Index: trunk/src/qft/qft.nw
===================================================================
--- trunk/src/qft/qft.nw	(revision 8732)
+++ trunk/src/qft/qft.nw	(revision 8733)
@@ -1,15654 +1,15751 @@
 %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: Quantum Field Theory concepts
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Quantum Field Theory Concepts}
 \includemodulegraph{qft}
 
 The objects and methods defined here implement concepts and data for
 the underlying quantum field theory that we use for computing matrix
 elements and processes.
 \begin{description}
 \item[model\_data]
   Fields and coupling parameters, operators as vertex structures, for
   a specific model.
 \item[model\_testbed]
   Provide hooks to deal with a [[model_data]] extension without
   referencing it explicitly.
 \item[helicities]
   Types and methods for spin density matrices.
 \item[colors]
   Dealing with colored particles, using the color-flow representation.
 \item[flavors]
   PDG codes and particle properties, depends on the model.
 \item[quantum\_numbers]
   Quantum numbers and density matrices for entangled particle systems.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Model Data}
 
 These data represent a specific Lagrangian in numeric terms.  That is,
 we have the fields with their quantum numbers, the masses, widths and
 couplings as numerical values, and the vertices as arrays of fields.
 
 We do not store the relations between coupling parameters.  They
 should be represented by expressions for evaluation, implemented as
 Sindarin objects in a distinct data structure.  Neither do we need the
 algebraic structure of vertices.  The field content of vertices is
 required for the sole purpose of setting up phase space.
 <<[[model_data.f90]]>>=
 <<File header>>
 
 module model_data
 
   use, intrinsic :: iso_c_binding !NODEP!
 
 <<Use kinds>>
   use kinds, only: i8, i32
   use kinds, only: c_default_float
 <<Use strings>>
   use format_defs, only: FMT_19
   use io_units
   use diagnostics
   use md5
   use hashes, only: hash
   use physics_defs, only: UNDEFINED, SCALAR
 
 <<Standard module head>>
 
 <<Model data: public>>
 
 <<Model data: parameters>>
 
 <<Model data: types>>
 
 contains
 
 <<Model data: procedures>>
 
 end module model_data
 @ %def model_data
 @
 \subsection{Physics Parameters}
 Couplings, masses, and widths are physics parameters.  Each parameter
 has a unique name (used, essentially, for diagnostics output and
 debugging) and a value.  The value may be a real or a complex number,
 so we provide to implementations of an abstract type.
 <<Model data: public>>=
   public :: modelpar_data_t
 <<Model data: types>>=
   type, abstract :: modelpar_data_t
      private
      type(string_t) :: name
    contains
    <<Model data: par data: TBP>>
   end type modelpar_data_t
 
   type, extends (modelpar_data_t) :: modelpar_real_t
      private
      real(default) :: value
   end type modelpar_real_t
 
   type, extends (modelpar_data_t) :: modelpar_complex_t
      private
      complex(default) :: value
   end type modelpar_complex_t
 
 @ %def modelpar_data_t modelpar_real_t modelpar_complex_t
 @
 Output for diagnostics.  Non-advancing.
 <<Model data: par data: TBP>>=
   procedure :: write => par_write
 <<Model data: procedures>>=
   subroutine par_write (par, unit)
     class(modelpar_data_t), intent(in) :: par
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A,1x,A)", advance="no")  char (par%name), "= "
     select type (par)
     type is (modelpar_real_t)
        write (u, "(" // FMT_19 // ")", advance="no")  par%value
     type is (modelpar_complex_t)
        write (u, "(" // FMT_19 // ",1x,'+',1x," // FMT_19 // ",1x,'I')", &
             advance="no")  par%value
     end select
   end subroutine par_write
 
 @ %def par_write
 @
 Pretty-printed on separate line, with fixed line length
 <<Model data: par data: TBP>>=
   procedure :: show => par_show
 <<Model data: procedures>>=
   subroutine par_show (par, l, u)
     class(modelpar_data_t), intent(in) :: par
     integer, intent(in) :: l, u
     character(len=l) :: buffer
     buffer = par%name
     select type (par)
     type is (modelpar_real_t)
        write (u, "(4x,A,1x,'=',1x," // FMT_19 // ")")  buffer, par%value
     type is (modelpar_complex_t)
        write (u, "(4x,A,1x,'=',1x," // FMT_19 // ",1x,'+',1x," &
             // FMT_19 // ",1x,'I')")  buffer, par%value
     end select
   end subroutine par_show
 
 @ %def par_show
 @
 Initialize with name and value.  The type depends on the argument
 type.  If the type does not match, the value is converted following
 Fortran rules.
 <<Model data: par data: TBP>>=
   generic :: init => modelpar_data_init_real, modelpar_data_init_complex
   procedure, private :: modelpar_data_init_real
   procedure, private :: modelpar_data_init_complex
 <<Model data: procedures>>=
   subroutine modelpar_data_init_real (par, name, value)
     class(modelpar_data_t), intent(out) :: par
     type(string_t), intent(in) :: name
     real(default), intent(in) :: value
     par%name = name
     par = value
   end subroutine modelpar_data_init_real
 
   subroutine modelpar_data_init_complex (par, name, value)
     class(modelpar_data_t), intent(out) :: par
     type(string_t), intent(in) :: name
     complex(default), intent(in) :: value
     par%name = name
     par = value
   end subroutine modelpar_data_init_complex
 
 @ %def modelpar_data_init_real modelpar_data_init_complex
 @
 Modify the value.  We assume that the parameter has been
 initialized.  The type (real or complex) must not be changed, and the
 name is also fixed.
 <<Model data: par data: TBP>>=
   generic :: assignment(=) => modelpar_data_set_real, modelpar_data_set_complex
   procedure, private :: modelpar_data_set_real
   procedure, private :: modelpar_data_set_complex
 <<Model data: procedures>>=
   elemental subroutine modelpar_data_set_real (par, value)
     class(modelpar_data_t), intent(inout) :: par
     real(default), intent(in) :: value
     select type (par)
     type is (modelpar_real_t)
        par%value = value
     type is (modelpar_complex_t)
        par%value = value
     end select
   end subroutine modelpar_data_set_real
 
   elemental subroutine modelpar_data_set_complex (par, value)
     class(modelpar_data_t), intent(inout) :: par
     complex(default), intent(in) :: value
     select type (par)
     type is (modelpar_real_t)
        par%value = value
     type is (modelpar_complex_t)
        par%value = value
     end select
   end subroutine modelpar_data_set_complex
 
 @ %def modelpar_data_set_real modelpar_data_set_complex
 @
 Return the parameter name.
 <<Model data: par data: TBP>>=
   procedure :: get_name => modelpar_data_get_name
 <<Model data: procedures>>=
   function modelpar_data_get_name (par) result (name)
     class(modelpar_data_t), intent(in) :: par
     type(string_t) :: name
     name = par%name
   end function modelpar_data_get_name
 
 @ %def modelpar_data_get_name
 @
 Return the value.  In case of a type mismatch, follow Fortran conventions.
 <<Model data: par data: TBP>>=
   procedure, pass :: get_real => modelpar_data_get_real
   procedure, pass :: get_complex => modelpar_data_get_complex
 <<Model data: procedures>>=
   elemental function modelpar_data_get_real (par) result (value)
     class(modelpar_data_t), intent(in), target :: par
     real(default) :: value
     select type (par)
     type is (modelpar_real_t)
        value = par%value
     type is (modelpar_complex_t)
        value = par%value
     end select
   end function modelpar_data_get_real
 
   elemental function modelpar_data_get_complex (par) result (value)
     class(modelpar_data_t), intent(in), target :: par
     complex(default) :: value
     select type (par)
     type is (modelpar_real_t)
        value = par%value
     type is (modelpar_complex_t)
        value = par%value
     end select
   end function modelpar_data_get_complex
 
 @ %def modelpar_data_get_real
 @ %def modelpar_data_get_complex
 @
 Return a pointer to the value.  This makes sense only for matching types.
 <<Model data: par data: TBP>>=
   procedure :: get_real_ptr => modelpar_data_get_real_ptr
   procedure :: get_complex_ptr => modelpar_data_get_complex_ptr
 <<Model data: procedures>>=
   function modelpar_data_get_real_ptr (par) result (ptr)
     class(modelpar_data_t), intent(in), target :: par
     real(default), pointer :: ptr
     select type (par)
     type is (modelpar_real_t)
        ptr => par%value
     class default
        ptr => null ()
     end select
   end function modelpar_data_get_real_ptr
 
   function modelpar_data_get_complex_ptr (par) result (ptr)
     class(modelpar_data_t), intent(in), target :: par
     complex(default), pointer :: ptr
     select type (par)
     type is (modelpar_complex_t)
        ptr => par%value
     class default
        ptr => null ()
     end select
   end function modelpar_data_get_complex_ptr
 
 @ %def modelpar_data_get_real_ptr
 @ %def modelpar_data_get_complex_ptr
 @
 \subsection{Field Data}
 The field-data type holds all information that pertains to a particular field
 (or particle) within a particular model.  Information such as spin type,
 particle code etc.\ is stored within the object itself, while mass and width
 are associated to parameters, otherwise assumed zero.
 <<Model data: public>>=
   public :: field_data_t
 <<Model data: types>>=
   type :: field_data_t
      private
      type(string_t) :: longname
      integer :: pdg = UNDEFINED
      logical :: visible = .true.
      logical :: parton = .false.
      logical :: gauge = .false.
      logical :: left_handed = .false.
      logical :: right_handed = .false.
      logical :: has_anti = .false.
      logical :: p_is_stable = .true.
      logical :: p_decays_isotropically = .false.
      logical :: p_decays_diagonal = .false.
      logical :: p_has_decay_helicity = .false.
      integer :: p_decay_helicity = 0
      logical :: a_is_stable = .true.
      logical :: a_decays_isotropically = .false.
      logical :: a_decays_diagonal = .false.
      logical :: a_has_decay_helicity = .false.
      integer :: a_decay_helicity = 0
      logical :: p_polarized = .false.
      logical :: a_polarized = .false.
      type(string_t), dimension(:), allocatable :: name, anti
      type(string_t) :: tex_name, tex_anti
      integer :: spin_type = UNDEFINED
      integer :: isospin_type = 1
      integer :: charge_type = 1
      integer :: color_type = 1
      real(default), pointer :: mass_val => null ()
      class(modelpar_data_t), pointer :: mass_data => null ()
      real(default), pointer :: width_val => null ()
      class(modelpar_data_t), pointer :: width_data => null ()
      integer :: multiplicity = 1
      type(string_t), dimension(:), allocatable :: p_decay
      type(string_t), dimension(:), allocatable :: a_decay
    contains
    <<Model data: field data: TBP>>
   end type field_data_t
 
 @ %def field_data_t
 @ Initialize field data with PDG long name and PDG code.  \TeX\
 names should be initialized to avoid issues with accessing
 unallocated string contents.
 <<Model data: field data: TBP>>=
   procedure :: init => field_data_init
 <<Model data: procedures>>=
   subroutine field_data_init (prt, longname, pdg)
     class(field_data_t), intent(out) :: prt
     type(string_t), intent(in) :: longname
     integer, intent(in) :: pdg
     prt%longname = longname
     prt%pdg = pdg
     prt%tex_name = ""
     prt%tex_anti = ""
   end subroutine field_data_init
 
 @ %def field_data_init
 @ Copy quantum numbers from another particle.  Do not compute the multiplicity
 yet, because this depends on the association of the [[mass_data]] pointer.
 <<Model data: field data: TBP>>=
   procedure :: copy_from => field_data_copy_from
 <<Model data: procedures>>=
   subroutine field_data_copy_from (prt, prt_src)
     class(field_data_t), intent(inout) :: prt
     class(field_data_t), intent(in) :: prt_src
     prt%visible = prt_src%visible
     prt%parton = prt_src%parton
     prt%gauge = prt_src%gauge
     prt%left_handed = prt_src%left_handed
     prt%right_handed = prt_src%right_handed
     prt%p_is_stable =             prt_src%p_is_stable
     prt%p_decays_isotropically =  prt_src%p_decays_isotropically
     prt%p_decays_diagonal =       prt_src%p_decays_diagonal
     prt%p_has_decay_helicity =    prt_src%p_has_decay_helicity
     prt%p_decay_helicity =        prt_src%p_decay_helicity
     prt%p_decays_diagonal =       prt_src%p_decays_diagonal
     prt%a_is_stable =             prt_src%a_is_stable
     prt%a_decays_isotropically =  prt_src%a_decays_isotropically
     prt%a_decays_diagonal =       prt_src%a_decays_diagonal
     prt%a_has_decay_helicity =    prt_src%a_has_decay_helicity
     prt%a_decay_helicity =        prt_src%a_decay_helicity
     prt%p_polarized =             prt_src%p_polarized
     prt%a_polarized =             prt_src%a_polarized
     prt%spin_type = prt_src%spin_type
     prt%isospin_type = prt_src%isospin_type
     prt%charge_type = prt_src%charge_type
     prt%color_type = prt_src%color_type
     prt%has_anti = prt_src%has_anti
     if (allocated (prt_src%name)) then
        if (allocated (prt%name))  deallocate (prt%name)
        allocate (prt%name (size (prt_src%name)), source = prt_src%name)
     end if
     if (allocated (prt_src%anti)) then
        if (allocated (prt%anti))  deallocate (prt%anti)
        allocate (prt%anti (size (prt_src%anti)), source = prt_src%anti)
     end if
     prt%tex_name = prt_src%tex_name
     prt%tex_anti = prt_src%tex_anti
     if (allocated (prt_src%p_decay)) then
        if (allocated (prt%p_decay))  deallocate (prt%p_decay)
        allocate (prt%p_decay (size (prt_src%p_decay)), source = prt_src%p_decay)
     end if
     if (allocated (prt_src%a_decay)) then
        if (allocated (prt%a_decay))  deallocate (prt%a_decay)
        allocate (prt%a_decay (size (prt_src%a_decay)), source = prt_src%a_decay)
     end if
   end subroutine field_data_copy_from
 
 @ %def field_data_copy_from
 @ Set particle quantum numbers.
 <<Model data: field data: TBP>>=
   procedure :: set => field_data_set
 <<Model data: procedures>>=
   subroutine field_data_set (prt, &
        is_visible, is_parton, is_gauge, is_left_handed, is_right_handed, &
        p_is_stable, p_decays_isotropically, p_decays_diagonal, &
        p_decay_helicity, &
        a_is_stable, a_decays_isotropically, a_decays_diagonal, &
        a_decay_helicity, &
        p_polarized, a_polarized, &
        name, anti, tex_name, tex_anti, &
        spin_type, isospin_type, charge_type, color_type, &
        mass_data, width_data, &
        p_decay, a_decay)
     class(field_data_t), intent(inout) :: prt
     logical, intent(in), optional :: is_visible, is_parton, is_gauge
     logical, intent(in), optional :: is_left_handed, is_right_handed
     logical, intent(in), optional :: p_is_stable
     logical, intent(in), optional :: p_decays_isotropically, p_decays_diagonal
     integer, intent(in), optional :: p_decay_helicity
     logical, intent(in), optional :: a_is_stable
     logical, intent(in), optional :: a_decays_isotropically, a_decays_diagonal
     integer, intent(in), optional :: a_decay_helicity
     logical, intent(in), optional :: p_polarized, a_polarized
     type(string_t), dimension(:), intent(in), optional :: name, anti
     type(string_t), intent(in), optional :: tex_name, tex_anti
     integer, intent(in), optional :: spin_type, isospin_type
     integer, intent(in), optional :: charge_type, color_type
     class(modelpar_data_t), intent(in), pointer, optional :: mass_data, width_data
     type(string_t), dimension(:), intent(in), optional :: p_decay, a_decay
     if (present (is_visible))  prt%visible = is_visible
     if (present (is_parton))  prt%parton = is_parton
     if (present (is_gauge))  prt%gauge = is_gauge
     if (present (is_left_handed))  prt%left_handed = is_left_handed
     if (present (is_right_handed))  prt%right_handed = is_right_handed
     if (present (p_is_stable))  prt%p_is_stable = p_is_stable
     if (present (p_decays_isotropically)) &
           prt%p_decays_isotropically = p_decays_isotropically
     if (present (p_decays_diagonal)) &
           prt%p_decays_diagonal = p_decays_diagonal
     if (present (p_decay_helicity)) then
        prt%p_has_decay_helicity = .true.
        prt%p_decay_helicity = p_decay_helicity
     end if
     if (present (a_is_stable))  prt%a_is_stable = a_is_stable
     if (present (a_decays_isotropically)) &
           prt%a_decays_isotropically = a_decays_isotropically
     if (present (a_decays_diagonal)) &
           prt%a_decays_diagonal = a_decays_diagonal
     if (present (a_decay_helicity)) then
        prt%a_has_decay_helicity = .true.
        prt%a_decay_helicity = a_decay_helicity
     end if
     if (present (p_polarized)) prt%p_polarized = p_polarized
     if (present (a_polarized)) prt%a_polarized = a_polarized
     if (present (name)) then
        if (allocated (prt%name))  deallocate (prt%name)
        allocate (prt%name (size (name)), source = name)
     end if
     if (present (anti)) then
        if (allocated (prt%anti))  deallocate (prt%anti)
        allocate (prt%anti (size (anti)), source = anti)
        prt%has_anti = .true.
     end if
     if (present (tex_name))  prt%tex_name = tex_name
     if (present (tex_anti))  prt%tex_anti = tex_anti
     if (present (spin_type))  prt%spin_type = spin_type
     if (present (isospin_type))  prt%isospin_type = isospin_type
     if (present (charge_type))  prt%charge_type = charge_type
     if (present (color_type))  prt%color_type = color_type
     if (present (mass_data)) then
        prt%mass_data => mass_data
        if (associated (mass_data)) then
           prt%mass_val => mass_data%get_real_ptr ()
        else
           prt%mass_val => null ()
        end if
     end if
     if (present (width_data)) then
        prt%width_data => width_data
        if (associated (width_data)) then
           prt%width_val => width_data%get_real_ptr ()
        else
           prt%width_val => null ()
        end if
     end if
     if (present (spin_type) .or. present (mass_data)) then
        call prt%set_multiplicity ()
     end if
     if (present (p_decay)) then
        if (allocated (prt%p_decay))  deallocate (prt%p_decay)
        if (size (p_decay) > 0) &
             allocate (prt%p_decay (size (p_decay)), source = p_decay)
     end if
     if (present (a_decay)) then
        if (allocated (prt%a_decay))  deallocate (prt%a_decay)
        if (size (a_decay) > 0) &
             allocate (prt%a_decay (size (a_decay)), source = a_decay)
     end if
   end subroutine field_data_set
 
 @ %def field_data_set
 @ Calculate the multiplicity given spin type and mass.
 <<Model data: field data: TBP>>=
   procedure, private :: &
        set_multiplicity => field_data_set_multiplicity
 <<Model data: procedures>>=
   subroutine field_data_set_multiplicity (prt)
     class(field_data_t), intent(inout) :: prt
     if (prt%spin_type /= SCALAR) then
        if (associated (prt%mass_data)) then
           prt%multiplicity = prt%spin_type
        else if (prt%left_handed .or. prt%right_handed) then
           prt%multiplicity = 1
        else
           prt%multiplicity = 2
        end if
     end if
   end subroutine field_data_set_multiplicity
 
 @ %def field_data_set_multiplicity
 @ Set the mass/width value (not the pointer).  The mass/width pointer
 must be allocated.
 <<Model data: field data: TBP>>=
   procedure, private :: set_mass => field_data_set_mass
   procedure, private :: set_width => field_data_set_width
 <<Model data: procedures>>=
   subroutine field_data_set_mass (prt, mass)
     class(field_data_t), intent(inout) :: prt
     real(default), intent(in) :: mass
     if (associated (prt%mass_val))  prt%mass_val = mass
   end subroutine field_data_set_mass
 
   subroutine field_data_set_width (prt, width)
     class(field_data_t), intent(inout) :: prt
     real(default), intent(in) :: width
     if (associated (prt%width_val))  prt%width_val = width
   end subroutine field_data_set_width
 
 @ %def field_data_set_mass field_data_set_width
 @ Loose ends: name arrays should be allocated.
 <<Model data: field data: TBP>>=
   procedure :: freeze => field_data_freeze
 <<Model data: procedures>>=
   elemental subroutine field_data_freeze (prt)
     class(field_data_t), intent(inout) :: prt
     if (.not. allocated (prt%name))  allocate (prt%name (0))
     if (.not. allocated (prt%anti))  allocate (prt%anti (0))
   end subroutine field_data_freeze
 
 @ %def field_data_freeze
 @ Output
 <<Model data: field data: TBP>>=
   procedure :: write => field_data_write
 <<Model data: procedures>>=
   subroutine field_data_write (prt, unit)
     class(field_data_t), intent(in) :: prt
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(3x,A,1x,A)", advance="no") "particle", char (prt%longname)
     write (u, "(1x,I0)", advance="no") prt%pdg
     if (.not. prt%visible) write (u, "(2x,A)", advance="no") "invisible"
     if (prt%parton)  write (u, "(2x,A)", advance="no") "parton"
     if (prt%gauge)  write (u, "(2x,A)", advance="no") "gauge"
     if (prt%left_handed)  write (u, "(2x,A)", advance="no") "left"
     if (prt%right_handed)  write (u, "(2x,A)", advance="no") "right"
     write (u, *)
     write (u, "(5x,A)", advance="no") "name"
     if (allocated (prt%name)) then
        do i = 1, size (prt%name)
           write (u, "(1x,A)", advance="no")  '"' // char (prt%name(i)) // '"'
        end do
        write (u, *)
        if (prt%has_anti) then
           write (u, "(5x,A)", advance="no") "anti"
           do i = 1, size (prt%anti)
              write (u, "(1x,A)", advance="no")  '"' // char (prt%anti(i)) // '"'
           end do
           write (u, *)
        end if
        if (prt%tex_name /= "") then
           write (u, "(5x,A)")  &
                "tex_name " // '"' // char (prt%tex_name) // '"'
        end if
        if (prt%has_anti .and. prt%tex_anti /= "") then
           write (u, "(5x,A)")  &
                "tex_anti " // '"' // char (prt%tex_anti) // '"'
        end if
     else
        write (u, "(A)")  "???"
     end if
     write (u, "(5x,A)", advance="no") "spin "
     select case (mod (prt%spin_type - 1, 2))
     case (0);  write (u, "(I0)", advance="no") (prt%spin_type-1) / 2
     case default;  write (u, "(I0,A)", advance="no") prt%spin_type-1, "/2"
     end select
     ! write (u, "(2x,A,I1,A)") "! [multiplicity = ", prt%multiplicity, "]"
     if (abs (prt%isospin_type) /= 1) then
        write (u, "(2x,A)", advance="no") "isospin "
        select case (mod (abs (prt%isospin_type) - 1, 2))
        case (0);  write (u, "(I0)", advance="no") &
             sign (abs (prt%isospin_type) - 1, prt%isospin_type) / 2
        case default;  write (u, "(I0,A)", advance="no") &
             sign (abs (prt%isospin_type) - 1, prt%isospin_type), "/2"
        end select
     end if
     if (abs (prt%charge_type) /= 1) then
        write (u, "(2x,A)", advance="no") "charge "
        select case (mod (abs (prt%charge_type) - 1, 3))
        case (0);  write (u, "(I0)", advance="no") &
             sign (abs (prt%charge_type) - 1, prt%charge_type) / 3
        case default;  write (u, "(I0,A)", advance="no") &
             sign (abs (prt%charge_type) - 1, prt%charge_type), "/3"
        end select
     end if
     if (prt%color_type /= 1) then
        write (u, "(2x,A,I0)", advance="no") "color ", prt%color_type
     end if
     write (u, *)
     if (associated (prt%mass_data)) then
        write (u, "(5x,A)", advance="no") &
             "mass " // char (prt%mass_data%get_name ())
        if (associated (prt%width_data)) then
           write (u, "(2x,A)") &
                "width " // char (prt%width_data%get_name ())
        else
           write (u, *)
        end if
     end if
     call prt%write_decays (u)
   end subroutine field_data_write
 
 @ %def field_data_write
 @ Write decay and polarization data.
 <<Model data: field data: TBP>>=
   procedure :: write_decays => field_data_write_decays
 <<Model data: procedures>>=
   subroutine field_data_write_decays (prt, unit)
     class(field_data_t), intent(in) :: prt
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     if (.not. prt%p_is_stable) then
        if (allocated (prt%p_decay)) then
           write (u, "(5x,A)", advance="no") "p_decay"
           do i = 1, size (prt%p_decay)
              write (u, "(1x,A)", advance="no")  char (prt%p_decay(i))
           end do
           if (prt%p_decays_isotropically) then
              write (u, "(1x,A)", advance="no")  "isotropic"
           else if (prt%p_decays_diagonal) then
              write (u, "(1x,A)", advance="no")  "diagonal"
           else if (prt%p_has_decay_helicity) then
              write (u, "(1x,A,I0)", advance="no")  "helicity = ", &
                   prt%p_decay_helicity
           end if
           write (u, *)
        end if
     else if (prt%p_polarized) then
        write (u, "(5x,A)")  "p_polarized"
     end if
     if (.not. prt%a_is_stable) then
        if (allocated (prt%a_decay)) then
           write (u, "(5x,A)", advance="no") "a_decay"
           do i = 1, size (prt%a_decay)
              write (u, "(1x,A)", advance="no")  char (prt%a_decay(i))
           end do
           if (prt%a_decays_isotropically) then
              write (u, "(1x,A)", advance="no")  "isotropic"
           else if (prt%a_decays_diagonal) then
              write (u, "(1x,A)", advance="no")  "diagonal"
           else if (prt%a_has_decay_helicity) then
              write (u, "(1x,A,I0)", advance="no")  "helicity = ", &
                   prt%a_decay_helicity
           end if
           write (u, *)
        end if
     else if (prt%a_polarized) then
        write (u, "(5x,A)")  "a_polarized"
     end if
   end subroutine field_data_write_decays
 
 @ %def field_data_write_decays
 @ Screen version of output.
 <<Model data: field data: TBP>>=
   procedure :: show => field_data_show
 <<Model data: procedures>>=
   subroutine field_data_show (prt, l, u)
     class(field_data_t), intent(in) :: prt
     integer, intent(in) :: l, u
     character(len=l) :: buffer
     integer :: i
     type(string_t), dimension(:), allocatable :: decay
     buffer = prt%get_name (.false.)
     write (u, "(4x,A,1x,I8)", advance="no")  buffer, &
          prt%get_pdg ()
     if (prt%is_polarized ()) then
        write (u, "(3x,A)")  "polarized"
     else if (.not. prt%is_stable ()) then
        write (u, "(3x,A)", advance="no")  "decays:"
        call prt%get_decays (decay)
        do i = 1, size (decay)
           write (u, "(1x,A)", advance="no")  char (decay(i))
        end do
        write (u, *)
     else
        write (u, *)
     end if
     if (prt%has_antiparticle ()) then
        buffer = prt%get_name (.true.)
        write (u, "(4x,A,1x,I8)", advance="no")  buffer, &
             prt%get_pdg_anti ()
        if (prt%is_polarized (.true.)) then
           write (u, "(3x,A)")  "polarized"
        else if (.not. prt%is_stable (.true.)) then
           write (u, "(3x,A)", advance="no")  "decays:"
           call prt%get_decays (decay, .true.)
           do i = 1, size (decay)
              write (u, "(1x,A)", advance="no")  char (decay(i))
           end do
           write (u, *)
        else
           write (u, *)
        end if
     end if
   end subroutine field_data_show
 
 @ %def field_data_show
 @ Retrieve data:
 <<Model data: field data: TBP>>=
   procedure :: get_pdg => field_data_get_pdg
   procedure :: get_pdg_anti => field_data_get_pdg_anti
 <<Model data: procedures>>=
   elemental function field_data_get_pdg (prt) result (pdg)
     integer :: pdg
     class(field_data_t), intent(in) :: prt
     pdg = prt%pdg
   end function field_data_get_pdg
 
   elemental function field_data_get_pdg_anti (prt) result (pdg)
     integer :: pdg
     class(field_data_t), intent(in) :: prt
     if (prt%has_anti) then
        pdg = - prt%pdg
     else
        pdg = prt%pdg
     end if
   end function field_data_get_pdg_anti
 
 @ %def field_data_get_pdg field_data_get_pdg_anti
 @ Predicates:
 <<Model data: field data: TBP>>=
   procedure :: is_visible => field_data_is_visible
   procedure :: is_parton => field_data_is_parton
   procedure :: is_gauge => field_data_is_gauge
   procedure :: is_left_handed => field_data_is_left_handed
   procedure :: is_right_handed => field_data_is_right_handed
   procedure :: has_antiparticle => field_data_has_antiparticle
   procedure :: is_stable => field_data_is_stable
   procedure :: get_decays => field_data_get_decays
   procedure :: decays_isotropically => field_data_decays_isotropically
   procedure :: decays_diagonal => field_data_decays_diagonal
   procedure :: has_decay_helicity => field_data_has_decay_helicity
   procedure :: decay_helicity => field_data_decay_helicity
   procedure :: is_polarized => field_data_is_polarized
 <<Model data: procedures>>=
   elemental function field_data_is_visible (prt) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     flag = prt%visible
   end function field_data_is_visible
 
   elemental function field_data_is_parton (prt) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     flag = prt%parton
   end function field_data_is_parton
 
   elemental function field_data_is_gauge (prt) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     flag = prt%gauge
   end function field_data_is_gauge
 
   elemental function field_data_is_left_handed (prt) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     flag = prt%left_handed
   end function field_data_is_left_handed
 
   elemental function field_data_is_right_handed (prt) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     flag = prt%right_handed
   end function field_data_is_right_handed
 
   elemental function field_data_has_antiparticle (prt) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     flag = prt%has_anti
   end function field_data_has_antiparticle
 
   elemental function field_data_is_stable (prt, anti) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     logical, intent(in), optional :: anti
     if (present (anti)) then
        if (anti) then
           flag = prt%a_is_stable
        else
           flag = prt%p_is_stable
        end if
     else
        flag = prt%p_is_stable
     end if
   end function field_data_is_stable
 
   subroutine field_data_get_decays (prt, decay, anti)
     class(field_data_t), intent(in) :: prt
     type(string_t), dimension(:), intent(out), allocatable :: decay
     logical, intent(in), optional :: anti
     if (present (anti)) then
        if (anti) then
           allocate (decay (size (prt%a_decay)), source = prt%a_decay)
        else
           allocate (decay (size (prt%p_decay)), source = prt%p_decay)
        end if
     else
        allocate (decay (size (prt%p_decay)), source = prt%p_decay)
     end if
   end subroutine field_data_get_decays
 
   elemental function field_data_decays_isotropically &
        (prt, anti) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     logical, intent(in), optional :: anti
     if (present (anti)) then
        if (anti) then
           flag = prt%a_decays_isotropically
        else
           flag = prt%p_decays_isotropically
        end if
     else
        flag = prt%p_decays_isotropically
     end if
   end function field_data_decays_isotropically
 
   elemental function field_data_decays_diagonal &
        (prt, anti) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     logical, intent(in), optional :: anti
     if (present (anti)) then
        if (anti) then
           flag = prt%a_decays_diagonal
        else
           flag = prt%p_decays_diagonal
        end if
     else
        flag = prt%p_decays_diagonal
     end if
   end function field_data_decays_diagonal
 
   elemental function field_data_has_decay_helicity &
        (prt, anti) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     logical, intent(in), optional :: anti
     if (present (anti)) then
        if (anti) then
           flag = prt%a_has_decay_helicity
        else
           flag = prt%p_has_decay_helicity
        end if
     else
        flag = prt%p_has_decay_helicity
     end if
   end function field_data_has_decay_helicity
 
   elemental function field_data_decay_helicity &
        (prt, anti) result (hel)
     integer :: hel
     class(field_data_t), intent(in) :: prt
     logical, intent(in), optional :: anti
     if (present (anti)) then
        if (anti) then
           hel = prt%a_decay_helicity
        else
           hel = prt%p_decay_helicity
        end if
     else
        hel = prt%p_decay_helicity
     end if
   end function field_data_decay_helicity
 
   elemental function field_data_is_polarized (prt, anti) result (flag)
     logical :: flag
     class(field_data_t), intent(in) :: prt
     logical, intent(in), optional :: anti
     logical :: a
     if (present (anti)) then
        a = anti
     else
        a = .false.
     end if
     if (a) then
        flag = prt%a_polarized
     else
        flag = prt%p_polarized
     end if
   end function field_data_is_polarized
 
 @ %def field_data_is_visible field_data_is_parton
 @ %def field_data_is_gauge
 @ %def field_data_is_left_handed field_data_is_right_handed
 @ %def field_data_has_antiparticle
 @ %def field_data_is_stable
 @ %def field_data_decays_isotropically
 @ %def field_data_decays_diagonal
 @ %def field_data_has_decay_helicity
 @ %def field_data_decay_helicity
 @ %def field_data_polarized
 @ Names.  Return the first name in the list (or the first antiparticle name)
 <<Model data: field data: TBP>>=
   procedure :: get_longname => field_data_get_longname
   procedure :: get_name => field_data_get_name
   procedure :: get_name_array => field_data_get_name_array
 <<Model data: procedures>>=
   pure function field_data_get_longname (prt) result (name)
     type(string_t) :: name
     class(field_data_t), intent(in) :: prt
     name = prt%longname
   end function field_data_get_longname
 
   pure function field_data_get_name (prt, is_antiparticle) result (name)
     type(string_t) :: name
     class(field_data_t), intent(in) :: prt
     logical, intent(in) :: is_antiparticle
     name = prt%longname
     if (is_antiparticle) then
        if (prt%has_anti) then
           if (allocated (prt%anti)) then
              if (size(prt%anti) > 0) name = prt%anti(1)
           end if
        else
           if (allocated (prt%name)) then
              if (size (prt%name) > 0) name = prt%name(1)
           end if
        end if
     else
        if (allocated (prt%name)) then
           if (size (prt%name) > 0) name = prt%name(1)
        end if
     end if
   end function field_data_get_name
 
   subroutine field_data_get_name_array (prt, is_antiparticle, name)
     class(field_data_t), intent(in) :: prt
     logical, intent(in) :: is_antiparticle
     type(string_t), dimension(:), allocatable, intent(inout) :: name
     if (allocated (name))  deallocate (name)
     if (is_antiparticle) then
        if (prt%has_anti) then
           allocate (name (size (prt%anti)))
           name = prt%anti
        else
           allocate (name (0))
        end if
     else
        allocate (name (size (prt%name)))
        name = prt%name
     end if
   end subroutine field_data_get_name_array
 
 @ %def field_data_get_name
 @ Same for the \TeX\ name.
 <<Model data: field data: TBP>>=
   procedure :: get_tex_name => field_data_get_tex_name
 <<Model data: procedures>>=
   elemental function field_data_get_tex_name &
        (prt, is_antiparticle) result (name)
     type(string_t) :: name
     class(field_data_t), intent(in) :: prt
     logical, intent(in) :: is_antiparticle
     if (is_antiparticle) then
        if (prt%has_anti) then
           name = prt%tex_anti
        else
           name = prt%tex_name
        end if
     else
        name = prt%tex_name
     end if
     if (name == "")  name = prt%get_name (is_antiparticle)
   end function field_data_get_tex_name
 
 @ %def field_data_get_tex_name
 @ Check if any of the field names matches the given string.
 <<Model data: field data: TBP>>=
   procedure, private :: matches_name => field_data_matches_name
 <<Model data: procedures>>=
   function field_data_matches_name (field, name, is_antiparticle) result (flag)
     class(field_data_t), intent(in) :: field
     type(string_t), intent(in) :: name
     logical, intent(in) :: is_antiparticle
     logical :: flag
     if (is_antiparticle) then
        if (field%has_anti) then
           flag = any (name == field%anti)
        else
           flag = .false.
        end if
     else
        flag = name == field%longname .or. any (name == field%name)
     end if
   end function field_data_matches_name
 
 @ %def field_data_matches_name
 @ Quantum numbers
 <<Model data: field data: TBP>>=
   procedure :: get_spin_type => field_data_get_spin_type
   procedure :: get_multiplicity => field_data_get_multiplicity
   procedure :: get_isospin_type => field_data_get_isospin_type
   procedure :: get_charge_type => field_data_get_charge_type
   procedure :: get_color_type => field_data_get_color_type
 <<Model data: procedures>>=
   elemental function field_data_get_spin_type (prt) result (type)
     integer :: type
     class(field_data_t), intent(in) :: prt
     type = prt%spin_type
   end function field_data_get_spin_type
 
   elemental function field_data_get_multiplicity (prt) result (type)
     integer :: type
     class(field_data_t), intent(in) :: prt
     type = prt%multiplicity
   end function field_data_get_multiplicity
 
   elemental function field_data_get_isospin_type (prt) result (type)
     integer :: type
     class(field_data_t), intent(in) :: prt
     type = prt%isospin_type
   end function field_data_get_isospin_type
 
   elemental function field_data_get_charge_type (prt) result (type)
     integer :: type
     class(field_data_t), intent(in) :: prt
     type = prt%charge_type
   end function field_data_get_charge_type
 
   elemental function field_data_get_color_type (prt) result (type)
     integer :: type
     class(field_data_t), intent(in) :: prt
     type = prt%color_type
   end function field_data_get_color_type
 
 @ %def field_data_get_spin_type
 @ %def field_data_get_multiplicity
 @ %def field_data_get_isospin_type
 @ %def field_data_get_charge_type
 @ %def field_data_get_color_type
 @ In the MSSM, neutralinos can have a negative mass.   This is
 relevant for computing matrix elements.  However, within the
 \whizard\ main program we are interested only in kinematics, therefore
 we return the absolute value of the particle mass.  If desired, we can
 extract the sign separately.
 <<Model data: field data: TBP>>=
   procedure :: get_charge => field_data_get_charge
   procedure :: get_isospin => field_data_get_isospin
   procedure :: get_mass => field_data_get_mass
   procedure :: get_mass_sign => field_data_get_mass_sign
   procedure :: get_width => field_data_get_width
 <<Model data: procedures>>=
   elemental function field_data_get_charge (prt) result (charge)
     real(default) :: charge
     class(field_data_t), intent(in) :: prt
     if (prt%charge_type /= 0) then
        charge = real (sign ((abs(prt%charge_type) - 1), &
              prt%charge_type), default) / 3
     else
        charge = 0
     end if
   end function field_data_get_charge
 
   elemental function field_data_get_isospin (prt) result (isospin)
     real(default) :: isospin
     class(field_data_t), intent(in) :: prt
     if (prt%isospin_type /= 0) then
        isospin = real (sign (abs(prt%isospin_type) - 1, &
             prt%isospin_type), default) / 2
     else
        isospin = 0
     end if
   end function field_data_get_isospin
 
   elemental function field_data_get_mass (prt) result (mass)
     real(default) :: mass
     class(field_data_t), intent(in) :: prt
     if (associated (prt%mass_val)) then
        mass = abs (prt%mass_val)
     else
        mass = 0
     end if
   end function field_data_get_mass
 
   elemental function field_data_get_mass_sign (prt) result (sgn)
     integer :: sgn
     class(field_data_t), intent(in) :: prt
     if (associated (prt%mass_val)) then
        sgn = sign (1._default, prt%mass_val)
     else
        sgn = 0
     end if
   end function field_data_get_mass_sign
 
   elemental function field_data_get_width (prt) result (width)
     real(default) :: width
     class(field_data_t), intent(in) :: prt
     if (associated (prt%width_val)) then
        width = prt%width_val
     else
        width = 0
     end if
   end function field_data_get_width
 
 @ %def field_data_get_charge field_data_get_isospin
 @ %def field_data_get_mass field_data_get_mass_sign
 @ %def field_data_get_width
 @ Find the [[model]] containing the [[PDG]] given two model files.
 <<Model data: public>>=
   public :: find_model
 <<Model data: procedures>>=
   subroutine find_model (model, PDG, model_A, model_B)
     class(model_data_t), pointer, intent(out) :: model
     integer, intent(in) :: PDG
     class(model_data_t), intent(in), target :: model_A, model_B
     character(len=10) :: buffer
     if (model_A%test_field (PDG)) then
        model => model_A
     else if (model_B%test_field (PDG)) then
        model => model_B
     else
        call model_A%write ()
        call model_B%write ()
        write (buffer, "(I10)") PDG
        call msg_fatal ("Parton " // buffer // &
             " not found in the given model files")
     end if
   end subroutine find_model
 
 @ %def find_model
 @
 \subsection{Vertex data}
 The vertex object contains an array of particle-data pointers, for
 which we need a separate type.  (We could use the flavor type defined
 in another module.)
 
 The program does not (yet?) make use of vertex definitions, so they
 are not stored here.
 <<Model data: types>>=
   type :: field_data_p
      type(field_data_t), pointer :: p => null ()
   end type field_data_p
 
 @ %def field_data_p
 <<Model data: types>>=
   type :: vertex_t
      private
      logical :: trilinear
      integer, dimension(:), allocatable :: pdg
      type(field_data_p), dimension(:), allocatable :: prt
    contains
    <<Model data: vertex: TBP>>
   end type vertex_t
 
 @ %def vertex_t
 <<Model data: vertex: TBP>>=
   procedure :: write => vertex_write
 <<Model data: procedures>>=
   subroutine vertex_write (vtx, unit)
     class(vertex_t), intent(in) :: vtx
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(3x,A)", advance="no")  "vertex"
     do i = 1, size (vtx%prt)
        if (associated (vtx%prt(i)%p)) then
           write (u, "(1x,A)", advance="no") &
                '"' // char (vtx%prt(i)%p%get_name (vtx%pdg(i) < 0)) &
                    // '"'
        else
           write (u, "(1x,I7)", advance="no") vtx%pdg(i)
        end if
     end do
     write (u, *)
   end subroutine vertex_write
 
 @ %def vertex_write
 @ Initialize using PDG codes.  The model is used for finding particle
 data pointers associated with the pdg codes.
 <<Model data: vertex: TBP>>=
   procedure :: init => vertex_init
 <<Model data: procedures>>=
   subroutine vertex_init (vtx, pdg, model)
     class(vertex_t), intent(out) :: vtx
     integer, dimension(:), intent(in) :: pdg
     type(model_data_t), intent(in), target, optional :: model
     integer :: i
     allocate (vtx%pdg (size (pdg)))
     allocate (vtx%prt (size (pdg)))
     vtx%trilinear = size (pdg) == 3
     vtx%pdg = pdg
     if (present (model)) then
        do i = 1, size (pdg)
           vtx%prt(i)%p => model%get_field_ptr (pdg(i))
        end do
     end if
   end subroutine vertex_init
 
 @ %def vertex_init
 @ Copy vertex: we must reassign the field-data pointer to a new model.
 <<Model data: vertex: TBP>>=
   procedure :: copy_from => vertex_copy_from
 <<Model data: procedures>>=
   subroutine vertex_copy_from (vtx, old_vtx, new_model)
     class(vertex_t), intent(out) :: vtx
     class(vertex_t), intent(in) :: old_vtx
     type(model_data_t), intent(in), target, optional :: new_model
     call vtx%init (old_vtx%pdg, new_model)
   end subroutine vertex_copy_from
 
 @ %def vertex_copy_from
 @ Single-particle lookup: Given a particle code, we return matching
 codes if present, otherwise zero.  Actually, we return the
 antiparticles of the matching codes, as appropriate for computing
 splittings.
 <<Model data: vertex: TBP>>=
   procedure :: get_match => vertex_get_match
 <<Model data: procedures>>=
   subroutine vertex_get_match (vtx, pdg1, pdg2)
     class(vertex_t), intent(in) :: vtx
     integer, intent(in) :: pdg1
     integer, dimension(:), allocatable, intent(out) :: pdg2
     integer :: i, j
     do i = 1, size (vtx%pdg)
        if (vtx%pdg(i) == pdg1) then
           allocate (pdg2 (size (vtx%pdg) - 1))
           do j = 1, i-1
              pdg2(j) = anti (j)
           end do
           do j = i, size (pdg2)
              pdg2(j) = anti (j+1)
           end do
           exit
        end if
     end do
   contains
     function anti (i) result (pdg)
       integer, intent(in) :: i
       integer :: pdg
       if (vtx%prt(i)%p%has_antiparticle ()) then
          pdg = - vtx%pdg(i)
       else
          pdg = vtx%pdg(i)
       end if
     end function anti
   end subroutine vertex_get_match
 
 @ %def vertex_get_match
 @ To access this from the outside, we create an iterator.  The iterator has
 the sole purpose of returning the matching particles for a given array of PDG
 codes.
 <<Model data: public>>=
   public :: vertex_iterator_t
 <<Model data: types>>=
   type :: vertex_iterator_t
      private
      class(model_data_t), pointer :: model => null ()
      integer, dimension(:), allocatable :: pdg
      integer :: vertex_index = 0
      integer :: pdg_index = 0
      logical :: save_pdg_index
    contains
      procedure :: init => vertex_iterator_init
      procedure :: get_next_match => vertex_iterator_get_next_match
   end type vertex_iterator_t
 
 @ %def vertex_iterator_t
 @ We initialize the iterator for a particular model with the [[pdg]] index of
 the particle we are looking at.
 <<Model data: procedures>>=
   subroutine vertex_iterator_init (it, model, pdg, save_pdg_index)
     class(vertex_iterator_t), intent(out) :: it
     class(model_data_t), intent(in), target :: model
     integer, dimension(:), intent(in) :: pdg
     logical, intent(in) :: save_pdg_index
     it%model => model
     allocate (it%pdg (size (pdg)), source = pdg)
     it%save_pdg_index = save_pdg_index
   end subroutine vertex_iterator_init
 
   subroutine vertex_iterator_get_next_match (it, pdg_match)
     class(vertex_iterator_t), intent(inout) :: it
     integer, dimension(:), allocatable, intent(out) :: pdg_match
     integer :: i, j
     do i = it%vertex_index + 1, size (it%model%vtx)
        do j = it%pdg_index + 1, size (it%pdg)
           call it%model%vtx(i)%get_match (it%pdg(j), pdg_match)
           if (it%save_pdg_index) then
              if (allocated (pdg_match) .and. j < size (it%pdg)) then
                 it%pdg_index = j
                 return
              else if (allocated (pdg_match) .and. j == size (it%pdg)) then
                 it%vertex_index = i
                 it%pdg_index = 0
                 return
              end if
           else if (allocated (pdg_match)) then
              it%vertex_index = i
              return
           end if
        end do
     end do
     it%vertex_index = 0
     it%pdg_index = 0
   end subroutine vertex_iterator_get_next_match
 
 @ %def vertex_iterator_get_next_match
 @
 \subsection{Vertex lookup table}
 The vertex lookup table is a hash table: given two particle codes, we
 check which codes are allowed for the third one.
 
 The size of the hash table should be large enough that collisions are
 rare.  We first select a size based on the number of vertices
 (multiplied by six because all permutations count), with some margin,
 and then choose the smallest integer power of two larger than this.
 <<Model data: parameters>>=
   integer, parameter :: VERTEX_TABLE_SCALE_FACTOR = 60
 @ %def VERTEX_TABLE_SCALE_FACTOR
 <<Model data: procedures>>=
   function vertex_table_size (n_vtx) result (n)
     integer(i32) :: n
     integer, intent(in) :: n_vtx
     integer :: i, s
     s = VERTEX_TABLE_SCALE_FACTOR * n_vtx
     n = 1
     do i = 1, 31
        n = ishft (n, 1)
        s = ishft (s,-1)
        if (s == 0)  exit
     end do
   end function vertex_table_size
 
 @ %def vertex_table_size
 @ The specific hash function takes two particle codes (arbitrary
 integers) and returns a 32-bit integer.  It makes use of the universal
 function [[hash]] which operates on a byte array.
 <<Model data: procedures>>=
   function hash2 (pdg1, pdg2)
     integer(i32) :: hash2
     integer, intent(in) :: pdg1, pdg2
     integer(i8), dimension(1) :: mold
     hash2 = hash (transfer ([pdg1, pdg2], mold))
   end function hash2
 
 @ %def hash2
 @ Each entry in the vertex table stores the two particle codes and an
 array of possibilities for the third code.
 <<Model data: types>>=
   type :: vertex_table_entry_t
      private
      integer :: pdg1 = 0, pdg2 = 0
      integer :: n = 0
      integer, dimension(:), allocatable :: pdg3
   end type vertex_table_entry_t
 
 @ %def vertex_table_entry_t
 @ The vertex table:
 <<Model data: types>>=
   type :: vertex_table_t
      type(vertex_table_entry_t), dimension(:), allocatable :: entry
      integer :: n_collisions = 0
      integer(i32) :: mask
    contains
    <<Model data: vertex table: TBP>>
   end type vertex_table_t
 
 @ %def vertex_table_t
 @ Output.
 <<Model data: vertex table: TBP>>=
   procedure :: write => vertex_table_write
 <<Model data: procedures>>=
   subroutine vertex_table_write (vt, unit)
     class(vertex_table_t), intent(in) :: vt
     integer, intent(in), optional :: unit
     integer :: u, i
     character(9) :: size_pdg3
     u = given_output_unit (unit)
     write (u, "(A)") "vertex hash table:"
     write (u, "(A,I7)") "  size = ", size (vt%entry)
     write (u, "(A,I7)") "  used = ", count (vt%entry%n /= 0)
     write (u, "(A,I7)") "  coll = ", vt%n_collisions
     do i = lbound (vt%entry, 1), ubound (vt%entry, 1)
        if (vt%entry(i)%n /= 0) then
           write (size_pdg3, "(I7)") size (vt%entry(i)%pdg3)
           write (u, "(A,1x,I7,1x,A,2(1x,I7),A," // &
                size_pdg3 // "(1x,I7))")  &
                "  ", i, ":", vt%entry(i)%pdg1, &
                vt%entry(i)%pdg2, "->", vt%entry(i)%pdg3
        end if
     end do
   end subroutine vertex_table_write
 
 @ %def vertex_table_write
 @ Initializing the vertex table: This is done in two passes.  First,
 we scan all permutations for all vertices and count the number of
 entries in each bucket of the hashtable.  Then, the buckets are
 allocated accordingly and filled.
 
 Collision resolution is done by just incrementing the hash value until
 an empty bucket is found.  The vertex table size is fixed, since we
 know from the beginning the number of entries.
 <<Model data: vertex table: TBP>>=
   procedure :: init => vertex_table_init
 <<Model data: procedures>>=
   subroutine vertex_table_init (vt, prt, vtx)
     class(vertex_table_t), intent(out) :: vt
     type(field_data_t), dimension(:), intent(in) :: prt
     type(vertex_t), dimension(:), intent(in) :: vtx
     integer :: n_vtx, vt_size, i, p1, p2, p3
     integer, dimension(3) :: p
     n_vtx = size (vtx)
     vt_size = vertex_table_size (count (vtx%trilinear))
     vt%mask = vt_size - 1
     allocate (vt%entry (0:vt_size-1))
     do i = 1, n_vtx
        if (vtx(i)%trilinear) then
           p = vtx(i)%pdg
           p1 = p(1);  p2 = p(2)
           call create (hash2 (p1, p2))
           if (p(2) /= p(3)) then
              p2 = p(3)
              call create (hash2 (p1, p2))
           end if
           if (p(1) /= p(2)) then
              p1 = p(2);  p2 = p(1)
              call create (hash2 (p1, p2))
              if (p(1) /= p(3)) then
                 p2 = p(3)
                 call create (hash2 (p1, p2))
              end if
           end if
           if (p(1) /= p(3)) then
              p1 = p(3);  p2 = p(1)
              call create (hash2 (p1, p2))
              if (p(1) /= p(2)) then
                 p2 = p(2)
                 call create (hash2 (p1, p2))
              end if
           end if
        end if
     end do
     do i = 0, vt_size - 1
        allocate (vt%entry(i)%pdg3 (vt%entry(i)%n))
     end do
     vt%entry%n = 0
     do i = 1, n_vtx
        if (vtx(i)%trilinear) then
           p = vtx(i)%pdg
           p1 = p(1);  p2 = p(2);  p3 = p(3)
           call register (hash2 (p1, p2))
           if (p(2) /= p(3)) then
              p2 = p(3);  p3 = p(2)
              call register (hash2 (p1, p2))
           end if
           if (p(1) /= p(2)) then
              p1 = p(2);  p2 = p(1);  p3 = p(3)
              call register (hash2 (p1, p2))
              if (p(1) /= p(3)) then
                 p2 = p(3);  p3 = p(1)
                 call register (hash2 (p1, p2))
              end if
           end if
           if (p(1) /= p(3)) then
              p1 = p(3);  p2 = p(1);  p3 = p(2)
              call register (hash2 (p1, p2))
              if (p(1) /= p(2)) then
                 p2 = p(2);  p3 = p(1)
                 call register (hash2 (p1, p2))
              end if
           end if
        end if
     end do
   contains
     recursive subroutine create (hashval)
       integer(i32), intent(in) :: hashval
       integer :: h
       h = iand (hashval, vt%mask)
       if (vt%entry(h)%n == 0) then
          vt%entry(h)%pdg1 = p1
          vt%entry(h)%pdg2 = p2
          vt%entry(h)%n = 1
       else if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then
          vt%entry(h)%n = vt%entry(h)%n + 1
       else
          vt%n_collisions = vt%n_collisions + 1
          call create (hashval + 1)
       end if
     end subroutine create
     recursive subroutine register (hashval)
       integer(i32), intent(in) :: hashval
       integer :: h
       h = iand (hashval, vt%mask)
       if (vt%entry(h)%pdg1 == p1 .and. vt%entry(h)%pdg2 == p2) then
          vt%entry(h)%n = vt%entry(h)%n + 1
          vt%entry(h)%pdg3(vt%entry(h)%n) = p3
       else
          call register (hashval + 1)
       end if
     end subroutine register
   end subroutine vertex_table_init
 
 @ %def vertex_table_init
 @ Return the array of particle codes that match the given pair.
 <<Model data: vertex table: TBP>>=
   procedure :: match => vertex_table_match
 <<Model data: procedures>>=
   subroutine vertex_table_match (vt, pdg1, pdg2, pdg3)
     class(vertex_table_t), intent(in) :: vt
     integer, intent(in) :: pdg1, pdg2
     integer, dimension(:), allocatable, intent(out) :: pdg3
     call match (hash2 (pdg1, pdg2))
   contains
     recursive subroutine match (hashval)
       integer(i32), intent(in) :: hashval
       integer :: h
       h = iand (hashval, vt%mask)
       if (vt%entry(h)%n == 0) then
          allocate (pdg3 (0))
       else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then
          allocate (pdg3 (size (vt%entry(h)%pdg3)))
          pdg3 = vt%entry(h)%pdg3
       else
          call match (hashval + 1)
       end if
     end subroutine match
   end subroutine vertex_table_match
 
 @ %def vertex_table_match
 @ Return true if the triplet is represented as a vertex.
 <<Model data: vertex table: TBP>>=
   procedure :: check => vertex_table_check
 <<Model data: procedures>>=
   function vertex_table_check (vt, pdg1, pdg2, pdg3) result (flag)
     class(vertex_table_t), intent(in) :: vt
     integer, intent(in) :: pdg1, pdg2, pdg3
     logical :: flag
     flag = check (hash2 (pdg1, pdg2))
   contains
     recursive function check (hashval) result (flag)
       integer(i32), intent(in) :: hashval
       integer :: h
       logical :: flag
       h = iand (hashval, vt%mask)
       if (vt%entry(h)%n == 0) then
          flag = .false.
       else if (vt%entry(h)%pdg1 == pdg1 .and. vt%entry(h)%pdg2 == pdg2) then
          flag = any (vt%entry(h)%pdg3 == pdg3)
       else
          flag = check (hashval + 1)
       end if
     end function check
   end function vertex_table_check
 
 @ %def vertex_table_check
 @
 \subsection{Model Data Record}
 This type collects the model data as defined above.
 
 We deliberately implement the parameter arrays as pointer arrays.  We
 thus avoid keeping track of TARGET attributes.
 
 The [[scheme]] identifier provides meta information.  It doesn't give the
 client code an extra parameter, but it tells something about the
 interpretation of the parameters.  If the scheme ID is left as default (zero),
 it is ignored.
 <<Model data: public>>=
   public :: model_data_t
 <<Model data: types>>=
   type :: model_data_t
      private
      type(string_t) :: name
      integer :: scheme = 0
      type(modelpar_real_t), dimension(:), pointer :: par_real => null ()
      type(modelpar_complex_t), dimension(:), pointer :: par_complex => null ()
      type(field_data_t), dimension(:), allocatable :: field
      type(vertex_t), dimension(:), allocatable :: vtx
      type(vertex_table_t) :: vt
    contains
    <<Model data: model data: TBP>>
   end type model_data_t
 
 @ %def model_data_t
 @ Finalizer, deallocate pointer arrays.
 <<Model data: model data: TBP>>=
   procedure :: final => model_data_final
 <<Model data: procedures>>=
   subroutine model_data_final (model)
     class(model_data_t), intent(inout) :: model
     if (associated (model%par_real)) then
        deallocate (model%par_real)
     end if
     if (associated (model%par_complex)) then
        deallocate (model%par_complex)
     end if
   end subroutine model_data_final
 
 @ %def model_data_final
 @ Output.  The signature matches the signature of the high-level
 [[model_write]] procedure, so some of the options don't actually apply.
 <<Model data: model data: TBP>>=
   procedure :: write => model_data_write
 <<Model data: procedures>>=
   subroutine model_data_write (model, unit, verbose, &
        show_md5sum, show_variables, show_parameters, &
        show_particles, show_vertices, show_scheme)
     class(model_data_t), intent(in) :: model
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     logical, intent(in), optional :: show_md5sum
     logical, intent(in), optional :: show_variables
     logical, intent(in), optional :: show_parameters
     logical, intent(in), optional :: show_particles
     logical, intent(in), optional :: show_vertices
     logical, intent(in), optional :: show_scheme
     logical :: show_sch, show_par, show_prt, show_vtx
     integer :: u, i
     u = given_output_unit (unit)
     show_sch = .false.;  if (present (show_scheme)) &
          show_sch = show_scheme
     show_par = .true.;  if (present (show_parameters)) &
          show_par = show_parameters
     show_prt = .true.;  if (present (show_particles)) &
          show_prt = show_particles
     show_vtx = .true.;  if (present (show_vertices)) &
          show_vtx = show_vertices
     if (show_sch) then
        write (u, "(3x,A,1X,I0)")  "scheme =", model%scheme
     end if
     if (show_par) then
        do i = 1, size (model%par_real)
           call model%par_real(i)%write (u)
           write (u, "(A)")
        end do
        do i = 1, size (model%par_complex)
           call model%par_complex(i)%write (u)
           write (u, "(A)")
        end do
     end if
     if (show_prt) then
        write (u, "(A)")
        call model%write_fields (u)
     end if
     if (show_vtx) then
        write (u, "(A)")
        call model%write_vertices (u, verbose)
     end if
   end subroutine model_data_write
 
 @ %def model_data_write
 @ Initialize, allocating pointer arrays.  The second version makes a
 deep copy.
 <<Model data: model data: TBP>>=
   generic :: init => model_data_init
   procedure, private :: model_data_init
 <<Model data: procedures>>=
   subroutine model_data_init (model, name, &
        n_par_real, n_par_complex, n_field, n_vtx)
     class(model_data_t), intent(out) :: model
     type(string_t), intent(in) :: name
     integer, intent(in) :: n_par_real, n_par_complex
     integer, intent(in) :: n_field
     integer, intent(in) :: n_vtx
     model%name = name
     allocate (model%par_real (n_par_real))
     allocate (model%par_complex (n_par_complex))
     allocate (model%field (n_field))
     allocate (model%vtx (n_vtx))
   end subroutine model_data_init
 
 @ %def model_data_init
 @ Set the scheme ID.
 <<Model data: model data: TBP>>=
   procedure :: set_scheme_num => model_data_set_scheme_num
 <<Model data: procedures>>=
   subroutine model_data_set_scheme_num (model, scheme)
     class(model_data_t), intent(inout) :: model
     integer, intent(in) :: scheme
     model%scheme = scheme
   end subroutine model_data_set_scheme_num
 
 @ %def model_data_set_scheme_num
 @ Complete model data initialization.
 <<Model data: model data: TBP>>=
   procedure :: freeze_fields => model_data_freeze_fields
 <<Model data: procedures>>=
   subroutine model_data_freeze_fields (model)
     class(model_data_t), intent(inout) :: model
     call model%field%freeze ()
   end subroutine model_data_freeze_fields
 
 @ %def model_data_freeze
 @ Deep copy.  The new model should already be initialized, so we do
 not allocate memory.
 <<Model data: model data: TBP>>=
   procedure :: copy_from => model_data_copy
 <<Model data: procedures>>=
   subroutine model_data_copy (model, src)
     class(model_data_t), intent(inout), target :: model
     class(model_data_t), intent(in), target :: src
     class(modelpar_data_t), pointer :: data, src_data
     integer :: i
     model%scheme = src%scheme
     model%par_real = src%par_real
     model%par_complex = src%par_complex
     do i = 1, size (src%field)
        associate (field => model%field(i), src_field => src%field(i))
          call field%init (src_field%get_longname (), src_field%get_pdg ())
          call field%copy_from (src_field)
          src_data => src_field%mass_data
          if (associated (src_data)) then
             data => model%get_par_data_ptr (src_data%get_name ())
             call field%set (mass_data = data)
          end if
          src_data => src_field%width_data
          if (associated (src_data)) then
             data => model%get_par_data_ptr (src_data%get_name ())
             call field%set (width_data = data)
          end if
          call field%set_multiplicity ()
        end associate
     end do
     do i = 1, size (src%vtx)
        call model%vtx(i)%copy_from (src%vtx(i), model)
     end do
     call model%freeze_vertices ()
   end subroutine model_data_copy
 
 @ %def model_data_copy
 @ Return the model name and numeric scheme.
 <<Model data: model data: TBP>>=
   procedure :: get_name => model_data_get_name
   procedure :: get_scheme_num => model_data_get_scheme_num
 <<Model data: procedures>>=
   function model_data_get_name (model) result (name)
     class(model_data_t), intent(in) :: model
     type(string_t) :: name
     name = model%name
   end function model_data_get_name
 
   function model_data_get_scheme_num (model) result (scheme)
     class(model_data_t), intent(in) :: model
     integer :: scheme
     scheme = model%scheme
   end function model_data_get_scheme_num
 
 @ %def model_data_get_name
 @ %def model_data_get_scheme
 @ Retrieve a MD5 sum for the current model parameter values and
 decay/polarization settings.  This is
 done by writing them to a temporary file, using a standard format.  If the
 model scheme is nonzero, it is also written.
 <<Model data: model data: TBP>>=
   procedure :: get_parameters_md5sum => model_data_get_parameters_md5sum
 <<Model data: procedures>>=
   function model_data_get_parameters_md5sum (model) result (par_md5sum)
     character(32) :: par_md5sum
     class(model_data_t), intent(in) :: model
     real(default), dimension(:), allocatable :: par
     type(field_data_t), pointer :: field
     integer :: unit, i
     allocate (par (model%get_n_real ()))
     call model%real_parameters_to_array (par)
     unit = free_unit ()
     open (unit, status="scratch", action="readwrite")
     if (model%scheme /= 0)  write (unit, "(I0)")  model%scheme
     write (unit, "(" // FMT_19 // ")")  par
     do i = 1, model%get_n_field ()
        field => model%get_field_ptr_by_index (i)
        if (.not. field%is_stable (.false.) .or. .not. field%is_stable (.true.) &
             .or. field%is_polarized (.false.) .or. field%is_polarized (.true.))&
             then
           write (unit, "(3x,A)") char (field%get_longname ())
           call field%write_decays (unit)
        end if
     end do
     rewind (unit)
     par_md5sum = md5sum (unit)
     close (unit)
   end function model_data_get_parameters_md5sum
 
 @ %def model_get_parameters_md5sum
 @ Return the MD5 sum.  This is a placeholder, to be overwritten
 for the complete model definition.
 <<Model data: model data: TBP>>=
   procedure :: get_md5sum => model_data_get_md5sum
 <<Model data: procedures>>=
   function model_data_get_md5sum (model) result (md5sum)
     class(model_data_t), intent(in) :: model
     character(32) :: md5sum
     md5sum = model%get_parameters_md5sum ()
   end function model_data_get_md5sum
 
 @ %def model_data_get_md5sum
 @ Initialize a real or complex parameter.
 <<Model data: model data: TBP>>=
   generic :: init_par => model_data_init_par_real, model_data_init_par_complex
   procedure, private :: model_data_init_par_real
   procedure, private :: model_data_init_par_complex
 <<Model data: procedures>>=
   subroutine model_data_init_par_real (model, i, name, value)
     class(model_data_t), intent(inout) :: model
     integer, intent(in) :: i
     type(string_t), intent(in) :: name
     real(default), intent(in) :: value
     call model%par_real(i)%init (name, value)
   end subroutine model_data_init_par_real
 
   subroutine model_data_init_par_complex (model, i, name, value)
     class(model_data_t), intent(inout) :: model
     integer, intent(in) :: i
     type(string_t), intent(in) :: name
     complex(default), intent(in) :: value
     call model%par_complex(i)%init (name, value)
   end subroutine model_data_init_par_complex
 
 @ %def model_data_init_par_real model_data_init_par_complex
 @ After initialization, return size of parameter array.
 <<Model data: model data: TBP>>=
   procedure :: get_n_real => model_data_get_n_real
   procedure :: get_n_complex => model_data_get_n_complex
 <<Model data: procedures>>=
   function model_data_get_n_real (model) result (n)
     class(model_data_t), intent(in) :: model
     integer :: n
     n = size (model%par_real)
   end function model_data_get_n_real
 
   function model_data_get_n_complex (model) result (n)
     class(model_data_t), intent(in) :: model
     integer :: n
     n = size (model%par_complex)
   end function model_data_get_n_complex
 
 @ %def model_data_get_n_real
 @ %def model_data_get_n_complex
 @ After initialization, extract the whole parameter array.
 <<Model data: model data: TBP>>=
   procedure :: real_parameters_to_array &
        => model_data_real_par_to_array
   procedure :: complex_parameters_to_array &
        => model_data_complex_par_to_array
 <<Model data: procedures>>=
   subroutine model_data_real_par_to_array (model, array)
     class(model_data_t), intent(in) :: model
     real(default), dimension(:), intent(inout) :: array
     array = model%par_real%get_real ()
   end subroutine model_data_real_par_to_array
 
   subroutine model_data_complex_par_to_array (model, array)
     class(model_data_t), intent(in) :: model
     complex(default), dimension(:), intent(inout) :: array
     array = model%par_complex%get_complex ()
   end subroutine model_data_complex_par_to_array
 
 @ %def model_data_real_par_to_array
 @ %def model_data_complex_par_to_array
 @ After initialization, set the whole parameter array.
 <<Model data: model data: TBP>>=
   procedure :: real_parameters_from_array &
        => model_data_real_par_from_array
   procedure :: complex_parameters_from_array &
        => model_data_complex_par_from_array
 <<Model data: procedures>>=
   subroutine model_data_real_par_from_array (model, array)
     class(model_data_t), intent(inout) :: model
     real(default), dimension(:), intent(in) :: array
     model%par_real = array
   end subroutine model_data_real_par_from_array
 
   subroutine model_data_complex_par_from_array (model, array)
     class(model_data_t), intent(inout) :: model
     complex(default), dimension(:), intent(in) :: array
     model%par_complex = array
   end subroutine model_data_complex_par_from_array
 
 @ %def model_data_real_par_from_array
 @ %def model_data_complex_par_from_array
 @ Analogous, for a C parameter array.
 <<Model data: model data: TBP>>=
   procedure :: real_parameters_to_c_array &
        => model_data_real_par_to_c_array
 <<Model data: procedures>>=
   subroutine model_data_real_par_to_c_array (model, array)
     class(model_data_t), intent(in) :: model
     real(c_default_float), dimension(:), intent(inout) :: array
     array = model%par_real%get_real ()
   end subroutine model_data_real_par_to_c_array
 
 @ %def model_data_real_par_to_c_array
 @ After initialization, set the whole parameter array.
 <<Model data: model data: TBP>>=
   procedure :: real_parameters_from_c_array &
        => model_data_real_par_from_c_array
 <<Model data: procedures>>=
   subroutine model_data_real_par_from_c_array (model, array)
     class(model_data_t), intent(inout) :: model
     real(c_default_float), dimension(:), intent(in) :: array
     model%par_real = real (array, default)
   end subroutine model_data_real_par_from_c_array
 
 @ %def model_data_real_par_from_c_array
 @ After initialization, get pointer to a real or complex parameter,
 directly by index.
 <<Model data: model data: TBP>>=
   procedure :: get_par_real_ptr => model_data_get_par_real_ptr_index
   procedure :: get_par_complex_ptr => model_data_get_par_complex_ptr_index
 <<Model data: procedures>>=
   function model_data_get_par_real_ptr_index (model, i) result (ptr)
     class(model_data_t), intent(inout) :: model
     integer, intent(in) :: i
     class(modelpar_data_t), pointer :: ptr
     ptr => model%par_real(i)
   end function model_data_get_par_real_ptr_index
 
   function model_data_get_par_complex_ptr_index (model, i) result (ptr)
     class(model_data_t), intent(inout) :: model
     integer, intent(in) :: i
     class(modelpar_data_t), pointer :: ptr
     ptr => model%par_complex(i)
   end function model_data_get_par_complex_ptr_index
 
 @ %def model_data_get_par_real_ptr model_data_get_par_complex_ptr
 @ After initialization, get pointer to a parameter by name.
 <<Model data: model data: TBP>>=
   procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name
 <<Model data: procedures>>=
   function model_data_get_par_data_ptr_name (model, name) result (ptr)
     class(model_data_t), intent(in) :: model
     type(string_t), intent(in) :: name
     class(modelpar_data_t), pointer :: ptr
     integer :: i
     do i = 1, size (model%par_real)
        if (model%par_real(i)%name == name) then
           ptr => model%par_real(i)
           return
        end if
     end do
     do i = 1, size (model%par_complex)
        if (model%par_complex(i)%name == name) then
           ptr => model%par_complex(i)
           return
        end if
     end do
     ptr => null ()
   end function model_data_get_par_data_ptr_name
 
 @ %def model_data_get_par_data_ptr
 @ Return the value by name.  Again, type conversion is allowed.
 <<Model data: model data: TBP>>=
   procedure :: get_real => model_data_get_par_real_value
   procedure :: get_complex => model_data_get_par_complex_value
 <<Model data: procedures>>=
   function model_data_get_par_real_value (model, name) result (value)
     class(model_data_t), intent(in) :: model
     type(string_t), intent(in) :: name
     class(modelpar_data_t), pointer :: par
     real(default) :: value
     par => model%get_par_data_ptr (name)
     value = par%get_real ()
   end function model_data_get_par_real_value
 
   function model_data_get_par_complex_value (model, name) result (value)
     class(model_data_t), intent(in) :: model
     type(string_t), intent(in) :: name
     class(modelpar_data_t), pointer :: par
     complex(default) :: value
     par => model%get_par_data_ptr (name)
     value = par%get_complex ()
   end function model_data_get_par_complex_value
 
 @ %def model_data_get_real
 @ %def model_data_get_complex
 @ Modify a real or complex parameter.
 <<Model data: model data: TBP>>=
   generic :: set_par => model_data_set_par_real, model_data_set_par_complex
   procedure, private :: model_data_set_par_real
   procedure, private :: model_data_set_par_complex
 <<Model data: procedures>>=
   subroutine model_data_set_par_real (model, name, value)
     class(model_data_t), intent(inout) :: model
     type(string_t), intent(in) :: name
     real(default), intent(in) :: value
     class(modelpar_data_t), pointer :: par
     par => model%get_par_data_ptr (name)
     par = value
   end subroutine model_data_set_par_real
 
   subroutine model_data_set_par_complex (model, name, value)
     class(model_data_t), intent(inout) :: model
     type(string_t), intent(in) :: name
     complex(default), intent(in) :: value
     class(modelpar_data_t), pointer :: par
     par => model%get_par_data_ptr (name)
     par = value
   end subroutine model_data_set_par_complex
 
 @ %def model_data_set_par_real model_data_set_par_complex
 @ List all fields in the model.
 <<Model data: model data: TBP>>=
   procedure :: write_fields => model_data_write_fields
 <<Model data: procedures>>=
   subroutine model_data_write_fields (model, unit)
     class(model_data_t), intent(in) :: model
     integer, intent(in), optional :: unit
     integer :: i
     do i = 1, size (model%field)
        call model%field(i)%write (unit)
     end do
   end subroutine model_data_write_fields
 
 @ %def model_data_write_fields
 @ After initialization, return number of fields (particles):
 <<Model data: model data: TBP>>=
   procedure :: get_n_field => model_data_get_n_field
 <<Model data: procedures>>=
   function model_data_get_n_field (model) result (n)
     class(model_data_t), intent(in) :: model
     integer :: n
     n = size (model%field)
   end function model_data_get_n_field
 
 @ %def model_data_get_n_field
 @ Return the PDG code of a field.  The field is identified by name or
 by index.  If the field is not found, return zero.
 <<Model data: model data: TBP>>=
   generic :: get_pdg => &
        model_data_get_field_pdg_index, &
        model_data_get_field_pdg_name
   procedure, private :: model_data_get_field_pdg_index
   procedure, private :: model_data_get_field_pdg_name
 <<Model data: procedures>>=
   function model_data_get_field_pdg_index (model, i) result (pdg)
     class(model_data_t), intent(in) :: model
     integer, intent(in) :: i
     integer :: pdg
     pdg = model%field(i)%get_pdg ()
   end function model_data_get_field_pdg_index
 
   function model_data_get_field_pdg_name (model, name, check) result (pdg)
     class(model_data_t), intent(in) :: model
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: check
     integer :: pdg
     integer :: i
     do i = 1, size (model%field)
        associate (field => model%field(i))
          if (field%matches_name (name, .false.)) then
             pdg = field%get_pdg ()
             return
          else if (field%matches_name (name, .true.)) then
             pdg = - field%get_pdg ()
             return
          end if
        end associate
     end do
     pdg = 0
     call model%field_error (check, name)
   end function model_data_get_field_pdg_name
 
 @ %def model_data_get_field_pdg
 @ Return an array of all PDG codes, including antiparticles.  The antiparticle
 are sorted after all particles.
 <<Model data: model data: TBP>>=
   procedure :: get_all_pdg => model_data_get_all_pdg
 <<Model data: procedures>>=
   subroutine model_data_get_all_pdg (model, pdg)
     class(model_data_t), intent(in) :: model
     integer, dimension(:), allocatable, intent(inout) :: pdg
     integer :: n0, n1, i, k
     n0 = size (model%field)
     n1 = n0 + count (model%field%has_antiparticle ())
     allocate (pdg (n1))
     pdg(1:n0) = model%field%get_pdg ()
     k = n0
     do i = 1, size (model%field)
        associate (field => model%field(i))
          if (field%has_antiparticle ()) then
             k = k + 1
             pdg(k) = - field%get_pdg ()
          end if
        end associate
     end do
   end subroutine model_data_get_all_pdg
 
 @ %def model_data_get_all_pdg
 @ Return pointer to the field array.
 <<Model data: model data: TBP>>=
   procedure :: get_field_array_ptr => model_data_get_field_array_ptr
 <<Model data: procedures>>=
   function model_data_get_field_array_ptr (model) result (ptr)
     class(model_data_t), intent(in), target :: model
     type(field_data_t), dimension(:), pointer :: ptr
     ptr => model%field
   end function model_data_get_field_array_ptr
 
 @ %def model_data_get_field_array_ptr
 @ Return pointer to a field.  The identifier should be the unique long
 name, the PDG code, or the index.
 
 We can issue an error message, if the [[check]] flag is set.  We never return
 an error if the PDG code is zero, this yields just a null pointer.
 <<Model data: model data: TBP>>=
   generic :: get_field_ptr => &
        model_data_get_field_ptr_name, &
        model_data_get_field_ptr_pdg
   procedure, private :: model_data_get_field_ptr_name
   procedure, private :: model_data_get_field_ptr_pdg
   procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index
 <<Model data: procedures>>=
   function model_data_get_field_ptr_name (model, name, check) result (ptr)
     class(model_data_t), intent(in), target :: model
     type(string_t), intent(in) :: name
     logical, intent(in), optional :: check
     type(field_data_t), pointer :: ptr
     integer :: i
     do i = 1, size (model%field)
        if (model%field(i)%matches_name (name, .false.)) then
           ptr => model%field(i)
           return
        else if (model%field(i)%matches_name (name, .true.)) then
           ptr => model%field(i)
           return
        end if
     end do
     ptr => null ()
     call model%field_error (check, name)
   end function model_data_get_field_ptr_name
 
   function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr)
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: pdg
     logical, intent(in), optional :: check
     type(field_data_t), pointer :: ptr
     integer :: i, pdg_abs
     if (pdg == 0) then
        ptr => null ()
        return
     end if
     pdg_abs = abs (pdg)
     do i = 1, size (model%field)
        if (abs(model%field(i)%get_pdg ()) == pdg_abs) then
           ptr => model%field(i)
           return
        end if
     end do
     ptr => null ()
     call model%field_error (check, pdg=pdg)
   end function model_data_get_field_ptr_pdg
 
   function model_data_get_field_ptr_index (model, i) result (ptr)
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: i
     type(field_data_t), pointer :: ptr
     ptr => model%field(i)
   end function model_data_get_field_ptr_index
 
 @ %def model_data_get_field_ptr
 @ Don't assign a pointer, just check.
 <<Model data: model data: TBP>>=
   procedure :: test_field => model_data_test_field_pdg
 <<Model data: procedures>>=
   function model_data_test_field_pdg (model, pdg, check) result (exist)
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: pdg
     logical, intent(in), optional :: check
     logical :: exist
     exist = associated (model%get_field_ptr (pdg, check))
   end function model_data_test_field_pdg
 
 @ %def model_data_test_field_pdg
 @ Error message, if [[check]] is set.
 <<Model data: model data: TBP>>=
   procedure :: field_error => model_data_field_error
 <<Model data: procedures>>=
   subroutine model_data_field_error (model, check, name, pdg)
     class(model_data_t), intent(in) :: model
     logical, intent(in), optional :: check
     type(string_t), intent(in), optional :: name
     integer, intent(in), optional :: pdg
     if (present (check)) then
        if (check) then
           if (present (name)) then
              write (msg_buffer, "(A,1x,A,1x,A,1x,A)") &
                   "No particle with name", char (name), &
                   "is contained in model", char (model%name)
           else if (present (pdg)) then
              write (msg_buffer, "(A,1x,I0,1x,A,1x,A)") &
                   "No particle with PDG code", pdg, &
                   "is contained in model", char (model%name)
           else
              write (msg_buffer, "(A,1x,A,1x,A)") &
                   "Particle missing", &
                   "in model", char (model%name)
           end if
           call msg_fatal ()
        end if
     end if
   end subroutine model_data_field_error
 
 @ %def model_data_field_error
 @ Assign mass and width value, which are associated via pointer.
 Identify the particle via pdg.
 <<Model data: model data: TBP>>=
   procedure :: set_field_mass => model_data_set_field_mass_pdg
   procedure :: set_field_width => model_data_set_field_width_pdg
 <<Model data: procedures>>=
   subroutine model_data_set_field_mass_pdg (model, pdg, value)
     class(model_data_t), intent(inout) :: model
     integer, intent(in) :: pdg
     real(default), intent(in) :: value
     type(field_data_t), pointer :: field
     field => model%get_field_ptr (pdg, check = .true.)
     call field%set_mass (value)
   end subroutine model_data_set_field_mass_pdg
 
   subroutine model_data_set_field_width_pdg (model, pdg, value)
     class(model_data_t), intent(inout) :: model
     integer, intent(in) :: pdg
     real(default), intent(in) :: value
     type(field_data_t), pointer :: field
     field => model%get_field_ptr (pdg, check = .true.)
     call field%set_width (value)
   end subroutine model_data_set_field_width_pdg
 
 @ %def model_data_set_field_mass
 @ %def model_data_set_field_width
 @ Mark a particle as unstable and provide a list of names for its
 decay processes.  In contrast with the previous subroutine which is
 for internal use, we address the particle by its PDG code.  If the
 index is negative, we address the antiparticle.
 <<Model data: model data: TBP>>=
   procedure :: set_unstable => model_data_set_unstable
   procedure :: set_stable => model_data_set_stable
 <<Model data: procedures>>=
   subroutine model_data_set_unstable &
        (model, pdg, decay, isotropic, diagonal, decay_helicity)
     class(model_data_t), intent(inout), target :: model
     integer, intent(in) :: pdg
     type(string_t), dimension(:), intent(in) :: decay
     logical, intent(in), optional :: isotropic, diagonal
     integer, intent(in), optional :: decay_helicity
     type(field_data_t), pointer :: field
     field => model%get_field_ptr (pdg)
     if (pdg > 0) then
        call field%set ( &
             p_is_stable = .false., p_decay = decay, &
             p_decays_isotropically = isotropic, &
             p_decays_diagonal = diagonal, &
             p_decay_helicity = decay_helicity)
     else
        call field%set ( &
             a_is_stable = .false., a_decay = decay, &
             a_decays_isotropically = isotropic, &
             a_decays_diagonal = diagonal, &
             a_decay_helicity = decay_helicity)
     end if
   end subroutine model_data_set_unstable
 
   subroutine model_data_set_stable (model, pdg)
     class(model_data_t), intent(inout), target :: model
     integer, intent(in) :: pdg
     type(field_data_t), pointer :: field
     field => model%get_field_ptr (pdg)
     if (pdg > 0) then
        call field%set (p_is_stable = .true.)
     else
        call field%set (a_is_stable = .true.)
     end if
   end subroutine model_data_set_stable
 
 @ %def model_data_set_unstable
 @ %def model_data_set_stable
 @ Mark a particle as polarized.
 <<Model data: model data: TBP>>=
   procedure :: set_polarized => model_data_set_polarized
   procedure :: set_unpolarized => model_data_set_unpolarized
 <<Model data: procedures>>=
   subroutine model_data_set_polarized (model, pdg)
     class(model_data_t), intent(inout), target :: model
     integer, intent(in) :: pdg
     type(field_data_t), pointer :: field
     field => model%get_field_ptr (pdg)
     if (pdg > 0) then
        call field%set (p_polarized = .true.)
     else
        call field%set (a_polarized = .true.)
     end if
   end subroutine model_data_set_polarized
 
   subroutine model_data_set_unpolarized (model, pdg)
     class(model_data_t), intent(inout), target :: model
     integer, intent(in) :: pdg
     type(field_data_t), pointer :: field
     field => model%get_field_ptr (pdg)
     if (pdg > 0) then
        call field%set (p_polarized = .false.)
     else
        call field%set (a_polarized = .false.)
     end if
   end subroutine model_data_set_unpolarized
 
 @ %def model_data_set_polarized
 @ %def model_data_set_unpolarized
 @ Revert all polarized (unstable) particles to unpolarized (stable)
 status, respectively.
 <<Model data: model data: TBP>>=
   procedure :: clear_unstable => model_clear_unstable
   procedure :: clear_polarized => model_clear_polarized
 <<Model data: procedures>>=
   subroutine model_clear_unstable (model)
     class(model_data_t), intent(inout), target :: model
     integer :: i
     type(field_data_t), pointer :: field
     do i = 1, model%get_n_field ()
        field => model%get_field_ptr_by_index (i)
        call field%set (p_is_stable = .true.)
        if (field%has_antiparticle ()) then
           call field%set (a_is_stable = .true.)
        end if
     end do
   end subroutine model_clear_unstable
 
   subroutine model_clear_polarized (model)
     class(model_data_t), intent(inout), target :: model
     integer :: i
     type(field_data_t), pointer :: field
     do i = 1, model%get_n_field ()
        field => model%get_field_ptr_by_index (i)
        call field%set (p_polarized = .false.)
        if (field%has_antiparticle ()) then
           call field%set (a_polarized = .false.)
        end if
     end do
   end subroutine model_clear_polarized
 
 @ %def model_clear_unstable
 @ %def model_clear_polarized
 @ List all vertices, optionally also the hash table.
 <<Model data: model data: TBP>>=
   procedure :: write_vertices => model_data_write_vertices
 <<Model data: procedures>>=
   subroutine model_data_write_vertices (model, unit, verbose)
     class(model_data_t), intent(in) :: model
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: i, u
     u = given_output_unit (unit)
     do i = 1, size (model%vtx)
        call vertex_write (model%vtx(i), unit)
     end do
     if (present (verbose)) then
        if (verbose) then
           write (u, *)
           call vertex_table_write (model%vt, unit)
        end if
     end if
   end subroutine model_data_write_vertices
 
 @ %def model_data_write_vertices
 @ Vertex definition.
 <<Model data: model data: TBP>>=
   generic :: set_vertex => &
        model_data_set_vertex_pdg, model_data_set_vertex_names
   procedure, private :: model_data_set_vertex_pdg
   procedure, private :: model_data_set_vertex_names
 <<Model data: procedures>>=
   subroutine model_data_set_vertex_pdg (model, i, pdg)
     class(model_data_t), intent(inout), target :: model
     integer, intent(in) :: i
     integer, dimension(:), intent(in) :: pdg
     call vertex_init (model%vtx(i), pdg, model)
   end subroutine model_data_set_vertex_pdg
 
   subroutine model_data_set_vertex_names (model, i, name)
     class(model_data_t), intent(inout), target :: model
     integer, intent(in) :: i
     type(string_t), dimension(:), intent(in) :: name
     integer, dimension(size(name)) :: pdg
     integer :: j
     do j = 1, size (name)
        pdg(j) = model%get_pdg (name(j))
     end do
     call model%set_vertex (i, pdg)
   end subroutine model_data_set_vertex_names
 
 @ %def model_data_set_vertex
 @ Finalize vertex definition: set up the hash table.
 <<Model data: model data: TBP>>=
   procedure :: freeze_vertices => model_data_freeze_vertices
 <<Model data: procedures>>=
   subroutine model_data_freeze_vertices (model)
     class(model_data_t), intent(inout) :: model
     call model%vt%init (model%field, model%vtx)
   end subroutine model_data_freeze_vertices
 
 @ %def model_data_freeze_vertices
 @ Number of vertices in model
 <<Model data: model data: TBP>>=
   procedure :: get_n_vtx => model_data_get_n_vtx
 <<Model data: procedures>>=
   function model_data_get_n_vtx (model) result (n)
     class(model_data_t), intent(in) :: model
     integer :: n
     n = size (model%vtx)
   end function model_data_get_n_vtx
 
 @ %def model_data_get_n_vtx
 @ Lookup functions
 <<Model data: model data: TBP>>=
   procedure :: match_vertex => model_data_match_vertex
 <<Model data: procedures>>=
   subroutine model_data_match_vertex (model, pdg1, pdg2, pdg3)
     class(model_data_t), intent(in) :: model
     integer, intent(in) :: pdg1, pdg2
     integer, dimension(:), allocatable, intent(out) :: pdg3
     call model%vt%match (pdg1, pdg2, pdg3)
   end subroutine model_data_match_vertex
 
 @ %def model_data_match_vertex
 <<Model data: model data: TBP>>=
   procedure :: check_vertex => model_data_check_vertex
 <<Model data: procedures>>=
   function model_data_check_vertex (model, pdg1, pdg2, pdg3) result (flag)
     logical :: flag
     class(model_data_t), intent(in) :: model
     integer, intent(in) :: pdg1, pdg2, pdg3
     flag = model%vt%check (pdg1, pdg2, pdg3)
   end function model_data_check_vertex
 
 @ %def model_data_check_vertex
 @
 \subsection{Toy Models}
 This is a stripped-down version of the (already trivial) model 'Test'.
 <<Model data: model data: TBP>>=
   procedure :: init_test => model_data_init_test
 <<Model data: procedures>>=
   subroutine model_data_init_test (model)
     class(model_data_t), intent(out) :: model
     type(field_data_t), pointer :: field
     integer, parameter :: n_real = 4
     integer, parameter :: n_field = 2
     integer, parameter :: n_vertex = 2
     integer :: i
     call model%init (var_str ("Test"), &
          n_real, 0, n_field, n_vertex)
     i = 0
     i = i + 1
     call model%init_par (i, var_str ("gy"), 1._default)
     i = i + 1
     call model%init_par (i, var_str ("ms"), 125._default)
     i = i + 1
     call model%init_par (i, var_str ("ff"), 1.5_default)
     i = i + 1
     call model%init_par (i, var_str ("mf"), 1.5_default * 125._default)
     i = 0
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("SCALAR"), 25)
     call field%set (spin_type=1)
     call field%set (mass_data=model%get_par_real_ptr (2))
     call field%set (name = [var_str ("s")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("FERMION"), 6)
     call field%set (spin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (4))
     call field%set (name = [var_str ("f")], anti = [var_str ("fbar")])
     call model%freeze_fields ()
     i = 0
     i = i + 1
     call model%set_vertex (i, [var_str ("fbar"), var_str ("f"), var_str ("s")])
     i = i + 1
     call model%set_vertex (i, [var_str ("s"), var_str ("s"), var_str ("s")])
     call model%freeze_vertices ()
   end subroutine model_data_init_test
 
 @ %def model_data_init_test
 @
 This procedure prepares a subset of QED for testing purposes.
 <<Model data: model data: TBP>>=
   procedure :: init_qed_test => model_data_init_qed_test
 <<Model data: procedures>>=
   subroutine model_data_init_qed_test (model)
     class(model_data_t), intent(out) :: model
     type(field_data_t), pointer :: field
     integer, parameter :: n_real = 1
     integer, parameter :: n_field = 2
     integer :: i
     call model%init (var_str ("QED_test"), &
          n_real, 0, n_field, 0)
     i = 0
     i = i + 1
     call model%init_par (i, var_str ("me"), 0.000510997_default)
     i = 0
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("E_LEPTON"), 11)
     call field%set (spin_type=2, charge_type=-4)
     call field%set (mass_data=model%get_par_real_ptr (1))
     call field%set (name = [var_str ("e-")], anti = [var_str ("e+")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("PHOTON"), 22)
     call field%set (spin_type=3)
     call field%set (name = [var_str ("A")])
     call model%freeze_fields ()
     call model%freeze_vertices ()
   end subroutine model_data_init_qed_test
 
 @ %def model_data_init_qed_test
 @
 This procedure prepares a subset of the Standard Model for testing purposes.
 We can thus avoid dependencies on model I/O, which is not defined here.
 <<Model data: model data: TBP>>=
   procedure :: init_sm_test => model_data_init_sm_test
 <<Model data: procedures>>=
   subroutine model_data_init_sm_test (model)
     class(model_data_t), intent(out) :: model
     type(field_data_t), pointer :: field
     integer, parameter :: n_real = 11
     integer, parameter :: n_field = 19
     integer, parameter :: n_vtx = 9
     integer :: i
     call model%init (var_str ("SM_test"), &
          n_real, 0, n_field, n_vtx)
     i = 0
     i = i + 1
     call model%init_par (i, var_str ("mZ"), 91.1882_default)
     i = i + 1
     call model%init_par (i, var_str ("mW"), 80.419_default)
     i = i + 1
     call model%init_par (i, var_str ("me"), 0.000510997_default)
     i = i + 1
     call model%init_par (i, var_str ("mmu"), 0.105658389_default)
     i = i + 1
     call model%init_par (i, var_str ("mb"), 4.2_default)
     i = i + 1
     call model%init_par (i, var_str ("mtop"), 173.1_default)
     i = i + 1
     call model%init_par (i, var_str ("wZ"), 2.443_default)
     i = i + 1
     call model%init_par (i, var_str ("wW"), 2.049_default)
     i = i + 1
     call model%init_par (i, var_str ("ee"), 0.3079561542961_default)
     i = i + 1
     call model%init_par (i, var_str ("cw"), 8.819013863636E-01_default)
     i = i + 1
     call model%init_par (i, var_str ("sw"), 4.714339240339E-01_default)
     i = 0
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("D_QUARK"), 1)
     call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
     call field%set (name = [var_str ("d")], anti = [var_str ("dbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("U_QUARK"), 2)
     call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
     call field%set (name = [var_str ("u")], anti = [var_str ("ubar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("S_QUARK"), 3)
     call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
     call field%set (name = [var_str ("s")], anti = [var_str ("sbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("C_QUARK"), 4)
     call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
     call field%set (name = [var_str ("c")], anti = [var_str ("cbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("B_QUARK"), 5)
     call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
     call field%set (mass_data=model%get_par_real_ptr (5))
     call field%set (name = [var_str ("b")], anti = [var_str ("bbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("T_QUARK"), 6)
     call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (6))
     call field%set (name = [var_str ("t")], anti = [var_str ("tbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("E_LEPTON"), 11)
     call field%set (spin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (3))
     call field%set (name = [var_str ("e-")], anti = [var_str ("e+")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("E_NEUTRINO"), 12)
     call field%set (spin_type=2, is_left_handed=.true.)
     call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("MU_LEPTON"), 13)
     call field%set (spin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (4))
     call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("MU_NEUTRINO"), 14)
     call field%set (spin_type=2, is_left_handed=.true.)
     call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("GLUON"), 21)
     call field%set (spin_type=3, color_type=8)
     call field%set (name = [var_str ("gl")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("PHOTON"), 22)
     call field%set (spin_type=3)
     call field%set (name = [var_str ("A")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("Z_BOSON"), 23)
     call field%set (spin_type=3)
     call field%set (mass_data=model%get_par_real_ptr (1))
     call field%set (width_data=model%get_par_real_ptr (7))
     call field%set (name = [var_str ("Z")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("W_BOSON"), 24)
     call field%set (spin_type=3)
     call field%set (mass_data=model%get_par_real_ptr (2))
     call field%set (width_data=model%get_par_real_ptr (8))
     call field%set (name = [var_str ("W+")], anti = [var_str ("W-")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("HIGGS"), 25)
     call field%set (spin_type=1)
 !    call field%set (mass_data=model%get_par_real_ptr (2))
 !    call field%set (width_data=model%get_par_real_ptr (8))
     call field%set (name = [var_str ("H")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("PROTON"), 2212)
     call field%set (spin_type=2)
     call field%set (name = [var_str ("p")], anti = [var_str ("pbar")])
 !    call field%set (mass_data=model%get_par_real_ptr (12))
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91)
     call field%set (color_type=1)
     call field%set (name = [var_str ("hr1")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92)
     call field%set (color_type=3)
     call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("HADRON_REMNANT_OCTET"), 93)
     call field%set (color_type=8)
     call field%set (name = [var_str ("hr8")])
     call model%freeze_fields ()
     i = 0
     i = i + 1
     call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")])
     i = i + 1
     call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")])
     call model%freeze_vertices ()
   end subroutine model_data_init_sm_test
 
 @ %def model_data_init_sm_test
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Model Testbed}
 The standard way of defining a model uses concrete variables and expressions to
 interpret the model file.  Some of this is not available at the point of use.  This
 is no problem for the \whizard\ program as a whole, but unit tests are
 kept local to their respective module and don't access all definitions.
 
 Instead, we introduce a separate module that provides hooks, one for
 initializing a model and one for finalizing a model.  The main program can
 assign real routines to the hooks (procedure pointers of abstract type) before
 unit tests are called.  The unit tests can call the abstract routines without
 knowing about their implementation.
 <<[[model_testbed.f90]]>>=
 <<File header>>
 
 module model_testbed
 
 <<Use strings>>
   use model_data
   use var_base
 
 <<Standard module head>>
 
 <<Model testbed: public>>
 
 <<Model testbed: variables>>
 
 <<Model testbed: interfaces>>
 
 end module model_testbed
 @ %def model_testbed
 @
 \subsection{Abstract Model Handlers}
 Both routines take a polymorphic model (data) target, which
 is not allocated/deallocated inside the subroutine.  The model constructor
 [[prepare_model]] requires the model name as input.  It can, optionally,
 return a link to the variable list of the model.
 <<Model testbed: public>>=
   public :: prepare_model
   public :: cleanup_model
 <<Model testbed: variables>>=
   procedure (prepare_model_proc), pointer :: prepare_model => null ()
   procedure (cleanup_model_proc), pointer :: cleanup_model => null ()
 <<Model testbed: interfaces>>=
   abstract interface
      subroutine prepare_model_proc (model, name, vars)
        import
        class(model_data_t), intent(inout), pointer :: model
        type(string_t), intent(in) :: name
        class(vars_t), pointer, intent(out), optional :: vars
      end subroutine prepare_model_proc
   end interface
 
   abstract interface
      subroutine cleanup_model_proc (model)
        import
        class(model_data_t), intent(inout), target :: model
      end subroutine cleanup_model_proc
   end interface
 
 @ %def prepare_model
 @ %def cleanup_model
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Helicities}
 This module defines types and tools for dealing with helicity
 information.
 <<[[helicities.f90]]>>=
 <<File header>>
 
 module helicities
 
   use io_units
 
 <<Standard module head>>
 
 <<Helicities: public>>
 
 <<Helicities: types>>
 
 <<Helicities: interfaces>>
 
 contains
 
 <<Helicities: procedures>>
 
 end module helicities
 @ %def helicities
 @
 \subsection{Helicity types}
 Helicities may be defined or undefined, corresponding to a polarized
 or unpolarized state.  Each helicity is actually a pair of helicities,
 corresponding to an entry in the spin density matrix.  Obviously,
 diagonal entries are distinguished.
 <<Helicities: public>>=
   public :: helicity_t
 <<Helicities: types>>=
   type :: helicity_t
      private
      logical :: defined = .false.
      integer :: h1, h2
    contains
    <<Helicities: helicity: TBP>>
   end type helicity_t
 
 @ %def helicity_t
 @ Constructor functions, for convenience:
 <<Helicities: public>>=
   public :: helicity
 <<Helicities: interfaces>>=
   interface helicity
      module procedure helicity0, helicity1, helicity2
   end interface helicity
 
 <<Helicities: procedures>>=
   pure function helicity0 () result (hel)
     type(helicity_t) :: hel
   end function helicity0
 
   elemental function helicity1 (h) result (hel)
     type(helicity_t) :: hel
     integer, intent(in) :: h
     call hel%init (h)
   end function helicity1
 
   elemental function helicity2 (h2, h1) result (hel)
     type(helicity_t) :: hel
     integer, intent(in) :: h1, h2
     call hel%init (h2, h1)
   end function helicity2
 
 @ %def helicity
 @ Initializers.
 
 Note: conceptually, the argument to initializers should be INTENT(OUT).
 However, Interp.\ F08/0033 prohibited this.  The reason is that, in principle,
 the call could result in the execution of an impure finalizer for a type
 extension of [[hel]] (ugh).
 <<Helicities: helicity: TBP>>=
   generic :: init => helicity_init_empty, helicity_init_same, helicity_init_different
   procedure, private :: helicity_init_empty
   procedure, private :: helicity_init_same
   procedure, private :: helicity_init_different
 <<Helicities: procedures>>=
   elemental subroutine helicity_init_empty (hel)
     class(helicity_t), intent(inout) :: hel
     hel%defined = .false.
   end subroutine helicity_init_empty
 
   elemental subroutine helicity_init_same (hel, h)
     class(helicity_t), intent(inout) :: hel
     integer, intent(in) :: h
     hel%defined = .true.
     hel%h1 = h
     hel%h2 = h
   end subroutine helicity_init_same
 
   elemental subroutine helicity_init_different (hel, h2, h1)
     class(helicity_t), intent(inout) :: hel
     integer, intent(in) :: h1, h2
     hel%defined = .true.
     hel%h2 = h2
     hel%h1 = h1
   end subroutine helicity_init_different
 
 @ %def helicity_init
 @ Undefine:
 <<Helicities: helicity: TBP>>=
   procedure :: undefine => helicity_undefine
 <<Helicities: procedures>>=
   elemental subroutine helicity_undefine (hel)
     class(helicity_t), intent(inout) :: hel
     hel%defined = .false.
   end subroutine helicity_undefine
 
 @ %def helicity_undefine
 @ Diagonalize by removing the second entry (use with care!)
 <<Helicities: helicity: TBP>>=
   procedure :: diagonalize => helicity_diagonalize
 <<Helicities: procedures>>=
   elemental subroutine helicity_diagonalize (hel)
     class(helicity_t), intent(inout) :: hel
     hel%h2 = hel%h1
   end subroutine helicity_diagonalize
 
 @ %def helicity_diagonalize
 @ Flip helicity indices by sign.
 <<Helicities: helicity: TBP>>=
   procedure :: flip => helicity_flip
 <<Helicities: procedures>>=
   elemental subroutine helicity_flip (hel)
     class(helicity_t), intent(inout) :: hel
     hel%h1 = - hel%h1
     hel%h2 = - hel%h2
   end subroutine helicity_flip
 
 @ %def helicity_flip
 @
 <<Helicities: helicity: TBP>>=
   procedure :: get_indices => helicity_get_indices
 <<Helicities: procedures>>=
   subroutine helicity_get_indices (hel, h1, h2)
     class(helicity_t), intent(in) :: hel
     integer, intent(out) :: h1, h2
     h1 = hel%h1; h2 = hel%h2
    end subroutine helicity_get_indices
 
 @ %def helicity_get_indices
 @ Output (no linebreak).  No output if undefined.
 <<Helicities: helicity: TBP>>=
   procedure :: write => helicity_write
 <<Helicities: procedures>>=
   subroutine helicity_write (hel, unit)
     class(helicity_t), intent(in) :: hel
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     if (hel%defined) then
        write (u, "(A)", advance="no")  "h("
        write (u, "(I0)", advance="no")  hel%h1
        if (hel%h1 /= hel%h2) then
           write (u, "(A)", advance="no") "|"
           write (u, "(I0)", advance="no")  hel%h2
        end if
        write (u, "(A)", advance="no")  ")"
     end if
   end subroutine helicity_write
 
 @ %def helicity_write
 @ Binary I/O.  Write contents only if defined.
 <<Helicities: helicity: TBP>>=
   procedure :: write_raw => helicity_write_raw
   procedure :: read_raw => helicity_read_raw
 <<Helicities: procedures>>=
   subroutine helicity_write_raw (hel, u)
     class(helicity_t), intent(in) :: hel
     integer, intent(in) :: u
     write (u) hel%defined
     if (hel%defined) then
        write (u) hel%h1, hel%h2
     end if
   end subroutine helicity_write_raw
 
   subroutine helicity_read_raw (hel, u, iostat)
     class(helicity_t), intent(out) :: hel
     integer, intent(in) :: u
     integer, intent(out), optional :: iostat
     read (u, iostat=iostat) hel%defined
     if (hel%defined) then
        read (u, iostat=iostat) hel%h1, hel%h2
     end if
   end subroutine helicity_read_raw
 
 @ %def helicity_write_raw helicity_read_raw
 @
 \subsection{Predicates}
 Check if the helicity is defined:
 <<Helicities: helicity: TBP>>=
   procedure :: is_defined => helicity_is_defined
 <<Helicities: procedures>>=
   elemental function helicity_is_defined (hel) result (defined)
     logical :: defined
     class(helicity_t), intent(in) :: hel
     defined = hel%defined
   end function helicity_is_defined
 
 @ %def helicity_is_defined
 @ Return true if the two helicities are equal or the particle is unpolarized:
 <<Helicities: helicity: TBP>>=
   procedure :: is_diagonal => helicity_is_diagonal
 <<Helicities: procedures>>=
   elemental function helicity_is_diagonal (hel) result (diagonal)
     logical :: diagonal
     class(helicity_t), intent(in) :: hel
     if (hel%defined) then
        diagonal = hel%h1 == hel%h2
     else
        diagonal = .true.
     end if
   end function helicity_is_diagonal
 
 @ %def helicity_is_diagonal
 @
 \subsection{Accessing contents}
 This returns a two-element array and thus cannot be elemental.  The
 result is unpredictable if the helicity is undefined.
 <<Helicities: helicity: TBP>>=
   procedure :: to_pair => helicity_to_pair
 <<Helicities: procedures>>=
   pure function helicity_to_pair (hel) result (h)
     integer, dimension(2) :: h
     class(helicity_t), intent(in) :: hel
     h(1) = hel%h2
     h(2) = hel%h1
   end function helicity_to_pair
 
 @ %def helicity_to_pair
 @
 \subsection{Comparisons}
 When comparing helicities, if either one is undefined, they are
 considered to match.  In other words, an unpolarized particle matches
 any polarization.  In the [[dmatch]] variant, it matches only diagonal
 helicity.
 <<Helicities: helicity: TBP>>=
   generic :: operator(.match.) => helicity_match
   generic :: operator(.dmatch.) => helicity_match_diagonal
   generic :: operator(==) => helicity_eq
   generic :: operator(/=) => helicity_neq
   procedure, private ::  helicity_match
   procedure, private ::  helicity_match_diagonal
   procedure, private ::  helicity_eq
   procedure, private ::  helicity_neq
 @ %def .match. .dmatch. == /=
 <<Helicities: procedures>>=
   elemental function helicity_match (hel1, hel2) result (eq)
     logical :: eq
     class(helicity_t), intent(in) :: hel1, hel2
     if (hel1%defined .and. hel2%defined) then
        eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
     else
        eq = .true.
     end if
   end function helicity_match
 
   elemental function helicity_match_diagonal (hel1, hel2) result (eq)
     logical :: eq
     class(helicity_t), intent(in) :: hel1, hel2
     if (hel1%defined .and. hel2%defined) then
        eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
     else if (hel1%defined) then
        eq = hel1%h1 == hel1%h2
     else if (hel2%defined) then
        eq = hel2%h1 == hel2%h2
     else
        eq = .true.
     end if
   end function helicity_match_diagonal
 
 @ %def helicity_match helicity_match_diagonal
 <<Helicities: procedures>>=
   elemental function helicity_eq (hel1, hel2) result (eq)
     logical :: eq
     class(helicity_t), intent(in) :: hel1, hel2
     if (hel1%defined .and. hel2%defined) then
        eq = (hel1%h1 == hel2%h1) .and. (hel1%h2 == hel2%h2)
     else if (.not. hel1%defined .and. .not. hel2%defined) then
        eq = .true.
     else
        eq = .false.
     end if
   end function helicity_eq
 
 @ %def helicity_eq
 <<Helicities: procedures>>=
   elemental function helicity_neq (hel1, hel2) result (neq)
     logical :: neq
     class(helicity_t), intent(in) :: hel1, hel2
     if (hel1%defined .and. hel2%defined) then
        neq = (hel1%h1 /= hel2%h1) .or. (hel1%h2 /= hel2%h2)
     else if (.not. hel1%defined .and. .not. hel2%defined) then
        neq = .false.
     else
        neq = .true.
     end if
   end function helicity_neq
 
 @ %def helicity_neq
 @
 \subsection{Tools}
 Merge two helicity objects by taking the first entry from the first and
 the second entry from the second argument.  Makes sense only if the
 input helicities were defined and diagonal.  The handling of ghost
 flags is not well-defined; one should verify beforehand that they
 match.
 <<Helicities: helicity: TBP>>=
   generic :: operator(.merge.) => merge_helicities
   procedure, private ::  merge_helicities
 @ %def .merge.
 <<Helicities: procedures>>=
   elemental function merge_helicities (hel1, hel2) result (hel)
     type(helicity_t) :: hel
     class(helicity_t), intent(in) :: hel1, hel2
     if (hel1%defined .and. hel2%defined) then
        call hel%init (hel2%h1, hel1%h1)
     else if (hel1%defined) then
        call hel%init (hel1%h2, hel1%h1)
     else if (hel2%defined) then
        call hel%init (hel2%h2, hel2%h1)
     end if
   end function merge_helicities
 
 @ %def merge_helicities
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Colors}
 This module defines a type and tools for dealing with color information.
 
 Each particle can have zero or more (in practice, usually not more
 than two) color indices.  Color indices are positive; flow direction
 can be determined from the particle nature.
 
 While parton shower matrix elements are diagonal in color, some
 special applications (e.g., subtractions for NLO matrix elements)
 require non-diagonal color matrices.
 <<[[colors.f90]]>>=
 <<File header>>
 
 module colors
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use diagnostics
 
 <<Standard module head>>
 
 <<Colors: public>>
 
 <<Colors: types>>
 
 <<Colors: interfaces>>
 
 contains
 
 <<Colors: procedures>>
 
 end module colors
 @ %def colors
 @
 \subsection{The color type}
 A particle may have an arbitrary number of color indices (in practice,
 from zero to two, but more are possible).  This object acts as a
 container.  (The current implementation has a fixed array of length two.)
 
 The fact that color comes as an array prohibits elemental procedures
 in some places.  (May add interfaces and multi versions where
 necessary.)
 
 The color may be undefined.
 
 NOTE: Due to a compiler bug in nagfor 5.2, we do not use allocatable
 but fixed-size arrays with dimension 2.  Only nonzero entries count.
 This may be more efficient anyway, but gives up some flexibility.
 However, the squaring algorithm currently works only for singlets,
 (anti)triplets and octets anyway, so two components are enough.
 
 This type has to be generalized (abstract type and specific
 implementations) when trying to pursue generalized color flows or
 Monte Carlo over continuous color.
 <<Colors: public>>=
   public :: color_t
 <<Colors: types>>=
   type :: color_t
      private
      logical :: defined = .false.
      integer, dimension(2) :: c1 = 0, c2 = 0
      logical :: ghost = .false.
    contains
    <<Colors: color: TBP>>
   end type color_t
 
 @ %def color_t
 @ Initializers:
 <<Colors: color: TBP>>=
   generic :: init => &
        color_init_trivial, color_init_trivial_ghost, &
        color_init_array, color_init_array_ghost, &
        color_init_arrays, color_init_arrays_ghost
   procedure, private :: color_init_trivial
   procedure, private :: color_init_trivial_ghost
   procedure, private :: color_init_array
   procedure, private :: color_init_array_ghost
   procedure, private :: color_init_arrays
   procedure, private :: color_init_arrays_ghost
 @ Undefined color: array remains unallocated
 <<Colors: procedures>>=
   pure subroutine color_init_trivial (col)
     class(color_t), intent(inout) :: col
     col%defined = .true.
     col%c1 = 0
     col%c2 = 0
     col%ghost = .false.
   end subroutine color_init_trivial
 
   pure subroutine color_init_trivial_ghost (col, ghost)
     class(color_t), intent(inout) :: col
     logical, intent(in) :: ghost
     col%defined = .true.
     col%c1 = 0
     col%c2 = 0
     col%ghost = ghost
   end subroutine color_init_trivial_ghost
 
 @ This defines color from an arbitrary length color array, suitable
 for any representation.  We may have two color arrays (non-diagonal
 matrix elements).  This cannot be elemental.  The third version
 assigns an array of colors, using a two-dimensional array as input.
 <<Colors: procedures>>=
   pure subroutine color_init_array (col, c1)
     class(color_t), intent(inout) :: col
     integer, dimension(:), intent(in) :: c1
     col%defined = .true.
     col%c1 = pack (c1, c1 /= 0, [0,0])
     col%c2 = col%c1
     col%ghost = .false.
   end subroutine color_init_array
 
   pure subroutine color_init_array_ghost (col, c1, ghost)
     class(color_t), intent(inout) :: col
     integer, dimension(:), intent(in) :: c1
     logical, intent(in) :: ghost
     call color_init_array (col, c1)
     col%ghost = ghost
   end subroutine color_init_array_ghost
 
   pure subroutine color_init_arrays (col, c1, c2)
     class(color_t), intent(inout) :: col
     integer, dimension(:), intent(in) :: c1, c2
     col%defined = .true.
     if (size (c1) == size (c2)) then
        col%c1 = pack (c1, c1 /= 0, [0,0])
        col%c2 = pack (c2, c2 /= 0, [0,0])
     else if (size (c1) /= 0) then
        col%c1 = pack (c1, c1 /= 0, [0,0])
        col%c2 = col%c1
     else if (size (c2) /= 0) then
        col%c1 = pack (c2, c2 /= 0, [0,0])
        col%c2 = col%c1
     end if
     col%ghost = .false.
   end subroutine color_init_arrays
 
   pure subroutine color_init_arrays_ghost (col, c1, c2, ghost)
     class(color_t), intent(inout) :: col
     integer, dimension(:), intent(in) :: c1, c2
     logical, intent(in) :: ghost
     call color_init_arrays (col, c1, c2)
     col%ghost = ghost
   end subroutine color_init_arrays_ghost
 
 @ %def color_init
 @ This version is restricted to singlets, triplets, antitriplets, and
 octets: The input contains the color and anticolor index, each of the
 may be zero.
 <<Colors: color: TBP>>=
   procedure :: init_col_acl => color_init_col_acl
 <<Colors: procedures>>=
   elemental subroutine color_init_col_acl (col, col_in, acl_in)
     class(color_t), intent(inout) :: col
     integer, intent(in) :: col_in, acl_in
     integer, dimension(0) :: null_array
     select case (col_in)
     case (0)
        select case (acl_in)
        case (0)
           call color_init_array (col, null_array)
        case default
           call color_init_array (col, [-acl_in])
        end select
     case default
        select case (acl_in)
        case (0)
           call color_init_array (col, [col_in])
        case default
           call color_init_array (col, [col_in, -acl_in])
        end select
     end select
   end subroutine color_init_col_acl
 
 @ %def color_init_col_acl
 @ This version is used for the external interface.  We convert a
 fixed-size array of colors (for each particle) to the internal form by
 packing only the nonzero entries.
 
 Some of these procedures produce an arry, so they can't be all
 type-bound.  We implement them as ordinary procedures.
 <<Colors: public>>=
   public :: color_init_from_array
 <<Colors: interfaces>>=
   interface color_init_from_array
      module procedure color_init_from_array1
      module procedure color_init_from_array1g
      module procedure color_init_from_array2
      module procedure color_init_from_array2g
   end interface color_init_from_array
 
 @ %def color_init_from_array
 <<Colors: procedures>>=
   pure subroutine color_init_from_array1 (col, c1)
     type(color_t), intent(inout) :: col
     integer, dimension(:), intent(in) :: c1
     logical, dimension(size(c1)) :: mask
     mask = c1 /= 0
     col%defined = .true.
     col%c1 = pack (c1, mask, col%c1)
     col%c2 = col%c1
     col%ghost = .false.
   end subroutine color_init_from_array1
 
   pure subroutine color_init_from_array1g (col, c1, ghost)
     type(color_t), intent(inout) :: col
     integer, dimension(:), intent(in) :: c1
     logical, intent(in) :: ghost
     call color_init_from_array1 (col, c1)
     col%ghost = ghost
   end subroutine color_init_from_array1g
 
   pure subroutine color_init_from_array2 (col, c1)
     integer, dimension(:,:), intent(in) :: c1
     type(color_t), dimension(:), intent(inout) :: col
     integer :: i
     do i = 1, size (c1,2)
        call color_init_from_array1 (col(i), c1(:,i))
     end do
   end subroutine color_init_from_array2
 
   pure subroutine color_init_from_array2g (col, c1, ghost)
     integer, dimension(:,:), intent(in) :: c1
     type(color_t), dimension(:), intent(out) :: col
     logical, intent(in), dimension(:) :: ghost
     call color_init_from_array2 (col, c1)
     col%ghost = ghost
   end subroutine color_init_from_array2g
 
 @ %def color_init_from_array
 @ Set the ghost property
 <<Colors: color: TBP>>=
   procedure :: set_ghost => color_set_ghost
 <<Colors: procedures>>=
   elemental subroutine color_set_ghost (col, ghost)
     class(color_t), intent(inout) :: col
     logical, intent(in) :: ghost
     col%ghost = ghost
   end subroutine color_set_ghost
 
 @ %def color_set_ghost
 @ Undefine the color state:
 <<Colors: color: TBP>>=
   procedure :: undefine => color_undefine
 <<Colors: procedures>>=
   elemental subroutine color_undefine (col, undefine_ghost)
     class(color_t), intent(inout) :: col
     logical, intent(in), optional :: undefine_ghost
     col%defined = .false.
     if (present (undefine_ghost)) then
        if (undefine_ghost)  col%ghost = .false.
     else
        col%ghost = .false.
     end if
   end subroutine color_undefine
 
 @ %def color_undefine
 @ Output.  As dense as possible, no linebreak.  If color is undefined,
 no output.
 
 The separate version for a color array suggest two distinct interfaces.
 <<Colors: public>>=
   public :: color_write
 <<Colors: interfaces>>=
   interface color_write
      module procedure color_write_single
      module procedure color_write_array
   end interface color_write
 
 <<Colors: color: TBP>>=
   procedure :: write => color_write_single
 <<Colors: procedures>>=
   subroutine color_write_single (col, unit)
     class(color_t), intent(in) :: col
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     if (col%ghost) then
        write (u, "(A)", advance="no")  "c*"
     else if (col%defined) then
        write (u, "(A)", advance="no")  "c("
        if (col%c1(1) /= 0)  write (u, "(I0)", advance="no")  col%c1(1)
        if (any (col%c1 /= 0))  write (u, "(1x)", advance="no")
        if (col%c1(2) /= 0)  write (u, "(I0)", advance="no")  col%c1(2)
        if (.not. col%is_diagonal ()) then
           write (u, "(A)", advance="no")  "|"
           if (col%c2(1) /= 0)  write (u, "(I0)", advance="no")  col%c2(1)
           if (any (col%c2 /= 0))  write (u, "(1x)", advance="no")
           if (col%c2(2) /= 0)  write (u, "(I0)", advance="no")  col%c2(2)
        end if
        write (u, "(A)", advance="no") ")"
     end if
   end subroutine color_write_single
 
   subroutine color_write_array (col, unit)
     type(color_t), dimension(:), intent(in) :: col
     integer, intent(in), optional :: unit
     integer :: u
     integer :: i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(A)", advance="no") "["
     do i = 1, size (col)
        if (i > 1)  write (u, "(1x)", advance="no")
        call color_write_single (col(i), u)
     end do
     write (u, "(A)", advance="no") "]"
   end subroutine color_write_array
 
 @ %def color_write
 @ Binary I/O.  For allocatable colors, this would have to be modified.
 <<Colors: color: TBP>>=
   procedure :: write_raw => color_write_raw
   procedure :: read_raw => color_read_raw
 <<Colors: procedures>>=
   subroutine color_write_raw (col, u)
     class(color_t), intent(in) :: col
     integer, intent(in) :: u
     logical :: defined
     defined = col%is_defined () .or. col%is_ghost ()
     write (u) defined
     if (defined) then
        write (u) col%c1, col%c2
        write (u) col%ghost
     end if
   end subroutine color_write_raw
 
   subroutine color_read_raw (col, u, iostat)
     class(color_t), intent(inout) :: col
     integer, intent(in) :: u
     integer, intent(out), optional :: iostat
     logical :: defined
     read (u, iostat=iostat) col%defined
     if (col%defined) then
        read (u, iostat=iostat) col%c1, col%c2
        read (u, iostat=iostat) col%ghost
     end if
   end subroutine color_read_raw
 
 @ %def color_write_raw color_read_raw
 @
 \subsection{Predicates}
 Return the definition status.  A color state may be defined but trivial.
 <<Colors: color: TBP>>=
   procedure :: is_defined => color_is_defined
   procedure :: is_nonzero => color_is_nonzero
 <<Colors: procedures>>=
   elemental function color_is_defined (col) result (defined)
     logical :: defined
     class(color_t), intent(in) :: col
     defined = col%defined
   end function color_is_defined
 
   elemental function color_is_nonzero (col) result (flag)
     logical :: flag
     class(color_t), intent(in) :: col
     flag = col%defined &
          .and. .not. col%ghost &
          .and. any (col%c1 /= 0 .or. col%c2 /= 0)
   end function color_is_nonzero
 
 @ %def color_is_defined
 @ %def color_is_nonzero
 @ Diagonal color objects have only one array allocated:
 <<Colors: color: TBP>>=
   procedure :: is_diagonal => color_is_diagonal
 <<Colors: procedures>>=
   elemental function color_is_diagonal (col) result (diagonal)
     logical :: diagonal
     class(color_t), intent(in) :: col
     if (col%defined) then
        diagonal = all (col%c1 == col%c2)
     else
        diagonal = .true.
     end if
   end function color_is_diagonal
 
 @ %def color_is_diagonal
 @ Return the ghost flag
 <<Colors: color: TBP>>=
   procedure :: is_ghost => color_is_ghost
 <<Colors: procedures>>=
   elemental function color_is_ghost (col) result (ghost)
     logical :: ghost
     class(color_t), intent(in) :: col
     ghost = col%ghost
   end function color_is_ghost
 
 @ %def color_is_ghost
 @ The ghost parity: true if the color-ghost flag is set.  Again, no
 TBP since this is an array.
 <<Colors: procedures>>=
   pure function color_ghost_parity (col) result (parity)
     type(color_t), dimension(:), intent(in) :: col
     logical :: parity
     parity = mod (count (col%ghost), 2) == 1
   end function color_ghost_parity
 
 @ %def color_ghost_parity
 @ Determine the color representation, given a color object. We allow
 only singlet ($1$), (anti)triplet ($\pm 3$), and octet states ($8$).
 A color ghost must not have color assigned, but the color type is $8$.  For
 non-diagonal color, representations must match.  If the color type is
 undefined, return $0$.  If it is invalid or unsupported, return $-1$.
 
 Assumption: nonzero entries precede nonzero ones.
 <<Colors: color: TBP>>=
   procedure :: get_type => color_get_type
 <<Colors: procedures>>=
   elemental function color_get_type (col) result (ctype)
     class(color_t), intent(in) :: col
     integer :: ctype
     if (col%defined) then
        ctype = -1
        if (col%ghost) then
           if (all (col%c1 == 0 .and. col%c2 == 0)) then
              ctype = 8
           end if
        else
           if (all ((col%c1 == 0 .and. col%c2 == 0) &
                & .or. (col%c1 > 0 .and. col%c2 > 0) &
                & .or. (col%c1 < 0 .and. col%c2 < 0))) then
              if (all (col%c1 == 0)) then
                 ctype = 1
              else if ((col%c1(1) > 0 .and. col%c1(2) == 0)) then
                 ctype = 3
              else if ((col%c1(1) < 0 .and. col%c1(2) == 0)) then
                 ctype = -3
              else if ((col%c1(1) > 0 .and. col%c1(2) < 0) &
                   .or.(col%c1(1) < 0 .and. col%c1(2) > 0)) then
                 ctype = 8
              end if
           end if
        end if
     else
        ctype = 0
     end if
   end function color_get_type
 
 @ %def color_get_type
 @
 \subsection{Accessing contents}
 Return the number of color indices.  We assume that it is identical
 for both arrays.
 <<Colors: color: TBP>>=
   procedure, private :: get_number_of_indices => color_get_number_of_indices
 <<Colors: procedures>>=
   elemental function color_get_number_of_indices (col) result (n)
     integer :: n
     class(color_t), intent(in) :: col
     if (col%defined .and. .not. col%ghost) then
        n = count (col%c1 /= 0)
     else
        n = 0
     end if
   end function color_get_number_of_indices
 
 @ %def color_get_number_of_indices
 @ Return the (first) color/anticolor entry (assuming that color is
 diagonal).  The result is a positive color index.
 <<Colors: color: TBP>>=
   procedure :: get_col => color_get_col
   procedure :: get_acl => color_get_acl
 <<Colors: procedures>>=
   elemental function color_get_col (col) result (c)
     integer :: c
     class(color_t), intent(in) :: col
     integer :: i
     if (col%defined .and. .not. col%ghost) then
        do i = 1, size (col%c1)
           if (col%c1(i) > 0) then
              c = col%c1(i)
              return
           end if
        end do
     end if
     c = 0
   end function color_get_col
 
   elemental function color_get_acl (col) result (c)
     integer :: c
     class(color_t), intent(in) :: col
     integer :: i
     if (col%defined .and. .not. col%ghost) then
        do i = 1, size (col%c1)
           if (col%c1(i) < 0) then
              c = - col%c1(i)
              return
           end if
        end do
     end if
     c = 0
   end function color_get_acl
 
 @ %def color_get_col color_get_acl
 @ Return the color index with highest absolute value
 <<Colors: public>>=
   public :: color_get_max_value
 <<Colors: interfaces>>=
   interface color_get_max_value
      module procedure color_get_max_value0
      module procedure color_get_max_value1
      module procedure color_get_max_value2
   end interface color_get_max_value
 
 <<Colors: procedures>>=
   elemental function color_get_max_value0 (col) result (cmax)
     integer :: cmax
     type(color_t), intent(in) :: col
     if (col%defined .and. .not. col%ghost) then
        cmax = maxval (abs (col%c1))
     else
        cmax = 0
     end if
   end function color_get_max_value0
 
   pure function color_get_max_value1 (col) result (cmax)
     integer :: cmax
     type(color_t), dimension(:), intent(in) :: col
     cmax = maxval (color_get_max_value0 (col))
   end function color_get_max_value1
 
   pure function color_get_max_value2 (col) result (cmax)
     integer :: cmax
     type(color_t), dimension(:,:), intent(in) :: col
     integer, dimension(size(col, 2)) :: cm
     integer :: i
     forall (i = 1:size(col, 2))
        cm(i) = color_get_max_value1 (col(:,i))
     end forall
     cmax = maxval (cm)
   end function color_get_max_value2
 
 @ %def color_get_max_value
 @
 \subsection{Comparisons}
 Similar to helicities, colors match if they are equal, or if either
 one is undefined.
 <<Colors: color: TBP>>=
   generic :: operator(.match.) => color_match
   generic :: operator(==) => color_eq
   generic :: operator(/=) => color_neq
   procedure, private ::  color_match
   procedure, private ::  color_eq
   procedure, private ::  color_neq
 @ %def .match. == /=
 <<Colors: procedures>>=
   elemental function color_match (col1, col2) result (eq)
     logical :: eq
     class(color_t), intent(in) :: col1, col2
     if (col1%defined .and. col2%defined) then
        if (col1%ghost .and. col2%ghost) then
           eq = .true.
        else if (.not. col1%ghost .and. .not. col2%ghost) then
           eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2)
        else
           eq = .false.
        end if
     else
        eq = .true.
     end if
   end function color_match
 
   elemental function color_eq (col1, col2) result (eq)
     logical :: eq
     class(color_t), intent(in) :: col1, col2
     if (col1%defined .and. col2%defined) then
        if (col1%ghost .and. col2%ghost) then
           eq = .true.
        else if (.not. col1%ghost .and. .not. col2%ghost) then
           eq = all (col1%c1 == col2%c1) .and. all (col1%c2 == col2%c2)
        else
           eq = .false.
        end if
     else if (.not. col1%defined &
        .and. .not. col2%defined) then
        eq = col1%ghost .eqv. col2%ghost
     else
        eq = .false.
     end if
   end function color_eq
 
 @ %def color_eq
 <<Colors: procedures>>=
   elemental function color_neq (col1, col2) result (neq)
     logical :: neq
     class(color_t), intent(in) :: col1, col2
     if (col1%defined .and. col2%defined) then
        if (col1%ghost .and. col2%ghost) then
           neq = .false.
        else if (.not. col1%ghost .and. .not. col2%ghost) then
           neq = any (col1%c1 /= col2%c1) .or. any (col1%c2 /= col2%c2)
        else
           neq = .true.
        end if
     else if (.not. col1%defined &
          .and. .not. col2%defined) then
        neq = col1%ghost .neqv. col2%ghost
     else
        neq = .true.
     end if
   end function color_neq
 
 @ %def color_neq
 @
 \subsection{Tools}
 Shift color indices by a common offset.
 <<Colors: color: TBP>>=
   procedure :: add_offset => color_add_offset
 <<Colors: procedures>>=
   elemental subroutine color_add_offset (col, offset)
     class(color_t), intent(inout) :: col
     integer, intent(in) :: offset
     if (col%defined .and. .not. col%ghost) then
        where (col%c1 /= 0)  col%c1 = col%c1 + sign (offset, col%c1)
        where (col%c2 /= 0)  col%c2 = col%c2 + sign (offset, col%c2)
     end if
   end subroutine color_add_offset
 
 @ %def color_add_offset
 @ Reassign color indices for an array of colored particle in canonical
 order.  The allocated size of the color map is such that two colors
 per particle can be accomodated.
 
 The algorithm works directly on the contents of the color objects, it
 <<Colors: public>>=
   public :: color_canonicalize
 <<Colors: procedures>>=
   subroutine color_canonicalize (col)
     type(color_t), dimension(:), intent(inout) :: col
     integer, dimension(2*size(col)) :: map
     integer :: n_col, i, j, k
     n_col = 0
     do i = 1, size (col)
        if (col(i)%defined .and. .not. col(i)%ghost) then
           do j = 1, size (col(i)%c1)
              if (col(i)%c1(j) /= 0) then
                 k = find (abs (col(i)%c1(j)), map(:n_col))
                 if (k == 0) then
                    n_col = n_col + 1
                    map(n_col) = abs (col(i)%c1(j))
                    k = n_col
                 end if
                 col(i)%c1(j) = sign (k, col(i)%c1(j))
              end if
              if (col(i)%c2(j) /= 0) then
                 k = find (abs (col(i)%c2(j)), map(:n_col))
                 if (k == 0) then
                    n_col = n_col + 1
                    map(n_col) = abs (col(i)%c2(j))
                    k = n_col
                 end if
                 col(i)%c2(j) = sign (k, col(i)%c2(j))
              end if
           end do
        end if
     end do
   contains
     function find (c, array) result (k)
       integer :: k
       integer, intent(in) :: c
       integer, dimension(:), intent(in) :: array
       integer :: i
       k = 0
       do i = 1, size (array)
          if (c == array (i)) then
             k = i
             return
          end if
       end do
     end function find
   end subroutine color_canonicalize
 
 @ %def color_canonicalize
 @ Return an array of different color indices from an array of colors.
 The last argument is a pseudo-color array, where the color entries
 correspond to the position of the corresponding index entry in the
 index array.  The colors are assumed to be diagonal.
 
 The algorithm works directly on the contents of the color objects.
 <<Colors: procedures>>=
   subroutine extract_color_line_indices (col, c_index, col_pos)
     type(color_t), dimension(:), intent(in) :: col
     integer, dimension(:), intent(out), allocatable :: c_index
     type(color_t), dimension(size(col)), intent(out) :: col_pos
     integer, dimension(:), allocatable :: c_tmp
     integer :: i, j, k, n, c
     allocate (c_tmp (sum (col%get_number_of_indices ())), source=0)
     n = 0
     SCAN1: do i = 1, size (col)
        if (col(i)%defined .and. .not. col(i)%ghost) then
           SCAN2: do j = 1, 2
              c = abs (col(i)%c1(j))
              if (c /= 0) then
                 do k = 1, n
                    if (c_tmp(k) == c) then
                       col_pos(i)%c1(j) = k
                       cycle SCAN2
                    end if
                 end do
                 n = n + 1
                 c_tmp(n) = c
                 col_pos(i)%c1(j) = n
              end if
           end do SCAN2
        end if
     end do SCAN1
     allocate (c_index (n))
     c_index = c_tmp(1:n)
   end subroutine extract_color_line_indices
 
 @ %def extract_color_line_indices
 @ Given a color array, pairwise contract the color lines in all
 possible ways and return the resulting array of arrays.  The input
 color array must be diagonal, and each color should occur exactly
 twice, once as color and once as anticolor.
 
 Gluon entries with equal color and anticolor are explicitly excluded.
 
 This algorithm is generic, but for long arrays it is neither
 efficient, nor does it avoid duplicates.  It is intended for small
 arrays, in particular for the state matrix of a structure-function
 pair.
 
 The algorithm works directly on the contents of the color objects, it
 thus depends on the implementation.
 <<Colors: public>>=
   public :: color_array_make_contractions
 <<Colors: procedures>>=
   subroutine color_array_make_contractions (col_in, col_out)
     type(color_t), dimension(:), intent(in) :: col_in
     type(color_t), dimension(:,:), intent(out), allocatable :: col_out
     type :: entry_t
        integer, dimension(:), allocatable :: map
        type(color_t), dimension(:), allocatable :: col
        type(entry_t), pointer :: next => null ()
        logical :: nlo_event = .false.
     end type entry_t
     type :: list_t
        integer :: n = 0
        type(entry_t), pointer :: first => null ()
        type(entry_t), pointer :: last => null ()
     end type list_t
     type(list_t) :: list
     type(entry_t), pointer :: entry
     integer, dimension(:), allocatable :: c_index
     type(color_t), dimension(size(col_in)) :: col_pos
     integer :: n_prt, n_c_index
     integer, dimension(:), allocatable :: map
     integer :: i, j, c
     n_prt = size (col_in)
     call extract_color_line_indices (col_in, c_index, col_pos)
     n_c_index = size (c_index)
     allocate (map (n_c_index))
     map = 0
     call list_append_if_valid (list, map)
     entry => list%first
     do while (associated (entry))
        do i = 1, n_c_index
           if (entry%map(i) == 0) then
              c = c_index(i)
              do j = i + 1, n_c_index
                 if (entry%map(j) == 0) then
                    map = entry%map
                    map(i) = c
                    map(j) = c
                    call list_append_if_valid (list, map)
                 end if
              end do
           end if
        end do
        entry => entry%next
     end do
     call list_to_array (list, col_out)
   contains
     subroutine list_append_if_valid (list, map)
       type(list_t), intent(inout) :: list
       integer, dimension(:), intent(in) :: map
       type(entry_t), pointer :: entry
       integer :: i, j, c, p
       entry => list%first
       do while (associated (entry))
          if (all (map == entry%map))  return
          entry => entry%next
       end do
       allocate (entry)
       allocate (entry%map (n_c_index))
       entry%map = map
       allocate (entry%col (n_prt))
       do i = 1, n_prt
          do j = 1, 2
             c = col_in(i)%c1(j)
             if (c /= 0) then
                p = col_pos(i)%c1(j)
                entry%col(i)%defined = .true.
                if (map(p) /= 0) then
                   entry%col(i)%c1(j) = sign (map(p), c)
                else
                   entry%col(i)%c1(j) = c
                endif
                entry%col(i)%c2(j) = entry%col(i)%c1(j)
             end if
          end do
          if (any (entry%col(i)%c1 /= 0) .and. &
               entry%col(i)%c1(1) == - entry%col(i)%c1(2))  return
       end do
       if (associated (list%last)) then
          list%last%next => entry
       else
          list%first => entry
       end if
       list%last => entry
       list%n = list%n + 1
     end subroutine list_append_if_valid
     subroutine list_to_array (list, col)
       type(list_t), intent(inout) :: list
       type(color_t), dimension(:,:), intent(out), allocatable :: col
       type(entry_t), pointer :: entry
       integer :: i
       allocate (col (n_prt, list%n - 1))
       do i = 0, list%n - 1
          entry => list%first
          list%first => list%first%next
          if (i /= 0)  col(:,i) = entry%col
          deallocate (entry)
       end do
       list%last => null ()
     end subroutine list_to_array
   end subroutine color_array_make_contractions
 
 @ %def color_array_make_contractions
 @ Invert the color index, switching from particle to antiparticle.
 For gluons, we have to swap the order of color entries.
 <<Colors: color: TBP>>=
   procedure :: invert => color_invert
 <<Colors: procedures>>=
   elemental subroutine color_invert (col)
     class(color_t), intent(inout) :: col
     if (col%defined .and. .not. col%ghost) then
        col%c1 = - col%c1
        col%c2 = - col%c2
        if (col%c1(1) < 0 .and. col%c1(2) > 0) then
           col%c1 = col%c1(2:1:-1)
           col%c2 = col%c2(2:1:-1)
        end if
     end if
   end subroutine color_invert
 
 @ %def color_invert
 @ Make a color map for two matching color arrays.  The result is an
 array of integer pairs.
 <<Colors: public>>=
   public :: make_color_map
 <<Colors: interfaces>>=
   interface make_color_map
      module procedure color_make_color_map
   end interface make_color_map
 
 <<Colors: procedures>>=
   subroutine color_make_color_map (map, col1, col2)
     integer, dimension(:,:), intent(out), allocatable :: map
     type(color_t), dimension(:), intent(in) :: col1, col2
     integer, dimension(:,:), allocatable :: map1
     integer :: i, j, k
     allocate (map1 (2, 2 * sum (col1%get_number_of_indices ())))
     k = 0
     do i = 1, size (col1)
        if (col1(i)%defined .and. .not. col1(i)%ghost) then
           do j = 1, size (col1(i)%c1)
              if (col1(i)%c1(j) /= 0 &
                   .and. all (map1(1,:k) /= abs (col1(i)%c1(j)))) then
                 k = k + 1
                 map1(1,k) = abs (col1(i)%c1(j))
                 map1(2,k) = abs (col2(i)%c1(j))
              end if
              if (col1(i)%c2(j) /= 0 &
                   .and. all (map1(1,:k) /= abs (col1(i)%c2(j)))) then
                 k = k + 1
                 map1(1,k) = abs (col1(i)%c2(j))
                 map1(2,k) = abs (col2(i)%c2(j))
              end if
           end do
        end if
     end do
     allocate (map (2, k))
     map(:,:) = map1(:,:k)
   end subroutine color_make_color_map
 
 @ %def make_color_map
 @ Translate colors which have a match in the translation table (an
 array of integer pairs).  Color that do not match an entry are simply
 transferred; this is done by first transferring all components, then
 modifiying entries where appropriate.
 <<Colors: public>>=
   public :: color_translate
 <<Colors: interfaces>>=
   interface color_translate
      module procedure color_translate0
      module procedure color_translate0_offset
      module procedure color_translate1
   end interface color_translate
 
 <<Colors: procedures>>=
   subroutine color_translate0 (col, map)
     type(color_t), intent(inout) :: col
     integer, dimension(:,:), intent(in) :: map
     type(color_t) :: col_tmp
     integer :: i
     if (col%defined .and. .not. col%ghost) then
        col_tmp = col
        do i = 1, size (map,2)
           where (abs (col%c1) == map(1,i))
              col_tmp%c1 = sign (map(2,i), col%c1)
           end where
           where (abs (col%c2) == map(1,i))
              col_tmp%c2 = sign (map(2,i), col%c2)
           end where
        end do
        col = col_tmp
     end if
   end subroutine color_translate0
 
   subroutine color_translate0_offset (col, map, offset)
     type(color_t), intent(inout) :: col
     integer, dimension(:,:), intent(in) :: map
     integer, intent(in) :: offset
     logical, dimension(size(col%c1)) :: mask1, mask2
     type(color_t) :: col_tmp
     integer :: i
     if (col%defined .and. .not. col%ghost) then
        col_tmp = col
        mask1 = col%c1 /= 0
        mask2 = col%c2 /= 0
        do i = 1, size (map,2)
           where (abs (col%c1) == map(1,i))
              col_tmp%c1 = sign (map(2,i), col%c1)
              mask1 = .false.
           end where
           where (abs (col%c2) == map(1,i))
              col_tmp%c2 = sign (map(2,i), col%c2)
              mask2 = .false.
           end where
        end do
        col = col_tmp
        where (mask1)  col%c1 = sign (abs (col%c1) + offset, col%c1)
        where (mask2)  col%c2 = sign (abs (col%c2) + offset, col%c2)
     end if
   end subroutine color_translate0_offset
 
   subroutine color_translate1 (col, map, offset)
     type(color_t), dimension(:), intent(inout) :: col
     integer, dimension(:,:), intent(in) :: map
     integer, intent(in), optional :: offset
     integer :: i
     if (present (offset)) then
        do i = 1, size (col)
           call color_translate0_offset (col(i), map, offset)
        end do
     else
        do i = 1, size (col)
           call color_translate0 (col(i), map)
        end do
     end if
   end subroutine color_translate1
 
 @ %def color_translate
 @ Merge two color objects by taking the first entry from the first and
 the first entry from the second argument.  Makes sense only if the
 input colors are defined (and diagonal).  If either one is undefined,
 transfer the defined one.
 <<Colors: color: TBP>>=
   generic :: operator(.merge.) => merge_colors
   procedure, private ::  merge_colors
 @ %def .merge.
 <<Colors: procedures>>=
   elemental function merge_colors (col1, col2) result (col)
     type(color_t) :: col
     class(color_t), intent(in) :: col1, col2
     if (color_is_defined (col1) .and. color_is_defined (col2)) then
        if (color_is_ghost (col1) .and. color_is_ghost (col2)) then
           call color_init_trivial_ghost (col, .true.)
        else
           call color_init_arrays (col, col1%c1, col2%c1)
        end if
     else if (color_is_defined (col1)) then
        call color_init_array (col, col1%c1)
     else if (color_is_defined (col2)) then
        call color_init_array (col, col2%c1)
     end if
   end function merge_colors
 
 @ %def merge_colors
 @ Merge up to two (diagonal!) color objects.  The result inherits the unmatched
 color lines of the input colors.  If one of the input colors is
 undefined, the output is undefined as well.  It must be in a supported
 color representation.
 
 A color-ghost object should not actually occur in real-particle
 events, but for completeness we define its behavior.  For simplicity,
 it is identified as a color-octet with zero color/anticolor.  It can
 only couple to a triplet or antitriplet.  A fusion of triplet with
 matching antitriplet will yield a singlet, not a ghost, however.
 
 If the fusion fails, the result is undefined.
 <<Colors: color: TBP>>=
   generic :: operator (.fuse.) => color_fusion
   procedure, private :: color_fusion
 <<Colors: procedures>>=
   function color_fusion (col1, col2) result (col)
     class(color_t), intent(in) :: col1, col2
     type(color_t) :: col
     integer, dimension(2) :: ctype
     if (col1%is_defined () .and. col2%is_defined ()) then
        if (col1%is_diagonal () .and. col2%is_diagonal ()) then
           ctype = [col1%get_type (), col2%get_type ()]
           select case (ctype(1))
           case (1)
              select case (ctype(2))
              case (1,3,-3,8)
                 col = col2
              end select
           case (3)
              select case (ctype(2))
              case (1)
                 col = col1
              case (-3)
                 call t_a (col1%get_col (), col2%get_acl ())
              case (8)
                 call t_o (col1%get_col (), col2%get_acl (), &
                      &    col2%get_col ())
              end select
           case (-3)
              select case (ctype(2))
              case (1)
                 col = col1
              case (3)
                 call t_a (col2%get_col (), col1%get_acl ())
              case (8)
                 call a_o (col1%get_acl (), col2%get_col (), &
                      &    col2%get_acl ())
              end select
           case (8)
              select case (ctype(2))
              case (1)
                 col = col1
              case (3)
                 call t_o (col2%get_col (), col1%get_acl (), &
                      &    col1%get_col ())
              case (-3)
                 call a_o (col2%get_acl (), col1%get_col (), &
                      &    col1%get_acl ())
              case (8)
                 call o_o (col1%get_col (), col1%get_acl (), &
                      &    col2%get_col (), col2%get_acl ())
              end select
           end select
        end if
     end if
   contains
     subroutine t_a (c1, c2)
       integer, intent(in) :: c1, c2
       if (c1 == c2) then
          call col%init_col_acl (0, 0)
       else
          call col%init_col_acl (c1, c2)
       end if
     end subroutine t_a
     subroutine t_o (c1, c2, c3)
       integer, intent(in) :: c1, c2, c3
       if (c1 == c2) then
          call col%init_col_acl (c3, 0)
       else if (c2 == 0 .and. c3 == 0) then
          call col%init_col_acl (c1, 0)
       end if
     end subroutine t_o
     subroutine a_o (c1, c2, c3)
       integer, intent(in) :: c1, c2, c3
       if (c1 == c2) then
          call col%init_col_acl (0, c3)
       else if (c2 == 0 .and. c3 == 0) then
          call col%init_col_acl (0, c1)
       end if
     end subroutine a_o
     subroutine o_o (c1, c2, c3, c4)
       integer, intent(in) :: c1, c2, c3, c4
       if (all ([c1,c2,c3,c4] /= 0)) then
          if (c2 == c3 .and. c4 == c1) then
             call col%init_col_acl (0, 0)
          else if (c2 == c3) then
             call col%init_col_acl (c1, c4)
          else if (c4 == c1) then
             call col%init_col_acl (c3, c2)
          end if
       end if
     end subroutine o_o
   end function color_fusion
 
 @ %def color_fusion
 @ Compute the color factor, given two interfering color arrays.
 <<Colors: public>>=
   public :: compute_color_factor
 <<Colors: procedures>>=
   function compute_color_factor (col1, col2, nc) result (factor)
     real(default) :: factor
     type(color_t), dimension(:), intent(in) :: col1, col2
     integer, intent(in), optional :: nc
     type(color_t), dimension(size(col1)) :: col
     integer :: ncol, nloops, nghost
     ncol = 3;  if (present (nc))  ncol = nc
     col = col1 .merge. col2
     nloops = count_color_loops (col)
     nghost = count (col%is_ghost ())
     factor = real (ncol, default) ** (nloops - nghost)
     if (color_ghost_parity (col))  factor = - factor
   end function compute_color_factor
 
 @ %def compute_color_factor
 @
 We have a pair of color index arrays which corresponds to a squared
 matrix element.  We want to determine the number of color loops in
 this square matrix element.  So we first copy the colors (stored in a
 single color array with a pair of color lists in each entry) to a
 temporary where the color indices are shifted by some offset.  We then
 recursively follow each loop, starting at the first color that has the
 offset, resetting the first color index to the loop index and each
 further index to zero as we go.  We check that (a) each color index
 occurs twice within the left (right) color array, (b) the loops are
 closed, so we always come back to a line which has the loop index.
 
 In order for the algorithm to work we have to conjugate the colors of
 initial state particles (one for decays, two for scatterings) into
 their corresponding anticolors of outgoing particles.
 <<Colors: public>>=
   public :: count_color_loops
 <<Colors: procedures>>=
   function count_color_loops (col) result (count)
     integer :: count
     type(color_t), dimension(:), intent(in) :: col
     type(color_t), dimension(size(col)) :: cc
     integer :: i, n, offset
     cc = col
     n = size (cc)
     offset = n
     call color_add_offset (cc, offset)
     count = 0
     SCAN_LOOPS: do
        do i = 1, n
           if (color_is_nonzero (cc(i))) then
              if (any (cc(i)%c1 > offset)) then
                 count = count + 1
                 call follow_line1 (pick_new_line (cc(i)%c1, count, 1))
                 cycle SCAN_LOOPS
              end if
           end if
        end do
        exit SCAN_LOOPS
     end do SCAN_LOOPS
   contains
     function pick_new_line (c, reset_val, sgn) result (line)
       integer :: line
       integer, dimension(:), intent(inout) :: c
       integer, intent(in) :: reset_val
       integer, intent(in) :: sgn
       integer :: i
       if (any (c == count)) then
          line = count
       else
          do i = 1, size (c)
             if (sign (1, c(i)) == sgn .and. abs (c(i)) > offset) then
                line = c(i)
                c(i) = reset_val
                return
             end if
          end do
          call color_mismatch
       end if
     end function pick_new_line
 
     subroutine reset_line (c, line)
       integer, dimension(:), intent(inout) :: c
       integer, intent(in) :: line
       integer :: i
       do i = 1, size (c)
          if (c(i) == line) then
             c(i) = 0
             return
          end if
       end do
     end subroutine reset_line
 
     recursive subroutine follow_line1 (line)
       integer, intent(in) :: line
       integer :: i
       if (line == count) return
       do i = 1, n
          if (any (cc(i)%c1 == -line)) then
             call reset_line (cc(i)%c1, -line)
             call follow_line2 (pick_new_line (cc(i)%c2, 0, sign (1, -line)))
             return
          end if
       end do
       call color_mismatch ()
     end subroutine follow_line1
 
     recursive subroutine follow_line2 (line)
       integer, intent(in) :: line
       integer :: i
       do i = 1, n
          if (any (cc(i)%c2 == -line)) then
             call reset_line (cc(i)%c2, -line)
             call follow_line1 (pick_new_line (cc(i)%c1, 0, sign (1, -line)))
             return
          end if
       end do
       call color_mismatch ()
     end subroutine follow_line2
 
     subroutine color_mismatch ()
       call color_write (col)
       print *
       call msg_fatal ("Color flow mismatch: Non-closed color lines appear during ", &
          [var_str ("the evaluation of color correlations. This can happen if there "), &
           var_str ("are different color structures in the initial or final state of "), &
           var_str ("the process definition. If so, please use separate processes for "), &
           var_str ("the different initial / final states. In a future WHIZARD version "), &
           var_str ("this will be fixed.")])
     end subroutine color_mismatch
   end function count_color_loops
 
 @ %def count_color_loops
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[colors_ut.f90]]>>=
 <<File header>>
 
 module colors_ut
   use unit_tests
   use colors_uti
 
 <<Standard module head>>
 
 <<Colors: public test>>
 
 contains
 
 <<Colors: test driver>>
 
 end module colors_ut
 @ %def colors_ut
 @
 <<[[colors_uti.f90]]>>=
 <<File header>>
 
 module colors_uti
 
   use colors
 
 <<Standard module head>>
 
 <<Colors: test declarations>>
 
 contains
 
 <<Colors: tests>>
 
 end module colors_uti
 @ %def colors_ut
 @ API: driver for the unit tests below.
 <<Colors: public test>>=
   public :: color_test
 <<Colors: test driver>>=
   subroutine color_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Colors: execute tests>>
   end subroutine color_test
 
 @ %def color_test
 @ This is a color counting test.
 <<Colors: execute tests>>=
   call test (color_1, "color_1", &
        "check color counting", &
        u, results)
 <<Colors: test declarations>>=
   public :: color_1
 <<Colors: tests>>=
   subroutine color_1 (u)
     integer, intent(in) :: u
     type(color_t), dimension(4) :: col1, col2, col
     type(color_t), dimension(:), allocatable :: col3
     type(color_t), dimension(:,:), allocatable :: col_array
     integer :: count, i
     call col1%init_col_acl ([1, 0, 2, 3], [0, 1, 3, 2])
     col2 = col1
     call color_write (col1, u)
     write (u, "(A)")
     call color_write (col2, u)
     write (u, "(A)")
     col = col1 .merge. col2
     call color_write (col, u)
     write (u, "(A)")
     count = count_color_loops (col)
     write (u, "(A,I1)") "Number of color loops (3): ", count
     call col2%init_col_acl ([1, 0, 2, 3], [0, 2, 3, 1])
     call color_write (col1, u)
     write (u, "(A)")
     call color_write (col2, u)
     write (u, "(A)")
     col = col1 .merge. col2
     call color_write (col, u)
     write (u, "(A)")
     count = count_color_loops (col)
     write (u, "(A,I1)")  "Number of color loops (2): ", count
     write (u, "(A)")
     allocate (col3 (4))
     call color_init_from_array (col3, &
          reshape ([1, 0,   0, -1,  2, -3,  3, -2], &
                   [2, 4]))
     call color_write (col3, u)
     write (u, "(A)")
     call color_array_make_contractions (col3, col_array)
     write (u, "(A)")  "Contractions:"
     do i = 1, size (col_array, 2)
        call color_write (col_array(:,i), u)
        write (u, "(A)")
     end do
     deallocate (col3)
     write (u, "(A)")
     allocate (col3 (6))
     call color_init_from_array (col3, &
          reshape ([1, -2,   3, 0,  0, -1,  2, -4,  -3, 0,  4, 0], &
                   [2, 6]))
     call color_write (col3, u)
     write (u, "(A)")
     call color_array_make_contractions (col3, col_array)
     write (u, "(A)")  "Contractions:"
     do i = 1, size (col_array, 2)
        call color_write (col_array(:,i), u)
        write (u, "(A)")
     end do
   end subroutine color_1
 
 @ %def color_1
 @ A color fusion test.
 <<Colors: execute tests>>=
   call test (color_2, "color_2", &
        "color fusion", &
        u, results)
 <<Colors: test declarations>>=
   public :: color_2
 <<Colors: tests>>=
   subroutine color_2 (u)
     integer, intent(in) :: u
     type(color_t) :: s1, t1, t2, a1, a2, o1, o2, o3, o4, g1
 
     write (u, "(A)")  "* Test output: color_2"
     write (u, "(A)")  "*   Purpose: test all combinations for color-object fusion"
     write (u, "(A)")
 
     call s1%init_col_acl (0,0)
     call t1%init_col_acl (1,0)
     call t2%init_col_acl (2,0)
     call a1%init_col_acl (0,1)
     call a2%init_col_acl (0,2)
     call o1%init_col_acl (1,2)
     call o2%init_col_acl (1,3)
     call o3%init_col_acl (2,3)
     call o4%init_col_acl (2,1)
     call g1%init (ghost=.true.)
 
     call wrt ("s1", s1)
     call wrt ("t1", t1)
     call wrt ("t2", t2)
     call wrt ("a1", a1)
     call wrt ("a2", a2)
     call wrt ("o1", o1)
     call wrt ("o2", o2)
     call wrt ("o3", o3)
     call wrt ("o4", o4)
     call wrt ("g1", g1)
 
     write (u, *)
 
     call wrt ("s1 * s1", s1 .fuse. s1)
 
     write (u, *)
 
     call wrt ("s1 * t1", s1 .fuse. t1)
     call wrt ("s1 * a1", s1 .fuse. a1)
     call wrt ("s1 * o1", s1 .fuse. o1)
 
     write (u, *)
 
     call wrt ("t1 * s1", t1 .fuse. s1)
     call wrt ("a1 * s1", a1 .fuse. s1)
     call wrt ("o1 * s1", o1 .fuse. s1)
 
     write (u, *)
 
     call wrt ("t1 * t1", t1 .fuse. t1)
 
     write (u, *)
 
     call wrt ("t1 * t2", t1 .fuse. t2)
     call wrt ("t1 * a1", t1 .fuse. a1)
     call wrt ("t1 * a2", t1 .fuse. a2)
     call wrt ("t1 * o1", t1 .fuse. o1)
     call wrt ("t2 * o1", t2 .fuse. o1)
 
     write (u, *)
 
     call wrt ("t2 * t1", t2 .fuse. t1)
     call wrt ("a1 * t1", a1 .fuse. t1)
     call wrt ("a2 * t1", a2 .fuse. t1)
     call wrt ("o1 * t1", o1 .fuse. t1)
     call wrt ("o1 * t2", o1 .fuse. t2)
 
     write (u, *)
 
     call wrt ("a1 * a1", a1 .fuse. a1)
 
     write (u, *)
 
     call wrt ("a1 * a2", a1 .fuse. a2)
     call wrt ("a1 * o1", a1 .fuse. o1)
     call wrt ("a2 * o2", a2 .fuse. o2)
 
     write (u, *)
 
     call wrt ("a2 * a1", a2 .fuse. a1)
     call wrt ("o1 * a1", o1 .fuse. a1)
     call wrt ("o2 * a2", o2 .fuse. a2)
 
     write (u, *)
 
     call wrt ("o1 * o1", o1 .fuse. o1)
 
     write (u, *)
 
     call wrt ("o1 * o2", o1 .fuse. o2)
     call wrt ("o1 * o3", o1 .fuse. o3)
     call wrt ("o1 * o4", o1 .fuse. o4)
 
     write (u, *)
 
     call wrt ("o2 * o1", o2 .fuse. o1)
     call wrt ("o3 * o1", o3 .fuse. o1)
     call wrt ("o4 * o1", o4 .fuse. o1)
 
     write (u, *)
 
     call wrt ("g1 * g1", g1 .fuse. g1)
 
     write (u, *)
 
     call wrt ("g1 * s1", g1 .fuse. s1)
     call wrt ("g1 * t1", g1 .fuse. t1)
     call wrt ("g1 * a1", g1 .fuse. a1)
     call wrt ("g1 * o1", g1 .fuse. o1)
 
     write (u, *)
 
     call wrt ("s1 * g1", s1 .fuse. g1)
     call wrt ("t1 * g1", t1 .fuse. g1)
     call wrt ("a1 * g1", a1 .fuse. g1)
     call wrt ("o1 * g1", o1 .fuse. g1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: color_2"
 
   contains
 
     subroutine wrt (s, col)
       character(*), intent(in) :: s
       class(color_t), intent(in) :: col
       write (u, "(A,1x,'=',1x)", advance="no")  s
       call col%write (u)
       write (u, *)
     end subroutine wrt
 
   end subroutine color_2
 
 @ %def color_2
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \subsection{The Madgraph color model}
 This section describes the method for matrix element and color
 flow calculation within Madgraph.
 
 For each Feynman diagram, the colorless amplitude for a specified
 helicity and momentum configuration (in- and out- combined) is
 computed:
 \begin{equation}
   A_d(p,h)
 \end{equation}
 Inserting color, the squared matrix element for definite helicity and
 momentum is
 \begin{equation}
   M^2(p,h) = \sum_{dd'} A_{d}(p,h)\,C_{dd'} A_{d'}^*(p,h)
 \end{equation}
 where $C_{dd'}$ describes the color interference of the two diagrams
 $A_d$ and $A_d'$, which is independent of momentum and helicity and
 can be calculated for each Feynman diagram pair by reducing it to the
 corresponding color graph.  Obviously, one could combine all diagrams
 with identical color structure, such that the index $d$ runs only over
 different color graphs.  For colorless diagrams all elements of
 $C_{dd'}$ are equal to unity.
 
 The hermitian matrix $C_{dd'}$ is diagonalized once and for all, such
 that it can be written in the form
 \begin{equation}
   C_{dd'} = \sum_\lambda c_d^\lambda \lambda\, c_d^\lambda{}^*,
 \end{equation}
 where the eigenvectors $c_d$ are normalized,
 \begin{equation}
   \sum_d |c_d^\lambda|^2 = 1,
 \end{equation}
 and the $\lambda$ values are the corresponding eigenvalues.  In the
 colorless case, this means $c_d = 1/\sqrt{N_d}$ for all diagrams
 ($N_d=$ number of diagrams), and $\lambda=N_d$ is the only nonzero
 eigenvalue.
 
 Consequently, the squared matrix element for definite helicity and
 momentum can also be written as
 \begin{equation}
   M^2(p,h) = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h)^*
 \end{equation}
 with
 \begin{equation}
   A_\lambda(p,h) = \sum_d c_d^\lambda A_d(p,h).
 \end{equation}
 For generic spin density matrices, this is easily generalized to
 \begin{equation}
   M^2(p,h,h') = \sum_\lambda A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^*
 \end{equation}
 
 To determine the color flow probabilities of a given momentum-helicity
 configuration, the color flow amplitudes are calculated as
 \begin{equation}
   a_f(p,h) = \sum_d \beta^f_d A_d(p,h),
 \end{equation}
 where the coefficients $\beta^f_d$ describe the amplitude for a given
 Feynman diagram (or color graph) $d$ to correspond to a definite color
 flow~$f$.  They are computed from $C_{dd'}$ by transforming this
 matrix into the color flow basis and neglecting all off-diagonal
 elements.  Again, these coefficients do not depend on momentum or
 helicity and can therefore be calculated in advance.  This gives the
 color flow transition matrix
 \begin{equation}
   F^f(p,h,h') = a_f(p,h)\, a^*_f(p,h')
 \end{equation}
 which is assumed diagonal in color flow space and is separate from the
 color-summed transition matrix $M^2$.  They are, however, equivalent
 (up to a factor) to leading order in $1/N_c$, and using the color flow
 transition matrix is appropriate for matching to hadronization.
 
 Note that the color flow transition matrix is not normalized at this
 stage.  To make use of it, we have to fold it with the in-state
 density matrix to get a pseudo density matrix
 \begin{equation}
   \hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})
   = \sum_{h_{\rm in} h'_{\rm in}} F^f(p,h,h')\,
     \rho_{\rm in}(p,h_{\rm in},h'_{\rm in})
 \end{equation}
 which gets a meaning only after contracted with projections on the
 outgoing helicity states $k_{\rm out}$, given as linear combinations
 of helicity states with the unitary coefficient matrix $c(k_{\rm out},
 h_{\rm out})$.  Then the probability of finding color flow $f$ when
 the helicity state $k_{\rm out}$ is measured is given by
 \begin{equation}
   P^f(p, k_{\rm out}) = Q^f(p, k_{\rm out}) / \sum_f Q^f(p, k_{\rm out})
 \end{equation}
 where
 \begin{equation}
   Q^f(p, k_{\rm out}) = \sum_{h_{\rm out} h'_{\rm out}}
     c(k_{\rm out}, h_{\rm out})\,
     \hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})\,
     c^*(k_{\rm out}, h'_{\rm out})
 \end{equation}
 However, if we can assume that the out-state helicity basis is the
 canonical one, we can throw away the off diagonal elements in the
 color flow density matrix and normalize the ones on the diagonal to obtain
 \begin{equation}
   P^f(p, h_{\rm out}) =
     \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out}) /
     \sum_f \hat\rho_{\rm out}^f(p,h_{\rm out},h_{\rm out})
 \end{equation}
 
 Finally, the color-summed out-state density matrix is computed by the
 scattering formula
 \begin{align}
   {\rho_{\rm out}(p,h_{\rm out},h'_{\rm out})}
   &=
     \sum_{h_{\rm in} h'_{\rm in}} M^2(p,h,h')\,
     \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}) \\
   &= \sum_{h_{\rm in} h'_{\rm in} \lambda}
      A_\lambda(p,h)\, \lambda\, A_\lambda(p,h')^*
      \rho_{\rm in}(p,h_{\rm in},h'_{\rm in}),
 \end{align}
 The trace of $\rho_{\rm out}$ is the squared matrix element, summed
 over all internal degrees of freedom.  To get the squared matrix
 element for a definite helicity $k_{\rm out}$ and color flow $f$, one
 has to project the density matrix onto the given helicity state and
 multiply with $P^f(p, k_{\rm out})$.
 
 For diagonal helicities the out-state density reduces to
 \begin{equation}
   \rho_{\rm out}(p,h_{\rm out})
   = \sum_{h_{\rm in}\lambda}
      \lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}).
 \end{equation}
 Since no basis transformation is involved, we can use the normalized
 color flow probability $P^f(p, h_{\rm out})$ and express the result as
 \begin{align}
   \rho_{\rm out}^f(p,h_{\rm out})
   &= \rho_{\rm out}(p,h_{\rm out})\,P^f(p, h_{\rm out}) \\
   &= \sum_{h_{\rm in}\lambda}
      \frac{|a^f(p,h)|^2}{\sum_f|a^f(p,h)|^2}
      \lambda|A_\lambda(p,h)|^2 \rho_{\rm in}(p,h_{\rm in}).
 \end{align}
 
 From these considerations, the following calculation strategy can be
 derived:
 \begin{itemize}
 \item
   Before the first event is generated, the color interference matrix
   $C_{dd'}$ is computed and diagonalized, so the eigenvectors
   $c^\lambda_d$, eigenvalues $\lambda$ and color flow coefficients
   $\beta^f_d$ are obtained.  In practice, these calculations are
   done when the matrix element code is generated, and the results are
   hardcoded in the matrix element subroutine as [[DATA]] statements.
 \item
   For each event, one loops over helicities once and stores the
   matrices $A_\lambda(p,h)$ and $a^f(p,h)$.  The allowed color flows,
   helicity combinations and eigenvalues are each labeled by integer
   indices, so one has to store complex matrices of dimension
   $N_\lambda\times N_h$ and $N_f\times N_h$, respectively.
 \item
   The further strategy depends on the requested information.
   \begin{enumerate}
   \item
     If colorless diagonal helicity amplitudes are required, the
     eigenvalues $A_\lambda(p,h)$ are squared, summed with weight
     $\lambda$, and the result contracted with the in-state probability
     vector $\rho_{\rm in}(p, h_{\rm in})$.  The result is a
     probability vector $\rho_{\rm out}(p, h_{\rm out})$.
   \item
     For colored diagonal helicity amplitudes, the color coefficients
     $a^f(p,h)$ are also squared and used as weights to obtain the color-flow
     probability vector $\rho_{\rm out}^f(p, h_{\rm out})$.
   \item
     For colorless non-diagonal helicity amplitudes, we contract the
     tensor product of $A_\lambda(p,h)$ with $A_\lambda(p,h')$,
     weighted with $\lambda$, with the correlated in-state density
     matrix, to obtain a correlated out-state density matrix.
   \item
     In the general (colored, non-diagonal) case, we do the same as
     in the colorless case, but return the un-normalized color flow
     density matrix $\hat\rho_{\rm out}^f(p,h_{\rm out},h'_{\rm out})$
     in addition.  When the relevant helicity basis is known, the
     latter can be used by the caller program to determine flow
     probabilities.  (In reality, we assume the canonical basis and
     reduce the correlated out-state density to its diagonal immediately.)
   \end{enumerate}
 \end{itemize}
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Flavors: Particle properties}
 This module contains a type for holding the flavor code, and all
 functions that depend on the model, i.e., that determine particle
 properties.
 
 The PDG code is packed in a special [[flavor]] type.  (This prohibits
 meaningless operations, and it allows for a different implementation,
 e.g., some non-PDG scheme internally, if appropiate at some point.)
 
 There are lots of further particle properties that depend on the
 model.  Implementing a flyweight pattern, the associated field data
 object is to be stored in a central area, the [[flavor]] object just
 receives a pointer to this, so all queries can be delegated.
 <<[[flavors.f90]]>>=
 <<File header>>
 
 module flavors
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use diagnostics
   use physics_defs, only: UNDEFINED
   use physics_defs, only: INVALID
   use physics_defs, only: HADRON_REMNANT
   use physics_defs, only: HADRON_REMNANT_SINGLET
   use physics_defs, only: HADRON_REMNANT_TRIPLET
   use physics_defs, only: HADRON_REMNANT_OCTET
   use model_data
   use colors, only: color_t
 
 <<Standard module head>>
 
 <<Flavors: public>>
 
 <<Flavors: types>>
 
 <<Flavors: interfaces>>
 
 contains
 
 <<Flavors: procedures>>
 
 end module flavors
 @ %def flavors
 @
 \subsection{The flavor type}
 The flavor type is an integer representing the PDG code, or
 undefined (zero).  Negative codes represent antiflavors.  They should
 be used only for particles which do have a distinct antiparticle.
 
 The [[hard_process]] flag can be set for particles that are participating in
 the hard interaction.
 
 The [[radiated]] flag can be set for particles that are the result of
 a beam-structure interaction (hadron beam remnant, ISR photon, etc.),
 not of the hard interaction itself.
 
 Further properties of the given flavor can be retrieved via the
 particle-data pointer, if it is associated.
 <<Flavors: public>>=
   public :: flavor_t
 <<Flavors: types>>=
   type :: flavor_t
      private
      integer :: f = UNDEFINED
      logical :: hard_process = .false.
      logical :: radiated = .false.
      type(field_data_t), pointer :: field_data => null ()
    contains
    <<Flavors: flavor: TBP>>
   end type flavor_t
 
 @ %def flavor_t
 @ Initializer form.  If the model is assigned, the procedure is
 impure, therefore we have to define a separate array version.
 
 Note: The pure elemental subroutines can't have an intent(out) CLASS
 argument (because of the potential for an impure finalizer in a type
 extension), so we stick to intent(inout) and (re)set all components
 explicitly.
 <<Flavors: flavor: TBP>>=
   generic :: init => &
        flavor_init_empty, &
        flavor_init, &
        flavor_init_field_data, &
        flavor_init_model, &
        flavor_init_model_alt, &
        flavor_init_name_model
   procedure, private :: flavor_init_empty
   procedure, private :: flavor_init
   procedure, private :: flavor_init_field_data
   procedure, private :: flavor_init_model
   procedure, private :: flavor_init_model_alt
   procedure, private :: flavor_init_name_model
 <<Flavors: procedures>>=
   elemental subroutine flavor_init_empty (flv)
     class(flavor_t), intent(inout) :: flv
     flv%f = UNDEFINED
     flv%hard_process = .false.
     flv%radiated = .false.
     flv%field_data => null ()
   end subroutine flavor_init_empty
 
   elemental subroutine flavor_init (flv, f)
     class(flavor_t), intent(inout) :: flv
     integer, intent(in) :: f
     flv%f = f
     flv%hard_process = .false.
     flv%radiated = .false.
     flv%field_data => null ()
   end subroutine flavor_init
 
   impure elemental subroutine flavor_init_field_data (flv, field_data)
     class(flavor_t), intent(inout) :: flv
     type(field_data_t), intent(in), target :: field_data
     flv%f = field_data%get_pdg ()
     flv%hard_process = .false.
     flv%radiated = .false.
     flv%field_data => field_data
   end subroutine flavor_init_field_data
 
   impure elemental subroutine flavor_init_model (flv, f, model)
     class(flavor_t), intent(inout) :: flv
     integer, intent(in) :: f
     class(model_data_t), intent(in), target :: model
     flv%f = f
     flv%hard_process = .false.
     flv%radiated = .false.
     flv%field_data => model%get_field_ptr (f, check=.true.)
   end subroutine flavor_init_model
 
   impure elemental subroutine flavor_init_model_alt (flv, f, model, alt_model)
     class(flavor_t), intent(inout) :: flv
     integer, intent(in) :: f
     class(model_data_t), intent(in), target :: model, alt_model
     flv%f = f
     flv%hard_process = .false.
     flv%radiated = .false.
     flv%field_data => model%get_field_ptr (f, check=.false.)
     if (.not. associated (flv%field_data)) then
        flv%field_data => alt_model%get_field_ptr (f, check=.false.)
        if (.not. associated (flv%field_data)) then
           write (msg_buffer, "(A,1x,I0,1x,A,1x,A,1x,A,1x,A)") &
                "Particle with code", f, &
                "found neither in model", char (model%get_name ()), &
                "nor in model", char (alt_model%get_name ())
           call msg_fatal ()
        end if
     end if
   end subroutine flavor_init_model_alt
 
   impure elemental subroutine flavor_init_name_model (flv, name, model)
     class(flavor_t), intent(inout) :: flv
     type(string_t), intent(in) :: name
     class(model_data_t), intent(in), target :: model
     flv%f = model%get_pdg (name)
     flv%hard_process = .false.
     flv%radiated = .false.
     flv%field_data => model%get_field_ptr (name, check=.true.)
   end subroutine flavor_init_name_model
 
 @ %def flavor_init
 @ Set the [[radiated]] flag.
 <<Flavors: flavor: TBP>>=
   procedure :: tag_radiated => flavor_tag_radiated
 <<Flavors: procedures>>=
   elemental subroutine flavor_tag_radiated (flv)
     class(flavor_t), intent(inout) :: flv
     flv%radiated = .true.
   end subroutine flavor_tag_radiated
 
 @ %def flavor_tag_radiated
 @ Set the [[hard_process]] flag.
 <<Flavors: flavor: TBP>>=
   procedure :: tag_hard_process => flavor_tag_hard_process
 <<Flavors: procedures>>=
   elemental subroutine flavor_tag_hard_process (flv, hard)
     class(flavor_t), intent(inout) :: flv
     logical, intent(in), optional :: hard
     if (present (hard)) then
        flv%hard_process = hard
     else
        flv%hard_process = .true.
     end if
   end subroutine flavor_tag_hard_process
 
 @ %def flavor_tag_hard_process
 @ Undefine the flavor state:
 <<Flavors: flavor: TBP>>=
   procedure :: undefine => flavor_undefine
 <<Flavors: procedures>>=
   elemental subroutine flavor_undefine (flv)
     class(flavor_t), intent(inout) :: flv
     flv%f = UNDEFINED
     flv%field_data => null ()
   end subroutine flavor_undefine
 
 @ %def flavor_undefine
 @ Output: dense, no linebreak
 
 A hard-process tag is only shown if debugging is on.
 <<Flavors: flavor: TBP>>=
   procedure :: write => flavor_write
 <<Flavors: procedures>>=
   subroutine flavor_write (flv, unit)
     class(flavor_t), intent(in) :: flv
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     if (associated (flv%field_data)) then
        write (u, "(A)", advance="no")  "f("
     else
        write (u, "(A)", advance="no")  "p("
     end if
     write (u, "(I0)", advance="no")  flv%f
     if (flv%radiated) then
        write (u, "('*')", advance="no")
     end if
     if (msg_level (D_FLAVOR) >= DEBUG) then
        if (flv%hard_process) then
           write (u, "('#')", advance="no")
        end if
     end if
     write (u, "(A)", advance="no")  ")"
   end subroutine flavor_write
 
 @ %def flavor_write
 @
 <<Flavors: public>>=
   public :: flavor_write_array
 <<Flavors: procedures>>=
   subroutine flavor_write_array (flv, unit)
     type(flavor_t), intent(in), dimension(:) :: flv
     integer, intent(in), optional :: unit
     integer :: u, i_flv
     u = given_output_unit (unit); if (u < 0) return
     do i_flv = 1, size (flv)
        call flv(i_flv)%write (u)
        if (i_flv /= size (flv)) write (u,"(A)", advance = "no") " / "
     end do
     write (u,"(A)")
   end subroutine flavor_write_array
 
 @ %def flavor_write_array
 @ Binary I/O.  Currently, the model information is not written/read,
 so after reading the particle-data pointer is empty.
 <<Flavors: flavor: TBP>>=
   procedure :: write_raw => flavor_write_raw
   procedure :: read_raw => flavor_read_raw
 <<Flavors: procedures>>=
   subroutine flavor_write_raw (flv, u)
     class(flavor_t), intent(in) :: flv
     integer, intent(in) :: u
     write (u) flv%f
     write (u) flv%radiated
     write (u) flv%hard_process
   end subroutine flavor_write_raw
 
   subroutine flavor_read_raw (flv, u, iostat)
     class(flavor_t), intent(out) :: flv
     integer, intent(in) :: u
     integer, intent(out), optional :: iostat
     read (u, iostat=iostat) flv%f
     if (present (iostat)) then
        if (iostat /= 0)  return
     end if
     read (u, iostat=iostat)  flv%radiated
     read (u, iostat=iostat)  flv%hard_process
   end subroutine flavor_read_raw
 
 @ %def flavor_write_raw flavor_read_raw
 @
 \subsubsection{Assignment}
 Default assignment of flavor objects is possible, but cannot be used
 in pure procedures, because a pointer assignment is involved.
 
 Assign the particle pointer separately.  This cannot be elemental, so
 we define a scalar and an array version explicitly.  We refer to an
 array of flavors, not an array of models.
 <<Flavors: flavor: TBP>>=
   procedure :: set_model => flavor_set_model_single
 <<Flavors: procedures>>=
   impure elemental subroutine flavor_set_model_single (flv, model)
     class(flavor_t), intent(inout) :: flv
     class(model_data_t), intent(in), target :: model
     if (flv%f /= UNDEFINED) &
          flv%field_data => model%get_field_ptr (flv%f)
   end subroutine flavor_set_model_single
 
 @ %def flavor_set_model
 @
 \subsubsection{Predicates}
 Return the definition status.  By definition, the flavor object is
 defined if the flavor PDG code is nonzero.
 <<Flavors: flavor: TBP>>=
   procedure :: is_defined => flavor_is_defined
 <<Flavors: procedures>>=
   elemental function flavor_is_defined (flv) result (defined)
     class(flavor_t), intent(in) :: flv
     logical :: defined
     defined = flv%f /= UNDEFINED
   end function flavor_is_defined
 
 @ %def flavor_is_defined
 @ Check for valid flavor (including undefined).  This is distinct from
 the [[is_defined]] status.  Invalid flavor is actually a specific PDG
 code.
 <<Flavors: flavor: TBP>>=
   procedure :: is_valid => flavor_is_valid
 <<Flavors: procedures>>=
   elemental function flavor_is_valid (flv) result (valid)
     class(flavor_t), intent(in) :: flv
     logical :: valid
     valid = flv%f /= INVALID
   end function flavor_is_valid
 
 @ %def flavor_is_valid
 @ Return true if the particle-data pointer is associated.  (Debugging aid)
 <<Flavors: flavor: TBP>>=
   procedure :: is_associated => flavor_is_associated
 <<Flavors: procedures>>=
   elemental function flavor_is_associated (flv) result (flag)
     class(flavor_t), intent(in) :: flv
     logical :: flag
     flag = associated (flv%field_data)
   end function flavor_is_associated
 
 @ %def flavor_is_associated
 @ Check the [[radiated]] flag.  A radiated particle has a definite PDG
 flavor status, but it is actually a pseudoparticle (a beam remnant)
 which may be subject to fragmentation.
 <<Flavors: flavor: TBP>>=
   procedure :: is_radiated => flavor_is_radiated
 <<Flavors: procedures>>=
   elemental function flavor_is_radiated (flv) result (flag)
     class(flavor_t), intent(in) :: flv
     logical :: flag
     flag = flv%radiated
   end function flavor_is_radiated
 
 @ %def flavor_is_radiated
 @ Check the [[hard_process]] flag. A particle is tagged with this flag if
 it participates in the hard interaction and is not a beam remnant.
 <<Flavors: flavor: TBP>>=
   procedure :: is_hard_process => flavor_is_hard_process
 <<Flavors: procedures>>=
   elemental function flavor_is_hard_process (flv) result (flag)
     class(flavor_t), intent(in) :: flv
     logical :: flag
     flag = flv%hard_process
   end function flavor_is_hard_process
 
 @ %def flavor_is_hard_process
 @
 \subsubsection{Accessing contents}
 With the exception of the PDG code, all particle property enquiries are
 delegated to the [[field_data]] pointer.  If this is unassigned, some
 access function will crash.
 
 Return the flavor as an integer
 <<Flavors: flavor: TBP>>=
   procedure :: get_pdg => flavor_get_pdg
 <<Flavors: procedures>>=
   elemental function flavor_get_pdg (flv) result (f)
     integer :: f
     class(flavor_t), intent(in) :: flv
     f = flv%f
   end function flavor_get_pdg
 
 @ %def flavor_get_pdg
 @ Return the flavor of the antiparticle
 <<Flavors: flavor: TBP>>=
   procedure :: get_pdg_anti => flavor_get_pdg_anti
 <<Flavors: procedures>>=
   elemental function flavor_get_pdg_anti (flv) result (f)
     integer :: f
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        if (flv%field_data%has_antiparticle ()) then
           f = -flv%f
        else
           f = flv%f
        end if
     else
        f = 0
     end if
   end function flavor_get_pdg_anti
 
 @ %def flavor_get_pdg_anti
 @
 Absolute value:
 <<Flavors: flavor: TBP>>=
   procedure :: get_pdg_abs => flavor_get_pdg_abs
 <<Flavors: procedures>>=
   elemental function flavor_get_pdg_abs (flv) result (f)
     integer :: f
     class(flavor_t), intent(in) :: flv
     f = abs (flv%f)
   end function flavor_get_pdg_abs
 
 @ %def flavor_get_pdg_abs
 @
 Generic properties
 <<Flavors: flavor: TBP>>=
   procedure :: is_visible => flavor_is_visible
   procedure :: is_parton => flavor_is_parton
   procedure :: is_beam_remnant => flavor_is_beam_remnant
   procedure :: is_gauge => flavor_is_gauge
   procedure :: is_left_handed => flavor_is_left_handed
   procedure :: is_right_handed => flavor_is_right_handed
   procedure :: is_antiparticle => flavor_is_antiparticle
   procedure :: has_antiparticle => flavor_has_antiparticle
   procedure :: is_stable => flavor_is_stable
   procedure :: get_decays => flavor_get_decays
   procedure :: decays_isotropically => flavor_decays_isotropically
   procedure :: decays_diagonal => flavor_decays_diagonal
   procedure :: has_decay_helicity => flavor_has_decay_helicity
   procedure :: get_decay_helicity => flavor_get_decay_helicity
   procedure :: is_polarized => flavor_is_polarized
 <<Flavors: procedures>>=
   elemental function flavor_is_visible (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%is_visible ()
     else
        flag = .false.
     end if
   end function flavor_is_visible
 
   elemental function flavor_is_parton (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%is_parton ()
     else
        flag = .false.
     end if
   end function flavor_is_parton
 
   elemental function flavor_is_beam_remnant (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     select case (abs (flv%f))
     case (HADRON_REMNANT, &
          HADRON_REMNANT_SINGLET, HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET)
        flag = .true.
     case default
        flag = .false.
     end select
   end function flavor_is_beam_remnant
 
   elemental function flavor_is_gauge (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%is_gauge ()
     else
        flag = .false.
     end if
   end function flavor_is_gauge
 
   elemental function flavor_is_left_handed (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        if (flv%f > 0) then
           flag = flv%field_data%is_left_handed ()
        else
           flag = flv%field_data%is_right_handed ()
        end if
     else
        flag = .false.
     end if
   end function flavor_is_left_handed
 
   elemental function flavor_is_right_handed (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        if (flv%f > 0) then
           flag = flv%field_data%is_right_handed ()
        else
           flag = flv%field_data%is_left_handed ()
        end if
     else
        flag = .false.
     end if
   end function flavor_is_right_handed
 
   elemental function flavor_is_antiparticle (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     flag = flv%f < 0
   end function flavor_is_antiparticle
 
   elemental function flavor_has_antiparticle (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%has_antiparticle ()
     else
        flag = .false.
     end if
   end function flavor_has_antiparticle
 
   elemental function flavor_is_stable (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%is_stable (anti = flv%f < 0)
     else
        flag = .true.
     end if
   end function flavor_is_stable
 
   subroutine flavor_get_decays (flv, decay)
     class(flavor_t), intent(in) :: flv
     type(string_t), dimension(:), intent(out), allocatable :: decay
     logical :: anti
     anti = flv%f < 0
     if (.not. flv%field_data%is_stable (anti)) then
        call flv%field_data%get_decays (decay, anti)
     end if
   end subroutine flavor_get_decays
 
   elemental function flavor_decays_isotropically (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%decays_isotropically (anti = flv%f < 0)
     else
        flag = .true.
     end if
   end function flavor_decays_isotropically
 
   elemental function flavor_decays_diagonal (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%decays_diagonal (anti = flv%f < 0)
     else
        flag = .true.
     end if
   end function flavor_decays_diagonal
 
   elemental function flavor_has_decay_helicity (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%has_decay_helicity (anti = flv%f < 0)
     else
        flag = .false.
     end if
   end function flavor_has_decay_helicity
 
   elemental function flavor_get_decay_helicity (flv) result (hel)
     integer :: hel
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        hel = flv%field_data%decay_helicity (anti = flv%f < 0)
     else
        hel = 0
     end if
   end function flavor_get_decay_helicity
 
   elemental function flavor_is_polarized (flv) result (flag)
     logical :: flag
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        flag = flv%field_data%is_polarized (anti = flv%f < 0)
     else
        flag = .false.
     end if
   end function flavor_is_polarized
 
 @ %def flavor_is_visible
 @ %def flavor_is_parton
 @ %def flavor_is_beam_remnant
 @ %def flavor_is_gauge
 @ %def flavor_is_left_handed
 @ %def flavor_is_right_handed
 @ %def flavor_is_antiparticle
 @ %def flavor_has_antiparticle
 @ %def flavor_is_stable
 @ %def flavor_get_decays
 @ %def flavor_decays_isotropically
 @ %def flavor_decays_diagonal
 @ %def flavor_has_decays_helicity
 @ %def flavor_get_decay_helicity
 @ %def flavor_is_polarized
 @ Names:
 <<Flavors: flavor: TBP>>=
   procedure :: get_name => flavor_get_name
   procedure :: get_tex_name => flavor_get_tex_name
 <<Flavors: procedures>>=
   elemental function flavor_get_name (flv) result (name)
     type(string_t) :: name
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        name = flv%field_data%get_name (flv%f < 0)
     else
        name = "?"
     end if
   end function flavor_get_name
 
   elemental function flavor_get_tex_name (flv) result (name)
     type(string_t) :: name
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        name = flv%field_data%get_tex_name (flv%f < 0)
     else
        name = "?"
     end if
   end function flavor_get_tex_name
 
 @ %def flavor_get_name flavor_get_tex_name
 <<Flavors: flavor: TBP>>=
   procedure :: get_spin_type => flavor_get_spin_type
   procedure :: get_multiplicity => flavor_get_multiplicity
   procedure :: get_isospin_type => flavor_get_isospin_type
   procedure :: get_charge_type => flavor_get_charge_type
   procedure :: get_color_type => flavor_get_color_type
 <<Flavors: procedures>>=
   elemental function flavor_get_spin_type (flv) result (type)
     integer :: type
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        type = flv%field_data%get_spin_type ()
     else
        type = 1
     end if
   end function flavor_get_spin_type
 
   elemental function flavor_get_multiplicity (flv) result (type)
     integer :: type
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        type = flv%field_data%get_multiplicity ()
     else
        type = 1
     end if
   end function flavor_get_multiplicity
 
   elemental function flavor_get_isospin_type (flv) result (type)
     integer :: type
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        type = flv%field_data%get_isospin_type ()
     else
        type = 1
     end if
   end function flavor_get_isospin_type
 
   elemental function flavor_get_charge_type (flv) result (type)
     integer :: type
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        type = flv%field_data%get_charge_type ()
     else
        type = 1
     end if
   end function flavor_get_charge_type
 
   elemental function flavor_get_color_type (flv) result (type)
     integer :: type
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        if (flavor_is_antiparticle (flv)) then
           type = - flv%field_data%get_color_type ()
        else
           type = flv%field_data%get_color_type ()
        end if
        select case (type)
        case (-1,-8);  type = abs (type)
        end select
     else
        type = 1
     end if
   end function flavor_get_color_type
 
 @ %def flavor_get_spin_type
 @ %def flavor_get_multiplicity
 @ %def flavor_get_isospin_type
 @ %def flavor_get_charge_type
 @ %def flavor_get_color_type
 @ These functions return real values:
 <<Flavors: flavor: TBP>>=
   procedure :: get_charge => flavor_get_charge
   procedure :: get_mass => flavor_get_mass
   procedure :: get_width => flavor_get_width
   procedure :: get_isospin => flavor_get_isospin
 <<Flavors: procedures>>=
   elemental function flavor_get_charge (flv) result (charge)
     real(default) :: charge
     class(flavor_t), intent(in) :: flv
     integer :: charge_type
     if (associated (flv%field_data)) then
        charge_type = flv%get_charge_type ()
        if (charge_type == 0 .or. charge_type == 1) then
           charge = 0
        else
           if (flavor_is_antiparticle (flv)) then
              charge = - flv%field_data%get_charge ()
           else
              charge = flv%field_data%get_charge ()
           end if
        end if
     else
        charge = 0
     end if
   end function flavor_get_charge
 
   elemental function flavor_get_mass (flv) result (mass)
     real(default) :: mass
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        mass = flv%field_data%get_mass ()
     else
        mass = 0
     end if
   end function flavor_get_mass
 
   elemental function flavor_get_width (flv) result (width)
     real(default) :: width
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        width = flv%field_data%get_width ()
     else
        width = 0
     end if
   end function flavor_get_width
 
   elemental function flavor_get_isospin (flv) result (isospin)
     real(default) :: isospin
     class(flavor_t), intent(in) :: flv
     if (associated (flv%field_data)) then
        if (flavor_is_antiparticle (flv)) then
           isospin = - flv%field_data%get_isospin ()
        else
           isospin = flv%field_data%get_isospin ()
        end if
     else
        isospin = 0
     end if
   end function flavor_get_isospin
 
 @ %def flavor_get_charge flavor_get_mass flavor_get_width
 @ %def flavor_get_isospin
 @
 \subsubsection{Comparisons}
 If one of the flavors is undefined, the other defined, they match.
 <<Flavors: flavor: TBP>>=
   generic :: operator(.match.) => flavor_match
   generic :: operator(==) => flavor_eq
   generic :: operator(/=) => flavor_neq
   procedure, private :: flavor_match
   procedure, private :: flavor_eq
   procedure, private :: flavor_neq
 @ %def .match. == /=
 <<Flavors: procedures>>=
   elemental function flavor_match (flv1, flv2) result (eq)
     logical :: eq
     class(flavor_t), intent(in) :: flv1, flv2
     if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
        eq = flv1%f == flv2%f
     else
        eq = .true.
     end if
   end function flavor_match
 
   elemental function flavor_eq (flv1, flv2) result (eq)
     logical :: eq
     class(flavor_t), intent(in) :: flv1, flv2
     if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
        eq = flv1%f == flv2%f
     else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then
        eq = .true.
     else
        eq = .false.
     end if
   end function flavor_eq
 
 @ %def flavor_match flavor_eq
 <<Flavors: procedures>>=
   elemental function flavor_neq (flv1, flv2) result (neq)
     logical :: neq
     class(flavor_t), intent(in) :: flv1, flv2
     if (flv1%f /= UNDEFINED .and. flv2%f /= UNDEFINED) then
        neq = flv1%f /= flv2%f
     else if (flv1%f == UNDEFINED .and. flv2%f == UNDEFINED) then
        neq = .false.
     else
        neq = .true.
     end if
   end function flavor_neq
 
 @ %def flavor_neq
 @
 \subsubsection{Tools}
 Merge two flavor indices.  This works only if both are equal or either
 one is undefined, because we have no off-diagonal flavor entries.
 Otherwise, generate an invalid flavor.
 
 We cannot use elemental procedures because of the pointer component.
 <<Flavors: public>>=
   public :: operator(.merge.)
 <<Flavors: interfaces>>=
   interface operator(.merge.)
      module procedure merge_flavors0
      module procedure merge_flavors1
   end interface
 
 @ %def .merge.
 <<Flavors: procedures>>=
   function merge_flavors0 (flv1, flv2) result (flv)
     type(flavor_t) :: flv
     type(flavor_t), intent(in) :: flv1, flv2
     if (flavor_is_defined (flv1) .and. flavor_is_defined (flv2)) then
        if (flv1 == flv2) then
           flv = flv1
        else
           flv%f = INVALID
        end if
     else if (flavor_is_defined (flv1)) then
        flv = flv1
     else if (flavor_is_defined (flv2)) then
        flv = flv2
     end if
   end function merge_flavors0
 
   function merge_flavors1 (flv1, flv2) result (flv)
     type(flavor_t), dimension(:), intent(in) :: flv1, flv2
     type(flavor_t), dimension(size(flv1)) :: flv
     integer :: i
     do i = 1, size (flv1)
        flv(i) = flv1(i) .merge. flv2(i)
     end do
   end function merge_flavors1
 
 @ %def merge_flavors
 @ Generate consecutive color indices for a given flavor.  The indices
 are counted starting with the stored value of c, so new indices are
 created each time this (impure) function is called.  The counter can
 be reset by the optional argument [[c_seed]] if desired.  The optional
 flag [[reverse]] is used only for octets.  If set, the color and
 anticolor entries of the octet particle are exchanged.
 <<Flavors: public>>=
   public :: color_from_flavor
 <<Flavors: interfaces>>=
   interface color_from_flavor
      module procedure color_from_flavor0
      module procedure color_from_flavor1
   end interface
 <<Flavors: procedures>>=
   function color_from_flavor0 (flv, c_seed, reverse) result (col)
     type(color_t) :: col
     type(flavor_t), intent(in) :: flv
     integer, intent(in), optional :: c_seed
     logical, intent(in), optional :: reverse
     integer, save :: c = 1
     logical :: rev
     if (present (c_seed))  c = c_seed
     rev = .false.;  if (present (reverse)) rev = reverse
     select case (flavor_get_color_type (flv))
     case (1)
        call col%init ()
     case (3)
        call col%init ([c]);  c = c + 1
     case (-3)
        call col%init ([-c]);  c = c + 1
     case (8)
        if (rev) then
           call col%init ([c+1, -c]);  c = c + 2
        else
           call col%init ([c, -(c+1)]);  c = c + 2
        end if
     end select
   end function color_from_flavor0
 
   function color_from_flavor1 (flv, c_seed, reverse) result (col)
     type(flavor_t), dimension(:), intent(in) :: flv
     integer, intent(in), optional :: c_seed
     logical, intent(in), optional :: reverse
     type(color_t), dimension(size(flv)) :: col
     integer :: i
     col(1) = color_from_flavor0 (flv(1), c_seed, reverse)
     do i = 2, size (flv)
        col(i) = color_from_flavor0 (flv(i), reverse=reverse)
     end do
   end function color_from_flavor1
 
 @ %def color_from_flavor
 @ This procedure returns the flavor object for the antiparticle.  The
 antiparticle code may either be the same code or its negative.
 <<Flavors: flavor: TBP>>=
   procedure :: anti => flavor_anti
 <<Flavors: procedures>>=
   function flavor_anti (flv) result (aflv)
     type(flavor_t) :: aflv
     class(flavor_t), intent(in) :: flv
     if (flavor_has_antiparticle (flv)) then
        aflv%f = - flv%f
     else
        aflv%f = flv%f
     end if
     aflv%field_data => flv%field_data
   end function flavor_anti
 
 @ %def flavor_anti
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Quantum numbers}
 This module collects helicity, color, and flavor in a single type and
 defines procedures
 <<[[quantum_numbers.f90]]>>=
 <<File header>>
 
 module quantum_numbers
 
   use io_units
   use model_data
   use helicities
   use colors
   use flavors
 
 <<Standard module head>>
 
 <<Quantum numbers: public>>
 
 <<Quantum numbers: types>>
 
 <<Quantum numbers: interfaces>>
 
 contains
 
 <<Quantum numbers: procedures>>
 
 end module quantum_numbers
 @ %def quantum_numbers
 @
 \subsection{The quantum number type}
 <<Quantum numbers: public>>=
   public :: quantum_numbers_t
 <<Quantum numbers: types>>=
   type :: quantum_numbers_t
      private
      type(flavor_t) :: f
      type(color_t) :: c
      type(helicity_t) :: h
      integer :: sub = 0
    contains
    <<Quantum numbers: quantum numbers: TBP>>
   end type quantum_numbers_t
 
 @ %def quantum_number_t
 @ Define quantum numbers: Initializer form.  All arguments may be
 present or absent.
 
 Some elemental initializers are impure because they set the [[flv]]
 component.  This implies transfer of a pointer behind the scenes.
 <<Quantum numbers: quantum numbers: TBP>>=
   generic :: init => &
      quantum_numbers_init_f, &
      quantum_numbers_init_c, &
      quantum_numbers_init_h, &
      quantum_numbers_init_fc, &
      quantum_numbers_init_fh, &
      quantum_numbers_init_ch, &
      quantum_numbers_init_fch, &
      quantum_numbers_init_fs, &
      quantum_numbers_init_fhs, &
      quantum_numbers_init_fcs, &
      quantum_numbers_init_fhcs
   procedure, private :: quantum_numbers_init_f
   procedure, private :: quantum_numbers_init_c
   procedure, private :: quantum_numbers_init_h
   procedure, private :: quantum_numbers_init_fc
   procedure, private :: quantum_numbers_init_fh
   procedure, private :: quantum_numbers_init_ch
   procedure, private :: quantum_numbers_init_fch
   procedure, private :: quantum_numbers_init_fs
   procedure, private :: quantum_numbers_init_fhs
   procedure, private :: quantum_numbers_init_fcs
   procedure, private :: quantum_numbers_init_fhcs
 <<Quantum numbers: procedures>>=
   impure elemental subroutine quantum_numbers_init_f (qn, flv)
     class(quantum_numbers_t), intent(out) :: qn
     type(flavor_t), intent(in) :: flv
     qn%f = flv
     call qn%c%undefine ()
     call qn%h%undefine ()
     qn%sub = 0
   end subroutine quantum_numbers_init_f
 
   impure elemental subroutine quantum_numbers_init_c (qn, col)
     class(quantum_numbers_t), intent(out) :: qn
     type(color_t), intent(in) :: col
     call qn%f%undefine ()
     qn%c = col
     call qn%h%undefine ()
     qn%sub = 0
   end subroutine quantum_numbers_init_c
 
   impure elemental subroutine quantum_numbers_init_h (qn, hel)
     class(quantum_numbers_t), intent(out) :: qn
     type(helicity_t), intent(in) :: hel
     call qn%f%undefine ()
     call qn%c%undefine ()
     qn%h = hel
     qn%sub = 0
   end subroutine quantum_numbers_init_h
 
   impure elemental subroutine quantum_numbers_init_fc (qn, flv, col)
     class(quantum_numbers_t), intent(out) :: qn
     type(flavor_t), intent(in) :: flv
     type(color_t), intent(in) :: col
     qn%f = flv
     qn%c = col
     call qn%h%undefine ()
     qn%sub = 0
   end subroutine quantum_numbers_init_fc
 
   impure elemental subroutine quantum_numbers_init_fh (qn, flv, hel)
     class(quantum_numbers_t), intent(out) :: qn
     type(flavor_t), intent(in) :: flv
     type(helicity_t), intent(in) :: hel
     qn%f = flv
     call qn%c%undefine ()
     qn%h = hel
     qn%sub = 0
   end subroutine quantum_numbers_init_fh
 
   impure elemental subroutine quantum_numbers_init_ch (qn, col, hel)
     class(quantum_numbers_t), intent(out) :: qn
     type(color_t), intent(in) :: col
     type(helicity_t), intent(in) :: hel
     call qn%f%undefine ()
     qn%c = col
     qn%h = hel
     qn%sub = 0
   end subroutine quantum_numbers_init_ch
 
   impure elemental subroutine quantum_numbers_init_fch (qn, flv, col, hel)
     class(quantum_numbers_t), intent(out) :: qn
     type(flavor_t), intent(in) :: flv
     type(color_t), intent(in) :: col
     type(helicity_t), intent(in) :: hel
     qn%f = flv
     qn%c = col
     qn%h = hel
     qn%sub = 0
   end subroutine quantum_numbers_init_fch
 
   impure elemental subroutine quantum_numbers_init_fs (qn, flv, sub)
     class(quantum_numbers_t), intent(out) :: qn
     type(flavor_t), intent(in) :: flv
     integer, intent(in) :: sub
     qn%f = flv; qn%sub = sub
   end subroutine quantum_numbers_init_fs
 
   impure elemental subroutine quantum_numbers_init_fhs (qn, flv, hel, sub)
     class(quantum_numbers_t), intent(out) :: qn
     type(flavor_t), intent(in) :: flv
     type(helicity_t), intent(in) :: hel
     integer, intent(in) :: sub
     qn%f = flv; qn%h = hel; qn%sub = sub
   end subroutine quantum_numbers_init_fhs
 
   impure elemental subroutine quantum_numbers_init_fcs (qn, flv, col, sub)
     class(quantum_numbers_t), intent(out) :: qn
     type(flavor_t), intent(in) :: flv
     type(color_t), intent(in) :: col
     integer, intent(in) :: sub
     qn%f = flv; qn%c = col; qn%sub = sub
   end subroutine quantum_numbers_init_fcs
 
   impure elemental subroutine quantum_numbers_init_fhcs (qn, flv, hel, col, sub)
     class(quantum_numbers_t), intent(out) :: qn
     type(flavor_t), intent(in) :: flv
     type(helicity_t), intent(in) :: hel
     type(color_t), intent(in) :: col
     integer, intent(in) :: sub
     qn%f = flv; qn%h = hel; qn%c = col; qn%sub = sub
   end subroutine quantum_numbers_init_fhcs
 
 @ %def quantum_numbers_init
 @
 \subsection{I/O}
 Write the quantum numbers in condensed form, enclosed by square
 brackets.  Color is written only if nontrivial.  For convenience,
 introduce also an array version.
 
 If the [[col_verbose]] option is set, show the quantum number color also
 if it is zero, but defined.  Otherwise, suppress zero color.
 <<Quantum numbers: public>>=
   public :: quantum_numbers_write
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: write => quantum_numbers_write_single
 <<Quantum numbers: interfaces>>=
   interface quantum_numbers_write
      module procedure quantum_numbers_write_single
      module procedure quantum_numbers_write_array
   end interface
 <<Quantum numbers: procedures>>=
   subroutine quantum_numbers_write_single (qn, unit, col_verbose)
     class(quantum_numbers_t), intent(in) :: qn
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: col_verbose
     integer :: u
     logical :: col_verb
     u = given_output_unit (unit);  if (u < 0)  return
     col_verb = .false.;  if (present (col_verbose)) col_verb = col_verbose
     write (u, "(A)", advance = "no")  "["
     if (qn%f%is_defined ()) then
        call qn%f%write (u)
        if (qn%c%is_nonzero () .or. qn%h%is_defined ()) &
             write (u, "(1x)", advance = "no")
     end if
     if (col_verb) then
        if (qn%c%is_defined () .or. qn%c%is_ghost ()) then
           call color_write (qn%c, u)
           if (qn%h%is_defined ())  write (u, "(1x)", advance = "no")
        end if
     else
        if (qn%c%is_nonzero () .or. qn%c%is_ghost ()) then
           call color_write (qn%c, u)
           if (qn%h%is_defined ())  write (u, "(1x)", advance = "no")
        end if
     end if
     if (qn%h%is_defined ()) then
        call qn%h%write (u)
     end if
     if (qn%sub > 0) &
        write (u, "(A,I0)", advance = "no") " SUB = ", qn%sub
     write (u, "(A)", advance="no")  "]"
   end subroutine quantum_numbers_write_single
 
   subroutine quantum_numbers_write_array (qn, unit, col_verbose)
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: col_verbose
     integer :: i
     integer :: u
     logical :: col_verb
     u = given_output_unit (unit);  if (u < 0)  return
     col_verb = .false.;  if (present (col_verbose)) col_verb = col_verbose
     write (u, "(A)", advance="no")  "["
     do i = 1, size (qn)
        if (i > 1)  write (u, "(A)", advance="no")  " / "
        if (qn(i)%f%is_defined ()) then
           call qn(i)%f%write (u)
           if (qn(i)%c%is_nonzero () .or. qn(i)%h%is_defined ()) &
                write (u, "(1x)", advance="no")
        end if
        if (col_verb) then
           if (qn(i)%c%is_defined () .or. qn(i)%c%is_ghost ()) then
              call color_write (qn(i)%c, u)
              if (qn(i)%h%is_defined ())  write (u, "(1x)", advance="no")
           end if
        else
           if (qn(i)%c%is_nonzero () .or. qn(i)%c%is_ghost ()) then
              call color_write (qn(i)%c, u)
              if (qn(i)%h%is_defined ())  write (u, "(1x)", advance="no")
           end if
        end if
        if (qn(i)%h%is_defined ()) then
           call qn(i)%h%write (u)
        end if
        if (qn(i)%sub > 0) &
           write (u, "(A,I2)", advance = "no") " SUB = ", qn(i)%sub
     end do
     write (u, "(A)", advance = "no")  "]"
   end subroutine quantum_numbers_write_array
 
 @ %def quantum_numbers_write
 @ Binary I/O.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: write_raw => quantum_numbers_write_raw
   procedure :: read_raw => quantum_numbers_read_raw
 <<Quantum numbers: procedures>>=
   subroutine quantum_numbers_write_raw (qn, u)
     class(quantum_numbers_t), intent(in) :: qn
     integer, intent(in) :: u
     call qn%f%write_raw (u)
     call qn%c%write_raw (u)
     call qn%h%write_raw (u)
   end subroutine quantum_numbers_write_raw
 
   subroutine quantum_numbers_read_raw (qn, u, iostat)
     class(quantum_numbers_t), intent(out) :: qn
     integer, intent(in) :: u
     integer, intent(out), optional :: iostat
     call qn%f%read_raw (u, iostat=iostat)
     call qn%c%read_raw (u, iostat=iostat)
     call qn%h%read_raw (u, iostat=iostat)
   end subroutine quantum_numbers_read_raw
 
 @ %def quantum_numbers_write_raw quantum_numbers_read_raw
 @
 \subsection{Accessing contents}
 Color and helicity can be done by elemental functions.  Flavor needs
 impure elemental.  We export also the functions directly, this allows
 us to avoid temporaries in some places.
 <<Quantum numbers: public>>=
   public :: quantum_numbers_get_flavor
   public :: quantum_numbers_get_color
   public :: quantum_numbers_get_helicity
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: get_flavor => quantum_numbers_get_flavor
   procedure :: get_color => quantum_numbers_get_color
   procedure :: get_helicity => quantum_numbers_get_helicity
   procedure :: get_sub => quantum_numbers_get_sub
 <<Quantum numbers: procedures>>=
   impure elemental function quantum_numbers_get_flavor (qn) result (flv)
     type(flavor_t) :: flv
     class(quantum_numbers_t), intent(in) :: qn
     flv = qn%f
   end function quantum_numbers_get_flavor
 
   elemental function quantum_numbers_get_color (qn) result (col)
     type(color_t) :: col
     class(quantum_numbers_t), intent(in) :: qn
     col = qn%c
   end function quantum_numbers_get_color
 
   elemental function quantum_numbers_get_helicity (qn) result (hel)
     type(helicity_t) :: hel
     class(quantum_numbers_t), intent(in) :: qn
     hel = qn%h
   end function quantum_numbers_get_helicity
 
   elemental function quantum_numbers_get_sub (qn) result (sub)
     integer :: sub
     class(quantum_numbers_t), intent(in) :: qn
     sub = qn%sub
   end function quantum_numbers_get_sub
 
 @ %def quantum_numbers_get_flavor
 @ %def quantum_numbers_get_color
 @ %def quantum_numbers_get_helicity
 @ %def quantum_numbers_get_sub
 @ This just resets the ghost property of the color part:
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: set_color_ghost => quantum_numbers_set_color_ghost
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_set_color_ghost (qn, ghost)
     class(quantum_numbers_t), intent(inout) :: qn
     logical, intent(in) :: ghost
     call qn%c%set_ghost (ghost)
   end subroutine quantum_numbers_set_color_ghost
 
 @ %def quantum_numbers_set_color_ghost
 @ Assign a model to the flavor part of quantum numbers.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: set_model => quantum_numbers_set_model
 <<Quantum numbers: procedures>>=
   impure elemental subroutine quantum_numbers_set_model (qn, model)
     class(quantum_numbers_t), intent(inout) :: qn
     class(model_data_t), intent(in), target :: model
     call qn%f%set_model (model)
   end subroutine quantum_numbers_set_model
 
 @ %def quantum_numbers_set_model
 @ Set the [[radiated]] flag for the flavor component.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: tag_radiated => quantum_numbers_tag_radiated
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_tag_radiated (qn)
     class(quantum_numbers_t), intent(inout) :: qn
     call qn%f%tag_radiated ()
   end subroutine quantum_numbers_tag_radiated
 
 @ %def quantum_numbers_tag_radiated
 @ Set the [[hard_process]] flag for the flavor component.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: tag_hard_process => quantum_numbers_tag_hard_process
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_tag_hard_process (qn, hard)
     class(quantum_numbers_t), intent(inout) :: qn
     logical, intent(in), optional :: hard
     call qn%f%tag_hard_process (hard)
   end subroutine quantum_numbers_tag_hard_process
 
 @ %def quantum_numbers_tag_hard_process
 @
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: set_subtraction_index => quantum_numbers_set_subtraction_index
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_set_subtraction_index (qn, i)
     class(quantum_numbers_t), intent(inout) :: qn
     integer, intent(in) :: i
     qn%sub = i
   end subroutine quantum_numbers_set_subtraction_index
 
 @ %def quantum_numbers_set_subtraction_index
 @
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: get_subtraction_index => quantum_numbers_get_subtraction_index
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_get_subtraction_index (qn) result (sub)
     integer :: sub
     class(quantum_numbers_t), intent(in) :: qn
     sub = qn%sub
   end function quantum_numbers_get_subtraction_index
 
 @ %def quantum_numbers_get_subtraction_index
 @ This is a convenience function: return the color type for the flavor
 (array).
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: get_color_type => quantum_numbers_get_color_type
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_get_color_type (qn) result (color_type)
     integer :: color_type
     class(quantum_numbers_t), intent(in) :: qn
     color_type = qn%f%get_color_type ()
   end function quantum_numbers_get_color_type
 
 @ %def quantum_numbers_get_color_type
 @
 \subsection{Predicates}
 Check if the flavor index is valid (including UNDEFINED).
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: are_valid => quantum_numbers_are_valid
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_are_valid (qn) result (valid)
     logical :: valid
     class(quantum_numbers_t), intent(in) :: qn
     valid = qn%f%is_valid ()
   end function quantum_numbers_are_valid
 
 @ %def quantum_numbers_are_valid
 @ Check if the flavor part has its particle-data pointer associated
 (debugging aid).
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: are_associated => quantum_numbers_are_associated
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_are_associated (qn) result (flag)
     logical :: flag
     class(quantum_numbers_t), intent(in) :: qn
     flag = qn%f%is_associated ()
   end function quantum_numbers_are_associated
 
 @ %def quantum_numbers_are_associated
 @ Check if the helicity and color quantum numbers are
 diagonal. (Unpolarized/colorless also counts as diagonal.)  Flavor is
 diagonal by definition.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: are_diagonal => quantum_numbers_are_diagonal
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_are_diagonal (qn) result (diagonal)
     logical :: diagonal
     class(quantum_numbers_t), intent(in) :: qn
     diagonal = qn%h%is_diagonal () .and. qn%c%is_diagonal ()
   end function quantum_numbers_are_diagonal
 
 @ %def quantum_numbers_are_diagonal
 @ Check if the color part has the ghost property.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: is_color_ghost => quantum_numbers_is_color_ghost
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_is_color_ghost (qn) result (ghost)
     logical :: ghost
     class(quantum_numbers_t), intent(in) :: qn
     ghost = qn%c%is_ghost ()
   end function quantum_numbers_is_color_ghost
 
 @ %def quantum_numbers_is_color_ghost
 @ Check if the flavor participates in the hard interaction.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: are_hard_process => quantum_numbers_are_hard_process
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_are_hard_process (qn) result (hard_process)
     logical :: hard_process
     class(quantum_numbers_t), intent(in) :: qn
     hard_process = qn%f%is_hard_process ()
   end function quantum_numbers_are_hard_process
 
 @ %def quantum_numbers_are_hard_process
 @
 \subsection{Comparisons}
 Matching and equality is derived from the individual quantum numbers.
 The variant [[fhmatch]] matches only flavor and helicity.  The variant
 [[dhmatch]] matches only diagonal helicity, if the matching helicity is
 undefined.
 <<Quantum numbers: public>>=
   public :: quantum_numbers_eq_wo_sub
 <<Quantum numbers: quantum numbers: TBP>>=
   generic :: operator(.match.) => quantum_numbers_match
   generic :: operator(.fmatch.) => quantum_numbers_match_f
   generic :: operator(.hmatch.) => quantum_numbers_match_h
   generic :: operator(.fhmatch.) => quantum_numbers_match_fh
   generic :: operator(.dhmatch.) => quantum_numbers_match_hel_diag
   generic :: operator(==) => quantum_numbers_eq
   generic :: operator(/=) => quantum_numbers_neq
   procedure, private :: quantum_numbers_match
   procedure, private :: quantum_numbers_match_f
   procedure, private :: quantum_numbers_match_h
   procedure, private :: quantum_numbers_match_fh
   procedure, private :: quantum_numbers_match_hel_diag
   procedure, private :: quantum_numbers_eq
   procedure, private :: quantum_numbers_neq
 @ %def .match. == /=
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_match (qn1, qn2) result (match)
     logical :: match
     class(quantum_numbers_t), intent(in) :: qn1, qn2
     match = (qn1%f .match. qn2%f) .and. &
          (qn1%c .match. qn2%c) .and. &
          (qn1%h .match. qn2%h)
   end function quantum_numbers_match
 
   elemental function quantum_numbers_match_f (qn1, qn2) result (match)
     logical :: match
     class(quantum_numbers_t), intent(in) :: qn1, qn2
     match = (qn1%f .match. qn2%f)
   end function quantum_numbers_match_f
 
   elemental function quantum_numbers_match_h (qn1, qn2) result (match)
     logical :: match
     class(quantum_numbers_t), intent(in) :: qn1, qn2
     match = (qn1%h .match. qn2%h)
   end function quantum_numbers_match_h
 
   elemental function quantum_numbers_match_fh (qn1, qn2) result (match)
     logical :: match
     class(quantum_numbers_t), intent(in) :: qn1, qn2
     match = (qn1%f .match. qn2%f) .and. &
          (qn1%h .match. qn2%h)
   end function quantum_numbers_match_fh
 
   elemental function quantum_numbers_match_hel_diag (qn1, qn2) result (match)
     logical :: match
     class(quantum_numbers_t), intent(in) :: qn1, qn2
     match = (qn1%f .match. qn2%f) .and. &
          (qn1%c .match. qn2%c) .and. &
          (qn1%h .dmatch. qn2%h)
   end function quantum_numbers_match_hel_diag
 
   elemental function quantum_numbers_eq_wo_sub (qn1, qn2) result (eq)
     logical :: eq
     type(quantum_numbers_t), intent(in) :: qn1, qn2
     eq = (qn1%f == qn2%f) .and. &
          (qn1%c == qn2%c) .and. &
          (qn1%h == qn2%h)
   end function quantum_numbers_eq_wo_sub
 
   elemental function quantum_numbers_eq (qn1, qn2) result (eq)
     logical :: eq
     class(quantum_numbers_t), intent(in) :: qn1, qn2
     eq = (qn1%f == qn2%f) .and. &
          (qn1%c == qn2%c) .and. &
          (qn1%h == qn2%h) .and. &
          (qn1%sub == qn2%sub)
   end function quantum_numbers_eq
 
   elemental function quantum_numbers_neq (qn1, qn2) result (neq)
     logical :: neq
     class(quantum_numbers_t), intent(in) :: qn1, qn2
     neq = (qn1%f /= qn2%f) .or. &
          (qn1%c /= qn2%c) .or. &
          (qn1%h /= qn2%h) .or. &
          (qn1%sub /= qn2%sub)
   end function quantum_numbers_neq
 
 @ %def quantum_numbers_match
 @ %def quantum_numbers_eq
 @ %def quantum_numbers_neq
 <<Quantum numbers: public>>=
   public :: assignment(=)
 <<Quantum numbers: interfaces>>=
   interface assignment(=)
      module procedure quantum_numbers_assign
   end interface
 
 <<Quantum numbers: procedures>>=
   subroutine quantum_numbers_assign (qn_out, qn_in)
     type(quantum_numbers_t), intent(out) :: qn_out
     type(quantum_numbers_t), intent(in) :: qn_in
     qn_out%f = qn_in%f
     qn_out%c = qn_in%c
     qn_out%h = qn_in%h
     qn_out%sub = qn_in%sub
   end subroutine quantum_numbers_assign
 
 @ %def quantum_numbers_assign
 @ Two sets of quantum numbers are compatible if the individual quantum numbers
 are compatible, depending on the mask.  Flavor has to match, regardless of the
 flavor mask.
 
 If the color flag is set, color is compatible if the ghost property is
 identical.  If the color flag is unset, color has to be identical.  I.e., if
 the flag is set, the color amplitudes can interfere.  If it is not set, they
 must be identical, and there must be no ghost.  The latter property is used
 for expanding physical color flows.
 
 Helicity is compatible if the mask is unset, otherwise it has to match.  This
 determines if two amplitudes can be multiplied (no mask) or traced (mask).
 <<Quantum numbers: public>>=
   public :: quantum_numbers_are_compatible
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_are_compatible (qn1, qn2, mask) &
       result (flag)
     logical :: flag
     type(quantum_numbers_t), intent(in) :: qn1, qn2
     type(quantum_numbers_mask_t), intent(in) :: mask
     if (mask%h .or. mask%hd) then
        flag = (qn1%f .match. qn2%f) .and. (qn1%h .match. qn2%h)
     else
        flag = (qn1%f .match. qn2%f)
     end if
     if (mask%c) then
        flag = flag .and. (qn1%c%is_ghost () .eqv. qn2%c%is_ghost ())
     else
        flag = flag .and. &
             .not. (qn1%c%is_ghost () .or. qn2%c%is_ghost ()) .and. &
             (qn1%c == qn2%c)
     end if
   end function quantum_numbers_are_compatible
 
 @ %def quantum_numbers_are_compatible
 @ This is the analog for a single quantum-number set.  We just check for color
 ghosts; they are excluded if the color mask is unset (color-flow expansion).
 <<Quantum numbers: public>>=
   public :: quantum_numbers_are_physical
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_are_physical (qn, mask) result (flag)
     logical :: flag
     type(quantum_numbers_t), intent(in) :: qn
     type(quantum_numbers_mask_t), intent(in) :: mask
     if (mask%c) then
        flag = .true.
     else
        flag = .not. qn%c%is_ghost ()
     end if
   end function quantum_numbers_are_physical
 
 @ %def quantum_numbers_are_physical
 @
 \subsection{Operations}
 Inherited from the color component: reassign color indices in
 canonical order.
 <<Quantum numbers: public>>=
   public :: quantum_numbers_canonicalize_color
 <<Quantum numbers: procedures>>=
   subroutine quantum_numbers_canonicalize_color (qn)
     type(quantum_numbers_t), dimension(:), intent(inout) :: qn
     call color_canonicalize (qn%c)
   end subroutine quantum_numbers_canonicalize_color
 
 @ %def quantum_numbers_canonicalize_color
 @ Inherited from the color component: make a color map for two matching
 quantum-number arrays.
 <<Quantum numbers: public>>=
   public :: make_color_map
 <<Quantum numbers: interfaces>>=
   interface make_color_map
      module procedure quantum_numbers_make_color_map
   end interface make_color_map
 
 <<Quantum numbers: procedures>>=
   subroutine quantum_numbers_make_color_map (map, qn1, qn2)
     integer, dimension(:,:), intent(out), allocatable :: map
     type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2
     call make_color_map (map, qn1%c, qn2%c)
   end subroutine quantum_numbers_make_color_map
 
 @ %def make_color_map
 @ Inherited from the color component: translate the color part using a
 color-map array
 <<Quantum numbers: public>>=
   public :: quantum_numbers_translate_color
 <<Quantum numbers: interfaces>>=
   interface quantum_numbers_translate_color
      module procedure quantum_numbers_translate_color0
      module procedure quantum_numbers_translate_color1
   end interface
 
 <<Quantum numbers: procedures>>=
   subroutine quantum_numbers_translate_color0 (qn, map, offset)
     type(quantum_numbers_t), intent(inout) :: qn
     integer, dimension(:,:), intent(in) :: map
     integer, intent(in), optional :: offset
     call color_translate (qn%c, map, offset)
   end subroutine quantum_numbers_translate_color0
 
   subroutine quantum_numbers_translate_color1 (qn, map, offset)
     type(quantum_numbers_t), dimension(:), intent(inout) :: qn
     integer, dimension(:,:), intent(in) :: map
     integer, intent(in), optional :: offset
     call color_translate (qn%c, map, offset)
   end subroutine quantum_numbers_translate_color1
 
 @ %def quantum_numbers_translate_color
 @ Inherited from the color component: return the color index with
 highest absolute value.
 
 Since the algorithm is not elemental, we keep the separate
 procedures for different array rank.
 <<Quantum numbers: public>>=
   public :: quantum_numbers_get_max_color_value
 <<Quantum numbers: interfaces>>=
   interface quantum_numbers_get_max_color_value
      module procedure quantum_numbers_get_max_color_value0
      module procedure quantum_numbers_get_max_color_value1
      module procedure quantum_numbers_get_max_color_value2
   end interface
 
 <<Quantum numbers: procedures>>=
   pure function quantum_numbers_get_max_color_value0 (qn) result (cmax)
     integer :: cmax
     type(quantum_numbers_t), intent(in) :: qn
     cmax = color_get_max_value (qn%c)
   end function quantum_numbers_get_max_color_value0
 
   pure function quantum_numbers_get_max_color_value1 (qn) result (cmax)
     integer :: cmax
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     cmax = color_get_max_value (qn%c)
   end function quantum_numbers_get_max_color_value1
 
   pure function quantum_numbers_get_max_color_value2 (qn) result (cmax)
     integer :: cmax
     type(quantum_numbers_t), dimension(:,:), intent(in) :: qn
     cmax = color_get_max_value (qn%c)
   end function quantum_numbers_get_max_color_value2
 
 @ Inherited from the color component: add an offset to the indices of
 the color part
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: add_color_offset => quantum_numbers_add_color_offset
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_add_color_offset (qn, offset)
     class(quantum_numbers_t), intent(inout) :: qn
     integer, intent(in) :: offset
     call qn%c%add_offset (offset)
   end subroutine quantum_numbers_add_color_offset
 
 @ %def quantum_numbers_add_color_offset
 @ Given a quantum number array, return all possible color
 contractions, leaving the other quantum numbers intact.
 <<Quantum numbers: public>>=
   public :: quantum_number_array_make_color_contractions
 <<Quantum numbers: procedures>>=
   subroutine quantum_number_array_make_color_contractions (qn_in, qn_out)
     type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
     type(quantum_numbers_t), dimension(:,:), intent(out), allocatable :: qn_out
     type(color_t), dimension(:,:), allocatable :: col
     integer :: i
     call color_array_make_contractions (qn_in%c, col)
     allocate (qn_out (size (col, 1), size (col, 2)))
     do i = 1, size (qn_out, 2)
        qn_out(:,i)%f = qn_in%f
        qn_out(:,i)%c = col(:,i)
        qn_out(:,i)%h = qn_in%h
     end do
   end subroutine quantum_number_array_make_color_contractions
 
 @ %def quantum_number_array_make_color_contractions
 @ Inherited from the color component: invert the color, switching
 particle/antiparticle.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: invert_color => quantum_numbers_invert_color
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_invert_color (qn)
     class(quantum_numbers_t), intent(inout) :: qn
     call qn%c%invert ()
   end subroutine quantum_numbers_invert_color
 
 @ %def quantum_numbers_invert_color
 @ Flip helicity.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: flip_helicity => quantum_numbers_flip_helicity
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_flip_helicity (qn)
     class(quantum_numbers_t), intent(inout) :: qn
     call qn%h%flip ()
   end subroutine quantum_numbers_flip_helicity
 
 @ %def quantum_numbers_flip_helicity
 @
 Merge two quantum number sets: for each entry, if both are defined,
 combine them to an off-diagonal entry (meaningful only if the input
 was diagonal).  If either entry is undefined, take the defined
 one.
 
 For flavor, off-diagonal entries are invalid, so both
 flavors must be equal, otherwise an invalid flavor is inserted.
 <<Quantum numbers: public>>=
   public :: operator(.merge.)
 <<Quantum numbers: interfaces>>=
   interface operator(.merge.)
      module procedure merge_quantum_numbers0
      module procedure merge_quantum_numbers1
   end interface
 
 <<Quantum numbers: procedures>>=
   function merge_quantum_numbers0 (qn1, qn2) result (qn3)
     type(quantum_numbers_t) :: qn3
     type(quantum_numbers_t), intent(in) :: qn1, qn2
     qn3%f = qn1%f .merge. qn2%f
     qn3%c = qn1%c .merge. qn2%c
     qn3%h = qn1%h .merge. qn2%h
     qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub)
   end function merge_quantum_numbers0
 
   function merge_quantum_numbers1 (qn1, qn2) result (qn3)
     type(quantum_numbers_t), dimension(:), intent(in) :: qn1, qn2
     type(quantum_numbers_t), dimension(size(qn1)) :: qn3
     qn3%f = qn1%f .merge. qn2%f
     qn3%c = qn1%c .merge. qn2%c
     qn3%h = qn1%h .merge. qn2%h
     qn3%sub = merge_subtraction_index (qn1%sub, qn2%sub)
   end function merge_quantum_numbers1
 
 @ %def merge_quantum_numbers
 @
 <<Quantum numbers: procedures>>=
   elemental function merge_subtraction_index (sub1, sub2) result (sub3)
     integer :: sub3
     integer, intent(in) :: sub1, sub2
     if (sub1 > 0 .and. sub2 > 0) then
        if (sub1 == sub2) then
           sub3 = sub1
        else
           sub3 = 0
        end if
     else if (sub1 > 0) then
        sub3 = sub1
     else if (sub2 > 0) then
        sub3 = sub2
     else
        sub3 = 0
     end if
   end function merge_subtraction_index
 
 @ %def merge_subtraction_index
 @
 \subsection{The quantum number mask}
 The quantum numbers mask is true for quantum numbers that should be
 ignored or summed over.  The three mandatory entries correspond to
 flavor, color, and helicity, respectively.
 
 There is an additional entry [[cg]]: If false, the color-ghosts
 property should be kept even if color is ignored.  This is relevant
 only if [[c]] is set, otherwise it is always false.
 
 The flag [[hd]] tells that only diagonal entries in helicity should be
 kept.  If [[h]] is set, [[hd]] is irrelevant and will be kept
 [[.false.]]
 <<Quantum numbers: public>>=
   public :: quantum_numbers_mask_t
 <<Quantum numbers: types>>=
   type :: quantum_numbers_mask_t
      private
      logical :: f = .false.
      logical :: c = .false.
      logical :: cg = .false.
      logical :: h = .false.
      logical :: hd = .false.
      integer :: sub = 0
    contains
    <<Quantum numbers: quantum numbers mask: TBP>>
   end type quantum_numbers_mask_t
 
 @ %def quantum_number_t
 @ Define a quantum number mask: Constructor form
 <<Quantum numbers: public>>=
   public :: quantum_numbers_mask
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_mask &
        (mask_f, mask_c, mask_h, mask_cg, mask_hd) result (mask)
     type(quantum_numbers_mask_t) :: mask
     logical, intent(in) :: mask_f, mask_c, mask_h
     logical, intent(in), optional :: mask_cg
     logical, intent(in), optional :: mask_hd
     call quantum_numbers_mask_init &
          (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd)
   end function quantum_numbers_mask
 
 @ %def new_quantum_numbers_mask
 @ Define quantum numbers: Initializer form
 <<Quantum numbers: quantum numbers mask: TBP>>=
   procedure :: init => quantum_numbers_mask_init
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_mask_init &
        (mask, mask_f, mask_c, mask_h, mask_cg, mask_hd)
     class(quantum_numbers_mask_t), intent(inout) :: mask
     logical, intent(in) :: mask_f, mask_c, mask_h
     logical, intent(in), optional :: mask_cg, mask_hd
     mask%f = mask_f
     mask%c = mask_c
     mask%h = mask_h
     mask%cg = .false.
     if (present (mask_cg)) then
        if (mask%c)  mask%cg = mask_cg
     else
        mask%cg = mask_c
     end if
     mask%hd = .false.
     if (present (mask_hd)) then
        if (.not. mask%h)  mask%hd = mask_hd
     end if
   end subroutine quantum_numbers_mask_init
 
 @ %def quantum_numbers_mask_init
 @ Write a quantum numbers mask.  We need the stand-alone subroutine for the
 array case.
 <<Quantum numbers: public>>=
   public :: quantum_numbers_mask_write
 <<Quantum numbers: interfaces>>=
   interface quantum_numbers_mask_write
      module procedure quantum_numbers_mask_write_single
      module procedure quantum_numbers_mask_write_array
   end interface
 <<Quantum numbers: quantum numbers mask: TBP>>=
   procedure :: write => quantum_numbers_mask_write_single
 <<Quantum numbers: procedures>>=
   subroutine quantum_numbers_mask_write_single (mask, unit)
     class(quantum_numbers_mask_t), intent(in) :: mask
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(A)", advance="no") "["
     write (u, "(L1)", advance="no")  mask%f
     write (u, "(L1)", advance="no")  mask%c
     if (.not.mask%cg)  write (u, "('g')", advance="no")
     write (u, "(L1)", advance="no")  mask%h
     if (mask%hd)  write (u, "('d')", advance="no")
     write (u, "(A)", advance="no") "]"
   end subroutine quantum_numbers_mask_write_single
 
   subroutine quantum_numbers_mask_write_array (mask, unit)
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(A)", advance="no") "["
     do i = 1, size (mask)
        if (i > 1)  write (u, "(A)", advance="no")  "/"
        write (u, "(L1)", advance="no")  mask(i)%f
        write (u, "(L1)", advance="no")  mask(i)%c
        if (.not.mask(i)%cg)  write (u, "('g')", advance="no")
        write (u, "(L1)", advance="no")  mask(i)%h
        if (mask(i)%hd)  write (u, "('d')", advance="no")
     end do
     write (u, "(A)", advance="no") "]"
   end subroutine quantum_numbers_mask_write_array
 
 @ %def quantum_numbers_mask_write
 @
 \subsection{Setting mask components}
 <<Quantum numbers: quantum numbers mask: TBP>>=
   procedure :: set_flavor => quantum_numbers_mask_set_flavor
   procedure :: set_color => quantum_numbers_mask_set_color
   procedure :: set_helicity => quantum_numbers_mask_set_helicity
   procedure :: set_sub => quantum_numbers_mask_set_sub
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_mask_set_flavor (mask, mask_f)
     class(quantum_numbers_mask_t), intent(inout) :: mask
     logical, intent(in) :: mask_f
     mask%f = mask_f
   end subroutine quantum_numbers_mask_set_flavor
 
   elemental subroutine quantum_numbers_mask_set_color (mask, mask_c, mask_cg)
     class(quantum_numbers_mask_t), intent(inout) :: mask
     logical, intent(in) :: mask_c
     logical, intent(in), optional :: mask_cg
     mask%c = mask_c
     if (present (mask_cg)) then
        if (mask%c)  mask%cg = mask_cg
     else
        mask%cg = mask_c
     end if
   end subroutine quantum_numbers_mask_set_color
 
   elemental subroutine quantum_numbers_mask_set_helicity (mask, mask_h, mask_hd)
     class(quantum_numbers_mask_t), intent(inout) :: mask
     logical, intent(in) :: mask_h
     logical, intent(in), optional :: mask_hd
     mask%h = mask_h
     if (present (mask_hd)) then
        if (.not. mask%h)  mask%hd = mask_hd
     end if
   end subroutine quantum_numbers_mask_set_helicity
 
   elemental subroutine quantum_numbers_mask_set_sub (mask, sub)
     class(quantum_numbers_mask_t), intent(inout) :: mask
     integer, intent(in) :: sub
     mask%sub = sub
   end subroutine quantum_numbers_mask_set_sub
 
 @ %def quantum_numbers_mask_set_flavor
 @ %def quantum_numbers_mask_set_color
 @ %def quantum_numbers_mask_set_helicity
 @ %def quantum_numbers_mask_set_sub
 @ The following routines assign part of a mask, depending on the flags given.
 <<Quantum numbers: quantum numbers mask: TBP>>=
   procedure :: assign => quantum_numbers_mask_assign
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_mask_assign &
        (mask, mask_in, flavor, color, helicity)
     class(quantum_numbers_mask_t), intent(inout) :: mask
     class(quantum_numbers_mask_t), intent(in) :: mask_in
     logical, intent(in), optional :: flavor, color, helicity
     if (present (flavor)) then
        if (flavor) then
           mask%f = mask_in%f
        end if
     end if
     if (present (color)) then
        if (color) then
           mask%c = mask_in%c
           mask%cg = mask_in%cg
        end if
     end if
     if (present (helicity)) then
        if (helicity) then
           mask%h = mask_in%h
           mask%hd = mask_in%hd
        end if
     end if
   end subroutine quantum_numbers_mask_assign
 
 @ %def quantum_numbers_mask_assign
 @
 \subsection{Mask predicates}
 Return true if either one of the entries is set:
 <<Quantum numbers: public>>=
   public :: any
 <<Quantum numbers: interfaces>>=
   interface any
      module procedure quantum_numbers_mask_any
   end interface
 <<Quantum numbers: procedures>>=
   function quantum_numbers_mask_any (mask) result (match)
     logical :: match
     type(quantum_numbers_mask_t), intent(in) :: mask
     match = mask%f .or. mask%c .or. mask%h .or. mask%hd
   end function quantum_numbers_mask_any
 
 @ %def any
 @
 \subsection{Operators}
 The OR operation is applied to all components.
 <<Quantum numbers: quantum numbers mask: TBP>>=
   generic :: operator(.or.) => quantum_numbers_mask_or
   procedure, private :: quantum_numbers_mask_or
 @ %def .or.
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_mask_or (mask1, mask2) result (mask)
     type(quantum_numbers_mask_t) :: mask
     class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
     mask%f = mask1%f .or. mask2%f
     mask%c = mask1%c .or. mask2%c
     if (mask%c)  mask%cg = mask1%cg .or. mask2%cg
     mask%h = mask1%h .or. mask2%h
     if (.not. mask%h)  mask%hd = mask1%hd .or. mask2%hd
   end function quantum_numbers_mask_or
 
 @ %def quantum_numbers_mask_or
 @
 \subsection{Mask comparisons}
 Return true if the two masks are equivalent / differ:
 <<Quantum numbers: quantum numbers mask: TBP>>=
   generic :: operator(.eqv.) => quantum_numbers_mask_eqv
   generic :: operator(.neqv.) => quantum_numbers_mask_neqv
   procedure, private :: quantum_numbers_mask_eqv
   procedure, private :: quantum_numbers_mask_neqv
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_mask_eqv (mask1, mask2) result (eqv)
     logical :: eqv
     class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
     eqv = (mask1%f .eqv. mask2%f) .and. &
          (mask1%c .eqv. mask2%c) .and. &
          (mask1%cg .eqv. mask2%cg) .and. &
          (mask1%h .eqv. mask2%h) .and. &
          (mask1%hd .eqv. mask2%hd)
   end function quantum_numbers_mask_eqv
 
   elemental function quantum_numbers_mask_neqv (mask1, mask2) result (neqv)
     logical :: neqv
     class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
     neqv = (mask1%f .neqv. mask2%f) .or. &
          (mask1%c .neqv. mask2%c) .or. &
          (mask1%cg .neqv. mask2%cg) .or. &
          (mask1%h .neqv. mask2%h) .or. &
          (mask1%hd .neqv. mask2%hd)
   end function quantum_numbers_mask_neqv
 
 @ %def .eqv. .neqv.
 @
 \subsection{Apply a mask}
 Applying a mask to the quantum number object means undefining those
 entries where the mask is set.  The others remain unaffected.
 
 The [[hd]] mask has the special property that it ``diagonalizes''
 helicity, i.e., the second helicity entry is dropped and the result is
 a diagonal helicity quantum number.
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: undefine => quantum_numbers_undefine
   procedure :: undefined => quantum_numbers_undefined0
 <<Quantum numbers: public>>=
   public :: quantum_numbers_undefined
 <<Quantum numbers: interfaces>>=
   interface quantum_numbers_undefined
      module procedure quantum_numbers_undefined0
      module procedure quantum_numbers_undefined1
      module procedure quantum_numbers_undefined11
   end interface
 
 <<Quantum numbers: procedures>>=
   elemental subroutine quantum_numbers_undefine (qn, mask)
     class(quantum_numbers_t), intent(inout) :: qn
     type(quantum_numbers_mask_t), intent(in) :: mask
     if (mask%f)  call qn%f%undefine ()
     if (mask%c)  call qn%c%undefine (undefine_ghost = mask%cg)
     if (mask%h) then
        call qn%h%undefine ()
     else if (mask%hd) then
        if (.not. qn%h%is_diagonal ()) then
           call qn%h%diagonalize ()
        end if
     end if
     if (mask%sub > 0)  qn%sub = 0
   end subroutine quantum_numbers_undefine
 
   function quantum_numbers_undefined0 (qn, mask) result (qn_new)
     class(quantum_numbers_t), intent(in) :: qn
     type(quantum_numbers_mask_t), intent(in) :: mask
     type(quantum_numbers_t) :: qn_new
     select type (qn)
     type is (quantum_numbers_t);  qn_new = qn
     end select
     call quantum_numbers_undefine (qn_new, mask)
   end function quantum_numbers_undefined0
 
   function quantum_numbers_undefined1 (qn, mask) result (qn_new)
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     type(quantum_numbers_mask_t), intent(in) :: mask
     type(quantum_numbers_t), dimension(size(qn)) :: qn_new
     qn_new = qn
     call quantum_numbers_undefine (qn_new, mask)
   end function quantum_numbers_undefined1
 
   function quantum_numbers_undefined11 (qn, mask) result (qn_new)
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
     type(quantum_numbers_t), dimension(size(qn)) :: qn_new
     qn_new = qn
     call quantum_numbers_undefine (qn_new, mask)
   end function quantum_numbers_undefined11
 
 @ %def quantum_numbers_undefine
 @ %def quantum_numbers_undefined
 @ Return true if the input quantum number set has entries that would
 be removed by the applied mask, e.g., if polarization is defined but
 [[mask%h]] is set:
 <<Quantum numbers: quantum numbers: TBP>>=
   procedure :: are_redundant => quantum_numbers_are_redundant
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_are_redundant (qn, mask) &
        result (redundant)
     logical :: redundant
     class(quantum_numbers_t), intent(in) :: qn
     type(quantum_numbers_mask_t), intent(in) :: mask
     redundant = .false.
     if (mask%f) then
        redundant = qn%f%is_defined ()
     end if
     if (mask%c) then
        redundant = qn%c%is_defined ()
     end if
     if (mask%h) then
        redundant = qn%h%is_defined ()
     else if (mask%hd) then
        redundant = .not. qn%h%is_diagonal ()
     end if
     if (mask%sub > 0) redundant = qn%sub >= mask%sub
   end function quantum_numbers_are_redundant
 
 @ %def quantum_numbers_are_redundant
 @ Return true if the helicity flag is set or the diagonal-helicity flag is
 set.
 <<Quantum numbers: quantum numbers mask: TBP>>=
   procedure :: diagonal_helicity => quantum_numbers_mask_diagonal_helicity
 <<Quantum numbers: procedures>>=
   elemental function quantum_numbers_mask_diagonal_helicity (mask) &
        result (flag)
     logical :: flag
     class(quantum_numbers_mask_t), intent(in) :: mask
     flag = mask%h .or. mask%hd
   end function quantum_numbers_mask_diagonal_helicity
 
 @ %def quantum_numbers_mask_diagonal_helicity
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Transition Matrices and Evaluation}
 
 The modules in this chapter implement transition matrices and calculations.
 The functionality is broken down in three modules
 \begin{description}
 \item[state\_matrices]
   represent state and transition density matrices built from particle quantum
   numbers (helicity, color, flavor)
 \item[interactions]
   extend state matrices with the record of particle momenta.  They also
   distinguish in- and out-particles and store parent-child relations.
 \item[evaluators]
   These objects extend interaction objects by the information how to calculate
   matrix elements from products and squares of other interactions.  They
   implement the methods to actually compute those matrix elements.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{State matrices}
 This module deals with the internal state of a particle system, i.e.,
 with its density matrix in flavor, color, and helicity space.
 <<[[state_matrices.f90]]>>=
 <<File header>>
 
 module state_matrices
 
 <<Use kinds>>
+  use constants, only: zero
   use io_units
   use format_utils, only: pac_fmt
   use format_defs, only: FMT_17, FMT_19
   use diagnostics
   use sorting
   use model_data
   use flavors
   use colors
   use helicities
   use quantum_numbers
 
 <<Standard module head>>
 
 <<State matrices: public>>
 
 <<State matrices: parameters>>
 
 <<State matrices: types>>
 
 <<State matrices: interfaces>>
 
 contains
 
 <<State matrices: procedures>>
 
 end module state_matrices
 @ %def state_matrices
 @
 \subsection{Nodes of the quantum state trie}
 A quantum state object represents an unnormalized density matrix,
 i.e., an array of possibilities for flavor, color, and helicity
 indices with associated complex values.  Physically, the trace of this
 matrix is the summed squared matrix element for an interaction, and
 the matrix elements divided by this value correspond to the
 flavor-color-helicity density matrix.  (Flavor and color are
 diagonal.)
 
 We store density matrices as tries, that is, as trees where each
 branching represents the possible quantum numbers of a particle.  The
 first branching is the first particle in the system.  A leaf (the node
 corresponding to the last particle) contains the value of the matrix
 element.
 
 Each node contains a flavor, color, and helicity entry.  Note that
 each of those entries may be actually undefined, so we can also represent,
 e.g., unpolarized particles.
 
 The value is meaningful only for leaves, which have no child nodes.
 There is a pointer to the parent node which allows for following the
 trie downwards from a leaf, it is null for a root node.  The child
 nodes are implemented as a list, so there is a pointer to the first
 and last child, and each node also has a [[next]] pointer to the next
 sibling.
 
 The root node does not correspond to a particle, only its children do.
 The quantum numbers of the root node are irrelevant and will not be
 set.  However, we use a common type for the three classes (root,
 branch, leaf); they may easily be distinguished by the association
 status of parent and child.
 
 \subsubsection{Node type}
 The node is linked in all directions: the parent, the first and last
 in the list of children, and the previous and next sibling.  This allows
 us for adding and removing nodes and whole branches anywhere in the
 trie.  (Circular links are not allowed, however.).  The node holds its
 associated set of quantum numbers.  The integer index, which is set
 only for leaf nodes, is the index of the corresponding matrix element
 value within the state matrix.
 
 Temporarily, matrix-element values may be stored within a leaf node.
 This is used during state-matrix factorization.  When the state matrix
 is [[freeze]]d, these values are transferred to the matrix-element
 array within the host state matrix.
 <<State matrices: types>>=
   type :: node_t
      private
      type(quantum_numbers_t) :: qn
      type(node_t), pointer :: parent => null ()
      type(node_t), pointer :: child_first => null ()
      type(node_t), pointer :: child_last => null ()
      type(node_t), pointer :: next => null ()
      type(node_t), pointer :: previous => null ()
      integer :: me_index = 0
      integer, dimension(:), allocatable :: me_count
      complex(default) :: me = 0
   end type node_t
 
 @ %def node_t
 @
 \subsubsection{Operations on nodes}
 Recursively deallocate all children of the current
 node.  This includes any values associated with the children.
 <<State matrices: procedures>>=
   pure recursive subroutine node_delete_offspring (node)
     type(node_t), pointer :: node
     type(node_t), pointer :: child
     child => node%child_first
     do while (associated (child))
        node%child_first => node%child_first%next
        call node_delete_offspring (child)
        deallocate (child)
        child => node%child_first
     end do
     node%child_last => null ()
   end subroutine node_delete_offspring
 
 @ %def node_delete_offspring
 @ Remove a node including its offspring.  Adjust the pointers of
 parent and siblings, if necessary.
 <<State matrices: procedures>>=
   pure subroutine node_delete (node)
     type(node_t), pointer :: node
     call node_delete_offspring (node)
     if (associated (node%previous)) then
        node%previous%next => node%next
     else if (associated (node%parent)) then
        node%parent%child_first => node%next
     end if
     if (associated (node%next)) then
        node%next%previous => node%previous
     else if (associated (node%parent)) then
        node%parent%child_last => node%previous
     end if
     deallocate (node)
   end subroutine node_delete
 
 @ %def node_delete
 @ Append a child node
 <<State matrices: procedures>>=
   subroutine node_append_child (node, child)
     type(node_t), target, intent(inout) :: node
     type(node_t), pointer :: child
     allocate (child)
     if (associated (node%child_last)) then
        node%child_last%next => child
        child%previous => node%child_last
     else
        node%child_first => child
     end if
     node%child_last => child
     child%parent => node
   end subroutine node_append_child
 
 @ %def node_append_child
 @
 \subsubsection{I/O}
 Output of a single node, no recursion.  We print the quantum numbers
 in square brackets, then the value (if any).
 <<State matrices: procedures>>=
   subroutine node_write (node, me_array, verbose, unit, col_verbose, testflag)
     type(node_t), intent(in) :: node
     complex(default), dimension(:), intent(in), optional :: me_array
     logical, intent(in), optional :: verbose, col_verbose, testflag
     integer, intent(in), optional :: unit
     logical :: verb
     integer :: u
     character(len=7) :: fmt
     call pac_fmt (fmt, FMT_19, FMT_17, testflag)
     verb = .false.;  if (present (verbose)) verb = verbose
     u = given_output_unit (unit);  if (u < 0)  return
     call node%qn%write (u, col_verbose)
     if (node%me_index /= 0) then
        write (u, "(A,I0,A)", advance="no")  " => ME(", node%me_index, ")"
        if (present (me_array)) then
           write (u, "(A)", advance="no")  " = "
           write (u, "('('," // fmt // ",','," // fmt // ",')')", &
                advance="no") pacify_complex (me_array(node%me_index))
        end if
     end if
     write (u, *)
     if (verb) then
        call ptr_write ("parent     ", node%parent)
        call ptr_write ("child_first", node%child_first)
        call ptr_write ("child_last ", node%child_last)
        call ptr_write ("next       ", node%next)
        call ptr_write ("previous   ", node%previous)
     end if
   contains
     subroutine ptr_write (label, node)
       character(*), intent(in) :: label
       type(node_t), pointer :: node
       if (associated (node)) then
          write (u, "(10x,A,1x,'->',1x)", advance="no") label
          call node%qn%write (u, col_verbose)
          write (u, *)
       end if
     end subroutine ptr_write
   end subroutine node_write
 
 @ %def node_write
 @ Recursive output of a node:
 <<State matrices: procedures>>=
   recursive subroutine node_write_rec (node, me_array, verbose, &
         indent, unit, col_verbose, testflag)
     type(node_t), intent(in), target :: node
     complex(default), dimension(:), intent(in), optional :: me_array
     logical, intent(in), optional :: verbose, col_verbose, testflag
     integer, intent(in), optional :: indent
     integer, intent(in), optional :: unit
     type(node_t), pointer :: current
     logical :: verb
     integer :: i, u
     verb = .false.;  if (present (verbose))  verb = verbose
     i = 0;  if (present (indent)) i = indent
     u = given_output_unit (unit);  if (u < 0)  return
     current => node%child_first
     do while (associated (current))
        write (u, "(A)", advance="no")  repeat (" ", i)
        call node_write (current, me_array, verbose = verb, &
             unit = u, col_verbose = col_verbose, testflag = testflag)
        call node_write_rec (current, me_array, verbose = verb, &
  	    indent = i + 2, unit = u, col_verbose = col_verbose, testflag = testflag)
        current => current%next
     end do
   end subroutine node_write_rec
 
 @ %def node_write_rec
 @ Binary I/O.  Matrix elements are written only for leaf nodes.
 <<State matrices: procedures>>=
   recursive subroutine node_write_raw_rec (node, u)
     type(node_t), intent(in), target :: node
     integer, intent(in) :: u
     logical :: associated_child_first, associated_next
     call node%qn%write_raw (u)
     associated_child_first = associated (node%child_first)
     write (u) associated_child_first
     associated_next = associated (node%next)
     write (u) associated_next
     if (associated_child_first) then
        call node_write_raw_rec (node%child_first, u)
     else
        write (u)  node%me_index
        write (u)  node%me
     end if
     if (associated_next) then
        call node_write_raw_rec (node%next, u)
     end if
   end subroutine node_write_raw_rec
 
   recursive subroutine node_read_raw_rec (node, u, parent, iostat)
     type(node_t), intent(out), target :: node
     integer, intent(in) :: u
     type(node_t), intent(in), optional, target :: parent
     integer, intent(out), optional :: iostat
     logical :: associated_child_first, associated_next
     type(node_t), pointer :: child
     call node%qn%read_raw (u, iostat=iostat)
     read (u, iostat=iostat) associated_child_first
     read (u, iostat=iostat) associated_next
     if (present (parent))  node%parent => parent
     if (associated_child_first) then
        allocate (child)
        node%child_first => child
        node%child_last => null ()
        call node_read_raw_rec (child, u, node, iostat=iostat)
        do while (associated (child))
           child%previous => node%child_last
           node%child_last => child
           child => child%next
        end do
     else
        read (u, iostat=iostat)  node%me_index
        read (u, iostat=iostat)  node%me
     end if
     if (associated_next) then
        allocate (node%next)
        call node_read_raw_rec (node%next, u, parent, iostat=iostat)
     end if
   end subroutine node_read_raw_rec
 
 @ %def node_write_raw
 @
 \subsection{State matrix}
 \subsubsection{Definition}
 The quantum state object is a container that keeps and hides the root
 node.  For direct accessibility of values, they are stored
 in a separate array.  The leaf nodes of the quantum-number tree point to those
 values, once the state matrix is finalized.
 
 The [[norm]] component is redefined if a common factor is extracted from all
 nodes.
 <<State matrices: public>>=
   public :: state_matrix_t
 <<State matrices: types>>=
   type :: state_matrix_t
      private
      type(node_t), pointer :: root => null ()
      integer :: depth = 0
      integer :: n_matrix_elements = 0
      logical :: leaf_nodes_store_values = .false.
      integer :: n_counters = 0
      complex(default), dimension(:), allocatable :: me
      real(default) :: norm = 1
      integer :: n_sub = -1
    contains
    <<State matrices: state matrix: TBP>>
   end type state_matrix_t
 
 @ %def state_matrix_t
 @ This initializer allocates the root node but does not fill
 anything.  We declare whether values are stored within the nodes
 during state-matrix construction, and how many counters should be
 maintained (default: none).
 <<State matrices: state matrix: TBP>>=
   procedure :: init => state_matrix_init
 <<State matrices: procedures>>=
   subroutine state_matrix_init (state, store_values, n_counters)
     class(state_matrix_t), intent(out) :: state
     logical, intent(in), optional :: store_values
     integer, intent(in), optional :: n_counters
     allocate (state%root)
     if (present (store_values)) &
        state%leaf_nodes_store_values = store_values
     if (present (n_counters)) state%n_counters = n_counters
   end subroutine state_matrix_init
 
 @ %def state_matrix_init
 @ This recursively deletes all children of the root node, restoring
 the initial state.  The matrix element array is not finalized, since
 it does not contain physical entries, just pointers.
 <<State matrices: state matrix: TBP>>=
   procedure :: final => state_matrix_final
 <<State matrices: procedures>>=
   subroutine state_matrix_final (state)
     class(state_matrix_t), intent(inout) :: state
     if (allocated (state%me))  deallocate (state%me)
     if (associated (state%root))  call node_delete (state%root)
     state%depth = 0
     state%n_matrix_elements = 0
   end subroutine state_matrix_final
 
 @ %def state_matrix_final
 @ Output: Present the tree as a nested list with appropriate
 indentation.
 <<State matrices: state matrix: TBP>>=
   procedure :: write => state_matrix_write
 <<State matrices: procedures>>=
   subroutine state_matrix_write (state, unit, write_value_list, &
          verbose, col_verbose, testflag)
     class(state_matrix_t), intent(in) :: state
     logical, intent(in), optional :: write_value_list, verbose, col_verbose
     logical, intent(in), optional :: testflag
     integer, intent(in), optional :: unit
     complex(default) :: me_dum
     character(len=7) :: fmt
     integer :: u
     integer :: i
     call pac_fmt (fmt, FMT_19, FMT_17, testflag)
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A," // fmt // ")") "State matrix:  norm = ", state%norm
     if (associated (state%root)) then
        if (allocated (state%me)) then
           call node_write_rec (state%root, state%me, verbose = verbose, &
                indent = 1, unit = u, col_verbose = col_verbose, &
                testflag = testflag)
        else
           call node_write_rec (state%root, verbose = verbose, indent = 1, &
                unit = u, col_verbose = col_verbose, testflag = testflag)
        end if
     end if
     if (present (write_value_list)) then
        if (write_value_list .and. allocated (state%me)) then
           do i = 1, size (state%me)
              write (u, "(1x,I0,A)", advance="no")  i, ":"
              me_dum = state%me(i)
              if (real(state%me(i)) == -real(state%me(i))) then
                 me_dum = &
                      cmplx (0._default, aimag(me_dum), kind=default)
              end if
              if (aimag(me_dum) == -aimag(me_dum)) then
                 me_dum = &
                      cmplx (real(me_dum), 0._default, kind=default)
              end if
              write (u, "('('," // fmt // ",','," // fmt // &
                   ",')')")  me_dum
           end do
        end if
     end if
   end subroutine state_matrix_write
 
 @ %def state_matrix_write
 @ Binary I/O.  The auxiliary matrix-element array is not written, but
 reconstructed after reading the tree.
 
 Note: To be checked.  Might be broken, don't use (unless trivial).
 <<State matrices: state matrix: TBP>>=
   procedure :: write_raw => state_matrix_write_raw
   procedure :: read_raw => state_matrix_read_raw
 <<State matrices: procedures>>=
   subroutine state_matrix_write_raw (state, u)
     class(state_matrix_t), intent(in), target :: state
     integer, intent(in) :: u
     logical :: is_defined
     integer :: depth, j
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     is_defined = state%is_defined ()
     write (u)  is_defined
     if (is_defined) then
        write (u)  state%get_norm ()
        write (u)  state%get_n_leaves ()
        depth = state%get_depth ()
        write (u)  depth
        allocate (qn (depth))
        call it%init (state)
        do while (it%is_valid ())
           qn = it%get_quantum_numbers ()
           do j = 1, depth
              call qn(j)%write_raw (u)
           end do
           write (u)  it%get_me_index ()
           write (u)  it%get_matrix_element ()
           call it%advance ()
        end do
     end if
   end subroutine state_matrix_write_raw
 
   subroutine state_matrix_read_raw (state, u, iostat)
     class(state_matrix_t), intent(out) :: state
     integer, intent(in) :: u
     integer, intent(out) :: iostat
     logical :: is_defined
     real(default) :: norm
     integer :: n_leaves, depth, i, j
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer :: me_index
     complex(default) :: me
     read (u, iostat=iostat)  is_defined
     if (iostat /= 0)  goto 1
     if (is_defined) then
        call state%init (store_values = .true.)
        read (u, iostat=iostat)  norm
        if (iostat /= 0)  goto 1
        call state_matrix_set_norm (state, norm)
        read (u)  n_leaves
        if (iostat /= 0)  goto 1
        read (u)  depth
        if (iostat /= 0)  goto 1
        allocate (qn (depth))
        do i = 1, n_leaves
           do j = 1, depth
              call qn(j)%read_raw (u, iostat=iostat)
              if (iostat /= 0)  goto 1
           end do
           read (u, iostat=iostat)  me_index
           if (iostat /= 0)  goto 1
           read (u, iostat=iostat)  me
           if (iostat /= 0)  goto 1
           call state%add_state (qn, index = me_index, value = me)
        end do
        call state_matrix_freeze (state)
     end if
     return
 
     ! Clean up on error
 1   continue
     call state%final ()
   end subroutine state_matrix_read_raw
 
 @ %def state_matrix_write_raw state_matrix_read_raw
 @ Assign a model pointer to all flavor entries.  This will become
 necessary when we have read a state matrix from file.
 <<State matrices: state matrix: TBP>>=
   procedure :: set_model => state_matrix_set_model
 <<State matrices: procedures>>=
   subroutine state_matrix_set_model (state, model)
     class(state_matrix_t), intent(inout), target :: state
     class(model_data_t), intent(in), target :: model
     type(state_iterator_t) :: it
     call it%init (state)
     do while (it%is_valid ())
        call it%set_model (model)
        call it%advance ()
     end do
   end subroutine state_matrix_set_model
 
 @ %def state_matrix_set_model
 @ Iterate over [[state]], get the quantum numbers array [[qn]] for each iteration, and tag
 all array elements of [[qn]] with the indizes given by [[tag]] as part of the hard interaction.
 Then add them to [[tagged_state]] and return it. If no [[tag]] is given, tag all [[qn]] as
 part of the hard process.
 <<State matrices: state matrix: TBP>>=
   procedure :: tag_hard_process => state_matrix_tag_hard_process
 <<State matrices: procedures>>=
   subroutine state_matrix_tag_hard_process (state, tagged_state, tag)
     class(state_matrix_t), intent(in), target :: state
     type(state_matrix_t), intent(out) :: tagged_state
     integer, dimension(:), intent(in), optional :: tag
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     complex(default) :: value
     integer :: i
     call tagged_state%init (store_values = .true.)
     call it%init (state)
     do while (it%is_valid ())
        qn = it%get_quantum_numbers ()
        value = it%get_matrix_element ()
        if (present (tag)) then
           do i = 1, size (tag)
              call qn(tag(i))%tag_hard_process ()
           end do
        else
           call qn%tag_hard_process ()
        end if
        call tagged_state%add_state (qn, index = it%get_me_index (), value = value)
        call it%advance ()
     end do
     call tagged_state%freeze ()
   end subroutine state_matrix_tag_hard_process
 
 @ %def state_matrix_tag_hard_process
 \subsubsection{Properties of the quantum state}
 A state is defined if its root is allocated:
 <<State matrices: state matrix: TBP>>=
   procedure :: is_defined => state_matrix_is_defined
 <<State matrices: procedures>>=
   elemental function state_matrix_is_defined (state) result (defined)
     logical :: defined
     class(state_matrix_t), intent(in) :: state
     defined = associated (state%root)
   end function state_matrix_is_defined
 
 @ %def state_matrix_is_defined
 @ A state is empty if its depth is zero:
 <<State matrices: state matrix: TBP>>=
   procedure :: is_empty => state_matrix_is_empty
 <<State matrices: procedures>>=
   elemental function state_matrix_is_empty (state) result (flag)
     logical :: flag
     class(state_matrix_t), intent(in) :: state
     flag = state%depth == 0
   end function state_matrix_is_empty
 
 @ %def state_matrix_is_empty
 @ Return the number of matrix-element values.
 <<State matrices: state matrix: TBP>>=
   generic :: get_n_matrix_elements => get_n_matrix_elements_all, get_n_matrix_elements_mask
   procedure :: get_n_matrix_elements_all => state_matrix_get_n_matrix_elements_all
   procedure :: get_n_matrix_elements_mask => state_matrix_get_n_matrix_elements_mask
 <<State matrices: procedures>>=
   pure function state_matrix_get_n_matrix_elements_all (state) result (n)
     integer :: n
     class(state_matrix_t), intent(in) :: state
     n = state%n_matrix_elements
   end function state_matrix_get_n_matrix_elements_all
 
 @ %def state_matrix_get_n_matrix_elements_all
 @
 <<State matrices: procedures>>=
   function state_matrix_get_n_matrix_elements_mask (state, qn_mask) result (n)
     integer :: n
     class(state_matrix_t), intent(in) :: state
     type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(size(qn_mask)) :: qn
     type(state_matrix_t) :: state_tmp
     call state_tmp%init ()
     call it%init (state)
     do while (it%is_valid ())
        qn = it%get_quantum_numbers ()
        call qn%undefine (qn_mask)
        call state_tmp%add_state (qn)
        call it%advance ()
     end do
     n = state_tmp%n_matrix_elements
     call state_tmp%final ()
   end function state_matrix_get_n_matrix_elements_mask
 
 @ %def state_matrix_get_n_matrix_elments_mask
 @ Return the size of the [[me]]-array for debugging purposes.
 <<State matrices: state matrix: TBP>>=
   procedure :: get_me_size => state_matrix_get_me_size
 <<State matrices: procedures>>=
   pure function state_matrix_get_me_size (state) result (n)
     integer :: n
     class(state_matrix_t), intent(in) :: state
     if (allocated (state%me)) then
        n = size (state%me)
     else
        n = 0
     end if
   end function state_matrix_get_me_size
 
 @ %def state_matrix_get_me_size
 @
 <<State matrices: state matrix: TBP>>=
   procedure :: compute_n_sub => state_matrix_compute_n_sub
 <<State matrices: procedures>>=
   function state_matrix_compute_n_sub (state) result (n_sub)
     integer :: n_sub
     class(state_matrix_t), intent(in) :: state
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(state%depth) :: qn
     integer :: sub, sub_pos
     n_sub = 0
     call it%init (state)
     do while (it%is_valid ())
        qn = it%get_quantum_numbers ()
        sub = 0
        sub_pos = qn_array_sub_pos ()
        if (sub_pos > 0)  sub = qn(sub_pos)%get_sub ()
        if (sub > n_sub)  n_sub = sub
        call it%advance ()
     end do
   contains
     function qn_array_sub_pos () result (pos)
       integer :: pos
       integer :: i
       pos = 0
       do i = 1, state%depth
          if (qn(i)%get_sub () > 0) then
             pos = i
             exit
          end if
       end do
     end function qn_array_sub_pos
   end function state_matrix_compute_n_sub
 
 @ %def state_matrix_compute_n_sub
 @
 <<State matrices: state matrix: TBP>>=
   procedure :: set_n_sub => state_matrix_set_n_sub
 <<State matrices: procedures>>=
   subroutine state_matrix_set_n_sub (state)
     class(state_matrix_t), intent(inout) :: state
     state%n_sub = state%compute_n_sub ()
   end subroutine state_matrix_set_n_sub
 
 @ %def state_matrix_set_n_sub
 @ Return number of subtractions.
 <<State matrices: state matrix: TBP>>=
   procedure :: get_n_sub => state_matrix_get_n_sub
 <<State matrices: procedures>>=
   function state_matrix_get_n_sub (state) result (n_sub)
     integer :: n_sub
     class(state_matrix_t), intent(in) :: state
     if (state%n_sub < 0) then
        call msg_bug ("[state_matrix_get_n_sub] number of subtractions not set.")
     end if
     n_sub = state%n_sub
   end function state_matrix_get_n_sub
 
 @ %def state_matrix_get_n_sub
 @ Return the number of leaves.  This can be larger than the number of
 independent matrix elements.
 <<State matrices: state matrix: TBP>>=
   procedure :: get_n_leaves => state_matrix_get_n_leaves
 <<State matrices: procedures>>=
   function state_matrix_get_n_leaves (state) result (n)
     integer :: n
     class(state_matrix_t), intent(in) :: state
     type(state_iterator_t) :: it
     n = 0
     call it%init (state)
     do while (it%is_valid ())
        n = n + 1
        call it%advance ()
     end do
   end function state_matrix_get_n_leaves
 
 @ %def state_matrix_get_n_leaves
 @ Return the depth:
 <<State matrices: state matrix: TBP>>=
   procedure :: get_depth => state_matrix_get_depth
 <<State matrices: procedures>>=
   pure function state_matrix_get_depth (state) result (depth)
     integer :: depth
     class(state_matrix_t), intent(in) :: state
     depth = state%depth
   end function state_matrix_get_depth
 
 @ %def state_matrix_get_depth
 @ Return the norm:
 <<State matrices: state matrix: TBP>>=
   procedure :: get_norm => state_matrix_get_norm
 <<State matrices: procedures>>=
   pure function state_matrix_get_norm (state) result (norm)
     real(default) :: norm
     class(state_matrix_t), intent(in) :: state
     norm = state%norm
   end function state_matrix_get_norm
 
 @ %def state_matrix_get_norm
 @
 \subsubsection{Retrieving contents}
 Return the quantum number array, using an index.  We have to scan the
 state matrix since there is no shortcut.
 <<State matrices: state matrix: TBP>>=
   procedure :: get_quantum_number => &
      state_matrix_get_quantum_number
 <<State matrices: procedures>>=
   function state_matrix_get_quantum_number (state, i, by_me_index) result (qn)
     class(state_matrix_t), intent(in), target :: state
     integer, intent(in) :: i
     logical, intent(in), optional :: by_me_index
     logical :: opt_by_me_index
     type(quantum_numbers_t), dimension(state%depth) :: qn
     type(state_iterator_t) :: it
     integer :: k
     opt_by_me_index = .false.
     if (present (by_me_index)) opt_by_me_index = by_me_index
     k = 0
     call it%init (state)
     do while (it%is_valid ())
        if (opt_by_me_index) then
           k = it%get_me_index ()
        else
           k = k + 1
        end if
        if (k == i) then
           qn = it%get_quantum_numbers ()
           exit
        end if
        call it%advance ()
     end do
   end function state_matrix_get_quantum_number
 
 @ %def state_matrix_get_quantum_number
 <<State matrices: state matrix: TBP>>=
   generic :: get_quantum_numbers => get_quantum_numbers_all, get_quantum_numbers_mask
   procedure :: get_quantum_numbers_all => state_matrix_get_quantum_numbers_all
   procedure :: get_quantum_numbers_mask => state_matrix_get_quantum_numbers_mask
 <<State matrices: procedures>>=
   subroutine state_matrix_get_quantum_numbers_all (state, qn)
     class(state_matrix_t), intent(in), target :: state
     type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn
     integer :: i
     allocate (qn (state%get_n_matrix_elements (), &
        state%get_depth()))
     do i = 1, state%get_n_matrix_elements ()
        qn (i, :) = state%get_quantum_number (i)
     end do
   end subroutine state_matrix_get_quantum_numbers_all
 
 @ %def state_matrix_get_quantum_numbers_all
 @
 <<State matrices: procedures>>=
   subroutine state_matrix_get_quantum_numbers_mask (state, qn_mask, qn)
     class(state_matrix_t), intent(in), target :: state
     type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
     type(quantum_numbers_t), intent(out), dimension(:,:), allocatable :: qn
     type(quantum_numbers_t), dimension(:), allocatable :: qn_tmp
     type(state_matrix_t) :: state_tmp
     type(state_iterator_t) :: it
     integer :: i, n
     n = state%get_n_matrix_elements (qn_mask)
     allocate (qn (n, state%get_depth ()))
     allocate (qn_tmp (state%get_depth ()))
     call it%init (state)
     call state_tmp%init ()
     do while (it%is_valid ())
        qn_tmp = it%get_quantum_numbers ()
        call qn_tmp%undefine (qn_mask)
        call state_tmp%add_state (qn_tmp)
        call it%advance ()
     end do
     do i = 1, n
        qn (i, :) = state_tmp%get_quantum_number (i)
     end do
     call state_tmp%final ()
   end subroutine state_matrix_get_quantum_numbers_mask
 
 @ %def state_matrix_get_quantum_numbers_mask
 @
 <<State matrices: state matrix: TBP>>=
   procedure :: get_flavors => state_matrix_get_flavors
 <<State matrices: procedures>>=
   subroutine state_matrix_get_flavors (state, only_elementary, qn_mask, flv)
     class(state_matrix_t), intent(in), target :: state
     logical, intent(in) :: only_elementary
     type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask
     integer, intent(out), dimension(:,:), allocatable :: flv
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     integer :: i_flv, n_partons
     type(flavor_t), dimension(:), allocatable :: flv_flv
     if (present (qn_mask)) then
        call state%get_quantum_numbers (qn_mask, qn)
     else
        call state%get_quantum_numbers (qn)
     end if
     allocate (flv_flv (size (qn, dim=2)))
     if (only_elementary) then
        flv_flv = qn(1, :)%get_flavor ()
        n_partons = count (is_elementary (flv_flv%get_pdg ()))
     end if
     allocate (flv (n_partons, size (qn, dim=1)))
     associate (n_flv => size (qn, dim=1))
       do i_flv = 1, size (qn, dim=1)
          flv_flv = qn(i_flv, :)%get_flavor ()
          flv(:, i_flv) = pack (flv_flv%get_pdg (), is_elementary(flv_flv%get_pdg()))
       end do
     end associate
   contains
     elemental function is_elementary (pdg)
       logical :: is_elementary
       integer, intent(in) :: pdg
       is_elementary = abs(pdg) /= 2212 .and. abs(pdg) /= 92 .and. abs(pdg) /= 93
     end function is_elementary
   end subroutine state_matrix_get_flavors
 
 @ %def state_matrix_get_flavors
 @ Return a single matrix element using its index.  Works only if the
 shortcut array is allocated.
 <<State matrices: state matrix: TBP>>=
   generic :: get_matrix_element => get_matrix_element_single
   generic :: get_matrix_element => get_matrix_element_array
   procedure :: get_matrix_element_single => &
     state_matrix_get_matrix_element_single
   procedure :: get_matrix_element_array => &
     state_matrix_get_matrix_element_array
 <<State matrices: procedures>>=
   elemental function state_matrix_get_matrix_element_single (state, i) result (me)
     complex(default) :: me
     class(state_matrix_t), intent(in) :: state
     integer, intent(in) :: i
     if (allocated (state%me)) then
        me = state%me(i)
     else
        me = 0
     end if
   end function state_matrix_get_matrix_element_single
 
 @ %def state_matrix_get_matrix_element_single
 @
 <<State matrices: procedures>>=
   function state_matrix_get_matrix_element_array (state) result (me)
      complex(default), dimension(:), allocatable :: me
      class(state_matrix_t), intent(in) :: state
      if (allocated (state%me)) then
         allocate (me (size (state%me)))
         me = state%me
      else
         me = 0
      end if
   end function state_matrix_get_matrix_element_array
 
 @ %def state_matrix_get_matrix_element_array
 @ Return the color index with maximum absolute value that is present within
 the state matrix.
 <<State matrices: state matrix: TBP>>=
   procedure :: get_max_color_value => state_matrix_get_max_color_value
 <<State matrices: procedures>>=
   function state_matrix_get_max_color_value (state) result (cmax)
     integer :: cmax
     class(state_matrix_t), intent(in) :: state
     if (associated (state%root)) then
        cmax = node_get_max_color_value (state%root)
     else
        cmax = 0
     end if
   contains
     recursive function node_get_max_color_value (node) result (cmax)
       integer :: cmax
       type(node_t), intent(in), target :: node
       type(node_t), pointer :: current
       cmax = quantum_numbers_get_max_color_value (node%qn)
       current => node%child_first
       do while (associated (current))
          cmax = max (cmax, node_get_max_color_value (current))
          current => current%next
       end do
     end function node_get_max_color_value
   end function state_matrix_get_max_color_value
 
 @ %def state_matrix_get_max_color_value
 @
 \subsubsection{Building the quantum state}
 The procedure generates a branch associated to the input array of
 quantum numbers.  If the branch exists already, it is used.
 
 Optionally, we set the matrix-element index, a value (which may be
 added to the previous one), and increment one of the possible
 counters.  We may also return the matrix element index of the current
 node.
 <<State matrices: state matrix: TBP>>=
   procedure :: add_state => state_matrix_add_state
 <<State matrices: procedures>>=
   subroutine state_matrix_add_state (state, qn, index, value, &
          sum_values, counter_index, ignore_sub_for_qn, me_index)
     class(state_matrix_t), intent(inout) :: state
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     integer, intent(in), optional :: index
     complex(default), intent(in), optional :: value
     logical, intent(in), optional :: sum_values
     integer, intent(in), optional :: counter_index
     logical, intent(in), optional :: ignore_sub_for_qn
     integer, intent(out), optional :: me_index
     logical :: set_index, get_index, add
     set_index = present (index)
     get_index = present (me_index)
     add = .false.;  if (present (sum_values))  add = sum_values
     if (state%depth == 0) then
        state%depth = size (qn)
     else if (state%depth /= size (qn)) then
        call state%write ()
        call msg_bug ("State matrix: depth mismatch")
     end if
     if (size (qn) > 0)  call node_make_branch (state%root, qn)
   contains
      recursive subroutine node_make_branch (parent, qn)
        type(node_t), pointer :: parent
        type(quantum_numbers_t), dimension(:), intent(in) :: qn
        type(node_t), pointer :: child
        logical :: match
        match = .false.
        child => parent%child_first
        SCAN_CHILDREN: do while (associated (child))
           if (present (ignore_sub_for_qn)) then
              if (ignore_sub_for_qn) then
                 match = quantum_numbers_eq_wo_sub (child%qn, qn(1))
              else
                 match = child%qn == qn(1)
              end if
           else
              match = child%qn == qn(1)
           end if
           if (match)  exit SCAN_CHILDREN
           child => child%next
        end do SCAN_CHILDREN
        if (.not. match) then
           call node_append_child (parent, child)
           child%qn = qn(1)
        end if
        select case (size (qn))
        case (1)
           if (.not. match) then
              state%n_matrix_elements = state%n_matrix_elements + 1
              child%me_index = state%n_matrix_elements
           end if
           if (set_index) then
              child%me_index = index
           end if
           if (get_index) then
              me_index = child%me_index
           end if
           if (present (counter_index)) then
              if (.not. allocated (child%me_count)) then
                 allocate (child%me_count (state%n_counters))
                 child%me_count = 0
              end if
              child%me_count(counter_index) = child%me_count(counter_index) + 1
           end if
           if (present (value)) then
              if (add) then
                 child%me = child%me + value
              else
                 child%me = value
              end if
           end if
        case (2:)
           call node_make_branch (child, qn(2:))
        end select
      end subroutine node_make_branch
    end subroutine state_matrix_add_state
 
 @ %def state_matrix_add_state
 @ Remove irrelevant flavor/color/helicity labels and the corresponding
 branchings.  The masks indicate which particles are affected; the
 masks length should coincide with the depth of the trie (without the
 root node).  Recursively scan the whole tree, starting from the leaf
 nodes and working up to the root node.  If a mask entry is set for the
 current tree level, scan the children there.  For each child within
 that level make a new empty branch where the masked quantum number is
 undefined.  Then recursively combine all following children with
 matching quantum number into this new node and move on.
 <<State matrices: state matrix: TBP>>=
   procedure :: collapse => state_matrix_collapse
 <<State matrices: procedures>>=
   subroutine state_matrix_collapse (state, mask)
     class(state_matrix_t), intent(inout) :: state
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
     type(state_matrix_t) :: red_state
     if (state%is_defined ()) then
        call state%reduce (mask, red_state)
        call state%final ()
        state = red_state
     end if
    end subroutine state_matrix_collapse
 
 @ %def state_matrix_collapse
 @ Transform the given state matrix into a reduced state matrix where
 some quantum numbers are removed, as indicated by the mask.  The
 procedure creates a new state matrix, so the old one can be deleted
 after this if it is no longer used.
 
 It is said that the matrix element ordering is lost afterwards. We allow to keep
 the original matrix element index in the new state matrix. If the matrix
 element indices are kept, we do not freeze the state matrix. After reordering
 the matrix element indices by [[state_matrix_reorder_me]], the state matrix can
 be frozen.
 <<State matrices: state matrix: TBP>>=
   procedure :: reduce => state_matrix_reduce
 <<State matrices: procedures>>=
   subroutine state_matrix_reduce (state, mask, red_state, keep_me_index)
     class(state_matrix_t), intent(in), target :: state
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
     type(state_matrix_t), intent(out) :: red_state
     logical, optional, intent(in)  :: keep_me_index
     logical :: opt_keep_me_index
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(size(mask)) :: qn
     opt_keep_me_index = .false.
     if (present (keep_me_index)) opt_keep_me_index = keep_me_index
     call red_state%init ()
     call it%init (state)
     do while (it%is_valid ())
        qn = it%get_quantum_numbers ()
        call qn%undefine (mask)
        if (opt_keep_me_index) then
           call red_state%add_state (qn, index = it%get_me_index ())
        else
           call red_state%add_state (qn)
        end if
        call it%advance ()
     end do
     if (.not. opt_keep_me_index) then
        call red_state%freeze ()
     end if
   end subroutine state_matrix_reduce
 
 @ %def state_matrix_reduce
 @ Reorder the matrix elements -- not the tree itself. The procedure is necessary
 in case the matrix element indices were kept when reducing over quantum numbers
 and one wants to reintroduce the previous order of the matrix elements.
 <<State matrices: state matrix: TBP>>=
   procedure :: reorder_me => state_matrix_reorder_me
 <<State matrices: procedures>>=
   subroutine state_matrix_reorder_me (state, ordered_state)
     class(state_matrix_t), intent(in), target :: state
     type(state_matrix_t), intent(out) :: ordered_state
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(state%depth) :: qn
     integer,  dimension(:), allocatable :: me_index
     integer :: i
     call ordered_state%init ()
     call get_me_index_sorted (state, me_index)
     i = 1; call it%init (state)
     do while (it%is_valid ())
        qn = it%get_quantum_numbers ()
        call ordered_state%add_state (qn, index = me_index(i))
        i = i + 1; call it%advance ()
     end do
     call ordered_state%freeze ()
   contains
     subroutine get_me_index_sorted (state, me_index)
       class(state_matrix_t), intent(in), target :: state
       integer, dimension(:), allocatable, intent(out) :: me_index
       type(state_iterator_t) :: it
       integer :: i, j
       integer, dimension(:), allocatable :: me_index_unsorted, me_index_sorted
       associate (n_matrix_elements => state%get_n_matrix_elements ())
         allocate (me_index(n_matrix_elements), source = 0)
         allocate (me_index_sorted(n_matrix_elements), source = 0)
         allocate (me_index_unsorted(n_matrix_elements), source = 0)
         i = 1; call it%init (state)
         do while (it%is_valid ())
            me_index_unsorted(i) = it%get_me_index ()
            i = i + 1
            call it%advance ()
         end do
         me_index_sorted = sort (me_index_unsorted)
         ! We do not care about efficiency at this point.
         UNSORTED: do i = 1, n_matrix_elements
            SORTED: do j = 1, n_matrix_elements
               if (me_index_unsorted(i) == me_index_sorted(j)) then
                  me_index(i) = j
                  cycle UNSORTED
               end if
            end do SORTED
         end do UNSORTED
       end associate
     end subroutine get_me_index_sorted
   end subroutine state_matrix_reorder_me
 
 @ %def state_matrix_order_by_flavors
+@ Sets all matrix elements whose flavor structure is a duplicate
+of another flavor structure to zero. We need this for the real finite to
+ignore duplicate flavor structures while keeping the indices identical to the
+singular real component.
+When comparing the flavor structures, we take into account permutations of final-
+state particles. To do this properly, we keep only the non-hard flavors and the
+initial-state flavors, i.e. the first two hard flavors fixed.
+<<State matrices: state matrix: TBP>>=
+  procedure :: set_duplicate_flv_zero => state_matrix_set_duplicate_flv_zero
+<<State matrices: procedures>>=
+  subroutine state_matrix_set_duplicate_flv_zero (state)
+    class(state_matrix_t), intent(inout), target :: state
+    type(quantum_numbers_t), dimension(state%depth) :: qn
+    type(flavor_t) :: flv
+    class(state_flv_content_t), allocatable :: state_flv
+    logical, dimension(:), allocatable :: hard_mask, sort_mask, duplicate_mask
+    integer :: i, j, n_in, n_flvs
+    n_flvs = state%get_depth ()
+    n_in = 2
+    !!! TODO (PS-28-07-21) n_in should not be hard coded to work for decays
+    !!! This assumes that the positions of the non-hard flavors are the same for all flavor structures.
+    qn = state%get_quantum_number(1)
+    allocate (hard_mask(n_flvs))
+    do i = 1, n_flvs
+       flv = qn(i)%get_flavor()
+       hard_mask(i) = flv%is_hard_process ()
+    end do
+    allocate (sort_mask(n_flvs))
+    sort_mask = hard_mask
+    j = 0
+    do i = 1, n_flvs
+       if (j == n_in) exit
+       if (sort_mask(i)) then
+          sort_mask(i) = .false.
+          j = j + 1
+       end if
+    end do
+    allocate (state_flv)
+    call state_flv%fill (state, sort_mask)
+    call state_flv%find_duplicates (duplicate_mask)
+    do i = 1, state%get_n_matrix_elements ()
+       if (duplicate_mask(i)) then
+          call state%set_matrix_element_single(i, cmplx(zero, zero, default))
+       end if
+    end do
+  end subroutine state_matrix_set_duplicate_flv_zero
+
+@ %def state_matrix_set_duplicate_flv_zero
 @ This subroutine sets up the matrix-element array.  The leaf nodes
 aquire the index values that point to the appropriate matrix-element
 entry.
 
 We recursively scan the trie.  Once we arrive at a leaf node, the
 index is increased and associated to that node.  Finally, we allocate
 the matrix-element array with the appropriate size.
 
 If matrix element values are temporarily stored within the leaf nodes,
 we scan the state again and transfer them to the matrix-element array.
 <<State matrices: state matrix: TBP>>=
   procedure :: freeze => state_matrix_freeze
 <<State matrices: procedures>>=
   subroutine state_matrix_freeze (state)
     class(state_matrix_t), intent(inout), target :: state
     type(state_iterator_t) :: it
     if (associated (state%root)) then
        if (allocated (state%me))  deallocate (state%me)
        allocate (state%me (state%n_matrix_elements))
        state%me = 0
        call state%set_n_sub ()
     end if
     if (state%leaf_nodes_store_values) then
        call it%init (state)
        do while (it%is_valid ())
           state%me(it%get_me_index ()) = it%get_matrix_element ()
           call it%advance ()
        end do
        state%leaf_nodes_store_values = .false.
     end if
   end subroutine state_matrix_freeze
 
 @ %def state_matrix_freeze
 @
 \subsubsection{Direct access to the value array}
 Several methods for setting a value directly are summarized in this
 generic:
 <<State matrices: state matrix: TBP>>=
   generic :: set_matrix_element => set_matrix_element_qn
   generic :: set_matrix_element => set_matrix_element_all
   generic :: set_matrix_element => set_matrix_element_array
   generic :: set_matrix_element => set_matrix_element_single
   generic :: set_matrix_element => set_matrix_element_clone
   procedure :: set_matrix_element_qn => state_matrix_set_matrix_element_qn
   procedure :: set_matrix_element_all => state_matrix_set_matrix_element_all
   procedure :: set_matrix_element_array => &
        state_matrix_set_matrix_element_array
   procedure :: set_matrix_element_single => &
        state_matrix_set_matrix_element_single
   procedure :: set_matrix_element_clone => &
      state_matrix_set_matrix_element_clone
 @ %def state_matrix_set_matrix_element
 @ Set a value that corresponds to a quantum number array:
 <<State matrices: procedures>>=
   subroutine state_matrix_set_matrix_element_qn (state, qn, value)
     class(state_matrix_t), intent(inout), target :: state
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     complex(default), intent(in) :: value
     type(state_iterator_t) :: it
     if (.not. allocated (state%me)) then
        allocate (state%me (size(qn)))
     end if
     call it%init (state)
     call it%go_to_qn (qn)
     call it%set_matrix_element (value)
   end subroutine state_matrix_set_matrix_element_qn
 
 @ %def state_matrix_set_matrix_element_qn
 @ Set all matrix elements to a single value
 <<State matrices: procedures>>=
   subroutine state_matrix_set_matrix_element_all (state, value)
     class(state_matrix_t), intent(inout) :: state
     complex(default), intent(in) :: value
     if (.not. allocated (state%me)) then
        allocate (state%me (state%n_matrix_elements))
     end if
     state%me = value
   end subroutine state_matrix_set_matrix_element_all
 
 @ %def state_matrix_set_matrix_element_all
 @ Set the matrix-element array directly.
 <<State matrices: procedures>>=
   subroutine state_matrix_set_matrix_element_array (state, value, range)
     class(state_matrix_t), intent(inout) :: state
     complex(default), intent(in), dimension(:) :: value
     integer, intent(in), dimension(:), optional :: range
     if (present (range)) then
        state%me(range) = value
     else
        if (.not. allocated (state%me)) &
             allocate (state%me (size (value)))
        state%me(:) = value
     end if
   end subroutine state_matrix_set_matrix_element_array
 
 @ %def state_matrix_set_matrix_element_array
 @ Set a matrix element at position [[i]] to [[value]].
 <<State matrices: procedures>>=
   pure subroutine state_matrix_set_matrix_element_single (state, i, value)
     class(state_matrix_t), intent(inout) :: state
     integer, intent(in) :: i
     complex(default), intent(in) :: value
     if (.not. allocated (state%me)) then
        allocate (state%me (state%n_matrix_elements))
     end if
     state%me(i) = value
   end subroutine state_matrix_set_matrix_element_single
 
 @ %def state_matrix_set_matrix_element_single
 @ Clone the matrix elements from another (matching) state matrix.
 <<State matrices: procedures>>=
   subroutine state_matrix_set_matrix_element_clone (state, state1)
     class(state_matrix_t), intent(inout) :: state
     type(state_matrix_t), intent(in) :: state1
     if (.not. allocated (state1%me)) return
     if (.not. allocated (state%me)) allocate (state%me (size (state1%me)))
     state%me = state1%me
   end subroutine state_matrix_set_matrix_element_clone
 
 @ %def state_matrix_set_matrix_element_clone
 @ Add a value to a matrix element
 <<State matrices: state matrix: TBP>>=
   procedure :: add_to_matrix_element => state_matrix_add_to_matrix_element
 <<State matrices: procedures>>=
   subroutine state_matrix_add_to_matrix_element (state, qn, value, match_only_flavor)
     class(state_matrix_t), intent(inout), target :: state
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     complex(default), intent(in) :: value
     logical, intent(in), optional :: match_only_flavor
     type(state_iterator_t) :: it
     call it%init (state)
     call it%go_to_qn (qn, match_only_flavor)
     if (it%is_valid ()) then
        call it%add_to_matrix_element (value)
     else
        call msg_fatal ("Cannot add to matrix element - it%node not allocated")
     end if
   end subroutine state_matrix_add_to_matrix_element
 
 @ %def state_matrix_add_to_matrix_element
 @
 \subsection{State iterators}
 Accessing the quantum state from outside is best done using a
 specialized iterator, i.e., a pointer to a particular branch of the
 quantum state trie.  Technically, the iterator contains a pointer to a
 leaf node, but via parent pointers it allows to access the whole
 branch where the leaf is attached.  For quick access, we also keep the
 branch depth (which is assumed to be universal for a quantum state).
 <<State matrices: public>>=
   public :: state_iterator_t
 <<State matrices: types>>=
   type :: state_iterator_t
      private
      integer :: depth = 0
      type(state_matrix_t), pointer :: state => null ()
      type(node_t), pointer :: node => null ()
    contains
    <<State matrices: state iterator: TBP>>
   end type state_iterator_t
 
 @ %def state_iterator
 @ The initializer: Point at the first branch.  Note that this cannot
 be pure, thus not be elemental, because the iterator can be used to
 manipulate data in the state matrix.
 <<State matrices: state iterator: TBP>>=
   procedure :: init => state_iterator_init
 <<State matrices: procedures>>=
   subroutine state_iterator_init (it, state)
     class(state_iterator_t), intent(out) :: it
     type(state_matrix_t), intent(in), target :: state
     it%state => state
     it%depth = state%depth
     if (state%is_defined ()) then
        it%node => state%root
        do while (associated (it%node%child_first))
           it%node => it%node%child_first
        end do
     else
        it%node => null ()
     end if
   end subroutine state_iterator_init
 
 @ %def state_iterator_init
 @ Go forward.  Recursively programmed: if the next node does not
 exist, go back to the parent node and look at its successor (if
 present), etc.
 
 There is a possible pitfall in the implementation: If the dummy
 pointer argument to the [[find_next]] routine is used directly, we
 still get the correct result for the iterator, but calling the
 recursion on [[node%parent]] means that we manipulate a parent pointer
 in the original state in addition to the iterator.  Making a local
 copy of the pointer avoids this.  Using pointer intent would be
 helpful, but we do not yet rely on this F2003 feature.
 <<State matrices: state iterator: TBP>>=
   procedure :: advance => state_iterator_advance
 <<State matrices: procedures>>=
   subroutine state_iterator_advance (it)
     class(state_iterator_t), intent(inout) :: it
     call find_next (it%node)
   contains
     recursive subroutine find_next (node_in)
       type(node_t), intent(in), target :: node_in
       type(node_t), pointer :: node
       node => node_in
       if (associated (node%next)) then
          node => node%next
          do while (associated (node%child_first))
             node => node%child_first
          end do
          it%node => node
       else if (associated (node%parent)) then
          call find_next (node%parent)
       else
          it%node => null ()
       end if
     end subroutine find_next
   end subroutine state_iterator_advance
 
 @ %def state_iterator_advance
 @ If all has been scanned, the iterator is at an undefined state.
 Check for this:
 <<State matrices: state iterator: TBP>>=
   procedure :: is_valid => state_iterator_is_valid
 <<State matrices: procedures>>=
   function state_iterator_is_valid (it) result (defined)
     logical :: defined
     class(state_iterator_t), intent(in) :: it
     defined = associated (it%node)
   end function state_iterator_is_valid
 
 @ %def state_iterator_is_valid
 @ Return the matrix-element index that corresponds to the current node
 <<State matrices: state iterator: TBP>>=
   procedure :: get_me_index => state_iterator_get_me_index
 <<State matrices: procedures>>=
   function state_iterator_get_me_index (it) result (n)
     integer :: n
     class(state_iterator_t), intent(in) :: it
     n = it%node%me_index
   end function state_iterator_get_me_index
 
 @ %def state_iterator_get_me_index
 @ Return the number of times this quantum-number state has been added
 (noting that it is physically inserted only the first time).  Note
 that for each state, there is an array of counters.
 <<State matrices: state iterator: TBP>>=
   procedure :: get_me_count => state_iterator_get_me_count
 <<State matrices: procedures>>=
   function state_iterator_get_me_count (it) result (n)
     integer, dimension(:), allocatable :: n
     class(state_iterator_t), intent(in) :: it
     if (allocated (it%node%me_count)) then
        allocate (n (size (it%node%me_count)))
        n = it%node%me_count
     else
        allocate (n (0))
     end if
   end function state_iterator_get_me_count
 
 @ %def state_iterator_get_me_count
 @
 <<State matrices: state iterator: TBP>>=
   procedure :: get_depth => state_iterator_get_depth
 <<State matrices: procedures>>=
   pure function state_iterator_get_depth (state_iterator) result (depth)
     integer :: depth
     class(state_iterator_t), intent(in) :: state_iterator
     depth = state_iterator%depth
   end function state_iterator_get_depth
 
 @ %def state_iterator_get_depth
 @ Proceed to the state associated with the quantum numbers [[qn]].
 <<State matrices: state iterator: TBP>>=
   procedure :: go_to_qn => state_iterator_go_to_qn
 <<State matrices: procedures>>=
   subroutine state_iterator_go_to_qn (it, qn, match_only_flavor)
     class(state_iterator_t), intent(inout) :: it
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     logical, intent(in), optional :: match_only_flavor
     type(quantum_numbers_t), dimension(:), allocatable :: qn_hard, qn_tmp
     logical :: match_flv
     match_flv = .false.; if (present (match_only_flavor)) match_flv = .true.
     do while (it%is_valid ())
        if (match_flv) then
           qn_tmp = it%get_quantum_numbers ()
           qn_hard = pack (qn_tmp, qn_tmp%are_hard_process ())
           if (all (qn .fmatch. qn_hard)) then
              return
           else
              call it%advance ()
           end if
        else
           if (all (qn == it%get_quantum_numbers ())) then
              return
           else
              call it%advance ()
           end if
        end if
     end do
   end subroutine state_iterator_go_to_qn
 
 @ %def state_iterator_go_to_qn
 @ Use the iterator to retrieve quantum-number information:
 <<State matrices: state iterator: TBP>>=
   generic :: get_quantum_numbers => get_qn_multi, get_qn_slice, &
        get_qn_range, get_qn_single
   generic :: get_flavor => get_flv_multi, get_flv_slice, &
        get_flv_range, get_flv_single
   generic :: get_color => get_col_multi, get_col_slice, &
        get_col_range, get_col_single
   generic :: get_helicity => get_hel_multi, get_hel_slice, &
        get_hel_range, get_hel_single
 <<State matrices: state iterator: TBP>>=
   procedure :: get_qn_multi => state_iterator_get_qn_multi
   procedure :: get_qn_slice => state_iterator_get_qn_slice
   procedure :: get_qn_range => state_iterator_get_qn_range
   procedure :: get_qn_single => state_iterator_get_qn_single
   procedure :: get_flv_multi => state_iterator_get_flv_multi
   procedure :: get_flv_slice => state_iterator_get_flv_slice
   procedure :: get_flv_range => state_iterator_get_flv_range
   procedure :: get_flv_single => state_iterator_get_flv_single
   procedure :: get_col_multi => state_iterator_get_col_multi
   procedure :: get_col_slice => state_iterator_get_col_slice
   procedure :: get_col_range => state_iterator_get_col_range
   procedure :: get_col_single => state_iterator_get_col_single
   procedure :: get_hel_multi => state_iterator_get_hel_multi
   procedure :: get_hel_slice => state_iterator_get_hel_slice
   procedure :: get_hel_range => state_iterator_get_hel_range
   procedure :: get_hel_single => state_iterator_get_hel_single
 @ These versions return the whole quantum number array
 <<State matrices: procedures>>=
   function state_iterator_get_qn_multi (it) result (qn)
     class(state_iterator_t), intent(in) :: it
     type(quantum_numbers_t), dimension(it%depth) :: qn
     type(node_t), pointer :: node
     integer :: i
     node => it%node
     do i = it%depth, 1, -1
        qn(i) = node%qn
        node => node%parent
     end do
   end function state_iterator_get_qn_multi
 
   function state_iterator_get_flv_multi (it) result (flv)
     class(state_iterator_t), intent(in) :: it
     type(flavor_t), dimension(it%depth) :: flv
     flv = quantum_numbers_get_flavor &
          (it%get_quantum_numbers ())
   end function state_iterator_get_flv_multi
 
   function state_iterator_get_col_multi (it) result (col)
     class(state_iterator_t), intent(in) :: it
     type(color_t), dimension(it%depth) :: col
     col = quantum_numbers_get_color &
          (it%get_quantum_numbers ())
   end function state_iterator_get_col_multi
 
   function state_iterator_get_hel_multi (it) result (hel)
     class(state_iterator_t), intent(in) :: it
     type(helicity_t), dimension(it%depth) :: hel
     hel = quantum_numbers_get_helicity &
          (it%get_quantum_numbers ())
   end function state_iterator_get_hel_multi
 
 @ An array slice (derived from the above).
 <<State matrices: procedures>>=
   function state_iterator_get_qn_slice (it, index) result (qn)
     class(state_iterator_t), intent(in) :: it
     integer, dimension(:), intent(in) :: index
     type(quantum_numbers_t), dimension(size(index)) :: qn
     type(quantum_numbers_t), dimension(it%depth) :: qn_tmp
     qn_tmp = state_iterator_get_qn_multi (it)
     qn = qn_tmp(index)
   end function state_iterator_get_qn_slice
 
   function state_iterator_get_flv_slice (it, index) result (flv)
     class(state_iterator_t), intent(in) :: it
     integer, dimension(:), intent(in) :: index
     type(flavor_t), dimension(size(index)) :: flv
     flv = quantum_numbers_get_flavor &
          (it%get_quantum_numbers (index))
   end function state_iterator_get_flv_slice
 
   function state_iterator_get_col_slice (it, index) result (col)
     class(state_iterator_t), intent(in) :: it
     integer, dimension(:), intent(in) :: index
     type(color_t), dimension(size(index)) :: col
     col = quantum_numbers_get_color &
          (it%get_quantum_numbers (index))
   end function state_iterator_get_col_slice
 
   function state_iterator_get_hel_slice (it, index) result (hel)
     class(state_iterator_t), intent(in) :: it
     integer, dimension(:), intent(in) :: index
     type(helicity_t), dimension(size(index)) :: hel
     hel = quantum_numbers_get_helicity &
          (it%get_quantum_numbers (index))
   end function state_iterator_get_hel_slice
 
 @ An array range (implemented directly).
 <<State matrices: procedures>>=
   function state_iterator_get_qn_range (it, k1, k2) result (qn)
     class(state_iterator_t), intent(in) :: it
     integer, intent(in) :: k1, k2
     type(quantum_numbers_t), dimension(k2-k1+1) :: qn
     type(node_t), pointer :: node
     integer :: i
     node => it%node
     SCAN: do i = it%depth, 1, -1
        if (k1 <= i .and. i <= k2) then
           qn(i-k1+1) = node%qn
        else
           node => node%parent
        end if
     end do SCAN
   end function state_iterator_get_qn_range
 
   function state_iterator_get_flv_range (it, k1, k2) result (flv)
     class(state_iterator_t), intent(in) :: it
     integer, intent(in) :: k1, k2
     type(flavor_t), dimension(k2-k1+1) :: flv
     flv = quantum_numbers_get_flavor &
          (it%get_quantum_numbers (k1, k2))
   end function state_iterator_get_flv_range
 
   function state_iterator_get_col_range (it, k1, k2) result (col)
     class(state_iterator_t), intent(in) :: it
     integer, intent(in) :: k1, k2
     type(color_t), dimension(k2-k1+1) :: col
     col = quantum_numbers_get_color &
          (it%get_quantum_numbers (k1, k2))
   end function state_iterator_get_col_range
 
   function state_iterator_get_hel_range (it, k1, k2) result (hel)
     class(state_iterator_t), intent(in) :: it
     integer, intent(in) :: k1, k2
     type(helicity_t), dimension(k2-k1+1) :: hel
     hel = quantum_numbers_get_helicity &
          (it%get_quantum_numbers (k1, k2))
   end function state_iterator_get_hel_range
 
 @ Just a specific single element
 <<State matrices: procedures>>=
   function state_iterator_get_qn_single (it, k) result (qn)
     class(state_iterator_t), intent(in) :: it
     integer, intent(in) :: k
     type(quantum_numbers_t) :: qn
     type(node_t), pointer :: node
     integer :: i
     node => it%node
     SCAN: do i = it%depth, 1, -1
        if (i == k) then
           qn = node%qn
           exit SCAN
        else
           node => node%parent
        end if
     end do SCAN
   end function state_iterator_get_qn_single
 
   function state_iterator_get_flv_single (it, k) result (flv)
     class(state_iterator_t), intent(in) :: it
     integer, intent(in) :: k
     type(flavor_t) :: flv
     flv = quantum_numbers_get_flavor &
          (it%get_quantum_numbers (k))
   end function state_iterator_get_flv_single
 
   function state_iterator_get_col_single (it, k) result (col)
     class(state_iterator_t), intent(in) :: it
     integer, intent(in) :: k
     type(color_t) :: col
     col = quantum_numbers_get_color &
          (it%get_quantum_numbers (k))
   end function state_iterator_get_col_single
 
   function state_iterator_get_hel_single (it, k) result (hel)
     class(state_iterator_t), intent(in) :: it
     integer, intent(in) :: k
     type(helicity_t) :: hel
     hel = quantum_numbers_get_helicity &
          (it%get_quantum_numbers (k))
   end function state_iterator_get_hel_single
 
 @ %def state_iterator_get_quantum_numbers
 @ %def state_iterator_get_flavor
 @ %def state_iterator_get_color
 @ %def state_iterator_get_helicity
 @ Assign a model pointer to the current flavor entries.
 <<State matrices: state iterator: TBP>>=
   procedure :: set_model => state_iterator_set_model
 <<State matrices: procedures>>=
   subroutine state_iterator_set_model (it, model)
     class(state_iterator_t), intent(inout) :: it
     class(model_data_t), intent(in), target :: model
     type(node_t), pointer :: node
     integer :: i
     node => it%node
     do i = it%depth, 1, -1
        call node%qn%set_model (model)
        node => node%parent
     end do
   end subroutine state_iterator_set_model
 
 @ %def state_iterator_set_model
 @ Modify the hard-interaction tag of the current flavor entries at a specific
 position, in-place.
 <<State matrices: state iterator: TBP>>=
   procedure :: retag_hard_process => state_iterator_retag_hard_process
 <<State matrices: procedures>>=
   subroutine state_iterator_retag_hard_process (it, i, hard)
     class(state_iterator_t), intent(inout) :: it
     integer, intent(in) :: i
     logical, intent(in) :: hard
     type(node_t), pointer :: node
     integer :: j
     node => it%node
     do j = 1, it%depth-i
        node => node%parent
     end do
     call node%qn%tag_hard_process (hard)
   end subroutine state_iterator_retag_hard_process
 
 @ %def state_iterator_retag_hard_process
 @ Retrieve the matrix element value associated with the current node.
 <<State matrices: state iterator: TBP>>=
   procedure :: get_matrix_element => state_iterator_get_matrix_element
 <<State matrices: procedures>>=
   function state_iterator_get_matrix_element (it) result (me)
     complex(default) :: me
     class(state_iterator_t), intent(in) :: it
     if (it%state%leaf_nodes_store_values) then
        me = it%node%me
     else if (it%node%me_index /= 0) then
        me = it%state%me(it%node%me_index)
     else
        me = 0
     end if
   end function state_iterator_get_matrix_element
 
 @ %def state_iterator_get_matrix_element
 @ Set the matrix element value using the state iterator.
 <<State matrices: state iterator: TBP>>=
   procedure :: set_matrix_element => state_iterator_set_matrix_element
 <<State matrices: procedures>>=
   subroutine state_iterator_set_matrix_element (it, value)
     class(state_iterator_t), intent(inout) :: it
     complex(default), intent(in) :: value
     if (it%node%me_index /= 0) it%state%me(it%node%me_index) = value
   end subroutine state_iterator_set_matrix_element
 
 @ %def state_iterator_set_matrix_element
 @
 <<State matrices: state iterator: TBP>>=
   procedure :: add_to_matrix_element => state_iterator_add_to_matrix_element
 <<State matrices: procedures>>=
   subroutine state_iterator_add_to_matrix_element (it, value)
     class(state_iterator_t), intent(inout) :: it
     complex(default), intent(in) :: value
     if (it%node%me_index /= 0) &
          it%state%me(it%node%me_index) = it%state%me(it%node%me_index) + value
   end subroutine state_iterator_add_to_matrix_element
 
 @ %def state_iterator_add_to_matrix_element
 @
 \subsection{Operations on quantum states}
 Return a deep copy of a state matrix.
 <<State matrices: public>>=
   public :: assignment(=)
 <<State matrices: interfaces>>=
   interface assignment(=)
      module procedure state_matrix_assign
   end interface
 
 <<State matrices: procedures>>=
   subroutine state_matrix_assign (state_out, state_in)
     type(state_matrix_t), intent(out) :: state_out
     type(state_matrix_t), intent(in), target :: state_in
     type(state_iterator_t) :: it
     if (.not. state_in%is_defined ())  return
     call state_out%init ()
     call it%init (state_in)
     do while (it%is_valid ())
        call state_out%add_state (it%get_quantum_numbers (), &
             it%get_me_index ())
        call it%advance ()
     end do
     if (allocated (state_in%me)) then
        allocate (state_out%me (size (state_in%me)))
        state_out%me = state_in%me
     end if
     state_out%n_sub = state_in%n_sub
   end subroutine state_matrix_assign
 
 @ %def state_matrix_assign
 @ Determine the indices of all diagonal matrix elements.
 <<State matrices: state matrix: TBP>>=
   procedure :: get_diagonal_entries => state_matrix_get_diagonal_entries
 <<State matrices: procedures>>=
   subroutine state_matrix_get_diagonal_entries (state, i)
     class(state_matrix_t), intent(in) :: state
     integer, dimension(:), allocatable, intent(out) :: i
     integer, dimension(state%n_matrix_elements) :: tmp
     integer :: n
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     n = 0
     call it%init (state)
     allocate (qn (it%depth))
     do while (it%is_valid ())
        qn = it%get_quantum_numbers ()
        if (all (qn%are_diagonal ())) then
           n = n + 1
           tmp(n) = it%get_me_index ()
        end if
        call it%advance ()
     end do
     allocate (i(n))
     if (n > 0) i = tmp(:n)
   end subroutine state_matrix_get_diagonal_entries
 
 @ %def state_matrices_get_diagonal_entries
 @ Normalize all matrix elements, i.e., multiply by a common factor.
 Assuming that the factor is nonzero, of course.
 <<State matrices: state matrix: TBP>>=
   procedure :: renormalize => state_matrix_renormalize
 <<State matrices: procedures>>=
   subroutine state_matrix_renormalize (state, factor)
     class(state_matrix_t), intent(inout) :: state
     complex(default), intent(in) :: factor
     state%me = state%me * factor
   end subroutine state_matrix_renormalize
 
 @ %def state_matrix_renormalize
 @ Renormalize the state matrix by its trace, if nonzero.  The renormalization
 is reflected in the state-matrix norm.
 <<State matrices: state matrix: TBP>>=
   procedure :: normalize_by_trace => state_matrix_normalize_by_trace
 <<State matrices: procedures>>=
   subroutine state_matrix_normalize_by_trace (state)
     class(state_matrix_t), intent(inout) :: state
     real(default) :: trace
     trace = state%trace ()
     if (trace /= 0) then
        state%me = state%me / trace
        state%norm = state%norm * trace
     end if
   end subroutine state_matrix_normalize_by_trace
 
 @ %def state_matrix_renormalize_by_trace
 @ Analogous, but renormalize by maximal (absolute) value.
 <<State matrices: state matrix: TBP>>=
   procedure :: normalize_by_max => state_matrix_normalize_by_max
 <<State matrices: procedures>>=
   subroutine state_matrix_normalize_by_max (state)
     class(state_matrix_t), intent(inout) :: state
     real(default) :: m
     m = maxval (abs (state%me))
     if (m /= 0) then
        state%me = state%me / m
        state%norm = state%norm * m
     end if
   end subroutine state_matrix_normalize_by_max
 
 @ %def state_matrix_renormalize_by_max
 @ Explicitly set the norm of a state matrix.
 <<State matrices: state matrix: TBP>>=
   procedure :: set_norm => state_matrix_set_norm
 <<State matrices: procedures>>=
   subroutine state_matrix_set_norm (state, norm)
     class(state_matrix_t), intent(inout) :: state
     real(default), intent(in) :: norm
     state%norm = norm
   end subroutine state_matrix_set_norm
 
 @ %def state_matrix_set_norm
 @ Return the sum of all matrix element values.
 <<State matrices: state matrix: TBP>>=
   procedure :: sum => state_matrix_sum
 <<State matrices: procedures>>=
   pure function state_matrix_sum (state) result (value)
     complex(default) :: value
     class(state_matrix_t), intent(in) :: state
     value = sum (state%me)
   end function state_matrix_sum
 
 @ %def state_matrix_sum
 @ Return the trace of a state matrix, i.e., the sum over all diagonal
 values.
 
 If [[qn_in]] is provided, only branches that match this
 quantum-numbers array in flavor and helicity are considered.  (This mode is
 used for selecting a color state.)
 <<State matrices: state matrix: TBP>>=
   procedure :: trace => state_matrix_trace
 <<State matrices: procedures>>=
   function state_matrix_trace (state, qn_in) result (trace)
     complex(default) :: trace
     class(state_matrix_t), intent(in), target :: state
     type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     type(state_iterator_t) :: it
     allocate (qn (state%get_depth ()))
     trace = 0
     call it%init (state)
     do while (it%is_valid ())
        qn = it%get_quantum_numbers ()
        if (present (qn_in)) then
           if (.not. all (qn .fhmatch. qn_in)) then
              call it%advance ();  cycle
           end if
        end if
        if (all (qn%are_diagonal ())) then
           trace = trace + it%get_matrix_element ()
        end if
        call it%advance ()
     end do
   end function state_matrix_trace
 
 @ %def state_matrix_trace
 @ Append new states which are color-contracted versions of the
 existing states.  The matrix element index of each color contraction
 coincides with the index of its origin, so no new matrix elements are
 generated.  After this operation, no [[freeze]] must be performed
 anymore.
 <<State matrices: state matrix: TBP>>=
   procedure :: add_color_contractions => state_matrix_add_color_contractions
 <<State matrices: procedures>>=
   subroutine state_matrix_add_color_contractions (state)
     class(state_matrix_t), intent(inout), target :: state
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn_con
     integer, dimension(:), allocatable :: me_index
     integer :: depth, n_me, i, j
     depth = state%get_depth ()
     n_me = state%get_n_matrix_elements ()
     allocate (qn (depth, n_me))
     allocate (me_index (n_me))
     i = 0
     call it%init (state)
     do while (it%is_valid ())
        i = i + 1
        qn(:,i) = it%get_quantum_numbers ()
        me_index(i) = it%get_me_index ()
        call it%advance ()
     end do
     do i = 1, n_me
        call quantum_number_array_make_color_contractions (qn(:,i), qn_con)
        do j = 1, size (qn_con, 2)
           call state%add_state (qn_con(:,j), index = me_index(i))
        end do
     end do
   end subroutine state_matrix_add_color_contractions
 
 @ %def state_matrix_add_color_contractions
 @ This procedure merges two state matrices of equal depth.  For each
 quantum number (flavor, color, helicity), we take the entry from the
 first argument where defined, otherwise the second one.  (If both are
 defined, we get an off-diagonal matrix.) The resulting
 trie combines the information of the input tries in all possible ways.
 Note that values are ignored, all values in the result are zero.
 <<State matrices: public>>=
   public :: merge_state_matrices
 <<State matrices: procedures>>=
   subroutine merge_state_matrices (state1, state2, state3)
     type(state_matrix_t), intent(in), target :: state1, state2
     type(state_matrix_t), intent(out) :: state3
     type(state_iterator_t) :: it1, it2
     type(quantum_numbers_t), dimension(state1%depth) :: qn1, qn2
     if (state1%depth /= state2%depth) then
        call state1%write ()
        call state2%write ()
        call msg_bug ("State matrices merge impossible: incompatible depths")
     end if
     call state3%init ()
     call it1%init (state1)
     do while (it1%is_valid ())
        qn1 = it1%get_quantum_numbers ()
        call it2%init (state2)
        do while (it2%is_valid ())
           qn2 = it2%get_quantum_numbers ()
           call state3%add_state (qn1 .merge. qn2)
           call it2%advance ()
        end do
        call it1%advance ()
     end do
     call state3%freeze ()
   end subroutine merge_state_matrices
 
 @ %def merge_state_matrices
 @ Multiply matrix elements from two state matrices.  Choose the elements
 as given by the integer index arrays, multiply them and store the sum
 of products in the indicated matrix element.  The suffixes mean:
 c=conjugate first factor; f=include weighting factor.
 
 Note that the [[dot_product]] intrinsic function conjugates its first
 complex argument.  This is intended for the [[c]] suffix case, but
 must be reverted for the plain-product case.
 
 We provide analogous subroutines for just summing over state matrix
 entries.  The [[evaluate_sum]] variant includes the state-matrix norm
 in the evaluation, the [[evaluate_me_sum]] takes into account just the
 matrix elements proper.
 <<State matrices: state matrix: TBP>>=
   procedure :: evaluate_product => state_matrix_evaluate_product
   procedure :: evaluate_product_cf => state_matrix_evaluate_product_cf
   procedure :: evaluate_square_c => state_matrix_evaluate_square_c
   procedure :: evaluate_sum => state_matrix_evaluate_sum
   procedure :: evaluate_me_sum => state_matrix_evaluate_me_sum
 <<State matrices: procedures>>=
   pure subroutine state_matrix_evaluate_product &
        (state, i, state1, state2, index1, index2)
     class(state_matrix_t), intent(inout) :: state
     integer, intent(in) :: i
     type(state_matrix_t), intent(in) :: state1, state2
     integer, dimension(:), intent(in) :: index1, index2
     state%me(i) = &
          dot_product (conjg (state1%me(index1)), state2%me(index2))
     state%norm = state1%norm * state2%norm
   end subroutine state_matrix_evaluate_product
 
   pure subroutine state_matrix_evaluate_product_cf &
        (state, i, state1, state2, index1, index2, factor)
     class(state_matrix_t), intent(inout) :: state
     integer, intent(in) :: i
     type(state_matrix_t), intent(in) :: state1, state2
     integer, dimension(:), intent(in) :: index1, index2
     complex(default), dimension(:), intent(in) :: factor
     state%me(i) = &
          dot_product (state1%me(index1), factor * state2%me(index2))
     state%norm = state1%norm * state2%norm
   end subroutine state_matrix_evaluate_product_cf
 
   pure subroutine state_matrix_evaluate_square_c (state, i, state1, index1)
     class(state_matrix_t), intent(inout) :: state
     integer, intent(in) :: i
     type(state_matrix_t), intent(in) :: state1
     integer, dimension(:), intent(in) :: index1
     state%me(i) = &
          dot_product (state1%me(index1), state1%me(index1))
     state%norm = abs (state1%norm) ** 2
   end subroutine state_matrix_evaluate_square_c
 
   pure subroutine state_matrix_evaluate_sum (state, i, state1, index1)
     class(state_matrix_t), intent(inout) :: state
     integer, intent(in) :: i
     type(state_matrix_t), intent(in) :: state1
     integer, dimension(:), intent(in) :: index1
     state%me(i) = &
          sum (state1%me(index1)) * state1%norm
   end subroutine state_matrix_evaluate_sum
 
   pure subroutine state_matrix_evaluate_me_sum (state, i, state1, index1)
     class(state_matrix_t), intent(inout) :: state
     integer, intent(in) :: i
     type(state_matrix_t), intent(in) :: state1
     integer, dimension(:), intent(in) :: index1
     state%me(i) = sum (state1%me(index1))
   end subroutine state_matrix_evaluate_me_sum
 
 @ %def state_matrix_evaluate_product
 @ %def state_matrix_evaluate_product_cf
 @ %def state_matrix_evaluate_square_c
 @ %def state_matrix_evaluate_sum
 @ %def state_matrix_evaluate_me_sum
 @ Outer product (of states and matrix elements):
 <<State matrices: public>>=
   public :: outer_multiply
 <<State matrices: interfaces>>=
   interface outer_multiply
      module procedure outer_multiply_pair
      module procedure outer_multiply_array
   end interface
 
 @ %def outer_multiply
 @ This procedure constructs the outer product of two state matrices.
 <<State matrices: procedures>>=
   subroutine outer_multiply_pair (state1, state2, state3)
     type(state_matrix_t), intent(in), target :: state1, state2
     type(state_matrix_t), intent(out) :: state3
     type(state_iterator_t) :: it1, it2
     type(quantum_numbers_t), dimension(state1%depth) :: qn1
     type(quantum_numbers_t), dimension(state2%depth) :: qn2
     type(quantum_numbers_t), dimension(state1%depth+state2%depth) :: qn3
     complex(default) :: val1, val2
     call state3%init (store_values = .true.)
     call it1%init (state1)
     do while (it1%is_valid ())
        qn1 = it1%get_quantum_numbers ()
        val1 = it1%get_matrix_element ()
        call it2%init (state2)
        do while (it2%is_valid ())
           qn2 = it2%get_quantum_numbers ()
           val2 = it2%get_matrix_element ()
           qn3(:state1%depth) = qn1
           qn3(state1%depth+1:) = qn2
           call state3%add_state (qn3, value=val1 * val2)
           call it2%advance ()
        end do
        call it1%advance ()
     end do
     call state3%freeze ()
   end subroutine outer_multiply_pair
 
 @ %def outer_multiply_state_pair
 @ This executes the above routine iteratively for an arbitrary number
 of state matrices.
 <<State matrices: procedures>>=
   subroutine outer_multiply_array (state_in, state_out)
     type(state_matrix_t), dimension(:), intent(in), target :: state_in
     type(state_matrix_t), intent(out) :: state_out
     type(state_matrix_t), dimension(:), allocatable, target :: state_tmp
     integer :: i, n
     n = size (state_in)
     select case (n)
     case (0)
        call state_out%init ()
     case (1)
        state_out = state_in(1)
     case (2)
        call outer_multiply_pair (state_in(1), state_in(2), state_out)
     case default
        allocate (state_tmp (n-2))
        call outer_multiply_pair (state_in(1), state_in(2), state_tmp(1))
        do i = 2, n - 2
           call outer_multiply_pair (state_tmp(i-1), state_in(i+1), state_tmp(i))
        end do
        call outer_multiply_pair (state_tmp(n-2), state_in(n), state_out)
        do i = 1, size(state_tmp)
           call state_tmp(i)%final ()
        end do
     end select
   end subroutine outer_multiply_array
 
 @ %def outer_multiply_pair
 @ %def outer_multiply_array
 @
 \subsection{Factorization}
 In physical events, the state matrix is factorized into
 single-particle state matrices.  This is essentially a measurement.
 
 In a simulation, we select one particular branch of the state matrix
 with a probability that is determined by the matrix elements at the
 leaves.  (This makes sense only if the state matrix represents a
 squared amplitude.)  The selection is based on a (random) value [[x]]
 between 0 and one that is provided as the third argument.
 
 For flavor and color, we select a unique value for each particle.  For
 polarization, we have three options (modes).  Option 1 is to drop
 helicity information altogether and sum over all diagonal helicities.
 Option 2 is to select a unique diagonal helicity in the same way as
 flavor and color.  Option 3 is, for each particle, to trace over all
 remaining helicities in order to obtain an array of independent
 single-particle helicity matrices.
 
 Only branches that match the given quantum-number array [[qn_in]], if
 present, are considered.  For this array, color is ignored.
 
 If the optional [[correlated_state]] is provided, it is assigned the
 correlated density matrix for the selected flavor-color branch, so
 multi-particle spin correlations remain available even if they are
 dropped in the single-particle density matrices.  This should be
 done by the caller for the choice [[FM_CORRELATED_HELICITY]], which
 otherwise is handled as [[FM_IGNORE_HELICITY]].
 
 The algorithm is as follows: First, we determine the normalization by
 summing over all diagonal matrix elements.  In a second scan, we
 select one of the diagonal matrix elements by a cumulative comparison
 with the normalized random number.  In the corresponding quantum
 number array, we undefine the helicity entries.  Then, we scan the
 third time.  For each branch that matches the selected quantum number
 array (i.e., definite flavor and color, arbitrary helicity), we
 determine its contribution to any of the single-particle state
 matrices.  The matrix-element value is added if all other quantum
 numbers are diagonal, while the helicity of the chosen particle may be
 arbitrary; this helicity determines the branch in the single-particle
 state.
 
 As a result, flavor and color quantum numbers are selected with the
 correct probability.  Within this subset of states, each
 single-particle state matrix results from tracing over all other
 particles.  Note that the single-particle state matrices are not
 normalized.
 
 The flag [[ok]] is set to false if the matrix element sum is zero, so
 factorization is not possible.  This can happen if an event did not pass
 cuts.
 <<State matrices: parameters>>=
   integer, parameter, public :: FM_IGNORE_HELICITY = 1
   integer, parameter, public :: FM_SELECT_HELICITY = 2
   integer, parameter, public :: FM_FACTOR_HELICITY = 3
   integer, parameter, public :: FM_CORRELATED_HELICITY = 4
 
 @ %def FM_IGNORE_HELICITY FM_SELECT_HELICITY FM_FACTOR_HELICITY
 @ %def FM_CORRELATED_HELICITY
 <<State matrices: state matrix: TBP>>=
   procedure :: factorize => state_matrix_factorize
 <<State matrices: procedures>>=
   subroutine state_matrix_factorize &
        (state, mode, x, ok, single_state, correlated_state, qn_in)
     class(state_matrix_t), intent(in), target :: state
     integer, intent(in) :: mode
     real(default), intent(in) :: x
     logical, intent(out) :: ok
     type(state_matrix_t), &
          dimension(:), allocatable, intent(out) :: single_state
     type(state_matrix_t), intent(out), optional :: correlated_state
     type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
     type(state_iterator_t) :: it
     real(default) :: s, xt
     complex(default) :: value
     integer :: i, depth
     type(quantum_numbers_t), dimension(:), allocatable :: qn, qn1
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
     logical, dimension(:), allocatable :: diagonal
     logical, dimension(:,:), allocatable :: mask
     ok = .true.
     if (x /= 0) then
        xt = x * abs (state%trace (qn_in))
     else
        xt = 0
     end if
     s = 0
     depth = state%get_depth ()
     allocate (qn (depth), qn1 (depth), diagonal (depth))
     call it%init (state)
     do while (it%is_valid ())
        qn = it%get_quantum_numbers ()
        if (present (qn_in)) then
           if (.not. all (qn .fhmatch. qn_in)) then
              call it%advance (); cycle
           end if
        end if
        if (all (qn%are_diagonal ())) then
           value = abs (it%get_matrix_element ())
           s = s + value
           if (s > xt)  exit
        end if
        call it%advance ()
     end do
     if (.not. it%is_valid ()) then
        if (s == 0)  ok = .false.
        call it%init (state)
     end if
     allocate (single_state (depth))
     do i = 1, depth
        call single_state(i)%init (store_values = .true.)
     end do
     if (present (correlated_state)) &
          call correlated_state%init (store_values = .true.)
     qn = it%get_quantum_numbers ()
     select case (mode)
     case (FM_SELECT_HELICITY)  ! single branch selected; shortcut
        do i = 1, depth
           call single_state(i)%add_state ([qn(i)], value=value)
        end do
        if (.not. present (correlated_state)) then
           do i = 1, size(single_state)
              call single_state(i)%freeze ()
           end do
           return
        end if
     end select
     allocate (qn_mask (depth))
     call qn_mask%init (.false., .false., .false., .true.)
     call qn%undefine (qn_mask)
     select case (mode)
     case (FM_FACTOR_HELICITY)
        allocate (mask (depth, depth))
        mask = .false.
        forall (i = 1:depth)  mask(i,i) = .true.
     end select
     call it%init (state)
     do while (it%is_valid ())
        qn1 = it%get_quantum_numbers ()
        if (all (qn .match. qn1)) then
           diagonal = qn1%are_diagonal ()
           value = it%get_matrix_element ()
           select case (mode)
           case (FM_IGNORE_HELICITY, FM_CORRELATED_HELICITY)
              !!! trace over diagonal states that match qn
              if (all (diagonal)) then
                 do i = 1, depth
                    call single_state(i)%add_state &
                         ([qn(i)], value=value, sum_values=.true.)
                 end do
              end if
           case (FM_FACTOR_HELICITY)  !!! trace over all other particles
              do i = 1, depth
                 if (all (diagonal .or. mask(:,i))) then
                    call single_state(i)%add_state &
                         ([qn1(i)], value=value, sum_values=.true.)
                 end if
              end do
           end select
           if (present (correlated_state)) &
                call correlated_state%add_state (qn1, value=value)
        end if
        call it%advance ()
     end do
     do i = 1, depth
        call single_state(i)%freeze ()
     end do
     if (present (correlated_state)) &
          call correlated_state%freeze ()
   end subroutine state_matrix_factorize
 
 @ %def state_matrix_factorize
 @ \subsubsection{Auxiliary functions}
 <<State matrices: state matrix: TBP>>=
   procedure :: get_polarization_density_matrix &
      => state_matrix_get_polarization_density_matrix
 <<State matrices: procedures>>=
   function state_matrix_get_polarization_density_matrix (state) result (pol_matrix)
     real(default), dimension(:,:), allocatable :: pol_matrix
     class(state_matrix_t), intent(in) :: state
     type(node_t), pointer :: current => null ()
     !!! What's the generic way to allocate the matrix?
     allocate (pol_matrix (4,4)); pol_matrix = 0
     if (associated (state%root%child_first)) then
        current => state%root%child_first
        do while (associated (current))
          call current%qn%write ()
          current => current%next
        end do
     else
        call msg_fatal ("Polarization state not allocated!")
     end if
   end function state_matrix_get_polarization_density_matrix
 
 @ %def state_matrix_get_polarization_density_matrix
 @
 \subsubsection{Quantum-number matching}
 This feature allows us to check whether a given string of PDG values
 matches, in any ordering, any of the flavor combinations that the
 state matrix provides.  We will also request the permutation of the
 successful match.
 
 This type provides an account of the state's flavor content.  We store
 all flavor combinations, as [[pdg]] values, in an array, assuming that
 the length is uniform.
 
 We check only the entries selected by [[mask_match]].  Among those,
 only the entries selected by [[mask_sort]] are sorted and thus matched
 without respecting array element order. The entries that correspond to
 a true value in the associated [[mask]] are sorted.  The mapping from
 the original state to the sorted state is given by the index array
 [[map]].
 <<State matrices: public>>=
   public :: state_flv_content_t
 <<State matrices: types>>=
   type :: state_flv_content_t
      private
      integer, dimension(:,:), allocatable :: pdg
      integer, dimension(:,:), allocatable :: map
      logical, dimension(:), allocatable :: mask
    contains
    <<State matrices: state flv content: TBP>>
   end type state_flv_content_t
 
 @ %def state_matrix_flavor_content
 @ Output (debugging aid).
 <<State matrices: state flv content: TBP>>=
   procedure :: write => state_flv_content_write
 <<State matrices: procedures>>=
   subroutine state_flv_content_write (state_flv, unit)
     class(state_flv_content_t), intent(in), target :: state_flv
     integer, intent(in), optional :: unit
     integer :: u, n, d, i, j
     u = given_output_unit (unit)
     d = size (state_flv%pdg, 1)
     n = size (state_flv%pdg, 2)
     do i = 1, n
        write (u, "(2x,'PDG =')", advance="no")
        do j = 1, d
           write (u, "(1x,I0)", advance="no")  state_flv%pdg(j,i)
        end do
        write (u, "(' :: map = (')", advance="no")
        do j = 1, d
           write (u, "(1x,I0)", advance="no")  state_flv%map(j,i)
        end do
        write (u, "(' )')")
     end do
   end subroutine state_flv_content_write
 
 @ %def state_flv_content_write
 @ Initialize with table length and mask.  Each row of the [[map]]
 array, of length $d$, is initialized with $(0,1,\ldots,d)$.
 <<State matrices: state flv content: TBP>>=
   procedure :: init => state_flv_content_init
 <<State matrices: procedures>>=
   subroutine state_flv_content_init (state_flv, n, mask)
     class(state_flv_content_t), intent(out) :: state_flv
     integer, intent(in) :: n
     logical, dimension(:), intent(in) :: mask
     integer :: d, i
     d = size (mask)
     allocate (state_flv%pdg (d, n), source = 0)
     allocate (state_flv%map (d, n), source = spread ([(i, i = 1, d)], 2, n))
     allocate (state_flv%mask (d), source = mask)
   end subroutine state_flv_content_init
 
 @ %def state_flv_content_init
 @ Manually fill the entries, one flavor set and mapping at a time.
 <<State matrices: state flv content: TBP>>=
   procedure :: set_entry => state_flv_content_set_entry
 <<State matrices: procedures>>=
   subroutine state_flv_content_set_entry (state_flv, i, pdg, map)
     class(state_flv_content_t), intent(inout) :: state_flv
     integer, intent(in) :: i
     integer, dimension(:), intent(in) :: pdg, map
     state_flv%pdg(:,i) = pdg
     where (map /= 0)
        state_flv%map(:,i) = map
     end where
   end subroutine state_flv_content_set_entry
 
 @ %def state_flv_content_set_entry
 @ Given a state matrix, determine the flavor content.  That is, scan
 the state matrix and extract flavor only, build a new state matrix
 from that.
 <<State matrices: state flv content: TBP>>=
   procedure :: fill => state_flv_content_fill
 <<State matrices: procedures>>=
   subroutine state_flv_content_fill &
        (state_flv, state_full, mask)
     class(state_flv_content_t), intent(out) :: state_flv
     type(state_matrix_t), intent(in), target :: state_full
     logical, dimension(:), intent(in) :: mask
     type(state_matrix_t), target :: state_tmp
     type(state_iterator_t) :: it
     type(flavor_t), dimension(:), allocatable :: flv
     integer, dimension(:), allocatable :: pdg, pdg_subset
     integer, dimension(:), allocatable :: idx, map_subset, idx_subset, map
     type(quantum_numbers_t), dimension(:), allocatable :: qn
-    integer :: n, d, c, i, j
+    integer :: n, d, c, i
     call state_tmp%init ()
     d = state_full%get_depth ()
     allocate (flv (d), qn (d), pdg (d), idx (d), map (d))
     idx = [(i, i = 1, d)]
     c = count (mask)
     allocate (pdg_subset (c), map_subset (c), idx_subset (c))
     call it%init (state_full)
     do while (it%is_valid ())
        flv = it%get_flavor ()
        call qn%init (flv)
        call state_tmp%add_state (qn)
        call it%advance ()
     end do
     n = state_tmp%get_n_leaves ()
     call state_flv%init (n, mask)
     i = 0
     call it%init (state_tmp)
     do while (it%is_valid ())
        i = i + 1
        flv = it%get_flavor ()
        pdg = flv%get_pdg ()
        idx_subset = pack (idx, mask)
        pdg_subset = pack (pdg, mask)
        map_subset = order_abs (pdg_subset)
        map = unpack (idx_subset (map_subset), mask, idx)
        call state_flv%set_entry (i, &
             unpack (pdg_subset(map_subset), mask, pdg), &
             order (map))
        call it%advance ()
     end do
     call state_tmp%final ()
   end subroutine state_flv_content_fill
 
 @ %def state_flv_content_fill
 @ Match a given flavor string against the flavor content.  We sort the
 input string and check whether it matches any of the stored strings.
 If yes, return the mapping.
 
 Only PDG entries under the preset mask are sorted before matching.  The
 other entries must match exactly (i.e., without reordering).  A zero
 entry matches anything.  In any case, the length of the PDG string
 must be equal to the length $d$ of the individual flavor-state entries.
 <<State matrices: state flv content: TBP>>=
   procedure :: match => state_flv_content_match
 <<State matrices: procedures>>=
   subroutine state_flv_content_match (state_flv, pdg, success, map)
     class(state_flv_content_t), intent(in) :: state_flv
     integer, dimension(:), intent(in) :: pdg
     logical, intent(out) :: success
     integer, dimension(:), intent(out) :: map
     integer, dimension(:), allocatable :: pdg_subset, pdg_sorted, map1, map2
     integer, dimension(:), allocatable :: idx, map_subset, idx_subset
     integer :: i, n, c, d
     c = count (state_flv%mask)
     d = size (state_flv%pdg, 1)
     n = size (state_flv%pdg, 2)
     allocate (idx (d), source = [(i, i = 1, d)])
     allocate (idx_subset (c), pdg_subset (c), map_subset (c))
     allocate (pdg_sorted (d), map1 (d), map2 (d))
     idx_subset = pack (idx, state_flv%mask)
     pdg_subset = pack (pdg, state_flv%mask)
     map_subset = order_abs (pdg_subset)
     pdg_sorted = unpack (pdg_subset(map_subset), state_flv%mask, pdg)
     success = .false.
     do i = 1, n
        if (all (pdg_sorted == state_flv%pdg(:,i) &
             .or. pdg_sorted == 0)) then
           success = .true.
           exit
        end if
     end do
     if (success) then
        map1 = state_flv%map(:,i)
        map2 = unpack (idx_subset(map_subset), state_flv%mask, idx)
        map = map2(map1)
        where (pdg == 0)  map = 0
     end if
   end subroutine state_flv_content_match
 
 @ %def state_flv_content_match
 @ Check if a given PDG code occurs anywhere in the table.
 <<State matrices: state flv content: TBP>>=
   procedure :: contains => state_flv_content_contains
 <<State matrices: procedures>>=
   function state_flv_content_contains (state_flv, pdg) result (success)
     class(state_flv_content_t), intent(in) :: state_flv
     integer, intent(in) :: pdg
     logical :: success
     success = any (state_flv%pdg == pdg)
   end function state_flv_content_contains
 
 @ %def state_flv_content_contains
 @
 <<State matrices: procedures>>=
   elemental function pacify_complex (c_in) result (c_pac)
     complex(default), intent(in) :: c_in
     complex(default) :: c_pac
     c_pac = c_in
     if (real(c_pac) == -real(c_pac)) then
        c_pac = &
             cmplx (0._default, aimag(c_pac), kind=default)
     end if
     if (aimag(c_pac) == -aimag(c_pac)) then
        c_pac = &
             cmplx (real(c_pac), 0._default, kind=default)
     end if
   end function pacify_complex
 
 @ %def pacify_complex
+@ Looks for flavor structures that only differ by a permutation
+of the masked flavors.
+The result is returned in form of a mask which is [[.true.]] at the
+positions of a duplicate flavor structure from the second encounter on.
+This routine implements the naive approach: We go through all flavor
+structures and compare each one with each preceeding one. This works
+but is $\mathcal{O}(n^2)$ in the number of flavor structures. Using
+a table to remember which flavor structure has already been encountered,
+if would be possible to find the duplicates in $\mathcal{O}(n)$.
+<<State matrices: state flv content: TBP>>=
+  procedure :: find_duplicates => state_flv_content_find_duplicates
+<<State matrices: procedures>>=
+  subroutine state_flv_content_find_duplicates (state_flv, duplicate_mask)
+    class(state_flv_content_t), intent(in) :: state_flv
+    logical, dimension(:), allocatable, intent(out) :: duplicate_mask
+    integer, dimension(:), allocatable :: flvst
+    integer :: i1, i2, n_flvsts
+    logical :: found_once
+    n_flvsts = size (state_flv%pdg, 2)
+    allocate (duplicate_mask (n_flvsts))
+    duplicate_mask = .false.
+    do i1 = 1, n_flvsts
+       found_once = .false.
+       flvst = state_flv%pdg(:,i1)
+       do i2 = 1, i1
+          if (all(flvst == state_flv%pdg(:,i2))) then
+             if (found_once) then
+                duplicate_mask(i1) = .true.
+                exit
+             else
+                found_once = .true.
+             end if
+          end if
+       end do
+    end do
+  end subroutine state_flv_content_find_duplicates
+
+@ %def state_flv_content_find_duplicates
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[state_matrices_ut.f90]]>>=
 <<File header>>
 
 module state_matrices_ut
   use unit_tests
   use state_matrices_uti
 
 <<Standard module head>>
 
 <<State matrices: public test>>
 
 contains
 
 <<State matrices: test driver>>
 
 end module state_matrices_ut
 @ %def state_matrices_ut
 @
 <<[[state_matrices_uti.f90]]>>=
 <<File header>>
 
 module state_matrices_uti
 
 <<Use kinds>>
   use io_units
   use format_defs, only: FMT_19
   use flavors
   use colors
   use helicities
   use quantum_numbers
 
   use state_matrices
 
 <<Standard module head>>
 
 <<State matrices: test declarations>>
 
 contains
 
 <<State matrices: tests>>
 
 end module state_matrices_uti
 @ %def state_matrices_ut
 @ API: driver for the unit tests below.
 <<State matrices: public test>>=
   public :: state_matrix_test
 <<State matrices: test driver>>=
   subroutine state_matrix_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<State matrices: execute tests>>
   end subroutine state_matrix_test
 
 @ %def state_matrix_test
 @ Create two quantum states of equal depth and merge them.
 <<State matrices: execute tests>>=
   call test (state_matrix_1, "state_matrix_1", &
        "check merge of quantum states of equal depth", &
        u, results)
 <<State matrices: test declarations>>=
   public :: state_matrix_1
 <<State matrices: tests>>=
   subroutine state_matrix_1 (u)
     integer, intent(in) :: u
     type(state_matrix_t) :: state1, state2, state3
     type(flavor_t), dimension(3) :: flv
     type(color_t), dimension(3) :: col
     type(quantum_numbers_t), dimension(3) :: qn
 
     write (u, "(A)")  "* Test output: state_matrix_1"
     write (u, "(A)")  "*   Purpose: create and merge two quantum states"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     write (u, "(A)")  "*  State matrix 1"
     write (u, "(A)")
 
     call state1%init ()
     call flv%init ([1, 2, 11])
     call qn%init (flv, helicity ([ 1, 1, 1]))
     call state1%add_state (qn)
     call qn%init (flv, helicity ([ 1, 1, 1], [-1, 1, -1]))
     call state1%add_state (qn)
     call state1%freeze ()
     call state1%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "*  State matrix 2"
     write (u, "(A)")
 
     call state2%init ()
     call col(1)%init ([501])
     call col(2)%init ([-501])
     call col(3)%init ([0])
     call qn%init (col, helicity ([-1, -1, 0]))
     call state2%add_state (qn)
     call col(3)%init ([99])
     call qn%init (col, helicity ([-1, -1, 0]))
     call state2%add_state (qn)
     call state2%freeze ()
     call state2%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Merge the state matrices"
     write (u, "(A)")
 
     call merge_state_matrices (state1, state2, state3)
     call state3%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Collapse the state matrix"
     write (u, "(A)")
 
     call state3%collapse (quantum_numbers_mask (.false., .false., &
          [.true.,.false.,.false.]))
     call state3%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     call state1%final ()
     call state2%final ()
     call state3%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: state_matrix_1"
     write (u, "(A)")
 
   end subroutine state_matrix_1
 
 @ %def state_matrix_1
 @ Create a correlated three-particle state matrix and factorize it.
 <<State matrices: execute tests>>=
   call test (state_matrix_2, "state_matrix_2", &
        "check factorizing 3-particle state matrix", &
        u, results)
 <<State matrices: test declarations>>=
   public :: state_matrix_2
 <<State matrices: tests>>=
   subroutine state_matrix_2 (u)
     integer, intent(in) :: u
     type(state_matrix_t) :: state
     type(state_matrix_t), dimension(:), allocatable :: single_state
     type(state_matrix_t) :: correlated_state
     integer :: f, h11, h12, h21, h22, i, mode
     type(flavor_t), dimension(2) :: flv
     type(color_t), dimension(2) :: col
     type(helicity_t), dimension(2) :: hel
     type(quantum_numbers_t), dimension(2) :: qn
     logical :: ok
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output: state_matrix_2"
     write (u, "(A)")  "*   Purpose: factorize correlated 3-particle state"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call state%init ()
     do f = 1, 2
        do h11 = -1, 1, 2
           do h12 = -1, 1, 2
              do h21 = -1, 1, 2
                 do h22 = -1, 1, 2
                    call flv%init ([f, -f])
                    call col(1)%init ([1])
                    call col(2)%init ([-1])
                    call hel%init ([h11,h12], [h21, h22])
                    call qn%init (flv, col, hel)
                    call state%add_state (qn)
                 end do
              end do
           end do
        end do
     end do
     call state%freeze ()
     call state%write (u)
 
     write (u, "(A)")
     write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") &
          "* Trace = ", state%trace ()
     write (u, "(A)")
 
     do mode = 1, 3
        write (u, "(A)")
        write (u, "(A,I1)")  "* Mode = ", mode
        call state%factorize &
             (mode, 0.15_default, ok, single_state, correlated_state)
        do i = 1, size (single_state)
           write (u, "(A)")
           call single_state(i)%write (u)
           write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')") &
                "Trace = ", single_state(i)%trace ()
        end do
        write (u, "(A)")
        call correlated_state%write (u)
        write (u, "(A,'('," // FMT_19 // ",','," // FMT_19 // ",')')")  &
             "Trace = ", correlated_state%trace ()
        do i = 1, size(single_state)
           call single_state(i)%final ()
        end do
        call correlated_state%final ()
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call state%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: state_matrix_2"
 
   end subroutine state_matrix_2
 
 @ %def state_matrix_2
 @ Create a colored state matrix and add color contractions.
 <<State matrices: execute tests>>=
   call test (state_matrix_3, "state_matrix_3", &
        "check factorizing 3-particle state matrix", &
        u, results)
 <<State matrices: test declarations>>=
   public :: state_matrix_3
 <<State matrices: tests>>=
   subroutine state_matrix_3 (u)
     use physics_defs, only: HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET
     integer, intent(in) :: u
     type(state_matrix_t) :: state
     type(flavor_t), dimension(4) :: flv
     type(color_t), dimension(4) :: col
     type(quantum_numbers_t), dimension(4) :: qn
 
     write (u, "(A)")  "* Test output: state_matrix_3"
     write (u, "(A)")  "*   Purpose: add color connections to colored state"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     call state%init ()
     call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, -1, HADRON_REMNANT_TRIPLET ])
     call col(1)%init ([17])
     call col(2)%init ([-17])
     call col(3)%init ([-19])
     call col(4)%init ([19])
     call qn%init (flv, col)
     call state%add_state (qn)
     call flv%init ([ 1, -HADRON_REMNANT_TRIPLET, 21, HADRON_REMNANT_OCTET ])
     call col(1)%init ([17])
     call col(2)%init ([-17])
     call col(3)%init ([3, -5])
     call col(4)%init ([5, -3])
     call qn%init (flv, col)
     call state%add_state (qn)
     call state%freeze ()
 
     write (u, "(A)") "* State:"
     write (u, "(A)")
 
     call state%write (u)
     call state%add_color_contractions ()
 
     write (u, "(A)") "* State with contractions:"
     write (u, "(A)")
 
     call state%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call state%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: state_matrx_3"
 
   end subroutine state_matrix_3
 
 @ %def state_matrix_3
 @ Create a correlated three-particle state matrix, write it to file
 and read again.
 <<State matrices: execute tests>>=
   call test (state_matrix_4, "state_matrix_4", &
        "check raw I/O", &
        u, results)
 <<State matrices: test declarations>>=
   public :: state_matrix_4
 <<State matrices: tests>>=
   subroutine state_matrix_4 (u)
     integer, intent(in) :: u
     type(state_matrix_t), allocatable :: state
     integer :: f, h11, h12, h21, h22, i
     type(flavor_t), dimension(2) :: flv
     type(color_t), dimension(2) :: col
     type(helicity_t), dimension(2) :: hel
     type(quantum_numbers_t), dimension(2) :: qn
     integer :: unit, iostat
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output: state_matrix_4"
     write (u, "(A)")  "*   Purpose: raw I/O for correlated 3-particle state"
     write (u, "(A)")
 
     write (u, "(A)")  "*  Initialization"
     write (u, "(A)")
 
     allocate (state)
 
     call state%init ()
     do f = 1, 2
        do h11 = -1, 1, 2
           do h12 = -1, 1, 2
              do h21 = -1, 1, 2
                 do h22 = -1, 1, 2
                    call flv%init ([f, -f])
                    call col(1)%init ([1])
                    call col(2)%init ([-1])
                    call hel%init ([h11, h12], [h21, h22])
                    call qn%init (flv, col, hel)
                    call state%add_state (qn)
                 end do
              end do
           end do
        end do
     end do
     call state%freeze ()
 
     call state%set_norm (3._default)
     do i = 1, state%get_n_leaves ()
        call state%set_matrix_element (i, cmplx (2 * i, 2 * i + 1, default))
     end do
 
     call state%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Write to file and read again "
     write (u, "(A)")
 
     unit = free_unit ()
     open (unit, action="readwrite", form="unformatted", status="scratch")
     call state%write_raw (unit)
     call state%final ()
     deallocate (state)
 
     allocate(state)
     rewind (unit)
     call state%read_raw (unit, iostat=iostat)
     close (unit)
 
     call state%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call state%final ()
     deallocate (state)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: state_matrix_4"
 
   end subroutine state_matrix_4
 
 @ %def state_matrix_4
 @
 Create a flavor-content object for a given state matrix and match it
 against trial flavor (i.e., PDG) strings.
 <<State matrices: execute tests>>=
   call test (state_matrix_5, "state_matrix_5", &
        "check flavor content", &
        u, results)
 <<State matrices: test declarations>>=
   public :: state_matrix_5
 <<State matrices: tests>>=
   subroutine state_matrix_5 (u)
     integer, intent(in) :: u
     type(state_matrix_t), allocatable, target :: state
     type(state_iterator_t) :: it
     type(state_flv_content_t), allocatable :: state_flv
     type(flavor_t), dimension(4) :: flv1, flv2, flv3, flv4
     type(color_t), dimension(4) :: col1, col2
     type(helicity_t), dimension(4) :: hel1, hel2, hel3
     type(quantum_numbers_t), dimension(4) :: qn
     logical, dimension(4) :: mask
 
     write (u, "(A)")  "* Test output: state_matrix_5"
     write (u, "(A)")  "*   Purpose: check flavor-content state"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up arbitrary state matrix"
     write (u, "(A)")
 
     call flv1%init ([1, 4, 2, 7])
     call flv2%init ([1, 3,-3, 8])
     call flv3%init ([5, 6, 3, 7])
     call flv4%init ([6, 3, 5, 8])
     call hel1%init ([0, 1, -1, 0])
     call hel2%init ([0, 1, 1, 1])
     call hel3%init ([1, 0, 0, 0])
     call col1(1)%init ([0])
     call col1(2)%init ([0])
     call col1(3)%init ([0])
     call col1(4)%init ([0])
     call col2(1)%init ([5, -6])
     call col2(2)%init ([0])
     call col2(3)%init ([6, -5])
     call col2(4)%init ([0])
 
     allocate (state)
     call state%init ()
     call qn%init (flv1, col1, hel1)
     call state%add_state (qn)
     call qn%init (flv1, col1, hel2)
     call state%add_state (qn)
     call qn%init (flv3, col1, hel3)
     call state%add_state (qn)
     call qn%init (flv4, col1, hel3)
     call state%add_state (qn)
     call qn%init (flv1, col2, hel3)
     call state%add_state (qn)
     call qn%init (flv2, col2, hel2)
     call state%add_state (qn)
     call qn%init (flv2, col2, hel1)
     call state%add_state (qn)
     call qn%init (flv2, col1, hel1)
     call state%add_state (qn)
     call qn%init (flv3, col1, hel1)
     call state%add_state (qn)
     call qn%init (flv3, col2, hel3)
     call state%add_state (qn)
     call qn%init (flv1, col1, hel1)
     call state%add_state (qn)
 
     write (u, "(A)")  "* Quantum number content"
     write (u, "(A)")
 
     call it%init (state)
     do while (it%is_valid ())
        call quantum_numbers_write (it%get_quantum_numbers (), u)
        write (u, *)
        call it%advance ()
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract the flavor content"
     write (u, "(A)")
 
     mask = [.true., .true., .true., .false.]
 
     allocate (state_flv)
     call state_flv%fill (state, mask)
     call state_flv%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Match trial sets"
     write (u, "(A)")
 
     call check ([1, 2, 3, 0])
     call check ([1, 4, 2, 0])
     call check ([4, 2, 1, 0])
     call check ([1, 3, -3, 0])
     call check ([1, -3, 3, 0])
     call check ([6, 3, 5, 0])
 
     write (u, "(A)")
     write (u, "(A)")  "* Determine the flavor content with mask"
     write (u, "(A)")
 
     mask = [.false., .true., .true., .false.]
 
     call state_flv%fill (state, mask)
     call state_flv%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Match trial sets"
     write (u, "(A)")
 
     call check ([1, 2, 3, 0])
     call check ([1, 4, 2, 0])
     call check ([4, 2, 1, 0])
     call check ([1, 3, -3, 0])
     call check ([1, -3, 3, 0])
     call check ([6, 3, 5, 0])
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     deallocate (state_flv)
 
     call state%final ()
     deallocate (state)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: state_matrix_5"
 
   contains
 
     subroutine check (pdg)
       integer, dimension(4), intent(in) :: pdg
       integer, dimension(4) :: map
       logical :: success
       call state_flv%match (pdg, success, map)
       write (u, "(2x,4(1x,I0),':',1x,L1)", advance="no")  pdg, success
       if (success) then
          write (u, "(2x,'map = (',4(1x,I0),' )')")  map
       else
          write (u, *)
       end if
     end subroutine check
 
   end subroutine state_matrix_5
 
 @ %def state_matrix_5
 @
 Create a state matrix with full flavor, color and helicity information.
 Afterwards, reduce such that it is only differential in flavor and
 initial-state helicities. This is used when preparing states for beam-
 polarized computations with external matrix element providers.
 <<State matrices: execute tests>>=
   call test (state_matrix_6, "state_matrix_6", &
              "check state matrix reduction", &
              u, results)
 <<State matrices: test declarations>>=
   public :: state_matrix_6
 <<State matrices: tests>>=
   subroutine state_matrix_6 (u)
     integer, intent(in) :: u
     type(state_matrix_t), allocatable :: state_orig, state_reduced
     type(flavor_t), dimension(4) :: flv
     type(helicity_t), dimension(4) :: hel
     type(color_t), dimension(4) :: col
     type(quantum_numbers_t), dimension(4) :: qn
     type(quantum_numbers_mask_t), dimension(4) :: qn_mask
     integer :: h1, h2, h3 , h4
     integer :: n_states = 0
 
     write (u, "(A)") "* Test output: state_matrix_6"
     write (u, "(A)") "* Purpose: Check state matrix reduction"
     write (u, "(A)")
 
     write (u, "(A)") "* Set up helicity-diagonal state matrix"
     write (u, "(A)")
 
     allocate (state_orig)
     call state_orig%init ()
 
     call flv%init ([11, -11, 1, -1])
     call col(3)%init ([1])
     call col(4)%init ([-1])
     do h1 = -1, 1, 2
        do h2 = -1, 1, 2
           do h3 = -1, 1, 2
              do h4 = -1, 1, 2
                 n_states = n_states + 1
                 call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
                 call qn%init (flv, col, hel)
                 call state_orig%add_state (qn)
              end do
           end do
        end do
     end do
     call state_orig%freeze ()
 
     write (u, "(A)") "* Original state: "
     write (u, "(A)")
     call state_orig%write (u)
 
     write (u, "(A)")
     write (u, "(A)") "* Setup quantum mask: "
 
     call qn_mask%init ([.false., .false., .false., .false.], &
                        [.true., .true., .true., .true.], &
                        [.false., .false., .true., .true.])
     call quantum_numbers_mask_write (qn_mask, u)
     write (u, "(A)")
     write (u, "(A)") "* Reducing the state matrix using above mask"
     write (u, "(A)")
     allocate (state_reduced)
     call state_orig%reduce (qn_mask, state_reduced)
 
     write (u, "(A)") "* Reduced state matrix: "
     call state_reduced%write (u)
 
     write (u, "(A)") "* Test output end: state_matrix_6"
   end subroutine state_matrix_6
 
 @ %def state_matrix_6
 @
 Create a state matrix with full flavor, color and helicity information.
 Afterwards, reduce such that it is only differential in flavor and
 initial-state helicities, and keeping old indices. Afterwards reorder the
 reduced state matrix in accordance to the original state matrix.
 <<State matrices: execute tests>>=
   call test (state_matrix_7, "state_matrix_7", &
              "check ordered state matrix reduction", &
              u, results)
 <<State matrices: test declarations>>=
   public :: state_matrix_7
 <<State matrices: tests>>=
   subroutine state_matrix_7 (u)
     integer, intent(in) :: u
     type(state_matrix_t), allocatable :: state_orig, state_reduced, &
          state_ordered
     type(flavor_t), dimension(4) :: flv
     type(helicity_t), dimension(4) :: hel
     type(color_t), dimension(4) :: col
     type(quantum_numbers_t), dimension(4) :: qn
     type(quantum_numbers_mask_t), dimension(4) :: qn_mask
     integer :: h1, h2, h3 , h4
     integer :: n_states = 0
 
     write (u, "(A)") "* Test output: state_matrix_7"
     write (u, "(A)") "* Purpose: Check ordered state matrix reduction"
     write (u, "(A)")
 
     write (u, "(A)") "* Set up helicity-diagonal state matrix"
     write (u, "(A)")
 
     allocate (state_orig)
     call state_orig%init ()
 
     call flv%init ([11, -11, 1, -1])
     call col(3)%init ([1])
     call col(4)%init ([-1])
     do h1 = -1, 1, 2
        do h2 = -1, 1, 2
           do h3 = -1, 1, 2
              do h4 = -1, 1, 2
                 n_states = n_states + 1
                 call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
                 call qn%init (flv, col, hel)
                 call state_orig%add_state (qn)
              end do
           end do
        end do
     end do
     call state_orig%freeze ()
 
     write (u, "(A)") "* Original state: "
     write (u, "(A)")
     call state_orig%write (u)
 
     write (u, "(A)")
     write (u, "(A)") "* Setup quantum mask: "
 
     call qn_mask%init ([.false., .false., .false., .false.], &
                        [.true., .true., .true., .true.], &
                        [.false., .false., .true., .true.])
     call quantum_numbers_mask_write (qn_mask, u)
     write (u, "(A)")
     write (u, "(A)") "* Reducing the state matrix using above mask and keeping the old indices:"
     write (u, "(A)")
     allocate (state_reduced)
     call state_orig%reduce (qn_mask, state_reduced, keep_me_index = .true.)
 
     write (u, "(A)") "* Reduced state matrix with kept indices: "
     call state_reduced%write (u)
 
     write (u, "(A)")
     write (u, "(A)") "* Reordering reduced state matrix:"
     write (u, "(A)")
     allocate (state_ordered)
     call state_reduced%reorder_me (state_ordered)
 
     write (u, "(A)") "* Reduced and ordered state matrix:"
     call state_ordered%write (u)
 
     write (u, "(A)") "* Test output end: state_matrix_6"
   end subroutine state_matrix_7
 
 @ %def state_matrix_7
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Interactions}
 This module defines the [[interaction_t]] type.  It is an extension of
 the [[state_matrix_t]] type.
 
 The state matrix is a representation of a multi-particle density
 matrix.  It implements all possible flavor, color, and quantum-number
 assignments of the entries in a generic density matrix, and it can
 hold a complex matrix element for each entry.  (Note that this matrix
 can hold non-diagonal entries in color and helicity space.)  The
 [[interaction_t]] object associates this with a list of momenta, such
 that the whole object represents a multi-particle state.
 
 The [[interaction_t]] holds information about which particles are
 incoming, virtual (i.e., kept for the records), or outgoing.  Each
 particle can be associated to a source within another interaction.
 This allows us to automatically fill those interaction momenta which
 have been computed or defined elsewhere.  It also contains internal
 parent-child relations and flags for (virtual) particles which are to
 be treated as resonances.
 
 A quantum-number mask array summarizes, for each particle within the
 interaction, the treatment of flavor, color, or helicity (expose or
 ignore).  A list of locks states which particles are bound to have an
 identical quantum-number mask.  This is useful when the mask is
 changed at one place.
 <<[[interactions.f90]]>>=
 <<File header>>
 
 module interactions
 
 <<Use kinds>>
   use io_units
   use diagnostics
   use sorting
   use lorentz
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use state_matrices
 
 <<Standard module head>>
 
 <<Interactions: public>>
 
 <<Interactions: types>>
 
 <<Interactions: interfaces>>
 
 contains
 
 <<Interactions: procedures>>
 
 end module interactions
 @ %def interactions
 @ Given an ordered list of quantum numbers (without any subtraction index) map
 this list to a state matrix, such that each list index corresponds to an
 index of a set of quantum numbers in the state matrix, hence, the matrix element.
 
 The (unphysical) subtraction index is not a genuine quantum number and as
 such handled specially.
 <<Interactions: public>>=
   public :: qn_index_map_t
 <<Interactions: types>>=
   type :: qn_index_map_t
      private
      type(quantum_numbers_t), dimension(:, :), allocatable :: qn_flv
      type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel
      logical :: flip_hel = .false.
      integer :: n_flv = 0, n_hel = 0, n_sub = 0
      integer, dimension(:, :, :), allocatable :: index
      integer, dimension(:,:), allocatable :: sf_index_born, sf_index_real
    contains
    <<Interactions: qn index map: TBP>>
   end type qn_index_map_t
 
 @ %def qn_index_map_t
 @ Construct a mapping from interaction to an array of (sorted) quantum numbers.
 
 We strip all non-elementary particles (like beam) from the quantum numbers which
 we retrieve from the interaction.
 
 We consider helicity matrix elements only, when [[qn_hel]] is allocated.
 Else the helicity index is handled trivially as [[1]].
 
 For the rescaling of the structure functions in the real subtraction
 and DGLAP components we need a mapping (initialized by [[qn_index_map_init_sf]])
 from the real and born flavor structure indices to the structure function chain
 interaction matrix element with the correct initial state quantum numbers. This is stored
 in [[sf_index_born]] and [[sf_index_real]]. The array [[index]] is only needed for the
 initialisation of the Born and real index arrays and is therefore deallocated again.
 <<Interactions: qn index map: TBP>>=
   generic :: init => init_trivial, &
                      init_involved, &
                      init_sf
   procedure, private :: init_trivial => qn_index_map_init_trivial
   procedure, private :: init_involved => qn_index_map_init_involved
   procedure, private :: init_sf => qn_index_map_init_sf
 <<Interactions: procedures>>=
   subroutine qn_index_map_init_trivial (self, int)
     class(qn_index_map_t), intent(out) :: self
     class(interaction_t), intent(in) :: int
     integer :: qn
     self%n_flv = int%get_n_matrix_elements ()
     self%n_hel = 1
     self%n_sub = 0
     allocate (self%index(self%n_flv, self%n_hel, 0:self%n_sub), source = 0)
     do qn = 1, self%n_flv
        self%index(qn, 1, 0) = qn
     end do
   end subroutine qn_index_map_init_trivial
 
   subroutine qn_index_map_init_involved (self, int, qn_flv, n_sub, qn_hel)
     class(qn_index_map_t), intent(out) :: self
     type(interaction_t), intent(in) :: int
     type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv
     integer, intent(in) :: n_sub
     type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel
     type(quantum_numbers_t), dimension(:), allocatable :: qn, qn_int
     integer :: i, i_flv, i_hel, i_sub
     self%qn_flv = qn_flv
     self%n_flv = size (qn_flv, dim=2)
     self%n_sub = n_sub
     if (present (qn_hel)) then
        if (size (qn_flv, dim=1) /= size (qn_hel, dim=1)) then
           call msg_bug ("[qn_index_map_init] number of particles does not match.")
        end if
        self%qn_hel = qn_hel
        self%n_hel = size (qn_hel, dim=2)
     else
        self%n_hel = 1
     end if
     allocate (self%index (self%n_flv, self%n_hel, 0:self%n_sub), source=0)
     associate (n_me => int%get_n_matrix_elements ())
        do i = 1, n_me
           qn_int = int%get_quantum_numbers (i, by_me_index = .true.)
           qn = pack (qn_int, qn_int%are_hard_process ())
           i_flv = find_flv_index (self, qn)
           i_hel = 1; if (allocated (self%qn_hel)) &
                i_hel = find_hel_index (self, qn)
           i_sub = find_sub_index (self, qn)
           self%index(i_flv, i_hel, i_sub) = i
        end do
     end associate
   contains
     integer function find_flv_index (self, qn) result (i_flv)
       type(qn_index_map_t), intent(in) :: self
       type(quantum_numbers_t), dimension(:), intent(in) :: qn
       integer :: j
       i_flv = 0
       do j = 1, self%n_flv
          if (.not. all (qn .fmatch. self%qn_flv(:, j))) cycle
          i_flv = j
          exit
       end do
       if (i_flv < 1) then
          call msg_message ("QN:")
          call quantum_numbers_write (qn)
          call msg_message ("")
          call msg_message ("QN_FLV:")
          do j = 1, self%n_flv
             call quantum_numbers_write (self%qn_flv(:, j))
             call msg_message ("")
          end do
          call msg_bug ("[find_flv_index] could not find flv in qn_flv.")
       end if
     end function find_flv_index
 
     integer function find_hel_index (self, qn) result (i_hel)
       type(qn_index_map_t), intent(in) :: self
       type(quantum_numbers_t), dimension(:), intent(in) :: qn
       integer :: j
       i_hel = 0
       do j = 1, self%n_hel
          if (.not. all (qn .hmatch. self%qn_hel(:, j))) cycle
          i_hel = j
          exit
       end do
       if (i_hel < 1) then
          call msg_message ("QN:")
          call quantum_numbers_write (qn)
          call msg_message ("")
          call msg_message ("QN_HEL:")
          do j = 1, self%n_hel
             call quantum_numbers_write (self%qn_hel(:, j))
             call msg_message ("")
          end do
          call msg_bug ("[find_hel_index] could not find hel in qn_hel.")
       end if
     end function find_hel_index
 
     integer function find_sub_index (self, qn) result (i_sub)
       type(qn_index_map_t), intent(in) :: self
       type(quantum_numbers_t), dimension(:), intent(in) :: qn
       integer :: s
       i_sub = -1
       do s = 0, self%n_sub
          if ((all (pack(qn%get_sub (), qn%get_sub () > 0) == s)) &
               .or. (all (qn%get_sub () == 0) .and. s == 0)) then
             i_sub = s
             exit
          end if
       end do
       if (i_sub < 0) then
          call msg_message ("QN:")
          call quantum_numbers_write (qn)
          call msg_bug ("[find_sub_index] could not find sub in qn.")
       end if
     end function find_sub_index
   end subroutine qn_index_map_init_involved
 
   subroutine qn_index_map_init_sf (self, int, qn_flv, n_flv_born, n_flv_real)
     class(qn_index_map_t), intent(out) :: self
     type(interaction_t), intent(in) :: int
     integer, intent(in) :: n_flv_born, n_flv_real
     type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn_int
     type(quantum_numbers_t), dimension(:), allocatable :: qn_int_tmp
     integer :: i, i_sub, n_flv, n_hard
     n_flv = int%get_n_matrix_elements ()
     qn_int_tmp = int%get_quantum_numbers (1, by_me_index = .true.)
     n_hard = count (qn_int_tmp%are_hard_process ())
     allocate (qn_int(n_hard, n_flv))
     do i = 1, n_flv
        qn_int_tmp = int%get_quantum_numbers (i, by_me_index = .true.)
        qn_int(:, i) = pack (qn_int_tmp, qn_int_tmp%are_hard_process ())
     end do
     call self%init (int, qn_int, int%get_n_sub ())
     allocate (self%sf_index_born(n_flv_born, 0:self%n_sub))
     allocate (self%sf_index_real(n_flv_real, 0:self%n_sub))
     do i_sub = 0, self%n_sub
        do i = 1, n_flv_born
           self%sf_index_born(i, i_sub) = self%get_index_by_qn (qn_flv(:,i), i_sub)
        end do
        do i = 1, n_flv_real
           self%sf_index_real(i, i_sub) = &
                self%get_index_by_qn (qn_flv(:,n_flv_born + i), i_sub)
        end do
     end do
     deallocate (self%index)
   end subroutine qn_index_map_init_sf
 
 @ %def qn_index_map_init_trivial
 @ %def qn_index_map_init_involved
 @ %def qn_index_map_init_sf
 @ Write the index map to unit.
 <<Interactions: qn index map: TBP>>=
   procedure :: write => qn_index_map_write
 <<Interactions: procedures>>=
   subroutine qn_index_map_write (self, unit)
     class(qn_index_map_t), intent(in) :: self
     integer, intent(in), optional :: unit
     integer :: u, i_flv, i_hel, i_sub
     u = given_output_unit (unit); if (u < 0) return
     write (u, *) "flip_hel: ", self%flip_hel
     do i_flv = 1, self%n_flv
        if (allocated (self%qn_flv)) &
             call quantum_numbers_write (self%qn_flv(:, i_flv))
        write (u, *)
        do i_hel = 1, self%n_hel
           if (allocated (self%qn_hel)) then
              call quantum_numbers_write (self%qn_hel(:, i_hel))
              write (u, *)
           end if
           do i_sub = 0, self%n_sub
              write (u, *) &
                   "(", i_flv, ",", i_hel, ",", i_sub, ") => ", self%index(i_flv, i_hel, i_sub)
           end do
        end do
     end do
   end subroutine qn_index_map_write
 
 @ %def qn_index_map_write
 @ Set helicity convention. If [[flip]], then we flip the helicities of
 anti-particles and we remap the indices accordingly.
 <<Interactions: qn index map: TBP>>=
   procedure :: set_helicity_flip => qn_index_map_set_helicity_flip
 <<Interactions: procedures>>=
   subroutine qn_index_map_set_helicity_flip (self, yorn)
     class(qn_index_map_t), intent(inout) :: self
     logical, intent(in) :: yorn
     integer :: i, i_flv, i_hel, i_hel_new
     type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel_flip
     integer, dimension(:, :, :), allocatable :: index
     if (.not. allocated (self%qn_hel)) then
        call msg_bug ("[qn_index_map_set_helicity_flip] &
             &cannot flip not-given helicity.")
     end if
     allocate (index (self%n_flv, self%n_hel, 0:self%n_sub), &
          source=self%index)
     self%flip_hel = yorn
     if (self%flip_hel) then
        do i_flv = 1, self%n_flv
           qn_hel_flip = self%qn_hel
           do i_hel = 1, self%n_hel
              do i = 1, size (self%qn_flv, dim=1)
                 if (is_anti_particle (self%qn_flv(i, i_flv))) then
                    call qn_hel_flip(i, i_hel)%flip_helicity ()
                 end if
              end do
           end do
           do i_hel = 1, self%n_hel
              i_hel_new = find_hel_index (qn_hel_flip, self%qn_hel(:, i_hel))
              self%index(i_flv, i_hel_new, :) = index(i_flv, i_hel, :)
           end do
        end do
     end if
   contains
     logical function is_anti_particle (qn) result (yorn)
       type(quantum_numbers_t), intent(in) :: qn
       type(flavor_t) :: flv
       flv = qn%get_flavor ()
       yorn = flv%get_pdg () < 0
     end function is_anti_particle
 
     integer function find_hel_index (qn_sort, qn) result (i_hel)
       type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_sort
       type(quantum_numbers_t), dimension(:), intent(in) :: qn
       integer :: j
       do j = 1, size(qn_sort, dim=2)
          if (.not. all (qn .hmatch. qn_sort(:, j))) cycle
          i_hel = j
          exit
       end do
     end function find_hel_index
   end subroutine qn_index_map_set_helicity_flip
 
 @ %def qn_index_map_set_helicity_flip
 @ Map from the previously given quantum number and subtraction
 index (latter ranging from 0 to [[n_sub]]) to the (interaction) matrix element.
 <<Interactions: qn index map: TBP>>=
   procedure :: get_index => qn_index_map_get_index
 <<Interactions: procedures>>=
   integer function qn_index_map_get_index (self, i_flv, i_hel, i_sub) result (index)
     class(qn_index_map_t), intent(in) :: self
     integer, intent(in) :: i_flv
     integer, intent(in), optional :: i_hel
     integer, intent(in), optional :: i_sub
     integer :: i_sub_opt, i_hel_opt
     i_sub_opt = 0; if (present (i_sub)) &
          i_sub_opt = i_sub
     i_hel_opt = 1; if (present (i_hel)) &
          i_hel_opt = i_hel
     index = 0
     if (.not. allocated (self%index)) then
        call msg_bug ("[qn_index_map_get_index] The index map is not allocated.")
     end if
     index = self%index(i_flv, i_hel_opt, i_sub_opt)
     if (index <= 0) then
        call self%write ()
        call msg_bug ("[qn_index_map_get_index] The index for the given quantum numbers could not be retrieved.")
     end if
   end function qn_index_map_get_index
 
 @ %def qn_index_map_get_i_flv
 @ Get [[n_flv]].
 <<Interactions: qn index map: TBP>>=
   procedure :: get_n_flv => qn_index_map_get_n_flv
 <<Interactions: procedures>>=
   integer function qn_index_map_get_n_flv (self) result (n_flv)
     class(qn_index_map_t), intent(in) :: self
     n_flv = self%n_flv
   end function qn_index_map_get_n_flv
 
 @ %def qn_index_map_get_n_flv
 @ Get [[n_hel]].
 <<Interactions: qn index map: TBP>>=
   procedure :: get_n_hel => qn_index_map_get_n_hel
 <<Interactions: procedures>>=
   integer function qn_index_map_get_n_hel (self) result (n_hel)
     class(qn_index_map_t), intent(in) :: self
     n_hel = self%n_hel
   end function qn_index_map_get_n_hel
 
 @ %def qn_index_map_get_n_flv
 @ Get [[n_sub]].
 <<Interactions: qn index map: TBP>>=
   procedure :: get_n_sub => qn_index_map_get_n_sub
 <<Interactions: procedures>>=
   integer function qn_index_map_get_n_sub (self) result (n_sub)
     class(qn_index_map_t), intent(in) :: self
     n_sub = self%n_sub
   end function qn_index_map_get_n_sub
 
 @ %def qn_index_map_get_n_sub
 @ Gets the index for the matrix element corresponding to a set of quantum numbers.
 So far, it ignores helicity (and color) indices.
 <<Interactions: qn index map: TBP>>=
   procedure :: get_index_by_qn => qn_index_map_get_index_by_qn
 <<Interactions: procedures>>=
   integer function qn_index_map_get_index_by_qn (self, qn, i_sub) result (index)
     class(qn_index_map_t), intent(in) :: self
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     integer, intent(in), optional :: i_sub
     integer :: i_qn
     if (size (qn) /= size (self%qn_flv, dim = 1)) &
          call msg_bug ("[qn_index_map_get_index_by_qn] number of particles does not match.")
     do i_qn = 1, self%n_flv
        if (all (qn .fmatch. self%qn_flv(:, i_qn))) then
           index = self%get_index (i_qn, i_sub = i_sub)
           return
        end if
     end do
     call self%write ()
     call msg_bug ("[qn_index_map_get_index_by_qn] The index for the given quantum &
          & numbers could not be retrieved.")
   end function qn_index_map_get_index_by_qn
 
 @ %def qn_index_map_get_index_by_qn
 @
 <<Interactions: qn index map: TBP>>=
   procedure :: get_sf_index_born => qn_index_map_get_sf_index_born
 <<Interactions: procedures>>=
   integer function qn_index_map_get_sf_index_born (self, i_born, i_sub) result (index)
     class(qn_index_map_t), intent(in) :: self
     integer, intent(in) :: i_born, i_sub
     index = self%sf_index_born(i_born, i_sub)
   end function qn_index_map_get_sf_index_born
 
 @ %def qn_index_map_get_sf_index_born
 @
 <<Interactions: qn index map: TBP>>=
   procedure :: get_sf_index_real => qn_index_map_get_sf_index_real
 <<Interactions: procedures>>=
   integer function qn_index_map_get_sf_index_real (self, i_real, i_sub) result (index)
     class(qn_index_map_t), intent(in) :: self
     integer, intent(in) :: i_real, i_sub
     index = self%sf_index_real(i_real, i_sub)
   end function qn_index_map_get_sf_index_real
 
 @ %def qn_index_map_get_sf_index_real
 @
 \subsection{External interaction links}
 Each particle in an interaction can have a link to a corresponding
 particle in another interaction.  This allows to fetch the momenta of
 incoming or virtual particles from the interaction where they are
 defined.  The link object consists of a pointer to the interaction and
 an index.
 <<Interactions: types>>=
   type :: external_link_t
      private
      type(interaction_t), pointer :: int => null ()
      integer :: i
   end type external_link_t
 
 @ %def external_link_t
 @ Set an external link.
 <<Interactions: procedures>>=
   subroutine external_link_set (link, int, i)
     type(external_link_t), intent(out) :: link
     type(interaction_t), target, intent(in) :: int
     integer, intent(in) :: i
     if (i /= 0) then
        link%int => int
        link%i = i
     end if
   end subroutine external_link_set
 
 @ %def external_link_set
 @ Reassign an external link to a new interaction (which should be an
 image of the original target).
 <<Interactions: procedures>>=
   subroutine external_link_reassign (link, int_src, int_target)
     type(external_link_t), intent(inout) :: link
     type(interaction_t), intent(in) :: int_src
     type(interaction_t), intent(in), target :: int_target
     if (associated (link%int)) then
        if (link%int%tag == int_src%tag)  link%int => int_target
     end if
   end subroutine external_link_reassign
 
 @ %def external_link_reassign
 @ Return true if the link is set
 <<Interactions: procedures>>=
   function external_link_is_set (link) result (flag)
     logical :: flag
     type(external_link_t), intent(in) :: link
     flag = associated (link%int)
   end function external_link_is_set
 
 @ %def external_link_is_set
 @ Return the interaction pointer.
 <<Interactions: public>>=
   public :: external_link_get_ptr
 <<Interactions: procedures>>=
   function external_link_get_ptr (link) result (int)
     type(interaction_t), pointer :: int
     type(external_link_t), intent(in) :: link
     int => link%int
   end function external_link_get_ptr
 
 @ %def external_link_get_ptr
 @ Return the index within that interaction
 <<Interactions: public>>=
   public :: external_link_get_index
 <<Interactions: procedures>>=
   function external_link_get_index (link) result (i)
     integer :: i
     type(external_link_t), intent(in) :: link
     i = link%i
   end function external_link_get_index
 
 @ %def external_link_get_index
 @ Return a pointer to the momentum of the corresponding particle.  If
 there is no association, return a null pointer.
 <<Interactions: procedures>>=
   function external_link_get_momentum_ptr (link) result (p)
     type(vector4_t), pointer :: p
     type(external_link_t), intent(in) :: link
     if (associated (link%int)) then
        p => link%int%p(link%i)
     else
        p => null ()
     end if
   end function external_link_get_momentum_ptr
 
 @ %def external_link_get_momentum_ptr
 @
 \subsection{Internal relations}
 In addition to the external links, particles within the interaction
 have parent-child relations.  Here, more than one link is possible,
 and we set up an array.
 <<Interactions: types>>=
   type :: internal_link_list_t
      private
      integer :: length = 0
      integer, dimension(:), allocatable :: link
    contains
    <<Interactions: internal link list: TBP>>
   end type internal_link_list_t
 
 @ %def internal_link_t internal_link_list_t
 @ Output, non-advancing.
 <<Interactions: internal link list: TBP>>=
   procedure :: write => internal_link_list_write
 <<Interactions: procedures>>=
   subroutine internal_link_list_write (object, unit)
     class(internal_link_list_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     do i = 1, object%length
        write (u, "(1x,I0)", advance="no")  object%link(i)
     end do
   end subroutine internal_link_list_write
 
 @ %def internal_link_list_write
 @ Append an item.  Start with an array size of 2 and double the size
 if necessary.
 
 Make sure that the indices are stored in ascending order.  To this
 end, shift the existing entries right, starting from the end, as long
 as they are larger than the new entry.
 <<Interactions: internal link list: TBP>>=
   procedure :: append => internal_link_list_append
 <<Interactions: procedures>>=
   subroutine internal_link_list_append (link_list, link)
     class(internal_link_list_t), intent(inout) :: link_list
     integer, intent(in) :: link
     integer :: l, j
     integer, dimension(:), allocatable :: tmp
     l = link_list%length
     if (allocated (link_list%link)) then
        if (l == size (link_list%link)) then
           allocate (tmp (2 * l))
           tmp(:l) = link_list%link
           call move_alloc (from = tmp, to = link_list%link)
        end if
     else
        allocate (link_list%link (2))
     end if
     link_list%link(l+1) = link
     SHIFT_LINK_IN_PLACE: do j = l, 1, -1
        if (link >= link_list%link(j)) then
           exit SHIFT_LINK_IN_PLACE
        else
           link_list%link(j+1) = link_list%link(j)
           link_list%link(j) = link
        end if
     end do SHIFT_LINK_IN_PLACE
     link_list%length = l + 1
   end subroutine internal_link_list_append
 
 @ %def internal_link_list_append
 @ Return true if the link list is nonempty:
 <<Interactions: internal link list: TBP>>=
   procedure :: has_entries => internal_link_list_has_entries
 <<Interactions: procedures>>=
   function internal_link_list_has_entries (link_list) result (flag)
     class(internal_link_list_t), intent(in) :: link_list
     logical :: flag
     flag = link_list%length > 0
   end function internal_link_list_has_entries
 
 @ %def internal_link_list_has_entries
 @ Return the list length
 <<Interactions: internal link list: TBP>>=
   procedure :: get_length => internal_link_list_get_length
 <<Interactions: procedures>>=
   function internal_link_list_get_length (link_list) result (length)
     class(internal_link_list_t), intent(in) :: link_list
     integer :: length
     length = link_list%length
   end function internal_link_list_get_length
 
 @ %def internal_link_list_get_length
 @ Return an entry.
 <<Interactions: internal link list: TBP>>=
   procedure :: get_link => internal_link_list_get_link
 <<Interactions: procedures>>=
   function internal_link_list_get_link (link_list, i) result (link)
     class(internal_link_list_t), intent(in) :: link_list
     integer, intent(in) :: i
     integer :: link
     if (i <= link_list%length) then
        link = link_list%link(i)
     else
        call msg_bug ("Internal link list: out of bounds")
     end if
   end function internal_link_list_get_link
 
 @ %def internal_link_list_get_link
 @
 \subsection{The interaction type}
 An interaction is an entangled system of particles.  Thus, the
 interaction object consists of two parts: the subevent, and the
 quantum state which technically is a trie.  The subnode levels beyond
 the trie root node are in correspondence to the subevent, so
 both should be traversed in parallel.
 
 The subevent is implemented as an allocatable array of
 four-momenta.  The first [[n_in]] particles are incoming, [[n_vir]]
 particles in-between can be kept for bookkeeping, and the last
 [[n_out]] particles are outgoing.
 
 Distinct interactions are linked by their particles: for each
 particle, we have the possibility of links to corresponding particles
 in other interactions.  Furthermore, for bookkeeping purposes we have
 a self-link array [[relations]] where the parent-child relations are
 kept, and a flag array [[resonant]] which is set for an intermediate
 resonance.
 
 Each momentum is associated with masks for flavor, color, and
 helicity.  If a mask entry is set, the associated quantum number is to
 be ignored for that particle.  If any mask has changed, the flag
 [[update]] is set.
 
 We can have particle pairs locked together.  If this is the case, the
 corresponding mask entries are bound to be equal.  This is useful for
 particles that go through the interaction.
 
 The interaction tag serves bookkeeping purposes.  In particular, it
 identifies links in printout.
 <<Interactions: public>>=
   public :: interaction_t
 <<Interactions: types>>=
   type :: interaction_t
      private
      integer :: tag = 0
      type(state_matrix_t) :: state_matrix
      integer :: n_in = 0
      integer :: n_vir = 0
      integer :: n_out = 0
      integer :: n_tot = 0
      logical, dimension(:), allocatable :: p_is_known
      type(vector4_t), dimension(:), allocatable :: p
      type(external_link_t), dimension(:), allocatable :: source
      type(internal_link_list_t), dimension(:), allocatable :: parents
      type(internal_link_list_t), dimension(:), allocatable :: children
      logical, dimension(:), allocatable :: resonant
      type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
      integer, dimension(:), allocatable :: hel_lock
      logical :: update_state_matrix = .false.
      logical :: update_values = .false.
      type(qn_index_map_t) :: qn_index
    contains
    <<Interactions: interaction: TBP>>
   end type interaction_t
 
 @ %def interaction_particle_p interaction_t
 @ Initialize the particle array with a fixed size.  The first [[n_in]]
 particles are incoming, the rest outgoing.  Masks are optional.  There
 is also an optional tag.  The interaction still needs fixing the
 values, but that is to be done after all branches have been added.
 
 Interaction tags are assigned consecutively, using a [[save]]d
 variable local to this procedure.  If desired, we can provide a seed
 for the interaction tags.  Such a seed should be positive.  The
 default seed is one. [[tag=0]] indicates an empty interaction.
 
 If [[set_relations]] is set and true, we establish parent-child
 relations for all incoming and outgoing particles.  Virtual particles
 are skipped; this option is normally used only for interations without
 virtual particles.
 <<Interactions: interaction: TBP>>=
   procedure :: basic_init => interaction_init
 <<Interactions: procedures>>=
   subroutine interaction_init &
        (int, n_in, n_vir, n_out, &
         tag, resonant, mask, hel_lock, set_relations, store_values)
     class(interaction_t), intent(out) :: int
     integer, intent(in) :: n_in, n_vir, n_out
     integer, intent(in), optional :: tag
     logical, dimension(:), intent(in), optional :: resonant
     type(quantum_numbers_mask_t), dimension(:), intent(in), optional :: mask
     integer, dimension(:), intent(in), optional :: hel_lock
     logical, intent(in), optional :: set_relations, store_values
     logical :: set_rel
     integer :: i, j
     set_rel = .false.;  if (present (set_relations))  set_rel = set_relations
     call interaction_set_tag (int, tag)
     call int%state_matrix%init (store_values)
     int%n_in = n_in
     int%n_vir = n_vir
     int%n_out = n_out
     int%n_tot = n_in + n_vir + n_out
     allocate (int%p_is_known (int%n_tot))
     int%p_is_known = .false.
     allocate (int%p (int%n_tot))
     allocate (int%source (int%n_tot))
     allocate (int%parents (int%n_tot))
     allocate (int%children (int%n_tot))
     allocate (int%resonant (int%n_tot))
     if (present (resonant)) then
        int%resonant = resonant
     else
        int%resonant = .false.
     end if
     allocate (int%mask (int%n_tot))
     allocate (int%hel_lock (int%n_tot))
     if (present (mask)) then
        int%mask = mask
     end if
     if (present (hel_lock)) then
        int%hel_lock = hel_lock
     else
        int%hel_lock = 0
     end if
     int%update_state_matrix = .false.
     int%update_values = .true.
     if (set_rel) then
        do i = 1, n_in
           do j = 1, n_out
              call int%relate (i, n_in + j)
           end do
        end do
     end if
   end subroutine interaction_init
 
 @ %def interaction_init
 @
 <<Interactions: interaction: TBP>>=
   generic :: init_qn_index => init_qn_index_trivial, &
                               init_qn_index_involved, &
                               init_qn_index_sf
   procedure :: init_qn_index_trivial => interaction_init_qn_index_trivial
   procedure :: init_qn_index_involved => interaction_init_qn_index_involved
   procedure :: init_qn_index_sf => interaction_init_qn_index_sf
 <<Interactions: procedures>>=
   subroutine interaction_init_qn_index_trivial (int)
     class(interaction_t), intent(inout) :: int
     call int%qn_index%init (int)
   end subroutine interaction_init_qn_index_trivial
 
   subroutine interaction_init_qn_index_involved (int, qn_flv, n_sub, qn_hel)
     class(interaction_t), intent(inout) :: int
     type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_flv
     integer, intent(in) :: n_sub
     type(quantum_numbers_t), dimension(:, :), intent(in), optional :: qn_hel
     call int%qn_index%init (int, qn_flv, n_sub, qn_hel)
   end subroutine interaction_init_qn_index_involved
 
   subroutine interaction_init_qn_index_sf (int, qn_flv, n_flv_born, n_flv_real)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: n_flv_born, n_flv_real
     type(quantum_numbers_t), dimension(:,:), intent(in) :: qn_flv
     call int%qn_index%init (int, qn_flv, n_flv_born, n_flv_real)
   end subroutine interaction_init_qn_index_sf
 
 @ %def interaction_init_qn_index_trivial
 @ %def interaction_init_qn_index
 @ %def interaction_init_qn_index_sf
 @
 <<Interactions: interaction: TBP>>=
   procedure :: set_qn_index_helicity_flip => interaction_set_qn_index_helicity_flip
 <<Interactions: procedures>>=
   subroutine interaction_set_qn_index_helicity_flip (int, yorn)
     class(interaction_t), intent(inout) :: int
     logical, intent(in) :: yorn
     call int%qn_index%set_helicity_flip (yorn)
   end subroutine interaction_set_qn_index_helicity_flip
 
 @ %def interaction_get_qn_index_n_flv
 @
 <<Interactions: interaction: TBP>>=
   procedure :: get_qn_index => interaction_get_qn_index
   procedure :: get_sf_qn_index_born => interaction_get_sf_qn_index_born
   procedure :: get_sf_qn_index_real => interaction_get_sf_qn_index_real
 <<Interactions: procedures>>=
   integer function interaction_get_qn_index (int, i_flv, i_hel, i_sub) result (index)
     class(interaction_t), intent(in) :: int
     integer, intent(in) :: i_flv
     integer, intent(in), optional :: i_hel
     integer, intent(in), optional :: i_sub
     index = int%qn_index%get_index (i_flv, i_hel, i_sub)
   end function interaction_get_qn_index
 
   integer function interaction_get_sf_qn_index_born (int, i_born, i_sub) result (index)
     class(interaction_t), intent(in) :: int
     integer, intent(in) :: i_born, i_sub
     index = int%qn_index%get_sf_index_born (i_born, i_sub)
   end function interaction_get_sf_qn_index_born
 
   integer function interaction_get_sf_qn_index_real (int, i_real, i_sub) result (index)
     class(interaction_t), intent(in) :: int
     integer, intent(in) :: i_real, i_sub
     index = int%qn_index%get_sf_index_real (i_real, i_sub)
   end function interaction_get_sf_qn_index_real
 
 @ %def interaction_get_qn_index
 @ %def interaction_get_sf_qn_index_born
 @ %def interaction_get_sf_qn_index_real
 @
 <<Interactions: interaction: TBP>>=
   procedure :: get_qn_index_n_flv => interaction_get_qn_index_n_flv
   procedure :: get_qn_index_n_hel => interaction_get_qn_index_n_hel
   procedure :: get_qn_index_n_sub => interaction_get_qn_index_n_sub
 <<Interactions: procedures>>=
   integer function interaction_get_qn_index_n_flv (int) result (index)
     class(interaction_t), intent(in) :: int
     index = int%qn_index%get_n_flv ()
   end function interaction_get_qn_index_n_flv
 
   integer function interaction_get_qn_index_n_hel (int) result (index)
     class(interaction_t), intent(in) :: int
     index = int%qn_index%get_n_hel ()
   end function interaction_get_qn_index_n_hel
 
   integer function interaction_get_qn_index_n_sub (int) result (index)
     class(interaction_t), intent(in) :: int
     index = int%qn_index%get_n_sub ()
   end function interaction_get_qn_index_n_sub
 
 @ %def interaction_get_qn_index_n_flv
 @ %def interaction_get_qn_index_n_hel
 @ %def interaction_get_qn_index_n_sub
 @ Set or create a unique tag for the interaction.  Without
 interaction, reset the tag counter.
 <<Interactions: procedures>>=
   subroutine interaction_set_tag (int, tag)
     type(interaction_t), intent(inout), optional :: int
     integer, intent(in), optional :: tag
     integer, save :: stored_tag = 1
     if (present (int)) then
        if (present (tag)) then
           int%tag = tag
        else
           int%tag = stored_tag
           stored_tag = stored_tag + 1
        end if
     else if (present (tag)) then
        stored_tag = tag
     else
        stored_tag = 1
     end if
   end subroutine interaction_set_tag
 
 @ %def interaction_set_tag
 @ The public interface for the previous procedure only covers the
 reset functionality.
 <<Interactions: public>>=
   public :: reset_interaction_counter
 <<Interactions: procedures>>=
   subroutine reset_interaction_counter (tag)
     integer, intent(in), optional :: tag
     call interaction_set_tag (tag=tag)
   end subroutine reset_interaction_counter
 
 @ %def reset_interaction_counter
 @ Finalizer: The state-matrix object contains pointers.
 <<Interactions: interaction: TBP>>=
   procedure :: final => interaction_final
 <<Interactions: procedures>>=
   subroutine interaction_final (object)
     class(interaction_t), intent(inout) :: object
     call object%state_matrix%final ()
   end subroutine interaction_final
 
 @ %def interaction_final
 @ Output.  The [[verbose]] option refers to the state matrix output.
 <<Interactions: interaction: TBP>>=
   procedure :: basic_write => interaction_write
 <<Interactions: procedures>>=
   subroutine interaction_write &
        (int, unit, verbose, show_momentum_sum, show_mass, show_state, &
        col_verbose, testflag)
     class(interaction_t), intent(in) :: int
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
     logical, intent(in), optional :: show_state, col_verbose, testflag
     integer :: u
     integer :: i, index_link
     type(interaction_t), pointer :: int_link
     logical :: show_st
     u = given_output_unit (unit);  if (u < 0)  return
     show_st = .true.;  if (present (show_state))  show_st = show_state
     if (int%tag /= 0) then
        write (u, "(1x,A,I0)")  "Interaction: ", int%tag
        do i = 1, int%n_tot
           if (i == 1 .and. int%n_in > 0) then
              write (u, "(1x,A)") "Incoming:"
           else if (i == int%n_in + 1 .and. int%n_vir > 0) then
              write (u, "(1x,A)") "Virtual:"
           else if (i == int%n_in + int%n_vir + 1 .and. int%n_out > 0) then
              write (u, "(1x,A)") "Outgoing:"
           end if
           write (u, "(1x,A,1x,I0)", advance="no") "Particle", i
           if (allocated (int%resonant)) then
              if (int%resonant(i)) then
                 write (u, "(A)") "[r]"
              else
                 write (u, *)
              end if
           else
              write (u, *)
           end if
           if (allocated (int%p)) then
              if (int%p_is_known(i)) then
                 call vector4_write (int%p(i), u, show_mass, testflag)
              else
                 write (u, "(A)")  "  [momentum undefined]"
              end if
           else
              write (u, "(A)") "  [momentum not allocated]"
           end if
           if (allocated (int%mask)) then
              write (u, "(1x,A)", advance="no")  "mask [fch] = "
              call int%mask(i)%write (u)
              write (u, *)
           end if
           if (int%parents(i)%has_entries () &
                .or. int%children(i)%has_entries ()) then
              write (u, "(1x,A)", advance="no") "internal links:"
              call int%parents(i)%write (u)
              if (int%parents(i)%has_entries ()) &
                   write (u, "(1x,A)", advance="no") "=>"
              write (u, "(1x,A)", advance="no") "X"
              if (int%children(i)%has_entries ()) &
                   write (u, "(1x,A)", advance="no") "=>"
              call int%children(i)%write (u)
              write (u, *)
           end if
           if (allocated (int%hel_lock)) then
              if (int%hel_lock(i) /= 0) then
                 write (u, "(1x,A,1x,I0)")  "helicity lock:", int%hel_lock(i)
              end if
           end if
           if (external_link_is_set (int%source(i))) then
              write (u, "(1x,A)", advance="no") "source:"
              int_link => external_link_get_ptr (int%source(i))
              index_link = external_link_get_index (int%source(i))
              write (u, "(1x,'(',I0,')',I0)", advance="no") &
                   int_link%tag, index_link
              write (u, *)
           end if
        end do
        if (present (show_momentum_sum)) then
           if (allocated (int%p) .and. show_momentum_sum) then
              write (u, "(1x,A)") "Incoming particles (sum):"
              call vector4_write &
                   (sum (int%p(1 : int%n_in)), u, show_mass = show_mass)
              write (u, "(1x,A)") "Outgoing particles (sum):"
              call vector4_write &
                   (sum (int%p(int%n_in + int%n_vir + 1 : )), &
                    u, show_mass = show_mass)
              write (u, *)
           end if
        end if
        if (show_st) then
           call int%write_state_matrix (write_value_list = verbose, &
              verbose = verbose, unit = unit, col_verbose = col_verbose, &
              testflag = testflag)
        end if
     else
        write (u, "(1x,A)") "Interaction: [empty]"
     end if
   end subroutine interaction_write
 
 @ %def interaction_write
 @
 <<Interactions: interaction: TBP>>=
   procedure :: write_state_matrix => interaction_write_state_matrix
 <<Interactions: procedures>>=
   subroutine interaction_write_state_matrix (int, unit, write_value_list, &
      verbose, col_verbose, testflag)
     class(interaction_t), intent(in) :: int
     logical, intent(in), optional :: write_value_list, verbose, col_verbose
     logical, intent(in), optional :: testflag
     integer, intent(in), optional :: unit
     call int%state_matrix%write (write_value_list = verbose, &
        verbose = verbose, unit = unit, col_verbose = col_verbose, &
        testflag = testflag)
   end subroutine interaction_write_state_matrix
 
 @ %def interaction_write_state_matrix
 @ Reduce the [[state_matrix]] over the quantum mask. During the reduce procedure
 the iterator does not conserve the order of the matrix element respective their
 quantum numbers. Setting the [[keep_order]] results in a reorder state matrix
 with reintroduced matrix element indices.
 <<Interactions: interaction: TBP>>=
   procedure :: reduce_state_matrix => interaction_reduce_state_matrix
 <<Interactions: procedures>>=
   subroutine interaction_reduce_state_matrix (int, qn_mask, keep_order)
     class(interaction_t), intent(inout) :: int
     type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask
     logical, optional, intent(in) :: keep_order
     type(state_matrix_t) :: state
     logical :: opt_keep_order
     opt_keep_order = .false.
     if (present (keep_order)) opt_keep_order = keep_order
     call int%state_matrix%reduce (qn_mask, state, keep_me_index = keep_order)
     int%state_matrix = state
     if (opt_keep_order) then
        call int%state_matrix%reorder_me (state)
        int%state_matrix = state
     end if
   end subroutine interaction_reduce_state_matrix
 
 @ %def interaction_reduce_state_matrix
 @ Assignment: We implement this as a deep copy.  This applies, in
 particular, to the state-matrix and internal-link components.
 Furthermore, the new interaction acquires a new tag.
 <<Interactions: public>>=
   public :: assignment(=)
 <<Interactions: interfaces>>=
   interface assignment(=)
      module procedure interaction_assign
   end interface
 
 <<Interactions: procedures>>=
   subroutine interaction_assign (int_out, int_in)
     type(interaction_t), intent(out) :: int_out
     type(interaction_t), intent(in), target :: int_in
     call interaction_set_tag (int_out)
     int_out%state_matrix = int_in%state_matrix
     int_out%n_in  = int_in%n_in
     int_out%n_out = int_in%n_out
     int_out%n_vir = int_in%n_vir
     int_out%n_tot = int_in%n_tot
     if (allocated (int_in%p_is_known)) then
        allocate (int_out%p_is_known (size (int_in%p_is_known)))
        int_out%p_is_known = int_in%p_is_known
     end if
     if (allocated (int_in%p)) then
        allocate (int_out%p (size (int_in%p)))
        int_out%p = int_in%p
     end if
     if (allocated (int_in%source)) then
        allocate (int_out%source (size (int_in%source)))
        int_out%source = int_in%source
     end if
     if (allocated (int_in%parents)) then
        allocate (int_out%parents (size (int_in%parents)))
        int_out%parents = int_in%parents
     end if
     if (allocated (int_in%children)) then
        allocate (int_out%children (size (int_in%children)))
        int_out%children = int_in%children
     end if
     if (allocated (int_in%resonant)) then
        allocate (int_out%resonant (size (int_in%resonant)))
        int_out%resonant = int_in%resonant
     end if
     if (allocated (int_in%mask)) then
        allocate (int_out%mask (size (int_in%mask)))
        int_out%mask = int_in%mask
     end if
     if (allocated (int_in%hel_lock)) then
        allocate (int_out%hel_lock (size (int_in%hel_lock)))
        int_out%hel_lock = int_in%hel_lock
     end if
     int_out%update_state_matrix = int_in%update_state_matrix
     int_out%update_values = int_in%update_values
   end subroutine interaction_assign
 
 @ %def interaction_assign
 @
 \subsection{Methods inherited from the state matrix member}
 Until F2003 is standard, we cannot implement inheritance directly.
 Therefore, we need wrappers for ``inherited'' methods.
 
 Make a new branch in the state matrix if it does not yet exist.  This
 is not just a wrapper but it introduces the interaction mask: where a
 quantum number is masked, it is not transferred but set undefined.
 After this, the value array has to be updated.
 <<Interactions: interaction: TBP>>=
   procedure :: add_state => interaction_add_state
 <<Interactions: procedures>>=
   subroutine interaction_add_state &
        (int, qn, index, value, sum_values, counter_index, ignore_sub_for_qn, me_index)
     class(interaction_t), intent(inout) :: int
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     integer, intent(in), optional :: index
     complex(default), intent(in), optional :: value
     logical, intent(in), optional :: sum_values
     integer, intent(in), optional :: counter_index
     logical, intent(in), optional :: ignore_sub_for_qn
     integer, intent(out), optional :: me_index
     type(quantum_numbers_t), dimension(size(qn)) :: qn_tmp
     qn_tmp = qn
     call qn_tmp%undefine (int%mask)
     call int%state_matrix%add_state (qn_tmp, index, value, sum_values, &
          counter_index, ignore_sub_for_qn, me_index)
     int%update_values = .true.
   end subroutine interaction_add_state
 
 @ %def interaction_add_state
+@
+<<Interactions: interaction: TBP>>=
+  procedure :: set_duplicate_flv_zero => interaction_set_duplicate_flv_zero
+<<Interactions: procedures>>=
+  subroutine interaction_set_duplicate_flv_zero (int)
+    class(interaction_t), intent(inout) :: int
+    call int%state_matrix%set_duplicate_flv_zero ()
+  end subroutine interaction_set_duplicate_flv_zero
+
+@ %def interaction_set_duplicate_flv_zero
 @ Freeze the quantum state: First collapse the quantum state, i.e.,
 remove quantum numbers if any mask has changed, then fix the array of
 value pointers.
 <<Interactions: interaction: TBP>>=
   procedure :: freeze => interaction_freeze
 <<Interactions: procedures>>=
   subroutine interaction_freeze (int)
     class(interaction_t), intent(inout) :: int
     if (int%update_state_matrix) then
        call int%state_matrix%collapse (int%mask)
        int%update_state_matrix = .false.
        int%update_values = .true.
     end if
     if (int%update_values) then
        call int%state_matrix%freeze ()
        int%update_values = .false.
     end if
   end subroutine interaction_freeze
 
 @ %def interaction_freeze
 @ Return true if the state matrix is empty.
 <<Interactions: interaction: TBP>>=
   procedure :: is_empty => interaction_is_empty
 <<Interactions: procedures>>=
   pure function interaction_is_empty (int) result (flag)
     logical :: flag
     class(interaction_t), intent(in) :: int
     flag = int%state_matrix%is_empty ()
   end function interaction_is_empty
 
 @ %def interaction_is_empty
 @ Get the number of values stored in the state matrix:
 <<Interactions: interaction: TBP>>=
   procedure :: get_n_matrix_elements => &
        interaction_get_n_matrix_elements
 <<Interactions: procedures>>=
   pure function interaction_get_n_matrix_elements (int) result (n)
     integer :: n
     class(interaction_t), intent(in) :: int
     n = int%state_matrix%get_n_matrix_elements ()
   end function interaction_get_n_matrix_elements
 
 @ %def interaction_get_n_matrix_elements
 @
 <<Interactions: interaction: TBP>>=
   procedure :: get_state_depth => interaction_get_state_depth
 <<Interactions: procedures>>=
   function interaction_get_state_depth (int) result (n)
     integer :: n
     class(interaction_t), intent(in) :: int
     n = int%state_matrix%get_depth ()
   end function interaction_get_state_depth
 
 @ %def interaction_get_state_depth
 @
 <<Interactions: interaction: TBP>>=
   procedure :: get_n_in_helicities => interaction_get_n_in_helicities
 <<Interactions: procedures>>=
   function interaction_get_n_in_helicities (int) result (n_hel)
     integer :: n_hel
     class(interaction_t), intent(in) :: int
     type(interaction_t) :: int_copy
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     integer :: i
     allocate (qn_mask (int%n_tot))
     do i = 1, int%n_tot
        if (i <= int%n_in) then
           call qn_mask(i)%init (.true., .true., .false.)
        else
           call qn_mask(i)%init (.true., .true., .true.)
        end if
     end do
     int_copy = int
     call int_copy%set_mask (qn_mask)
     call int_copy%freeze ()
     allocate (qn (int_copy%state_matrix%get_n_matrix_elements (), &
          int_copy%state_matrix%get_depth ()))
     qn = int_copy%get_quantum_numbers ()
     n_hel = 0
     do i = 1, size (qn, dim=1)
        if (all (qn(:, i)%get_subtraction_index () == 0)) n_hel = n_hel + 1
     end do
     call int_copy%final ()
     deallocate (qn_mask)
     deallocate (qn)
   end function interaction_get_n_in_helicities
 
 @ %def interaction_get_n_in_helicities
 @ Get the size of the [[me]]-array of the associated state matrix
 for debugging purposes
 <<Interactions: interaction: TBP>>=
   procedure :: get_me_size => interaction_get_me_size
 <<Interactions: procedures>>=
   pure function interaction_get_me_size (int) result (n)
     integer :: n
     class(interaction_t), intent(in) :: int
     n = int%state_matrix%get_me_size ()
   end function interaction_get_me_size
 
 @ %def interaction_get_me_size
 @ Get the norm of the state matrix (if the norm has been taken out, otherwise
 this would be unity).
 <<Interactions: interaction: TBP>>=
   procedure :: get_norm => interaction_get_norm
 <<Interactions: procedures>>=
   pure function interaction_get_norm (int) result (norm)
     real(default) :: norm
     class(interaction_t), intent(in) :: int
     norm = int%state_matrix%get_norm ()
   end function interaction_get_norm
 
 @ %def interaction_get_norm
 @
 <<Interactions: interaction: TBP>>=
   procedure :: get_n_sub => interaction_get_n_sub
 <<Interactions: procedures>>=
   function interaction_get_n_sub (int) result (n_sub)
     integer :: n_sub
     class(interaction_t), intent(in) :: int
     n_sub = int%state_matrix%get_n_sub ()
   end function interaction_get_n_sub
 
 @ %def interaction_get_n_sub
 @ Get the quantum number array that corresponds to a given index.
 <<Interactions: interaction: TBP>>=
   generic :: get_quantum_numbers => get_quantum_numbers_single, &
                                     get_quantum_numbers_all, &
                                     get_quantum_numbers_all_qn_mask
   procedure :: get_quantum_numbers_single => &
      interaction_get_quantum_numbers_single
   procedure :: get_quantum_numbers_all => &
      interaction_get_quantum_numbers_all
   procedure :: get_quantum_numbers_all_qn_mask => &
      interaction_get_quantum_numbers_all_qn_mask
 <<Interactions: procedures>>=
   function interaction_get_quantum_numbers_single (int, i, by_me_index) result (qn)
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     class(interaction_t), intent(in), target :: int
     integer, intent(in) :: i
     logical, intent(in), optional :: by_me_index
     allocate (qn (int%state_matrix%get_depth ()))
     qn = int%state_matrix%get_quantum_number (i, by_me_index)
   end function interaction_get_quantum_numbers_single
 
   function interaction_get_quantum_numbers_all (int) result (qn)
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     class(interaction_t), intent(in), target :: int
     integer :: i
 <<Interactions: get quantum numbers all>>
 <<Interactions: get quantum numbers all>>=
     allocate (qn (int%state_matrix%get_depth(), &
          int%state_matrix%get_n_matrix_elements ()))
     do i = 1, int%state_matrix%get_n_matrix_elements ()
        qn (:, i) = int%state_matrix%get_quantum_number (i)
     end do
 <<Interactions: procedures>>=
   end function interaction_get_quantum_numbers_all
 
   function interaction_get_quantum_numbers_all_qn_mask (int, qn_mask) &
      result (qn)
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     class(interaction_t), intent(in) :: int
     type(quantum_numbers_mask_t), intent(in) :: qn_mask
     integer :: n_redundant, n_all, n_me
     integer :: i
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all
 <<Interactions: get quantum numbers all qn mask>>
 <<Interactions: get quantum numbers all qn mask>>=
     call int%state_matrix%get_quantum_numbers (qn_all)
     n_redundant = count (qn_all%are_redundant (qn_mask))
     n_all = size (qn_all)
     !!! Number of matrix elements = survivors / n_particles
     n_me = (n_all - n_redundant) / int%state_matrix%get_depth ()
     allocate (qn (int%state_matrix%get_depth(), n_me))
     do i = 1, n_me
        if (.not. any (qn_all(i, :)%are_redundant (qn_mask))) &
           qn (:, i) = qn_all (i, :)
     end do
 <<Interactions: procedures>>=
   end function interaction_get_quantum_numbers_all_qn_mask
 
 @ %def interaction_get_quantum_numbers_single
 @ %def interaction_get_quantum_numbers_all
 @ %def interaction_get_quantum_numbers_all_qn_mask
 @
 @
 <<Interactions: interaction: TBP>>=
   procedure :: get_quantum_numbers_all_sub => interaction_get_quantum_numbers_all_sub
 <<Interactions: procedures>>=
   subroutine interaction_get_quantum_numbers_all_sub (int, qn)
     class(interaction_t), intent(in) :: int
     type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn
     integer :: i
 <<Interactions: get quantum numbers all>>
   end subroutine interaction_get_quantum_numbers_all_sub
 
 @ %def interaction_get_quantum_numbers_all
 @
 <<Interactions: interaction: TBP>>=
   procedure :: get_flavors => interaction_get_flavors
 <<Interactions: procedures>>=
   subroutine interaction_get_flavors (int, only_elementary, qn_mask, flv)
     class(interaction_t), intent(in), target :: int
     logical, intent(in) :: only_elementary
     type(quantum_numbers_mask_t), intent(in), dimension(:), optional :: qn_mask
     integer, intent(out), dimension(:,:), allocatable :: flv
     call int%state_matrix%get_flavors (only_elementary, qn_mask, flv)
   end subroutine interaction_get_flavors
 
 @ %def interaction_get_flavors
 @
 <<Interactions: interaction: TBP>>=
   procedure :: get_quantum_numbers_mask => interaction_get_quantum_numbers_mask
 <<Interactions: procedures>>=
   subroutine interaction_get_quantum_numbers_mask (int, qn_mask, qn)
     class(interaction_t), intent(in) :: int
     type(quantum_numbers_mask_t), intent(in) :: qn_mask
     type(quantum_numbers_t), dimension(:,:), allocatable, intent(out) :: qn
     integer :: n_redundant, n_all, n_me
     integer :: i
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn_all
 <<Interactions: get quantum numbers all qn mask>>
   end subroutine interaction_get_quantum_numbers_mask
 
 @ %def interaction_get_quantum_numbers_mask
 @ Get the matrix element that corresponds to a set of quantum
 numbers, a given index, or return the whole array.
 <<Interactions: interaction: TBP>>=
   generic :: get_matrix_element => get_matrix_element_single
   generic :: get_matrix_element => get_matrix_element_array
   procedure :: get_matrix_element_single => &
      interaction_get_matrix_element_single
   procedure :: get_matrix_element_array => &
      interaction_get_matrix_element_array
 <<Interactions: procedures>>=
   elemental function interaction_get_matrix_element_single (int, i) result (me)
     complex(default) :: me
     class(interaction_t), intent(in) :: int
     integer, intent(in) :: i
     me = int%state_matrix%get_matrix_element (i)
   end function interaction_get_matrix_element_single
 
 @ %def interaction_get_matrix_element_single
 <<Interactions: procedures>>=
   function interaction_get_matrix_element_array (int) result (me)
     complex(default), dimension(:), allocatable :: me
     class(interaction_t), intent(in) :: int
     allocate (me (int%get_n_matrix_elements ()))
     me = int%state_matrix%get_matrix_element ()
   end function interaction_get_matrix_element_array
 
 @ %def interaction_get_matrix_element_array
 @ Set the complex value(s) stored in the quantum state.
 <<Interactions: interaction: TBP>>=
   generic :: set_matrix_element => interaction_set_matrix_element_qn, &
        interaction_set_matrix_element_all, &
        interaction_set_matrix_element_array, &
        interaction_set_matrix_element_single, &
        interaction_set_matrix_element_clone
   procedure :: interaction_set_matrix_element_qn
   procedure :: interaction_set_matrix_element_all
   procedure :: interaction_set_matrix_element_array
   procedure :: interaction_set_matrix_element_single
   procedure :: interaction_set_matrix_element_clone
 @ %def interaction_set_matrix_element
 @ Indirect access via the quantum number array:
 <<Interactions: procedures>>=
   subroutine interaction_set_matrix_element_qn (int, qn, val)
     class(interaction_t), intent(inout) :: int
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     complex(default), intent(in) :: val
     call int%state_matrix%set_matrix_element (qn, val)
   end subroutine interaction_set_matrix_element_qn
 
 @ %def interaction_set_matrix_element
 @ Set all entries of the matrix-element array to a given value.
 <<Interactions: procedures>>=
   subroutine interaction_set_matrix_element_all (int, value)
     class(interaction_t), intent(inout) :: int
     complex(default), intent(in) :: value
     call int%state_matrix%set_matrix_element (value)
   end subroutine interaction_set_matrix_element_all
 
 @ %def interaction_set_matrix_element_all
 @ Set the matrix-element array directly.
 <<Interactions: procedures>>=
   subroutine interaction_set_matrix_element_array (int, value, range)
     class(interaction_t), intent(inout) :: int
     complex(default), intent(in), dimension(:) :: value
     integer, intent(in), dimension(:), optional :: range
     call int%state_matrix%set_matrix_element (value, range)
   end subroutine interaction_set_matrix_element_array
 
   pure subroutine interaction_set_matrix_element_single (int, i, value)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     complex(default), intent(in) :: value
     call int%state_matrix%set_matrix_element (i, value)
   end subroutine interaction_set_matrix_element_single
 
 @ %def interaction_set_matrix_element_array
 @ %def interaction_set_matrix_element_single
 @ Clone from another (matching) interaction.
 <<Interactions: procedures>>=
   subroutine interaction_set_matrix_element_clone (int, int1)
     class(interaction_t), intent(inout) :: int
     class(interaction_t), intent(in) :: int1
     call int%state_matrix%set_matrix_element (int1%state_matrix)
   end subroutine interaction_set_matrix_element_clone
 
 @ %def interaction_set_matrix_element_clone
 @
 <<Interactions: interaction: TBP>>=
   procedure :: set_only_matrix_element => interaction_set_only_matrix_element
 <<Interactions: procedures>>=
   subroutine interaction_set_only_matrix_element (int, i, value)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     complex(default), intent(in) :: value
     call int%set_matrix_element (cmplx (0, 0, default))
     call int%set_matrix_element (i, value)
   end subroutine interaction_set_only_matrix_element
 
 @ %def interaction_set_only_matrix_element
 @
 <<Interactions: interaction: TBP>>=
   procedure :: add_to_matrix_element => interaction_add_to_matrix_element
 <<Interactions: procedures>>=
   subroutine interaction_add_to_matrix_element (int, qn, value, match_only_flavor)
     class(interaction_t), intent(inout) :: int
     type(quantum_numbers_t), dimension(:), intent(in) :: qn
     complex(default), intent(in) :: value
     logical, intent(in), optional :: match_only_flavor
     call int%state_matrix%add_to_matrix_element (qn, value, match_only_flavor)
   end subroutine interaction_add_to_matrix_element
 
 @ %def interaction_add_to_matrix_element
 @ Get the indices of any diagonal matrix elements.
 <<Interactions: interaction: TBP>>=
   procedure :: get_diagonal_entries => interaction_get_diagonal_entries
 <<Interactions: procedures>>=
   subroutine interaction_get_diagonal_entries (int, i)
     class(interaction_t), intent(in) :: int
     integer, dimension(:), allocatable, intent(out) :: i
     call int%state_matrix%get_diagonal_entries (i)
   end subroutine interaction_get_diagonal_entries
 
 @ %def interaction_get_diagonal_entries
 @ Renormalize the state matrix by its trace, if nonzero.  The renormalization
 is reflected in the state-matrix norm.
 <<Interactions: interaction: TBP>>=
   procedure :: normalize_by_trace => interaction_normalize_by_trace
 <<Interactions: procedures>>=
   subroutine interaction_normalize_by_trace (int)
     class(interaction_t), intent(inout) :: int
     call int%state_matrix%normalize_by_trace ()
   end subroutine interaction_normalize_by_trace
 
 @ %def interaction_normalize_by_trace
 @ Analogous, but renormalize by maximal (absolute) value.
 <<Interactions: interaction: TBP>>=
   procedure :: normalize_by_max => interaction_normalize_by_max
 <<Interactions: procedures>>=
   subroutine interaction_normalize_by_max (int)
     class(interaction_t), intent(inout) :: int
     call int%state_matrix%normalize_by_max ()
   end subroutine interaction_normalize_by_max
 
 @ %def interaction_normalize_by_max
 @ Explicitly set the norm value (of the state matrix).
 <<Interactions: interaction: TBP>>=
   procedure :: set_norm => interaction_set_norm
 <<Interactions: procedures>>=
   subroutine interaction_set_norm (int, norm)
     class(interaction_t), intent(inout) :: int
     real(default), intent(in) :: norm
     call int%state_matrix%set_norm (norm)
   end subroutine interaction_set_norm
 
 @ %def interaction_set_norm
 @
 <<Interactions: interaction: TBP>>=
   procedure :: set_state_matrix => interaction_set_state_matrix
 <<Interactions: procedures>>=
   subroutine interaction_set_state_matrix (int, state)
     class(interaction_t), intent(inout) :: int
     type(state_matrix_t), intent(in) :: state
     int%state_matrix = state
   end subroutine interaction_set_state_matrix
 
 @ %def interaction_set_state_matrix
 @ Return the maximum absolute value of color indices.
 <<Interactions: interaction: TBP>>=
   procedure :: get_max_color_value => &
        interaction_get_max_color_value
 <<Interactions: procedures>>=
   function interaction_get_max_color_value (int) result (cmax)
     class(interaction_t), intent(in) :: int
     integer :: cmax
     cmax = int%state_matrix%get_max_color_value ()
   end function interaction_get_max_color_value
 
 @ %def interaction_get_max_color_value
 @ Factorize the state matrix into single-particle state matrices, the
 branch selection depending on a (random) value between 0 and 1;
 optionally also return a correlated state matrix.
 <<Interactions: interaction: TBP>>=
   procedure :: factorize => interaction_factorize
 <<Interactions: procedures>>=
   subroutine interaction_factorize &
        (int, mode, x, ok, single_state, correlated_state, qn_in)
     class(interaction_t), intent(in), target :: int
     integer, intent(in) :: mode
     real(default), intent(in) :: x
     logical, intent(out) :: ok
     type(state_matrix_t), &
          dimension(:), allocatable, intent(out) :: single_state
     type(state_matrix_t), intent(out), optional :: correlated_state
     type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_in
     call int%state_matrix%factorize &
          (mode, x, ok, single_state, correlated_state, qn_in)
   end subroutine interaction_factorize
 
 @ %def interaction_factorize
 @ Sum all matrix element values
 <<Interactions: interaction: TBP>>=
   procedure :: sum => interaction_sum
 <<Interactions: procedures>>=
   function interaction_sum (int) result (value)
     class(interaction_t), intent(in) :: int
     complex(default) :: value
     value = int%state_matrix%sum ()
   end function interaction_sum
 
 @ %def interaction_sum
 @ Append new states which are color-contracted versions of the
 existing states.  The matrix element index of each color contraction
 coincides with the index of its origin, so no new matrix elements are
 generated.  After this operation, no [[freeze]] must be performed
 anymore.
 <<Interactions: interaction: TBP>>=
   procedure :: add_color_contractions => &
        interaction_add_color_contractions
 <<Interactions: procedures>>=
   subroutine interaction_add_color_contractions (int)
     class(interaction_t), intent(inout) :: int
     call int%state_matrix%add_color_contractions ()
   end subroutine interaction_add_color_contractions
 
 @ %def interaction_add_color_contractions
 @ Multiply matrix elements from two interactions.  Choose the elements
 as given by the integer index arrays, multiply them and store the sum
 of products in the indicated matrix element.  The suffixes mean:
 c=conjugate first factor; f=include weighting factor.
 <<Interactions: interaction: TBP>>=
   procedure :: evaluate_product => interaction_evaluate_product
   procedure :: evaluate_product_cf => interaction_evaluate_product_cf
   procedure :: evaluate_square_c => interaction_evaluate_square_c
   procedure :: evaluate_sum => interaction_evaluate_sum
   procedure :: evaluate_me_sum => interaction_evaluate_me_sum
 <<Interactions: procedures>>=
   pure subroutine interaction_evaluate_product &
        (int, i, int1, int2, index1, index2)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     type(interaction_t), intent(in) :: int1, int2
     integer, dimension(:), intent(in) :: index1, index2
     call int%state_matrix%evaluate_product &
          (i, int1%state_matrix, int2%state_matrix, &
           index1, index2)
   end subroutine interaction_evaluate_product
 
   pure subroutine interaction_evaluate_product_cf &
        (int, i, int1, int2, index1, index2, factor)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     type(interaction_t), intent(in) :: int1, int2
     integer, dimension(:), intent(in) :: index1, index2
     complex(default), dimension(:), intent(in) :: factor
     call int%state_matrix%evaluate_product_cf &
          (i, int1%state_matrix, int2%state_matrix, &
           index1, index2, factor)
   end subroutine interaction_evaluate_product_cf
 
   pure subroutine interaction_evaluate_square_c (int, i, int1, index1)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     type(interaction_t), intent(in) :: int1
     integer, dimension(:), intent(in) :: index1
     call int%state_matrix%evaluate_square_c (i, int1%state_matrix, index1)
   end subroutine interaction_evaluate_square_c
 
   pure subroutine interaction_evaluate_sum (int, i, int1, index1)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     type(interaction_t), intent(in) :: int1
     integer, dimension(:), intent(in) :: index1
     call int%state_matrix%evaluate_sum (i, int1%state_matrix, index1)
   end subroutine interaction_evaluate_sum
 
   pure subroutine interaction_evaluate_me_sum (int, i, int1, index1)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     type(interaction_t), intent(in) :: int1
     integer, dimension(:), intent(in) :: index1
     call int%state_matrix%evaluate_me_sum (i, int1%state_matrix, index1)
   end subroutine interaction_evaluate_me_sum
 
 @ %def interaction_evaluate_product
 @ %def interaction_evaluate_product_cf
 @ %def interaction_evaluate_square_c
 @ %def interaction_evaluate_sum
 @ %def interaction_evaluate_me_sum
 @ Tag quantum numbers of the state matrix as part of the hard process, according
 to the indices specified in [[tag]]. If no [[tag]] is given, all quantum numbers are
 tagged as part of the hard process.
 <<Interactions: interaction: TBP>>=
   procedure :: tag_hard_process => interaction_tag_hard_process
 <<Interactions: procedures>>=
   subroutine interaction_tag_hard_process (int, tag)
     class(interaction_t), intent(inout) :: int
     integer, dimension(:), intent(in), optional :: tag
     type(state_matrix_t) :: state
     call int%state_matrix%tag_hard_process (state, tag)
     call int%state_matrix%final ()
     int%state_matrix = state
   end subroutine interaction_tag_hard_process
 
 @ %def interaction_tag_hard_process
 @ Modify hard-interaction flags at the specified particle-position, in-place.
 <<Interactions: interaction: TBP>>=
   procedure :: retag_hard_process => interaction_retag_hard_process
 <<Interactions: procedures>>=
   subroutine interaction_retag_hard_process (int, i, hard)
     class(interaction_t), intent(inout), target :: int
     integer, intent(in) :: i
     logical, intent(in) :: hard
     type(state_iterator_t) :: it
     call it%init (int%get_state_matrix_ptr ())
     do while (it%is_valid ())
        call it%retag_hard_process (i, hard)
        call it%advance ()
     end do
   end subroutine interaction_retag_hard_process
-  
+
 @ %def interaction_retag_hard_process
 @
 \subsection{Accessing contents}
 Return the integer tag.
 <<Interactions: interaction: TBP>>=
   procedure :: get_tag => interaction_get_tag
 <<Interactions: procedures>>=
   function interaction_get_tag (int) result (tag)
     class(interaction_t), intent(in) :: int
     integer :: tag
     tag = int%tag
   end function interaction_get_tag
 
 @ %def interaction_get_tag
 @ Return the number of particles.
 <<Interactions: interaction: TBP>>=
   procedure :: get_n_tot => interaction_get_n_tot
   procedure :: get_n_in => interaction_get_n_in
   procedure :: get_n_vir => interaction_get_n_vir
   procedure :: get_n_out => interaction_get_n_out
 <<Interactions: procedures>>=
   pure function interaction_get_n_tot (object) result (n_tot)
     class(interaction_t), intent(in) :: object
     integer :: n_tot
     n_tot = object%n_tot
   end function interaction_get_n_tot
 
   pure function interaction_get_n_in (object) result (n_in)
     class(interaction_t), intent(in) :: object
     integer :: n_in
     n_in = object%n_in
   end function interaction_get_n_in
 
   pure function interaction_get_n_vir (object) result (n_vir)
     class(interaction_t), intent(in) :: object
     integer :: n_vir
     n_vir = object%n_vir
   end function interaction_get_n_vir
 
   pure function interaction_get_n_out (object) result (n_out)
     class(interaction_t), intent(in) :: object
     integer :: n_out
     n_out = object%n_out
   end function interaction_get_n_out
 
 @ %def interaction_get_n_tot
 @ %def interaction_get_n_in interaction_get_n_vir interaction_get_n_out
 @ Return a momentum index.  The flags specify whether to keep/drop
 incoming, virtual, or outgoing momenta.  Check for illegal values.
 <<Interactions: procedures>>=
   function idx (int, i, outgoing)
     integer :: idx
     type(interaction_t), intent(in) :: int
     integer, intent(in) :: i
     logical, intent(in), optional :: outgoing
     logical :: in, vir, out
     if (present (outgoing)) then
        in  = .not. outgoing
        vir = .false.
        out = outgoing
     else
        in = .true.
        vir = .true.
        out = .true.
     end if
     idx = 0
     if (in) then
        if (vir) then
           if (out) then
              if (i <= int%n_tot)  idx = i
           else
              if (i <= int%n_in + int%n_vir)  idx = i
           end if
        else if (out) then
           if (i <= int%n_in) then
              idx = i
           else if (i <= int%n_in + int%n_out) then
              idx = int%n_vir + i
           end if
        else
           if (i <= int%n_in)  idx = i
        end if
     else if (vir) then
        if (out) then
           if (i <= int%n_vir + int%n_out)  idx = int%n_in + i
        else
           if (i <= int%n_vir)  idx = int%n_in + i
        end if
     else if (out) then
        if (i <= int%n_out)  idx = int%n_in + int%n_vir + i
     end if
     if (idx == 0) then
        call int%basic_write ()
        print *, i, in, vir, out
        call msg_bug (" Momentum index is out of range for this interaction")
     end if
   end function idx
 
 @ %def idx
 @ Return all or just a specific four-momentum.
 <<Interactions: interaction: TBP>>=
   generic :: get_momenta => get_momenta_all, get_momenta_idx
   procedure :: get_momentum => interaction_get_momentum
   procedure :: get_momenta_all => interaction_get_momenta_all
   procedure :: get_momenta_idx => interaction_get_momenta_idx
 <<Interactions: procedures>>=
   function interaction_get_momenta_all (int, outgoing) result (p)
     class(interaction_t), intent(in) :: int
     type(vector4_t), dimension(:), allocatable :: p
     logical, intent(in), optional :: outgoing
     integer :: i
     if (present (outgoing)) then
        if (outgoing) then
           allocate (p (int%n_out))
        else
           allocate (p (int%n_in))
        end if
     else
        allocate (p (int%n_tot))
     end if
     do i = 1, size (p)
        p(i) = int%p(idx (int, i, outgoing))
     end do
   end function interaction_get_momenta_all
 
   function interaction_get_momenta_idx (int, jj) result (p)
     class(interaction_t), intent(in) :: int
     type(vector4_t), dimension(:), allocatable :: p
     integer, dimension(:), intent(in) :: jj
     allocate (p (size (jj)))
     p = int%p(jj)
   end function interaction_get_momenta_idx
 
   function interaction_get_momentum (int, i, outgoing) result (p)
     class(interaction_t), intent(in) :: int
     type(vector4_t) :: p
     integer, intent(in) :: i
     logical, intent(in), optional :: outgoing
     p = int%p(idx (int, i, outgoing))
   end function interaction_get_momentum
 
 @ %def interaction_get_momenta interaction_get_momentum
 @ Return a shallow copy of the state matrix:
 <<Interactions: interaction: TBP>>=
   procedure :: get_state_matrix_ptr => &
        interaction_get_state_matrix_ptr
 <<Interactions: procedures>>=
   function interaction_get_state_matrix_ptr (int) result (state)
     class(interaction_t), intent(in), target :: int
     type(state_matrix_t), pointer :: state
     state => int%state_matrix
   end function interaction_get_state_matrix_ptr
 
 @ %def interaction_get_state_matrix_ptr
 @ Return the array of resonance flags
 <<Interactions: interaction: TBP>>=
   procedure :: get_resonance_flags => interaction_get_resonance_flags
 <<Interactions: procedures>>=
   function interaction_get_resonance_flags (int) result (resonant)
     class(interaction_t), intent(in) :: int
     logical, dimension(size(int%resonant)) :: resonant
     resonant = int%resonant
   end function interaction_get_resonance_flags
 
 @ %def interaction_get_resonance_flags
 @ Return the quantum-numbers mask (or part of it)
 <<Interactions: interaction: TBP>>=
   generic :: get_mask => get_mask_all, get_mask_slice
   procedure :: get_mask_all => interaction_get_mask_all
   procedure :: get_mask_slice => interaction_get_mask_slice
 <<Interactions: procedures>>=
   function interaction_get_mask_all (int) result (mask)
     class(interaction_t), intent(in) :: int
     type(quantum_numbers_mask_t), dimension(size(int%mask)) :: mask
     mask = int%mask
   end function interaction_get_mask_all
 
   function interaction_get_mask_slice (int, index) result (mask)
     class(interaction_t), intent(in) :: int
     integer, dimension(:), intent(in) :: index
     type(quantum_numbers_mask_t), dimension(size(index)) :: mask
     mask = int%mask(index)
   end function interaction_get_mask_slice
 
 @ %def interaction_get_mask
 @ Compute the invariant mass squared of the incoming particles (if any,
 otherwise outgoing).
 <<Interactions: public>>=
   public :: interaction_get_s
 <<Interactions: procedures>>=
   function interaction_get_s (int) result (s)
     real(default) :: s
     type(interaction_t), intent(in) :: int
     if (int%n_in /= 0) then
        s = sum (int%p(:int%n_in)) ** 2
     else
        s = sum (int%p(int%n_vir + 1 : )) ** 2
     end if
   end function interaction_get_s
 
 @ %def interaction_get_s
 @ Compute the Lorentz transformation that transforms the incoming
 particles from the center-of-mass frame to the lab frame where they
 are given.  If the c.m. mass squared is negative or zero, return the
 identity.
 <<Interactions: public>>=
   public :: interaction_get_cm_transformation
 <<Interactions: procedures>>=
   function interaction_get_cm_transformation (int) result (lt)
     type(lorentz_transformation_t) :: lt
     type(interaction_t), intent(in) :: int
     type(vector4_t) :: p_cm
     real(default) :: s
     if (int%n_in /= 0) then
        p_cm = sum (int%p(:int%n_in))
     else
        p_cm = sum (int%p(int%n_vir+1:))
     end if
     s = p_cm ** 2
     if (s > 0) then
        lt = boost (p_cm, sqrt (s))
     else
        lt = identity
     end if
   end function interaction_get_cm_transformation
 
 @ %def interaction_get_cm_transformation
 @ Return flavor, momentum, and position of the first outgoing
 unstable particle present in the interaction.  Note that we need not
 iterate through the state matrix; if there is an unstable particle, it
 will be present in all state-matrix entries.
 <<Interactions: public>>=
   public :: interaction_get_unstable_particle
 <<Interactions: procedures>>=
   subroutine interaction_get_unstable_particle (int, flv, p, i)
     type(interaction_t), intent(in), target :: int
     type(flavor_t), intent(out) :: flv
     type(vector4_t), intent(out) :: p
     integer, intent(out) :: i
     type(state_iterator_t) :: it
     type(flavor_t), dimension(int%n_tot) :: flv_array
     call it%init (int%state_matrix)
     flv_array = it%get_flavor ()
     do i = int%n_in + int%n_vir + 1, int%n_tot
        if (.not. flv_array(i)%is_stable ()) then
           flv = flv_array(i)
           p = int%p(i)
           return
        end if
     end do
   end subroutine interaction_get_unstable_particle
 
 @ %def interaction_get_unstable_particle
 @ Return the complete set of \emph{outgoing} flavors, assuming that
 the flavor quantum number is not suppressed.
 <<Interactions: public>>=
   public :: interaction_get_flv_out
 <<Interactions: procedures>>=
   subroutine interaction_get_flv_out (int, flv)
     type(interaction_t), intent(in), target :: int
     type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
     type(state_iterator_t) :: it
     type(flavor_t), dimension(:), allocatable :: flv_state
     integer :: n_in, n_vir, n_out, n_tot, n_state, i
     n_in = int%get_n_in ()
     n_vir = int%get_n_vir ()
     n_out = int%get_n_out ()
     n_tot = int%get_n_tot ()
     n_state = int%get_n_matrix_elements ()
     allocate (flv (n_out, n_state))
     allocate (flv_state (n_tot))
     i = 1
     call it%init (int%get_state_matrix_ptr ())
     do while (it%is_valid ())
        flv_state = it%get_flavor ()
        flv(:,i) = flv_state(n_in + n_vir + 1 : )
        i = i + 1
        call it%advance ()
     end do
   end subroutine interaction_get_flv_out
 
 @ %def interaction_get_flv_out
 @ Determine the flavor content of the interaction.  We analyze the
 state matrix for this, and we select the outgoing particles of the
 hard process only for the required mask, which indicates the particles
 that can appear in any order in a matching event record.
 
 We have to assume that any radiated particles (beam remnants) appear
 at the beginning of the particles marked as outgoing.
 <<Interactions: public>>=
   public :: interaction_get_flv_content
 <<Interactions: procedures>>=
   subroutine interaction_get_flv_content (int, state_flv, n_out_hard)
     type(interaction_t), intent(in), target :: int
     type(state_flv_content_t), intent(out) :: state_flv
     integer, intent(in) :: n_out_hard
     logical, dimension(:), allocatable :: mask
     integer :: n_tot
     n_tot = int%get_n_tot ()
     allocate (mask (n_tot), source = .false.)
     mask(n_tot-n_out_hard + 1 : ) = .true.
     call state_flv%fill (int%get_state_matrix_ptr (), mask)
   end subroutine interaction_get_flv_content
 
 @ %def interaction_get_flv_content
 @
 \subsection{Modifying contents}
 Set the quantum numbers mask.
 <<Interactions: interaction: TBP>>=
   procedure :: set_mask => interaction_set_mask
 <<Interactions: procedures>>=
   subroutine interaction_set_mask (int, mask)
     class(interaction_t), intent(inout) :: int
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: mask
     if (size (int%mask) /= size (mask)) &
        call msg_fatal ("Attempting to set mask with unfitting size!")
     int%mask = mask
     int%update_state_matrix = .true.
   end subroutine interaction_set_mask
 
 @ %def interaction_set_mask
 @ Merge a particular mask entry, respecting a possible helicity lock for this
 entry.  We apply an OR relation, which means that quantum numbers are
 summed over if either of the two masks requires it.
 <<Interactions: procedures>>=
   subroutine interaction_merge_mask_entry (int, i, mask)
     type(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     type(quantum_numbers_mask_t), intent(in) :: mask
     type(quantum_numbers_mask_t) :: mask_tmp
     integer :: ii
     ii = idx (int, i)
     if (int%mask(ii) .neqv. mask) then
        int%mask(ii) = int%mask(ii) .or. mask
        if (int%hel_lock(ii) /= 0) then
           call mask_tmp%assign (mask, helicity=.true.)
           int%mask(int%hel_lock(ii)) = int%mask(int%hel_lock(ii)) .or. mask_tmp
        end if
     end if
     int%update_state_matrix = .true.
   end subroutine interaction_merge_mask_entry
 
 @ %def interaction_merge_mask_entry
 @ Fill the momenta array, do not care about the quantum numbers of
 particles.
 <<Interactions: interaction: TBP>>=
   procedure :: reset_momenta => interaction_reset_momenta
   procedure :: set_momenta => interaction_set_momenta
   procedure :: set_momentum => interaction_set_momentum
 <<Interactions: procedures>>=
   subroutine interaction_reset_momenta (int)
     class(interaction_t), intent(inout) :: int
     int%p = vector4_null
     int%p_is_known = .true.
   end subroutine interaction_reset_momenta
 
   subroutine interaction_set_momenta (int, p, outgoing)
     class(interaction_t), intent(inout) :: int
     type(vector4_t), dimension(:), intent(in) :: p
     logical, intent(in), optional :: outgoing
     integer :: i, index
     do i = 1, size (p)
        index = idx (int, i, outgoing)
        int%p(index) = p(i)
        int%p_is_known(index) = .true.
     end do
   end subroutine interaction_set_momenta
 
   subroutine interaction_set_momentum (int, p, i, outgoing)
     class(interaction_t), intent(inout) :: int
     type(vector4_t), intent(in) :: p
     integer, intent(in) :: i
     logical, intent(in), optional :: outgoing
     integer :: index
     index = idx (int, i, outgoing)
     int%p(index) = p
     int%p_is_known(index) = .true.
   end subroutine interaction_set_momentum
 
 @ %def interaction_reset_momenta
 @ %def interaction_set_momenta interaction_set_momentum
 @ This more sophisticated version of setting values is used for
 structure functions, in particular if nontrivial flavor, color, and
 helicity may be present: set values selectively for the given flavors.
 If there is more than one flavor, scan the interaction and check for a
 matching flavor at the specified particle location.  If it matches,
 insert the value that corresponds to this flavor.
 <<Interactions: public>>=
   public :: interaction_set_flavored_values
 <<Interactions: procedures>>=
   subroutine interaction_set_flavored_values (int, value, flv_in, pos)
     type(interaction_t), intent(inout) :: int
     complex(default), dimension(:), intent(in) :: value
     type(flavor_t), dimension(:), intent(in) :: flv_in
     integer, intent(in) :: pos
     type(state_iterator_t) :: it
     type(flavor_t) :: flv
     integer :: i
     if (size (value) == 1) then
        call int%set_matrix_element (value(1))
     else
        call it%init (int%state_matrix)
        do while (it%is_valid ())
           flv = it%get_flavor (pos)
           SCAN_FLV: do i = 1, size (value)
              if (flv == flv_in(i)) then
                 call it%set_matrix_element (value(i))
                 exit SCAN_FLV
              end if
           end do SCAN_FLV
           call it%advance ()
        end do
     end if
   end subroutine interaction_set_flavored_values
 
 @ %def interaction_set_flavored_values
 @
 \subsection{Handling Linked interactions}
 Store relations between corresponding particles within one
 interaction.  The first particle is the parent, the second one the
 child.  Links are established in both directions.
 
 These relations have no effect on the propagation of momenta etc.,
 they are rather used for mother-daughter relations in event output.
 <<Interactions: interaction: TBP>>=
   procedure :: relate => interaction_relate
 <<Interactions: procedures>>=
   subroutine interaction_relate (int, i1, i2)
     class(interaction_t), intent(inout), target :: int
     integer, intent(in) :: i1, i2
     if (i1 /= 0 .and. i2 /= 0) then
        call int%children(i1)%append (i2)
        call int%parents(i2)%append (i1)
     end if
   end subroutine interaction_relate
 
 @ %def interaction_relate
 @ Transfer internal parent-child relations defined within interaction
 [[int1]] to a new interaction [[int]] where the particle indices are
 mapped to.  Some particles in [[int1]] may have no image in [[int]].
 In that case, a child entry maps to zero, and we skip this relation.
 
 Also transfer resonance flags.
 <<Interactions: interaction: TBP>>=
   procedure :: transfer_relations => interaction_transfer_relations
 <<Interactions: procedures>>=
   subroutine interaction_transfer_relations (int1, int2, map)
     class(interaction_t), intent(in) :: int1
     class(interaction_t), intent(inout), target :: int2
     integer, dimension(:), intent(in) :: map
     integer :: i, j, k
     do i = 1, size (map)
        do j = 1, int1%parents(i)%get_length ()
           k = int1%parents(i)%get_link (j)
           call int2%relate (map(k), map(i))
        end do
        if (map(i) /= 0) then
           int2%resonant(map(i)) = int1%resonant(i)
        end if
     end do
   end subroutine interaction_transfer_relations
 
 @ %def interaction_transfer_relations
 @ Make up internal parent-child relations for the particle(s) that are
 connected to a new interaction [[int]].
 
 If [[resonant]] is defined and true, the connections are marked as
 resonant in the result interaction.  Also, the children of the resonant
 connections are untagged if they were tagged with hard-interaction flags
 previously.
 <<Interactions: interaction: TBP>>=
   procedure :: relate_connections => interaction_relate_connections
 <<Interactions: procedures>>=
   subroutine interaction_relate_connections &
        (int, int_in, connection_index, &
         map, map_connections, resonant)
     class(interaction_t), intent(inout), target :: int
     class(interaction_t), intent(in) :: int_in
     integer, dimension(:), intent(in) :: connection_index
     integer, dimension(:), intent(in) :: map, map_connections
     logical, intent(in), optional :: resonant
     logical :: reson
     integer :: i, j, i2, k2
     reson = .false.;  if (present (resonant))  reson = resonant
     do i = 1, size (map_connections)
        k2 = connection_index(i)
        do j = 1, int_in%children(k2)%get_length ()
           i2 = int_in%children(k2)%get_link (j)
           call int%relate (map_connections(i), map(i2))
           if (reson)  call int%retag_hard_process (map(i2), .false.)
        end do
        int%resonant(map_connections(i)) = reson
     end do
   end subroutine interaction_relate_connections
 
 @ %def interaction_relate_connections.
 @ Return the number of source/target links of the internal connections of
 particle [[i]].
 <<Interactions: public>>=
   public :: interaction_get_n_children
   public :: interaction_get_n_parents
 <<Interactions: procedures>>=
   function interaction_get_n_children (int, i) result (n)
     integer :: n
     type(interaction_t), intent(in) :: int
     integer, intent(in) :: i
     n = int%children(i)%get_length ()
   end function interaction_get_n_children
 
   function interaction_get_n_parents (int, i) result (n)
     integer :: n
     type(interaction_t), intent(in) :: int
     integer, intent(in) :: i
     n = int%parents(i)%get_length ()
   end function interaction_get_n_parents
 
 @ %def interaction_get_n_children interaction_get_n_parents
 @ Return the source/target links of the internal connections of
 particle [[i]] as an array.
 <<Interactions: public>>=
   public :: interaction_get_children
   public :: interaction_get_parents
 <<Interactions: procedures>>=
   function interaction_get_children (int, i) result (idx)
     integer, dimension(:), allocatable :: idx
     type(interaction_t), intent(in) :: int
     integer, intent(in) :: i
     integer :: k, l
     l = int%children(i)%get_length ()
     allocate (idx (l))
     do k = 1, l
        idx(k) = int%children(i)%get_link (k)
     end do
   end function interaction_get_children
 
   function interaction_get_parents (int, i) result (idx)
     integer, dimension(:), allocatable :: idx
     type(interaction_t), intent(in) :: int
     integer, intent(in) :: i
     integer :: k, l
     l = int%parents(i)%get_length ()
     allocate (idx (l))
     do k = 1, l
        idx(k) = int%parents(i)%get_link (k)
     end do
   end function interaction_get_parents
 
 @ %def interaction_get_children interaction_get_parents
 @ Add a source link from an interaction to a corresponding particle
 within another interaction.  These links affect the propagation of
 particles: the two linked particles are considered as the same
 particle, outgoing and incoming.
 <<Interactions: interaction: TBP>>=
   procedure :: set_source_link => interaction_set_source_link
 <<Interactions: procedures>>=
   subroutine interaction_set_source_link (int, i, int1, i1)
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: i
     class(interaction_t), intent(in), target :: int1
     integer, intent(in) :: i1
     if (i /= 0)  call external_link_set (int%source(i), int1, i1)
   end subroutine interaction_set_source_link
 
 @ %def interaction_set_source_link
 @ Reassign links to a new interaction (which is an image of the
 current interaction).
 <<Interactions: public>>=
   public :: interaction_reassign_links
 <<Interactions: procedures>>=
   subroutine interaction_reassign_links (int, int_src, int_target)
     type(interaction_t), intent(inout) :: int
     type(interaction_t), intent(in) :: int_src
     type(interaction_t), intent(in), target :: int_target
     integer :: i
     if (allocated (int%source)) then
        do i = 1, size (int%source)
           call external_link_reassign (int%source(i), int_src, int_target)
        end do
     end if
   end subroutine interaction_reassign_links
 
 @ %def interaction_reassign_links
 @ Since links are one-directional, if we want to follow them backwards
 we have to scan all possibilities.  This procedure returns the index
 of the particle within [[int]] which points to the particle [[i1]]
 within interaction [[int1]].  If unsuccessful, return zero.
 <<Interactions: public>>=
   public :: interaction_find_link
 <<Interactions: procedures>>=
   function interaction_find_link (int, int1, i1) result (i)
     integer :: i
     type(interaction_t), intent(in) :: int, int1
     integer, intent(in) :: i1
     type(interaction_t), pointer :: int_tmp
     do i = 1, int%n_tot
        int_tmp => external_link_get_ptr (int%source(i))
        if (int_tmp%tag == int1%tag) then
           if (external_link_get_index (int%source(i)) == i1)  return
        end if
     end do
     i = 0
   end function interaction_find_link
 
 @ %def interaction_find_link
 @ The inverse: return interaction pointer and index for the ultimate source of
 [[i]] within [[int]].
 <<Interactions: interaction: TBP>>=
   procedure :: find_source => interaction_find_source
 <<Interactions: procedures>>=
   subroutine interaction_find_source (int, i, int1, i1)
     class(interaction_t), intent(in) :: int
     integer, intent(in) :: i
     type(interaction_t), intent(out), pointer :: int1
     integer, intent(out) :: i1
     type(external_link_t) :: link
     link = interaction_get_ultimate_source (int, i)
     int1 => external_link_get_ptr (link)
     i1 = external_link_get_index (link)
   end subroutine interaction_find_source
 
 @ %def interaction_find_source
 @ Follow source links recursively to return the ultimate source of a particle.
 <<Interactions: procedures>>=
   function interaction_get_ultimate_source (int, i) result (link)
     type(external_link_t) :: link
     type(interaction_t), intent(in) :: int
     integer, intent(in) :: i
     type(interaction_t), pointer :: int_src
     integer :: i_src
     link = int%source(i)
     if (external_link_is_set (link)) then
        do
           int_src => external_link_get_ptr (link)
           i_src = external_link_get_index (link)
           if (external_link_is_set (int_src%source(i_src))) then
              link = int_src%source(i_src)
           else
              exit
           end if
        end do
     end if
   end function interaction_get_ultimate_source
 
 @ %def interaction_get_ultimate_source
 @ Update mask entries by merging them with corresponding masks in
 interactions linked to the current one.  The mask determines quantum
 numbers which are summed over.
 
 Note that both the mask of the current interaction and the mask of the
 linked interaction are updated (side effect!).  This ensures that both
 agree for the linked particle.
 <<Interactions: public>>=
   public :: interaction_exchange_mask
 <<Interactions: procedures>>=
   subroutine interaction_exchange_mask (int)
     type(interaction_t), intent(inout) :: int
     integer :: i, index_link
     type(interaction_t), pointer :: int_link
     do i = 1, int%n_tot
        if (external_link_is_set (int%source(i))) then
           int_link => external_link_get_ptr (int%source(i))
           index_link = external_link_get_index (int%source(i))
           call interaction_merge_mask_entry &
                (int, i, int_link%mask(index_link))
           call interaction_merge_mask_entry &
                (int_link, index_link, int%mask(i))
        end if
     end do
     call int%freeze ()
   end subroutine interaction_exchange_mask
 
 @ %def interaction_exchange_mask
 @ Copy momenta from interactions linked to the current one.
 <<Interactions: interaction: TBP>>=
   procedure :: receive_momenta => interaction_receive_momenta
 <<Interactions: procedures>>=
   subroutine interaction_receive_momenta (int)
     class(interaction_t), intent(inout) :: int
     integer :: i, index_link
     type(interaction_t), pointer :: int_link
     do i = 1, int%n_tot
        if (external_link_is_set (int%source(i))) then
           int_link => external_link_get_ptr (int%source(i))
           index_link = external_link_get_index (int%source(i))
           call int%set_momentum (int_link%p(index_link), i)
        end if
     end do
   end subroutine interaction_receive_momenta
 
 @ %def interaction_receive_momenta
 @ The inverse operation: Copy momenta back to the interactions linked
 to the current one.
 <<Interactions: public>>=
   public :: interaction_send_momenta
 <<Interactions: procedures>>=
   subroutine interaction_send_momenta (int)
     type(interaction_t), intent(in) :: int
     integer :: i, index_link
     type(interaction_t), pointer :: int_link
     do i = 1, int%n_tot
        if (external_link_is_set (int%source(i))) then
           int_link => external_link_get_ptr (int%source(i))
           index_link = external_link_get_index (int%source(i))
           call int_link%set_momentum (int%p(i), index_link)
        end if
     end do
   end subroutine interaction_send_momenta
 
 @ %def interaction_send_momenta
 @ For numerical comparisons: pacify all momenta in an interaction.
 <<Interactions: public>>=
   public :: interaction_pacify_momenta
 <<Interactions: procedures>>=
   subroutine interaction_pacify_momenta (int, acc)
     type(interaction_t), intent(inout) :: int
     real(default), intent(in) :: acc
     integer :: i
     do i = 1, int%n_tot
        call pacify (int%p(i), acc)
     end do
   end subroutine interaction_pacify_momenta
 
 @ %def interaction_pacify_momenta
 @ For each subtraction entry starting from [[SUB = 0]], we duplicate the original state matrix entries as is.
 <<Interactions: interaction: TBP>>=
   procedure :: declare_subtraction => interaction_declare_subtraction
 <<Interactions: procedures>>=
   subroutine interaction_declare_subtraction (int, n_sub)
     class(interaction_t), intent(inout), target :: int
     integer, intent(in) :: n_sub
     integer :: i_sub
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     type(state_matrix_t) :: state_matrix
     call state_matrix%init (store_values = .true.)
     allocate (qn (int%get_state_depth ()))
     do i_sub = 0, n_sub
        call it%init (int%state_matrix)
        do while (it%is_valid ())
           qn = it%get_quantum_numbers ()
           call qn%set_subtraction_index (i_sub)
           call state_matrix%add_state (qn, value = it%get_matrix_element ())
           call it%advance ()
        end do
     end do
     call state_matrix%freeze ()
     call state_matrix%set_n_sub ()
     call int%state_matrix%final ()
     int%state_matrix = state_matrix
   end subroutine interaction_declare_subtraction
 
 @ %def interaction_declare_subtraction
 @
 \subsection{Recovering connections}
 When creating an evaluator for two interactions, we have to know by
 which particles they are connected.  The connection indices can be
 determined if we have two linked interactions.  We assume that
 [[int1]] is the source and [[int2]] the target, so the connections of
 interest are stored within [[int2]].  A connection is found if either the
 source is [[int1]], or the (ultimate)
 source of a particle within [[int2]] coincides with the (ultimate) source of a
 particle within [[int1]].  The result is an array of
 index pairs.
 
 To make things simple, we scan the interaction twice,
 once for counting hits, then allocate the array, then scan again and
 store the connections.
 
 The connections are scanned for [[int2]], which has sources in [[int1]].  It
 may happen that the order of connections is interchanged (crossed).  We
 require the indices in [[int1]] to be sorted, so we reorder both index arrays
 correspondingly before returning them.  (After this, the indices in [[int2]]
 may be out of order.)
 <<Interactions: public>>=
   public :: find_connections
 <<Interactions: procedures>>=
   subroutine find_connections (int1, int2, n, connection_index)
     class(interaction_t), intent(in) :: int1, int2
     integer, intent(out) :: n
     integer, dimension(:,:), intent(out), allocatable :: connection_index
     integer, dimension(:,:), allocatable :: conn_index_tmp
     integer, dimension(:), allocatable :: ordering
     integer :: i, j, k
     type(external_link_t) :: link1, link2
     type(interaction_t), pointer :: int_link1, int_link2
     n = 0
     do i = 1, size (int2%source)
        link2 = interaction_get_ultimate_source (int2, i)
        if (external_link_is_set (link2)) then
           int_link2 => external_link_get_ptr (link2)
           if (int_link2%tag == int1%tag) then
              n = n + 1
           else
              k = external_link_get_index (link2)
              do j = 1, size (int1%source)
                 link1 = interaction_get_ultimate_source (int1, j)
                 if (external_link_is_set (link1)) then
                    int_link1 => external_link_get_ptr (link1)
                    if (int_link1%tag == int_link2%tag) then
                       if (external_link_get_index (link1) == k) &
                            n = n + 1
                    end if
                 end if
              end do
           end if
        end if
     end do
     allocate (conn_index_tmp (n, 2))
     n = 0
     do i = 1, size (int2%source)
        link2 = interaction_get_ultimate_source (int2, i)
        if (external_link_is_set (link2)) then
           int_link2 => external_link_get_ptr (link2)
           if (int_link2%tag == int1%tag) then
              n = n + 1
              conn_index_tmp(n,1) = external_link_get_index (int2%source(i))
              conn_index_tmp(n,2) = i
           else
              k = external_link_get_index (link2)
              do j = 1, size (int1%source)
                 link1 = interaction_get_ultimate_source (int1, j)
                 if (external_link_is_set (link1)) then
                    int_link1 => external_link_get_ptr (link1)
                    if (int_link1%tag == int_link2%tag) then
                       if (external_link_get_index (link1) == k) then
                          n = n + 1
                          conn_index_tmp(n,1) = j
                          conn_index_tmp(n,2) = i
                       end if
                    end if
                 end if
              end do
           end if
        end if
     end do
     allocate (connection_index (n, 2))
     if (n > 1) then
        allocate (ordering (n))
        ordering = order (conn_index_tmp(:,1))
        connection_index = conn_index_tmp(ordering,:)
     else
        connection_index = conn_index_tmp
     end if
   end subroutine find_connections
 
 @ %def find_connections
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[interactions_ut.f90]]>>=
 <<File header>>
 
 module interactions_ut
   use unit_tests
   use interactions_uti
 
 <<Standard module head>>
 
 <<Interactions: public test>>
 
 contains
 
 <<Interactions: test driver>>
 
 end module interactions_ut
 @ %def interactions_ut
 @
 <<[[interactions_uti.f90]]>>=
 <<File header>>
 
 module interactions_uti
 
 <<Use kinds>>
   use lorentz
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use state_matrices
 
   use interactions
 
 <<Standard module head>>
 
 <<Interactions: test declarations>>
 
 contains
 
 <<Interactions: tests>>
 
 end module interactions_uti
 @ %def interactions_ut
 @ API: driver for the unit tests below.
 <<Interactions: public test>>=
   public :: interaction_test
 <<Interactions: test driver>>=
   subroutine interaction_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Interactions: execute tests>>
   end subroutine interaction_test
 
 @ %def interaction_test
 @ Generate an interaction of a polarized virtual photon and a colored
 quark which may be either up or down.  Remove the quark polarization.
 Generate another interaction for the quark radiating a photon and link
 this to the first interation.  The radiation ignores polarization;
 transfer this information to the first interaction to simplify it.
 Then, transfer the momentum to the radiating quark and perform a
 splitting.
 <<Interactions: execute tests>>=
   call test (interaction_1, "interaction_1", &
        "check interaction setup", &
        u, results)
 <<Interactions: test declarations>>=
   public :: interaction_1
 <<Interactions: tests>>=
   subroutine interaction_1 (u)
     integer, intent(in) :: u
     type(interaction_t), target :: int, rad
     type(vector4_t), dimension(3) :: p
     type(quantum_numbers_mask_t), dimension(3) :: mask
     p(2) = vector4_moving (500._default, 500._default, 1)
     p(3) = vector4_moving (500._default,-500._default, 1)
     p(1) = p(2) + p(3)
 
     write (u, "(A)")  "* Test output: interaction"
     write (u, "(A)")  "*   Purpose: check routines for interactions"
     write (u, "(A)")
 
     call int%basic_init (1, 0, 2, set_relations=.true., &
          store_values = .true. )
     call int_set (int, 1, -1, 1, 1, &
          cmplx (0.3_default, 0.1_default, kind=default))
     call int_set (int, 1, -1,-1, 1, &
          cmplx (0.5_default,-0.7_default, kind=default))
     call int_set (int, 1, 1, 1, 1, &
          cmplx (0.1_default, 0._default, kind=default))
     call int_set (int, -1, 1, -1, 2, &
          cmplx (0.4_default, -0.1_default, kind=default))
     call int_set (int, 1, 1, 1, 2, &
          cmplx (0.2_default, 0._default, kind=default))
     call int%freeze ()
     call int%set_momenta (p)
     mask = quantum_numbers_mask (.false.,.false., [.true.,.true.,.true.])
     call rad%basic_init (1, 0, 2, &
          mask=mask, set_relations=.true., store_values = .true.)
     call rad_set (1)
     call rad_set (2)
     call rad%set_source_link (1, int, 2)
     call interaction_exchange_mask (rad)
     call rad%receive_momenta ()
     p(1) = rad%get_momentum (1)
     p(2) = 0.4_default * p(1)
     p(3) = p(1) - p(2)
     call rad%set_momenta (p(2:3), outgoing=.true.)
     call int%freeze ()
     call rad%freeze ()
     call rad%set_matrix_element &
          (cmplx (0._default, 0._default, kind=default))
     call int%basic_write (u)
     write (u, "(A)")
     call rad%basic_write (u)
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
     call int%final ()
     call rad%final ()
     write (u, "(A)")
     write (u, "(A)")  "* Test interaction_1: successful."
   contains
     subroutine int_set (int, h1, h2, hq, q, val)
       type(interaction_t), target, intent(inout) :: int
       integer, intent(in) :: h1, h2, hq, q
       type(flavor_t), dimension(3) :: flv
       type(color_t), dimension(3) :: col
       type(helicity_t), dimension(3) :: hel
       type(quantum_numbers_t), dimension(3) :: qn
       complex(default), intent(in) :: val
       call flv%init ([21, q, -q])
       call col(2)%init_col_acl (5, 0)
       call col(3)%init_col_acl (0, 5)
       call hel%init ([h1, hq, -hq], [h2, hq, -hq])
       call qn%init (flv, col, hel)
       call int%add_state (qn)
       call int%set_matrix_element (val)
     end subroutine int_set
     subroutine rad_set (q)
       integer, intent(in) :: q
       type(flavor_t), dimension(3) :: flv
       type(quantum_numbers_t), dimension(3) :: qn
       call flv%init ([ q, q, 21 ])
       call qn%init (flv)
       call rad%add_state (qn)
     end subroutine rad_set
   end subroutine interaction_1
 
 @ %def interaction_1
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Matrix element evaluation}
 
 The [[evaluator_t]] type is an extension of the [[interaction_t]]
 type.  It represents either a density matrix as the square of a
 transition matrix element, or the product of two density matrices.
 Usually, some quantum numbers are summed over in the result.
 
 The [[interaction_t]] subobject represents a multi-particle
 interaction with incoming, virtual, and outgoing particles and the
 associated (not necessarily diagonal) density matrix of quantum
 state.  When the evaluator is initialized, this interaction is
 constructed from the input interaction(s).
 
 In addition, the initialization process sets up a multiplication
 table.  For each matrix element of the result, it states which matrix
 elements are to be taken from the input interaction(s), multiplied
 (optionally, with an additional weight factor) and summed over.
 
 Eventually, to a processes we associate a chain of evaluators which
 are to be evaluated sequentially.  The physical event and its matrix
 element value(s) can be extracted from the last evaluator in such a
 chain.
 
 Evaluators are constructed only once (as long as this is possible)
 during an initialization step.  Then, for each event, momenta
 are computed and transferred among evaluators using the links within
 the interaction subobject.  The multiplication tables enable fast
 evaluation of the result without looking at quantum numbers anymore.
 <<[[evaluators.f90]]>>=
 <<File header>>
 
 module evaluators
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_19
   use physics_defs, only: n_beams_rescaled
   use diagnostics
   use lorentz
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use state_matrices
   use interactions
 
 <<Standard module head>>
 
 <<Evaluators: public>>
 
 <<Evaluators: parameters>>
 
 <<Evaluators: types>>
 
 <<Evaluators: interfaces>>
 
 contains
 
 <<Evaluators: procedures>>
 
 end module evaluators
 @ %def evaluators
 @
 \subsection{Array of pairings}
 The evaluator contains an array of [[pairing_array]] objects.  This
 makes up the multiplication table.
 
 Each pairing array contains two list of matrix element indices and a
 list of numerical factors.  The matrix element indices correspond to
 the input interactions.  The corresponding matrix elements are to be
 multiplied and optionally multiplied by a factor.  The results are
 summed over to yield one specific matrix element of the result
 evaluator.
 <<Evaluators: types>>=
   type :: pairing_array_t
      integer, dimension(:), allocatable :: i1, i2
      complex(default), dimension(:), allocatable :: factor
   end type pairing_array_t
 
 @ %def pairing_array_t
 <<Evaluators: procedures>>=
   elemental subroutine pairing_array_init (pa, n, has_i2, has_factor)
     type(pairing_array_t), intent(out) :: pa
     integer, intent(in) :: n
     logical, intent(in) :: has_i2, has_factor
     allocate (pa%i1 (n))
     if (has_i2)  allocate (pa%i2 (n))
     if (has_factor)  allocate (pa%factor (n))
   end subroutine pairing_array_init
 
 @ %def pairing_array_init
 @
 <<Evaluators: public>>=
   public :: pairing_array_write
 <<Evaluators: procedures>>=
   subroutine pairing_array_write (pa, unit)
     type(pairing_array_t), intent(in) :: pa
     integer, intent(in), optional :: unit
     integer :: i, u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(A)", advance = "no") "["
     if (allocated (pa%i1)) then
        write (u, "(I0,A)", advance = "no") pa%i1, ","
     else
        write (u, "(A)", advance = "no") "x,"
     end if
     if (allocated (pa%i2)) then
        write (u, "(I0,A)", advance = "no") pa%i1, ","
     else
        write (u, "(A)", advance = "no") "x,"
     end if
     write (u, "(A)", advance = "no") "]"
     if (allocated (pa%factor)) then
        write (u, "(A,F5.4,A,F5.4,A)") ";(", &
             real(pa%factor), ",", aimag(pa%factor), ")]"
     else
        write (u, "(A)") ""
     end if
   end subroutine pairing_array_write
 
 @ %def pairing_array_write
 @
 \subsection{The evaluator type}
 Possible variants of evaluators:
 <<Evaluators: parameters>>=
   integer, parameter :: &
        EVAL_UNDEFINED = 0, &
        EVAL_PRODUCT = 1, &
        EVAL_SQUARED_FLOWS = 2, &
        EVAL_SQUARE_WITH_COLOR_FACTORS = 3, &
        EVAL_COLOR_CONTRACTION = 4, &
        EVAL_IDENTITY = 5, &
        EVAL_QN_SUM = 6
 @ %def EVAL_PRODUCT EVAL_SQUARED_FLOWS EVAL_SQUARE_WITH_COLOR_FACTORS
 @ %def EVAL_COLOR_CONTRACTION EVAL_QN_SUM
 @ The evaluator type contains the result interaction and an array of
 pairing lists, one for each matrix element in the result interaction.
 <<Evaluators: public>>=
   public :: evaluator_t
 <<Evaluators: types>>=
   type, extends (interaction_t) :: evaluator_t
      private
      integer :: type = EVAL_UNDEFINED
      class(interaction_t), pointer :: int_in1 => null ()
      class(interaction_t), pointer :: int_in2 => null ()
      type(pairing_array_t), dimension(:), allocatable :: pairing_array
    contains
    <<Evaluators: evaluator: TBP>>
   end type evaluator_t
 
 @ %def evaluator_t
 @ Output.
 <<Evaluators: evaluator: TBP>>=
   procedure :: write => evaluator_write
 <<Evaluators: procedures>>=
   subroutine evaluator_write (eval, unit, &
        verbose, show_momentum_sum, show_mass, show_state, show_table, &
        col_verbose, testflag)
     class(evaluator_t), intent(in) :: eval
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
     logical, intent(in), optional :: show_state, show_table, col_verbose
     logical, intent(in), optional :: testflag
     logical :: conjugate, square, show_tab
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     show_tab = .true.;  if (present (show_table))  show_tab = .false.
     call eval%basic_write &
          (unit, verbose, show_momentum_sum, show_mass, &
             show_state, col_verbose, testflag)
     if (show_tab) then
        write (u, "(1x,A)")  "Matrix-element multiplication"
        write (u, "(2x,A)", advance="no")  "Input interaction 1:"
        if (associated (eval%int_in1)) then
           write (u, "(1x,I0)")  eval%int_in1%get_tag ()
        else
           write (u, "(A)")  " [undefined]"
        end if
        write (u, "(2x,A)", advance="no")  "Input interaction 2:"
        if (associated (eval%int_in2)) then
           write (u, "(1x,I0)")  eval%int_in2%get_tag ()
        else
           write (u, "(A)")  " [undefined]"
        end if
        select case (eval%type)
        case (EVAL_SQUARED_FLOWS, EVAL_SQUARE_WITH_COLOR_FACTORS)
           conjugate = .true.
           square = .true.
        case (EVAL_IDENTITY)
           write (u, "(1X,A)") "Identity evaluator, pairing array unused"
           return
        case default
           conjugate = .false.
           square = .false.
        end select
        call eval%write_pairing_array (conjugate, square, u)
     end if
   end subroutine evaluator_write
 
 @ %def evaluator_write
 @
 <<Evaluators: evaluator: TBP>>=
   procedure :: write_pairing_array => evaluator_write_pairing_array
 <<Evaluators: procedures>>=
   subroutine evaluator_write_pairing_array (eval, conjugate, square, unit)
     class(evaluator_t), intent(in) :: eval
     logical, intent(in) :: conjugate, square
     integer, intent(in), optional :: unit
     integer :: u, i, j
     u = given_output_unit (unit);  if (u < 0)  return
     if (allocated (eval%pairing_array)) then
        do i = 1, size (eval%pairing_array)
           write (u, "(2x,A,I0,A)")  "ME(", i, ") = "
           do j = 1, size (eval%pairing_array(i)%i1)
              write (u, "(4x,A)", advance="no")  "+"
              if (allocated (eval%pairing_array(i)%i2)) then
                 write (u, "(1x,A,I0,A)", advance="no")  &
                      "ME1(", eval%pairing_array(i)%i1(j), ")"
                 if (conjugate) then
                    write (u, "(A)", advance="no")  "* x"
                 else
                    write (u, "(A)", advance="no")  " x"
                 end if
                 write (u, "(1x,A,I0,A)", advance="no")  &
                      "ME2(", eval%pairing_array(i)%i2(j), ")"
              else if (square) then
                 write (u, "(1x,A)", advance="no")  "|"
                 write (u, "(A,I0,A)", advance="no")  &
                      "ME1(", eval%pairing_array(i)%i1(j), ")"
                 write (u, "(A)", advance="no")  "|^2"
              else
                 write (u, "(1x,A,I0,A)", advance="no")  &
                      "ME1(", eval%pairing_array(i)%i1(j), ")"
              end if
              if (allocated (eval%pairing_array(i)%factor)) then
                 write (u, "(1x,A)", advance="no")  "x"
                 write (u, "(1x,'('," // FMT_19 // ",','," // FMT_19 // &
                      ",')')") eval%pairing_array(i)%factor(j)
              else
                 write (u, *)
              end if
           end do
        end do
     end if
   end subroutine evaluator_write_pairing_array
 
 @ %def evaluator_write_pairing_array
 @ Assignment: Deep copy of the interaction component.
 <<Evaluators: public>>=
   public :: assignment(=)
 <<Evaluators: interfaces>>=
   interface assignment(=)
      module procedure evaluator_assign
   end interface
 
 <<Evaluators: procedures>>=
   subroutine evaluator_assign (eval_out, eval_in)
     type(evaluator_t), intent(out) :: eval_out
     type(evaluator_t), intent(in) :: eval_in
     eval_out%type = eval_in%type
     eval_out%int_in1 => eval_in%int_in1
     eval_out%int_in2 => eval_in%int_in2
     eval_out%interaction_t = eval_in%interaction_t
     if (allocated (eval_in%pairing_array)) then
        allocate (eval_out%pairing_array (size (eval_in%pairing_array)))
        eval_out%pairing_array = eval_in%pairing_array
     end if
   end subroutine evaluator_assign
 
 @ %def evaluator_assign
 @
 \subsection{Auxiliary structures for evaluator creation}
 Creating an evaluator that properly handles all quantum numbers requires some
 bookkeeping.  In this section, we define several auxiliary types and methods
 that organize and simplify this task.  More structures are defined within the
 specific initializers (as local types and internal subroutines).
 
 These types are currently implemented in a partial object-oriented way: We
 define some basic methods for initialization etc.\ here, but the evaluator
 routines below do access their internals as well.  This simplifies some things
 such as index addressing using array slices, at the expense of losing some
 clarity.
 
 \subsubsection{Index mapping}
 Index mapping are abundant when constructing an evaluator.  To have arrays of
 index mappings, we define this:
 <<Evaluators: types>>=
   type :: index_map_t
      integer, dimension(:), allocatable :: entry
   end type index_map_t
 
 @ %def index_map_t
 <<Evaluators: procedures>>=
   elemental subroutine index_map_init (map, n)
     type(index_map_t), intent(out) :: map
     integer, intent(in) :: n
     allocate (map%entry (n))
     map%entry = 0
   end subroutine index_map_init
 
 @ %def index_map_init
 <<Evaluators: procedures>>=
   function index_map_exists (map) result (flag)
     logical :: flag
     type(index_map_t), intent(in) :: map
     flag = allocated (map%entry)
   end function index_map_exists
 
 @ %def index_map_exists
 <<Evaluators: interfaces>>=
   interface size
      module procedure index_map_size
   end interface
 
 @ %def size
 <<Evaluators: procedures>>=
   function index_map_size (map) result (s)
     integer :: s
     type(index_map_t), intent(in) :: map
     if (allocated (map%entry)) then
        s = size (map%entry)
     else
        s = 0
     end if
   end function index_map_size
 
 @ %def index_map_size
 <<Evaluators: interfaces>>=
   interface assignment(=)
      module procedure index_map_assign_int
      module procedure index_map_assign_array
   end interface
 
 @ %def =
 <<Evaluators: procedures>>=
   elemental subroutine index_map_assign_int (map, ival)
     type(index_map_t), intent(inout) :: map
     integer, intent(in) :: ival
     map%entry = ival
   end subroutine index_map_assign_int
 
   subroutine index_map_assign_array (map, array)
     type(index_map_t), intent(inout) :: map
     integer, dimension(:), intent(in) :: array
     map%entry = array
   end subroutine index_map_assign_array
 
 @ %def index_map_assign_int index_map_assign_array
 <<Evaluators: procedures>>=
   elemental subroutine index_map_set_entry (map, i, ival)
     type(index_map_t), intent(inout) :: map
     integer, intent(in) :: i
     integer, intent(in) :: ival
     map%entry(i) = ival
   end subroutine index_map_set_entry
 
 @ %def index_map_set_entry
 <<Evaluators: procedures>>=
   elemental function index_map_get_entry (map, i) result (ival)
     integer :: ival
     type(index_map_t), intent(in) :: map
     integer, intent(in) :: i
     ival = map%entry(i)
   end function index_map_get_entry
 
 @ %def index_map_get_entry
 @
 \subsubsection{Index mapping (two-dimensional)}
 This is a variant with a square matrix instead of an array.
 <<Evaluators: types>>=
   type :: index_map2_t
      integer :: s = 0
      integer, dimension(:,:), allocatable :: entry
   end type index_map2_t
 
 @ %def index_map2_t
 <<Evaluators: procedures>>=
   elemental subroutine index_map2_init (map, n)
     type(index_map2_t), intent(out) :: map
     integer, intent(in) :: n
     map%s = n
     allocate (map%entry (n, n))
   end subroutine index_map2_init
 
 @ %def index_map2_init
 <<Evaluators: procedures>>=
   function index_map2_exists (map) result (flag)
     logical :: flag
     type(index_map2_t), intent(in) :: map
     flag = allocated (map%entry)
   end function index_map2_exists
 
 @ %def index_map2_exists
 <<Evaluators: interfaces>>=
   interface size
      module procedure index_map2_size
   end interface
 
 @ %def size
 <<Evaluators: procedures>>=
   function index_map2_size (map) result (s)
     integer :: s
     type(index_map2_t), intent(in) :: map
     s = map%s
   end function index_map2_size
 
 @ %def index_map2_size
 <<Evaluators: interfaces>>=
   interface assignment(=)
      module procedure index_map2_assign_int
   end interface
 
 @ %def =
 <<Evaluators: procedures>>=
   elemental subroutine index_map2_assign_int (map, ival)
     type(index_map2_t), intent(inout) :: map
     integer, intent(in) :: ival
     map%entry = ival
   end subroutine index_map2_assign_int
 
 @ %def index_map2_assign_int
 <<Evaluators: procedures>>=
   elemental subroutine index_map2_set_entry (map, i, j, ival)
     type(index_map2_t), intent(inout) :: map
     integer, intent(in) :: i, j
     integer, intent(in) :: ival
     map%entry(i,j) = ival
   end subroutine index_map2_set_entry
 
 @ %def index_map2_set_entry
 <<Evaluators: procedures>>=
   elemental function index_map2_get_entry (map, i, j) result (ival)
     integer :: ival
     type(index_map2_t), intent(in) :: map
     integer, intent(in) :: i, j
     ival = map%entry(i,j)
   end function index_map2_get_entry
 
 @ %def index_map2_get_entry
 @
 \subsubsection{Auxiliary structures: particle mask}
 This is a simple container of a logical array.
 <<Evaluators: types>>=
   type :: prt_mask_t
      logical, dimension(:), allocatable :: entry
   end type prt_mask_t
 
 @ %def prt_mask_t
 <<Evaluators: procedures>>=
   subroutine prt_mask_init (mask, n)
     type(prt_mask_t), intent(out) :: mask
     integer, intent(in) :: n
     allocate (mask%entry (n))
   end subroutine prt_mask_init
 
 @ %def prt_mask_init
 <<Evaluators: interfaces>>=
   interface size
      module procedure prt_mask_size
   end interface
 
 @ %def size
 <<Evaluators: procedures>>=
   function prt_mask_size (mask) result (s)
     integer :: s
     type(prt_mask_t), intent(in) :: mask
     s = size (mask%entry)
   end function prt_mask_size
 
 @ %def prt_mask_size
 @
 \subsubsection{Quantum number containers}
 Trivial transparent containers:
 <<Evaluators: types>>=
   type :: qn_list_t
      type(quantum_numbers_t), dimension(:,:), allocatable :: qn
   end type qn_list_t
 
   type :: qn_mask_array_t
      type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
   end type qn_mask_array_t
 
 @ %def qn_list_t qn_mask_array_t
 @
 \subsubsection{Auxiliary structures: connection entries}
 This type is used as intermediate storage when computing the product of two
 evaluators or the square of an evaluator.  The quantum-number array [[qn]]
 corresponds to the particles common to both interactions, but irrelevant
 quantum numbers (color) masked out.  The index arrays [[index_in]] determine
 the entries in the input interactions that contribute to this connection.
 [[n_index]] is the size of these arrays, and [[count]] is used while filling
 the entries.  Finally, the quantum-number arrays [[qn_in_list]] are the actual
 entries in the input interaction that contribute.  In the product case, they
 exclude the connected quantum numbers.
 
 Each evaluator has its own [[connection_table]] which contains an array of
 [[connection_entry]] objects, but also has stuff that specifically applies to
 the evaluator type.  Hence, we do not generalize the [[connection_table_t]]
 type.
 
 The filling procedure [[connection_entry_add_state]] is specific to the
 various evaluator types.
 <<Evaluators: types>>=
   type :: connection_entry_t
      type(quantum_numbers_t), dimension(:), allocatable :: qn_conn
      integer, dimension(:), allocatable :: n_index
      integer, dimension(:), allocatable :: count
      type(index_map_t), dimension(:), allocatable :: index_in
      type(qn_list_t), dimension(:), allocatable :: qn_in_list
   end type connection_entry_t
 
 @ %def connection_entry_t
 <<Evaluators: procedures>>=
   subroutine connection_entry_init &
       (entry, n_count, n_map, qn_conn, count, n_rest)
     type(connection_entry_t), intent(out) :: entry
     integer, intent(in) :: n_count, n_map
     type(quantum_numbers_t), dimension(:), intent(in) :: qn_conn
     integer, dimension(n_count), intent(in) :: count
     integer, dimension(n_count), intent(in) :: n_rest
     integer :: i
     allocate (entry%qn_conn (size (qn_conn)))
     allocate (entry%n_index (n_count))
     allocate (entry%count (n_count))
     allocate (entry%index_in (n_map))
     allocate (entry%qn_in_list (n_count))
     entry%qn_conn = qn_conn
     entry%n_index = count
     entry%count = 0
     if (size (entry%index_in) == size (count)) then
        call index_map_init (entry%index_in, count)
     else
        call index_map_init (entry%index_in, count(1))
     end if
     do i = 1, n_count
       allocate (entry%qn_in_list(i)%qn (n_rest(i), count(i)))
     end do
   end subroutine connection_entry_init
 
 @ %def connection_entry_init
 <<Evaluators: procedures>>=
   subroutine connection_entry_write (entry, unit)
     type(connection_entry_t), intent(in) :: entry
     integer, intent(in), optional :: unit
     integer :: i, j
     integer :: u
     u = given_output_unit (unit)
     call quantum_numbers_write (entry%qn_conn, unit)
     write (u, *)
     do i = 1, size (entry%n_index)
        write (u, *)  "Input interaction", i
        do j = 1, entry%n_index(i)
           if (size (entry%n_index) == size (entry%index_in)) then
              write (u, "(2x,I0,4x,I0,2x)", advance = "no") &
                   j, index_map_get_entry (entry%index_in(i), j)
           else
              write (u, "(2x,I0,4x,I0,2x,I0,2x)", advance = "no") &
                   j, index_map_get_entry (entry%index_in(1), j), &
                      index_map_get_entry (entry%index_in(2), j)
           end if
           call quantum_numbers_write (entry%qn_in_list(i)%qn(:,j), unit)
           write (u, *)
        end do
     end do
   end subroutine connection_entry_write
 
 @ %def connection_entry_write
 @
 \subsubsection{Color handling}
 For managing color-factor computation, we introduce this local type.   The
 [[index]] is the index in the color table that corresponds to a given matrix
 element index in the input interaction.  The [[col]] array stores the color
 assignments in rows.  The [[factor]] array associates a complex number with
 each pair of arrays in the color table.  The [[factor_is_known]] array reveals
 whether a given factor is known already or still has to be computed.
 <<Evaluators: types>>=
   type :: color_table_t
      integer, dimension(:), allocatable :: index
      type(color_t), dimension(:,:), allocatable :: col
      logical, dimension(:,:), allocatable :: factor_is_known
      complex(default), dimension(:,:), allocatable :: factor
   end type color_table_t
 
 @ %def color_table_t
 @ This is the initializer.  We extract the color states from the given state
 matrices, establish index mappings between the two states (implemented by the
 array [[me_index]]), make an array of color states, and initialize the
 color-factor table.  The latter is two-dimensional (includes interference) and
 not yet filled.
 <<Evaluators: procedures>>=
   subroutine color_table_init (color_table, state, n_tot)
     type(color_table_t), intent(out) :: color_table
     type(state_matrix_t), intent(in) :: state
     integer, intent(in) :: n_tot
     type(state_iterator_t) :: it
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     type(state_matrix_t) :: state_col
     integer :: index, n_col_state
     allocate (color_table%index (state%get_n_matrix_elements ()))
     color_table%index = 0
     allocate (qn (n_tot))
     call state_col%init ()
     call it%init (state)
     do while (it%is_valid ())
        index = it%get_me_index ()
        call qn%init (col = it%get_color ())
        call state_col%add_state (qn, me_index = color_table%index(index))
        call it%advance ()
     end do
     n_col_state = state_col%get_n_matrix_elements ()
     allocate (color_table%col (n_tot, n_col_state))
     call it%init (state_col)
     do while (it%is_valid ())
        index = it%get_me_index ()
        color_table%col(:,index) = it%get_color ()
        call it%advance ()
     end do
     call state_col%final ()
     allocate (color_table%factor_is_known (n_col_state, n_col_state))
     allocate (color_table%factor (n_col_state, n_col_state))
     color_table%factor_is_known = .false.
   end subroutine color_table_init
 
 @ %def color_table_init
 @ Output (debugging use):
 <<Evaluators: procedures>>=
   subroutine color_table_write (color_table, unit)
     type(color_table_t), intent(in) :: color_table
     integer, intent(in), optional :: unit
     integer :: i, j
     integer :: u
     u = given_output_unit (unit)
     write (u, *) "Color table:"
     if (allocated (color_table%index)) then
        write (u, *) "  Index mapping state => color table:"
        do i = 1, size (color_table%index)
           write (u, "(3x,I0,2x,I0,2x)")  i, color_table%index(i)
        end do
        write (u, *) "  Color table:"
        do i = 1, size (color_table%col, 2)
           write (u, "(3x,I0,2x)", advance = "no")  i
           call color_write (color_table%col(:,i), unit)
           write (u, *)
        end do
        write (u, *) "  Defined color factors:"
        do i = 1, size (color_table%factor, 1)
           do j = 1, size (color_table%factor, 2)
              if (color_table%factor_is_known(i,j)) then
                 write (u, *)  i, j, color_table%factor(i,j)
              end if
           end do
        end do
     end if
   end subroutine color_table_write
 
 @ %def color_table_write
 @ This subroutine sets color factors, based on information from the hard
 matrix element: the list of pairs of color-flow indices (in the basis of the
 matrix element code), the list of corresponding factors, and the list of
 mappings from the matrix element index in the input interaction to the
 color-flow index in the hard matrix element object.
 
 We first determine the mapping of color-flow indices from the hard matrix
 element code to the current color table.  The mapping could be nontrivial
 because the latter is derived from iterating over a state matrix, which may
 return states in non-canonical order.  The translation table can be determined
 because we have, for the complete state matrix, both the mapping to the hard
 interaction (the input [[col_index_hi]]) and the mapping to the current
 color table (the component [[color_table%index]]).
 
 Once this mapping is known, we scan the list of index pairs
 [[color_flow_index]] and translate them to valid color-table index pairs.  For
 this pair, the color factor is set using the corresponding entry in the list
 [[col_factor]].
 <<Evaluators: procedures>>=
   subroutine color_table_set_color_factors (color_table, &
        col_flow_index, col_factor, col_index_hi)
     type(color_table_t), intent(inout) :: color_table
     integer, dimension(:,:), intent(in) :: col_flow_index
     complex(default), dimension(:), intent(in) :: col_factor
     integer, dimension(:), intent(in) :: col_index_hi
     integer, dimension(:), allocatable :: hi_to_ct
     integer :: n_cflow
     integer :: hi_index, me_index, ct_index, cf_index
     integer, dimension(2) :: hi_index_pair, ct_index_pair
     n_cflow = size (col_index_hi)
     if (size (color_table%index) /= n_cflow) &
          call msg_bug ("Mismatch between hard matrix element and color table")
     allocate (hi_to_ct (n_cflow))
     do me_index = 1, size (color_table%index)
        ct_index = color_table%index(me_index)
        hi_index = col_index_hi(me_index)
        hi_to_ct(hi_index) = ct_index
     end do
     do cf_index = 1, size (col_flow_index, 2)
        hi_index_pair = col_flow_index(:,cf_index)
        ct_index_pair = hi_to_ct(hi_index_pair)
        color_table%factor(ct_index_pair(1), ct_index_pair(2)) = &
             col_factor(cf_index)
        color_table%factor_is_known(ct_index_pair(1), ct_index_pair(2)) = .true.
     end do
   end subroutine color_table_set_color_factors
 
 @ %def color_table_set_color_factors
 @ This function returns a color factor, given two indices which point to the
 matrix elements of the initial state matrix.  Internally, we can map them to
 the corresponding indices in the color table.  As a side effect, we store the
 color factor in the color table for later lookup.  (I.e., this function is
 impure.)
 <<Evaluators: procedures>>=
   function color_table_get_color_factor (color_table, index1, index2, nc) &
       result (factor)
     real(default) :: factor
     type(color_table_t), intent(inout) :: color_table
     integer, intent(in) :: index1, index2
     integer, intent(in), optional :: nc
     integer :: i1, i2
     i1 = color_table%index(index1)
     i2 = color_table%index(index2)
     if (color_table%factor_is_known(i1,i2)) then
        factor = real(color_table%factor(i1,i2), kind=default)
     else
        factor = compute_color_factor &
             (color_table%col(:,i1), color_table%col(:,i2), nc)
        color_table%factor(i1,i2) = factor
        color_table%factor_is_known(i1,i2) = .true.
     end if
   end function color_table_get_color_factor
 
 @ %def color_table_get_color_factor
 @
 \subsection{Creating an evaluator: Matrix multiplication}
 The evaluator for matrix multiplication is the most complicated
 variant.
 
 The initializer takes two input interactions and constructs the result
 evaluator, which consists of the interaction and the multiplication
 table for the product (or convolution) of the two.  Normally, the
 input interactions are connected by one or more common particles
 (e.g., decay, structure function convolution).
 
 In the result interaction, quantum numbers of the connections can be
 summed over.  This is determined by the [[qn_mask_conn]] argument.
 The [[qn_mask_rest]] argument is its analog for the other particles
 within the result interaction.  (E.g., for the trace of the state
-matrix, all quantum numbers are summed over.)  
+matrix, all quantum numbers are summed over.)
 
 Finally, the
 [[connections_are_resonant]] argument tells whether the connecting
 particles should be marked as resonant in the final event record.  If true,
 this also implies that the second interaction is not the hard process, so any
 corresponding tags should be removed from the outgoing particles.
 This applies to decays.
 
 The algorithm consists of the following steps:
 \begin{enumerate}
 \item
   [[find_connections]]: Find the particles which are connected, i.e.,
   common to both input interactions.  Either they are directly linked,
   or both are linked to a common source.
 \item
   [[compute_index_bounds_and_mappings]]: Compute the mappings of
   particle indices from the input interactions to the result
   interaction.  There is a separate mapping for the connected
   particles.
 \item
   [[accumulate_connected_states]]: Create an auxiliary state matrix
   which lists the possible quantum numbers for the connected
   particles.  When building this matrix, count the number of times
   each assignment is contained in any of the input states and, for
   each of the input states, record the index of the matrix element
   within the new state matrix.  For the connected particles, reassign
   color indices such that no color state is present twice in different
   color-index assignment.  Note that helicity assignments of the
   connected state can be (and will be) off-diagonal, so no spin
   correlations are lost in decays.
 
   Do this for both input interactions.
 \item
   [[allocate_connection_entries]]: Allocate a table of connections.
   Each table row corresponds to one state in the auxiliary matrix, and
   to multiple states of the input interactions.  It collects all
   states of the unconnected particles in the two input interactions
   that are associated with the particular state (quantum-number
   assignment) of the connected particles.
 \item
   [[fill_connection_table]]: Fill the table of connections by scanning
   both input interactions.  When copying states, reassign color
   indices for the unconnected particles such that they match between
   all involved particle sets (interaction 1, interaction 2, and
   connected particles).
 \item
   [[make_product_interaction]]: Scan the table of connections we have
   just built.  For each entry, construct all possible pairs of states
   of the unconnected particles and combine them with the specific
   connected-particle state.  This is a possible quantum-number
   assignment of the result interaction.  Now mask all quantum numbers
   that should be summed over, and append this to the result state
   matrix.  Record the matrix element index of the result.  We now have
   the result interaction.
 \item
   [[make_pairing_array]]: First allocate the pairing array with the
   number of entries of the result interaction.  Then scan the table of
   connections again.  For each entry, record the indices of the matrix
   elements which have to be multiplied and summed over in order to
   compute this particular matrix element.  This makes up the
   multiplication table.
 \item
   [[record_links]]: Transfer all source pointers from the input
   interactions to the result interaction.  Do the same for the
   internal parent-child relations and resonance assignments.  For the
   connected particles, make up appropriate additional parent-child
   relations.  This allows for fetching momenta from other interactions
   when a new event is filled, and to reconstruct the event history
   when the event is analyzed.
 \end{enumerate}
 
 After all this is done, for each event, we just have to evaluate the
 pairing arrays (multiplication tables) in order to compute the result
 matrix elements in their proper positions.  The quantum-number
 assignments remain fixed from now on.
 <<Evaluators: evaluator: TBP>>=
   procedure :: init_product => evaluator_init_product
 <<Evaluators: procedures>>=
   subroutine evaluator_init_product &
        (eval, int_in1, int_in2, qn_mask_conn, qn_filter_conn, qn_mask_rest, &
         connections_are_resonant, ignore_sub_for_qn)
 
     class(evaluator_t), intent(out), target :: eval
     class(interaction_t), intent(in), target :: int_in1, int_in2
     type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn
     type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
     type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest
     logical, intent(in), optional :: connections_are_resonant
     logical, intent(in), optional :: ignore_sub_for_qn
 
     type(qn_mask_array_t), dimension(2) :: qn_mask_in
     type(state_matrix_t), pointer :: state_in1, state_in2
 
     type :: connection_table_t
        integer :: n_conn = 0
        integer, dimension(2) :: n_rest = 0
        integer :: n_tot = 0
        integer :: n_me_conn = 0
        type(state_matrix_t) :: state
        type(index_map_t), dimension(:), allocatable :: index_conn
        type(connection_entry_t), dimension(:), allocatable :: entry
        type(index_map_t) :: index_result
     end type connection_table_t
     type(connection_table_t) :: connection_table
 
     integer :: n_in, n_vir, n_out, n_tot
     integer, dimension(2) :: n_rest
     integer :: n_conn
 
     integer, dimension(:,:), allocatable :: connection_index
     type(index_map_t), dimension(2) :: prt_map_in
     type(index_map_t) :: prt_map_conn
     type(prt_mask_t), dimension(2) :: prt_is_connected
     type(quantum_numbers_mask_t), dimension(:), allocatable :: &
          qn_mask_conn_initial, int_in1_mask, int_in2_mask
 
     integer :: i
 
     eval%type = EVAL_PRODUCT
     eval%int_in1 => int_in1
     eval%int_in2 => int_in2
 
     state_in1 => int_in1%get_state_matrix_ptr ()
     state_in2 => int_in2%get_state_matrix_ptr ()
 
     call find_connections (int_in1, int_in2, n_conn, connection_index)
     if (n_conn == 0) then
        call msg_message ("First interaction:")
        call int_in1%basic_write (col_verbose=.true.)
        call msg_message ("Second interaction:")
        call int_in2%basic_write (col_verbose=.true.)
        call msg_fatal ("Evaluator product: no connections found between factors")
     end if
     call compute_index_bounds_and_mappings &
          (int_in1, int_in2, n_conn, &
           n_in, n_vir, n_out, n_tot, &
           n_rest, prt_map_in, prt_map_conn)
 
     call prt_mask_init (prt_is_connected(1), int_in1%get_n_tot ())
     call prt_mask_init (prt_is_connected(2), int_in2%get_n_tot ())
     do i = 1, 2
        prt_is_connected(i)%entry = .true.
        prt_is_connected(i)%entry(connection_index(:,i)) = .false.
     end do
     allocate (qn_mask_conn_initial (n_conn), &
          int_in1_mask (n_conn), int_in2_mask (n_conn))
     int_in1_mask = int_in1%get_mask (connection_index(:,1))
     int_in2_mask = int_in2%get_mask (connection_index(:,2))
     do i = 1, n_conn
        qn_mask_conn_initial(i) = int_in1_mask(i) .or. int_in2_mask(i)
     end do
     allocate (qn_mask_in(1)%mask (int_in1%get_n_tot ()))
     allocate (qn_mask_in(2)%mask (int_in2%get_n_tot ()))
     qn_mask_in(1)%mask = int_in1%get_mask ()
     qn_mask_in(2)%mask = int_in2%get_mask ()
 
     call connection_table_init (connection_table, &
          state_in1, state_in2, &
          qn_mask_conn_initial,  &
          n_conn, connection_index, n_rest, &
          qn_filter_conn, ignore_sub_for_qn)
     call connection_table_fill (connection_table, &
          state_in1, state_in2, &
          connection_index, prt_is_connected)
     call make_product_interaction (eval%interaction_t, &
          n_in, n_vir, n_out, &
          connection_table, &
          prt_map_in, prt_is_connected, &
          qn_mask_in, qn_mask_conn_initial, &
          qn_mask_conn, qn_filter_conn, qn_mask_rest)
     call make_pairing_array (eval%pairing_array, &
          eval%get_n_matrix_elements (), &
          connection_table)
     call record_links (eval%interaction_t, &
          int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, &
          prt_is_connected, connections_are_resonant)
     call connection_table_final (connection_table)
 
 
     if (eval%get_n_matrix_elements () == 0) then
        print *, "Evaluator product"
        print *, "First interaction"
        call int_in1%basic_write (col_verbose=.true.)
        print *
        print *, "Second interaction"
        call int_in2%basic_write (col_verbose=.true.)
        print *
        call msg_fatal ("Product of density matrices is empty", &
            [var_str ("   --------------------------------------------"), &
             var_str ("This happens when two density matrices are convoluted "), &
             var_str ("but the processes they belong to (e.g., production "), &
             var_str ("and decay) do not match. This could happen if the "), &
             var_str ("beam specification does not match the hard "), &
             var_str ("process. Or it may indicate a WHIZARD bug.")])
     end if
 
   contains
 
     subroutine compute_index_bounds_and_mappings &
          (int1, int2, n_conn, &
           n_in, n_vir, n_out, n_tot, &
           n_rest, prt_map_in, prt_map_conn)
       class(interaction_t), intent(in) :: int1, int2
       integer, intent(in) :: n_conn
       integer, intent(out) :: n_in, n_vir, n_out, n_tot
       integer, dimension(2), intent(out) :: n_rest
       type(index_map_t), dimension(2), intent(out) :: prt_map_in
       type(index_map_t), intent(out) :: prt_map_conn
       integer, dimension(:), allocatable :: index
       integer :: n_in1, n_vir1, n_out1
       integer :: n_in2, n_vir2, n_out2
       integer :: k
       n_in1  = int1%get_n_in  ()
       n_vir1 = int1%get_n_vir ()
       n_out1 = int1%get_n_out () - n_conn
       n_rest(1) = n_in1 + n_vir1 + n_out1
       n_in2  = int2%get_n_in  () - n_conn
       n_vir2 = int2%get_n_vir ()
       n_out2 = int2%get_n_out ()
       n_rest(2) = n_in2 + n_vir2 + n_out2
       n_in  = n_in1  + n_in2
       n_vir = n_vir1 + n_vir2 + n_conn
       n_out = n_out1 + n_out2
       n_tot = n_in + n_vir + n_out
       call index_map_init (prt_map_in, n_rest)
       call index_map_init (prt_map_conn, n_conn)
       allocate (index (n_tot))
       index = [ (i, i = 1, n_tot) ]
       prt_map_in(1)%entry(1 : n_in1) = index(  1 :   n_in1)
       k =     n_in1
       prt_map_in(2)%entry(1 : n_in2) = index(k + 1 : k + n_in2)
       k = k + n_in2
       prt_map_in(1)%entry(n_in1 + 1 : n_in1 + n_vir1) = index(k + 1 : k + n_vir1)
       k = k + n_vir1
       prt_map_in(2)%entry(n_in2 + 1 : n_in2 + n_vir2) = index(k + 1 : k + n_vir2)
       k = k + n_vir2
       prt_map_conn%entry = index(k + 1 : k + n_conn)
       k = k + n_conn
       prt_map_in(1)%entry(n_in1 + n_vir1 + 1 : n_rest(1)) = index(k + 1 : k + n_out1)
       k = k + n_out1
       prt_map_in(2)%entry(n_in2 + n_vir2 + 1 : n_rest(2)) = index(k + 1 : k + n_out2)
     end subroutine compute_index_bounds_and_mappings
 
     subroutine connection_table_init &
         (connection_table, state_in1, state_in2, qn_mask_conn, &
          n_conn, connection_index, n_rest, &
          qn_filter_conn, ignore_sub_for_qn_in)
       type(connection_table_t), intent(out) :: connection_table
       type(state_matrix_t), intent(in), target :: state_in1, state_in2
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_conn
       integer, intent(in) :: n_conn
       integer, dimension(:,:), intent(in) :: connection_index
       integer, dimension(2), intent(in) :: n_rest
       type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
       logical, intent(in), optional :: ignore_sub_for_qn_in
       integer, dimension(2) :: n_me_in
       type(state_iterator_t) :: it
       type(quantum_numbers_t), dimension(n_conn) :: qn
       integer :: i, me_index_in, me_index_conn, n_me_conn
       integer, dimension(2) :: me_count
       logical :: ignore_sub_for_qn, has_sub_qn
       integer :: i_beam_sub
       connection_table%n_conn = n_conn
       connection_table%n_rest = n_rest
       n_me_in(1) = state_in1%get_n_matrix_elements ()
       n_me_in(2) = state_in2%get_n_matrix_elements ()
       allocate (connection_table%index_conn (2))
       call index_map_init (connection_table%index_conn, n_me_in)
       connection_table%index_conn = 0
       call connection_table%state%init (n_counters = 2)
       do i = 1, 2
          select case (i)
          case (1);  call it%init (state_in1)
          case (2);  call it%init (state_in2)
          end select
          do while (it%is_valid ())
             qn = it%get_quantum_numbers (connection_index(:,i))
             call qn%undefine (qn_mask_conn)
             if (present (qn_filter_conn)) then
                if (.not. all (qn .match. qn_filter_conn)) then
                   call it%advance ();  cycle
                end if
             end if
             call quantum_numbers_canonicalize_color (qn)
             me_index_in = it%get_me_index ()
             ignore_sub_for_qn = .false.; if (present (ignore_sub_for_qn_in)) ignore_sub_for_qn = ignore_sub_for_qn_in
             has_sub_qn = .false.
             do i_beam_sub = 1, n_beams_rescaled
                has_sub_qn = has_sub_qn .or. any (qn%get_sub () == i_beam_sub)
             end do
             call connection_table%state%add_state (qn, &
                  counter_index = i, &
                  ignore_sub_for_qn = .not. (ignore_sub_for_qn .and. has_sub_qn), &
                  me_index = me_index_conn)
             call index_map_set_entry (connection_table%index_conn(i), &
                  me_index_in, me_index_conn)
             call it%advance ()
          end do
       end do
       n_me_conn = connection_table%state%get_n_matrix_elements ()
       connection_table%n_me_conn = n_me_conn
       allocate (connection_table%entry (n_me_conn))
       call it%init (connection_table%state)
       do while (it%is_valid ())
          i = it%get_me_index ()
          me_count = it%get_me_count ()
          call connection_entry_init (connection_table%entry(i), 2, 2, &
               it%get_quantum_numbers (), me_count, n_rest)
          call it%advance ()
       end do
     end subroutine connection_table_init
 
     subroutine connection_table_final (connection_table)
       type(connection_table_t), intent(inout) :: connection_table
       call connection_table%state%final ()
     end subroutine connection_table_final
 
     subroutine connection_table_write (connection_table, unit)
       type(connection_table_t), intent(in) :: connection_table
       integer, intent(in), optional :: unit
       integer :: i, j
       integer :: u
       u = given_output_unit (unit)
       write (u, *) "Connection table:"
       call connection_table%state%write (unit)
       if (allocated (connection_table%index_conn)) then
          write (u, *) "  Index mapping input => connection table:"
          do i = 1, size (connection_table%index_conn)
             write (u, *) "  Input state", i
             do j = 1, size (connection_table%index_conn(i))
                write (u, *)  j, &
                     index_map_get_entry (connection_table%index_conn(i), j)
             end do
          end do
       end if
       if (allocated (connection_table%entry)) then
          write (u, *) "  Connection table contents:"
          do i = 1, size (connection_table%entry)
             call connection_entry_write (connection_table%entry(i), unit)
          end do
       end if
       if (index_map_exists (connection_table%index_result)) then
          write (u, *) "  Index mapping connection table => output:"
          do i = 1, size (connection_table%index_result)
             write (u, *)  i, &
                  index_map_get_entry (connection_table%index_result, i)
          end do
       end if
     end subroutine connection_table_write
 
     subroutine connection_table_fill &
         (connection_table, state_in1, state_in2, &
          connection_index, prt_is_connected)
       type(connection_table_t), intent(inout) :: connection_table
       type(state_matrix_t), intent(in), target :: state_in1, state_in2
       integer, dimension(:,:), intent(in) :: connection_index
       type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
       type(state_iterator_t) :: it
       integer :: index_in, index_conn
       integer :: color_offset
       integer :: n_result_entries
       integer :: i, k
       color_offset = connection_table%state%get_max_color_value ()
       do i = 1, 2
          select case (i)
          case (1);  call it%init (state_in1)
          case (2);  call it%init (state_in2)
          end select
          do while (it%is_valid ())
             index_in = it%get_me_index ()
             index_conn = index_map_get_entry &
                               (connection_table%index_conn(i), index_in)
             if (index_conn /= 0) then
                call connection_entry_add_state &
                     (connection_table%entry(index_conn), i, &
                     index_in, it%get_quantum_numbers (), &
                     connection_index(:,i), prt_is_connected(i), &
                     color_offset)
             end if
             call it%advance ()
          end do
          color_offset = color_offset + state_in1%get_max_color_value ()
       end do
       n_result_entries = 0
       do k = 1, size (connection_table%entry)
          n_result_entries = &
               n_result_entries + product (connection_table%entry(k)%n_index)
       end do
       call index_map_init (connection_table%index_result, n_result_entries)
     end subroutine connection_table_fill
 
     subroutine connection_entry_add_state &
         (entry, i, index_in, qn_in, connection_index, prt_is_connected, &
          color_offset)
       type(connection_entry_t), intent(inout) :: entry
       integer, intent(in) :: i
       integer, intent(in) :: index_in
       type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
       integer, dimension(:), intent(in) :: connection_index
       type(prt_mask_t), intent(in) :: prt_is_connected
       integer, intent(in) :: color_offset
       integer :: c
       integer, dimension(:,:), allocatable :: color_map
       entry%count(i) = entry%count(i) + 1
       c = entry%count(i)
       call make_color_map (color_map, &
            qn_in(connection_index), entry%qn_conn)
       call index_map_set_entry (entry%index_in(i), c, index_in)
       entry%qn_in_list(i)%qn(:,c) = pack (qn_in, prt_is_connected%entry)
       call quantum_numbers_translate_color &
            (entry%qn_in_list(i)%qn(:,c), color_map, color_offset)
     end subroutine connection_entry_add_state
 
     subroutine make_product_interaction (int, &
          n_in, n_vir, n_out, &
          connection_table, &
          prt_map_in, prt_is_connected, &
          qn_mask_in, qn_mask_conn_initial, &
          qn_mask_conn, qn_filter_conn, qn_mask_rest)
       type(interaction_t), intent(out), target :: int
       integer, intent(in) :: n_in, n_vir, n_out
       type(connection_table_t), intent(inout), target :: connection_table
       type(index_map_t), dimension(2), intent(in) :: prt_map_in
       type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
       type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: &
            qn_mask_conn_initial
       type(quantum_numbers_mask_t), intent(in) :: qn_mask_conn
       type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
       type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_rest
       type(index_map_t), dimension(2) :: prt_index_in
       type(index_map_t) :: prt_index_conn
       integer :: n_tot, n_conn
       integer, dimension(2) :: n_rest
       integer :: i, j, k, m
       type(quantum_numbers_t), dimension(:), allocatable :: qn
       type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
       type(connection_entry_t), pointer :: entry
       integer :: result_index
       n_conn = connection_table%n_conn
       n_rest = connection_table%n_rest
       n_tot = sum (n_rest) + n_conn
       allocate (qn (n_tot), qn_mask (n_tot))
       do i = 1, 2
          call index_map_init (prt_index_in(i), n_rest(i))
          prt_index_in(i) = &
               prt_map_in(i)%entry ([ (j, j = 1, n_rest(i)) ])
       end do
       call index_map_init (prt_index_conn, n_conn)
       prt_index_conn = prt_map_conn%entry ([ (j, j = 1, n_conn) ])
       do i = 1, 2
          if (present (qn_mask_rest)) then
             qn_mask(prt_index_in(i)%entry) = &
                  pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) &
                  .or. qn_mask_rest
          else
             qn_mask(prt_index_in(i)%entry) = &
                  pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry)
          end if
       end do
       qn_mask(prt_index_conn%entry) = qn_mask_conn_initial .or. qn_mask_conn
       call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask = qn_mask)
       m = 1
       do i = 1, connection_table%n_me_conn
          entry => connection_table%entry(i)
          qn(prt_index_conn%entry) = &
               quantum_numbers_undefined (entry%qn_conn, qn_mask_conn)
          if (present (qn_filter_conn)) then
             if (.not. all (qn(prt_index_conn%entry) .match. qn_filter_conn)) &
                  cycle
          end if
          do j = 1, entry%n_index(1)
             qn(prt_index_in(1)%entry) = entry%qn_in_list(1)%qn(:,j)
             do k = 1, entry%n_index(2)
                qn(prt_index_in(2)%entry) = entry%qn_in_list(2)%qn(:,k)
                call int%add_state (qn, me_index = result_index)
                call index_map_set_entry &
                     (connection_table%index_result, m, result_index)
                m = m + 1
             end do
          end do
       end do
       call int%freeze ()
     end subroutine make_product_interaction
 
     subroutine make_pairing_array (pa, n_matrix_elements, connection_table)
       type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
       integer, intent(in) :: n_matrix_elements
       type(connection_table_t), intent(in), target :: connection_table
       type(connection_entry_t), pointer :: entry
       integer, dimension(:), allocatable :: n_entries
       integer :: i, j, k, m, r
       allocate (pa (n_matrix_elements))
       allocate (n_entries (n_matrix_elements))
       n_entries = 0
       do m = 1, size (connection_table%index_result)
          r = index_map_get_entry (connection_table%index_result, m)
          n_entries(r) = n_entries(r) + 1
       end do
       call pairing_array_init &
            (pa, n_entries, has_i2=.true., has_factor=.false.)
       m = 1
       n_entries = 0
       do i = 1, connection_table%n_me_conn
          entry => connection_table%entry(i)
          do j = 1, entry%n_index(1)
             do k = 1, entry%n_index(2)
                r = index_map_get_entry (connection_table%index_result, m)
                n_entries(r) = n_entries(r) + 1
                pa(r)%i1(n_entries(r)) = &
                     index_map_get_entry (entry%index_in(1), j)
                pa(r)%i2(n_entries(r)) = &
                     index_map_get_entry (entry%index_in(2), k)
                m = m + 1
             end do
          end do
       end do
     end subroutine make_pairing_array
 
     subroutine record_links (int, &
          int_in1, int_in2, connection_index, prt_map_in, prt_map_conn, &
          prt_is_connected, connections_are_resonant)
       class(interaction_t), intent(inout) :: int
       class(interaction_t), intent(in), target :: int_in1, int_in2
       integer, dimension(:,:), intent(in) :: connection_index
       type(index_map_t), dimension(2), intent(in) :: prt_map_in
       type(index_map_t), intent(in) :: prt_map_conn
       type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
       logical, intent(in), optional :: connections_are_resonant
       type(index_map_t), dimension(2) :: prt_map_all
       integer :: i, j, k, ival
       call index_map_init (prt_map_all(1), size (prt_is_connected(1)))
       k = 0
       j = 0
       do i = 1, size (prt_is_connected(1))
          if (prt_is_connected(1)%entry(i)) then
             j = j + 1
             ival = index_map_get_entry (prt_map_in(1), j)
             call index_map_set_entry (prt_map_all(1), i, ival)
          else
             k = k + 1
             ival = index_map_get_entry (prt_map_conn, k)
             call index_map_set_entry (prt_map_all(1), i, ival)
          end if
          call int%set_source_link (ival, int_in1, i)
       end do
       call int_in1%transfer_relations (int, prt_map_all(1)%entry)
       call index_map_init (prt_map_all(2), size (prt_is_connected(2)))
       j = 0
       do i = 1, size (prt_is_connected(2))
          if (prt_is_connected(2)%entry(i)) then
             j = j + 1
             ival = index_map_get_entry (prt_map_in(2), j)
             call index_map_set_entry (prt_map_all(2), i, ival)
             call int%set_source_link (ival, int_in2, i)
          else
             call index_map_set_entry (prt_map_all(2), i, 0)
          end if
       end do
       call int_in2%transfer_relations (int, prt_map_all(2)%entry)
       call int%relate_connections &
            (int_in2, connection_index(:,2), prt_map_all(2)%entry, &
            prt_map_conn%entry, connections_are_resonant)
     end subroutine record_links
 
   end subroutine evaluator_init_product
 
 @ %def evaluator_init_product
 @
 \subsection{Creating an evaluator: square}
 The generic initializer for an evaluator that squares a matrix element.
 Depending on the provided mask, we select the appropriate specific initializer
 for either diagonal or non-diagonal helicity density matrices.
 <<Evaluators: evaluator: TBP>>=
   procedure :: init_square => evaluator_init_square
 <<Evaluators: procedures>>=
   subroutine evaluator_init_square (eval, int_in, qn_mask, &
        col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
     class(evaluator_t), intent(out), target :: eval
     class(interaction_t), intent(in), target :: int_in
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
     integer, dimension(:,:), intent(in), optional :: col_flow_index
     complex(default), dimension(:), intent(in), optional :: col_factor
     integer, dimension(:), intent(in), optional :: col_index_hi
     logical, intent(in), optional :: expand_color_flows
     integer, intent(in), optional :: nc
     if (all (qn_mask%diagonal_helicity ())) then
        call eval%init_square_diag (int_in, qn_mask, &
             col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
     else
        call eval%init_square_nondiag (int_in, qn_mask, &
             col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
     end if
   end subroutine evaluator_init_square
 
 @ %def evaluator_init_square
 @
 \subsubsection{Color-summed squared matrix (diagonal helicities)}
 The initializer for an evaluator that squares a matrix element,
 including color factors.  The mask must be such that off-diagonal matrix
 elements are excluded.
 
 If [[color_flows]] is set, the evaluator keeps color-flow entries
 separate and drops all interfering color structures.  The color factors are
 set to unity in this case.
 
 There is only one input interaction.  The quantum-number mask is an
 array, one entry for each particle, so they can be treated
 individually.  For academic purposes, we allow for the number of
 colors being different from three (but 3 is the default).
 
 The algorithm is analogous to multiplication, with a few notable
 differences:
 \begin{enumerate}
 \item
   The connected particles are known, the correspondence is
   one-to-one.  All particles are connected, and the mapping of indices
   is trivial, which simplifies the following steps.
 \item
   [[accumulate_connected_states]]: The matrix of connected states
   encompasses all particles, but color indices are removed.  However,
   ghost states are still kept separate from physical color states.  No
   color-index reassignment is necessary.
 \item
   The table of connections contains single index and quantum-number
   arrays instead of pairs of them.  They are paired with themselves
   in all possible ways.
 \item
   [[make_squared_interaction]]: Now apply the predefined
   quantum-numbers mask, which usually collects all color states
   (physical and ghosts), and possibly a helicity sum.
 \item
   [[make_pairing_array]]: For each pair of input states, compute the
   color factor (including a potential ghost-parity sign) and store
   this in the pairing array together with the matrix-element indices
   for multiplication.
 \item
   [[record_links]]: This is again trivial due to the one-to-one
   correspondence.
 \end{enumerate}
 
 <<Evaluators: evaluator: TBP>>=
   procedure :: init_square_diag => evaluator_init_square_diag
 <<Evaluators: procedures>>=
   subroutine evaluator_init_square_diag (eval, int_in, qn_mask, &
        col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
 
     class(evaluator_t), intent(out), target :: eval
     class(interaction_t), intent(in), target :: int_in
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
     integer, dimension(:,:), intent(in), optional :: col_flow_index
     complex(default), dimension(:), intent(in), optional :: col_factor
     integer, dimension(:), intent(in), optional :: col_index_hi
     logical, intent(in), optional :: expand_color_flows
     integer, intent(in), optional :: nc
 
     integer :: n_in, n_vir, n_out, n_tot
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial
     type(state_matrix_t), pointer :: state_in
 
     type :: connection_table_t
       integer :: n_tot = 0
       integer :: n_me_conn = 0
       type(state_matrix_t) :: state
       type(index_map_t) :: index_conn
       type(connection_entry_t), dimension(:), allocatable :: entry
       type(index_map_t) :: index_result
     end type connection_table_t
     type(connection_table_t) :: connection_table
 
     logical :: sum_colors
     type(color_table_t) :: color_table
 
     if (present (expand_color_flows)) then
        sum_colors = .not. expand_color_flows
     else
        sum_colors = .true.
     end if
 
     if (sum_colors) then
        eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS
     else
        eval%type = EVAL_SQUARED_FLOWS
     end if
     eval%int_in1 => int_in
 
     n_in  = int_in%get_n_in  ()
     n_vir = int_in%get_n_vir ()
     n_out = int_in%get_n_out ()
     n_tot = int_in%get_n_tot ()
 
     state_in => int_in%get_state_matrix_ptr ()
 
     allocate (qn_mask_initial (n_tot))
     qn_mask_initial = int_in%get_mask ()
     call qn_mask_initial%set_color (sum_colors, mask_cg=.false.)
     if (sum_colors) then
        call color_table_init (color_table, state_in, n_tot)
        if (present (col_flow_index) .and. present (col_factor) &
            .and. present (col_index_hi)) then
           call color_table_set_color_factors &
                (color_table, col_flow_index, col_factor, col_index_hi)
        end if
     end if
 
     call connection_table_init (connection_table, state_in, &
          qn_mask_initial, qn_mask, n_tot)
     call connection_table_fill (connection_table, state_in)
     call make_squared_interaction (eval%interaction_t, &
          n_in, n_vir, n_out, n_tot, &
          connection_table, sum_colors, qn_mask_initial .or. qn_mask)
     call make_pairing_array (eval%pairing_array, &
          eval%get_n_matrix_elements (), &
          connection_table, sum_colors, color_table, n_in, n_tot, nc)
     call record_links (eval, int_in, n_tot)
     call connection_table_final (connection_table)
 
   contains
 
     subroutine connection_table_init &
          (connection_table, state_in, qn_mask_in, qn_mask, n_tot)
       type(connection_table_t), intent(out) :: connection_table
       type(state_matrix_t), intent(in), target :: state_in
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
       integer, intent(in) :: n_tot
       type(quantum_numbers_t), dimension(n_tot) :: qn
       type(state_iterator_t) :: it
       integer :: i, n_me_in, me_index_in
       integer :: me_index_conn, n_me_conn
       integer, dimension(1) :: me_count
       logical :: qn_passed
       connection_table%n_tot = n_tot
       n_me_in = state_in%get_n_matrix_elements ()
       call index_map_init (connection_table%index_conn, n_me_in)
       connection_table%index_conn = 0
       call connection_table%state%init (n_counters=1)
       call it%init (state_in)
       do while (it%is_valid ())
          qn = it%get_quantum_numbers ()
          if (all (quantum_numbers_are_physical (qn, qn_mask))) then
             call qn%undefine (qn_mask_in)
             qn_passed = .true.
             if (qn_passed) then
                me_index_in = it%get_me_index ()
                call connection_table%state%add_state (qn, &
                     counter_index = 1, me_index = me_index_conn)
                call index_map_set_entry (connection_table%index_conn, &
                     me_index_in, me_index_conn)
             end if
          end if
          call it%advance ()
       end do
       n_me_conn = connection_table%state%get_n_matrix_elements ()
       connection_table%n_me_conn = n_me_conn
       allocate (connection_table%entry (n_me_conn))
       call it%init (connection_table%state)
       do while (it%is_valid ())
          i = it%get_me_index ()
          me_count = it%get_me_count ()
          call connection_entry_init (connection_table%entry(i), 1, 2, &
               it%get_quantum_numbers (), me_count, [n_tot])
          call it%advance ()
       end do
     end subroutine connection_table_init
 
     subroutine connection_table_final (connection_table)
       type(connection_table_t), intent(inout) :: connection_table
       call connection_table%state%final ()
     end subroutine connection_table_final
 
     subroutine connection_table_write (connection_table, unit)
       type(connection_table_t), intent(in) :: connection_table
       integer, intent(in), optional :: unit
       integer :: i
       integer :: u
       u = given_output_unit (unit)
       write (u, *) "Connection table:"
       call connection_table%state%write (unit)
       if (index_map_exists (connection_table%index_conn)) then
          write (u, *) "  Index mapping input => connection table:"
          do i = 1, size (connection_table%index_conn)
             write (u, *)  i, &
                    index_map_get_entry (connection_table%index_conn, i)
          end do
       end if
       if (allocated (connection_table%entry)) then
          write (u, *) "  Connection table contents"
          do i = 1, size (connection_table%entry)
             call connection_entry_write (connection_table%entry(i), unit)
          end do
       end if
       if (index_map_exists (connection_table%index_result)) then
          write (u, *) "  Index mapping connection table => output"
          do i = 1, size (connection_table%index_result)
             write (u, *)  i, &
                   index_map_get_entry (connection_table%index_result, i)
          end do
       end if
     end subroutine connection_table_write
 
     subroutine connection_table_fill (connection_table, state)
       type(connection_table_t), intent(inout) :: connection_table
       type(state_matrix_t), intent(in), target :: state
       integer :: index_in, index_conn, n_result_entries
       type(state_iterator_t) :: it
       integer :: k
       call it%init (state)
       do while (it%is_valid ())
          index_in = it%get_me_index ()
          index_conn = &
               index_map_get_entry (connection_table%index_conn, index_in)
          if (index_conn /= 0) then
             call connection_entry_add_state &
                  (connection_table%entry(index_conn), &
                  index_in, it%get_quantum_numbers ())
          end if
          call it%advance ()
       end do
       n_result_entries = 0
       do k = 1, size (connection_table%entry)
          n_result_entries = &
               n_result_entries + connection_table%entry(k)%n_index(1) ** 2
       end do
       call index_map_init (connection_table%index_result, n_result_entries)
       connection_table%index_result = 0
     end subroutine connection_table_fill
 
     subroutine connection_entry_add_state (entry, index_in, qn_in)
       type(connection_entry_t), intent(inout) :: entry
       integer, intent(in) :: index_in
       type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
       integer :: c
       entry%count = entry%count + 1
       c = entry%count(1)
       call index_map_set_entry (entry%index_in(1), c, index_in)
       entry%qn_in_list(1)%qn(:,c) = qn_in
     end subroutine connection_entry_add_state
 
     subroutine make_squared_interaction (int, &
          n_in, n_vir, n_out, n_tot, &
          connection_table, sum_colors, qn_mask)
       type(interaction_t), intent(out), target :: int
       integer, intent(in) :: n_in, n_vir, n_out, n_tot
       type(connection_table_t), intent(inout), target :: connection_table
       logical, intent(in) :: sum_colors
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
       type(connection_entry_t), pointer :: entry
       integer :: result_index, n_contrib
       integer :: i, m
       type(quantum_numbers_t), dimension(n_tot) :: qn
       call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask)
       m = 0
       do i = 1, connection_table%n_me_conn
          entry => connection_table%entry(i)
          qn = quantum_numbers_undefined (entry%qn_conn, qn_mask)
          if (.not. sum_colors)   call qn(1:n_in)%invert_color ()
          call int%add_state (qn, me_index = result_index)
          n_contrib = entry%n_index(1) ** 2
          connection_table%index_result%entry(m+1:m+n_contrib) = result_index
          m = m + n_contrib
       end do
       call int%freeze ()
     end subroutine make_squared_interaction
 
     subroutine make_pairing_array (pa, &
          n_matrix_elements, connection_table, sum_colors, color_table, &
          n_in, n_tot, nc)
       type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
       integer, intent(in) :: n_matrix_elements
       type(connection_table_t), intent(in), target :: connection_table
       logical, intent(in) :: sum_colors
       type(color_table_t), intent(inout) :: color_table
       type(connection_entry_t), pointer :: entry
       integer, intent(in) :: n_in, n_tot
       integer, intent(in), optional :: nc
       integer, dimension(:), allocatable :: n_entries
       integer :: i, k, l, ks, ls, m, r
       integer :: color_multiplicity_in
       allocate (pa (n_matrix_elements))
       allocate (n_entries (n_matrix_elements))
       n_entries = 0
       do m = 1, size (connection_table%index_result)
          r = index_map_get_entry (connection_table%index_result, m)
          n_entries(r) = n_entries(r) + 1
       end do
       call pairing_array_init &
            (pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors)
       m = 1
       n_entries = 0
       do i = 1, connection_table%n_me_conn
          entry => connection_table%entry(i)
          do k = 1, entry%n_index(1)
             if (sum_colors) then
                color_multiplicity_in = product (abs &
                     (entry%qn_in_list(1)%qn(:n_in, k)%get_color_type ()))
                do l = 1, entry%n_index(1)
                   r = index_map_get_entry (connection_table%index_result, m)
                   n_entries(r) = n_entries(r) + 1
                   ks = index_map_get_entry (entry%index_in(1), k)
                   ls = index_map_get_entry (entry%index_in(1), l)
                   pa(r)%i1(n_entries(r)) = ks
                   pa(r)%i2(n_entries(r)) = ls
                   pa(r)%factor(n_entries(r)) = &
                        color_table_get_color_factor (color_table, ks, ls, nc) &
                        / color_multiplicity_in
                   m = m + 1
                end do
             else
                r = index_map_get_entry (connection_table%index_result, m)
                n_entries(r) = n_entries(r) + 1
                ks = index_map_get_entry (entry%index_in(1), k)
                pa(r)%i1(n_entries(r)) = ks
                m = m + 1
             end if
          end do
       end do
     end subroutine make_pairing_array
 
     subroutine record_links (int, int_in, n_tot)
       class(interaction_t), intent(inout) :: int
       class(interaction_t), intent(in), target :: int_in
       integer, intent(in) :: n_tot
       integer, dimension(n_tot) :: map
       integer :: i
       do i = 1, n_tot
          call int%set_source_link (i, int_in, i)
       end do
       map = [ (i, i = 1, n_tot) ]
       call int_in%transfer_relations (int, map)
     end subroutine record_links
 
   end subroutine evaluator_init_square_diag
 
 @ %def evaluator_init_square_diag
 @
 \subsubsection{Color-summed squared matrix (support nodiagonal helicities)}
 The initializer for an evaluator that squares a matrix element,
 including color factors.  Unless requested otherwise by the
 quantum-number mask, the result contains off-diagonal matrix elements.
 (The input interaction must be diagonal since it represents an
 amplitude, not a density matrix.)
 
 There is only one input interaction.  The quantum-number mask is an
 array, one entry for each particle, so they can be treated
 individually.  For academic purposes, we allow for the number of
 colors being different from three (but 3 is the default).
 
 The algorithm is analogous to the previous one, with some additional
 complications due to the necessity to loop over two helicity indices.
 <<Evaluators: evaluator: TBP>>=
   procedure :: init_square_nondiag => evaluator_init_square_nondiag
 <<Evaluators: procedures>>=
   subroutine evaluator_init_square_nondiag (eval, int_in, qn_mask, &
        col_flow_index, col_factor, col_index_hi, expand_color_flows, nc)
 
     class(evaluator_t), intent(out), target :: eval
     class(interaction_t), intent(in), target :: int_in
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
     integer, dimension(:,:), intent(in), optional :: col_flow_index
     complex(default), dimension(:), intent(in), optional :: col_factor
     integer, dimension(:), intent(in), optional :: col_index_hi
     logical, intent(in), optional :: expand_color_flows
     integer, intent(in), optional :: nc
 
     integer :: n_in, n_vir, n_out, n_tot
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask_initial
     type(state_matrix_t), pointer :: state_in
 
     type :: connection_table_t
       integer :: n_tot = 0
       integer :: n_me_conn = 0
       type(state_matrix_t) :: state
       type(index_map2_t) :: index_conn
       type(connection_entry_t), dimension(:), allocatable :: entry
       type(index_map_t) :: index_result
     end type connection_table_t
     type(connection_table_t) :: connection_table
 
     logical :: sum_colors
     type(color_table_t) :: color_table
 
     if (present (expand_color_flows)) then
        sum_colors = .not. expand_color_flows
     else
        sum_colors = .true.
     end if
 
     if (sum_colors) then
        eval%type = EVAL_SQUARE_WITH_COLOR_FACTORS
     else
        eval%type = EVAL_SQUARED_FLOWS
     end if
     eval%int_in1 => int_in
 
     n_in  = int_in%get_n_in  ()
     n_vir = int_in%get_n_vir ()
     n_out = int_in%get_n_out ()
     n_tot = int_in%get_n_tot ()
 
     state_in => int_in%get_state_matrix_ptr ()
 
     allocate (qn_mask_initial (n_tot))
     qn_mask_initial = int_in%get_mask ()
     call qn_mask_initial%set_color (sum_colors, mask_cg=.false.)
     if (sum_colors) then
        call color_table_init (color_table, state_in, n_tot)
        if (present (col_flow_index) .and. present (col_factor) &
            .and. present (col_index_hi)) then
           call color_table_set_color_factors &
                (color_table, col_flow_index, col_factor, col_index_hi)
        end if
     end if
 
     call connection_table_init (connection_table, state_in, &
          qn_mask_initial, qn_mask, n_tot)
     call connection_table_fill (connection_table, state_in)
     call make_squared_interaction (eval%interaction_t, &
          n_in, n_vir, n_out, n_tot, &
          connection_table, sum_colors, qn_mask_initial .or. qn_mask)
     call make_pairing_array (eval%pairing_array, &
          eval%get_n_matrix_elements (), &
          connection_table, sum_colors, color_table, n_in, n_tot, nc)
     call record_links (eval, int_in, n_tot)
     call connection_table_final (connection_table)
 
   contains
 
     subroutine connection_table_init &
          (connection_table, state_in, qn_mask_in, qn_mask, n_tot)
       type(connection_table_t), intent(out) :: connection_table
       type(state_matrix_t), intent(in), target :: state_in
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
       integer, intent(in) :: n_tot
       type(quantum_numbers_t), dimension(n_tot) :: qn1, qn2, qn
       type(state_iterator_t) :: it1, it2, it
       integer :: i, n_me_in, me_index_in1, me_index_in2
       integer :: me_index_conn, n_me_conn
       integer, dimension(1) :: me_count
       logical :: qn_passed
       connection_table%n_tot = n_tot
       n_me_in = state_in%get_n_matrix_elements ()
       call index_map2_init (connection_table%index_conn, n_me_in)
       connection_table%index_conn = 0
       call connection_table%state%init (n_counters=1)
       call it1%init (state_in)
       do while (it1%is_valid ())
          qn1 = it1%get_quantum_numbers ()
          me_index_in1 = it1%get_me_index ()
          call it2%init (state_in)
          do while (it2%is_valid ())
             qn2 = it2%get_quantum_numbers ()
             if (all (quantum_numbers_are_compatible (qn1, qn2, qn_mask))) then
                qn = qn1 .merge. qn2
                call qn%undefine (qn_mask_in)
                qn_passed = .true.
                if (qn_passed) then
                   me_index_in2 = it2%get_me_index ()
                   call connection_table%state%add_state (qn, &
                        counter_index = 1, me_index = me_index_conn)
                   call index_map2_set_entry (connection_table%index_conn, &
                        me_index_in1, me_index_in2, me_index_conn)
                end if
             end if
             call it2%advance ()
          end do
          call it1%advance ()
       end do
       n_me_conn = connection_table%state%get_n_matrix_elements ()
       connection_table%n_me_conn = n_me_conn
       allocate (connection_table%entry (n_me_conn))
       call it%init (connection_table%state)
       do while (it%is_valid ())
          i = it%get_me_index ()
          me_count = it%get_me_count ()
          call connection_entry_init (connection_table%entry(i), 1, 2, &
               it%get_quantum_numbers (), me_count, [n_tot])
          call it%advance ()
       end do
     end subroutine connection_table_init
 
     subroutine connection_table_final (connection_table)
       type(connection_table_t), intent(inout) :: connection_table
       call connection_table%state%final ()
     end subroutine connection_table_final
 
     subroutine connection_table_write (connection_table, unit)
       type(connection_table_t), intent(in) :: connection_table
       integer, intent(in), optional :: unit
       integer :: i, j
       integer :: u
       u = given_output_unit (unit)
       write (u, *) "Connection table:"
       call connection_table%state%write (unit)
       if (index_map2_exists (connection_table%index_conn)) then
          write (u, *) "  Index mapping input => connection table:"
          do i = 1, size (connection_table%index_conn)
             do j = 1, size (connection_table%index_conn)
                write (u, *)  i, j, &
                     index_map2_get_entry (connection_table%index_conn, i, j)
             end do
          end do
       end if
       if (allocated (connection_table%entry)) then
          write (u, *) "  Connection table contents"
          do i = 1, size (connection_table%entry)
             call connection_entry_write (connection_table%entry(i), unit)
          end do
       end if
       if (index_map_exists (connection_table%index_result)) then
          write (u, *) "  Index mapping connection table => output"
          do i = 1, size (connection_table%index_result)
             write (u, *)  i, &
                  index_map_get_entry (connection_table%index_result, i)
          end do
       end if
     end subroutine connection_table_write
 
     subroutine connection_table_fill (connection_table, state)
       type(connection_table_t), intent(inout), target :: connection_table
       type(state_matrix_t), intent(in), target :: state
       integer :: index1_in, index2_in, index_conn, n_result_entries
       type(state_iterator_t) :: it1, it2
       integer :: k
       call it1%init (state)
       do while (it1%is_valid ())
          index1_in = it1%get_me_index ()
          call it2%init (state)
          do while (it2%is_valid ())
             index2_in = it2%get_me_index ()
             index_conn = index_map2_get_entry &
                             (connection_table%index_conn, index1_in, index2_in)
             if (index_conn /= 0) then
                call connection_entry_add_state &
                     (connection_table%entry(index_conn), &
                      index1_in, index2_in, &
                      it1%get_quantum_numbers () &
                      .merge. &
                      it2%get_quantum_numbers ())
             end if
             call it2%advance ()
          end do
          call it1%advance ()
       end do
       n_result_entries = 0
       do k = 1, size (connection_table%entry)
          n_result_entries = &
               n_result_entries + connection_table%entry(k)%n_index(1)
       end do
       call index_map_init (connection_table%index_result, n_result_entries)
       connection_table%index_result = 0
     end subroutine connection_table_fill
 
     subroutine connection_entry_add_state (entry, index1_in, index2_in, qn_in)
       type(connection_entry_t), intent(inout) :: entry
       integer, intent(in) :: index1_in, index2_in
       type(quantum_numbers_t), dimension(:), intent(in) :: qn_in
       integer :: c
       entry%count = entry%count + 1
       c = entry%count(1)
       call index_map_set_entry (entry%index_in(1), c, index1_in)
       call index_map_set_entry (entry%index_in(2), c, index2_in)
       entry%qn_in_list(1)%qn(:,c) = qn_in
     end subroutine connection_entry_add_state
 
     subroutine make_squared_interaction (int, &
          n_in, n_vir, n_out, n_tot, &
          connection_table, sum_colors, qn_mask)
       type(interaction_t), intent(out), target :: int
       integer, intent(in) :: n_in, n_vir, n_out, n_tot
       type(connection_table_t), intent(inout), target :: connection_table
       logical, intent(in) :: sum_colors
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
       type(connection_entry_t), pointer :: entry
       integer :: result_index
       integer :: i, k, m
       type(quantum_numbers_t), dimension(n_tot) :: qn
       call eval%interaction_t%basic_init (n_in, n_vir, n_out, mask=qn_mask)
       m = 0
       do i = 1, connection_table%n_me_conn
          entry => connection_table%entry(i)
          do k = 1, size (entry%qn_in_list(1)%qn, 2)
             qn = quantum_numbers_undefined &
                     (entry%qn_in_list(1)%qn(:,k), qn_mask)
             if (.not. sum_colors)  call qn(1:n_in)%invert_color ()
             call int%add_state (qn, me_index = result_index)
             call index_map_set_entry (connection_table%index_result, m + 1, &
                  result_index)
             m = m + 1
          end do
       end do
       call int%freeze ()
     end subroutine make_squared_interaction
 
     subroutine make_pairing_array (pa, &
          n_matrix_elements, connection_table, sum_colors, color_table, &
          n_in, n_tot, nc)
       type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
       integer, intent(in) :: n_matrix_elements
       type(connection_table_t), intent(in), target :: connection_table
       logical, intent(in) :: sum_colors
       type(color_table_t), intent(inout) :: color_table
       type(connection_entry_t), pointer :: entry
       integer, intent(in) :: n_in, n_tot
       integer, intent(in), optional :: nc
       integer, dimension(:), allocatable :: n_entries
       integer :: i, k, k1s, k2s, m, r
       integer :: color_multiplicity_in
       allocate (pa (n_matrix_elements))
       allocate (n_entries (n_matrix_elements))
       n_entries = 0
       do m = 1, size (connection_table%index_result)
          r = index_map_get_entry (connection_table%index_result, m)
          n_entries(r) = n_entries(r) + 1
       end do
       call pairing_array_init &
            (pa, n_entries, has_i2 = sum_colors, has_factor = sum_colors)
       m = 1
       n_entries = 0
       do i = 1, connection_table%n_me_conn
          entry => connection_table%entry(i)
          do k = 1, entry%n_index(1)
             r = index_map_get_entry (connection_table%index_result, m)
             n_entries(r) = n_entries(r) + 1
             if (sum_colors) then
                k1s = index_map_get_entry (entry%index_in(1), k)
                k2s = index_map_get_entry (entry%index_in(2), k)
                pa(r)%i1(n_entries(r)) = k1s
                pa(r)%i2(n_entries(r)) = k2s
                color_multiplicity_in = product (abs &
                     (entry%qn_in_list(1)%qn(:n_in, k)%get_color_type ()))
                pa(r)%factor(n_entries(r)) = &
                     color_table_get_color_factor (color_table, k1s, k2s, nc) &
                     / color_multiplicity_in
             else
                k1s = index_map_get_entry (entry%index_in(1), k)
                pa(r)%i1(n_entries(r)) = k1s
             end if
             m = m + 1
          end do
       end do
     end subroutine make_pairing_array
 
     subroutine record_links (int, int_in, n_tot)
       class(interaction_t), intent(inout) :: int
       class(interaction_t), intent(in), target :: int_in
       integer, intent(in) :: n_tot
       integer, dimension(n_tot) :: map
       integer :: i
       do i = 1, n_tot
          call int%set_source_link (i, int_in, i)
       end do
       map = [ (i, i = 1, n_tot) ]
       call int_in%transfer_relations (int, map)
     end subroutine record_links
 
   end subroutine evaluator_init_square_nondiag
 
 @ %def evaluator_init_square_nondiag
 @
 \subsubsection{Copy with additional contracted color states}
 This evaluator involves no square or multiplication, its matrix
 elements are just copies of the (single) input interaction.  However,
 the state matrix of the interaction contains additional states that
 have color indices contracted.  This is used for copies of the beam or
 structure-function interactions that need to match the hard
 interaction also in the case where its color indices coincide.
 <<Evaluators: evaluator: TBP>>=
   procedure :: init_color_contractions => evaluator_init_color_contractions
 <<Evaluators: procedures>>=
   subroutine evaluator_init_color_contractions (eval, int_in)
     class(evaluator_t), intent(out), target :: eval
     type(interaction_t), intent(in), target :: int_in
     integer :: n_in, n_vir, n_out, n_tot
     type(state_matrix_t) :: state_with_contractions
     integer, dimension(:), allocatable :: me_index
     integer, dimension(:), allocatable :: result_index
     eval%type = EVAL_COLOR_CONTRACTION
     eval%int_in1 => int_in
     n_in  = int_in%get_n_in  ()
     n_vir = int_in%get_n_vir ()
     n_out = int_in%get_n_out ()
     n_tot = int_in%get_n_tot ()
     state_with_contractions = int_in%get_state_matrix_ptr ()
     call state_with_contractions%add_color_contractions ()
     call make_contracted_interaction (eval%interaction_t, &
          me_index, result_index, &
          n_in, n_vir, n_out, n_tot, &
          state_with_contractions, int_in%get_mask ())
     call make_pairing_array (eval%pairing_array, me_index, result_index)
     call record_links (eval, int_in, n_tot)
     call state_with_contractions%final ()
 
   contains
 
     subroutine make_contracted_interaction (int, &
          me_index, result_index, &
          n_in, n_vir, n_out, n_tot, state, qn_mask)
       type(interaction_t), intent(out), target :: int
       integer, dimension(:), intent(out), allocatable :: me_index
       integer, dimension(:), intent(out), allocatable :: result_index
       integer, intent(in) :: n_in, n_vir, n_out, n_tot
       type(state_matrix_t), intent(in) :: state
       type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
       type(state_iterator_t) :: it
       integer :: n_me, i
       type(quantum_numbers_t), dimension(n_tot) :: qn
       call int%basic_init (n_in, n_vir, n_out, mask=qn_mask)
       n_me = state%get_n_leaves ()
       allocate (me_index (n_me))
       allocate (result_index (n_me))
       call it%init (state)
       i = 0
       do while (it%is_valid ())
          i = i + 1
          me_index(i) = it%get_me_index ()
          qn = it%get_quantum_numbers ()
          call int%add_state (qn, me_index = result_index(i))
          call it%advance ()
       end do
       call int%freeze ()
     end subroutine make_contracted_interaction
 
     subroutine make_pairing_array (pa, me_index, result_index)
       type(pairing_array_t), dimension(:), intent(out), allocatable :: pa
       integer, dimension(:), intent(in) :: me_index, result_index
       integer, dimension(:), allocatable :: n_entries
       integer :: n_matrix_elements, r, i, k
       !!! The result indices of the appended color contracted states
       !!! start counting from 1 again. For the pairing array, we currently
       !!! only take the first part of ascending indices into account
       !!! excluding the color contracted states.
       n_matrix_elements = size (me_index)
       k = 0
       do i = 1, n_matrix_elements
          r = result_index(i)
          if (r < i) exit
          k = r
       end do
       allocate (pa (k))
       allocate (n_entries (k))
       n_entries = 1
       call pairing_array_init &
            (pa, n_entries, has_i2=.false., has_factor=.false.)
       do i = 1, k
          r = result_index(i)
          pa(r)%i1(1) = me_index(i)
       end do
     end subroutine make_pairing_array
 
     subroutine record_links (int, int_in, n_tot)
       class(interaction_t), intent(inout) :: int
       class(interaction_t), intent(in), target :: int_in
       integer, intent(in) :: n_tot
       integer, dimension(n_tot) :: map
       integer :: i
       do i = 1, n_tot
          call int%set_source_link (i, int_in, i)
       end do
       map = [ (i, i = 1, n_tot) ]
       call int_in%transfer_relations (int, map)
     end subroutine record_links
 
   end subroutine evaluator_init_color_contractions
 
 @ %def evaluator_init_color_contractions
 @
 \subsubsection{Auxiliary procedure for initialization}
 This will become a standard procedure in F2008.  The result is true if
 the number of true values in the mask is odd.  We use the function for
 determining the ghost parity of a quantum-number array.
 
 [tho:] It's not used anymore and [[mod (count (mask), 2) == 1]] is
 a cooler implementation anyway.
 <<(UNUSED) Evaluators: procedures>>=
   function parity (mask)
     logical :: parity
     logical, dimension(:) :: mask
     integer :: i
     parity = .false.
     do i = 1, size (mask)
        if (mask(i))  parity = .not. parity
     end do
   end function parity
 
 @ %def parity
 @ Reassign external source links from one to another.
 <<Evaluators: public>>=
   public :: evaluator_reassign_links
 <<Evaluators: interfaces>>=
   interface evaluator_reassign_links
      module procedure evaluator_reassign_links_eval
      module procedure evaluator_reassign_links_int
   end interface
 
 <<Evaluators: procedures>>=
   subroutine evaluator_reassign_links_eval (eval, eval_src, eval_target)
     type(evaluator_t), intent(inout) :: eval
     type(evaluator_t), intent(in) :: eval_src
     type(evaluator_t), intent(in), target :: eval_target
     if (associated (eval%int_in1)) then
        if (eval%int_in1%get_tag () == eval_src%get_tag ()) then
           eval%int_in1 => eval_target%interaction_t
        end if
     end if
     if (associated (eval%int_in2)) then
        if (eval%int_in2%get_tag () == eval_src%get_tag ()) then
           eval%int_in2 => eval_target%interaction_t
        end if
     end if
     call interaction_reassign_links &
          (eval%interaction_t, eval_src%interaction_t, &
          eval_target%interaction_t)
   end subroutine evaluator_reassign_links_eval
 
   subroutine evaluator_reassign_links_int (eval, int_src, int_target)
     type(evaluator_t), intent(inout) :: eval
     type(interaction_t), intent(in) :: int_src
     type(interaction_t), intent(in), target :: int_target
     if (associated (eval%int_in1)) then
        if (eval%int_in1%get_tag () == int_src%get_tag ()) then
           eval%int_in1 => int_target
        end if
     end if
     if (associated (eval%int_in2)) then
        if (eval%int_in2%get_tag () == int_src%get_tag ()) then
           eval%int_in2 => int_target
        end if
     end if
     call interaction_reassign_links (eval%interaction_t, int_src, int_target)
   end subroutine evaluator_reassign_links_int
 
 @ %def evaluator_reassign_links
 @ Return flavor, momentum, and position of the first unstable particle
 present in the interaction.
 <<Evaluators: public>>=
   public :: evaluator_get_unstable_particle
 <<Evaluators: procedures>>=
   subroutine evaluator_get_unstable_particle (eval, flv, p, i)
     type(evaluator_t), intent(in) :: eval
     type(flavor_t), intent(out) :: flv
     type(vector4_t), intent(out) :: p
     integer, intent(out) :: i
     call interaction_get_unstable_particle (eval%interaction_t, flv, p, i)
   end subroutine evaluator_get_unstable_particle
 
 @ %def evaluator_get_unstable_particle
 @
 <<Evaluators: public>>=
   public :: evaluator_get_int_in_ptr
 <<Evaluators: procedures>>=
   function evaluator_get_int_in_ptr (eval, i) result (int_in)
     class(interaction_t), pointer :: int_in
     type(evaluator_t), intent(in), target :: eval
     integer, intent(in) :: i
     if (i == 1) then
        int_in => eval%int_in1
     else if (i == 2) then
        int_in => eval%int_in2
     else
        int_in => null ()
     end if
   end function evaluator_get_int_in_ptr
 
 @ %def evaluator_get_int_in_ptr
 @
 \subsection{Creating an evaluator: identity}
 The identity evaluator creates a copy of the first input evaluator; the second
 input is not used.
 
 All particles link back to the input evaluatorand  the internal
 relations are copied. As evaluation does take a shortcut by cloning the matrix
 elements, the pairing array is not used and does not have to be set up.
 
 <<Evaluators: evaluator: TBP>>=
   procedure :: init_identity => evaluator_init_identity
 <<Evaluators: procedures>>=
   subroutine evaluator_init_identity (eval, int)
     class(evaluator_t), intent(out), target :: eval
     class(interaction_t), intent(in), target :: int
     integer :: n_in, n_out, n_vir, n_tot
     integer :: i
     integer, dimension(:), allocatable :: map
     type(state_matrix_t), pointer :: state
     type(state_iterator_t) :: it
     eval%type = EVAL_IDENTITY
     eval%int_in1 => int
     nullify (eval%int_in2)
     n_in = int%get_n_in ()
     n_out = int%get_n_out ()
     n_vir = int%get_n_vir ()
     n_tot = int%get_n_tot ()
     call eval%interaction_t%basic_init (n_in, n_vir, n_out, &
        mask = int%get_mask (), &
        resonant = int%get_resonance_flags ())
     do i = 1, n_tot
        call eval%set_source_link (i, int, i)
     end do
     allocate (map(n_tot))
     map = [(i, i = 1, n_tot)]
     call int%transfer_relations (eval, map)
     state => int%get_state_matrix_ptr ()
     call it%init (state)
     do while (it%is_valid ())
        call eval%add_state (it%get_quantum_numbers (), &
             it%get_me_index ())
        call it%advance ()
     end do
     call eval%freeze ()
 
   end subroutine evaluator_init_identity
 
 @ %def evaluator_init_identity
 @
 \subsection {Creating an evaluator: quantum number sum}
 This evaluator operates on the diagonal of a density matrix and sums over the
 quantum numbers specified by the mask. The optional argument [[drop]] allows to
 drop a particle from the resulting density matrix. The handling of virtuals is
 not completely sane, especially in connection with dropping particles.
 
 When summing over matrix element entries, we keep the separation into
 entries and normalization (in the corresponding evaluation routine below).
 <<Evaluators: evaluator: TBP>>=
   procedure :: init_qn_sum => evaluator_init_qn_sum
 <<Evaluators: procedures>>=
   subroutine evaluator_init_qn_sum (eval, int, qn_mask, drop)
     class(evaluator_t), intent(out), target :: eval
     class(interaction_t), target, intent(in) :: int
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask
     logical, intent(in), optional, dimension(:) :: drop
     type(state_iterator_t) :: it_old, it_new
     integer, dimension(:), allocatable :: pairing_size, pairing_target, i_new
     integer, dimension(:), allocatable :: map
     integer :: n_in, n_out, n_vir, n_tot, n_me_old, n_me_new
     integer :: i, j
     type(state_matrix_t), pointer :: state_new, state_old
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     logical :: matched
     logical, dimension(size (qn_mask)) :: dropped
     integer :: ndropped
     integer, dimension(:), allocatable :: inotdropped
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
     logical, dimension(:), allocatable :: resonant
 
     eval%type = EVAL_QN_SUM
     eval%int_in1 => int
     nullify (eval%int_in2)
     if (present (drop)) then
        dropped = drop
     else
        dropped = .false.
     end if
     ndropped = count (dropped)
 
     n_in = int%get_n_in ()
     n_out = int%get_n_out () - ndropped
     n_vir = int%get_n_vir ()
     n_tot = int%get_n_tot () - ndropped
 
     allocate (inotdropped (n_tot))
     i = 1
     do j = 1, n_tot + ndropped
        if (dropped (j)) cycle
        inotdropped(i) = j
        i = i + 1
     end do
 
     allocate (mask(n_tot + ndropped))
     mask = int%get_mask ()
     allocate (resonant(n_tot + ndropped))
     resonant = int%get_resonance_flags ()
     call eval%interaction_t%basic_init (n_in, n_vir, n_out, &
          mask = mask(inotdropped) .or. qn_mask(inotdropped), &
          resonant = resonant(inotdropped))
     i = 1
     do j = 1, n_tot + ndropped
        if (dropped(j)) cycle
        call eval%set_source_link (i, int, j)
        i = i + 1
     end do
     allocate (map(n_tot + ndropped))
     i = 1
     do j = 1, n_tot + ndropped
        if (dropped (j)) then
           map(j) = 0
        else
           map(j) = i
           i = i + 1
        end if
     end do
     call int%transfer_relations (eval, map)
 
     n_me_old = int%get_n_matrix_elements ()
     allocate (pairing_size (n_me_old), source = 0)
     allocate (pairing_target (n_me_old), source = 0)
     pairing_size = 0
     state_old => int%get_state_matrix_ptr ()
     state_new => eval%get_state_matrix_ptr ()
     call it_old%init (state_old)
     allocate (qn(n_tot + ndropped))
     do while (it_old%is_valid ())
        qn = it_old%get_quantum_numbers ()
        if (.not. all (qn%are_diagonal ())) then
           call it_old%advance ()
           cycle
        end if
        matched = .false.
        call it_new%init (state_new)
        if (eval%get_n_matrix_elements () > 0) then
           do while (it_new%is_valid ())
              if (all (qn(inotdropped) .match. &
                 it_new%get_quantum_numbers ())) &
              then
                 matched = .true.
                 i = it_new%get_me_index ()
                 exit
              end if
              call it_new%advance ()
           end do
        end if
        if (.not. matched) then
           call eval%add_state (qn(inotdropped))
           i = eval%get_n_matrix_elements ()
        end if
        pairing_size(i) = pairing_size(i) + 1
        pairing_target(it_old%get_me_index ()) = i
        call it_old%advance ()
     end do
     call eval%freeze ()
 
     n_me_new = eval%get_n_matrix_elements ()
     allocate (eval%pairing_array (n_me_new))
     do i = 1, n_me_new
        call pairing_array_init (eval%pairing_array(i), &
             pairing_size(i), .false., .false.)
     end do
 
     allocate (i_new (n_me_new), source = 0)
     do i = 1, n_me_old
        j = pairing_target(i)
        if (j > 0) then
           i_new(j) = i_new(j) + 1
           eval%pairing_array(j)%i1(i_new(j)) = i
        end if
     end do
 
   end subroutine evaluator_init_qn_sum
 
 @ %def evaluator_init_qn_sum
 @
 \subsection{Evaluation}
 When the input interactions (which are pointed to in the pairings
 stored within the evaluator) are filled with values, we can activate
 the evaluator, i.e., calculate the result values which are stored in
 the interaction.
 
 The evaluation of matrix elements can be done in parallel.  A
 [[forall]] construct is not appropriate, however.  We would need
 [[do concurrent]] here.  Nevertheless, the evaluation functions are
 marked as [[pure]].
 <<Evaluators: evaluator: TBP>>=
   procedure :: evaluate => evaluator_evaluate
 <<Evaluators: procedures>>=
   subroutine evaluator_evaluate (eval)
     class(evaluator_t), intent(inout), target :: eval
     integer :: i
     select case (eval%type)
     case (EVAL_PRODUCT)
        do i = 1, size(eval%pairing_array)
           call eval%evaluate_product (i, &
                eval%int_in1, eval%int_in2, &
                eval%pairing_array(i)%i1, eval%pairing_array(i)%i2)
           if (debug2_active (D_QFT)) then
              print *, 'eval%pairing_array(i)%i1, eval%pairing_array(i)%i2 =    ', &
                   eval%pairing_array(i)%i1, eval%pairing_array(i)%i2
              print *, 'MEs =    ', &
                   eval%int_in1%get_matrix_element (eval%pairing_array(i)%i1), &
                   eval%int_in2%get_matrix_element (eval%pairing_array(i)%i2)
           end if
        end do
     case (EVAL_SQUARE_WITH_COLOR_FACTORS)
        do i = 1, size(eval%pairing_array)
           call eval%evaluate_product_cf (i, &
                eval%int_in1, eval%int_in1, &
                eval%pairing_array(i)%i1, eval%pairing_array(i)%i2, &
                eval%pairing_array(i)%factor)
        end do
     case (EVAL_SQUARED_FLOWS)
        do i = 1, size(eval%pairing_array)
           call eval%evaluate_square_c (i, &
                eval%int_in1, &
                eval%pairing_array(i)%i1)
        end do
     case (EVAL_COLOR_CONTRACTION)
        do i = 1, size(eval%pairing_array)
           call eval%evaluate_sum (i, &
                eval%int_in1, &
                eval%pairing_array(i)%i1)
        end do
     case (EVAL_IDENTITY)
        call eval%set_matrix_element (eval%int_in1)
     case (EVAL_QN_SUM)
        do i = 1, size (eval%pairing_array)
           call eval%evaluate_me_sum (i, &
              eval%int_in1, eval%pairing_array(i)%i1)
           call eval%set_norm (eval%int_in1%get_norm ())
        end do
     end select
   end subroutine evaluator_evaluate
 
 @ %def evaluator_evaluate
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[evaluators_ut.f90]]>>=
 <<File header>>
 
 module evaluators_ut
   use unit_tests
   use evaluators_uti
 
 <<Standard module head>>
 
 <<Evaluators: public test>>
 
 contains
 
 <<Evaluators: test driver>>
 
 end module evaluators_ut
 @ %def evaluators_ut
 @
 <<[[evaluators_uti.f90]]>>=
 <<File header>>
 
 module evaluators_uti
 
 <<Use kinds>>
   use lorentz
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use interactions
   use model_data
 
   use evaluators
 
 <<Standard module head>>
 
 <<Evaluators: test declarations>>
 
 contains
 
 <<Evaluators: tests>>
 
 end module evaluators_uti
 @ %def evaluators_ut
 @ API: driver for the unit tests below.
 <<Evaluators: public test>>=
   public :: evaluator_test
 <<Evaluators: test driver>>=
   subroutine evaluator_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Evaluators: execute tests>>
   end subroutine evaluator_test
 
 @ %def evaluator_test
 @ Test: Create two interactions.  The interactions are twofold
 connected.  The first connection has a helicity index that is kept,
 the second connection has a helicity index that is summed over.
 Concatenate the interactions in an evaluator, which thus contains a
 result interaction.  Fill the input interactions with values, activate
 the evaluator and print the result.
 <<Evaluators: execute tests>>=
   call test (evaluator_1, "evaluator_1", &
        "check evaluators (1)", &
        u, results)
 <<Evaluators: test declarations>>=
   public :: evaluator_1
 <<Evaluators: tests>>=
   subroutine evaluator_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(interaction_t), target :: int_qqtt, int_tbw, int1, int2
     type(flavor_t), dimension(:), allocatable :: flv
     type(color_t), dimension(:), allocatable :: col
     type(helicity_t), dimension(:), allocatable :: hel
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer :: f, c, h1, h2, h3
     type(vector4_t), dimension(4) :: p
     type(vector4_t), dimension(2) :: q
     type(quantum_numbers_mask_t) :: qn_mask_conn
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask2
     type(evaluator_t), target :: eval, eval2, eval3
 
     call model%init_sm_test ()
 
     write (u, "(A)")   "*** Evaluator for matrix product"
     write (u, "(A)")   "***   Construct interaction for qq -> tt"
     write (u, "(A)")
     call int_qqtt%basic_init (2, 0, 2, set_relations=.true.)
     allocate (flv (4), col (4), hel (4), qn (4))
     allocate (qn_mask2 (4))
     do c = 1, 2
        select case (c)
        case (1)
           call col%init_col_acl ([1, 0, 1, 0], [0, 2, 0, 2])
        case (2)
           call col%init_col_acl ([1, 0, 2, 0], [0, 1, 0, 2])
        end select
        do f = 1, 2
           call flv%init ([f, -f, 6, -6], model)
           do h1 = -1, 1, 2
              call hel(3)%init (h1)
              do h2 = -1, 1, 2
                 call hel(4)%init (h2)
                 call qn%init (flv, col, hel)
                 call int_qqtt%add_state (qn)
              end do
           end do
        end do
     end do
     call int_qqtt%freeze ()
     deallocate (flv, col, hel, qn)
     write (u, "(A)")  "***   Construct interaction for t -> bW"
     call int_tbw%basic_init (1, 0, 2, set_relations=.true.)
     allocate (flv (3), col (3), hel (3), qn (3))
     call flv%init ([6, 5, 24], model)
     call col%init_col_acl ([1, 1, 0], [0, 0, 0])
     do h1 = -1, 1, 2
        call hel(1)%init (h1)
        do h2 = -1, 1, 2
           call hel(2)%init (h2)
           do h3 = -1, 1
              call hel(3)%init (h3)
              call qn%init (flv, col, hel)
              call int_tbw%add_state (qn)
           end do
        end do
     end do
     call int_tbw%freeze ()
     deallocate (flv, col, hel, qn)
     write (u, "(A)")  "***   Link interactions"
     call int_tbw%set_source_link (1, int_qqtt, 3)
     qn_mask_conn = quantum_numbers_mask (.false.,.false.,.true.)
     write (u, "(A)")
     write (u, "(A)")  "***   Show input"
     call int_qqtt%basic_write (unit = u)
     write (u, "(A)")
     call int_tbw%basic_write (unit = u)
     write (u, "(A)")
     write (u, "(A)")  "***   Evaluate product"
     call eval%init_product (int_qqtt, int_tbw, qn_mask_conn)
     call eval%write (unit = u)
 
      call int1%basic_init (2, 0, 2, set_relations=.true.)
      call int2%basic_init (1, 0, 2, set_relations=.true.)
      p(1) = vector4_moving (1000._default, 1000._default, 3)
      p(2) = vector4_moving (200._default, 200._default, 2)
      p(3) = vector4_moving (100._default, 200._default, 1)
      p(4) = p(1) - p(2) - p(3)
      call int1%set_momenta (p)
      q(1) = vector4_moving (50._default,-50._default, 3)
      q(2) = p(2) + p(4) - q(1)
      call int2%set_momenta (q, outgoing=.true.)
      call int1%set_matrix_element ([(2._default,0._default), &
           (4._default,1._default), (-3._default,0._default)])
      call int2%set_matrix_element ([(-3._default,0._default), &
           (0._default,1._default), (1._default,2._default)])
      call eval%receive_momenta ()
      call eval%evaluate ()
      call int1%basic_write (unit = u)
      write (u, "(A)")
      call int2%basic_write (unit = u)
      write (u, "(A)")
      call eval%write (unit = u)
      write (u, "(A)")
      call int1%final ()
      call int2%final ()
      call eval%final ()
 
      write (u, "(A)")
      write (u, "(A)")   "*** Evaluator for matrix square"
      allocate (flv(4), col(4), qn(4))
      call int1%basic_init (2, 0, 2, set_relations=.true.)
      call flv%init ([1, -1, 21, 21], model)
      call col(1)%init ([1])
      call col(2)%init ([-2])
      call col(3)%init ([2, -3])
      call col(4)%init ([3, -1])
      call qn%init (flv, col)
      call int1%add_state (qn)
      call col(3)%init ([3, -1])
      call col(4)%init ([2, -3])
      call qn%init (flv, col)
      call int1%add_state (qn)
      call col(3)%init ([2, -1])
      call col(4)%init (.true.)
      call qn%init (flv, col)
      call int1%add_state (qn)
      call int1%freeze ()
      ! [qn_mask2 not set since default is false]
      call eval%init_square (int1, qn_mask2, nc=3)
      call eval2%init_square_nondiag (int1, qn_mask2)
      qn_mask2 = quantum_numbers_mask (.false., .true., .true.)
      call eval3%init_square_diag (eval, qn_mask2)
      call int1%set_matrix_element &
           ([(2._default,0._default), &
           (4._default,1._default), (-3._default,0._default)])
      call int1%set_momenta (p)
      call int1%basic_write (unit = u)
      write (u, "(A)")
      call eval%receive_momenta ()
      call eval%evaluate ()
      call eval%write (unit = u)
      write (u, "(A)")
      call eval2%receive_momenta ()
      call eval2%evaluate ()
      call eval2%write (unit = u)
      write (u, "(A)")
      call eval3%receive_momenta ()
      call eval3%evaluate ()
      call eval3%write (unit = u)
      call int1%final ()
      call eval%final ()
      call eval2%final ()
      call eval3%final ()
 
      call model%final ()
   end subroutine evaluator_1
 
 @ %def evaluator_1
 @
 <<Evaluators: execute tests>>=
   call test (evaluator_2, "evaluator_2", &
        "check evaluators (2)", &
        u, results)
 <<Evaluators: test declarations>>=
   public :: evaluator_2
 <<Evaluators: tests>>=
   subroutine evaluator_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(interaction_t), target :: int
     integer :: h1, h2, h3, h4
     type(helicity_t), dimension(4) :: hel
     type(color_t), dimension(4) :: col
     type(flavor_t), dimension(4) :: flv
     type(quantum_numbers_t), dimension(4) :: qn
     type(vector4_t), dimension(4) :: p
     type(evaluator_t) :: eval
     integer :: i
 
     call model%init_sm_test ()
 
     write (u, "(A)") "*** Creating interaction for e+ e- -> W+ W-"
     write (u, "(A)")
 
     call flv%init ([11, -11, 24, -24], model)
     do i = 1, 4
        call col(i)%init ()
     end do
     call int%basic_init (2, 0, 2, set_relations=.true.)
     do h1 = -1, 1, 2
        call hel(1)%init (h1)
        do h2 = -1, 1, 2
           call hel(2)%init (h2)
           do h3 = -1, 1
              call hel(3)%init (h3)
              do h4 = -1, 1
                 call hel(4)%init (h4)
                 call qn%init (flv, col, hel)
                 call int%add_state (qn)
              end do
           end do
        end do
     end do
     call int%freeze ()
     call int%set_matrix_element &
        ([(cmplx (i, kind=default), i = 1, 36)])
     p(1) = vector4_moving (1000._default, 1000._default, 3)
     p(2) = vector4_moving (1000._default, -1000._default, 3)
     p(3) = vector4_moving (1000._default, &
        sqrt (1E6_default - 80._default**2), 3)
     p(4) = p(1) + p(2) - p(3)
     call int%set_momenta (p)
     write (u, "(A)") "*** Setting up evaluator"
     write (u, "(A)")
 
     call eval%init_identity (int)
     write (u, "(A)") "*** Transferring momenta and evaluating"
     write (u, "(A)")
 
     call eval%receive_momenta ()
     call eval%evaluate ()
     write (u, "(A)")  "*******************************************************"
     write (u, "(A)")  "   Interaction dump"
     write (u, "(A)")  "*******************************************************"
     call int%basic_write (unit = u)
     write (u, "(A)")
     write (u, "(A)")  "*******************************************************"
     write (u, "(A)")  "   Evaluator dump"
     write (u, "(A)")  "*******************************************************"
     call eval%write (unit = u)
     write (u, "(A)")
     write (u, "(A)")   "*** cleaning up"
     call int%final ()
     call eval%final ()
 
     call model%final ()
   end subroutine evaluator_2
 
 @  %def evaluator_2
 @
 <<Evaluators: execute tests>>=
   call test (evaluator_3, "evaluator_3", &
        "check evaluators (3)", &
        u, results)
 <<Evaluators: test declarations>>=
   public :: evaluator_3
 <<Evaluators: tests>>=
   subroutine evaluator_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(interaction_t), target :: int
     integer :: h1, h2, h3, h4
     type(helicity_t), dimension(4) :: hel
     type(color_t), dimension(4) :: col
     type(flavor_t), dimension(4) :: flv1, flv2
     type(quantum_numbers_t), dimension(4) :: qn
     type(vector4_t), dimension(4) :: p
     type(evaluator_t) :: eval1, eval2, eval3
     type(quantum_numbers_mask_t), dimension(4) :: qn_mask
     integer :: i
 
     call model%init_sm_test ()
 
     write (u, "(A)")  "*** Creating interaction for e+/mu+ e-/mu- -> W+ W-"
     call flv1%init ([11, -11, 24, -24], model)
     call flv2%init ([13, -13, 24, -24], model)
     do i = 1, 4
        call col (i)%init ()
     end do
     call int%basic_init (2, 0, 2, set_relations=.true.)
     do h1 = -1, 1, 2
        call hel(1)%init (h1)
        do h2 = -1, 1, 2
           call hel(2)%init (h2)
           do h3 = -1, 1
              call hel(3)%init (h3)
              do h4 = -1, 1
                 call hel(4)%init (h4)
                 call qn%init (flv1, col, hel)
                 call int%add_state (qn)
                 call qn%init (flv2, col, hel)
                 call int%add_state (qn)
              end do
           end do
        end do
     end do
     call int%freeze ()
     call int%set_matrix_element &
        ([(cmplx (1, kind=default), i = 1, 72)])
     p(1) = vector4_moving (1000._default, 1000._default, 3)
     p(2) = vector4_moving (1000._default, -1000._default, 3)
     p(3) = vector4_moving (1000._default, &
        sqrt (1E6_default - 80._default**2), 3)
     p(4) = p(1) + p(2) - p(3)
     call int%set_momenta (p)
     write (u, "(A)")  "*** Setting up evaluators"
     call qn_mask%init (.false., .true., .true.)
     call eval1%init_qn_sum (int, qn_mask)
     call qn_mask%init (.true., .true., .true.)
     call eval2%init_qn_sum (int, qn_mask)
     call qn_mask%init (.false., .true., .false.)
     call eval3%init_qn_sum (int, qn_mask, &
       [.false., .false., .false., .true.])
     write (u, "(A)")  "*** Transferring momenta and evaluating"
     call eval1%receive_momenta ()
     call eval1%evaluate ()
     call eval2%receive_momenta ()
     call eval2%evaluate ()
     call eval3%receive_momenta ()
     call eval3%evaluate ()
     write (u, "(A)")  "*******************************************************"
     write (u, "(A)")  "   Interaction dump"
     write (u, "(A)")  "*******************************************************"
     call int%basic_write (unit = u)
     write (u, "(A)")
     write (u, "(A)")  "*******************************************************"
     write (u, "(A)")  "   Evaluator dump --- spin sum"
     write (u, "(A)")  "*******************************************************"
     call eval1%write (unit = u)
     call eval1%basic_write (unit = u)
     write (u, "(A)")  "*******************************************************"
     write (u, "(A)")  "   Evaluator dump --- spin / flavor sum"
     write (u, "(A)")  "*******************************************************"
     call eval2%write (unit = u)
     call eval2%basic_write (unit = u)
     write (u, "(A)")  "*******************************************************"
     write (u, "(A)")  "   Evaluator dump --- flavor sum, drop last W"
     write (u, "(A)")  "*******************************************************"
     call eval3%write (unit = u)
     call eval3%basic_write (unit = u)
     write (u, "(A)")
     write (u, "(A)")  "*** cleaning up"
     call int%final ()
     call eval1%final ()
     call eval2%final ()
     call eval3%final ()
 
     call model%final ()
   end subroutine evaluator_3
 
 @ %def evaluator_3
 @ This test evaluates a product with different quantum-number masks and
 filters for the linked entry.
 <<Evaluators: execute tests>>=
   call test (evaluator_4, "evaluator_4", &
        "check evaluator product with filter", &
        u, results)
 <<Evaluators: test declarations>>=
   public :: evaluator_4
 <<Evaluators: tests>>=
   subroutine evaluator_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(interaction_t), target :: int1, int2
     integer :: h1, h2, h3
     type(helicity_t), dimension(3) :: hel
     type(color_t), dimension(3) :: col
     type(flavor_t), dimension(2) :: flv1, flv2
     type(flavor_t), dimension(3) :: flv3, flv4
     type(quantum_numbers_t), dimension(3) :: qn
     type(evaluator_t) :: eval1, eval2, eval3, eval4
     type(quantum_numbers_mask_t) :: qn_mask
     type(flavor_t) :: flv_filter
     type(helicity_t) :: hel_filter
     type(color_t) :: col_filter
     type(quantum_numbers_t) :: qn_filter
     integer :: i
 
     write (u, "(A)")  "* Test output: evaluator_4"
     write (u, "(A)")  "*   Purpose: test evaluator products &
          &with mask and filter"
     write (u, "(A)")
 
     call model%init_sm_test ()
 
     write (u, "(A)")  "* Creating interaction for e- -> W+/Z"
     write (u, "(A)")
 
     call flv1%init ([11, 24], model)
     call flv2%init ([11, 23], model)
     do i = 1, 3
        call col(i)%init ()
     end do
     call int1%basic_init (1, 0, 1, set_relations=.true.)
     do h1 = -1, 1, 2
        call hel(1)%init (h1)
        do h2 = -1, 1
           call hel(2)%init (h2)
           call qn(:2)%init (flv1, col(:2), hel(:2))
           call int1%add_state (qn(:2))
           call qn(:2)%init (flv2, col(:2), hel(:2))
           call int1%add_state (qn(:2))
        end do
     end do
     call int1%freeze ()
     call int1%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Creating interaction for W+/Z -> u ubar/dbar"
     write (u, "(A)")
 
     call flv3%init ([24, 2, -1], model)
     call flv4%init ([23, 2, -2], model)
 
     call int2%basic_init (1, 0, 2, set_relations=.true.)
     do h1 = -1, 1
        call hel(1)%init (h1)
        do h2 = -1, 1, 2
           call hel(2)%init (h2)
           do h3 = -1, 1, 2
              call hel(3)%init (h3)
              call qn(:3)%init (flv3, col(:3), hel(:3))
              call int2%add_state (qn(:3))
              call qn(:3)%init (flv4, col(:3), hel(:3))
              call int2%add_state (qn(:3))
           end do
        end do
     end do
     call int2%freeze ()
 
     call int2%set_source_link (1, int1, 2)
     call int2%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Product evaluator"
     write (u, "(A)")
 
     call qn_mask%init (.false., .false., .false.)
     call eval1%init_product (int1, int2, qn_mask_conn = qn_mask)
     call eval1%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Product evaluator with helicity mask"
     write (u, "(A)")
 
     call qn_mask%init (.false., .false., .true.)
     call eval2%init_product (int1, int2, qn_mask_conn = qn_mask)
     call eval2%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Product with flavor filter and helicity mask"
     write (u, "(A)")
 
     call qn_mask%init (.false., .false., .true.)
     call flv_filter%init (24, model)
     call hel_filter%init ()
     call col_filter%init ()
     call qn_filter%init (flv_filter, col_filter, hel_filter)
     call eval3%init_product (int1, int2, &
          qn_mask_conn = qn_mask, qn_filter_conn = qn_filter)
     call eval3%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Product with helicity filter and mask"
     write (u, "(A)")
 
     call qn_mask%init (.false., .false., .true.)
     call flv_filter%init ()
     call hel_filter%init (0)
     call col_filter%init ()
     call qn_filter%init (flv_filter, col_filter, hel_filter)
     call eval4%init_product (int1, int2, &
          qn_mask_conn = qn_mask, qn_filter_conn = qn_filter)
     call eval4%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call eval1%final ()
     call eval2%final ()
     call eval3%final ()
     call eval4%final ()
 
     call int1%final ()
     call int2%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: evaluator_4"
 
   end subroutine evaluator_4
 
 @ %def evaluator_4
Index: trunk/src/process_integration/process_integration.nw
===================================================================
--- trunk/src/process_integration/process_integration.nw	(revision 8732)
+++ trunk/src/process_integration/process_integration.nw	(revision 8733)
@@ -1,19517 +1,19523 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: integration and process objects and such
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Integration and Process Objects}
 \includemodulegraph{process_integration}
 
 This is the central part of the \whizard\ package.  It provides the
 functionality for evaluating structure functions, kinematics and matrix
 elements, integration and event generation.  It combines the various
 parts that deal with those tasks individually and organizes the data
 transfer between them.
 
 \begin{description}
 \item[subevt\_expr]
   This enables process observables as (abstract) expressions, to be
   evaluated for each process call.
 \item[parton\_states]
   A [[parton_state_t]] object represents an elementary partonic
   interaction.  There are two versions: one for the isolated
   elementary process, one for the elementary process convoluted with
   the structure-function chain.  The parton state is an effective
   state.  It needs not coincide with the seed-kinematics state which is
   used in evaluating phase space.
 \item[process]
   Here, all pieces are combined for the purpose of evaluating the
   elementary processes.  The whole algorithm is coded in terms of
   abstract data types as defined in the appropriate modules: [[prc_core]]
   for matrix-element evaluation, [[prc_core_def]] for the associated
   configuration and driver, [[sf_base]] for beams and structure-functions,
   [[phs_base]] for phase space, and [[mci_base]] for integration and event
   generation.
 \item[process\_config]
 \item[process\_counter]
   Very simple object for statistics
 \item[process\_mci]
 \item[pcm]
 \item[kinematics]
 \item[instances]
   While the above modules set up all static information, the instances
   have the changing event data. There are term and process instances but
   no component instances.
 \item[process\_stacks]
   Process stacks collect process objects.
 \end{description}
 
 We combine here hard interactions, phase space, and (for scatterings)
 structure functions and interfaces them to the integration module.
 
 The process object implements the combination of a fixed beam and
 structure-function setup with a number of elementary processes.  The
 latter are called process components.  The process object
 represents an entity which is supposedly observable.  It should
 be meaningful to talk about the cross section of a process.
 
 The individual components of a process are, technically, processes
 themselves, but they may have unphysical cross sections which have to
 be added for a physical result.  Process components may be exclusive
 tree-level elementary processes, dipole subtraction term, loop
 corrections, etc.
 
 The beam and structure function setup is common to all process
 components.  Thus, there is only one instance of this part.
 
 The process may be a scattering process or a decay process.  In the
 latter case, there are no structure functions, and the beam setup
 consists of a single particle.  Otherwise, the two classes are treated
 on the same footing.
 
 Once a sampling point has been chosen, a process determines a set of
 partons with a correlated density matrix of quantum numbers.  In
 general, each sampling point will generate, for each process component,
 one or more distinct parton configurations.  This is the [[computed]]
 state.  The computed state is the subject of the multi-channel
 integration algorithm.
 
 For NLO computations, it is necessary to project the computed states
 onto another set of parton configurations (e.g., by recombining
 certain pairs).  This is the [[observed]] state.  When computing
 partonic observables, the information is taken from the observed
 state.
 
 For the purpose of event generation, we will later select one parton
 configuration from the observed state and collapse the correlated
 quantum state.  This configuration is then dressed by applying parton
 shower, decays and hadronization.  The decay chain, in particular,
 combines a scattering process with possible subsequent decay processes
 on the parton level, which are full-fledged process objects themselves.
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process observables}
 We define an abstract [[subevt_expr_t]] object as an extension of the
 [[subevt_t]] type.  The object contains a local variable list, variable
 instances (as targets for pointers in the variable list), and evaluation
 trees.  The evaluation trees reference both the variables and the [[subevt]].
 
 There are two instances of the abstract type: one for process instances, one
 for physical events.  Both have a common logical expression [[selection]]
 which determines whether the object passes user-defined cuts.
 
 The intention is that we fill the [[subevt_t]] base object and compute the
 variables once we have evaluated a kinematical phase space point (or a
 complete event).  We then evaluate the expressions and can use the results in
 further calculations.
 
 The [[process_expr_t]] extension contains furthermore scale and weight
 expressions.  The [[event_expr_t]] extension contains a reweighting-factor
 expression and a logical expression for event analysis.  In practice, we will
 link the variable list of the [[event_obs]] object to the variable list of the
 currently active [[process_obs]] object, such that the process variables are
 available to both objects.  Event variables are meaningful only for physical
 events.
 
 Note that there are unit tests, but they are deferred to the
 [[expr_tests]] module.
 <<[[subevt_expr.f90]]>>=
 <<File header>>
 module subevt_expr
 
 <<Use kinds>>
 <<Use strings>>
   use constants, only: zero, one
   use io_units
   use format_utils, only: write_separator
   use diagnostics
   use lorentz
   use subevents
   use variables
   use flavors
   use quantum_numbers
   use interactions
   use particles
   use expr_base
 
 <<Standard module head>>
 
 <<Subevt expr: public>>
 
 <<Subevt expr: types>>
 
 <<Subevt expr: interfaces>>
 
 contains
 
 <<Subevt expr: procedures>>
 
 end module subevt_expr
 @ %def subevt_expr
 @
 \subsection{Abstract base type}
 <<Subevt expr: types>>=
   type, extends (subevt_t), abstract :: subevt_expr_t
      logical :: subevt_filled = .false.
      type(var_list_t) :: var_list
      real(default) :: sqrts_hat = 0
      integer :: n_in = 0
      integer :: n_out = 0
      integer :: n_tot = 0
      logical :: has_selection = .false.
      class(expr_t), allocatable :: selection
      logical :: colorize_subevt = .false.
    contains
    <<Subevt expr: subevt expr: TBP>>
   end type subevt_expr_t
 
 @ %def subevt_expr_t
 @ Output: Base and extended version.  We already have a [[write]] routine for
 the [[subevt_t]] parent type.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: base_write => subevt_expr_write
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_write (object, unit, pacified)
     class(subevt_expr_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: pacified
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Local variables:"
     call write_separator (u)
     call var_list_write (object%var_list, u, follow_link=.false., &
          pacified = pacified)
     call write_separator (u)
     if (object%subevt_filled) then
        call object%subevt_t%write (u, pacified = pacified)
        if (object%has_selection) then
           call write_separator (u)
           write (u, "(1x,A)")  "Selection expression:"
           call write_separator (u)
           call object%selection%write (u)
        end if
     else
        write (u, "(1x,A)")  "subevt: [undefined]"
     end if
   end subroutine subevt_expr_write
 
 @ %def subevt_expr_write
 @ Finalizer.
 <<Subevt expr: subevt expr: TBP>>=
   procedure (subevt_expr_final), deferred :: final
   procedure :: base_final => subevt_expr_final
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_final (object)
     class(subevt_expr_t), intent(inout) :: object
     call object%var_list%final ()
     if (object%has_selection) then
        call object%selection%final ()
     end if
   end subroutine subevt_expr_final
 
 @ %def subevt_expr_final
 @
 \subsection{Initialization}
 Initialization: define local variables and establish pointers.
 
 The common variables are [[sqrts]] (the nominal beam energy, fixed),
 [[sqrts_hat]] (the actual energy), [[n_in]], [[n_out]], and [[n_tot]] for
 the [[subevt]].  With the exception of [[sqrts]], all are implemented as
 pointers to subobjects.
 <<Subevt expr: subevt expr: TBP>>=
   procedure (subevt_expr_setup_vars), deferred :: setup_vars
   procedure :: base_setup_vars => subevt_expr_setup_vars
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_setup_vars (expr, sqrts)
     class(subevt_expr_t), intent(inout), target :: expr
     real(default), intent(in) :: sqrts
     call expr%var_list%final ()
     call var_list_append_real (expr%var_list, &
          var_str ("sqrts"), sqrts, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("sqrts_hat"), expr%sqrts_hat, &
          is_known = expr%subevt_filled, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("n_in"), expr%n_in, &
          is_known = expr%subevt_filled, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("n_out"), expr%n_out, &
          is_known = expr%subevt_filled, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("n_tot"), expr%n_tot, &
          is_known = expr%subevt_filled, &
          locked = .true., verbose = .false., intrinsic = .true.)
   end subroutine subevt_expr_setup_vars
 
 @ %def subevt_expr_setup_vars
 @ Append the subevent expr (its base-type core) itself to the variable
 list, if it is not yet present.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: setup_var_self => subevt_expr_setup_var_self
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_setup_var_self (expr)
     class(subevt_expr_t), intent(inout), target :: expr
     if (.not. expr%var_list%contains (var_str ("@evt"))) then
        call var_list_append_subevt_ptr &
             (expr%var_list, &
             var_str ("@evt"), expr%subevt_t, &
             is_known = expr%subevt_filled, &
             locked = .true., verbose = .false., intrinsic=.true.)
     end if
   end subroutine subevt_expr_setup_var_self
 
 @ %def subevt_expr_setup_var_self
 @ Link a variable list to the local one.  This could be done event by event,
 but before evaluating expressions.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: link_var_list => subevt_expr_link_var_list
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_link_var_list (expr, var_list)
     class(subevt_expr_t), intent(inout) :: expr
     type(var_list_t), intent(in), target :: var_list
     call expr%var_list%link (var_list)
   end subroutine subevt_expr_link_var_list
 
 @ %def subevt_expr_link_var_list
 @ Compile the selection expression.  If there is no expression, the build
 method will not allocate the expression object.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: setup_selection => subevt_expr_setup_selection
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_setup_selection (expr, ef_cuts)
     class(subevt_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_cuts
     call ef_cuts%build (expr%selection)
     if (allocated (expr%selection)) then
        call expr%setup_var_self ()
        call expr%selection%setup_lexpr (expr%var_list)
        expr%has_selection = .true.
     end if
   end subroutine subevt_expr_setup_selection
 
 @ %def subevt_expr_setup_selection
 @ (De)activate color storage and evaluation for the expression.  The subevent
 particles will have color information.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: colorize => subevt_expr_colorize
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_colorize (expr, colorize_subevt)
     class(subevt_expr_t), intent(inout), target :: expr
     logical, intent(in) :: colorize_subevt
     expr%colorize_subevt = colorize_subevt
   end subroutine subevt_expr_colorize
 
 @ %def subevt_expr_colorize
 @
 \subsection{Evaluation}
 Reset to initial state, i.e., mark the [[subevt]] as invalid.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: reset_contents => subevt_expr_reset_contents
   procedure :: base_reset_contents => subevt_expr_reset_contents
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_reset_contents (expr)
     class(subevt_expr_t), intent(inout) :: expr
     expr%subevt_filled = .false.
   end subroutine subevt_expr_reset_contents
 
 @ %def subevt_expr_reset_contents
 @ Evaluate the selection expression and return the result.  There is also a
 deferred version: this should evaluate the remaining expressions if the event
 has passed.
 <<Subevt expr: subevt expr: TBP>>=
   procedure :: base_evaluate => subevt_expr_evaluate
 <<Subevt expr: procedures>>=
   subroutine subevt_expr_evaluate (expr, passed)
     class(subevt_expr_t), intent(inout) :: expr
     logical, intent(out) :: passed
     if (expr%has_selection) then
        call expr%selection%evaluate ()
        if (expr%selection%is_known ()) then
           passed = expr%selection%get_log ()
        else
           call msg_error ("Evaluate selection expression: result undefined")
           passed = .false.
        end if
     else
        passed = .true.
     end if
   end subroutine subevt_expr_evaluate
 
 @ %def subevt_expr_evaluate
 @
 \subsection{Implementation for partonic events}
 This implementation contains the expressions that we can evaluate for the
 partonic process during integration.
 <<Subevt expr: public>>=
   public :: parton_expr_t
 <<Subevt expr: types>>=
   type, extends (subevt_expr_t) :: parton_expr_t
      integer, dimension(:), allocatable :: i_beam
      integer, dimension(:), allocatable :: i_in
      integer, dimension(:), allocatable :: i_out
      logical :: has_scale = .false.
      logical :: has_fac_scale = .false.
      logical :: has_ren_scale = .false.
      logical :: has_weight = .false.
      class(expr_t), allocatable :: scale
      class(expr_t), allocatable :: fac_scale
      class(expr_t), allocatable :: ren_scale
      class(expr_t), allocatable :: weight
    contains
    <<Subevt expr: parton expr: TBP>>
   end type parton_expr_t
 
 @ %def parton_expr_t
 @ Finalizer.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: final => parton_expr_final
 <<Subevt expr: procedures>>=
   subroutine parton_expr_final (object)
     class(parton_expr_t), intent(inout) :: object
     call object%base_final ()
     if (object%has_scale) then
        call object%scale%final ()
     end if
     if (object%has_fac_scale) then
        call object%fac_scale%final ()
     end if
     if (object%has_ren_scale) then
        call object%ren_scale%final ()
     end if
     if (object%has_weight) then
        call object%weight%final ()
     end if
   end subroutine parton_expr_final
 
 @ %def parton_expr_final
 @ Output: continue writing the active expressions, after the common selection
 expression.
 
 Note: the [[prefix]] argument is declared in the [[write]] method of the
 [[subevt_t]] base type.  Here, it is unused.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: write => parton_expr_write
 <<Subevt expr: procedures>>=
   subroutine parton_expr_write (object, unit, prefix, pacified)
     class(parton_expr_t), intent(in) :: object
     integer, intent(in), optional :: unit
     character(*), intent(in), optional :: prefix
     logical, intent(in), optional :: pacified
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (u, pacified = pacified)
     if (object%subevt_filled) then
        if (object%has_scale) then
           call write_separator (u)
           write (u, "(1x,A)")  "Scale expression:"
           call write_separator (u)
           call object%scale%write (u)
        end if
        if (object%has_fac_scale) then
           call write_separator (u)
           write (u, "(1x,A)")  "Factorization scale expression:"
           call write_separator (u)
           call object%fac_scale%write (u)
        end if
        if (object%has_ren_scale) then
           call write_separator (u)
           write (u, "(1x,A)")  "Renormalization scale expression:"
           call write_separator (u)
           call object%ren_scale%write (u)
        end if
        if (object%has_weight) then
           call write_separator (u)
           write (u, "(1x,A)")  "Weight expression:"
           call write_separator (u)
           call object%weight%write (u)
        end if
     end if
   end subroutine parton_expr_write
 
 @ %def parton_expr_write
 @ Define variables.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: setup_vars => parton_expr_setup_vars
 <<Subevt expr: procedures>>=
   subroutine parton_expr_setup_vars (expr, sqrts)
     class(parton_expr_t), intent(inout), target :: expr
     real(default), intent(in) :: sqrts
     call expr%base_setup_vars (sqrts)
   end subroutine parton_expr_setup_vars
 
 @ %def parton_expr_setup_vars
 @ Compile the scale expressions.  If a pointer is disassociated, there is
 no expression.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: setup_scale => parton_expr_setup_scale
   procedure :: setup_fac_scale => parton_expr_setup_fac_scale
   procedure :: setup_ren_scale => parton_expr_setup_ren_scale
 <<Subevt expr: procedures>>=
   subroutine parton_expr_setup_scale (expr, ef_scale)
     class(parton_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_scale
     call ef_scale%build (expr%scale)
     if (allocated (expr%scale)) then
        call expr%setup_var_self ()
        call expr%scale%setup_expr (expr%var_list)
        expr%has_scale = .true.
     end if
   end subroutine parton_expr_setup_scale
 
   subroutine parton_expr_setup_fac_scale (expr, ef_fac_scale)
     class(parton_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_fac_scale
     call ef_fac_scale%build (expr%fac_scale)
     if (allocated (expr%fac_scale)) then
        call expr%setup_var_self ()
        call expr%fac_scale%setup_expr (expr%var_list)
        expr%has_fac_scale = .true.
     end if
   end subroutine parton_expr_setup_fac_scale
 
   subroutine parton_expr_setup_ren_scale (expr, ef_ren_scale)
     class(parton_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_ren_scale
     call ef_ren_scale%build (expr%ren_scale)
     if (allocated (expr%ren_scale)) then
        call expr%setup_var_self ()
        call expr%ren_scale%setup_expr (expr%var_list)
        expr%has_ren_scale = .true.
     end if
   end subroutine parton_expr_setup_ren_scale
 
 @ %def parton_expr_setup_scale
 @ %def parton_expr_setup_fac_scale
 @ %def parton_expr_setup_ren_scale
 @ Compile the weight expression.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: setup_weight => parton_expr_setup_weight
 <<Subevt expr: procedures>>=
   subroutine parton_expr_setup_weight (expr, ef_weight)
     class(parton_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_weight
     call ef_weight%build (expr%weight)
     if (allocated (expr%weight)) then
        call expr%setup_var_self ()
        call expr%weight%setup_expr (expr%var_list)
        expr%has_weight = .true.
     end if
   end subroutine parton_expr_setup_weight
 
 @ %def parton_expr_setup_weight
 @ Filling the partonic state consists of two parts.  The first routine
 prepares the subevt without assigning momenta.  It takes the particles from an
 [[interaction_t]].  It needs the indices and flavors for the beam,
 incoming, and outgoing particles.
 
 We can assume that the particle content of the subevt does not change.
 Therefore, we set the event variables [[n_in]], [[n_out]], [[n_tot]] already
 in this initialization step.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: setup_subevt => parton_expr_setup_subevt
 <<Subevt expr: procedures>>=
   subroutine parton_expr_setup_subevt (expr, int, &
        i_beam, i_in, i_out, f_beam, f_in, f_out)
     class(parton_expr_t), intent(inout) :: expr
     type(interaction_t), intent(in), target :: int
     integer, dimension(:), intent(in) :: i_beam, i_in, i_out
     type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
     allocate (expr%i_beam (size (i_beam)))
     allocate (expr%i_in (size (i_in)))
     allocate (expr%i_out (size (i_out)))
     expr%i_beam = i_beam
     expr%i_in = i_in
     expr%i_out = i_out
     call interaction_to_subevt (int, &
          expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
     call subevt_set_pdg_beam     (expr%subevt_t, f_beam%get_pdg ())
     call subevt_set_pdg_incoming (expr%subevt_t, f_in%get_pdg ())
     call subevt_set_pdg_outgoing (expr%subevt_t, f_out%get_pdg ())
     call subevt_set_p2_beam     (expr%subevt_t, f_beam%get_mass () ** 2)
     call subevt_set_p2_incoming (expr%subevt_t, f_in%get_mass ()   ** 2)
     call subevt_set_p2_outgoing (expr%subevt_t, f_out%get_mass ()  ** 2)
     expr%n_in  = size (i_in)
     expr%n_out = size (i_out)
     expr%n_tot = expr%n_in + expr%n_out
   end subroutine parton_expr_setup_subevt
 
 @ %def parton_expr_setup_subevt
 @ Transfer PDG codes, masses (initalization) and momenta to a
 predefined subevent.  We use the flavor assignment of the first
 branch in the interaction state matrix.  Only incoming and outgoing
 particles are transferred.  Switch momentum sign for incoming
 particles.
 <<Subevt expr: interfaces>>=
   interface interaction_momenta_to_subevt
      module procedure interaction_momenta_to_subevt_id
      module procedure interaction_momenta_to_subevt_tr
   end interface
 
 <<Subevt expr: procedures>>=
   subroutine interaction_to_subevt (int, j_beam, j_in, j_out, subevt)
     type(interaction_t), intent(in), target :: int
     integer, dimension(:), intent(in) :: j_beam, j_in, j_out
     type(subevt_t), intent(out) :: subevt
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: n_beam, n_in, n_out, i, j
     allocate (flv (int%get_n_tot ()))
     flv = quantum_numbers_get_flavor (int%get_quantum_numbers (1))
     n_beam = size (j_beam)
     n_in = size (j_in)
     n_out = size (j_out)
     call subevt_init (subevt, n_beam + n_in + n_out)
     do i = 1, n_beam
        j = j_beam(i)
        call subevt_set_beam (subevt, i, &
             flv(j)%get_pdg (), &
             vector4_null, &
             flv(j)%get_mass () ** 2)
     end do
     do i = 1, n_in
        j = j_in(i)
        call subevt_set_incoming (subevt, n_beam + i, &
             flv(j)%get_pdg (), &
             vector4_null, &
             flv(j)%get_mass () ** 2)
     end do
     do i = 1, n_out
        j = j_out(i)
        call subevt_set_outgoing (subevt, n_beam + n_in + i, &
             flv(j)%get_pdg (), &
             vector4_null, &
             flv(j)%get_mass () ** 2)
     end do
   end subroutine interaction_to_subevt
 
   subroutine interaction_momenta_to_subevt_id (int, j_beam, j_in, j_out, subevt)
     type(interaction_t), intent(in) :: int
     integer, dimension(:), intent(in) :: j_beam, j_in, j_out
     type(subevt_t), intent(inout) :: subevt
     call subevt_set_p_beam (subevt, - int%get_momenta (j_beam))
     call subevt_set_p_incoming (subevt, - int%get_momenta (j_in))
     call subevt_set_p_outgoing (subevt, int%get_momenta (j_out))
   end subroutine interaction_momenta_to_subevt_id
 
   subroutine interaction_momenta_to_subevt_tr &
        (int, j_beam, j_in, j_out, lt, subevt)
     type(interaction_t), intent(in) :: int
     integer, dimension(:), intent(in) :: j_beam, j_in, j_out
     type(subevt_t), intent(inout) :: subevt
     type(lorentz_transformation_t), intent(in) :: lt
     call subevt_set_p_beam &
          (subevt, - lt * int%get_momenta (j_beam))
     call subevt_set_p_incoming &
          (subevt, - lt * int%get_momenta (j_in))
     call subevt_set_p_outgoing &
          (subevt, lt * int%get_momenta (j_out))
   end subroutine interaction_momenta_to_subevt_tr
 
 @ %def interaction_momenta_to_subevt
 @ The second part takes the momenta from the interaction object and thus
 completes the subevt.  The partonic energy can then be computed.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: fill_subevt => parton_expr_fill_subevt
 <<Subevt expr: procedures>>=
   subroutine parton_expr_fill_subevt (expr, int)
     class(parton_expr_t), intent(inout) :: expr
     type(interaction_t), intent(in), target :: int
     call interaction_momenta_to_subevt (int, &
          expr%i_beam, expr%i_in, expr%i_out, expr%subevt_t)
     expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
     expr%subevt_filled = .true.
   end subroutine parton_expr_fill_subevt
 
 @ %def parton_expr_fill_subevt
 @ Evaluate, if the event passes the selection.  For absent expressions we take
 default values.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: evaluate => parton_expr_evaluate
 <<Subevt expr: procedures>>=
   subroutine parton_expr_evaluate &
        (expr, passed, scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
     class(parton_expr_t), intent(inout) :: expr
     logical, intent(out) :: passed
     real(default), intent(out) :: scale
     real(default), intent(out) :: fac_scale
     real(default), intent(out) :: ren_scale
     real(default), intent(out) :: weight
     real(default), intent(in), allocatable, optional :: scale_forced
     logical, intent(in), optional :: force_evaluation
     logical :: force_scale, force_eval
     force_scale = .false.; force_eval = .false.
     if (present (scale_forced))  force_scale = allocated (scale_forced)
     if (present (force_evaluation)) force_eval = force_evaluation
     call expr%base_evaluate (passed)
     if (passed .or. force_eval) then
        if (force_scale) then
           scale = scale_forced
        else if (expr%has_scale) then
           call expr%scale%evaluate ()
           if (expr%scale%is_known ()) then
              scale = expr%scale%get_real ()
           else
              call msg_error ("Evaluate scale expression: result undefined")
              scale = zero
           end if
        else
           scale = expr%sqrts_hat
        end if
        if (force_scale) then
           fac_scale = scale_forced
        else if (expr%has_fac_scale) then
           call expr%fac_scale%evaluate ()
           if (expr%fac_scale%is_known ()) then
              fac_scale = expr%fac_scale%get_real ()
           else
              call msg_error ("Evaluate factorization scale expression: &
                   &result undefined")
              fac_scale = zero
           end if
        else
           fac_scale = scale
        end if
        if (force_scale) then
           ren_scale = scale_forced
        else if (expr%has_ren_scale) then
           call expr%ren_scale%evaluate ()
           if (expr%ren_scale%is_known ()) then
              ren_scale = expr%ren_scale%get_real ()
           else
              call msg_error ("Evaluate renormalization scale expression: &
                   &result undefined")
              ren_scale = zero
           end if
        else
           ren_scale = scale
        end if
        if (expr%has_weight) then
           call expr%weight%evaluate ()
           if (expr%weight%is_known ()) then
              weight = expr%weight%get_real ()
           else
              call msg_error ("Evaluate weight expression: result undefined")
              weight = zero
           end if
        else
           weight = one
        end if
     else
        weight = zero
     end if
   end subroutine parton_expr_evaluate
 
 @ %def parton_expr_evaluate
 @ Return the beam/incoming parton indices.
 <<Subevt expr: parton expr: TBP>>=
   procedure :: get_beam_index => parton_expr_get_beam_index
   procedure :: get_in_index => parton_expr_get_in_index
 <<Subevt expr: procedures>>=
   subroutine parton_expr_get_beam_index (expr, i_beam)
     class(parton_expr_t), intent(in) :: expr
     integer, dimension(:), intent(out) :: i_beam
     i_beam = expr%i_beam
   end subroutine parton_expr_get_beam_index
 
   subroutine parton_expr_get_in_index (expr, i_in)
     class(parton_expr_t), intent(in) :: expr
     integer, dimension(:), intent(out) :: i_in
     i_in = expr%i_in
   end subroutine parton_expr_get_in_index
 
 @ %def parton_expr_get_beam_index
 @ %def parton_expr_get_in_index
 @
 \subsection{Implementation for full events}
 This implementation contains the expressions that we can evaluate for the
 full event.  It also contains data that pertain to the event, suitable
 for communication with external event formats.  These data
 simultaneously serve as pointer targets for the variable lists hidden
 in the expressions (eval trees).
 
 Squared matrix element and weight values: when reading events from
 file, the [[ref]] value is the number in the file, while the [[prc]]
 value is the number that we calculate from the momenta in the file,
 possibly with different parameters.  When generating events the first
 time, or if we do not recalculate, the numbers should coincide.
 Furthermore, the array of [[alt]] values is copied from an array of
 alternative event records.  These values should represent calculated
 values.
 <<Subevt expr: public>>=
   public :: event_expr_t
 <<Subevt expr: types>>=
   type, extends (subevt_expr_t) :: event_expr_t
      logical :: has_reweight = .false.
      logical :: has_analysis = .false.
      class(expr_t), allocatable :: reweight
      class(expr_t), allocatable :: analysis
      logical :: has_id = .false.
      type(string_t) :: id
      logical :: has_num_id = .false.
      integer :: num_id = 0
      logical :: has_index = .false.
      integer :: index = 0
      logical :: has_sqme_ref = .false.
      real(default) :: sqme_ref = 0
      logical :: has_sqme_prc = .false.
      real(default) :: sqme_prc = 0
      logical :: has_weight_ref = .false.
      real(default) :: weight_ref = 0
      logical :: has_weight_prc = .false.
      real(default) :: weight_prc = 0
      logical :: has_excess_prc = .false.
      real(default) :: excess_prc = 0
      integer :: n_alt = 0
      logical :: has_sqme_alt = .false.
      real(default), dimension(:), allocatable :: sqme_alt
      logical :: has_weight_alt = .false.
      real(default), dimension(:), allocatable :: weight_alt
    contains
    <<Subevt expr: event expr: TBP>>
   end type event_expr_t
 
 @ %def event_expr_t
 @ Finalizer for the expressions.
 <<Subevt expr: event expr: TBP>>=
   procedure :: final => event_expr_final
 <<Subevt expr: procedures>>=
   subroutine event_expr_final (object)
     class(event_expr_t), intent(inout) :: object
     call object%base_final ()
     if (object%has_reweight) then
        call object%reweight%final ()
     end if
     if (object%has_analysis) then
        call object%analysis%final ()
     end if
   end subroutine event_expr_final
 
 @ %def event_expr_final
 @ Output: continue writing the active expressions, after the common selection
 expression.
 
 Note: the [[prefix]] argument is declared in the [[write]] method of the
 [[subevt_t]] base type.  Here, it is unused.
 <<Subevt expr: event expr: TBP>>=
   procedure :: write => event_expr_write
 <<Subevt expr: procedures>>=
   subroutine event_expr_write (object, unit, prefix, pacified)
     class(event_expr_t), intent(in) :: object
     integer, intent(in), optional :: unit
     character(*), intent(in), optional :: prefix
     logical, intent(in), optional :: pacified
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (u, pacified = pacified)
     if (object%subevt_filled) then
        if (object%has_reweight) then
           call write_separator (u)
           write (u, "(1x,A)")  "Reweighting expression:"
           call write_separator (u)
           call object%reweight%write (u)
        end if
        if (object%has_analysis) then
           call write_separator (u)
           write (u, "(1x,A)")  "Analysis expression:"
           call write_separator (u)
           call object%analysis%write (u)
        end if
     end if
   end subroutine event_expr_write
 
 @ %def event_expr_write
 @ Initializer.  This is required only for the [[sqme_alt]] and
 [[weight_alt]] arrays.
 <<Subevt expr: event expr: TBP>>=
   procedure :: init => event_expr_init
 <<Subevt expr: procedures>>=
   subroutine event_expr_init (expr, n_alt)
     class(event_expr_t), intent(out) :: expr
     integer, intent(in), optional :: n_alt
     if (present (n_alt)) then
        expr%n_alt = n_alt
        allocate (expr%sqme_alt (n_alt), source = 0._default)
        allocate (expr%weight_alt (n_alt), source = 0._default)
     end if
   end subroutine event_expr_init
 
 @ %def event_expr_init
 @ Define variables.  We have the variables of the base type plus
 specific variables for full events.  There is the event index.
 <<Subevt expr: event expr: TBP>>=
   procedure :: setup_vars => event_expr_setup_vars
 <<Subevt expr: procedures>>=
   subroutine event_expr_setup_vars (expr, sqrts)
     class(event_expr_t), intent(inout), target :: expr
     real(default), intent(in) :: sqrts
     call expr%base_setup_vars (sqrts)
     call var_list_append_string_ptr (expr%var_list, &
          var_str ("$process_id"), expr%id, &
          is_known = expr%has_id, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("process_num_id"), expr%num_id, &
          is_known = expr%has_num_id, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("sqme"), expr%sqme_prc, &
          is_known = expr%has_sqme_prc, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("sqme_ref"), expr%sqme_ref, &
          is_known = expr%has_sqme_ref, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_int_ptr (expr%var_list, &
          var_str ("event_index"), expr%index, &
          is_known = expr%has_index, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("event_weight"), expr%weight_prc, &
          is_known = expr%has_weight_prc, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("event_weight_ref"), expr%weight_ref, &
          is_known = expr%has_weight_ref, &
          locked = .true., verbose = .false., intrinsic = .true.)
     call var_list_append_real_ptr (expr%var_list, &
          var_str ("event_excess"), expr%excess_prc, &
          is_known = expr%has_excess_prc, &
          locked = .true., verbose = .false., intrinsic = .true.)
   end subroutine event_expr_setup_vars
 
 @ %def event_expr_setup_vars
 @ Compile the analysis expression.  If the pointer is disassociated, there is
 no expression.
 <<Subevt expr: event expr: TBP>>=
   procedure :: setup_analysis => event_expr_setup_analysis
 <<Subevt expr: procedures>>=
   subroutine event_expr_setup_analysis (expr, ef_analysis)
     class(event_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_analysis
     call ef_analysis%build (expr%analysis)
     if (allocated (expr%analysis)) then
        call expr%setup_var_self ()
        call expr%analysis%setup_lexpr (expr%var_list)
        expr%has_analysis = .true.
     end if
   end subroutine event_expr_setup_analysis
 
 @ %def event_expr_setup_analysis
 @ Compile the reweight expression.
 <<Subevt expr: event expr: TBP>>=
   procedure :: setup_reweight => event_expr_setup_reweight
 <<Subevt expr: procedures>>=
   subroutine event_expr_setup_reweight (expr, ef_reweight)
     class(event_expr_t), intent(inout), target :: expr
     class(expr_factory_t), intent(in) :: ef_reweight
     call ef_reweight%build (expr%reweight)
     if (allocated (expr%reweight)) then
        call expr%setup_var_self ()
        call expr%reweight%setup_expr (expr%var_list)
        expr%has_reweight = .true.
     end if
   end subroutine event_expr_setup_reweight
 
 @ %def event_expr_setup_reweight
 @ Store the string or numeric process ID.  This should be done during
 initialization.
 <<Subevt expr: event expr: TBP>>=
   procedure :: set_process_id => event_expr_set_process_id
   procedure :: set_process_num_id => event_expr_set_process_num_id
 <<Subevt expr: procedures>>=
   subroutine event_expr_set_process_id (expr, id)
     class(event_expr_t), intent(inout) :: expr
     type(string_t), intent(in) :: id
     expr%id = id
     expr%has_id = .true.
   end subroutine event_expr_set_process_id
 
   subroutine event_expr_set_process_num_id (expr, num_id)
     class(event_expr_t), intent(inout) :: expr
     integer, intent(in) :: num_id
     expr%num_id = num_id
     expr%has_num_id = .true.
   end subroutine event_expr_set_process_num_id
 
 @ %def event_expr_set_process_id
 @ %def event_expr_set_process_num_id
 @ Reset / set the data that pertain to a particular event.  The event
 index is reset unless explicitly told to keep it.
 <<Subevt expr: event expr: TBP>>=
   procedure :: reset_contents => event_expr_reset_contents
   procedure :: set => event_expr_set
 <<Subevt expr: procedures>>=
   subroutine event_expr_reset_contents (expr)
     class(event_expr_t), intent(inout) :: expr
     call expr%base_reset_contents ()
     expr%has_sqme_ref = .false.
     expr%has_sqme_prc = .false.
     expr%has_sqme_alt = .false.
     expr%has_weight_ref = .false.
     expr%has_weight_prc = .false.
     expr%has_weight_alt = .false.
     expr%has_excess_prc = .false.
   end subroutine event_expr_reset_contents
 
   subroutine event_expr_set (expr, &
        weight_ref, weight_prc, weight_alt, &
        excess_prc, &
        sqme_ref, sqme_prc, sqme_alt)
     class(event_expr_t), intent(inout) :: expr
     real(default), intent(in), optional :: weight_ref, weight_prc
     real(default), intent(in), optional :: excess_prc
     real(default), intent(in), optional :: sqme_ref, sqme_prc
     real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt
     if (present (sqme_ref)) then
        expr%has_sqme_ref = .true.
        expr%sqme_ref = sqme_ref
     end if
     if (present (sqme_prc)) then
        expr%has_sqme_prc = .true.
        expr%sqme_prc = sqme_prc
     end if
     if (present (sqme_alt)) then
        expr%has_sqme_alt = .true.
        expr%sqme_alt = sqme_alt
     end if
     if (present (weight_ref)) then
        expr%has_weight_ref = .true.
        expr%weight_ref = weight_ref
     end if
     if (present (weight_prc)) then
        expr%has_weight_prc = .true.
        expr%weight_prc = weight_prc
     end if
     if (present (weight_alt)) then
        expr%has_weight_alt = .true.
        expr%weight_alt = weight_alt
     end if
     if (present (excess_prc)) then
        expr%has_excess_prc = .true.
        expr%excess_prc = excess_prc
     end if
   end subroutine event_expr_set
 
 @ %def event_expr_reset_contents event_expr_set
 @ Access the subevent index.
 <<Subevt expr: event expr: TBP>>=
   procedure :: has_event_index => event_expr_has_event_index
   procedure :: get_event_index => event_expr_get_event_index
 <<Subevt expr: procedures>>=
   function event_expr_has_event_index (expr) result (flag)
     class(event_expr_t), intent(in) :: expr
     logical :: flag
     flag = expr%has_index
   end function event_expr_has_event_index
 
   function event_expr_get_event_index (expr) result (index)
     class(event_expr_t), intent(in) :: expr
     integer :: index
     if (expr%has_index) then
        index = expr%index
     else
        index = 0
     end if
   end function event_expr_get_event_index
 
 @ %def event_expr_has_event_index
 @ %def event_expr_get_event_index
 @ Set/increment the subevent index.  Initialize it if necessary.
 <<Subevt expr: event expr: TBP>>=
   procedure :: set_event_index => event_expr_set_event_index
   procedure :: reset_event_index => event_expr_reset_event_index
   procedure :: increment_event_index => event_expr_increment_event_index
 <<Subevt expr: procedures>>=
   subroutine event_expr_set_event_index (expr, index)
     class(event_expr_t), intent(inout) :: expr
     integer, intent(in) :: index
     expr%index = index
     expr%has_index = .true.
   end subroutine event_expr_set_event_index
 
   subroutine event_expr_reset_event_index (expr)
     class(event_expr_t), intent(inout) :: expr
     expr%has_index = .false.
   end subroutine event_expr_reset_event_index
 
   subroutine event_expr_increment_event_index (expr, offset)
     class(event_expr_t), intent(inout) :: expr
     integer, intent(in), optional :: offset
     if (expr%has_index) then
        expr%index = expr%index + 1
     else if (present (offset)) then
        call expr%set_event_index (offset + 1)
     else
        call expr%set_event_index (1)
     end if
   end subroutine event_expr_increment_event_index
 
 @ %def event_expr_set_event_index
 @ %def event_expr_increment_event_index
 @ Fill the event expression: take the particle data and kinematics
 from a [[particle_set]] object.
 
 We allow the particle content to change for each event.  Therefore, we set the
 event variables each time.
 
 Also increment the event index; initialize it if necessary.
 <<Subevt expr: event expr: TBP>>=
   procedure :: fill_subevt => event_expr_fill_subevt
 <<Subevt expr: procedures>>=
   subroutine event_expr_fill_subevt (expr, particle_set)
     class(event_expr_t), intent(inout) :: expr
     type(particle_set_t), intent(in) :: particle_set
     call particle_set%to_subevt (expr%subevt_t, expr%colorize_subevt)
     expr%sqrts_hat = subevt_get_sqrts_hat (expr%subevt_t)
     expr%n_in  = subevt_get_n_in  (expr%subevt_t)
     expr%n_out = subevt_get_n_out (expr%subevt_t)
     expr%n_tot = expr%n_in + expr%n_out
     expr%subevt_filled = .true.
   end subroutine event_expr_fill_subevt
 
 @ %def event_expr_fill_subevt
 @ Evaluate, if the event passes the selection.  For absent expressions we take
 default values.
 <<Subevt expr: event expr: TBP>>=
   procedure :: evaluate => event_expr_evaluate
 <<Subevt expr: procedures>>=
   subroutine event_expr_evaluate (expr, passed, reweight, analysis_flag)
     class(event_expr_t), intent(inout) :: expr
     logical, intent(out) :: passed
     real(default), intent(out) :: reweight
     logical, intent(out) :: analysis_flag
     call expr%base_evaluate (passed)
     if (passed) then
        if (expr%has_reweight) then
           call expr%reweight%evaluate ()
           if (expr%reweight%is_known ()) then
              reweight = expr%reweight%get_real ()
           else
              call msg_error ("Evaluate reweight expression: &
                   &result undefined")
              reweight = 0
           end if
        else
           reweight = 1
        end if
        if (expr%has_analysis) then
           call expr%analysis%evaluate ()
           if (expr%analysis%is_known ()) then
              analysis_flag = expr%analysis%get_log ()
           else
              call msg_error ("Evaluate analysis expression: &
                   &result undefined")
              analysis_flag = .false.
           end if
        else
           analysis_flag = .true.
        end if
     end if
   end subroutine event_expr_evaluate
 
 @ %def event_expr_evaluate
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Parton states}
 A [[parton_state_t]] object contains the effective kinematics and
 dynamics of an elementary partonic interaction, with or without the
 beam/structure function state included.  The type is abstract and has
 two distinct extensions.  The [[isolated_state_t]] extension describes
 the isolated elementary interaction where the [[int_eff]] subobject
 contains the complex transition amplitude, exclusive in all quantum
 numbers.  The particle content and kinematics describe the effective
 partonic state.  The [[connected_state_t]] extension contains the
 partonic [[subevt]] and the expressions for cuts and scales which use
 it.
 
 In the isolated state, the effective partonic interaction may either
 be identical to the hard interaction, in which case it is just a
 pointer to the latter.  Or it may involve a rearrangement of partons,
 in which case we allocate it explicitly and flag this by
 [[int_is_allocated]].
 
 The [[trace]] evaluator contains the absolute square of the effective
 transition amplitude matrix, summed over final states.  It is also summed over
 initial states, depending on the the beam setup allows.  The result is used for
 integration.
 
 The [[matrix]] evaluator is the counterpart of [[trace]] which is kept
 exclusive in all observable quantum numbers.  The [[flows]] evaluator is
 furthermore exclusive in colors, but neglecting all color interference.  The
 [[matrix]] and [[flows]] evaluators are filled only for sampling points that
 become part of physical events.
 
 Note: It would be natural to make the evaluators allocatable. The extra
 [[has_XXX]] flags indicate whether evaluators are active, instead.
 
 This module contains no unit tests.  The tests are covered by the
 [[processes]] module below.
 <<[[parton_states.f90]]>>=
 <<File header>>
 module parton_states
 
 <<Use kinds>>
 <<Use debug>>
   use io_units
   use format_utils, only: write_separator
   use diagnostics
   use lorentz
   use subevents
   use variables
   use expr_base
   use model_data
   use flavors
   use helicities
   use colors
   use quantum_numbers
   use state_matrices
   use polarizations
   use interactions
   use evaluators
 
   use beams
   use sf_base
   use process_constants
   use prc_core
   use subevt_expr
 
 <<Standard module head>>
 
 <<Parton states: public>>
 
 <<Parton states: types>>
 
 contains
 
 <<Parton states: procedures>>
 
 end module parton_states
 @ %def parton_states
 @
 \subsection{Abstract base type}
 The common part are the evaluators, one for the trace (summed over all
 quantum numbers), one for the transition matrix (summed only over
 unobservable quantum numbers), and one for the flow distribution
 (transition matrix without interferences, exclusive in color flow).
 <<Parton states: types>>=
   type, abstract :: parton_state_t
      logical :: has_trace = .false.
      logical :: has_matrix = .false.
      logical :: has_flows = .false.
      type(evaluator_t) :: trace
      type(evaluator_t) :: matrix
      type(evaluator_t) :: flows
    contains
    <<Parton states: parton state: TBP>>
   end type parton_state_t
 
 @ %def parton_state_t
 @ The [[isolated_state_t]] extension contains the [[sf_chain_eff]] object
 and the (hard) effective interaction [[int_eff]], separately, both are
 implemented as a pointer.  The evaluators (trace, matrix, flows) apply
 to the hard interaction only.
 
 If the effective interaction differs from the hard interaction, the
 pointer is allocated explicitly.  Analogously for [[sf_chain_eff]].
 <<Parton states: public>>=
   public :: isolated_state_t
 <<Parton states: types>>=
   type, extends (parton_state_t) :: isolated_state_t
      logical :: sf_chain_is_allocated = .false.
      type(sf_chain_instance_t), pointer :: sf_chain_eff => null ()
      logical :: int_is_allocated = .false.
      type(interaction_t), pointer :: int_eff => null ()
    contains
    <<Parton states: isolated state: TBP>>
   end type isolated_state_t
 
 @ %def isolated_state_t
 @ The [[connected_state_t]] extension contains all data that enable
 the evaluation of observables for the effective connected state.  The
 evaluators connect the (effective) structure-function chain and hard
 interaction that were kept separate in the [[isolated_state_t]].
 
 The [[flows_sf]] evaluator is an extended copy of the
 structure-function
 
 The [[expr]] subobject consists of the [[subevt]], a simple event record,
 expressions for cuts etc.\ which refer to this record, and a [[var_list]]
 which contains event-specific variables, linked to the process variable
 list.  Variables used within the expressions are looked up in [[var_list]].
 <<Parton states: public>>=
   public :: connected_state_t
 <<Parton states: types>>=
   type, extends (parton_state_t) :: connected_state_t
      type(state_flv_content_t) :: state_flv
      logical :: has_flows_sf = .false.
      type(evaluator_t) :: flows_sf
      logical :: has_expr = .false.
      type(parton_expr_t) :: expr
    contains
    <<Parton states: connected state: TBP>>
   end type connected_state_t
 
 @ %def connected_state_t
 @ Output: each evaluator is written only when it is active.  The
 [[sf_chain]] is only written if it is explicitly allocated.
 <<Parton states: parton state: TBP>>=
   procedure :: write => parton_state_write
 <<Parton states: procedures>>=
   subroutine parton_state_write (state, unit, testflag)
     class(parton_state_t), intent(in) :: state
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     select type (state)
     class is (isolated_state_t)
        if (state%sf_chain_is_allocated) then
           call write_separator (u)
           call state%sf_chain_eff%write (u)
        end if
        if (state%int_is_allocated) then
           call write_separator (u)
           write (u, "(1x,A)") &
                "Effective interaction:"
           call write_separator (u)
           call state%int_eff%basic_write (u, testflag = testflag)
        end if
     class is (connected_state_t)
        if (state%has_flows_sf) then
           call write_separator (u)
           write (u, "(1x,A)") &
                "Evaluator (extension of the beam evaluator &
                &with color contractions):"
           call write_separator (u)
           call state%flows_sf%write (u, testflag = testflag)
        end if
     end select
     if (state%has_trace) then
        call write_separator (u)
        write (u, "(1x,A)") &
             "Evaluator (trace of the squared transition matrix):"
        call write_separator (u)
        call state%trace%write (u, testflag = testflag)
     end if
     if (state%has_matrix) then
        call write_separator (u)
        write (u, "(1x,A)") &
             "Evaluator (squared transition matrix):"
        call write_separator (u)
        call state%matrix%write (u, testflag = testflag)
     end if
     if (state%has_flows) then
        call write_separator (u)
        write (u, "(1x,A)") &
             "Evaluator (squared color-flow matrix):"
        call write_separator (u)
        call state%flows%write (u, testflag = testflag)
     end if
     select type (state)
     class is (connected_state_t)
        if (state%has_expr) then
           call write_separator (u)
           call state%expr%write (u)
        end if
     end select
   end subroutine parton_state_write
 
 @ %def parton_state_write
 @ Finalize interaction and evaluators, but only if allocated.
 <<Parton states: parton state: TBP>>=
   procedure :: final => parton_state_final
 <<Parton states: procedures>>=
   subroutine parton_state_final (state)
     class(parton_state_t), intent(inout) :: state
     if (state%has_flows) then
        call state%flows%final ()
        state%has_flows = .false.
     end if
     if (state%has_matrix) then
        call state%matrix%final ()
        state%has_matrix = .false.
     end if
     if (state%has_trace) then
        call state%trace%final ()
        state%has_trace = .false.
     end if
     select type (state)
     class is (connected_state_t)
        if (state%has_flows_sf) then
           call state%flows_sf%final ()
           state%has_flows_sf = .false.
        end if
        call state%expr%final ()
     class is (isolated_state_t)
        if (state%int_is_allocated) then
           call state%int_eff%final ()
           deallocate (state%int_eff)
           state%int_is_allocated = .false.
        end if
        if (state%sf_chain_is_allocated) then
           call state%sf_chain_eff%final ()
        end if
     end select
   end subroutine parton_state_final
 
 @ %def parton_state_final
 @
 \subsection{Common Initialization}
 Initialize the isolated parton state.  In this version, the
 effective structure-function chain [[sf_chain_eff]] and the effective
 interaction [[int_eff]] both are trivial pointers to the seed
 structure-function chain and to the hard interaction, respectively.
 <<Parton states: isolated state: TBP>>=
   procedure :: init => isolated_state_init
 <<Parton states: procedures>>=
   subroutine isolated_state_init (state, sf_chain, int)
     class(isolated_state_t), intent(out) :: state
     type(sf_chain_instance_t), intent(in), target :: sf_chain
     type(interaction_t), intent(in), target :: int
     state%sf_chain_eff => sf_chain
     state%int_eff => int
   end subroutine isolated_state_init
 
 @ %def isolated_state_init
 @
 \subsection{Evaluator initialization: isolated state}
 Create an evaluator for the trace of the squared transition matrix.
 The trace goes over all outgoing quantum numbers.  Whether we trace
 over incoming quantum numbers other than color, depends on the given
 [[qn_mask_in]].
 
 There are two options: explicitly computing the color factor table
 ([[use_cf]] false; [[nc]] defined), or taking the color factor
 table from the hard matrix element data.
 <<Parton states: isolated state: TBP>>=
   procedure :: setup_square_trace => isolated_state_setup_square_trace
 <<Parton states: procedures>>=
   subroutine isolated_state_setup_square_trace (state, core, &
        qn_mask_in, col, keep_fs_flavor)
     class(isolated_state_t), intent(inout), target :: state
     class(prc_core_t), intent(in) :: core
     type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
     !!! Actually need allocatable attribute here for once because col might
     !!! enter the subroutine non-allocated.
     integer, intent(in), dimension(:), allocatable :: col
     logical, intent(in) :: keep_fs_flavor
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
     associate (data => core%data)
       allocate (qn_mask (data%n_in + data%n_out))
       qn_mask( : data%n_in) = &
               quantum_numbers_mask (.false., .true., .false.) &
               .or. qn_mask_in
       qn_mask(data%n_in + 1 : ) = &
               quantum_numbers_mask (.not. keep_fs_flavor, .true., .true.)
       if (core%use_color_factors) then
          call state%trace%init_square (state%int_eff, qn_mask, &
               col_flow_index = data%cf_index, &
               col_factor = data%color_factors, &
               col_index_hi = col, &
               nc = core%nc)
       else
          call state%trace%init_square (state%int_eff, qn_mask, nc = core%nc)
       end if
     end associate
     state%has_trace = .true.
   end subroutine isolated_state_setup_square_trace
 
 @ %def isolated_state_setup_square_trace
 @ Set up an identity-evaluator for the trace. This implies that [[me]]
 is considered to be a squared amplitude, as for example for BLHA matrix
 elements.
 <<Parton states: isolated state: TBP>>=
   procedure :: setup_identity_trace => isolated_state_setup_identity_trace
 <<Parton states: procedures>>=
   subroutine isolated_state_setup_identity_trace (state, core, qn_mask_in, &
       keep_fs_flavors, keep_colors)
      class(isolated_state_t), intent(inout), target :: state
      class(prc_core_t), intent(in) :: core
      type(quantum_numbers_mask_t), intent(in), dimension(:) :: qn_mask_in
      logical, intent(in), optional :: keep_fs_flavors, keep_colors
      type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
      logical :: fs_flv_flag, col_flag
      fs_flv_flag = .true.; col_flag = .true.
      if (present(keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
      if (present(keep_colors)) col_flag = .not. keep_colors
      associate (data => core%data)
         allocate (qn_mask (data%n_in + data%n_out))
         qn_mask( : data%n_in) = &
            quantum_numbers_mask (.false., col_flag, .false.) .or. qn_mask_in
         qn_mask(data%n_in + 1 : ) = &
            quantum_numbers_mask (fs_flv_flag, col_flag, .true.)
      end associate
      call state%int_eff%set_mask (qn_mask)
      call state%trace%init_identity (state%int_eff)
      state%has_trace = .true.
   end subroutine isolated_state_setup_identity_trace
 
 @ %def isolated_state_setup_identity_trace
 @ Set up the evaluator for the transition matrix, exclusive in
 helicities where this is requested.
 
 For all unstable final-state particles we keep polarization according to the
 applicable decay options.  If the process is a decay itself, this applies also
 to the initial state.
 
 For all polarized final-state particles, we keep polarization including
 off-diagonal entries.  We drop helicity completely for unpolarized final-state
 particles.
 
 For the initial state, if the particle has not been handled yet, we
 apply the provided [[qn_mask_in]] which communicates the beam properties.
 <<Parton states: isolated state: TBP>>=
   procedure :: setup_square_matrix => isolated_state_setup_square_matrix
 <<Parton states: procedures>>=
   subroutine isolated_state_setup_square_matrix &
        (state, core, model, qn_mask_in, col)
     class(isolated_state_t), intent(inout), target :: state
     class(prc_core_t), intent(in) :: core
     class(model_data_t), intent(in), target :: model
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
     integer, dimension(:), intent(in) :: col
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     logical :: helmask, helmask_hd
     associate (data => core%data)
       allocate (qn_mask (data%n_in + data%n_out))
       allocate (flv (data%n_flv))
       do i = 1, data%n_in + data%n_out
          call flv%init (data%flv_state(i,:), model)
          if ((data%n_in == 1 .or. i > data%n_in) &
               .and. any (.not. flv%is_stable ())) then
             helmask = all (flv%decays_isotropically ())
             helmask_hd = all (flv%decays_diagonal ())
             qn_mask(i) = quantum_numbers_mask (.false., .true., helmask, &
                  mask_hd = helmask_hd)
          else if (i > data%n_in) then
             helmask = all (.not. flv%is_polarized ())
             qn_mask(i) = quantum_numbers_mask (.false., .true., helmask)
          else
             qn_mask(i) = quantum_numbers_mask (.false., .true., .false.) &
               .or. qn_mask_in(i)
          end if
       end do
       if (core%use_color_factors) then
          call state%matrix%init_square (state%int_eff, qn_mask, &
               col_flow_index = data%cf_index, &
               col_factor = data%color_factors, &
               col_index_hi = col, &
               nc = core%nc)
       else
          call state%matrix%init_square (state%int_eff, &
               qn_mask, &
               nc = core%nc)
       end if
     end associate
     state%has_matrix = .true.
   end subroutine isolated_state_setup_square_matrix
 
 @ %def isolated_state_setup_square_matrix
 @ This procedure initializes the evaluator that computes the
 contributions to color flows, neglecting color interference.
 The incoming-particle mask can be used to sum over incoming flavor.
 
 Helicity handling: see above.
 <<Parton states: isolated state: TBP>>=
   procedure :: setup_square_flows => isolated_state_setup_square_flows
 <<Parton states: procedures>>=
   subroutine isolated_state_setup_square_flows (state, core, model, qn_mask_in)
     class(isolated_state_t), intent(inout), target :: state
     class(prc_core_t), intent(in) :: core
     class(model_data_t), intent(in), target :: model
     type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in
     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     logical :: helmask, helmask_hd
     associate (data => core%data)
       allocate (qn_mask (data%n_in + data%n_out))
       allocate (flv (data%n_flv))
       do i = 1, data%n_in + data%n_out
          call flv%init (data%flv_state(i,:), model)
          if ((data%n_in == 1 .or. i > data%n_in) &
               .and. any (.not. flv%is_stable ())) then
             helmask = all (flv%decays_isotropically ())
             helmask_hd = all (flv%decays_diagonal ())
             qn_mask(i) = quantum_numbers_mask (.false., .false., helmask, &
                  mask_hd = helmask_hd)
          else if (i > data%n_in) then
             helmask = all (.not. flv%is_polarized ())
             qn_mask(i) = quantum_numbers_mask (.false., .false., helmask)
          else
             qn_mask(i) = quantum_numbers_mask (.false., .false., .false.) &
               .or. qn_mask_in(i)
          end if
       end do
       call state%flows%init_square (state%int_eff, qn_mask, &
            expand_color_flows = .true.)
     end associate
     state%has_flows = .true.
   end subroutine isolated_state_setup_square_flows
 
 @ %def isolated_state_setup_square_flows
 @
 \subsection{Evaluator initialization: connected state}
 Set up a trace evaluator as a product of two evaluators (incoming state,
 effective interaction).  In the result, all quantum numbers are summed over.
 
 If the optional [[int]] interaction is provided, use this for the
 first factor in the convolution.  Otherwise, use the final interaction
 of the stored [[sf_chain]].
 
 The [[resonant]] flag applies if we want to construct
 a decay chain.  The resonance property can propagate to the final
 event output.
 
 If an extended structure function is required [[requires_extended_sf]],
 we have to not consider [[sub]] as a quantum number.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_connected_trace => connected_state_setup_connected_trace
 <<Parton states: procedures>>=
   subroutine connected_state_setup_connected_trace &
        (state, isolated, int, resonant, undo_helicities, &
         keep_fs_flavors, requires_extended_sf)
     class(connected_state_t), intent(inout), target :: state
     type(isolated_state_t), intent(in), target :: isolated
     type(interaction_t), intent(in), optional, target :: int
     logical, intent(in), optional :: resonant
     logical, intent(in), optional :: undo_helicities
     logical, intent(in), optional :: keep_fs_flavors
     logical, intent(in), optional :: requires_extended_sf
     type(quantum_numbers_mask_t) :: mask
     type(interaction_t), pointer :: src_int, beam_int
     logical :: reduce, fs_flv_flag
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
          "connected_state_setup_connected_trace")
     reduce = .false.; fs_flv_flag = .true.
     if (present (undo_helicities)) reduce = undo_helicities
     if (present (keep_fs_flavors)) fs_flv_flag = .not. keep_fs_flavors
     mask = quantum_numbers_mask (fs_flv_flag, .true., .true.)
     if (present (int)) then
        src_int => int
     else
        src_int => isolated%sf_chain_eff%get_out_int_ptr ()
     end if
 
     if (debug2_active (D_PROCESS_INTEGRATION)) then
        call src_int%basic_write ()
     end if
 
     call state%trace%init_product (src_int, isolated%trace, &
          qn_mask_conn = mask, &
          qn_mask_rest = mask, &
          connections_are_resonant = resonant, &
          ignore_sub_for_qn = requires_extended_sf)
 
     if (reduce) then
        beam_int => isolated%sf_chain_eff%get_beam_int_ptr ()
        call undo_qn_hel (beam_int, mask, beam_int%get_n_tot ())
        call undo_qn_hel (src_int, mask, src_int%get_n_tot ())
        call beam_int%set_matrix_element (cmplx (1, 0, default))
        call src_int%set_matrix_element (cmplx (1, 0, default))
     end if
 
     state%has_trace = .true.
   contains
     subroutine undo_qn_hel (int_in, mask, n_tot)
       type(interaction_t), intent(inout) :: int_in
       type(quantum_numbers_mask_t), intent(in) :: mask
       integer, intent(in) :: n_tot
       type(quantum_numbers_mask_t), dimension(n_tot) :: mask_in
       mask_in = mask
       call int_in%set_mask (mask_in)
     end subroutine undo_qn_hel
   end subroutine connected_state_setup_connected_trace
 
 @ %def connected_state_setup_connected_trace
 @ Set up a matrix evaluator as a product of two evaluators (incoming
 state, effective interation).  In the intermediate state, color and
 helicity is summed over.  In the final state, we keep the quantum
 numbers which are present in the original evaluators.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_connected_matrix => connected_state_setup_connected_matrix
 <<Parton states: procedures>>=
   subroutine connected_state_setup_connected_matrix &
        (state, isolated, int, resonant, qn_filter_conn)
     class(connected_state_t), intent(inout), target :: state
     type(isolated_state_t), intent(in), target :: isolated
     type(interaction_t), intent(in), optional, target :: int
     logical, intent(in), optional :: resonant
     type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
     type(quantum_numbers_mask_t) :: mask
     type(interaction_t), pointer :: src_int
     mask = quantum_numbers_mask (.false., .true., .true.)
     if (present (int)) then
        src_int => int
     else
        src_int => isolated%sf_chain_eff%get_out_int_ptr ()
     end if
     call state%matrix%init_product &
          (src_int, isolated%matrix, mask, &
           qn_filter_conn = qn_filter_conn, &
           connections_are_resonant = resonant)
     state%has_matrix = .true.
   end subroutine connected_state_setup_connected_matrix
 
 @ %def connected_state_setup_connected_matrix
 @ Set up a matrix evaluator as a product of two evaluators (incoming
 state, effective interation).  In the intermediate state, only
 helicity is summed over.  In the final state, we keep the quantum
 numbers which are present in the original evaluators.
 
 
 If the optional [[int]] interaction is provided, use this for the
 first factor in the convolution.  Otherwise, use the final interaction
 of the stored [[sf_chain]], after creating an intermediate interaction
 that includes a correlated color state.  We assume that for a
 caller-provided [[int]], this is not necessary.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_connected_flows => connected_state_setup_connected_flows
 <<Parton states: procedures>>=
   subroutine connected_state_setup_connected_flows &
        (state, isolated, int, resonant, qn_filter_conn)
     class(connected_state_t), intent(inout), target :: state
     type(isolated_state_t), intent(in), target :: isolated
     type(interaction_t), intent(in), optional, target :: int
     logical, intent(in), optional :: resonant
     type(quantum_numbers_t), intent(in), optional :: qn_filter_conn
     type(quantum_numbers_mask_t) :: mask
     type(interaction_t), pointer :: src_int
     mask = quantum_numbers_mask (.false., .false., .true.)
     if (present (int)) then
        src_int => int
     else
        src_int => isolated%sf_chain_eff%get_out_int_ptr ()
        call state%flows_sf%init_color_contractions (src_int)
        state%has_flows_sf = .true.
        src_int => state%flows_sf%interaction_t
     end if
     call state%flows%init_product (src_int, isolated%flows, mask, &
          qn_filter_conn = qn_filter_conn, &
          connections_are_resonant = resonant)
     state%has_flows = .true.
   end subroutine connected_state_setup_connected_flows
 
 @ %def connected_state_setup_connected_flows
 @ Determine and store the flavor content for the connected state.
 This queries the [[matrix]] evaluator component, which should hold the
 requested flavor information.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_state_flv => connected_state_setup_state_flv
 <<Parton states: procedures>>=
   subroutine connected_state_setup_state_flv (state, n_out_hard)
     class(connected_state_t), intent(inout), target :: state
     integer, intent(in) :: n_out_hard
     call interaction_get_flv_content &
          (state%matrix%interaction_t, state%state_flv, n_out_hard)
   end subroutine connected_state_setup_state_flv
 
 @ %def connected_state_setup_state_flv
 @ Return the current flavor state object.
 <<Parton states: connected state: TBP>>=
   procedure :: get_state_flv => connected_state_get_state_flv
 <<Parton states: procedures>>=
   function connected_state_get_state_flv (state) result (state_flv)
     class(connected_state_t), intent(in) :: state
     type(state_flv_content_t) :: state_flv
     state_flv = state%state_flv
   end function connected_state_get_state_flv
 
 @ %def connected_state_get_state_flv
 @
 \subsection{Cuts and expressions}
 Set up the [[subevt]] that corresponds to the connected interaction.
 The index arrays refer to the interaction.
 
 We assign the particles as follows: the beam particles are the first
 two (decay process: one) entries in the trace evaluator.  The incoming
 partons are identified by their link to the outgoing partons of the
 structure-function chain.  The outgoing partons are those of the trace
 evaluator, which include radiated partons during the
 structure-function chain.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_subevt => connected_state_setup_subevt
 <<Parton states: procedures>>=
   subroutine connected_state_setup_subevt (state, sf_chain, f_beam, f_in, f_out)
     class(connected_state_t), intent(inout), target :: state
     type(sf_chain_instance_t), intent(in), target :: sf_chain
     type(flavor_t), dimension(:), intent(in) :: f_beam, f_in, f_out
     integer :: n_beam, n_in, n_out, n_vir, n_tot, i, j
     integer, dimension(:), allocatable :: i_beam, i_in, i_out
     integer :: sf_out_i
     type(interaction_t), pointer :: sf_int
     sf_int => sf_chain%get_out_int_ptr ()
     n_beam = size (f_beam)
     n_in = size (f_in)
     n_out = size (f_out)
     n_vir = state%trace%get_n_vir ()
     n_tot = state%trace%get_n_tot ()
     allocate (i_beam (n_beam), i_in (n_in), i_out (n_out))
     i_beam = [(i, i = 1, n_beam)]
     do j = 1, n_in
        sf_out_i = sf_chain%get_out_i (j)
        i_in(j) = interaction_find_link &
             (state%trace%interaction_t, sf_int, sf_out_i)
     end do
     i_out = [(i, i = n_vir + 1, n_tot)]
     call state%expr%setup_subevt (state%trace%interaction_t, &
          i_beam, i_in, i_out, f_beam, f_in, f_out)
     state%has_expr = .true.
   end subroutine connected_state_setup_subevt
 
 @ %def connected_state_setup_subevt
 @ Initialize the variable list specific for this state/term.  We insert event
 variables ([[sqrts_hat]]) and link the process variable list.  The variable
 list acquires pointers to subobjects of [[state]], which must therefore have a
 [[target]] attribute.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_var_list => connected_state_setup_var_list
 <<Parton states: procedures>>=
   subroutine connected_state_setup_var_list (state, process_var_list, beam_data)
     class(connected_state_t), intent(inout), target :: state
     type(var_list_t), intent(in), target :: process_var_list
     type(beam_data_t), intent(in) :: beam_data
     call state%expr%setup_vars (beam_data%get_sqrts ())
     call state%expr%link_var_list (process_var_list)
   end subroutine connected_state_setup_var_list
 
 @ %def connected_state_setup_var_list
 @ Allocate the cut expression etc.
 <<Parton states: connected state: TBP>>=
   procedure :: setup_cuts => connected_state_setup_cuts
   procedure :: setup_scale => connected_state_setup_scale
   procedure :: setup_fac_scale => connected_state_setup_fac_scale
   procedure :: setup_ren_scale => connected_state_setup_ren_scale
   procedure :: setup_weight => connected_state_setup_weight
 <<Parton states: procedures>>=
   subroutine connected_state_setup_cuts (state, ef_cuts)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_cuts
     call state%expr%setup_selection (ef_cuts)
   end subroutine connected_state_setup_cuts
 
   subroutine connected_state_setup_scale (state, ef_scale)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_scale
     call state%expr%setup_scale (ef_scale)
   end subroutine connected_state_setup_scale
 
   subroutine connected_state_setup_fac_scale (state, ef_fac_scale)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_fac_scale
     call state%expr%setup_fac_scale (ef_fac_scale)
   end subroutine connected_state_setup_fac_scale
 
   subroutine connected_state_setup_ren_scale (state, ef_ren_scale)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_ren_scale
     call state%expr%setup_ren_scale (ef_ren_scale)
   end subroutine connected_state_setup_ren_scale
 
   subroutine connected_state_setup_weight (state, ef_weight)
     class(connected_state_t), intent(inout), target :: state
     class(expr_factory_t), intent(in) :: ef_weight
     call state%expr%setup_weight (ef_weight)
   end subroutine connected_state_setup_weight
 
 @ %def connected_state_setup_expressions
 @ Reset the expression object: invalidate the subevt.
 <<Parton states: connected state: TBP>>=
   procedure :: reset_expressions => connected_state_reset_expressions
 <<Parton states: procedures>>=
   subroutine connected_state_reset_expressions (state)
     class(connected_state_t), intent(inout) :: state
     if (state%has_expr)  call state%expr%reset_contents ()
   end subroutine connected_state_reset_expressions
 
 @ %def connected_state_reset_expressions
 @
 \subsection{Evaluation}
 Transfer momenta to the trace evaluator and fill the [[subevt]] with
 this effective kinematics, if applicable.
 
 Note: we may want to apply a boost for the [[subevt]].
 <<Parton states: parton state: TBP>>=
   procedure :: receive_kinematics => parton_state_receive_kinematics
 <<Parton states: procedures>>=
   subroutine parton_state_receive_kinematics (state)
     class(parton_state_t), intent(inout), target :: state
     if (state%has_trace) then
        call state%trace%receive_momenta ()
        select type (state)
        class is (connected_state_t)
           if (state%has_expr) then
              call state%expr%fill_subevt (state%trace%interaction_t)
           end if
        end select
     end if
   end subroutine parton_state_receive_kinematics
 
 @ %def parton_state_receive_kinematics
 @ Recover kinematics: We assume that the trace evaluator is filled
 with momenta.  Send those momenta back to the sources, then fill the
 variables and subevent as above.
 
 The incoming momenta of the connected state are not connected to the
 isolated state but to the beam interaction.  Therefore, the incoming
 momenta within the isolated state do not become defined, yet.
 Instead, we reconstruct the beam (and ISR) momentum configuration.
 <<Parton states: parton state: TBP>>=
   procedure :: send_kinematics => parton_state_send_kinematics
 <<Parton states: procedures>>=
   subroutine parton_state_send_kinematics (state)
     class(parton_state_t), intent(inout), target :: state
     if (state%has_trace) then
        call interaction_send_momenta (state%trace%interaction_t)
        select type (state)
        class is (connected_state_t)
           call state%expr%fill_subevt (state%trace%interaction_t)
        end select
     end if
   end subroutine parton_state_send_kinematics
 
 @ %def parton_state_send_kinematics
 @ Evaluate the expressions.  The routine evaluates first the cut expression.
 If the event passes, it evaluates the other expressions.  Where no expressions
 are defined, default values are inserted.
 <<Parton states: connected state: TBP>>=
   procedure :: evaluate_expressions => connected_state_evaluate_expressions
 <<Parton states: procedures>>=
   subroutine connected_state_evaluate_expressions (state, passed, &
        scale, fac_scale, ren_scale, weight, scale_forced, force_evaluation)
     class(connected_state_t), intent(inout) :: state
     logical, intent(out) :: passed
     real(default), intent(out) :: scale, fac_scale, ren_scale, weight
     real(default), intent(in), allocatable, optional :: scale_forced
     logical, intent(in), optional :: force_evaluation
     if (state%has_expr) then
        call state%expr%evaluate (passed, scale, fac_scale, ren_scale, weight, &
             scale_forced, force_evaluation)
     end if
   end subroutine connected_state_evaluate_expressions
 
 @ %def connected_state_evaluate_expressions
 @ Evaluate the structure-function chain, if it is allocated
 explicitly.  The argument is the factorization scale.
 
 If the chain is merely a pointer, the chain should already be
 evaluated at this point.
 <<Parton states: isolated state: TBP>>=
   procedure :: evaluate_sf_chain => isolated_state_evaluate_sf_chain
 <<Parton states: procedures>>=
   subroutine isolated_state_evaluate_sf_chain (state, fac_scale)
     class(isolated_state_t), intent(inout) :: state
     real(default), intent(in) :: fac_scale
     if (state%sf_chain_is_allocated)  call state%sf_chain_eff%evaluate (fac_scale)
   end subroutine isolated_state_evaluate_sf_chain
 
 @ %def isolated_state_evaluate_sf_chain
 @ Evaluate the trace.
 <<Parton states: parton state: TBP>>=
   procedure :: evaluate_trace => parton_state_evaluate_trace
 <<Parton states: procedures>>=
   subroutine parton_state_evaluate_trace (state)
     class(parton_state_t), intent(inout) :: state
     if (state%has_trace) call state%trace%evaluate ()
   end subroutine parton_state_evaluate_trace
 
 @ %def parton_state_evaluate_trace
 <<Parton states: parton state: TBP>>=
   procedure :: evaluate_matrix => parton_state_evaluate_matrix
 <<Parton states: procedures>>=
   subroutine parton_state_evaluate_matrix (state)
     class(parton_state_t), intent(inout) :: state
     if (state%has_matrix) call state%matrix%evaluate ()
   end subroutine parton_state_evaluate_matrix
 
 @ %def parton_state_evaluate_matrix
 @ Evaluate the extra evaluators that we need for physical events.
 <<Parton states: parton state: TBP>>=
   procedure :: evaluate_event_data => parton_state_evaluate_event_data
 <<Parton states: procedures>>=
   subroutine parton_state_evaluate_event_data (state, only_momenta)
     class(parton_state_t), intent(inout) :: state
     logical, intent(in), optional :: only_momenta
     logical :: only_mom
     only_mom = .false.; if (present (only_momenta)) only_mom = only_momenta
     select type (state)
     type is (connected_state_t)
        if (state%has_flows_sf) then
           call state%flows_sf%receive_momenta ()
           if (.not. only_mom) call state%flows_sf%evaluate ()
        end if
     end select
     if (state%has_matrix) then
        call state%matrix%receive_momenta ()
        if (.not. only_mom) call state%matrix%evaluate ()
     end if
     if (state%has_flows) then
        call state%flows%receive_momenta ()
        if (.not. only_mom) call state%flows%evaluate ()
     end if
   end subroutine parton_state_evaluate_event_data
 
 @ %def parton_state_evaluate_event_data
 @ Normalize the helicity density matrix by its trace, i.e., factor out
 the trace and put it into an overall normalization factor.  The trace
 and flow evaluators are unchanged.
 <<Parton states: parton state: TBP>>=
   procedure :: normalize_matrix_by_trace => &
        parton_state_normalize_matrix_by_trace
 <<Parton states: procedures>>=
   subroutine parton_state_normalize_matrix_by_trace (state)
     class(parton_state_t), intent(inout) :: state
     if (state%has_matrix) call state%matrix%normalize_by_trace ()
   end subroutine parton_state_normalize_matrix_by_trace
 
 @ %def parton_state_normalize_matrix_by_trace
 @
 \subsection{Accessing the state}
 Three functions return a pointer to the event-relevant interactions.
 <<Parton states: parton state: TBP>>=
   procedure :: get_trace_int_ptr => parton_state_get_trace_int_ptr
   procedure :: get_matrix_int_ptr => parton_state_get_matrix_int_ptr
   procedure :: get_flows_int_ptr => parton_state_get_flows_int_ptr
 <<Parton states: procedures>>=
   function parton_state_get_trace_int_ptr (state) result (ptr)
     class(parton_state_t), intent(in), target :: state
     type(interaction_t), pointer :: ptr
     if (state%has_trace) then
        ptr => state%trace%interaction_t
     else
        ptr => null ()
     end if
   end function parton_state_get_trace_int_ptr
 
   function parton_state_get_matrix_int_ptr (state) result (ptr)
     class(parton_state_t), intent(in), target :: state
     type(interaction_t), pointer :: ptr
     if (state%has_matrix) then
        ptr => state%matrix%interaction_t
     else
        ptr => null ()
     end if
   end function parton_state_get_matrix_int_ptr
 
   function parton_state_get_flows_int_ptr (state) result (ptr)
     class(parton_state_t), intent(in), target :: state
     type(interaction_t), pointer :: ptr
     if (state%has_flows) then
        ptr => state%flows%interaction_t
     else
        ptr => null ()
     end if
   end function parton_state_get_flows_int_ptr
 
 @ %def parton_state_get_trace_int_ptr
 @ %def parton_state_get_matrix_int_ptr
 @ %def parton_state_get_flows_int_ptr
 @ Return the indices of the beam particles and the outgoing particles within
 the trace (and thus, matrix and flows) evaluator, respectively.
 <<Parton states: connected state: TBP>>=
   procedure :: get_beam_index => connected_state_get_beam_index
   procedure :: get_in_index => connected_state_get_in_index
 <<Parton states: procedures>>=
   subroutine connected_state_get_beam_index (state, i_beam)
     class(connected_state_t), intent(in) :: state
     integer, dimension(:), intent(out) :: i_beam
     call state%expr%get_beam_index (i_beam)
   end subroutine connected_state_get_beam_index
 
   subroutine connected_state_get_in_index (state, i_in)
     class(connected_state_t), intent(in) :: state
     integer, dimension(:), intent(out) :: i_in
     call state%expr%get_in_index (i_in)
   end subroutine connected_state_get_in_index
 
 @ %def connected_state_get_beam_index
 @ %def connected_state_get_in_index
 @
 <<Parton states: public>>=
   public :: refill_evaluator
 <<Parton states: procedures>>=
   subroutine refill_evaluator (sqme, qn, flv_index, evaluator)
     complex(default), intent(in), dimension(:) :: sqme
     type(quantum_numbers_t), intent(in), dimension(:,:) :: qn
     integer, intent(in), dimension(:), optional :: flv_index
     type(evaluator_t), intent(inout) :: evaluator
     integer :: i, i_flv
     do i = 1, size (sqme)
        if (present (flv_index)) then
           i_flv = flv_index(i)
        else
           i_flv = i
        end if
        call evaluator%add_to_matrix_element (qn(:,i_flv), sqme(i), &
             match_only_flavor = .true.)
     end do
   end subroutine refill_evaluator
 
 @ %def refill_evaluator
 @ Return the number of outgoing (hard) particles for the state.
 <<Parton states: parton state: TBP>>=
   procedure :: get_n_out => parton_state_get_n_out
 <<Parton states: procedures>>=
   function parton_state_get_n_out (state) result (n)
     class(parton_state_t), intent(in), target :: state
     integer :: n
     n = state%trace%get_n_out ()
   end function parton_state_get_n_out
 
 @ %def parton_state_get_n_out
 @
 \subsection{Unit tests}
 <<[[parton_states_ut.f90]]>>=
 <<File header>>
 
 module parton_states_ut
   use unit_tests
   use parton_states_uti
 
 <<Standard module head>>
 
 <<Parton states: public test>>
 
 contains
 
 <<Parton states: test driver>>
 
 end module parton_states_ut
 @ %def parton_states_ut
 <<[[parton_states_uti.f90]]>>=
 <<File header>>
 
 module parton_states_uti
 
 <<Use kinds>>
 <<Use strings>>
   use constants, only: zero
   use numeric_utils
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use sf_base, only: sf_chain_instance_t
   use state_matrices, only: state_matrix_t
   use prc_template_me, only: prc_template_me_t
   use interactions, only: interaction_t
   use models, only: model_t, create_test_model
   use parton_states
 
 <<Standard module head>>
 
 <<Parton states: test declarations>>
 
 contains
 
 <<Parton states: tests>>
 
 end module parton_states_uti
 @ %def parton_states_uti
 @
 <<Parton states: public test>>=
   public :: parton_states_test
 <<Parton states: test driver>>=
   subroutine parton_states_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Parton states: execute tests>>
   end subroutine parton_states_test
 
 @ %def parton_states_test
 @
 \subsubsection{Test a simple isolated state}
 <<Parton states: execute tests>>=
   call test (parton_states_1, "parton_states_1", &
        "Create a 2 -> 2 isolated state and compute trace", &
        u, results)
 <<Parton states: test declarations>>=
   public :: parton_states_1
 <<Parton states: tests>>=
   subroutine parton_states_1 (u)
     integer, intent(in) :: u
     type(state_matrix_t), allocatable :: state
     type(flavor_t), dimension(2) :: flv_in
     type(flavor_t), dimension(2) :: flv_out1, flv_out2
     type(flavor_t), dimension(4) :: flv_tot
     type(helicity_t), dimension(4) :: hel
     type(color_t), dimension(4) :: col
     integer :: h1, h2, h3, h4
     integer :: f
     integer :: i
     type(quantum_numbers_t), dimension(4) :: qn
     type(prc_template_me_t) :: core
     type(sf_chain_instance_t), target :: sf_chain
     type(interaction_t), target :: int
     type(isolated_state_t) :: isolated_state
     integer :: n_states = 0
     integer, dimension(:), allocatable :: col_flow_index
     type(quantum_numbers_mask_t), dimension(2) :: qn_mask
     integer, dimension(8) :: i_allowed_states
     complex(default), dimension(8) :: me
     complex(default) :: me_check_tot, me_check_1, me_check_2, me2
     logical :: tmp1, tmp2
     type(model_t), pointer :: test_model => null ()
 
     write (u, "(A)") "* Test output: parton_states_1"
     write (u, "(A)") "* Purpose: Test the standard parton states"
     write (u, "(A)")
 
     call flv_in%init ([11, -11])
     call flv_out1%init ([1, -1])
     call flv_out2%init ([2, -2])
 
     write (u, "(A)") "* Using incoming flavors: "
     call flavor_write_array (flv_in, u)
     write (u, "(A)") "* Two outgoing flavor structures: "
     call flavor_write_array (flv_out1, u)
     call flavor_write_array (flv_out2, u)
 
 
     write (u, "(A)") "* Initialize state matrix"
     allocate (state)
     call state%init ()
 
     write (u, "(A)") "* Fill state matrix"
     call col(3)%init ([1])
     call col(4)%init ([-1])
     do f = 1, 2
        do h1 = -1, 1, 2
           do h2 = -1, 1, 2
              do h3 = -1, 1, 2
                 do h4 = -1, 1, 2
                    n_states = n_states + 1
                    call hel%init ([h1, h2, h3, h4], [h1, h2, h3, h4])
                    if (f == 1) then
                       flv_tot = [flv_in, flv_out1]
                    else
                       flv_tot = [flv_in, flv_out2]
                    end if
                    call qn%init (flv_tot, col, hel)
                    call state%add_state (qn)
                 end do
              end do
           end do
        end do
     end do
 
     !!! Two flavors, one color flow, 2 x 2 x 2 x 2 helicity configurations
     !!! -> 32 states.
     write (u, "(A)")
     write (u, "(A,I2)") "* Generated number of states: ", n_states
 
     call state%freeze ()
 
     !!! Indices of the helicity configurations which are non-zero
     i_allowed_states = [6, 7, 10, 11, 22, 23, 26, 27]
     me = [cmplx (-1.89448E-5_default,  9.94456E-7_default, default), &
           cmplx (-8.37887E-2_default,  4.30842E-3_default, default), &
           cmplx (-1.99997E-1_default, -1.01985E-2_default, default), &
           cmplx ( 1.79717E-5_default,  9.27038E-7_default, default), &
           cmplx (-1.74859E-5_default,  8.78819E-7_default, default), &
           cmplx ( 1.67577E-1_default, -8.61683E-3_default, default), &
           cmplx ( 2.41331E-1_default,  1.23306E-2_default, default), &
           cmplx (-3.59435E-5_default, -1.85407E-6_default, default)]
     me_check_tot = cmplx (zero, zero, default)
     me_check_1 = cmplx (zero, zero, default)
     me_check_2 = cmplx (zero, zero, default)
     do i = 1, 8
        me2 = me(i) * conjg (me(i))
        me_check_tot = me_check_tot + me2
        if (i < 5) then
           me_check_1 = me_check_1 + me2
        else
           me_check_2 = me_check_2 + me2
        end if
        call state%set_matrix_element (i_allowed_states(i), me(i))
     end do
 
     !!! Do not forget the color factor
     me_check_tot = 3._default * me_check_tot
     me_check_1 = 3._default * me_check_1
     me_check_2 = 3._default * me_check_2
     write (u, "(A)")
 
     write (u, "(A)") "* Setup interaction"
     call int%basic_init (2, 0, 2, set_relations = .true.)
     call int%set_state_matrix (state)
 
     core%data%n_in = 2; core%data%n_out = 2
     core%data%n_flv = 2
     allocate (core%data%flv_state (4, 2))
     core%data%flv_state (1, :) = [11, 11]
     core%data%flv_state (2, :) = [-11, -11]
     core%data%flv_state (3, :) = [1, 2]
     core%data%flv_state (4, :) = [-1, -2]
     core%use_color_factors = .false.
     core%nc = 3
 
     write (u, "(A)") "* Init isolated state"
     call isolated_state%init (sf_chain, int)
     !!! There is only one color flow.
     allocate (col_flow_index (n_states)); col_flow_index = 1
     call qn_mask%init (.false., .false., .true., mask_cg = .false.)
     write (u, "(A)") "* Give a trace to the isolated state"
     call isolated_state%setup_square_trace (core, qn_mask, col_flow_index, .false.)
     call isolated_state%evaluate_trace ()
     write (u, "(A)")
     write (u, "(A)", advance = "no") "* Squared matrix element correct: "
     write (u, "(L1)") nearly_equal (me_check_tot, &
        isolated_state%trace%get_matrix_element (1), rel_smallness = 0.00001_default)
 
 
     write (u, "(A)") "* Give a matrix to the isolated state"
     call create_test_model (var_str ("SM"), test_model)
     call isolated_state%setup_square_matrix (core, test_model, qn_mask, col_flow_index)
     call isolated_state%evaluate_matrix ()
 
     write (u, "(A)") "* Sub-matrixelements correct: "
     tmp1 = nearly_equal (me_check_1, &
        isolated_state%matrix%get_matrix_element (1), rel_smallness = 0.00001_default)
     tmp2 = nearly_equal (me_check_2, &
        isolated_state%matrix%get_matrix_element (2), rel_smallness = 0.00001_default)
     write (u, "(A,L1,A,L1)") "* 1: ", tmp1, ", 2: ", tmp2
 
     write (u, "(A)") "* Test output end: parton_states_1"
   end subroutine parton_states_1
 
 @ %def parton_states_1
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process component management}
 This module contains tools for managing and combining process
 components and matrix-element code and values, acting at a level below
 the actual process definition.
 
 \subsection{Abstract base type}
 The types introduced here are abstract base types.
 <<[[pcm_base.f90]]>>=
 <<File header>>
 
 module pcm_base
 
 <<Use kinds>>
   use io_units
   use diagnostics
   use format_utils, only: write_integer_array
   use format_utils, only: write_separator
   use physics_defs, only: BORN, NLO_REAL
 <<Use strings>>
   use os_interface, only: os_data_t
 
   use process_libraries, only: process_component_def_t
   use process_libraries, only: process_library_t
 
   use prc_core_def
   use prc_core
 
   use variables, only: var_list_t
   use mappings, only: mapping_defaults_t
   use phs_base, only: phs_config_t
   use phs_forests, only: phs_parameters_t
   use mci_base, only: mci_t
   use model_data, only: model_data_t
   use models, only: model_t
 
   use blha_config, only: blha_master_t
   use blha_olp_interfaces, only: blha_template_t
   use process_config
   use process_mci, only: process_mci_entry_t
 
 <<Standard module head>>
 
 <<PCM base: public>>
 
 <<PCM base: parameters>>
 
 <<PCM base: types>>
 
 <<PCM base: interfaces>>
 
 contains
 
 <<PCM base: procedures>>
 
 end module pcm_base
 @ %def pcm_base
 @
 \subsection{Core management}
 This object holds information about the cores used by the components
 and allocates the corresponding manager instance.
 
 [[i_component]] is the index of the process component which this core belongs
 to.  The pointer to the core definition is a convenient help in configuring
 the core itself.
 
 We allow for a [[blha_config]] configuration object that covers BLHA cores.
 The BLHA standard is suitable generic to warrant support outside of specific
 type extension (i.e., applies to LO and NLO if requested).  The BLHA
 configuration is allocated only if the core requires it.
 <<PCM base: public>>=
   public :: core_entry_t
 <<PCM base: types>>=
   type :: core_entry_t
      integer :: i_component = 0
      logical :: active = .false.
      class(prc_core_def_t), pointer :: core_def => null ()
      type(blha_template_t), allocatable :: blha_config
      class(prc_core_t), allocatable :: core
    contains
    <<PCM base: core entry: TBP>>
   end type core_entry_t
 
 @ %def core_entry_t
 @
 <<PCM base: core entry: TBP>>=
   procedure :: get_core_ptr => core_entry_get_core_ptr
 <<PCM base: procedures>>=
   function core_entry_get_core_ptr (core_entry) result (core)
     class(core_entry_t), intent(in), target :: core_entry
     class(prc_core_t), pointer :: core
     if (allocated (core_entry%core)) then
        core => core_entry%core
     else
        core => null ()
     end if
   end function core_entry_get_core_ptr
 
 @ %def core_entry_get_core_ptr
 @ Configure the core object after allocation with correct type.  The
 [[core_def]] object pointer and the index [[i_component]] of the associated
 process component are already there.
 <<PCM base: core entry: TBP>>=
   procedure :: configure => core_entry_configure
 <<PCM base: procedures>>=
   subroutine core_entry_configure (core_entry, lib, id)
     class(core_entry_t), intent(inout) :: core_entry
     type(process_library_t), intent(in), target :: lib
     type(string_t), intent(in) :: id
     call core_entry%core%init &
          (core_entry%core_def, lib, id, core_entry%i_component)
   end subroutine core_entry_configure
 
 @ %def core_entry_configure
 @
 \subsection{Process component manager}
 This object may hold process and method-specific data, and it should
 allocate the corresponding manager instance.
 
 The number of components determines the [[component_selected]] array.
 
 [[i_phs_config]] is a lookup table that returns the PHS configuration index
 for a given component index.
 
 [[i_core]] is a lookup table that returns the core-entry index for a given
 component index.
 <<PCM base: public>>=
   public :: pcm_t
 <<PCM base: types>>=
   type, abstract :: pcm_t
      logical :: initialized = .false.
      logical :: has_pdfs = .false.
      integer :: n_components = 0
      integer :: n_cores = 0
      integer :: n_mci = 0
      logical, dimension(:), allocatable :: component_selected
      logical, dimension(:), allocatable :: component_active
      integer, dimension(:), allocatable :: i_phs_config
      integer, dimension(:), allocatable :: i_core
      integer, dimension(:), allocatable :: i_mci
      type(blha_template_t) :: blha_defaults
      logical :: uses_blha = .false.
      type(os_data_t) :: os_data
   contains
   <<PCM base: pcm: TBP>>
   end type pcm_t
 
 @ %def pcm_t
 @ The factory method.  We use the [[inout]] intent, so calling this
 again is an error.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_allocate_instance), deferred :: allocate_instance
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_allocate_instance (pcm, instance)
        import
        class(pcm_t), intent(in) :: pcm
        class(pcm_instance_t), intent(inout), allocatable :: instance
      end subroutine pcm_allocate_instance
   end interface
 
 @ %def pcm_allocate_instance
 @
 <<PCM base: pcm: TBP>>=
   procedure(pcm_is_nlo), deferred :: is_nlo
 <<PCM base: interfaces>>=
   abstract interface
      function pcm_is_nlo (pcm) result (is_nlo)
         import
         logical :: is_nlo
         class(pcm_t), intent(in) :: pcm
      end function pcm_is_nlo
   end interface
 
 @ %def pcm_is_nlo
 @
 <<PCM base: pcm: TBP>>=
   procedure(pcm_final), deferred :: final
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_final (pcm)
         import
         class(pcm_t), intent(inout) :: pcm
      end subroutine pcm_final
   end interface
 
 @ %def pcm_final
 @
 \subsection{Initialization methods}
 The PCM has the duty to coordinate and configure the process-object
 components.
 
 Initialize the PCM configuration itself, using environment data.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_init), deferred :: init
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_init (pcm, env, meta)
        import
        class(pcm_t), intent(out) :: pcm
        type(process_environment_t), intent(in) :: env
        type(process_metadata_t), intent(in) :: meta
      end subroutine pcm_init
   end interface
 
 @ %def pcm_init
 @
 Initialize the BLHA configuration block, the component-independent default
 settings.  This is to be called by [[pcm_init]].  We use the provided variable
 list.
 
 This block is filled regardless of whether BLHA is actually used, because why
 not?  We use a default value for the scheme (not set in unit tests).
 <<PCM base: pcm: TBP>>=
   procedure :: set_blha_defaults => pcm_set_blha_defaults
 <<PCM base: procedures>>=
   subroutine pcm_set_blha_defaults (pcm, polarized_beams, var_list)
     class(pcm_t), intent(inout) :: pcm
     type(var_list_t), intent(in) :: var_list
     logical, intent(in) :: polarized_beams
     logical :: muon_yukawa_off
     real(default) :: top_yukawa
     type(string_t) :: ew_scheme
     muon_yukawa_off = &
          var_list%get_lval (var_str ("?openloops_switch_off_muon_yukawa"))
     top_yukawa = &
          var_list%get_rval (var_str ("blha_top_yukawa"))
     ew_scheme = &
          var_list%get_sval (var_str ("$blha_ew_scheme"))
     if (ew_scheme == "")  ew_scheme = "Gmu"
     call pcm%blha_defaults%init &
          (polarized_beams, muon_yukawa_off, top_yukawa, ew_scheme)
   end subroutine pcm_set_blha_defaults
 
 @ %def pcm_set_blha_defaults
 @ Read the method settings from the variable list and store them in the BLHA
 master.  The details depend on the [[pcm]] concrete type.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_set_blha_methods), deferred :: set_blha_methods
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_set_blha_methods (pcm, blha_master, var_list)
        import
        class(pcm_t), intent(inout) :: pcm
        type(blha_master_t), intent(inout) :: blha_master
        type(var_list_t), intent(in) :: var_list
      end subroutine pcm_set_blha_methods
   end interface
 
 @ %def pcm_set_blha_methods
 @ Produce the LO and NLO flavor-state tables (as far as available), as
 appropriate for BLHA configuration.  We may inspect either the PCM itself or
 the array of process cores.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_get_blha_flv_states), deferred :: get_blha_flv_states
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_get_blha_flv_states (pcm, core_entry, flv_born, flv_real)
        import
        class(pcm_t), intent(in) :: pcm
        type(core_entry_t), dimension(:), intent(in) :: core_entry
        integer, dimension(:,:), allocatable, intent(out) :: flv_born
        integer, dimension(:,:), allocatable, intent(out) :: flv_real
      end subroutine pcm_get_blha_flv_states
   end interface
 
 @ %def pcm_get_blha_flv_states
 @
 Allocate the right number of process components.  The number is also stored in
 the process meta.  Initially, all components are active but none are
 selected.
 <<PCM base: pcm: TBP>>=
   procedure :: allocate_components => pcm_allocate_components
 <<PCM base: procedures>>=
   subroutine pcm_allocate_components (pcm, comp, meta)
     class(pcm_t), intent(inout) :: pcm
     type(process_component_t), dimension(:), allocatable, intent(out) :: comp
     type(process_metadata_t), intent(in) :: meta
     pcm%n_components = meta%n_components
     allocate (comp (pcm%n_components))
     allocate (pcm%component_selected (pcm%n_components), source = .false.)
     allocate (pcm%component_active (pcm%n_components), source = .true.)
   end subroutine pcm_allocate_components
 
 @ %def pcm_allocate_components
 @ Each process component belongs to a category/type, which we identify by a
 universal integer constant.  The categories can be taken from the process
 definition.  For easy lookup, we store the categories in an array.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_categorize_components), deferred :: categorize_components
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_categorize_components (pcm, config)
        import
        class(pcm_t), intent(inout) :: pcm
        type(process_config_data_t), intent(in) :: config
      end subroutine pcm_categorize_components
   end interface
 
 @ %def pcm_categorize_components
 @
 Allocate the right number and type(s) of process-core
 objects, i.e., the interface object between the process and matrix-element
 code.
 
 Within the [[pcm]] block, also associate cores with components and store
 relevant configuration data, including the [[i_core]] lookup table.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_allocate_cores), deferred :: allocate_cores
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_allocate_cores (pcm, config, core_entry)
        import
        class(pcm_t), intent(inout) :: pcm
        type(process_config_data_t), intent(in) :: config
        type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
      end subroutine pcm_allocate_cores
   end interface
 
 @ %def pcm_allocate_cores
 @ Generate and interface external code for a single core, if this is
 required.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_prepare_any_external_code), deferred :: &
        prepare_any_external_code
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_prepare_any_external_code &
           (pcm, core_entry, i_core, libname, model, var_list)
        import
        class(pcm_t), intent(in) :: pcm
        type(core_entry_t), intent(inout) :: core_entry
        integer, intent(in) :: i_core
        type(string_t), intent(in) :: libname
        type(model_data_t), intent(in), target :: model
        type(var_list_t), intent(in) :: var_list
      end subroutine pcm_prepare_any_external_code
   end interface
 
 @ %def pcm_prepare_any_external_code
 @ Prepare the BLHA configuration for a core object that requires it.  This
 does not affect the core object, which may not yet be allocated.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_setup_blha), deferred :: setup_blha
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_setup_blha (pcm, core_entry)
        import
        class(pcm_t), intent(in) :: pcm
        type(core_entry_t), intent(inout) :: core_entry
      end subroutine pcm_setup_blha
   end interface
 
 @ %def pcm_setup_blha
 @ Configure the BLHA interface for a core object that requires it.  This is
 separate from the previous method, assuming that the [[pcm]] has to allocate
 the actual cores and acquire some data in-between.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_prepare_blha_core), deferred :: prepare_blha_core
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_prepare_blha_core (pcm, core_entry, model)
        import
        class(pcm_t), intent(in) :: pcm
        type(core_entry_t), intent(inout) :: core_entry
        class(model_data_t), intent(in), target :: model
      end subroutine pcm_prepare_blha_core
   end interface
 
 @ %def pcm_prepare_blha_core
 @ Allocate and configure the MCI (multi-channel integrator) records and their
 relation to process components, appropriate for the algorithm implemented by
 [[pcm]].
 
 Create a [[mci_t]] template: the procedure [[dispatch_mci]] is called as a
 factory method for allocating the [[mci_t]] object with a specific concrete
 type.  The call may depend on the concrete [[pcm]] type.
 <<PCM base: public>>=
   public :: dispatch_mci_proc
 <<PCM base: interfaces>>=
   abstract interface
      subroutine dispatch_mci_proc (mci, var_list, process_id, is_nlo)
        import
        class(mci_t), allocatable, intent(out) :: mci
        type(var_list_t), intent(in) :: var_list
        type(string_t), intent(in) :: process_id
        logical, intent(in), optional :: is_nlo
      end subroutine dispatch_mci_proc
   end interface
 
 @ %def dispatch_mci_proc
 <<PCM base: pcm: TBP>>=
   procedure(pcm_setup_mci), deferred :: setup_mci
   procedure(pcm_call_dispatch_mci), deferred :: call_dispatch_mci
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_setup_mci (pcm, mci_entry)
        import
        class(pcm_t), intent(inout) :: pcm
        type(process_mci_entry_t), &
             dimension(:), allocatable, intent(out) :: mci_entry
      end subroutine pcm_setup_mci
   end interface
 
   abstract interface
      subroutine pcm_call_dispatch_mci (pcm, &
           dispatch_mci, var_list, process_id, mci_template)
        import
        class(pcm_t), intent(inout) :: pcm
        procedure(dispatch_mci_proc) :: dispatch_mci
        type(var_list_t), intent(in) :: var_list
        type(string_t), intent(in) :: process_id
        class(mci_t), intent(out), allocatable :: mci_template
      end subroutine pcm_call_dispatch_mci
   end interface
 
 @ %def pcm_setup_mci
 @ %def pcm_call_dispatch_mci
 @ Proceed with PCM configuration based on the core and component
 configuration data.  Base version is empty.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_complete_setup), deferred :: complete_setup
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_complete_setup (pcm, core_entry, component, model)
        import
        class(pcm_t), intent(inout) :: pcm
        type(core_entry_t), dimension(:), intent(in) :: core_entry
        type(process_component_t), dimension(:), intent(inout) :: component
        type(model_t), intent(in), target :: model
      end subroutine pcm_complete_setup
   end interface
 
 @ %def pcm_complete_setup
 @
 \subsubsection{Retrieve information}
 Return the core index that belongs to a particular component.
 <<PCM base: pcm: TBP>>=
   procedure :: get_i_core => pcm_get_i_core
 <<PCM base: procedures>>=
   function pcm_get_i_core (pcm, i_component) result (i_core)
     class(pcm_t), intent(in) :: pcm
     integer, intent(in) :: i_component
     integer :: i_core
     if (allocated (pcm%i_core)) then
        i_core = pcm%i_core(i_component)
     else
        i_core = 0
     end if
   end function pcm_get_i_core
 
 @ %def pcm_get_i_core
 @
 \subsubsection{Phase-space configuration}
 Allocate and initialize the right number and type(s) of phase-space
 configuration entries.  The [[i_phs_config]] lookup table must be set
 accordingly.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_init_phs_config), deferred :: init_phs_config
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_init_phs_config &
           (pcm, phs_entry, meta, env, phs_par, mapping_defs)
        import
        class(pcm_t), intent(inout) :: pcm
        type(process_phs_config_t), &
             dimension(:), allocatable, intent(out) :: phs_entry
        type(process_metadata_t), intent(in) :: meta
        type(process_environment_t), intent(in) :: env
        type(mapping_defaults_t), intent(in) :: mapping_defs
        type(phs_parameters_t), intent(in) :: phs_par
      end subroutine pcm_init_phs_config
   end interface
 
 @ %def pcm_init_phs_config
 @
 Initialize a single component.  We require all process-configuration blocks,
 and specific templates for the phase-space and integrator configuration.
 
 We also provide the current component index [[i]] and the [[active]] flag.
 <<PCM base: pcm: TBP>>=
   procedure(pcm_init_component), deferred :: init_component
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_init_component &
           (pcm, component, i, active, phs_config, env, meta, config)
        import
        class(pcm_t), intent(in) :: pcm
        type(process_component_t), intent(out) :: component
        integer, intent(in) :: i
        logical, intent(in) :: active
        class(phs_config_t), allocatable, intent(in) :: phs_config
        type(process_environment_t), intent(in) :: env
        type(process_metadata_t), intent(in) :: meta
        type(process_config_data_t), intent(in) :: config
      end subroutine pcm_init_component
   end interface
 
 @ %def pcm_init_component
 @
 Record components in the process [[meta]] data if they have turned
 out to be inactive.
 <<PCM base: pcm: TBP>>=
   procedure :: record_inactive_components => pcm_record_inactive_components
 <<PCM base: procedures>>=
   subroutine pcm_record_inactive_components (pcm, component, meta)
     class(pcm_t), intent(inout) :: pcm
     type(process_component_t), dimension(:), intent(in) :: component
     type(process_metadata_t), intent(inout) :: meta
     integer :: i
     pcm%component_active = component%active
     do i = 1, pcm%n_components
        if (.not. component(i)%active)  call meta%deactivate_component (i)
     end do
   end subroutine pcm_record_inactive_components
 
 @ %def pcm_record_inactive_components
 @
 \subsection{Manager instance}
 This object deals with the actual (squared) matrix element values.
 <<PCM base: public>>=
   public :: pcm_instance_t
 <<PCM base: types>>=
   type, abstract :: pcm_instance_t
     class(pcm_t), pointer :: config => null ()
     logical :: bad_point = .false.
   contains
   <<PCM base: pcm instance: TBP>>
   end type pcm_instance_t
 
 @ %def pcm_instance_t
 @
 <<PCM base: pcm instance: TBP>>=
   procedure(pcm_instance_final), deferred :: final
 <<PCM base: interfaces>>=
   abstract interface
      subroutine pcm_instance_final (pcm_instance)
         import
         class(pcm_instance_t), intent(inout) :: pcm_instance
      end subroutine pcm_instance_final
   end interface
 
 @ %def pcm_instance_final
 @
 <<PCM base: pcm instance: TBP>>=
   procedure :: link_config => pcm_instance_link_config
 <<PCM base: procedures>>=
   subroutine pcm_instance_link_config (pcm_instance, config)
      class(pcm_instance_t), intent(inout) :: pcm_instance
      class(pcm_t), intent(in), target :: config
      pcm_instance%config => config
   end subroutine pcm_instance_link_config
 
 @ %def pcm_instance_link_config
 @
 <<PCM base: pcm instance: TBP>>=
   procedure :: is_valid => pcm_instance_is_valid
 <<PCM base: procedures>>=
   function pcm_instance_is_valid (pcm_instance) result (valid)
     logical :: valid
     class(pcm_instance_t), intent(in) :: pcm_instance
     valid = .not. pcm_instance%bad_point
   end function pcm_instance_is_valid
 
 @ %def pcm_instance_is_valid
 @
 <<PCM base: pcm instance: TBP>>=
   procedure :: set_bad_point => pcm_instance_set_bad_point
 <<PCM base: procedures>>=
   pure subroutine pcm_instance_set_bad_point (pcm_instance, bad_point)
     class(pcm_instance_t), intent(inout) :: pcm_instance
     logical, intent(in) :: bad_point
     pcm_instance%bad_point = pcm_instance%bad_point .or. bad_point
   end subroutine pcm_instance_set_bad_point
 
 @ %def pcm_instance_set_bad_point
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{The process object}
 <<[[process.f90]]>>=
 <<File header>>
 
 module process
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use format_utils, only: write_separator
   use constants
   use diagnostics
   use numeric_utils
   use lorentz
   use cputime
   use md5
   use rng_base
   use dispatch_rng, only: dispatch_rng_factory
   use dispatch_rng, only: update_rng_seed_in_var_list
   use os_interface
   use sm_qcd
   use integration_results
   use mci_base
   use flavors
   use model_data
   use models
   use physics_defs
   use process_libraries
   use process_constants
   use particles
   use variables
   use beam_structures
   use beams
   use interactions
   use pdg_arrays
   use expr_base
   use sf_base
   use sf_mappings
   use resonances, only: resonance_history_t, resonance_history_set_t
 
   use prc_test_core, only: test_t
   use prc_core_def, only: prc_core_def_t
   use prc_core, only: prc_core_t, helicity_selection_t
   use prc_external, only: prc_external_t
   use prc_recola, only: prc_recola_t
   use blha_olp_interfaces, only: prc_blha_t, blha_template_t
   use prc_threshold, only: prc_threshold_t
   use phs_fks, only: phs_fks_config_t
 
   use phs_base
   use mappings, only: mapping_defaults_t
   use phs_forests, only: phs_parameters_t
   use phs_wood, only: phs_wood_config_t
   use dispatch_phase_space, only: dispatch_phs
   use blha_config, only: blha_master_t
   use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES
 
   use parton_states, only: connected_state_t
   use pcm_base
   use pcm
   use process_counter
   use process_config
   use process_mci
 
 <<Standard module head>>
 
 <<Process: public>>
 
 <<Process: public parameters>>
 
 <<Process: types>>
 
 <<Process: interfaces>>
 
 contains
 
 <<Process: procedures>>
 
 end module process
 @ %def process
 @
 \subsection{Process status}
 Store counter and status information in a process object.
 <<Process: types>>=
   type :: process_status_t
      private
   end type process_status_t
 
 @ %def process_status_t
 @
 \subsection{Process status}
 Store integration results in a process object.
 <<Process: types>>=
   type :: process_results_t
      private
   end type process_results_t
 
 @ %def process_results_t
 @
 \subsection{The process type}
 A process object is the workspace for the process instance.
 After initialization, its contents are filled by
 integration passes which shape the integration grids and compute cross
 sections.  Processes are set up initially from user-level
 configuration data.  After calculating integrals and thus developing
 integration grid data, the program may use a process
 object or a copy of it for the purpose of generating events.
 
 The process object consists of several subobjects with their specific
 purposes.  The corresponding types are defined below.  (Technically,
 the subobject type definitions have to come before the process type
 definition, but with NOWEB magic we reverse this order here.)
 
 The [[type]] determines whether we are considering a decay or a
 scattering process.
 
 The [[meta]] object describes the process and its environment.  All
 contents become fixed when the object is initialized.
 
 The [[config]] object holds physical and technical configuration data
 that have been obtained during process initialization, and which are
 common to all process components.
 
 The individual process components are configured in the [[component]]
 objects.  These objects contain more configuration parameters and
 workspace, as needed for the specific process variant.
 
 The [[term]] objects describe parton configurations which are
 technically used as phase-space points.  Each process component may
 split into several terms with distinct kinematics and particle
 content.  Furthermore, each term may project on a different physical
 state, e.g., by particle recombination.  The [[term]] object provides
 the framework for this projection, for applying cuts, weight, and thus
 completing the process calculation.
 
 The [[beam_config]] object describes the incoming particles, either the
 decay mother or the scattering beams.  It also contains the structure-function
 information.
 
 The [[mci_entry]] objects configure a MC input parameter set and integrator,
 each.  The number of parameters depends on the process component and on the
 beam and structure-function setup.
 
 The [[pcm]] component is the process-component manager.  This
 polymorphic object manages and hides the details of dealing with NLO
 processes where several components have to be combined in a
 non-trivial way.  It also acts as an abstract factory for the
 corresponding object in [[process_instance]], which does the actual
 work for this matter.
 <<Process: public>>=
   public :: process_t
 <<Process: types>>=
   type :: process_t
      private
      type(process_metadata_t) :: &
           meta
      type(process_environment_t) :: &
           env
      type(process_config_data_t) :: &
           config
      class(pcm_t), allocatable :: &
           pcm
      type(process_component_t), dimension(:), allocatable :: &
           component
      type(process_phs_config_t), dimension(:), allocatable :: &
           phs_entry
      type(core_entry_t), dimension(:), allocatable :: &
           core_entry
      type(process_mci_entry_t), dimension(:), allocatable :: &
           mci_entry
      class(rng_factory_t), allocatable :: &
           rng_factory
      type(process_beam_config_t) :: &
           beam_config
      type(process_term_t), dimension(:), allocatable :: &
           term
      type(process_status_t) :: &
           status
      type(process_results_t) :: &
           result
    contains
    <<Process: process: TBP>>
   end type process_t
 
 @ %def process_t
 @
 \subsection{Process pointer}
 Wrapper type for storing pointers to process objects in arrays.
 <<Process: public>>=
   public :: process_ptr_t
 <<Process: types>>=
   type :: process_ptr_t
      type(process_t), pointer :: p => null ()
   end type process_ptr_t
 
 @ %def process_ptr_t
 @
 \subsection{Output}
 This procedure is an important debugging and inspection tool; it is
 not used during normal operation.  The process object is written
 to a file (identified by unit, which may also be standard output).
 Optional flags determine whether we show everything or just the
 interesting parts.
 
 The shorthand as a traditional TBP.
 <<Process: process: TBP>>=
   procedure :: write => process_write
 <<Process: procedures>>=
   subroutine process_write (process, screen, unit, &
        show_os_data, show_var_list, show_rng, show_expressions, pacify)
     class(process_t), intent(in) :: process
     logical, intent(in) :: screen
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_os_data
     logical, intent(in), optional :: show_var_list
     logical, intent(in), optional :: show_rng
     logical, intent(in), optional :: show_expressions
     logical, intent(in), optional :: pacify
     integer :: u, iostat
     character(0) :: iomsg
     integer, dimension(:), allocatable :: v_list
     u = given_output_unit (unit)
     allocate (v_list (0))
     call set_flag (v_list, F_SHOW_OS_DATA, show_os_data)
     call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list)
     call set_flag (v_list, F_SHOW_RNG, show_rng)
     call set_flag (v_list, F_SHOW_EXPRESSIONS, show_expressions)
     call set_flag (v_list, F_PACIFY, pacify)
     if (screen) then
        call process%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
     else
        call process%write_formatted (u, "DT", v_list, iostat, iomsg)
     end if
   end subroutine process_write
 
 @ %def process_write
 @ Standard DTIO procedure with binding.
 
 For the particular application, the screen format is triggered by the
 [[LISTDIRECTED]] option for the [[iotype]] format editor string.  The
 other options activate when the particular parameter value is found in
 [[v_list]].
 
 NOTE: The DTIO [[generic]] binding is supported by gfortran since 7.0.
 
 TODO wk 2018: The default could be to show everything, and we should have separate
 switches for all major parts.  Currently, there are only a few.
 <<Process: process: TBP>>=
   ! generic :: write (formatted) => write_formatted
   procedure :: write_formatted => process_write_formatted
 <<Process: procedures>>=
   subroutine process_write_formatted (dtv, unit, iotype, v_list, iostat, iomsg)
     class(process_t), intent(in) :: dtv
     integer, intent(in) :: unit
     character(*), intent(in) :: iotype
     integer, dimension(:), intent(in) :: v_list
     integer, intent(out) :: iostat
     character(*), intent(inout) :: iomsg
     integer :: u
     logical :: screen
     logical :: var_list
     logical :: rng_factory
     logical :: expressions
     logical :: counters
     logical :: os_data
     logical :: model
     logical :: pacify
     integer :: i
     u = unit
     select case (iotype)
     case ("LISTDIRECTED")
        screen = .true.
     case default
        screen = .false.
     end select
     var_list = flagged (v_list, F_SHOW_VAR_LIST)
     rng_factory = flagged (v_list, F_SHOW_RNG, .true.)
     expressions = flagged (v_list, F_SHOW_EXPRESSIONS)
     counters = .true.
     os_data = flagged (v_list, F_SHOW_OS_DATA)
     model = .false.
     pacify = flagged (v_list, F_PACIFY)
     associate (process => dtv)
       if (screen) then
          write (msg_buffer, "(A)")  repeat ("-", 72)
          call msg_message ()
       else
          call write_separator (u, 2)
       end if
       call process%meta%write (u, screen)
       if (var_list) then
          call process%env%write (u, show_var_list=var_list, &
               show_model=.false., show_lib=.false., &
               show_os_data=os_data)
       else if (.not. screen) then
          write (u, "(1x,A)")  "Variable list: [not shown]"
       end if
       if (process%meta%type == PRC_UNKNOWN) then
          call write_separator (u, 2)
          return
       else if (screen) then
          return
       end if
       call write_separator (u)
       call process%config%write (u, counters, model, expressions)
       if (rng_factory) then
          if (allocated (process%rng_factory)) then
             call write_separator (u)
             call process%rng_factory%write (u)
          end if
       end if
       call write_separator (u, 2)
       if (allocated (process%component)) then
          write (u, "(1x,A)") "Process component configuration:"
          do i = 1, size (process%component)
             call write_separator (u)
             call process%component(i)%write (u)
          end do
       else
          write (u, "(1x,A)") "Process component configuration: [undefined]"
       end if
       call write_separator (u, 2)
       if (allocated (process%term)) then
          write (u, "(1x,A)") "Process term configuration:"
          do i = 1, size (process%term)
             call write_separator (u)
             call process%term(i)%write (u)
          end do
       else
          write (u, "(1x,A)") "Process term configuration: [undefined]"
       end if
       call write_separator (u, 2)
       call process%beam_config%write (u)
       call write_separator (u, 2)
       if (allocated (process%mci_entry)) then
          write (u, "(1x,A)") "Multi-channel integrator configurations:"
          do i = 1, size (process%mci_entry)
             call write_separator (u)
             write (u, "(1x,A,I0,A)")  "MCI #", i, ":"
             call process%mci_entry(i)%write (u, pacify)
          end do
       end if
       call write_separator (u, 2)
     end associate
     iostat = 0
     iomsg = ""
   end subroutine process_write_formatted
 
 @ %def process_write_formatted
 @
 <<Process: process: TBP>>=
   procedure :: write_meta => process_write_meta
 <<Process: procedures>>=
   subroutine process_write_meta (process, unit, testflag)
     class(process_t), intent(in) :: process
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u, i
     u = given_output_unit (unit)
     select case (process%meta%type)
     case (PRC_UNKNOWN)
        write (u, "(1x,A)") "Process instance [undefined]"
        return
     case (PRC_DECAY)
        write (u, "(1x,A)", advance="no") "Process instance [decay]:"
     case (PRC_SCATTERING)
        write (u, "(1x,A)", advance="no") "Process instance [scattering]:"
     case default
        call msg_bug ("process_instance_write: undefined process type")
     end select
     write (u, "(1x,A,A,A)") "'", char (process%meta%id), "'"
     write (u, "(3x,A,A,A)") "Run ID = '", char (process%meta%run_id), "'"
     if (allocated (process%meta%component_id)) then
        write (u, "(3x,A)")  "Process components:"
        do i = 1, size (process%meta%component_id)
           if (process%pcm%component_selected(i)) then
              write (u, "(3x,'*')", advance="no")
           else
              write (u, "(4x)", advance="no")
           end if
           write (u, "(1x,I0,9A)")  i, ": '", &
                char (process%meta%component_id (i)), "':   ", &
                char (process%meta%component_description (i))
        end do
     end if
   end subroutine process_write_meta
 
 @ %def process_write_meta
 @ Screen output.  Write a short account of the process configuration
 and the current results.  The verbose version lists the components,
 the short version just the results.
 <<Process: process: TBP>>=
   procedure :: show => process_show
 <<Process: procedures>>=
   subroutine process_show (object, unit, verbose)
     class(process_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     logical :: verb
     real(default) :: err_percent
     u = given_output_unit (unit)
     verb = .true.;  if (present (verbose)) verb = verbose
     if (verb) then
        call object%meta%show (u, object%config%model%get_name ())
        select case (object%meta%type)
        case (PRC_DECAY)
           write (u, "(2x,A)", advance="no")  "Computed width ="
        case (PRC_SCATTERING)
           write (u, "(2x,A)", advance="no")  "Computed cross section ="
        case default;  return
        end select
     else
        if (object%meta%run_id /= "") then
           write (u, "('Run',1x,A,':',1x)", advance="no") &
                char (object%meta%run_id)
        end if
        write (u, "(A)", advance="no") char (object%meta%id)
        select case (object%meta%num_id)
        case (0)
           write (u, "(':')")
        case default
           write (u, "(1x,'(',I0,')',':')") object%meta%num_id
        end select
        write (u, "(2x)", advance="no")
     end if
     if (object%has_integral_tot ()) then
        write (u, "(ES14.7,1x,'+-',ES9.2)", advance="no") &
             object%get_integral_tot (), object%get_error_tot ()
        select case (object%meta%type)
        case (PRC_DECAY)
           write (u, "(1x,A)", advance="no")  "GeV"
        case (PRC_SCATTERING)
           write (u, "(1x,A)", advance="no")  "fb "
        case default
           write (u, "(1x,A)", advance="no")  "   "
        end select
        if (object%get_integral_tot () /= 0) then
           err_percent = abs (100 &
                * object%get_error_tot () / object%get_integral_tot ())
        else
           err_percent = 0
        end if
        if (err_percent == 0) then
           write (u, "(1x,'(',F4.0,4x,'%)')")  err_percent
        else if (err_percent < 0.1) then
           write (u, "(1x,'(',F7.3,1x,'%)')")  err_percent
        else if (err_percent < 1) then
           write (u, "(1x,'(',F6.2,2x,'%)')")  err_percent
        else if (err_percent < 10) then
           write (u, "(1x,'(',F5.1,3x,'%)')")  err_percent
        else
           write (u, "(1x,'(',F4.0,4x,'%)')")  err_percent
        end if
     else
        write (u, "(A)")  "[integral undefined]"
     end if
   end subroutine process_show
 
 @ %def process_show
 @ Finalizer.  Explicitly iterate over all subobjects that may contain
 allocated pointers.
 
 TODO wk 2018 (workaround): The finalizer for the [[config_data]] component is not
 called.  The reason is that this deletes model data local to the process,
 but these could be referenced by pointers (flavor objects) from some
 persistent event record.  Obviously, such side effects should be avoided, but
 this requires refactoring the event-handling procedures.
 <<Process: process: TBP>>=
   procedure :: final => process_final
 <<Process: procedures>>=
   subroutine process_final (process)
     class(process_t), intent(inout) :: process
     integer :: i
     ! call process%meta%final ()
     call process%env%final ()
     ! call process%config%final ()
     if (allocated (process%component)) then
        do i = 1, size (process%component)
           call process%component(i)%final ()
        end do
     end if
     if (allocated (process%term)) then
        do i = 1, size (process%term)
           call process%term(i)%final ()
        end do
     end if
     call process%beam_config%final ()
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           call process%mci_entry(i)%final ()
        end do
     end if
     if (allocated (process%pcm)) then
        call process%pcm%final ()
        deallocate (process%pcm)
     end if
   end subroutine process_final
 
 @ %def process_final
 @
 \subsubsection{Process setup}
 Initialize a process.  We need a process library [[lib]] and the process
 identifier [[proc_id]] (string).  We will fetch the current run ID from the
 variable list [[var_list]].
 
 We collect all important data from the environment and store them in the
 appropriate places.  OS data, model, and variable list are copied
 into [[env]] (true snapshot), also the process library (pointer only).
 
 The [[meta]] subobject is initialized with process ID and attributes taken
 from the process library.
 
 We initialize the [[config]] subobject with all data that are relevant for
 this run, using the settings from [[env]].  These data determine the MD5 sum
 for this run, which allows us to identify the setup and possibly skips in a
 later re-run.
 
 We also allocate and initialize the embedded RNG factory.  We take the seed
 from the [[var_list]], and we should return the [[var_list]] to the caller
 with a new seed.
 
 Finally, we allocate the process component manager [[pcm]], which implements
 the chosen algorithm for process integration.  The first task of the manager
 is to allocate the component array and to determine the component categories
 (e.g., Born/Virtual etc.).
 
 TODO wk 2018: The [[pcm]] dispatcher should be provided by the caller, if we
 eventually want to eliminate dependencies on concrete [[pcm_t]] extensions.
 <<Process: process: TBP>>=
   procedure :: init => process_init
 <<Process: procedures>>=
   subroutine process_init &
        (process, proc_id, lib, os_data, model, var_list, beam_structure)
     class(process_t), intent(out) :: process
     type(string_t), intent(in) :: proc_id
     type(process_library_t), intent(in), target :: lib
     type(os_data_t), intent(in) :: os_data
     class(model_t), intent(in), target :: model
     type(var_list_t), intent(inout), target, optional :: var_list
     type(beam_structure_t), intent(in), optional :: beam_structure
     integer :: next_rng_seed
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_init")
     associate &
          (meta => process%meta, env => process%env, config => process%config)
       call env%init &
            (model, lib, os_data, var_list, beam_structure)
       call meta%init &
            (proc_id, lib, env%get_var_list_ptr ())
       call config%init &
            (meta, env)
       call dispatch_rng_factory &
            (process%rng_factory, env%get_var_list_ptr (), next_rng_seed)
       call update_rng_seed_in_var_list (var_list, next_rng_seed)
       call dispatch_pcm &
            (process%pcm, config%process_def%is_nlo ())
       associate (pcm => process%pcm)
         call pcm%init (env, meta)
         call pcm%allocate_components (process%component, meta)
         call pcm%categorize_components (config)
       end associate
     end associate
   end subroutine process_init
 
 @ %def process_init
 @
 \subsection{Process component manager}
 The [[pcm]] (read: process-component manager) takes the responsibility of
 steering the actual algorithm of configuration and integration.  Depending on
 the concrete type, different algorithms can be implemented.
 
 The first version of this supports just two implementations: leading-order
 (tree-level) integration and event generation, and NLO (QCD/FKS subtraction).
 We thus can start with a single logical for steering the dispatcher.
 
 TODO wk 2018: Eventually, we may eliminate all references to the extensions of
 [[pcm_t]] from this module and therefore move this outside the module as well.
 <<Process: procedures>>=
   subroutine dispatch_pcm (pcm, is_nlo)
     class(pcm_t), allocatable, intent(out) :: pcm
     logical, intent(in) :: is_nlo
     if (.not. is_nlo) then
        allocate (pcm_default_t :: pcm)
     else
        allocate (pcm_nlo_t :: pcm)
     end if
   end subroutine dispatch_pcm
 
 @ %def dispatch_pcm
 @ This step is performed after phase-space and core objects are done: collect
 all missing information and prepare the process component manager for the
 appropriate integration algorithm.
 <<Process: process: TBP>>=
   procedure :: complete_pcm_setup => process_complete_pcm_setup
 <<Process: procedures>>=
   subroutine process_complete_pcm_setup (process)
     class(process_t), intent(inout) :: process
     call process%pcm%complete_setup &
          (process%core_entry, process%component, process%env%get_model_ptr ())
   end subroutine process_complete_pcm_setup
 
 @ %def process_complete_pcm_setup
 @
 \subsection{Core management}
 Allocate cores (interface objects to matrix-element code).
 
 The [[dispatch_core]] procedure is taken as an argument, so we do not depend on
 the implementation, and thus on the specific core types.
 
 The [[helicity_selection]] object collects data that the matrix-element
 code needs for configuring the appropriate behavior.
 
 After the cores have been allocated, and assuming the phs initial
 configuration has been done before, we proceed with computing the [[pcm]]
 internal data.
 <<Process: process: TBP>>=
   procedure :: setup_cores => process_setup_cores
 <<Process: procedures>>=
   subroutine process_setup_cores (process, dispatch_core, &
        helicity_selection, use_color_factors, has_beam_pol)
     class(process_t), intent(inout) :: process
     procedure(dispatch_core_proc) :: dispatch_core
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     logical, intent(in), optional :: use_color_factors
     logical, intent(in), optional :: has_beam_pol
     integer :: i
     associate (pcm => process%pcm)
       call pcm%allocate_cores (process%config, process%core_entry)
       do i = 1, size (process%core_entry)
          call dispatch_core (process%core_entry(i)%core, &
               process%core_entry(i)%core_def, &
               process%config%model, &
               helicity_selection, &
               process%config%qcd, &
               use_color_factors, &
               has_beam_pol)
          call process%core_entry(i)%configure &
               (process%env%get_lib_ptr (), process%meta%id)
          if (process%core_entry(i)%core%uses_blha ()) then
             call pcm%setup_blha (process%core_entry(i))
          end if
       end do
     end associate
   end subroutine process_setup_cores
 
 @ %def process_setup_cores
 <<Process: interfaces>>=
   abstract interface
      subroutine dispatch_core_proc (core, core_def, model, &
           helicity_selection, qcd, use_color_factors, has_beam_pol)
        import
        class(prc_core_t), allocatable, intent(inout) :: core
        class(prc_core_def_t), intent(in) :: core_def
        class(model_data_t), intent(in), target, optional :: model
        type(helicity_selection_t), intent(in), optional :: helicity_selection
        type(qcd_t), intent(in), optional :: qcd
        logical, intent(in), optional :: use_color_factors
        logical, intent(in), optional :: has_beam_pol
      end subroutine dispatch_core_proc
   end interface
 
 @ %def dispatch_core_proc
 @ Use the [[pcm]] to initialize the BLHA interface for each core which
 requires it.
 <<Process: process: TBP>>=
   procedure :: prepare_blha_cores => process_prepare_blha_cores
 <<Process: procedures>>=
   subroutine process_prepare_blha_cores (process)
     class(process_t), intent(inout), target :: process
     integer :: i
     associate (pcm => process%pcm)
       do i = 1, size (process%core_entry)
          associate (core_entry => process%core_entry(i))
            if (core_entry%core%uses_blha ()) then
               pcm%uses_blha = .true.
               call pcm%prepare_blha_core (core_entry, process%config%model)
            end if
          end associate
       end do
     end associate
   end subroutine process_prepare_blha_cores
 
 @ %def process_prepare_blha_cores
 @ Create the BLHA interface data, using PCM for specific data, and write the
 BLHA contract file(s).
 
 We take various configuration data and copy them to the [[blha_master]]
 record, which then creates and writes the contracts.
 
 For assigning the QCD/EW coupling powers, we inspect the first process
 component only.  The other parameters are taken as-is from the process
 environment variables.
 <<Process: process: TBP>>=
   procedure :: create_blha_interface => process_create_blha_interface
 <<Process: procedures>>=
   subroutine process_create_blha_interface (process)
     class(process_t), intent(inout) :: process
     integer :: alpha_power, alphas_power
     integer :: openloops_phs_tolerance, openloops_stability_log
     logical :: use_cms
     type(string_t) :: ew_scheme, correction_type
     type(string_t) :: openloops_extra_cmd
     type(blha_master_t) :: blha_master
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     if (process%pcm%uses_blha) then
        call collect_configuration_parameters (process%get_var_list_ptr ())
        call process%component(1)%config%get_coupling_powers &
             (alpha_power, alphas_power)
        associate (pcm => process%pcm)
          call pcm%set_blha_methods (blha_master, process%get_var_list_ptr ())
          call blha_master%set_ew_scheme (ew_scheme)
          call blha_master%allocate_config_files ()
          call blha_master%set_correction_type (correction_type)
          call blha_master%setup_additional_features ( &
               openloops_phs_tolerance, &
               use_cms, &
               openloops_stability_log, &
               extra_cmd = openloops_extra_cmd, &
               beam_structure = process%env%get_beam_structure ())
          call pcm%get_blha_flv_states (process%core_entry, flv_born, flv_real)
          call blha_master%set_photon_characteristics (flv_born, process%config%n_in)
          call blha_master%generate (process%meta%id, &
               process%config%model, process%config%n_in, &
               alpha_power, alphas_power, &
               flv_born, flv_real)
          call blha_master%write_olp (process%meta%id)
        end associate
     end if
   contains
     subroutine collect_configuration_parameters (var_list)
       type(var_list_t), intent(in) :: var_list
       openloops_phs_tolerance = &
            var_list%get_ival (var_str ("openloops_phs_tolerance"))
       openloops_stability_log = &
            var_list%get_ival (var_str ("openloops_stability_log"))
       use_cms = &
            var_list%get_lval (var_str ("?openloops_use_cms"))
       ew_scheme = &
            var_list%get_sval (var_str ("$blha_ew_scheme"))
       correction_type = &
            var_list%get_sval (var_str ("$nlo_correction_type"))
       openloops_extra_cmd = &
            var_list%get_sval (var_str ("$openloops_extra_cmd"))
     end subroutine collect_configuration_parameters
   end subroutine process_create_blha_interface
 
 @ %def process_create_blha_interface
 @ Initialize the process components, one by one.  We require templates for the
 [[mci]] (integrator) and [[phs_config]] (phase-space) configuration data.
 
 The [[active]] flag is set if the component has an associated matrix
 element, so we can compute it.  The case of no core is a unit-test case.
 
 The specifics depend on the algorithm and are delegated to the [[pcm]]
 process-component manager.
 
 The optional [[phs_config]] overrides a pre-generated config array (for unit
 test).
 <<Process: process: TBP>>=
   procedure :: init_components => process_init_components
 <<Process: procedures>>=
   subroutine process_init_components (process, phs_config)
     class(process_t), intent(inout), target :: process
     class(phs_config_t), allocatable, intent(in), optional :: phs_config
     integer :: i, i_core
     class(prc_core_t), pointer :: core
     logical :: active
     associate (pcm => process%pcm)
       do i = 1, pcm%n_components
          i_core = pcm%get_i_core(i)
          if (i_core > 0) then
             core => process%get_core_ptr (i_core)
             active = core%has_matrix_element ()
          else
             active = .true.
          end if
          if (present (phs_config)) then
             call pcm%init_component (process%component(i), &
               i, &
               active, &
               phs_config, &
               process%env, process%meta, process%config)
          else
             call pcm%init_component (process%component(i), &
               i, &
               active, &
               process%phs_entry(pcm%i_phs_config(i))%phs_config, &
               process%env, process%meta, process%config)
          end if
       end do
     end associate
   end subroutine process_init_components
 
 @ %def process_init_components
 @ If process components have turned out to be inactive, this has to be
 recorded in the [[meta]] block.  Delegate to the [[pcm]].
 <<Process: process: TBP>>=
   procedure :: record_inactive_components => process_record_inactive_components
 <<Process: procedures>>=
   subroutine process_record_inactive_components (process)
     class(process_t), intent(inout) :: process
     associate (pcm => process%pcm)
       call pcm%record_inactive_components (process%component, process%meta)
     end associate
   end subroutine process_record_inactive_components
 
 @ %def process_record_inactive_components
 @ Determine the process terms for each process component.
 <<Process: process: TBP>>=
   procedure :: setup_terms => process_setup_terms
 <<Process: procedures>>=
   subroutine process_setup_terms (process, with_beams)
     class(process_t), intent(inout), target :: process
     logical, intent(in), optional :: with_beams
     class(model_data_t), pointer :: model
     integer :: i, j, k, i_term
     integer, dimension(:), allocatable :: n_entry
     integer :: n_components, n_tot
     integer :: i_sub
     type(string_t) :: subtraction_method
     class(prc_core_t), pointer :: core => null ()
     logical :: setup_subtraction_component, singular_real
     logical :: requires_spin_correlations
     integer :: nlo_type_to_fetch, n_emitters
     i_sub = 0
     model => process%config%model
     n_components = process%meta%n_components
     allocate (n_entry (n_components), source = 0)
     do i = 1, n_components
        associate (component => process%component(i))
          if (component%active) then
             n_entry(i) = 1
             if (component%get_nlo_type () == NLO_REAL) then
                select type (pcm => process%pcm)
                type is (pcm_nlo_t)
                   if (component%component_type /= COMP_REAL_FIN) &
                        n_entry(i) = n_entry(i) + pcm%region_data%get_n_phs ()
                end select
             end if
          end if
        end associate
     end do
     n_tot = sum (n_entry)
     allocate (process%term (n_tot))
     k = 0
     if (process%is_nlo_calculation ()) then
        i_sub = process%component(1)%config%get_associated_subtraction ()
        subtraction_method = process%component(i_sub)%config%get_me_method ()
        if (debug_on) call msg_debug2 &
             (D_PROCESS_INTEGRATION, "process_setup_terms: ", subtraction_method)
     end if
 
     do i = 1, n_components
        associate (component => process%component(i))
          if (.not. component%active)  cycle
            allocate (component%i_term (n_entry(i)))
            do j = 1, n_entry(i)
               singular_real = component%get_nlo_type () == NLO_REAL &
                    .and. component%component_type /= COMP_REAL_FIN
               setup_subtraction_component = singular_real .and. j == n_entry(i)
               i_term = k + j
               component%i_term(j) = i_term
               if (singular_real) then
                  process%term(i_term)%i_sub = k + n_entry(i)
               else
                  process%term(i_term)%i_sub = 0
               end if
               if (setup_subtraction_component) then
                  select type (pcm => process%pcm)
                  class is (pcm_nlo_t)
                     process%term(i_term)%i_core = pcm%i_core(pcm%i_sub)
                  end select
               else
                  process%term(i_term)%i_core = process%pcm%get_i_core(i)
               end if
 
               if (process%term(i_term)%i_core == 0) then
                  call msg_bug ("Process '" // char (process%get_id ()) &
                       // "': core not found!")
               end if
               core => process%get_core_term (i_term)
               if (i_sub > 0) then
                  select type (pcm => process%pcm)
                  type is (pcm_nlo_t)
                     requires_spin_correlations = &
                          pcm%region_data%requires_spin_correlations ()
                     n_emitters = pcm%region_data%get_n_emitters_sc ()
                  class default
                     requires_spin_correlations = .false.
                     n_emitters = 0
                  end select
                  if (requires_spin_correlations) then
                     call process%term(i_term)%init ( &
                          i_term, i, j, core, model, &
                          nlo_type = component%config%get_nlo_type (), &
                          use_beam_pol = with_beams, &
                          subtraction_method = subtraction_method, &
                          has_pdfs = process%pcm%has_pdfs, &
                          n_emitters = n_emitters)
                  else
                     call process%term(i_term)%init ( &
                          i_term, i, j, core, model, &
                          nlo_type = component%config%get_nlo_type (), &
                          use_beam_pol = with_beams, &
                          subtraction_method = subtraction_method, &
                          has_pdfs = process%pcm%has_pdfs)
                  end if
               else
                  call process%term(i_term)%init ( &
                       i_term, i, j, core, model, &
                       nlo_type = component%config%get_nlo_type (), &
                       use_beam_pol = with_beams, &
                       has_pdfs = process%pcm%has_pdfs)
               end if
            end do
        end associate
        k = k + n_entry(i)
     end do
     process%config%n_terms = n_tot
   end subroutine process_setup_terms
 
 @ %def process_setup_terms
 @ Initialize the beam setup.  This is the trivial version where the
 incoming state of the matrix element coincides with the initial state
 of the process.  For a scattering process, we need the c.m. energy,
 all other variables are set to their default values (no polarization,
 lab frame and c.m.\ frame coincide, etc.)
 
 We assume that all components consistently describe a scattering
 process, i.e., two incoming particles.
 
 Note: The current layout of the [[beam_data_t]] record requires that the
 flavor for each beam is unique.  For processes with multiple
 flavors in the initial state, one has to set up beams explicitly.
 This restriction could be removed by extending the code in the
 [[beams]] module.
 <<Process: process: TBP>>=
   procedure :: setup_beams_sqrts => process_setup_beams_sqrts
 <<Process: procedures>>=
   subroutine process_setup_beams_sqrts (process, sqrts, beam_structure, i_core)
     class(process_t), intent(inout) :: process
     real(default), intent(in) :: sqrts
     type(beam_structure_t), intent(in), optional :: beam_structure
     integer, intent(in), optional :: i_core
     type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
     integer, dimension(2) :: pdg_scattering
     type(flavor_t), dimension(2) :: flv_in
     integer :: i, i0, ic
     allocate (pdg_in (2, process%meta%n_components))
     i0 = 0
     do i = 1, process%meta%n_components
        if (process%component(i)%active) then
           if (present (i_core)) then
              ic = i_core
           else
              ic = process%pcm%get_i_core (i)
           end if
           associate (core => process%core_entry(ic)%core)
             pdg_in(:,i) = core%data%get_pdg_in ()
           end associate
           if (i0 == 0)  i0 = i
        end if
     end do
     do i = 1, process%meta%n_components
        if (.not. process%component(i)%active) then
           pdg_in(:,i) = pdg_in(:,i0)
        end if
     end do
     if (all (pdg_array_get_length (pdg_in) == 1) .and. &
          all (pdg_in(1,:) == pdg_in(1,i0)) .and. &
          all (pdg_in(2,:) == pdg_in(2,i0))) then
        pdg_scattering = pdg_array_get (pdg_in(:,i0), 1)
        call flv_in%init (pdg_scattering, process%config%model)
        call process%beam_config%init_scattering (flv_in, sqrts, beam_structure)
     else
        call msg_fatal ("Setting up process '" // char (process%meta%id) // "':", &
            [var_str ("   --------------------------------------------"), &
             var_str ("Inconsistent initial state. This happens if either "), &
             var_str ("several processes with non-matching initial states "), &
             var_str ("have been added, or for a single process with an "), &
             var_str ("initial state flavor sum. In that case, please set beams "), &
             var_str ("explicitly [singling out a flavor / structure function.]")])
     end if
   end subroutine process_setup_beams_sqrts
 
 @ %def process_setup_beams_sqrts
 @ This is the version that applies to decay processes.  The energy is the
 particle mass, hence no extra argument.
 <<Process: process: TBP>>=
   procedure :: setup_beams_decay => process_setup_beams_decay
 <<Process: procedures>>=
   subroutine process_setup_beams_decay (process, rest_frame, beam_structure, i_core)
     class(process_t), intent(inout), target :: process
     logical, intent(in), optional :: rest_frame
     type(beam_structure_t), intent(in), optional :: beam_structure
     integer, intent(in), optional :: i_core
     type(pdg_array_t), dimension(:,:), allocatable :: pdg_in
     integer, dimension(1) :: pdg_decay
     type(flavor_t), dimension(1) :: flv_in
     integer :: i, i0, ic
     allocate (pdg_in (1, process%meta%n_components))
     i0 = 0
     do i = 1, process%meta%n_components
        if (process%component(i)%active) then
           if (present (i_core)) then
              ic = i_core
           else
              ic = process%pcm%get_i_core (i)
           end if
           associate (core => process%core_entry(ic)%core)
             pdg_in(:,i) = core%data%get_pdg_in ()
           end associate
           if (i0 == 0)  i0 = i
        end if
     end do
     do i = 1, process%meta%n_components
        if (.not. process%component(i)%active) then
           pdg_in(:,i) = pdg_in(:,i0)
        end if
     end do
     if (all (pdg_array_get_length (pdg_in) == 1) &
          .and. all (pdg_in(1,:) == pdg_in(1,i0))) then
        pdg_decay = pdg_array_get (pdg_in(:,i0), 1)
        call flv_in%init (pdg_decay, process%config%model)
        call process%beam_config%init_decay (flv_in, rest_frame, beam_structure)
     else
        call msg_fatal ("Setting up decay '" &
             // char (process%meta%id) // "': decaying particle not unique")
     end if
   end subroutine process_setup_beams_decay
 
 @ %def process_setup_beams_decay
 @ We have to make sure that the masses of the various flavors
 in a given position in the particle string coincide.
 <<Process: process: TBP>>=
   procedure :: check_masses => process_check_masses
 <<Process: procedures>>=
   subroutine process_check_masses (process)
     class(process_t), intent(in) :: process
     type(flavor_t), dimension(:), allocatable :: flv
     real(default), dimension(:), allocatable :: mass
     integer :: i, j
     integer :: i_component
     class(prc_core_t), pointer :: core
     do i = 1, process%get_n_terms ()
        i_component = process%term(i)%i_component
        if (.not. process%component(i_component)%active)  cycle
        core => process%get_core_term (i)
        associate (data => core%data)
          allocate (flv (data%n_flv), mass (data%n_flv))
          do j = 1, data%n_in + data%n_out
             call flv%init (data%flv_state(j,:), process%config%model)
             mass = flv%get_mass ()
             if (any (.not. nearly_equal(mass, mass(1)))) then
                call msg_fatal ("Process '" // char (process%meta%id) // "': " &
                     // "mass values in flavor combination do not coincide. ")
             end if
          end do
          deallocate (flv, mass)
        end associate
     end do
   end subroutine process_check_masses
 
 @ %def process_check_masses
 @ Set up index mapping for [[region_data]] for singular regions equivalent w.r.t.
 their amplitudes. Has to be called after [[region_data]] AND the [[core]] are fully
 set up. For processes with structure function, subprocesses which lead to the same
 amplitude for the hard interaction can differ if structure functions are applied.
 In this case we remap flavor structures to themselves if the eqvivalent hard interaction
 flavor structure has no identical initial state.
 <<Process: process: TBP>>=
   procedure :: optimize_nlo_singular_regions => process_optimize_nlo_singular_regions
 <<Process: procedures>>=
   subroutine process_optimize_nlo_singular_regions (process)
     class(process_t), intent(inout) :: process
     class(prc_core_t), pointer :: core, core_sub
     integer, dimension(:), allocatable :: eqv_flv_index_born
     integer, dimension(:), allocatable :: eqv_flv_index_real
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     integer :: i_flv, i_flv2, n_in, i
     integer :: i_component, i_core, i_core_sub
     logical :: fetched_born, fetched_real
     logical :: optimize
     fetched_born = .false.; fetched_real = .false.
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        optimize = pcm%settings%reuse_amplitudes_fks
        if (optimize) then
           do i_component = 1, pcm%n_components
              i_core = pcm%get_i_core(i_component)
              core => process%get_core_ptr (i_core)
              if (.not. core%data_known) cycle
              associate (data => core%data)
                 if (pcm%nlo_type_core(i_core) == NLO_REAL .and. &
                      .not. pcm%component_type(i_component) == COMP_SUB) then
                    if (allocated (core%data%eqv_flv_index)) then
                       eqv_flv_index_real = core%get_equivalent_flv_index ()
                       fetched_real = .true.
                    end if
                    i_core_sub = pcm%get_i_core (pcm%i_sub)
                    core_sub => process%get_core_ptr (i_core_sub)
                    if (allocated (core_sub%data%eqv_flv_index)) then
                       eqv_flv_index_born = core_sub%get_equivalent_flv_index ()
                       fetched_born = .true.
                    end if
                    if (fetched_born .and. fetched_real) exit
                 end if
              end associate
           end do
           if (.not. fetched_born .or. .not. fetched_real) then
              call msg_warning('Failed to fetch flavor equivalence indices. &
                   &Disabling singular region optimization')
              optimize = .false.
              eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)]
              eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)]
           end if
           if (optimize .and. pcm%has_pdfs) then
              flv_born = pcm%region_data%get_flv_states_born ()
              flv_real = pcm%region_data%get_flv_states_real ()
              n_in = pcm%region_data%n_in
              do i_flv = 1, size (eqv_flv_index_born)
                 do i_flv2 = 1, i_flv
                    if (any (flv_born(1:n_in, eqv_flv_index_born(i_flv)) /= &
                         flv_born(1:n_in, i_flv))) then
                       eqv_flv_index_born(i_flv) = i_flv
                       exit
                    end if
                 end do
              end do
              do i_flv = 1, size (eqv_flv_index_real)
                 do i_flv2 = 1, i_flv
                    if (any (flv_real(1:n_in, eqv_flv_index_real(i_flv)) /= &
                         flv_real(1:n_in, i_flv))) then
                       eqv_flv_index_real(i_flv) = i_flv
                       exit
                    end if
                 end do
              end do
           end if
        else
           eqv_flv_index_born = [(i, i = 1, pcm%region_data%n_flv_born)]
           eqv_flv_index_real = [(i, i = 1, pcm%region_data%n_flv_real)]
        end if
        pcm%region_data%eqv_flv_index_born = eqv_flv_index_born
        pcm%region_data%eqv_flv_index_real = eqv_flv_index_real
        call pcm%region_data%find_eqv_regions (optimize)
     end select
   end subroutine process_optimize_nlo_singular_regions
 
 @ %def process_optimize_nlo_singular_regions
 @ For some structure functions we need to get the list of initial
 state flavors.  This is a two-dimensional array.  The first index is
 the beam index, the second index is the component index.  Each array
 element is itself a PDG array object, which consists of the list of
 incoming PDG values for this beam and component.
 <<Process: process: TBP>>=
   procedure :: get_pdg_in => process_get_pdg_in
 <<Process: procedures>>=
   subroutine process_get_pdg_in (process, pdg_in)
     class(process_t), intent(in), target :: process
     type(pdg_array_t), dimension(:,:), allocatable, intent(out) :: pdg_in
     integer :: i, i_core
     allocate (pdg_in (process%config%n_in, process%meta%n_components))
     do i = 1, process%meta%n_components
        if (process%component(i)%active) then
           i_core = process%pcm%get_i_core (i)
           associate (core => process%core_entry(i_core)%core)
             pdg_in(:,i) = core%data%get_pdg_in ()
           end associate
        end if
     end do
   end subroutine process_get_pdg_in
 
 @ %def process_get_pdg_in
 @ The phase-space configuration object, in case we need it separately.
 <<Process: process: TBP>>=
   procedure :: get_phs_config => process_get_phs_config
 <<Process: procedures>>=
   function process_get_phs_config (process, i_component) result (phs_config)
     class(phs_config_t), pointer :: phs_config
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_component
     if (allocated (process%component)) then
        phs_config => process%component(i_component)%phs_config
     else
        phs_config => null ()
     end if
   end function process_get_phs_config
 
 @ %def process_get_phs_config
 @ The resonance history set can be extracted from the phase-space
 configuration.  However, this is only possible if the default phase-space
 method (wood) has been chosen.  If [[include_trivial]] is set, we include the
 resonance history with no resonances in the set.
 <<Process: process: TBP>>=
   procedure :: extract_resonance_history_set &
        => process_extract_resonance_history_set
 <<Process: procedures>>=
   subroutine process_extract_resonance_history_set &
        (process, res_set, include_trivial, i_component)
     class(process_t), intent(in), target :: process
     type(resonance_history_set_t), intent(out) :: res_set
     logical, intent(in), optional :: include_trivial
     integer, intent(in), optional :: i_component
     integer :: i
     i = 1;  if (present (i_component))  i = i_component
     select type (phs_config => process%get_phs_config (i))
     class is (phs_wood_config_t)
        call phs_config%extract_resonance_history_set (res_set, include_trivial)
     class default
        call msg_error ("process '" // char (process%get_id ()) &
             // "': extract resonance histories: phase-space method must be &
             &'wood'.  No resonances can be determined.")
     end select
   end subroutine process_extract_resonance_history_set
 
 @ %def process_extract_resonance_history_set
 @ Initialize from a complete beam setup.  If the beam setup does not
 apply directly to the process, choose a fallback option as a straight
 scattering or decay process.
 <<Process: process: TBP>>=
   procedure :: setup_beams_beam_structure => process_setup_beams_beam_structure
 <<Process: procedures>>=
   subroutine process_setup_beams_beam_structure &
        (process, beam_structure, sqrts, decay_rest_frame)
     class(process_t), intent(inout) :: process
     type(beam_structure_t), intent(in) :: beam_structure
     real(default), intent(in) :: sqrts
     logical, intent(in), optional :: decay_rest_frame
     integer :: n_in
     logical :: applies
     n_in = process%get_n_in ()
     call beam_structure%check_against_n_in (process%get_n_in (), applies)
     if (applies) then
        call process%beam_config%init_beam_structure &
             (beam_structure, sqrts, process%get_model_ptr (), decay_rest_frame)
     else if (n_in == 2) then
        call process%setup_beams_sqrts (sqrts, beam_structure)
     else
        call process%setup_beams_decay (decay_rest_frame, beam_structure)
     end if
   end subroutine process_setup_beams_beam_structure
 
 @ %def process_setup_beams_beam_structure
 @ Notify the user about beam setup.
 <<Process: process: TBP>>=
   procedure :: beams_startup_message => process_beams_startup_message
 <<Process: procedures>>=
   subroutine process_beams_startup_message (process, unit, beam_structure)
     class(process_t), intent(in) :: process
     integer, intent(in), optional :: unit
     type(beam_structure_t), intent(in), optional :: beam_structure
     call process%beam_config%startup_message (unit, beam_structure)
   end subroutine process_beams_startup_message
 
 @ %def process_beams_startup_message
 @ Initialize phase-space configuration by reading out the environment
 variables.  We return the rebuild flags and store parameters in the blocks
 [[phs_par]] and [[mapping_defs]].
 
 The phase-space configuration object(s) are allocated by [[pcm]].
 <<Process: process: TBP>>=
   procedure :: init_phs_config => process_init_phs_config
 <<Process: procedures>>=
   subroutine process_init_phs_config (process)
     class(process_t), intent(inout) :: process
 
     type(var_list_t), pointer :: var_list
     type(phs_parameters_t) :: phs_par
     type(mapping_defaults_t) :: mapping_defs
 
     var_list => process%env%get_var_list_ptr ()
 
     phs_par%m_threshold_s = &
          var_list%get_rval (var_str ("phs_threshold_s"))
     phs_par%m_threshold_t = &
          var_list%get_rval (var_str ("phs_threshold_t"))
     phs_par%off_shell = &
          var_list%get_ival (var_str ("phs_off_shell"))
     phs_par%keep_nonresonant = &
          var_list%get_lval (var_str ("?phs_keep_nonresonant"))
     phs_par%t_channel = &
          var_list%get_ival (var_str ("phs_t_channel"))
 
     mapping_defs%energy_scale = &
          var_list%get_rval (var_str ("phs_e_scale"))
     mapping_defs%invariant_mass_scale = &
          var_list%get_rval (var_str ("phs_m_scale"))
     mapping_defs%momentum_transfer_scale = &
          var_list%get_rval (var_str ("phs_q_scale"))
     mapping_defs%step_mapping = &
          var_list%get_lval (var_str ("?phs_step_mapping"))
     mapping_defs%step_mapping_exp = &
          var_list%get_lval (var_str ("?phs_step_mapping_exp"))
     mapping_defs%enable_s_mapping = &
          var_list%get_lval (var_str ("?phs_s_mapping"))
 
     associate (pcm => process%pcm)
       call pcm%init_phs_config (process%phs_entry, &
            process%meta, process%env, phs_par, mapping_defs)
     end associate
 
   end subroutine process_init_phs_config
 
 @ %def process_init_phs_config
 @ We complete the kinematics configuration after the beam setup, but before we
 configure the chain of structure functions.  The reason is that we need the
 total energy [[sqrts]] for the kinematics, but the structure-function setup
 requires the number of channels, which depends on the kinematics
 configuration.  For instance, the kinematics module may return the need for
 parameterizing an s-channel resonance.
 <<Process: process: TBP>>=
   procedure :: configure_phs => process_configure_phs
 <<Process: procedures>>=
   subroutine process_configure_phs (process, rebuild, ignore_mismatch, &
      combined_integration, subdir)
     class(process_t), intent(inout) :: process
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     logical, intent(in), optional :: combined_integration
     type(string_t), intent(in), optional :: subdir
     real(default) :: sqrts
     integer :: i, i_born, nlo_type
     class(phs_config_t), pointer :: phs_config_born
     sqrts = process%get_sqrts ()
     do i = 1, process%meta%n_components
        associate (component => process%component(i))
          if (component%active) then
             select type (pcm => process%pcm)
             type is (pcm_default_t)
                call component%configure_phs (sqrts, process%beam_config, &
                     rebuild, ignore_mismatch, subdir)
             class is (pcm_nlo_t)
                nlo_type = component%config%get_nlo_type ()
                select case (nlo_type)
                case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
                   call component%configure_phs (sqrts, process%beam_config, &
                        rebuild, ignore_mismatch, subdir)
                   call check_and_extend_phs (component)
                case (NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
                   i_born = component%config%get_associated_born ()
                   if (component%component_type /= COMP_REAL_FIN) &
                        call check_and_extend_phs (component)
                   call process%component(i_born)%get_phs_config &
                        (phs_config_born)
                   select type (config => component%phs_config)
                   type is (phs_fks_config_t)
                      select type (phs_config_born)
                      type is (phs_wood_config_t)
                         config%md5sum_born_config = &
                              phs_config_born%md5sum_phs_config
                         call config%set_born_config (phs_config_born)
                         call config%set_mode (component%config%get_nlo_type ())
                      end select
                   end select
                   call component%configure_phs (sqrts, &
                        process%beam_config, rebuild, ignore_mismatch, subdir)
                end select
             class default
                call msg_bug ("process_configure_phs: unsupported PCM type")
             end select
          end if
        end associate
     end do
   contains
     subroutine check_and_extend_phs (component)
       type(process_component_t), intent(inout) :: component
       if (combined_integration) then
          select type (phs_config => component%phs_config)
          class is (phs_wood_config_t)
             phs_config%is_combined_integration = .true.
             call phs_config%increase_n_par ()
          end select
       end if
     end subroutine check_and_extend_phs
   end subroutine process_configure_phs
 
 @ %def process_configure_phs
 @
 <<Process: process: TBP>>=
   procedure :: print_phs_startup_message => process_print_phs_startup_message
 <<Process: procedures>>=
   subroutine process_print_phs_startup_message (process)
     class(process_t), intent(in) :: process
     integer :: i_component
     do i_component = 1, process%meta%n_components
        associate (component => process%component(i_component))
           if (component%active) then
              call component%phs_config%startup_message ()
           end if
        end associate
     end do
   end subroutine process_print_phs_startup_message
 
 @ %def process_print_phs_startup_message
 @ Insert the structure-function configuration data.  First allocate the
 storage, then insert data one by one.  The third procedure declares a
 mapping (of the MC input parameters) for a specific channel and
 structure-function combination.
 
 We take the number of channels from the corresponding entry in the
 [[config_data]] section.
 
 Otherwise, these a simple wrapper routines.  The extra level in the
 call tree may allow for simple addressing of multiple concurrent beam
 configurations, not implemented currently.
 
 If we do not want structure functions, we simply do not call those procedures.
 <<Process: process: TBP>>=
   procedure :: init_sf_chain => process_init_sf_chain
   generic :: set_sf_channel => set_sf_channel_single
   procedure :: set_sf_channel_single => process_set_sf_channel
   generic :: set_sf_channel => set_sf_channel_array
   procedure :: set_sf_channel_array => process_set_sf_channel_array
 <<Process: procedures>>=
   subroutine process_init_sf_chain (process, sf_config, sf_trace_file)
     class(process_t), intent(inout) :: process
     type(sf_config_t), dimension(:), intent(in) :: sf_config
     type(string_t), intent(in), optional :: sf_trace_file
     type(string_t) :: file
     if (present (sf_trace_file)) then
        if (sf_trace_file /= "") then
           file = sf_trace_file
        else
           file = process%get_id () // "_sftrace.dat"
        end if
        call process%beam_config%init_sf_chain (sf_config, file)
     else
        call process%beam_config%init_sf_chain (sf_config)
     end if
   end subroutine process_init_sf_chain
 
   subroutine process_set_sf_channel (process, c, sf_channel)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: c
     type(sf_channel_t), intent(in) :: sf_channel
     call process%beam_config%set_sf_channel (c, sf_channel)
   end subroutine process_set_sf_channel
 
   subroutine process_set_sf_channel_array (process, sf_channel)
     class(process_t), intent(inout) :: process
     type(sf_channel_t), dimension(:), intent(in) :: sf_channel
     integer :: c
     call process%beam_config%allocate_sf_channels (size (sf_channel))
     do c = 1, size (sf_channel)
        call process%beam_config%set_sf_channel (c, sf_channel(c))
     end do
   end subroutine process_set_sf_channel_array
 
 @ %def process_init_sf_chain
 @ %def process_set_sf_channel
 @ Notify about the structure-function setup.
 <<Process: process: TBP>>=
   procedure :: sf_startup_message => process_sf_startup_message
 <<Process: procedures>>=
   subroutine process_sf_startup_message (process, sf_string, unit)
     class(process_t), intent(in) :: process
     type(string_t), intent(in) :: sf_string
     integer, intent(in), optional :: unit
     call process%beam_config%sf_startup_message (sf_string, unit)
   end subroutine process_sf_startup_message
 
 @ %def process_sf_startup_message
 @ As soon as both the kinematics configuration and the
 structure-function setup are complete, we match parameterizations
 (channels) for both.  The matching entries are (re)set in the
 [[component]] phase-space configuration, while the structure-function
 configuration is left intact.
 <<Process: process: TBP>>=
   procedure :: collect_channels => process_collect_channels
 <<Process: procedures>>=
   subroutine process_collect_channels (process, coll)
     class(process_t), intent(inout) :: process
     type(phs_channel_collection_t), intent(inout) :: coll
     integer :: i
     do i = 1, process%meta%n_components
        associate (component => process%component(i))
          if (component%active) &
             call component%collect_channels (coll)
        end associate
     end do
   end subroutine process_collect_channels
 
 @ %def process_collect_channels
 @ Independently, we should be able to check if any component does not
 contain phase-space parameters.  Such a process can only be integrated
 if there are structure functions.
 <<Process: process: TBP>>=
   procedure :: contains_trivial_component => process_contains_trivial_component
 <<Process: procedures>>=
   function process_contains_trivial_component (process) result (flag)
     class(process_t), intent(in) :: process
     logical :: flag
     integer :: i
     flag = .true.
     do i = 1, process%meta%n_components
        associate (component => process%component(i))
          if (component%active) then
             if (component%get_n_phs_par () == 0)  return
          end if
        end associate
     end do
     flag = .false.
   end function process_contains_trivial_component
 
 @ %def process_contains_trivial_component
 @
 <<Process: process: TBP>>=
   procedure :: get_master_component => process_get_master_component
 <<Process: procedures>>=
   function process_get_master_component (process, i_mci) result (i_component)
      integer :: i_component
      class(process_t), intent(in) :: process
      integer, intent(in) :: i_mci
      integer :: i
      i_component = 0
      do i = 1, size (process%component)
         if (process%component(i)%i_mci == i_mci) then
            i_component = i
            return
         end if
      end do
   end function process_get_master_component
 
 
 @ %def process_get_master_component
 @ Determine the MC parameter set structure and the MCI configuration for each
 process component.  We need data from the structure-function and phase-space
 setup, so those should be complete before this is called.  We also
 make a random-number generator instance for each MCI group.
 <<Process: process: TBP>>=
   procedure :: setup_mci => process_setup_mci
 <<Process: procedures>>=
   subroutine process_setup_mci (process, dispatch_mci)
     class(process_t), intent(inout) :: process
     procedure(dispatch_mci_proc) :: dispatch_mci
     class(mci_t), allocatable :: mci_template
     integer :: i, i_mci
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_setup_mci")
     associate (pcm => process%pcm)
       call pcm%call_dispatch_mci (dispatch_mci, &
            process%get_var_list_ptr (), process%meta%id, mci_template)
       call pcm%setup_mci (process%mci_entry)
       process%config%n_mci = pcm%n_mci
       process%component(:)%i_mci = pcm%i_mci(:)
       do i = 1, pcm%n_components
          i_mci = process%pcm%i_mci(i)
          if (i_mci > 0) then
             associate (component => process%component(i), &
                  mci_entry => process%mci_entry(i_mci))
               call mci_entry%configure (mci_template, &
                    process%meta%type, &
                    i_mci, i, component, process%beam_config%n_sfpar, &
                    process%rng_factory)
               call mci_entry%set_parameters (process%get_var_list_ptr ())
             end associate
          end if
       end do
     end associate
   end subroutine process_setup_mci
 
 @ %def process_setup_mci
 @ Set cuts.  This is a parse node, namely the right-hand side of the [[cut]]
 assignment.  When creating an instance, we compile this into an evaluation
 tree.  The parse node may be null.
 <<Process: process: TBP>>=
   procedure :: set_cuts => process_set_cuts
 <<Process: procedures>>=
   subroutine process_set_cuts (process, ef_cuts)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_cuts
     allocate (process%config%ef_cuts, source = ef_cuts)
   end subroutine process_set_cuts
 
 @ %def process_set_cuts
 @ Analogously for the other expressions.
 <<Process: process: TBP>>=
   procedure :: set_scale => process_set_scale
   procedure :: set_fac_scale => process_set_fac_scale
   procedure :: set_ren_scale => process_set_ren_scale
   procedure :: set_weight => process_set_weight
 <<Process: procedures>>=
   subroutine process_set_scale (process, ef_scale)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_scale
     allocate (process%config%ef_scale, source = ef_scale)
   end subroutine process_set_scale
 
   subroutine process_set_fac_scale (process, ef_fac_scale)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_fac_scale
     allocate (process%config%ef_fac_scale, source = ef_fac_scale)
   end subroutine process_set_fac_scale
 
   subroutine process_set_ren_scale (process, ef_ren_scale)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_ren_scale
     allocate (process%config%ef_ren_scale, source = ef_ren_scale)
   end subroutine process_set_ren_scale
 
   subroutine process_set_weight (process, ef_weight)
     class(process_t), intent(inout) :: process
     class(expr_factory_t), intent(in) :: ef_weight
     allocate (process%config%ef_weight, source = ef_weight)
   end subroutine process_set_weight
 
 @ %def process_set_scale
 @ %def process_set_fac_scale
 @ %def process_set_ren_scale
 @ %def process_set_weight
 @
 \subsubsection{MD5 sum}
 The MD5 sum of the process object should reflect the state completely,
 including integration results.  It is used for checking the integrity
 of event files.  This global checksum includes checksums for the
 various parts.  In particular, the MCI object receives a checksum that
 includes the configuration of all configuration parts relevant for an
 individual integration.  This checksum is used for checking the
 integrity of integration grids.
 
 We do not need MD5 sums for the process terms, since these are
 generated from the component definitions.
 <<Process: process: TBP>>=
   procedure :: compute_md5sum => process_compute_md5sum
 <<Process: procedures>>=
   subroutine process_compute_md5sum (process)
     class(process_t), intent(inout) :: process
     integer :: i
     call process%config%compute_md5sum ()
     do i = 1, process%config%n_components
        associate (component => process%component(i))
          if (component%active) then
             call component%compute_md5sum ()
          end if
        end associate
     end do
     call process%beam_config%compute_md5sum ()
     do i = 1, process%config%n_mci
        call process%mci_entry(i)%compute_md5sum &
             (process%config, process%component, process%beam_config)
     end do
   end subroutine process_compute_md5sum
 
 @ %def process_compute_md5sum
 @
 <<Process: process: TBP>>=
   procedure :: sampler_test => process_sampler_test
 <<Process: procedures>>=
   subroutine process_sampler_test (process, sampler, n_calls, i_mci)
     class(process_t), intent(inout) :: process
     class(mci_sampler_t), intent(inout) :: sampler
     integer, intent(in) :: n_calls, i_mci
     call process%mci_entry(i_mci)%sampler_test (sampler, n_calls)
   end subroutine process_sampler_test
 
 @ %def process_sampler_test
 @ The finalizer should be called after all integration passes have been
 completed.  It will, for instance, write a summary of the integration
 results.
 
 [[integrate_dummy]] does a ``dummy'' integration in the sense that
 nothing is done but just empty integration results appended.
 <<Process: process: TBP>>=
   procedure :: final_integration => process_final_integration
   procedure :: integrate_dummy => process_integrate_dummy
 <<Process: procedures>>=
   subroutine process_final_integration (process, i_mci)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     call process%mci_entry(i_mci)%final_integration ()
   end subroutine process_final_integration
 
   subroutine process_integrate_dummy (process)
     class(process_t), intent(inout) :: process
     type(integration_results_t) :: results
     integer :: u_log
     u_log = logfile_unit ()
     call results%init (process%meta%type)
     call results%display_init (screen = .true., unit = u_log)
     call results%new_pass ()
     call results%record (1, 0, 0._default, 0._default, 0._default)
     call results%display_final ()
   end subroutine process_integrate_dummy
 
 @ %def process_final_integration
 @ %def process_integrate_dummy
 @
 <<Process: process: TBP>>=
   procedure :: integrate => process_integrate
 <<Process: procedures>>=
   subroutine process_integrate (process, i_mci, mci_work, &
      mci_sampler, n_it, n_calls, adapt_grids, adapt_weights, final, &
      pacify, nlo_type)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(mci_work_t), intent(inout) :: mci_work
     class(mci_sampler_t), intent(inout) :: mci_sampler
     integer, intent(in) :: n_it, n_calls
     logical, intent(in), optional :: adapt_grids, adapt_weights
     logical, intent(in), optional :: final
     logical, intent(in), optional :: pacify
     integer, intent(in), optional :: nlo_type
     associate (mci_entry => process%mci_entry(i_mci))
        call mci_entry%integrate (mci_work%mci, mci_sampler, n_it, n_calls, &
             adapt_grids, adapt_weights, final, pacify, &
             nlo_type = nlo_type)
        call mci_entry%results%display_pass (pacify)
     end associate
   end subroutine process_integrate
 
 @ %def process_integrate
 @
 <<Process: process: TBP>>=
   procedure :: generate_weighted_event => process_generate_weighted_event
 <<Process: procedures>>=
   subroutine process_generate_weighted_event (process, i_mci, mci_work, &
      mci_sampler, keep_failed_events)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(mci_work_t), intent(inout) :: mci_work
     class(mci_sampler_t), intent(inout) :: mci_sampler
     logical, intent(in) :: keep_failed_events
     associate (mci_entry => process%mci_entry(i_mci))
        call mci_entry%generate_weighted_event (mci_work%mci, &
             mci_sampler, keep_failed_events)
     end associate
   end subroutine process_generate_weighted_event
 
 @ %def process_generate_weighted_event
 <<Process: process: TBP>>=
   procedure :: generate_unweighted_event => process_generate_unweighted_event
 <<Process: procedures>>=
   subroutine process_generate_unweighted_event (process, i_mci, &
      mci_work, mci_sampler)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(mci_work_t), intent(inout) :: mci_work
     class(mci_sampler_t), intent(inout) :: mci_sampler
     associate (mci_entry => process%mci_entry(i_mci))
        call mci_entry%generate_unweighted_event &
           (mci_work%mci, mci_sampler)
     end associate
   end subroutine process_generate_unweighted_event
 
 @ %def process_generate_unweighted_event
 @ Display the final results for the sum of all components. This is useful,
 obviously, only if there is more than one component and not if a combined
 integration of all components together has been performed.
 <<Process: process: TBP>>=
   procedure :: display_summed_results => process_display_summed_results
 <<Process: procedures>>=
   subroutine process_display_summed_results (process, pacify)
     class(process_t), intent(inout) :: process
     logical, intent(in) :: pacify
     type(integration_results_t) :: results
     integer :: u_log
     u_log = logfile_unit ()
     call results%init (process%meta%type)
     call results%display_init (screen = .true., unit = u_log)
     call results%new_pass ()
     call results%record (1, 0, &
          process%get_integral (), &
          process%get_error (), &
          process%get_efficiency (), suppress = pacify)
     select type (pcm => process%pcm)
     class is (pcm_nlo_t)
        !!! Check that Born integral is there
        if (.not. pcm%settings%combined_integration .and. &
             process%component_can_be_integrated (1)) then
           call results%record_correction (process%get_correction (), &
                process%get_correction_error ())
        end if
     end select
     call results%display_final ()
   end subroutine process_display_summed_results
 
 @ %def process_display_summed_results
 @ Run LaTeX/Metapost to generate a ps/pdf file for the integration
 history.  We (re)write the driver file -- just in case it has been
 missed before -- then we compile it.
 <<Process: process: TBP>>=
   procedure :: display_integration_history => &
        process_display_integration_history
 <<Process: procedures>>=
   subroutine process_display_integration_history &
        (process, i_mci, filename, os_data, eff_reset)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(string_t), intent(in) :: filename
     type(os_data_t), intent(in) :: os_data
     logical, intent(in), optional :: eff_reset
     call integration_results_write_driver &
          (process%mci_entry(i_mci)%results, filename, eff_reset)
     call integration_results_compile_driver &
          (process%mci_entry(i_mci)%results, filename, os_data)
   end subroutine process_display_integration_history
 
 @ %def subroutine process_display_integration_history
 @ Write a complete logfile (with hardcoded name based on the process ID).
 We do not write internal data.
 <<Process: process: TBP>>=
   procedure :: write_logfile => process_write_logfile
 <<Process: procedures>>=
   subroutine process_write_logfile (process, i_mci, filename)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(string_t), intent(in) :: filename
     type(time_t) :: time
     integer :: unit, u
     unit = free_unit ()
     open (unit = unit, file = char (filename), action = "write", &
           status = "replace")
     u = given_output_unit (unit)
     write (u, "(A)")  repeat ("#", 79)
     call process%meta%write (u, .false.)
     write (u, "(A)")  repeat ("#", 79)
     write (u, "(3x,A,ES17.10)")  "Integral   = ", &
          process%mci_entry(i_mci)%get_integral ()
     write (u, "(3x,A,ES17.10)")  "Error      = ", &
          process%mci_entry(i_mci)%get_error ()
     write (u, "(3x,A,ES17.10)")  "Accuracy   = ", &
          process%mci_entry(i_mci)%get_accuracy ()
     write (u, "(3x,A,ES17.10)")  "Chi2       = ", &
          process%mci_entry(i_mci)%get_chi2 ()
     write (u, "(3x,A,ES17.10)")  "Efficiency = ", &
          process%mci_entry(i_mci)%get_efficiency ()
     call process%mci_entry(i_mci)%get_time (time, 10000)
     if (time%is_known ()) then
        write (u, "(3x,A,1x,A)")  "T(10k evt) = ", char (time%to_string_dhms ())
     else
        write (u, "(3x,A)")  "T(10k evt) =  [undefined]"
     end if
     call process%mci_entry(i_mci)%results%write (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%mci_entry(i_mci)%results%write_chain_weights (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%mci_entry(i_mci)%counter%write (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%mci_entry(i_mci)%mci%write_log_entry (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%beam_config%data%write (u)
     write (u, "(A)")  repeat ("#", 79)
     if (allocated (process%config%ef_cuts)) then
        write (u, "(3x,A)") "Cut expression:"
        call process%config%ef_cuts%write (u)
     else
        write (u, "(3x,A)") "No cuts used."
     end if
     call write_separator (u)
     if (allocated (process%config%ef_scale)) then
        write (u, "(3x,A)") "Scale expression:"
        call process%config%ef_scale%write (u)
     else
        write (u, "(3x,A)") "No scale expression was given."
     end if
     call write_separator (u)
     if (allocated (process%config%ef_fac_scale)) then
        write (u, "(3x,A)") "Factorization scale expression:"
        call process%config%ef_fac_scale%write (u)
     else
        write (u, "(3x,A)") "No factorization scale expression was given."
     end if
     call write_separator (u)
     if (allocated (process%config%ef_ren_scale)) then
        write (u, "(3x,A)") "Renormalization scale expression:"
        call process%config%ef_ren_scale%write (u)
     else
        write (u, "(3x,A)") "No renormalization scale expression was given."
     end if
     call write_separator (u)
     if (allocated (process%config%ef_weight)) then
        call write_separator (u)
        write (u, "(3x,A)") "Weight expression:"
        call process%config%ef_weight%write (u)
     else
        write (u, "(3x,A)") "No weight expression was given."
     end if
     write (u, "(A)")  repeat ("#", 79)
     write (u, "(1x,A)") "Summary of quantum-number states:"
     write (u, "(1x,A)")  " + sign: allowed and contributing"
     write (u, "(1x,A)")  " no +  : switched off at runtime"
     call process%write_state_summary (u)
     write (u, "(A)")  repeat ("#", 79)
     call process%env%write (u, show_var_list=.true., &
               show_model=.false., show_lib=.false., show_os_data=.false.)
     write (u, "(A)")  repeat ("#", 79)
     close (u)
   end subroutine process_write_logfile
 
 @ %def process_write_logfile
 @ Display the quantum-number combinations of the process components, and their
 current status (allowed or switched off).
 <<Process: process: TBP>>=
   procedure :: write_state_summary => process_write_state_summary
 <<Process: procedures>>=
   subroutine process_write_state_summary (process, unit)
     class(process_t), intent(in) :: process
     integer, intent(in), optional :: unit
     integer :: i, i_component, u
     u = given_output_unit (unit)
     do i = 1, size (process%term)
        call write_separator (u)
        i_component = process%term(i)%i_component
        if (i_component /= 0) then
           call process%term(i)%write_state_summary &
                (process%get_core_term(i), unit)
        end if
     end do
   end subroutine process_write_state_summary
 
 @ %def process_write_state_summary
 @ Prepare event generation for the specified MCI entry.  This implies, in
 particular, checking the phase-space file.
 <<Process: process: TBP>>=
   procedure :: prepare_simulation => process_prepare_simulation
 <<Process: procedures>>=
   subroutine process_prepare_simulation (process, i_mci)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     call process%mci_entry(i_mci)%prepare_simulation ()
   end subroutine process_prepare_simulation
 
 @ %def process_prepare_simulation
 @
 \subsubsection{Retrieve process data}
 Tell whether integral (and error) are known.
 <<Process: process: TBP>>=
   generic :: has_integral => has_integral_tot, has_integral_mci
   procedure :: has_integral_tot => process_has_integral_tot
   procedure :: has_integral_mci => process_has_integral_mci
 <<Process: procedures>>=
   function process_has_integral_mci (process, i_mci) result (flag)
     logical :: flag
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     if (allocated (process%mci_entry)) then
        flag = process%mci_entry(i_mci)%has_integral ()
     else
        flag = .false.
     end if
   end function process_has_integral_mci
 
   function process_has_integral_tot (process) result (flag)
     logical :: flag
     class(process_t), intent(in) :: process
     integer :: i, j, i_component
     if (allocated (process%mci_entry)) then
        flag = .true.
        do i = 1, size (process%mci_entry)
           do j = 1, size (process%mci_entry(i)%i_component)
              i_component = process%mci_entry(i)%i_component(j)
              if (process%component_can_be_integrated (i_component)) &
                 flag = flag .and. process%mci_entry(i)%has_integral ()
           end do
        end do
     else
        flag = .false.
     end if
   end function process_has_integral_tot
 
 @ %def process_has_integral
 @
 Return the current integral and error obtained by the integrator [[i_mci]].
 <<Process: process: TBP>>=
   generic :: get_integral => get_integral_tot, get_integral_mci
   generic :: get_error => get_error_tot, get_error_mci
   generic :: get_efficiency => get_efficiency_tot, get_efficiency_mci
   procedure :: get_integral_tot => process_get_integral_tot
   procedure :: get_integral_mci => process_get_integral_mci
   procedure :: get_error_tot => process_get_error_tot
   procedure :: get_error_mci => process_get_error_mci
   procedure :: get_efficiency_tot => process_get_efficiency_tot
   procedure :: get_efficiency_mci => process_get_efficiency_mci
 <<Process: procedures>>=
   function process_get_integral_mci (process, i_mci) result (integral)
     real(default) :: integral
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     integral = process%mci_entry(i_mci)%get_integral ()
   end function process_get_integral_mci
 
   function process_get_error_mci (process, i_mci) result (error)
     real(default) :: error
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     error = process%mci_entry(i_mci)%get_error ()
   end function process_get_error_mci
 
   function process_get_efficiency_mci (process, i_mci) result (efficiency)
     real(default) :: efficiency
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     efficiency = process%mci_entry(i_mci)%get_efficiency ()
   end function process_get_efficiency_mci
 
   function process_get_integral_tot (process) result (integral)
     real(default) :: integral
     class(process_t), intent(in) :: process
     integer :: i, j, i_component
     integral = zero
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           do j = 1, size (process%mci_entry(i)%i_component)
              i_component = process%mci_entry(i)%i_component(j)
              if (process%component_can_be_integrated(i_component)) &
                   integral = integral + process%mci_entry(i)%get_integral ()
           end do
        end do
     end if
   end function process_get_integral_tot
 
   function process_get_error_tot (process) result (error)
     real(default) :: variance
     class(process_t), intent(in) :: process
     real(default) :: error
     integer :: i, j, i_component
     variance = zero
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           do j = 1, size (process%mci_entry(i)%i_component)
              i_component = process%mci_entry(i)%i_component(j)
              if (process%component_can_be_integrated(i_component)) &
                   variance = variance + process%mci_entry(i)%get_error () ** 2
           end do
        end do
     end if
     error = sqrt (variance)
   end function process_get_error_tot
 
   function process_get_efficiency_tot (process) result (efficiency)
     real(default) :: efficiency
     class(process_t), intent(in) :: process
     real(default) :: den, eff, int
     integer :: i, j, i_component
     den = zero
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           do j = 1, size (process%mci_entry(i)%i_component)
              i_component = process%mci_entry(i)%i_component(j)
              if (process%component_can_be_integrated(i_component)) then
                 int = process%get_integral (i)
                 if (int > 0) then
                    eff = process%mci_entry(i)%get_efficiency ()
                    if (eff > 0) then
                       den = den + int / eff
                    else
                       efficiency = 0
                       return
                    end if
                 end if
              end if
           end do
        end do
     end if
     if (den > 0) then
        efficiency = process%get_integral () / den
     else
        efficiency = 0
     end if
   end function process_get_efficiency_tot
 
 @ %def process_get_integral process_get_efficiency
 @ Let us call the ratio of the NLO and the LO result $\iota = I_{NLO} / I_{LO}$. Then
 usual error propagation gives
 \begin{equation*}
   \sigma_{\iota}^2 = \left(\frac{\partial \iota}{\partial I_{LO}}\right)^2 \sigma_{I_{LO}}^2
                    + \left(\frac{\partial \iota}{\partial I_{NLO}}\right)^2 \sigma_{I_{NLO}}^2
                    = \frac{I_{NLO}^2\sigma_{I_{LO}}^2}{I_{LO}^4} + \frac{\sigma_{I_{NLO}}^2}{I_{LO}^2}.
 \end{equation*}
 <<Process: process: TBP>>=
   procedure :: get_correction => process_get_correction
   procedure :: get_correction_error => process_get_correction_error
 <<Process: procedures>>=
   function process_get_correction (process) result (ratio)
     real(default) :: ratio
     class(process_t), intent(in) :: process
     integer :: i_mci, i_component
     real(default) :: int_born, int_nlo
     int_nlo = zero
     int_born = process%mci_entry(1)%get_integral ()
     i_mci = 2
     do i_component = 2, size (process%component)
        if (process%component_can_be_integrated (i_component)) then
           int_nlo = int_nlo + process%mci_entry(i_mci)%get_integral ()
           i_mci = i_mci + 1
        end if
     end do
     ratio = int_nlo / int_born * 100
   end function process_get_correction
 
   function process_get_correction_error (process) result (error)
     real(default) :: error
     class(process_t), intent(in) :: process
     real(default) :: int_born, sum_int_nlo
     real(default) :: err_born, err2
     integer :: i_mci, i_component
     sum_int_nlo = zero; err2 = zero
     int_born = process%mci_entry(1)%get_integral ()
     err_born = process%mci_entry(1)%get_error ()
     i_mci = 2
     do i_component = 2, size (process%component)
        if (process%component_can_be_integrated (i_component)) then
           sum_int_nlo = sum_int_nlo + process%mci_entry(i_mci)%get_integral ()
           err2 = err2 + process%mci_entry(i_mci)%get_error()**2
           i_mci = i_mci + 1
        end if
     end do
     error = sqrt (err2 / int_born**2 + sum_int_nlo**2 * err_born**2 / int_born**4) * 100
   end function process_get_correction_error
 
 @ %def process_get_correction process_get_correction_error
 @
 <<Process: process: TBP>>=
   procedure :: lab_is_cm => process_lab_is_cm
 <<Process: procedures>>=
   pure function process_lab_is_cm (process) result (lab_is_cm)
     logical :: lab_is_cm
     class(process_t), intent(in) :: process
     lab_is_cm = process%beam_config%lab_is_cm
     ! This asks beam_config for the frame
   end function process_lab_is_cm
 
 @ %def process_lab_is_cm
 @
 <<Process: process: TBP>>=
   procedure :: get_component_ptr => process_get_component_ptr
 <<Process: procedures>>=
   function process_get_component_ptr (process, i) result (component)
     type(process_component_t), pointer :: component
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i
     component => process%component(i)
   end function process_get_component_ptr
 
 @ %def process_get_component_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_qcd => process_get_qcd
 <<Process: procedures>>=
   function process_get_qcd (process) result (qcd)
     type(qcd_t) :: qcd
     class(process_t), intent(in) :: process
     qcd = process%config%get_qcd ()
   end function process_get_qcd
 
 @ %def process_get_qcd
 @
 <<Process: process: TBP>>=
   generic :: get_component_type => get_component_type_single
   procedure :: get_component_type_single => process_get_component_type_single
 <<Process: procedures>>=
   elemental function process_get_component_type_single &
      (process, i_component) result (comp_type)
     integer :: comp_type
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     comp_type = process%component(i_component)%component_type
   end function process_get_component_type_single
 
 @ %def process_get_component_type_single
 @
 <<Process: process: TBP>>=
   generic :: get_component_type => get_component_type_all
   procedure :: get_component_type_all => process_get_component_type_all
 <<Process: procedures>>=
   function process_get_component_type_all &
      (process) result (comp_type)
     integer, dimension(:), allocatable :: comp_type
     class(process_t), intent(in) :: process
     allocate (comp_type (size (process%component)))
     comp_type = process%component%component_type
   end function process_get_component_type_all
 
 @ %def process_get_component_type_all
 @
 <<Process: process: TBP>>=
   procedure :: get_component_i_terms => process_get_component_i_terms
 <<Process: procedures>>=
   function process_get_component_i_terms (process, i_component) result (i_term)
      integer, dimension(:), allocatable :: i_term
      class(process_t), intent(in) :: process
      integer, intent(in) :: i_component
      allocate (i_term (size (process%component(i_component)%i_term)))
      i_term = process%component(i_component)%i_term
   end function process_get_component_i_terms
 
 @ %def process_get_component_i_terms
 @
 <<Process: process: TBP>>=
   procedure :: get_n_allowed_born => process_get_n_allowed_born
 <<Process: procedures>>=
   function process_get_n_allowed_born (process, i_born) result (n_born)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_born
     integer :: n_born
     n_born = process%term(i_born)%n_allowed
   end function process_get_n_allowed_born
 
 @ %def process_get_n_allowed_born
 @ Workaround getter. Would be better to remove this.
 <<Process: process: TBP>>=
   procedure :: get_pcm_ptr => process_get_pcm_ptr
 <<Process: procedures>>=
   function process_get_pcm_ptr (process) result (pcm)
     class(pcm_t), pointer :: pcm
     class(process_t), intent(in), target :: process
     pcm => process%pcm
   end function process_get_pcm_ptr
 
 @ %def process_get_pcm_ptr
 <<Process: process: TBP>>=
   generic :: component_can_be_integrated => component_can_be_integrated_single
   generic :: component_can_be_integrated => component_can_be_integrated_all
   procedure :: component_can_be_integrated_single => process_component_can_be_integrated_single
 <<Process: procedures>>=
   function process_component_can_be_integrated_single (process, i_component) &
            result (active)
     logical :: active
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     logical :: combined_integration
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        combined_integration = pcm%settings%combined_integration
     class default
        combined_integration = .false.
     end select
     associate (component => process%component(i_component))
        active = component%can_be_integrated ()
        if (combined_integration) &
             active = active .and. component%component_type <= COMP_MASTER
     end associate
   end function process_component_can_be_integrated_single
 
 @ %def process_component_can_be_integrated_single
 @
 <<Process: process: TBP>>=
   procedure :: component_can_be_integrated_all => process_component_can_be_integrated_all
 <<Process: procedures>>=
   function process_component_can_be_integrated_all (process) result (val)
     logical, dimension(:), allocatable :: val
     class(process_t), intent(in) :: process
     integer :: i
     allocate (val (size (process%component)))
     do i = 1, size (process%component)
        val(i) = process%component_can_be_integrated (i)
     end do
   end function process_component_can_be_integrated_all
 
 @ %def process_component_can_be_integrated_all
 @
 <<Process: process: TBP>>=
   procedure :: reset_selected_cores => process_reset_selected_cores
 <<Process: procedures>>=
   pure subroutine process_reset_selected_cores (process)
     class(process_t), intent(inout) :: process
     process%pcm%component_selected = .false.
   end subroutine process_reset_selected_cores
 
 @ %def process_reset_selected_cores
 @
 <<Process: process: TBP>>=
   procedure :: select_components => process_select_components
 <<Process: procedures>>=
   pure subroutine process_select_components (process, indices)
     class(process_t), intent(inout) :: process
     integer, dimension(:), intent(in) :: indices
     associate (pcm => process%pcm)
       pcm%component_selected(indices) = .true.
     end associate
   end subroutine process_select_components
 
 @ %def process_select_components
 @
 <<Process: process: TBP>>=
   procedure :: component_is_selected => process_component_is_selected
 <<Process: procedures>>=
   pure function process_component_is_selected (process, index) result (val)
     logical :: val
     class(process_t), intent(in) :: process
     integer, intent(in) :: index
     associate (pcm => process%pcm)
       val = pcm%component_selected(index)
     end associate
   end function process_component_is_selected
 
 @ %def process_component_is_selected
 @
 <<Process: process: TBP>>=
   procedure :: get_coupling_powers => process_get_coupling_powers
 <<Process: procedures>>=
   pure subroutine process_get_coupling_powers (process, alpha_power, alphas_power)
     class(process_t), intent(in) :: process
     integer, intent(out) :: alpha_power, alphas_power
     call process%component(1)%config%get_coupling_powers (alpha_power, alphas_power)
   end subroutine process_get_coupling_powers
 
 @ %def process_get_coupling_powers
 @
 <<Process: process: TBP>>=
   procedure :: get_real_component => process_get_real_component
 <<Process: procedures>>=
   function process_get_real_component (process) result (i_real)
     integer :: i_real
     class(process_t), intent(in) :: process
     integer :: i_component
     type(process_component_def_t), pointer :: config => null ()
     i_real = 0
     do i_component = 1, size (process%component)
        config => process%get_component_def_ptr (i_component)
        if (config%get_nlo_type () == NLO_REAL) then
           i_real = i_component
           exit
        end if
     end do
   end function process_get_real_component
 
 @ %def process_get_real_component
 @
 <<Process: process: TBP>>=
   procedure :: extract_active_component_mci => process_extract_active_component_mci
 <<Process: procedures>>=
   function process_extract_active_component_mci (process) result (i_active)
     integer :: i_active
     class(process_t), intent(in) :: process
     integer :: i_mci, j, i_component, n_active
     call count_n_active ()
     if (n_active /= 1) i_active = 0
   contains
     subroutine count_n_active ()
        n_active = 0
        do i_mci = 1, size (process%mci_entry)
           associate (mci_entry => process%mci_entry(i_mci))
              do j = 1, size (mci_entry%i_component)
                 i_component = mci_entry%i_component(j)
                 associate (component => process%component (i_component))
                    if (component%can_be_integrated ()) then
                       i_active = i_mci
                       n_active = n_active + 1
                    end if
                 end associate
              end do
           end associate
        end do
     end subroutine count_n_active
   end function process_extract_active_component_mci
 
 @ %def process_extract_active_component_mci
 @
 <<Process: process: TBP>>=
   procedure :: uses_real_partition => process_uses_real_partition
 <<Process: procedures>>=
   function process_uses_real_partition (process) result (val)
      logical :: val
      class(process_t), intent(in) :: process
      val = any (process%mci_entry%real_partition_type /= REAL_FULL)
   end function process_uses_real_partition
 
 @ %def process_uses_real_partition
 @ Return the MD5 sums that summarize the process component
 definitions.  These values should be independent of parameters, beam
 details, expressions, etc.  They can be used for checking the
 integrity of a process when reusing an old event file.
 <<Process: process: TBP>>=
   procedure :: get_md5sum_prc => process_get_md5sum_prc
 <<Process: procedures>>=
   function process_get_md5sum_prc (process, i_component) result (md5sum)
     character(32) :: md5sum
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     if (process%component(i_component)%active) then
        md5sum = process%component(i_component)%config%get_md5sum ()
     else
        md5sum = ""
     end if
   end function process_get_md5sum_prc
 
 @ %def process_get_md5sum_prc
 @ Return the MD5 sums that summarize the state of the MCI integrators.
 These values should encode all process data, integration and phase
 space configuration, etc., and the integration results.  They can thus
 be used for checking the integrity of an event-generation setup when
 reusing an old event file.
 <<Process: process: TBP>>=
   procedure :: get_md5sum_mci => process_get_md5sum_mci
 <<Process: procedures>>=
   function process_get_md5sum_mci (process, i_mci) result (md5sum)
     character(32) :: md5sum
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     md5sum = process%mci_entry(i_mci)%get_md5sum ()
   end function process_get_md5sum_mci
 
 @ %def process_get_md5sum_mci
 @ Return the MD5 sum of the process configuration.  This should encode
 the process setup, data, and expressions, but no integration results.
 <<Process: process: TBP>>=
   procedure :: get_md5sum_cfg => process_get_md5sum_cfg
 <<Process: procedures>>=
   function process_get_md5sum_cfg (process) result (md5sum)
     character(32) :: md5sum
     class(process_t), intent(in) :: process
     md5sum = process%config%md5sum
   end function process_get_md5sum_cfg
 
 @ %def process_get_md5sum_cfg
 @
 <<Process: process: TBP>>=
   procedure :: get_n_cores => process_get_n_cores
 <<Process: procedures>>=
   function process_get_n_cores (process) result (n)
     integer :: n
     class(process_t), intent(in) :: process
     n = process%pcm%n_cores
   end function process_get_n_cores
 
 @ %def process_get_n_cores
 @
 <<Process: process: TBP>>=
   procedure :: get_base_i_term => process_get_base_i_term
 <<Process: procedures>>=
   function process_get_base_i_term (process, i_component) result (i_term)
     integer :: i_term
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     i_term = process%component(i_component)%i_term(1)
   end function process_get_base_i_term
 
 @ %def process_get_base_i_term
 @
 <<Process: process: TBP>>=
   procedure :: get_core_term => process_get_core_term
 <<Process: procedures>>=
   function process_get_core_term (process, i_term) result (core)
     class(prc_core_t), pointer :: core
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_term
     integer :: i_core
     i_core = process%term(i_term)%i_core
     core => process%core_entry(i_core)%get_core_ptr ()
   end function process_get_core_term
 
 @ %def process_get_core_term
 @
 <<Process: process: TBP>>=
   procedure :: get_core_ptr => process_get_core_ptr
 <<Process: procedures>>=
   function process_get_core_ptr (process, i_core) result (core)
     class(prc_core_t), pointer :: core
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_core
     if (allocated (process%core_entry)) then
        core => process%core_entry(i_core)%get_core_ptr ()
     else
        core => null ()
     end if
   end function process_get_core_ptr
 
 @ %def process_get_core_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_term_ptr => process_get_term_ptr
 <<Process: procedures>>=
   function process_get_term_ptr (process, i) result (term)
     type(process_term_t), pointer :: term
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i
     term => process%term(i)
   end function process_get_term_ptr
 
 @ %def process_get_term_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_i_term => process_get_i_term
 <<Process: procedures>>=
   function process_get_i_term (process, i_core) result (i_term)
     integer :: i_term
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_core
     do i_term = 1, process%get_n_terms ()
        if (process%term(i_term)%i_core == i_core) return
     end do
     i_term = -1
   end function process_get_i_term
 
 @ %def process_get_i_term
 @
 <<Process: process: TBP>>=
   procedure :: get_i_core => process_get_i_core
 <<Process: procedures>>=
   integer function process_get_i_core (process, i_term) result (i_core)
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_term
     i_core = process%term(i_term)%i_core
   end function process_get_i_core
 
 @ %def process_get_i_core
 @
 <<Process: process: TBP>>=
   procedure :: set_i_mci_work => process_set_i_mci_work
 <<Process: procedures>>=
   subroutine process_set_i_mci_work (process, i_mci)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     process%mci_entry(i_mci)%i_mci = i_mci
   end subroutine process_set_i_mci_work
 
 @ %def process_set_i_mci_work
 @
 <<Process: process: TBP>>=
   procedure :: get_i_mci_work => process_get_i_mci_work
 <<Process: procedures>>=
   pure function process_get_i_mci_work (process, i_mci) result (i_mci_work)
     integer :: i_mci_work
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     i_mci_work = process%mci_entry(i_mci)%i_mci
   end function process_get_i_mci_work
 
 @ %def process_get_i_mci_work
 @
 <<Process: process: TBP>>=
   procedure :: get_i_sub => process_get_i_sub
 <<Process: procedures>>=
   elemental function process_get_i_sub (process, i_term) result (i_sub)
     integer :: i_sub
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_term
     i_sub = process%term(i_term)%i_sub
   end function process_get_i_sub
 
 @ %def process_get_i_sub
 @
 <<Process: process: TBP>>=
   procedure :: get_i_term_virtual => process_get_i_term_virtual
 <<Process: procedures>>=
   elemental function process_get_i_term_virtual (process) result (i_term)
     integer :: i_term
     class(process_t), intent(in) :: process
     integer :: i_component
     i_term = 0
     do i_component = 1, size (process%component)
        if (process%component(i_component)%get_nlo_type () == NLO_VIRTUAL) &
             i_term = process%component(i_component)%i_term(1)
     end do
   end function process_get_i_term_virtual
 
 @ %def process_get_i_term_virtual
 @
 <<Process: process: TBP>>=
   generic :: component_is_active => component_is_active_single
   procedure :: component_is_active_single => process_component_is_active_single
 <<Process: procedures>>=
   elemental function process_component_is_active_single (process, i_comp) result (val)
     logical :: val
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_comp
     val = process%component(i_comp)%is_active ()
   end function process_component_is_active_single
 
 @ %def process_component_is_active_single
 @
 <<Process: process: TBP>>=
   generic :: component_is_active => component_is_active_all
   procedure :: component_is_active_all => process_component_is_active_all
 <<Process: procedures>>=
   pure function process_component_is_active_all (process) result (val)
     logical, dimension(:), allocatable :: val
     class(process_t), intent(in) :: process
     allocate (val (size (process%component)))
     val = process%component%is_active ()
   end function process_component_is_active_all
 
 @ %def process_component_is_active_all
 @
 \subsection{Default iterations}
 If the user does not specify the passes and iterations for
 integration, we should be able to give reasonable defaults.  These
 depend on the process, therefore we implement the following procedures
 as methods of the process object.  The algorithm is not very
 sophisticated yet, it may be improved by looking at the process in
 more detail.
 
 We investigate only the first process component, assuming that it
 characterizes the complexity of the process reasonable well.
 
 The number of passes is limited to two: one for adaption, one for
 integration.
 <<Process: process: TBP>>=
   procedure :: get_n_pass_default => process_get_n_pass_default
   procedure :: adapt_grids_default => process_adapt_grids_default
   procedure :: adapt_weights_default => process_adapt_weights_default
 <<Process: procedures>>=
   function process_get_n_pass_default (process) result (n_pass)
     class(process_t), intent(in) :: process
     integer :: n_pass
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (n_eff)
     case (1)
        n_pass = 1
     case default
        n_pass = 2
     end select
   end function process_get_n_pass_default
 
   function process_adapt_grids_default (process, pass) result (flag)
     class(process_t), intent(in) :: process
     integer, intent(in) :: pass
     logical :: flag
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (n_eff)
     case (1)
        flag = .false.
     case default
        select case (pass)
        case (1);  flag = .true.
        case (2);  flag = .false.
        case default
           call msg_bug ("adapt grids default: impossible pass index")
        end select
     end select
   end function process_adapt_grids_default
 
   function process_adapt_weights_default (process, pass) result (flag)
     class(process_t), intent(in) :: process
     integer, intent(in) :: pass
     logical :: flag
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (n_eff)
     case (1)
        flag = .false.
     case default
        select case (pass)
        case (1);  flag = .true.
        case (2);  flag = .false.
        case default
           call msg_bug ("adapt weights default: impossible pass index")
        end select
     end select
   end function process_adapt_weights_default
 
 @ %def process_get_n_pass_default
 @ %def process_adapt_grids_default
 @ %def process_adapt_weights_default
 @ The number of iterations and calls per iteration depends on the
 number of outgoing particles.
 <<Process: process: TBP>>=
   procedure :: get_n_it_default => process_get_n_it_default
   procedure :: get_n_calls_default => process_get_n_calls_default
 <<Process: procedures>>=
   function process_get_n_it_default (process, pass) result (n_it)
     class(process_t), intent(in) :: process
     integer, intent(in) :: pass
     integer :: n_it
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (pass)
     case (1)
        select case (n_eff)
        case (1);   n_it = 1
        case (2);   n_it = 3
        case (3);   n_it = 5
        case (4:5); n_it = 10
        case (6);   n_it = 15
        case (7:);  n_it = 20
        end select
     case (2)
        select case (n_eff)
        case (:3);   n_it = 3
        case (4:);   n_it = 5
        end select
     end select
   end function process_get_n_it_default
 
   function process_get_n_calls_default (process, pass) result (n_calls)
     class(process_t), intent(in) :: process
     integer, intent(in) :: pass
     integer :: n_calls
     integer :: n_eff
     type(process_component_def_t), pointer :: config
     config => process%component(1)%config
     n_eff = config%get_n_tot () - 2
     select case (pass)
     case (1)
        select case (n_eff)
        case (1);   n_calls =   100
        case (2);   n_calls =  1000
        case (3);   n_calls =  5000
        case (4);   n_calls = 10000
        case (5);   n_calls = 20000
        case (6:);  n_calls = 50000
        end select
     case (2)
        select case (n_eff)
        case (:3);  n_calls =  10000
        case (4);   n_calls =  20000
        case (5);   n_calls =  50000
        case (6);   n_calls = 100000
        case (7:);  n_calls = 200000
        end select
     end select
   end function process_get_n_calls_default
 
 @ %def process_get_n_it_default
 @ %def process_get_n_calls_default
 @
 \subsection{Constant process data}
 Manually set the Run ID (unit test only).
 <<Process: process: TBP>>=
   procedure :: set_run_id => process_set_run_id
 <<Process: procedures>>=
   subroutine process_set_run_id (process, run_id)
     class(process_t), intent(inout) :: process
     type(string_t), intent(in) :: run_id
     process%meta%run_id = run_id
   end subroutine process_set_run_id
 
 @ %def process_set_run_id
 @
 The following methods return basic process data that stay constant
 after initialization.
 
 The process and IDs.
 <<Process: process: TBP>>=
   procedure :: get_id => process_get_id
   procedure :: get_num_id => process_get_num_id
   procedure :: get_run_id => process_get_run_id
   procedure :: get_library_name => process_get_library_name
 <<Process: procedures>>=
   function process_get_id (process) result (id)
     class(process_t), intent(in) :: process
     type(string_t) :: id
     id = process%meta%id
   end function process_get_id
 
   function process_get_num_id (process) result (id)
     class(process_t), intent(in) :: process
     integer :: id
     id = process%meta%num_id
   end function process_get_num_id
 
   function process_get_run_id (process) result (id)
     class(process_t), intent(in) :: process
     type(string_t) :: id
     id = process%meta%run_id
   end function process_get_run_id
 
   function process_get_library_name (process) result (id)
     class(process_t), intent(in) :: process
     type(string_t) :: id
     id = process%meta%lib_name
   end function process_get_library_name
 
 @ %def process_get_id process_get_num_id
 @ %def process_get_run_id process_get_library_name
 @ The number of incoming particles.
 <<Process: process: TBP>>=
   procedure :: get_n_in => process_get_n_in
 <<Process: procedures>>=
   function process_get_n_in (process) result (n)
     class(process_t), intent(in) :: process
     integer :: n
     n = process%config%n_in
   end function process_get_n_in
 
 @ %def process_get_n_in
 @ The number of MCI data sets.
 <<Process: process: TBP>>=
   procedure :: get_n_mci => process_get_n_mci
 <<Process: procedures>>=
   function process_get_n_mci (process) result (n)
     class(process_t), intent(in) :: process
     integer :: n
     n = process%config%n_mci
   end function process_get_n_mci
 
 @ %def process_get_n_mci
 @ The number of process components, total.
 <<Process: process: TBP>>=
   procedure :: get_n_components => process_get_n_components
 <<Process: procedures>>=
   function process_get_n_components (process) result (n)
     class(process_t), intent(in) :: process
     integer :: n
     n = process%meta%n_components
   end function process_get_n_components
 
 @ %def process_get_n_components
 @ The number of process terms, total.
 <<Process: process: TBP>>=
   procedure :: get_n_terms => process_get_n_terms
 <<Process: procedures>>=
   function process_get_n_terms (process) result (n)
     class(process_t), intent(in) :: process
     integer :: n
     n = process%config%n_terms
   end function process_get_n_terms
 
 @ %def process_get_n_terms
 @ Return the indices of the components that belong to a
 specific MCI entry.
 <<Process: process: TBP>>=
   procedure :: get_i_component => process_get_i_component
 <<Process: procedures>>=
   subroutine process_get_i_component (process, i_mci, i_component)
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     integer, dimension(:), intent(out), allocatable :: i_component
     associate (mci_entry => process%mci_entry(i_mci))
       allocate (i_component (size (mci_entry%i_component)))
       i_component = mci_entry%i_component
     end associate
   end subroutine process_get_i_component
 
 @ %def process_get_i_component
 @ Return the ID of a specific component.
 <<Process: process: TBP>>=
   procedure :: get_component_id => process_get_component_id
 <<Process: procedures>>=
   function process_get_component_id (process, i_component) result (id)
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     type(string_t) :: id
     id = process%meta%component_id(i_component)
   end function process_get_component_id
 
 @ %def process_get_component_id
 @ Return a pointer to the definition of a specific component.
 <<Process: process: TBP>>=
   procedure :: get_component_def_ptr => process_get_component_def_ptr
 <<Process: procedures>>=
   function process_get_component_def_ptr (process, i_component) result (ptr)
     type(process_component_def_t), pointer :: ptr
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     ptr => process%config%process_def%get_component_def_ptr (i_component)
   end function process_get_component_def_ptr
 
 @ %def process_get_component_def_ptr
 @ These procedures extract and restore (by transferring the
 allocation) the process core.  This is useful for changing process
 parameters from outside this module.
 <<Process: process: TBP>>=
   procedure :: extract_core => process_extract_core
   procedure :: restore_core => process_restore_core
 <<Process: procedures>>=
   subroutine process_extract_core (process, i_term, core)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_term
     class(prc_core_t), intent(inout), allocatable :: core
     integer :: i_core
     i_core = process%term(i_term)%i_core
     call move_alloc (from = process%core_entry(i_core)%core, to = core)
   end subroutine process_extract_core
 
   subroutine process_restore_core (process, i_term, core)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_term
     class(prc_core_t), intent(inout), allocatable :: core
     integer :: i_core
     i_core = process%term(i_term)%i_core
     call move_alloc (from = core, to = process%core_entry(i_core)%core)
   end subroutine process_restore_core
 
 @ %def process_extract_core
 @ %def process_restore_core
 @ The block of process constants.
 <<Process: process: TBP>>=
   procedure :: get_constants => process_get_constants
 <<Process: procedures>>=
   function process_get_constants (process, i_core) result (data)
     type(process_constants_t) :: data
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_core
     data = process%core_entry(i_core)%core%data
   end function process_get_constants
 
 @ %def process_get_constants
 @
 <<Process: process: TBP>>=
   procedure :: get_config => process_get_config
 <<Process: procedures>>=
   function process_get_config (process) result (config)
     type(process_config_data_t) :: config
     class(process_t), intent(in) :: process
     config = process%config
   end function process_get_config
 
 @ %def process_get_config
 @
 Construct an MD5 sum for the constant data, including the NLO type.
 
 For the NLO type [[NLO_MISMATCH]], we pretend that this was
 [[NLO_SUBTRACTION]] instead.
 
 TODO wk 2018: should not depend explicitly on NLO data.
 <<Process: process: TBP>>=
   procedure :: get_md5sum_constants => process_get_md5sum_constants
 <<Process: procedures>>=
   function process_get_md5sum_constants (process, i_component, &
      type_string, nlo_type) result (this_md5sum)
     character(32) :: this_md5sum
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     type(string_t), intent(in) :: type_string
     integer, intent(in) :: nlo_type
     type(process_constants_t) :: data
     integer :: unit
     call process%env%fill_process_constants (process%meta%id, i_component, data)
     unit = data%fill_unit_for_md5sum (.false.)
     write (unit, '(A)') char(type_string)
     select case (nlo_type)
     case (NLO_MISMATCH)
        write (unit, '(I0)')  NLO_SUBTRACTION
     case default
        write (unit, '(I0)')  nlo_type
     end select
     rewind (unit)
     this_md5sum = md5sum (unit)
     close (unit)
   end function process_get_md5sum_constants
 
 @ %def process_get_md5sum_constants
 @ Return the set of outgoing flavors that are associated with a particular
 term. We deduce this from the effective interaction.
 <<Process: process: TBP>>=
   procedure :: get_term_flv_out => process_get_term_flv_out
 <<Process: procedures>>=
   subroutine process_get_term_flv_out (process, i_term, flv)
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_term
     type(flavor_t), dimension(:,:), allocatable, intent(out) :: flv
     type(interaction_t), pointer :: int
     int => process%term(i_term)%int_eff
     if (.not. associated (int))  int => process%term(i_term)%int
     call interaction_get_flv_out (int, flv)
   end subroutine process_get_term_flv_out
 
 @ %def process_get_term_flv_out
 @ Return true if there is any unstable particle in any of the process
 terms.  We decide this based on the provided model instance, not the
 one that is stored in the process object.
 <<Process: process: TBP>>=
   procedure :: contains_unstable => process_contains_unstable
 <<Process: procedures>>=
   function process_contains_unstable (process, model) result (flag)
     class(process_t), intent(in) :: process
     class(model_data_t), intent(in), target :: model
     logical :: flag
     integer :: i_term
     type(flavor_t), dimension(:,:), allocatable :: flv
     flag = .false.
     do i_term = 1, process%get_n_terms ()
        call process%get_term_flv_out (i_term, flv)
        call flv%set_model (model)
        flag = .not. all (flv%is_stable ())
        deallocate (flv)
        if (flag)  return
     end do
   end function process_contains_unstable
 
 @ %def process_contains_unstable
 @ The nominal process energy.
 <<Process: process: TBP>>=
   procedure :: get_sqrts => process_get_sqrts
 <<Process: procedures>>=
   function process_get_sqrts (process) result (sqrts)
     class(process_t), intent(in) :: process
     real(default) :: sqrts
     sqrts = process%beam_config%data%get_sqrts ()
   end function process_get_sqrts
 
 @ %def process_get_sqrts
 @ The lab-frame beam energy/energies..
 <<Process: process: TBP>>=
   procedure :: get_energy => process_get_energy
 <<Process: procedures>>=
   function process_get_energy (process) result (e)
     class(process_t), intent(in) :: process
     real(default), dimension(:), allocatable :: e
     e = process%beam_config%data%get_energy ()
   end function process_get_energy
 
 @ %def process_get_energy
 @ The beam polarization in case of simple degrees.
 <<Process: process: TBP>>=
   procedure :: get_polarization => process_get_polarization
 <<Process: procedures>>=
   function process_get_polarization (process) result (pol)
     class(process_t), intent(in) :: process
     real(default), dimension(2) :: pol
     pol = process%beam_config%data%get_polarization ()
   end function process_get_polarization
 
 @ %def process_get_polarization
 @
 <<Process: process: TBP>>=
   procedure :: get_meta => process_get_meta
 <<Process: procedures>>=
   function process_get_meta (process) result (meta)
     type(process_metadata_t) :: meta
     class(process_t), intent(in) :: process
     meta = process%meta
   end function process_get_meta
 
 @ %def process_get_meta
 <<Process: process: TBP>>=
   procedure :: has_matrix_element => process_has_matrix_element
 <<Process: procedures>>=
   function process_has_matrix_element (process, i, is_term_index) result (active)
     logical :: active
     class(process_t), intent(in) :: process
     integer, intent(in), optional :: i
     logical, intent(in), optional :: is_term_index
     integer :: i_component
     logical :: is_term
     is_term = .false.
     if (present (i)) then
        if (present (is_term_index)) is_term = is_term_index
        if (is_term) then
           i_component = process%term(i)%i_component
        else
           i_component = i
        end if
        active = process%component(i_component)%active
     else
        active = any (process%component%active)
     end if
   end function process_has_matrix_element
 
 @ %def process_has_matrix_element
 @ Pointer to the beam data object.
 <<Process: process: TBP>>=
   procedure :: get_beam_data_ptr => process_get_beam_data_ptr
 <<Process: procedures>>=
   function process_get_beam_data_ptr (process) result (beam_data)
     class(process_t), intent(in), target :: process
     type(beam_data_t), pointer :: beam_data
     beam_data => process%beam_config%data
   end function process_get_beam_data_ptr
 
 @ %def process_get_beam_data_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_beam_config => process_get_beam_config
 <<Process: procedures>>=
   function process_get_beam_config (process) result (beam_config)
     type(process_beam_config_t) :: beam_config
     class(process_t), intent(in) :: process
     beam_config = process%beam_config
   end function process_get_beam_config
 
 @ %def process_get_beam_config
 @
 <<Process: process: TBP>>=
   procedure :: get_beam_config_ptr => process_get_beam_config_ptr
 <<Process: procedures>>=
   function process_get_beam_config_ptr (process) result (beam_config)
     type(process_beam_config_t), pointer :: beam_config
     class(process_t), intent(in), target :: process
     beam_config => process%beam_config
   end function process_get_beam_config_ptr
 
 @ %def process_get_beam_config_ptr
 @ Get the PDF set currently in use, if any.
 <<Process: process: TBP>>=
   procedure :: get_pdf_set => process_get_pdf_set
 <<Process: procedures>>=
   function process_get_pdf_set (process) result (pdf_set)
     class(process_t), intent(in) :: process
     integer :: pdf_set
     pdf_set = process%beam_config%get_pdf_set ()
   end function process_get_pdf_set
 
 @ %def process_get_pdf_set
 @
 <<Process: process: TBP>>=
   procedure :: pcm_contains_pdfs => process_pcm_contains_pdfs
 <<Process: procedures>>=
   function process_pcm_contains_pdfs (process) result (has_pdfs)
     logical :: has_pdfs
     class(process_t), intent(in) :: process
     has_pdfs = process%pcm%has_pdfs
   end function process_pcm_contains_pdfs
 
 @ %def process_pcm_contains_pdfs
 @ Get the beam spectrum file currently in use, if any.
 <<Process: process: TBP>>=
   procedure :: get_beam_file => process_get_beam_file
 <<Process: procedures>>=
   function process_get_beam_file (process) result (file)
     class(process_t), intent(in) :: process
     type(string_t) :: file
     file = process%beam_config%get_beam_file ()
   end function process_get_beam_file
 
 @ %def process_get_beam_file
 @ Pointer to the process variable list.
 <<Process: process: TBP>>=
   procedure :: get_var_list_ptr => process_get_var_list_ptr
 <<Process: procedures>>=
   function process_get_var_list_ptr (process) result (ptr)
     class(process_t), intent(in), target :: process
     type(var_list_t), pointer :: ptr
     ptr => process%env%get_var_list_ptr ()
   end function process_get_var_list_ptr
 
 @ %def process_get_var_list_ptr
 @ Pointer to the common model.
 <<Process: process: TBP>>=
   procedure :: get_model_ptr => process_get_model_ptr
 <<Process: procedures>>=
   function process_get_model_ptr (process) result (ptr)
     class(process_t), intent(in) :: process
     class(model_data_t), pointer :: ptr
     ptr => process%config%model
   end function process_get_model_ptr
 
 @ %def process_get_model_ptr
 @ Use the embedded RNG factory to spawn a new random-number generator
 instance.  (This modifies the state of the factory.)
 <<Process: process: TBP>>=
   procedure :: make_rng => process_make_rng
 <<Process: procedures>>=
   subroutine process_make_rng (process, rng)
     class(process_t), intent(inout) :: process
     class(rng_t), intent(out), allocatable :: rng
     if (allocated (process%rng_factory)) then
        call process%rng_factory%make (rng)
     else
        call msg_bug ("Process: make rng: factory not allocated")
     end if
   end subroutine process_make_rng
 
 @ %def process_make_rng
 @
 \subsection{Compute an amplitude}
 Each process variant should allow for computing an amplitude value
 directly, without generating a process instance.
 
 The process component is selected by the index [[i]].  The term within the
 process component is selected by [[j]].  The momentum
 combination is transferred as the array [[p]].  The function sets the specific
 quantum state via the indices of a flavor [[f]], helicity [[h]], and color
 [[c]] combination.  Each index refers to the list of flavor, helicity, and
 color states, respectively, as stored in the process data.
 
 Optionally, we may set factorization and renormalization scale.  If unset, the
 partonic c.m.\ energy is inserted.
 
 The function checks arguments for validity.
 For invalid arguments (quantum states), we return zero.
 <<Process: process: TBP>>=
   procedure :: compute_amplitude => process_compute_amplitude
 <<Process: procedures>>=
   function process_compute_amplitude &
        (process, i_core, i, j, p, f, h, c, fac_scale, ren_scale, alpha_qcd_forced) &
        result (amp)
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_core
     integer, intent(in) :: i, j
     type(vector4_t), dimension(:), intent(in) :: p
     integer, intent(in) :: f, h, c
     real(default), intent(in), optional :: fac_scale, ren_scale
     real(default), intent(in), allocatable, optional :: alpha_qcd_forced
     real(default) :: fscale, rscale
     real(default), allocatable :: aqcd_forced
     complex(default) :: amp
     class(prc_core_t), pointer :: core
     amp = 0
     if (0 < i .and. i <= process%meta%n_components) then
        if (process%component(i)%active) then
           associate (core => process%core_entry(i_core)%core)
             associate (data => core%data)
               if (size (p) == data%n_in + data%n_out &
                    .and. 0 < f .and. f <= data%n_flv &
                    .and. 0 < h .and. h <= data%n_hel &
                    .and. 0 < c .and. c <= data%n_col) then
                  if (present (fac_scale)) then
                     fscale = fac_scale
                  else
                     fscale = sum (p(data%n_in+1:)) ** 1
                  end if
                  if (present (ren_scale)) then
                     rscale = ren_scale
                  else
                     rscale = fscale
                  end if
                  if (present (alpha_qcd_forced)) then
                     if (allocated (alpha_qcd_forced)) &
                          allocate (aqcd_forced, source = alpha_qcd_forced)
                  end if
                  amp = core%compute_amplitude (j, p, f, h, c, &
                       fscale, rscale, aqcd_forced)
               end if
             end associate
           end associate
        else
           amp = 0
        end if
     end if
   end function process_compute_amplitude
 
 @ %def process_compute_amplitude
 @ Sanity check for the process library.  We abort the program if it
 has changed after process initialization.
 <<Process: process: TBP>>=
   procedure :: check_library_sanity => process_check_library_sanity
 <<Process: procedures>>=
   subroutine process_check_library_sanity (process)
     class(process_t), intent(in) :: process
     call process%env%check_lib_sanity (process%meta)
   end subroutine process_check_library_sanity
 
 @ %def process_check_library_sanity
 @ Reset the association to a process library.
 <<Process: process: TBP>>=
   procedure :: reset_library_ptr => process_reset_library_ptr
 <<Process: procedures>>=
   subroutine process_reset_library_ptr (process)
     class(process_t), intent(inout) :: process
     call process%env%reset_lib_ptr ()
   end subroutine process_reset_library_ptr
 
 @ %def process_reset_library_ptr
 @
 <<Process: process: TBP>>=
   procedure :: set_component_type => process_set_component_type
 <<Process: procedures>>=
   subroutine process_set_component_type (process, i_component, i_type)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_component, i_type
     process%component(i_component)%component_type = i_type
   end subroutine process_set_component_type
 
 @ %def process_set_component_type
 @
 <<Process: process: TBP>>=
   procedure :: set_counter_mci_entry => process_set_counter_mci_entry
 <<Process: procedures>>=
   subroutine process_set_counter_mci_entry (process, i_mci, counter)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: i_mci
     type(process_counter_t), intent(in) :: counter
     process%mci_entry(i_mci)%counter = counter
   end subroutine process_set_counter_mci_entry
 
 @ %def process_set_counter_mci_entry
 @ This is for suppression of numerical noise in the integration results
 stored in the [[process_mci_entry]] type. As the error and efficiency
 enter the MD5 sum, we recompute it.
 <<Process: process: TBP>>=
   procedure :: pacify => process_pacify
 <<Process: procedures>>=
   subroutine process_pacify (process, efficiency_reset, error_reset)
     class(process_t), intent(inout) :: process
     logical, intent(in), optional :: efficiency_reset, error_reset
     logical :: eff_reset, err_reset
     integer :: i
     eff_reset = .false.
     err_reset = .false.
     if (present (efficiency_reset))  eff_reset = efficiency_reset
     if (present (error_reset))  err_reset = error_reset
     if (allocated (process%mci_entry)) then
        do i = 1, size (process%mci_entry)
           call process%mci_entry(i)%results%pacify (efficiency_reset)
           if (allocated (process%mci_entry(i)%mci)) then
              associate (mci => process%mci_entry(i)%mci)
                if (process%mci_entry(i)%mci%error_known &
                     .and. err_reset) &
                     mci%error = 0
                if (process%mci_entry(i)%mci%efficiency_known &
                     .and. eff_reset)  &
                     mci%efficiency = 1
                call mci%pacify (efficiency_reset, error_reset)
                call mci%compute_md5sum ()
              end associate
           end if
        end do
     end if
   end subroutine process_pacify
 
 @ %def process_pacify
 @ The following methods are used only in the unit tests; the access
 process internals directly that would otherwise be hidden.
 <<Process: process: TBP>>=
   procedure :: test_allocate_sf_channels
   procedure :: test_set_component_sf_channel
   procedure :: test_get_mci_ptr
 <<Process: procedures>>=
   subroutine test_allocate_sf_channels (process, n)
     class(process_t), intent(inout) :: process
     integer, intent(in) :: n
     call process%beam_config%allocate_sf_channels (n)
   end subroutine test_allocate_sf_channels
 
   subroutine test_set_component_sf_channel (process, c)
     class(process_t), intent(inout) :: process
     integer, dimension(:), intent(in) :: c
     call process%component(1)%phs_config%set_sf_channel (c)
   end subroutine test_set_component_sf_channel
 
   subroutine test_get_mci_ptr (process, mci)
     class(process_t), intent(in), target :: process
     class(mci_t), intent(out), pointer :: mci
     mci => process%mci_entry(1)%mci
   end subroutine test_get_mci_ptr
 
 @ %def test_allocate_sf_channels
 @ %def test_set_component_sf_channel
 @ %def test_get_mci_ptr
 @
 <<Process: process: TBP>>=
   procedure :: init_mci_work => process_init_mci_work
 <<Process: procedures>>=
   subroutine process_init_mci_work (process, mci_work, i)
     class(process_t), intent(in), target :: process
     type(mci_work_t), intent(out) :: mci_work
     integer, intent(in) :: i
     call mci_work%init (process%mci_entry(i))
   end subroutine process_init_mci_work
 
 @ %def process_init_mci_work
 @
 Prepare the process core with type [[test_me]], or otherwise the externally
 provided [[type_string]] version.  The toy dispatchers as a procedure
 argument come handy, knowing that we need to support only the [[test_me]] and
 [[template]] matrix-element types.
 <<Process: process: TBP>>=
   procedure :: setup_test_cores => process_setup_test_cores
 <<Process: procedures>>=
   subroutine process_setup_test_cores (process, type_string)
     class(process_t), intent(inout) :: process
     class(prc_core_t), allocatable :: core
     type(string_t), intent(in), optional :: type_string
     if (present (type_string)) then
        select case (char (type_string))
        case ("template")
           call process%setup_cores (dispatch_template_core)
        case ("test_me")
           call process%setup_cores (dispatch_test_me_core)
        case default
           call msg_bug ("process setup test cores: unsupported type string")
        end select
     else
        call process%setup_cores (dispatch_test_me_core)
     end if
   end subroutine process_setup_test_cores
 
   subroutine dispatch_test_me_core (core, core_def, model, &
        helicity_selection, qcd, use_color_factors, has_beam_pol)
     use prc_test_core, only: test_t
     class(prc_core_t), allocatable, intent(inout) :: core
     class(prc_core_def_t), intent(in) :: core_def
     class(model_data_t), intent(in), target, optional :: model
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     type(qcd_t), intent(in), optional :: qcd
     logical, intent(in), optional :: use_color_factors
     logical, intent(in), optional :: has_beam_pol
     allocate (test_t :: core)
   end subroutine dispatch_test_me_core
 
   subroutine dispatch_template_core (core, core_def, model, &
        helicity_selection, qcd, use_color_factors, has_beam_pol)
     use prc_template_me, only: prc_template_me_t
     class(prc_core_t), allocatable, intent(inout) :: core
     class(prc_core_def_t), intent(in) :: core_def
     class(model_data_t), intent(in), target, optional :: model
     type(helicity_selection_t), intent(in), optional :: helicity_selection
     type(qcd_t), intent(in), optional :: qcd
     logical, intent(in), optional :: use_color_factors
     logical, intent(in), optional :: has_beam_pol
     allocate (prc_template_me_t :: core)
     select type (core)
     type is (prc_template_me_t)
        call core%set_parameters (model)
     end select
   end subroutine dispatch_template_core
 
 @ %def process_setup_test_cores
 @
 <<Process: process: TBP>>=
   procedure :: get_connected_states => process_get_connected_states
 <<Process: procedures>>=
   function process_get_connected_states (process, i_component, &
          connected_terms) result (connected)
     type(connected_state_t), dimension(:), allocatable :: connected
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     type(connected_state_t), dimension(:), intent(in) :: connected_terms
     integer :: i, i_conn
     integer :: n_conn
     n_conn = 0
     do i = 1, process%get_n_terms ()
        if (process%term(i)%i_component == i_component) then
           n_conn = n_conn + 1
        end if
     end do
     allocate (connected (n_conn))
     i_conn = 1
     do i = 1, process%get_n_terms ()
        if (process%term(i)%i_component == i_component) then
           connected (i_conn) = connected_terms(i)
           i_conn = i_conn + 1
        end if
     end do
   end function process_get_connected_states
 
 @ %def process_get_connected_states
 @
 \subsection{NLO specifics}
 These subroutines (and the NLO specific properties they work on) could
 potentially be moved to [[pcm_nlo_t]] and used more generically in
 [[process_t]] with an appropriate interface in [[pcm_t]]
 
 TODO wk 2018: This is used only by event initialization, which deals with an incomplete
 process object.
 <<Process: process: TBP>>=
   procedure :: init_nlo_settings => process_init_nlo_settings
 <<Process: procedures>>=
   subroutine process_init_nlo_settings (process, var_list)
     class(process_t), intent(inout) :: process
     type(var_list_t), intent(in), target :: var_list
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        call pcm%init_nlo_settings (var_list)
        if (debug_active (D_SUBTRACTION) .or. debug_active (D_VIRTUAL)) &
               call pcm%settings%write ()
     class default
        call msg_fatal ("Attempt to set nlo_settings with a non-NLO pcm!")
     end select
   end subroutine process_init_nlo_settings
 
 @ %def process_init_nlo_settings
 @
 <<Process: process: TBP>>=
   generic :: get_nlo_type_component => get_nlo_type_component_single
   procedure :: get_nlo_type_component_single => process_get_nlo_type_component_single
 <<Process: procedures>>=
   elemental function process_get_nlo_type_component_single (process, i_component) result (val)
     integer :: val
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     val = process%component(i_component)%get_nlo_type ()
   end function process_get_nlo_type_component_single
 
 @ %def process_get_nlo_type_component_single
 @
 <<Process: process: TBP>>=
   generic :: get_nlo_type_component => get_nlo_type_component_all
   procedure :: get_nlo_type_component_all => process_get_nlo_type_component_all
 <<Process: procedures>>=
   pure function process_get_nlo_type_component_all (process) result (val)
     integer, dimension(:), allocatable :: val
     class(process_t), intent(in) :: process
     allocate (val (size (process%component)))
     val = process%component%get_nlo_type ()
   end function process_get_nlo_type_component_all
 
 @ %def process_get_nlo_type_component_all
 @
 <<Process: process: TBP>>=
   procedure :: is_nlo_calculation => process_is_nlo_calculation
 <<Process: procedures>>=
   function process_is_nlo_calculation (process) result (nlo)
     logical :: nlo
     class(process_t), intent(in) :: process
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        nlo = .true.
     class default
        nlo = .false.
     end select
   end function process_is_nlo_calculation
 
 @ %def process_is_nlo_calculation
 @
 <<Process: process: TBP>>=
   procedure :: get_negative_sf => process_get_negative_sf
 <<Process: procedures>>=
   function process_get_negative_sf (process) result (neg_sf)
     logical :: neg_sf
     class(process_t), intent(in) :: process
     neg_sf = process%config%process_def%get_negative_sf ()
   end function process_get_negative_sf
 
 @ %def process_get_negative_sf
 @
 <<Process: process: TBP>>=
   procedure :: is_combined_nlo_integration &
        => process_is_combined_nlo_integration
 <<Process: procedures>>=
   function process_is_combined_nlo_integration (process) result (combined)
     logical :: combined
     class(process_t), intent(in) :: process
     select type (pcm => process%pcm)
     type is (pcm_nlo_t)
        combined = pcm%settings%combined_integration
     class default
        combined = .false.
     end select
   end function process_is_combined_nlo_integration
 
 @ %def process_is_combined_nlo_integration
 @
 <<Process: process: TBP>>=
   procedure :: component_is_real_finite => process_component_is_real_finite
 <<Process: procedures>>=
   pure function process_component_is_real_finite (process, i_component) &
          result (val)
     logical :: val
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     val = process%component(i_component)%component_type == COMP_REAL_FIN
   end function process_component_is_real_finite
 
 @ %def process_component_is_real_finite
 @ Return nlo data of a process component
 <<Process: process: TBP>>=
   procedure :: get_component_nlo_type => process_get_component_nlo_type
 <<Process: procedures>>=
   elemental function process_get_component_nlo_type (process, i_component) &
            result (nlo_type)
     integer :: nlo_type
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     nlo_type = process%component(i_component)%config%get_nlo_type ()
   end function process_get_component_nlo_type
 
 @ %def process_get_component_nlo_type
 @ Return a pointer to the core that belongs to a component.
 <<Process: process: TBP>>=
   procedure :: get_component_core_ptr => process_get_component_core_ptr
 <<Process: procedures>>=
   function process_get_component_core_ptr (process, i_component) result (core)
     class(process_t), intent(in), target :: process
     integer, intent(in) :: i_component
     class(prc_core_t), pointer :: core
     integer :: i_core
     i_core = process%pcm%get_i_core(i_component)
     core => process%core_entry(i_core)%core
   end function process_get_component_core_ptr
 
 @ %def process_get_component_core_ptr
 @
 <<Process: process: TBP>>=
   procedure :: get_component_associated_born &
             => process_get_component_associated_born
 <<Process: procedures>>=
   function process_get_component_associated_born (process, i_component) &
            result (i_born)
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_component
     integer :: i_born
     i_born = process%component(i_component)%config%get_associated_born ()
   end function process_get_component_associated_born
 
 @ %def process_get_component_associated_born
 @
 <<Process: process: TBP>>=
   procedure :: get_first_real_component => process_get_first_real_component
 <<Process: procedures>>=
   function process_get_first_real_component (process) result (i_real)
      integer :: i_real
      class(process_t), intent(in) :: process
      i_real = process%component(1)%config%get_associated_real ()
   end function process_get_first_real_component
 
 @ %def process_get_first_real_component
 @
 <<Process: process: TBP>>=
   procedure :: get_first_real_term => process_get_first_real_term
 <<Process: procedures>>=
   function process_get_first_real_term (process) result (i_real)
      integer :: i_real
      class(process_t), intent(in) :: process
      integer :: i_component, i_term
      i_component = process%component(1)%config%get_associated_real ()
      i_real = 0
      do i_term = 1, size (process%term)
         if (process%term(i_term)%i_component == i_component) then
            i_real = i_term
            exit
         end if
      end do
      if (i_real == 0) call msg_fatal ("Did not find associated real term!")
   end function process_get_first_real_term
 
 @ %def process_get_first_real_term
 @
 <<Process: process: TBP>>=
   procedure :: get_associated_real_fin => process_get_associated_real_fin
 <<Process: procedures>>=
   elemental function process_get_associated_real_fin (process, i_component) result (i_real)
      integer :: i_real
      class(process_t), intent(in) :: process
      integer, intent(in) :: i_component
      i_real = process%component(i_component)%config%get_associated_real_fin ()
   end function process_get_associated_real_fin
 
 @ %def process_get_associated_real_fin
 @
 <<Process: process: TBP>>=
   procedure :: select_i_term => process_select_i_term
 <<Process: procedures>>=
   pure function process_select_i_term (process, i_mci) result (i_term)
     integer :: i_term
     class(process_t), intent(in) :: process
     integer, intent(in) :: i_mci
     integer :: i_component, i_sub
     i_component = process%mci_entry(i_mci)%i_component(1)
     i_term = process%component(i_component)%i_term(1)
     i_sub = process%term(i_term)%i_sub
     if (i_sub > 0) &
        i_term = process%term(i_sub)%i_term_global
   end function process_select_i_term
 
 @ %def process_select_i_term
 @ Would be better to do this at the level of the writer of the core but
 one has to bring NLO information there.
 <<Process: process: TBP>>=
   procedure :: prepare_any_external_code &
      => process_prepare_any_external_code
 <<Process: procedures>>=
   subroutine process_prepare_any_external_code (process)
     class(process_t), intent(inout), target :: process
     integer :: i
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "process_prepare_external_code")
     associate (pcm => process%pcm)
       do i = 1, pcm%n_cores
          call pcm%prepare_any_external_code ( &
               process%core_entry(i), i, &
               process%get_library_name (), &
               process%config%model, &
               process%env%get_var_list_ptr ())
       end do
     end associate
   end subroutine process_prepare_any_external_code
 
 @ %def process_prepare_any_external_code
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process config}
 <<[[process_config.f90]]>>=
 <<File header>>
 
 module process_config
 
 <<Use kinds>>
 <<Use strings>>
   use format_utils, only: write_separator
   use io_units
   use md5
   use os_interface
   use diagnostics
   use sf_base
   use sf_mappings
   use mappings, only: mapping_defaults_t
   use phs_forests, only: phs_parameters_t
   use sm_qcd
   use physics_defs
   use integration_results
   use model_data
   use models
   use interactions
   use quantum_numbers
   use flavors
   use helicities
   use colors
   use rng_base
   use state_matrices
   use process_libraries
   use process_constants
   use prc_core
   use prc_external
   use prc_openloops, only: prc_openloops_t
   use prc_threshold, only: prc_threshold_t
   use beams
   use dispatch_beams, only: dispatch_qcd
   use mci_base
   use beam_structures
   use phs_base
   use variables
   use expr_base
   use blha_olp_interfaces, only: prc_blha_t
 
 <<Standard module head>>
 
 <<Process config: public>>
 
 <<Process config: parameters>>
 
 <<Process config: types>>
 
 contains
 
 <<Process config: procedures>>
 
 end module process_config
 @ %def process_config
 @ Identifiers for the NLO setup.
 <<Process config: parameters>>=
   integer, parameter, public :: COMP_DEFAULT = 0
   integer, parameter, public :: COMP_REAL_FIN = 1
   integer, parameter, public :: COMP_MASTER = 2
   integer, parameter, public :: COMP_VIRT = 3
   integer, parameter, public :: COMP_REAL = 4
   integer, parameter, public :: COMP_REAL_SING = 5
   integer, parameter, public :: COMP_MISMATCH = 6
   integer, parameter, public :: COMP_PDF = 7
   integer, parameter, public :: COMP_SUB = 8
   integer, parameter, public :: COMP_RESUM = 9
 
 @
 \subsection{Output selection flags}
 We declare a number of identifiers for write methods, so they only
 displays selected parts.  The identifiers can be supplied to the [[vlist]]
 array argument of the standard F2008 derived-type writer call.
 <<Process config: parameters>>=
   integer, parameter, public :: F_PACIFY = 1
   integer, parameter, public :: F_SHOW_VAR_LIST = 11
   integer, parameter, public :: F_SHOW_EXPRESSIONS = 12
   integer, parameter, public :: F_SHOW_LIB = 13
   integer, parameter, public :: F_SHOW_MODEL = 14
   integer, parameter, public :: F_SHOW_QCD = 15
   integer, parameter, public :: F_SHOW_OS_DATA = 16
   integer, parameter, public :: F_SHOW_RNG = 17
   integer, parameter, public :: F_SHOW_BEAMS = 18
 @ %def SHOW_VAR_LIST
 @ %def SHOW_EXPRESSIONS
 @
 This is a simple function that returns true if a flag value is present in
 [[v_list]], but not its negative.  If neither is present, it returns
 [[default]].
 <<Process config: public>>=
   public :: flagged
 <<Process config: procedures>>=
   function flagged (v_list, id, def) result (flag)
     logical :: flag
     integer, dimension(:), intent(in) :: v_list
     integer, intent(in) :: id
     logical, intent(in), optional :: def
     logical :: default_result
     default_result = .false.;  if (present (def))  default_result = def
     if (default_result) then
        flag = all (v_list /= -id)
     else
        flag = all (v_list /= -id) .and. any (v_list == id)
     end if
   end function flagged
 
 @ %def flagged
 @
 Related: if flag is set (unset), append [[value]] (its negative) to the
 [[v_list]], respectively.  [[v_list]] must be allocated.
 <<Process config: public>>=
   public :: set_flag
 <<Process config: procedures>>=
   subroutine set_flag (v_list, value, flag)
     integer, dimension(:), intent(inout), allocatable :: v_list
     integer, intent(in) :: value
     logical, intent(in), optional :: flag
     if (present (flag)) then
        if (flag) then
           v_list = [v_list, value]
        else
           v_list = [v_list, -value]
        end if
     end if
   end subroutine set_flag
 
 @ %def set_flag
 @
 \subsection{Generic configuration data}
 This information concerns physical and technical properties of the
 process.  It is fixed upon initialization, using data from the
 process specification and the variable list.
 
 The number [[n_in]] is the number of incoming beam particles,
 simultaneously the number of incoming partons, 1 for a decay and 2 for
 a scattering process. (The number of outgoing partons may depend on
 the process component.)
 
 The number [[n_components]] is the number of components that constitute
 the current process.
 
 The number [[n_terms]] is the number of distinct contributions to the
 scattering matrix that constitute the current process.  Each component
 may generate several terms.
 
 The number [[n_mci]] is the number of independent MC
 integration configurations that this process uses.  Distinct process
 components that share a MCI configuration may be combined pointwise.
 (Nevertheless, a given MC variable set may correspond to several
 ``nearby'' kinematical configurations.)  This is also the number of
 distinct sampling-function results that this process can generate.
 Process components that use distinct variable sets are added only once
 after an integration pass has completed.
 
 The [[model]] pointer identifies the physics model and its
 parameters.  This is a pointer to an external object.
 
 Various [[parse_node_t]] objects are taken from the SINDARIN input.
 They encode expressions for evaluating cuts and scales.  The
 workspaces for evaluating those expressions are set up in the
 [[effective_state]] subobjects.  Note that these are really pointers,
 so the actual nodes are not stored inside the process object.
 
 The [[md5sum]] is taken and used to verify the process configuration
 when re-reading data from file.
 <<Process config: public>>=
   public :: process_config_data_t
 <<Process config: types>>=
   type :: process_config_data_t
      class(process_def_t), pointer :: process_def => null ()
      integer :: n_in = 0
      integer :: n_components = 0
      integer :: n_terms = 0
      integer :: n_mci = 0
      type(string_t) :: model_name
      class(model_data_t), pointer :: model => null ()
      type(qcd_t) :: qcd
      class(expr_factory_t), allocatable :: ef_cuts
      class(expr_factory_t), allocatable :: ef_scale
      class(expr_factory_t), allocatable :: ef_fac_scale
      class(expr_factory_t), allocatable :: ef_ren_scale
      class(expr_factory_t), allocatable :: ef_weight
      character(32) :: md5sum = ""
    contains
    <<Process config: process config data: TBP>>
   end type process_config_data_t
 
 @ %def process_config_data_t
 @ Here, we may compress the expressions for cuts etc.
 <<Process config: process config data: TBP>>=
   procedure :: write => process_config_data_write
 <<Process config: procedures>>=
   subroutine process_config_data_write (config, u, counters, model, expressions)
     class(process_config_data_t), intent(in) :: config
     integer, intent(in) :: u
     logical, intent(in) :: counters
     logical, intent(in) :: model
     logical, intent(in) :: expressions
     write (u, "(1x,A)") "Configuration data:"
     if (counters) then
        write (u, "(3x,A,I0)") "Number of incoming particles = ", &
             config%n_in
        write (u, "(3x,A,I0)") "Number of process components = ", &
             config%n_components
        write (u, "(3x,A,I0)") "Number of process terms      = ", &
             config%n_terms
        write (u, "(3x,A,I0)") "Number of MCI configurations = ", &
             config%n_mci
     end if
     if (associated (config%model)) then
        write (u, "(3x,A,A)")  "Model = ", char (config%model_name)
        if (model) then
           call write_separator (u)
           call config%model%write (u)
           call write_separator (u)
        end if
     else
        write (u, "(3x,A,A,A)")  "Model = ", char (config%model_name), &
             " [not associated]"
     end if
     call config%qcd%write (u, show_md5sum = .false.)
     call write_separator (u)
     if (expressions) then
        if (allocated (config%ef_cuts)) then
           call write_separator (u)
           write (u, "(3x,A)") "Cut expression:"
           call config%ef_cuts%write (u)
        end if
        if (allocated (config%ef_scale)) then
           call write_separator (u)
           write (u, "(3x,A)") "Scale expression:"
           call config%ef_scale%write (u)
        end if
        if (allocated (config%ef_fac_scale)) then
           call write_separator (u)
           write (u, "(3x,A)") "Factorization scale expression:"
           call config%ef_fac_scale%write (u)
        end if
        if (allocated (config%ef_ren_scale)) then
           call write_separator (u)
           write (u, "(3x,A)") "Renormalization scale expression:"
           call config%ef_ren_scale%write (u)
        end if
        if (allocated (config%ef_weight)) then
           call write_separator (u)
           write (u, "(3x,A)") "Weight expression:"
           call config%ef_weight%write (u)
        end if
     else
        call write_separator (u)
        write (u, "(3x,A)") "Expressions (cut, scales, weight): [not shown]"
     end if
     if (config%md5sum /= "") then
        call write_separator (u)
        write (u, "(3x,A,A,A)")  "MD5 sum (config)  = '", config%md5sum, "'"
     end if
   end subroutine process_config_data_write
 
 @ %def process_config_data_write
 @ Initialize.  We use information from the process metadata and from
 the process library, given the process ID.  We also store the
 currently active OS data set.
 
 The model pointer references the model data within the [[env]] record.  That
 should be an instance of the global model.
 
 We initialize the QCD object, unless the environment information is unavailable
 (unit tests).
 
 The RNG factory object is imported by moving the allocation.
 <<Process config: process config data: TBP>>=
   procedure :: init => process_config_data_init
 <<Process config: procedures>>=
   subroutine process_config_data_init (config, meta, env)
     class(process_config_data_t), intent(out) :: config
     type(process_metadata_t), intent(in) :: meta
     type(process_environment_t), intent(in) :: env
     config%process_def => env%lib%get_process_def_ptr (meta%id)
     config%n_in = config%process_def%get_n_in ()
     config%n_components = size (meta%component_id)
     config%model => env%get_model_ptr ()
     config%model_name = config%model%get_name ()
     if (env%got_var_list ()) then
        call dispatch_qcd &
             (config%qcd, env%get_var_list_ptr (), env%get_os_data ())
     end if
   end subroutine process_config_data_init
 
 @ %def process_config_data_init
 @ Current implementation: nothing to finalize.
 <<Process config: process config data: TBP>>=
   procedure :: final => process_config_data_final
 <<Process config: procedures>>=
   subroutine process_config_data_final (config)
     class(process_config_data_t), intent(inout) :: config
   end subroutine process_config_data_final
 
 @ %def process_config_data_final
 @ Return a copy of the QCD data block.
 <<Process config: process config data: TBP>>=
   procedure :: get_qcd => process_config_data_get_qcd
 <<Process config: procedures>>=
   function process_config_data_get_qcd (config) result (qcd)
     class(process_config_data_t), intent(in) :: config
     type(qcd_t) :: qcd
     qcd = config%qcd
   end function process_config_data_get_qcd
 
 @ %def process_config_data_get_qcd
 @ Compute the MD5 sum of the configuration data.  This encodes, in
 particular, the model and the expressions for cut, scales, weight,
 etc.  It should not contain the IDs and number of components, etc.,
 since the MD5 sum should be useful for integrating individual
 components.
 
 This is done only once.  If the MD5 sum is nonempty, the calculation
 is skipped.
 <<Process config: process config data: TBP>>=
   procedure :: compute_md5sum => process_config_data_compute_md5sum
 <<Process config: procedures>>=
   subroutine process_config_data_compute_md5sum (config)
     class(process_config_data_t), intent(inout) :: config
     integer :: u
     if (config%md5sum == "") then
        u = free_unit ()
        open (u, status = "scratch", action = "readwrite")
        call config%write (u, counters = .false., &
             model = .true., expressions = .true.)
        rewind (u)
        config%md5sum = md5sum (u)
        close (u)
     end if
   end subroutine process_config_data_compute_md5sum
 
 @ %def process_config_data_compute_md5sum
 @
 <<Process config: process config data: TBP>>=
   procedure :: get_md5sum => process_config_data_get_md5sum
 <<Process config: procedures>>=
   pure function process_config_data_get_md5sum (config) result (md5)
     character(32) :: md5
     class(process_config_data_t), intent(in) :: config
     md5 = config%md5sum
   end function process_config_data_get_md5sum
 
 @ %def process_config_data_get_md5sum
 @
 \subsection{Environment}
 This record stores a snapshot of the process environment at the point where
 the process object is created.
 
 Model and variable list are implemented as pointer, so they always have the
 [[target]] attribute.
 
 For unit-testing purposes, setting the var list is optional.  If not set, the
 pointer is null.
 <<Process config: public>>=
   public :: process_environment_t
 <<Process config: types>>=
   type :: process_environment_t
      private
      type(model_t), pointer :: model => null ()
      type(var_list_t), pointer :: var_list => null ()
      logical :: var_list_is_set = .false.
      type(process_library_t), pointer :: lib => null ()
      type(beam_structure_t) :: beam_structure
      type(os_data_t) :: os_data
    contains
    <<Process config: process environment: TBP>>
   end type process_environment_t
 
 @ %def process_environment_t
 @ Model and local var list are snapshots and need a finalizer.
 <<Process config: process environment: TBP>>=
   procedure :: final => process_environment_final
 <<Process config: procedures>>=
   subroutine process_environment_final (env)
     class(process_environment_t), intent(inout) :: env
     if (associated (env%model)) then
        call env%model%final ()
        deallocate (env%model)
     end if
     if (associated (env%var_list)) then
        call env%var_list%final (follow_link=.true.)
        deallocate (env%var_list)
     end if
   end subroutine process_environment_final
 
 @ %def process_environment_final
 @ Output, DTIO compatible.
 <<Process config: process environment: TBP>>=
   procedure :: write => process_environment_write
   procedure :: write_formatted => process_environment_write_formatted
   ! generic :: write (formatted) => write_formatted
 <<Process config: procedures>>=
   subroutine process_environment_write (env, unit, &
        show_var_list, show_model, show_lib, show_beams, show_os_data)
     class(process_environment_t), intent(in) :: env
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_var_list
     logical, intent(in), optional :: show_model
     logical, intent(in), optional :: show_lib
     logical, intent(in), optional :: show_beams
     logical, intent(in), optional :: show_os_data
     integer :: u, iostat
     integer, dimension(:), allocatable :: v_list
     character(0) :: iomsg
     u = given_output_unit (unit)
     allocate (v_list (0))
     call set_flag (v_list, F_SHOW_VAR_LIST, show_var_list)
     call set_flag (v_list, F_SHOW_MODEL, show_model)
     call set_flag (v_list, F_SHOW_LIB, show_lib)
     call set_flag (v_list, F_SHOW_BEAMS, show_beams)
     call set_flag (v_list, F_SHOW_OS_DATA, show_os_data)
     call env%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
   end subroutine process_environment_write
 
 @ %def process_environment_write
 @ DTIO standard write.
 <<Process config: procedures>>=
   subroutine process_environment_write_formatted &
        (dtv, unit, iotype, v_list, iostat, iomsg)
     class(process_environment_t), intent(in) :: dtv
     integer, intent(in) :: unit
     character(*), intent(in) :: iotype
     integer, dimension(:), intent(in) :: v_list
     integer, intent(out) :: iostat
     character(*), intent(inout) :: iomsg
     associate (env => dtv)
       if (flagged (v_list, F_SHOW_VAR_LIST, .true.)) then
          write (unit, "(1x,A)")  "Variable list:"
          if (associated (env%var_list)) then
             call write_separator (unit)
             call env%var_list%write (unit)
          else
             write (unit, "(3x,A)")  "[not allocated]"
          end if
          call write_separator (unit)
       end if
       if (flagged (v_list, F_SHOW_MODEL, .true.)) then
          write (unit, "(1x,A)")  "Model:"
          if (associated (env%model)) then
             call write_separator (unit)
             call env%model%write (unit)
          else
             write (unit, "(3x,A)")  "[not allocated]"
          end if
          call write_separator (unit)
       end if
       if (flagged (v_list, F_SHOW_LIB, .true.)) then
          write (unit, "(1x,A)")  "Process library:"
          if (associated (env%lib)) then
             call write_separator (unit)
             call env%lib%write (unit)
          else
             write (unit, "(3x,A)")  "[not allocated]"
          end if
       end if
       if (flagged (v_list, F_SHOW_BEAMS, .true.)) then
          call write_separator (unit)
          call env%beam_structure%write (unit)
       end if
       if (flagged (v_list, F_SHOW_OS_DATA, .true.)) then
          write (unit, "(1x,A)")  "Operating-system data:"
          call write_separator (unit)
          call env%os_data%write (unit)
       end if
     end associate
     iostat = 0
   end subroutine process_environment_write_formatted
 
 @ %def process_environment_write_formatted
 @ Initialize: Make a snapshot of the provided model.  Make a link to the
 current process library.
 
 Also make a snapshot of the variable list, if provided.  If none is
 provided, there is an empty variable list nevertheless, so a pointer
 lookup does not return null.
 
 If no beam structure is provided, the beam-structure member is empty and will
 yield a number of zero beams when queried.
 <<Process config: process environment: TBP>>=
   procedure :: init => process_environment_init
 <<Process config: procedures>>=
   subroutine process_environment_init &
        (env, model, lib, os_data, var_list, beam_structure)
     class(process_environment_t), intent(out) :: env
     type(model_t), intent(in), target :: model
     type(process_library_t), intent(in), target :: lib
     type(os_data_t), intent(in) :: os_data
     type(var_list_t), intent(in), target, optional :: var_list
     type(beam_structure_t), intent(in), optional :: beam_structure
     allocate (env%model)
     call env%model%init_instance (model)
     env%lib => lib
     env%os_data = os_data
     allocate (env%var_list)
     if (present (var_list)) then
        call env%var_list%init_snapshot (var_list, follow_link=.true.)
        env%var_list_is_set = .true.
     end if
     if (present (beam_structure)) then
        env%beam_structure = beam_structure
     end if
   end subroutine process_environment_init
 
 @ %def process_environment_init
 @ Indicate whether a variable list has been provided upon initialization.
 <<Process config: process environment: TBP>>=
   procedure :: got_var_list => process_environment_got_var_list
 <<Process config: procedures>>=
   function process_environment_got_var_list (env) result (flag)
     class(process_environment_t), intent(in) :: env
     logical :: flag
     flag = env%var_list_is_set
   end function process_environment_got_var_list
 
 @ %def process_environment_got_var_list
 @ Return a pointer to the variable list.
 <<Process config: process environment: TBP>>=
   procedure :: get_var_list_ptr => process_environment_get_var_list_ptr
 <<Process config: procedures>>=
   function process_environment_get_var_list_ptr (env) result (var_list)
     class(process_environment_t), intent(in) :: env
     type(var_list_t), pointer :: var_list
     var_list => env%var_list
   end function process_environment_get_var_list_ptr
 
 @ %def process_environment_get_var_list_ptr
 @ Return a pointer to the model, if it exists.
 <<Process config: process environment: TBP>>=
   procedure :: get_model_ptr => process_environment_get_model_ptr
 <<Process config: procedures>>=
   function process_environment_get_model_ptr (env) result (model)
     class(process_environment_t), intent(in) :: env
     type(model_t), pointer :: model
     model => env%model
   end function process_environment_get_model_ptr
 
 @ %def process_environment_get_model_ptr
 @ Return the process library pointer.
 <<Process config: process environment: TBP>>=
   procedure :: get_lib_ptr => process_environment_get_lib_ptr
 <<Process config: procedures>>=
   function process_environment_get_lib_ptr (env) result (lib)
     class(process_environment_t), intent(inout) :: env
     type(process_library_t), pointer :: lib
     lib => env%lib
   end function process_environment_get_lib_ptr
 
 @ %def process_environment_get_lib_ptr
 @ Clear the process library pointer, in case the library is deleted.
 <<Process config: process environment: TBP>>=
   procedure :: reset_lib_ptr => process_environment_reset_lib_ptr
 <<Process config: procedures>>=
   subroutine process_environment_reset_lib_ptr (env)
     class(process_environment_t), intent(inout) :: env
     env%lib => null ()
   end subroutine process_environment_reset_lib_ptr
 
 @ %def process_environment_reset_lib_ptr
 @ Check whether the process library has changed, in case the library is
 recompiled, etc.
 <<Process config: process environment: TBP>>=
   procedure :: check_lib_sanity => process_environment_check_lib_sanity
 <<Process config: procedures>>=
   subroutine process_environment_check_lib_sanity (env, meta)
     class(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     if (associated (env%lib)) then
        if (env%lib%get_update_counter () /= meta%lib_update_counter) then
           call msg_fatal ("Process '" // char (meta%id) &
                // "': library has been recompiled after integration")
        end if
     end if
   end subroutine process_environment_check_lib_sanity
 
 @ %def process_environment_check_lib_sanity
 @ Fill the [[data]] block using the appropriate process-library access entry.
 <<Process config: process environment: TBP>>=
   procedure :: fill_process_constants => &
        process_environment_fill_process_constants
 <<Process config: procedures>>=
   subroutine process_environment_fill_process_constants &
        (env, id, i_component, data)
     class(process_environment_t), intent(in) :: env
     type(string_t), intent(in) :: id
     integer, intent(in) :: i_component
     type(process_constants_t), intent(out) :: data
     call env%lib%fill_constants (id, i_component, data)
   end subroutine process_environment_fill_process_constants
 
 @ %def process_environment_fill_process_constants
 @ Return the entire beam structure.
 <<Process config: process environment: TBP>>=
   procedure :: get_beam_structure => process_environment_get_beam_structure
 <<Process config: procedures>>=
   function process_environment_get_beam_structure (env) result (beam_structure)
     class(process_environment_t), intent(in) :: env
     type(beam_structure_t) :: beam_structure
     beam_structure = env%beam_structure
   end function process_environment_get_beam_structure
 
 @ %def process_environment_get_beam_structure
 @ Check the beam structure for PDFs.
 <<Process config: process environment: TBP>>=
   procedure :: has_pdfs => process_environment_has_pdfs
 <<Process config: procedures>>=
   function process_environment_has_pdfs (env) result (flag)
     class(process_environment_t), intent(in) :: env
     logical :: flag
     flag = env%beam_structure%has_pdf ()
   end function process_environment_has_pdfs
 
 @ %def process_environment_has_pdfs
 @ Check the beam structure for polarized beams.
 <<Process config: process environment: TBP>>=
   procedure :: has_polarized_beams => process_environment_has_polarized_beams
 <<Process config: procedures>>=
   function process_environment_has_polarized_beams (env) result (flag)
     class(process_environment_t), intent(in) :: env
     logical :: flag
     flag = env%beam_structure%has_polarized_beams ()
   end function process_environment_has_polarized_beams
 
 @ %def process_environment_has_polarized_beams
 @ Return a copy of the OS data block.
 <<Process config: process environment: TBP>>=
   procedure :: get_os_data => process_environment_get_os_data
 <<Process config: procedures>>=
   function process_environment_get_os_data (env) result (os_data)
     class(process_environment_t), intent(in) :: env
     type(os_data_t) :: os_data
     os_data = env%os_data
   end function process_environment_get_os_data
 
 @ %def process_environment_get_os_data
 @
 \subsection{Metadata}
 This information describes the process.  It is fixed upon initialization.
 
 The [[id]] string is the name of the process object, as given by the
 user.  The matrix element generator will use this string for naming
 Fortran procedures and types, so it should qualify as a Fortran name.
 
 The [[num_id]] is meaningful if nonzero.  It is used for communication
 with external programs or file standards which do not support string IDs.
 
 The [[run_id]] string distinguishes among several runs for the same
 process.  It identifies process instances with respect to adapted
 integration grids and similar run-specific data.  The run ID is kept
 when copying processes for creating instances, however, so it does not
 distinguish event samples.
 
 The [[lib_name]] identifies the process library where the process
 definition and the process driver are located.
 
 The [[lib_index]] is the index of entry in the process library that
 corresponds to the current process.
 
 The [[component_id]] array identifies the individual process components.
 
 The [[component_description]] is an array of human-readable strings
 that characterize the process components, for instance [[a, b => c, d]].
 
 The [[active]] mask array marks those components which are active.  The others
 are skipped.
 <<Process config: public>>=
   public :: process_metadata_t
 <<Process config: types>>=
   type :: process_metadata_t
      integer :: type = PRC_UNKNOWN
      type(string_t) :: id
      integer :: num_id = 0
      type(string_t) :: run_id
      type(string_t), allocatable :: lib_name
      integer :: lib_update_counter = 0
      integer :: lib_index = 0
      integer :: n_components = 0
      type(string_t), dimension(:), allocatable :: component_id
      type(string_t), dimension(:), allocatable :: component_description
      logical, dimension(:), allocatable :: active
    contains
    <<Process config: process metadata: TBP>>
   end type process_metadata_t
 
 @ %def process_metadata_t
 @ Output: ID and run ID.
 We write the variable list only upon request.
 <<Process config: process metadata: TBP>>=
   procedure :: write => process_metadata_write
 <<Process config: procedures>>=
   subroutine process_metadata_write (meta, u, screen)
     class(process_metadata_t), intent(in) :: meta
     integer, intent(in) :: u
     logical, intent(in) :: screen
     integer :: i
     select case (meta%type)
     case (PRC_UNKNOWN)
        if (screen) then
           write (msg_buffer, "(A)") "Process [undefined]"
        else
           write (u, "(1x,A)") "Process [undefined]"
        end if
        return
     case (PRC_DECAY)
        if (screen) then
           write (msg_buffer, "(A,1x,A,A,A)") "Process [decay]:", &
                "'", char (meta%id), "'"
        else
           write (u, "(1x,A)", advance="no") "Process [decay]:"
        end if
     case (PRC_SCATTERING)
        if (screen) then
           write (msg_buffer, "(A,1x,A,A,A)") "Process [scattering]:", &
                "'", char (meta%id), "'"
        else
           write (u, "(1x,A)", advance="no") "Process [scattering]:"
        end if
     case default
        call msg_bug ("process_write: undefined process type")
     end select
     if (screen)  then
        call msg_message ()
     else
        write (u, "(1x,A,A,A)") "'", char (meta%id), "'"
     end if
     if (meta%num_id /= 0) then
        if (screen) then
           write (msg_buffer, "(2x,A,I0)") "ID (num)      = ", meta%num_id
           call msg_message ()
        else
           write (u, "(3x,A,I0)") "ID (num)      = ", meta%num_id
        end if
     end if
     if (screen) then
        if (meta%run_id /= "") then
           write (msg_buffer, "(2x,A,A,A)") "Run ID        = '", &
                char (meta%run_id), "'"
           call msg_message ()
        end if
     else
        write (u, "(3x,A,A,A)") "Run ID        = '", char (meta%run_id), "'"
     end if
     if (allocated (meta%lib_name)) then
        if (screen) then
           write (msg_buffer, "(2x,A,A,A)")  "Library name  = '", &
                char (meta%lib_name), "'"
           call msg_message ()
        else
           write (u, "(3x,A,A,A)")  "Library name  = '", &
                char (meta%lib_name), "'"
        end if
     else
        if (screen) then
           write (msg_buffer, "(2x,A)")  "Library name  = [not associated]"
           call msg_message ()
        else
           write (u, "(3x,A)")  "Library name  = [not associated]"
        end if
     end if
     if (screen) then
        write (msg_buffer, "(2x,A,I0)")  "Process index = ", meta%lib_index
        call msg_message ()
     else
        write (u, "(3x,A,I0)")  "Process index = ", meta%lib_index
     end if
     if (allocated (meta%component_id)) then
        if (screen) then
           if (any (meta%active)) then
              write (msg_buffer, "(2x,A)")  "Process components:"
           else
              write (msg_buffer, "(2x,A)")  "Process components: [none]"
           end if
           call msg_message ()
        else
           write (u, "(3x,A)")  "Process components:"
        end if
        do i = 1, size (meta%component_id)
           if (.not. meta%active(i))  cycle
           if (screen) then
              write (msg_buffer, "(4x,I0,9A)")  i, ": '", &
                   char (meta%component_id (i)), "':   ", &
                   char (meta%component_description (i))
              call msg_message ()
           else
              write (u, "(5x,I0,9A)")  i, ": '", &
                   char (meta%component_id (i)), "':   ", &
                   char (meta%component_description (i))
           end if
        end do
     end if
     if (screen) then
        write (msg_buffer, "(A)")  repeat ("-", 72)
        call msg_message ()
     else
        call write_separator (u)
     end if
   end subroutine process_metadata_write
 
 @ %def process_metadata_write
 @ Short output: list components.
 <<Process config: process metadata: TBP>>=
   procedure :: show => process_metadata_show
 <<Process config: procedures>>=
   subroutine process_metadata_show (meta, u, model_name)
     class(process_metadata_t), intent(in) :: meta
     integer, intent(in) :: u
     type(string_t), intent(in) :: model_name
     integer :: i
     select case (meta%type)
     case (PRC_UNKNOWN)
        write (u, "(A)") "Process: [undefined]"
        return
     case default
        write (u, "(A)", advance="no") "Process:"
     end select
     write (u, "(1x,A)", advance="no") char (meta%id)
     select case (meta%num_id)
     case (0)
     case default
        write (u, "(1x,'(',I0,')')", advance="no") meta%num_id
     end select
     select case (char (model_name))
     case ("")
     case default
        write (u, "(1x,'[',A,']')", advance="no")  char (model_name)
     end select
     write (u, *)
     if (allocated (meta%component_id)) then
        do i = 1, size (meta%component_id)
           if (meta%active(i)) then
              write (u, "(2x,I0,':',1x,A)")  i, &
                   char (meta%component_description (i))
           end if
        end do
     end if
   end subroutine process_metadata_show
 
 @ %def process_metadata_show
 @ Initialize.  Find process ID and run ID.
 
 Also find the process ID in the process library and retrieve some metadata from
 there.
 <<Process config: process metadata: TBP>>=
   procedure :: init => process_metadata_init
 <<Process config: procedures>>=
   subroutine process_metadata_init (meta, id, lib, var_list)
     class(process_metadata_t), intent(out) :: meta
     type(string_t), intent(in) :: id
     type(process_library_t), intent(in), target :: lib
     type(var_list_t), intent(in) :: var_list
     select case (lib%get_n_in (id))
     case (1);  meta%type = PRC_DECAY
     case (2);  meta%type = PRC_SCATTERING
     case default
        call msg_bug ("Process '" // char (id) // "': impossible n_in")
     end select
     meta%id = id
     meta%run_id = var_list%get_sval (var_str ("$run_id"))
     allocate (meta%lib_name)
     meta%lib_name = lib%get_name ()
     meta%lib_update_counter = lib%get_update_counter ()
     if (lib%contains (id)) then
        meta%lib_index = lib%get_entry_index (id)
        meta%num_id = lib%get_num_id (id)
        call lib%get_component_list (id, meta%component_id)
        meta%n_components = size (meta%component_id)
        call lib%get_component_description_list &
             (id, meta%component_description)
        allocate (meta%active (meta%n_components), source = .true.)
     else
        call msg_fatal ("Process library does not contain process '" &
             // char (id) // "'")
     end if
     if (.not. lib%is_active ()) then
        call msg_bug ("Process init: inactive library not handled yet")
     end if
   end subroutine process_metadata_init
 
 @ %def process_metadata_init
 @ Mark a component as inactive.
 <<Process config: process metadata: TBP>>=
   procedure :: deactivate_component => process_metadata_deactivate_component
 <<Process config: procedures>>=
   subroutine process_metadata_deactivate_component (meta, i)
     class(process_metadata_t), intent(inout) :: meta
     integer, intent(in) :: i
     call msg_message ("Process component '" &
          // char (meta%component_id(i)) // "': matrix element vanishes")
     meta%active(i) = .false.
   end subroutine process_metadata_deactivate_component
 
 @ %def process_metadata_deactivate_component
 @
 \subsection{Phase-space configuration}
 A process can have a number of independent phase-space configuration entries,
 depending on the process definition and evaluation algorithm.  Each entry
 holds various configuration-parameter data and the actual [[phs_config_t]]
 record, which can vary in concrete type.
 <<Process config: public>>=
   public :: process_phs_config_t
 <<Process config: types>>=
   type :: process_phs_config_t
      type(phs_parameters_t) :: phs_par
      type(mapping_defaults_t) :: mapping_defs
      class(phs_config_t), allocatable :: phs_config
    contains
    <<Process config: process phs config: TBP>>
   end type process_phs_config_t
 
 @ %def process_phs_config_t
 @ Output, DTIO compatible.
 <<Process config: process phs config: TBP>>=
   procedure :: write => process_phs_config_write
   procedure :: write_formatted => process_phs_config_write_formatted
   ! generic :: write (formatted) => write_formatted
 <<Process config: procedures>>=
   subroutine process_phs_config_write (phs_config, unit)
     class(process_phs_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     integer :: u, iostat
     integer, dimension(:), allocatable :: v_list
     character(0) :: iomsg
     u = given_output_unit (unit)
     allocate (v_list (0))
     call phs_config%write_formatted (u, "LISTDIRECTED", v_list, iostat, iomsg)
   end subroutine process_phs_config_write
 
 @ %def process_phs_config_write
 @ DTIO standard write.
 <<Process config: procedures>>=
   subroutine process_phs_config_write_formatted &
        (dtv, unit, iotype, v_list, iostat, iomsg)
     class(process_phs_config_t), intent(in) :: dtv
     integer, intent(in) :: unit
     character(*), intent(in) :: iotype
     integer, dimension(:), intent(in) :: v_list
     integer, intent(out) :: iostat
     character(*), intent(inout) :: iomsg
     associate (phs_config => dtv)
       write (unit, "(1x, A)")  "Phase-space configuration entry:"
       call phs_config%phs_par%write (unit)
       call phs_config%mapping_defs%write (unit)
     end associate
     iostat = 0
   end subroutine process_phs_config_write_formatted
 
 @ %def process_phs_config_write_formatted
 @
 \subsection{Beam configuration}
 The object [[data]] holds all details about the initial beam
 configuration.  The allocatable array [[sf]] holds the structure-function
 configuration blocks.  There are [[n_strfun]] entries in the
 structure-function chain (not counting the initial beam object).  We
 maintain [[n_channel]] independent parameterizations of this chain.
 If this is greater than zero, we need a multi-channel sampling
 algorithm, where for each point one channel is selected to generate
 kinematics.
 
 The number of parameters that are required for generating a
 structure-function chain is [[n_sfpar]].
 
 The flag [[azimuthal_dependence]] tells whether the process setup is
 symmetric about the beam axis in the c.m.\ system.  This implies that
 there is no transversal beam polarization.  The flag [[lab_is_cm]] is
 obvious.
 <<Process config: public>>=
   public :: process_beam_config_t
 <<Process config: types>>=
   type :: process_beam_config_t
      type(beam_data_t) :: data
      integer :: n_strfun = 0
      integer :: n_channel = 1
      integer :: n_sfpar = 0
      type(sf_config_t), dimension(:), allocatable :: sf
      type(sf_channel_t), dimension(:), allocatable :: sf_channel
      logical :: azimuthal_dependence = .false.
      logical :: lab_is_cm = .true.
      character(32) :: md5sum = ""
      logical :: sf_trace = .false.
      type(string_t) :: sf_trace_file
    contains
    <<Process config: process beam config: TBP>>
   end type process_beam_config_t
 
 @ %def process_beam_config_t
 @ Here we write beam data only if they are actually used.
 
 The [[verbose]] flag is passed to the beam-data writer.
 <<Process config: process beam config: TBP>>=
   procedure :: write => process_beam_config_write
 <<Process config: procedures>>=
   subroutine process_beam_config_write (object, unit, verbose)
     class(process_beam_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i, c
     u = given_output_unit (unit)
     call object%data%write (u, verbose = verbose)
     if (object%data%initialized) then
        write (u, "(3x,A,L1)")  "Azimuthal dependence    = ", &
             object%azimuthal_dependence
        write (u, "(3x,A,L1)")  "Lab frame is c.m. frame = ", &
             object%lab_is_cm
        if (object%md5sum /= "") then
           write (u, "(3x,A,A,A)")  "MD5 sum (beams/strf) = '", &
                object%md5sum, "'"
        end if
        if (allocated (object%sf)) then
           do i = 1, size (object%sf)
              call object%sf(i)%write (u)
           end do
           if (any_sf_channel_has_mapping (object%sf_channel)) then
              write (u, "(1x,A,L1)")  "Structure-function mappings per channel:"
              do c = 1, object%n_channel
                 write (u, "(3x,I0,':')", advance="no")  c
                 call object%sf_channel(c)%write (u)
              end do
           end if
        end if
     end if
   end subroutine process_beam_config_write
 
 @ %def process_beam_config_write
 @ The beam data have a finalizer.  We assume that there is none for the
 structure-function data.
 <<Process config: process beam config: TBP>>=
   procedure :: final => process_beam_config_final
 <<Process config: procedures>>=
   subroutine process_beam_config_final (object)
     class(process_beam_config_t), intent(inout) :: object
     call object%data%final ()
   end subroutine process_beam_config_final
 
 @ %def process_beam_config_final
 @ Initialize the beam setup with a given beam structure object.
 <<Process config: process beam config: TBP>>=
   procedure :: init_beam_structure => process_beam_config_init_beam_structure
 <<Process config: procedures>>=
   subroutine process_beam_config_init_beam_structure &
        (beam_config, beam_structure, sqrts, model, decay_rest_frame)
     class(process_beam_config_t), intent(out) :: beam_config
     type(beam_structure_t), intent(in) :: beam_structure
     logical, intent(in), optional :: decay_rest_frame
     real(default), intent(in) :: sqrts
     class(model_data_t), intent(in), target :: model
     call beam_config%data%init_structure (beam_structure, &
          sqrts, model, decay_rest_frame)
     beam_config%lab_is_cm = beam_config%data%lab_is_cm
   end subroutine process_beam_config_init_beam_structure
 
 @ %def process_beam_config_init_beam_structure
 @ Initialize the beam setup for a scattering process with specified
 flavor combination, other properties taken from the beam structure
 object (if any).
 <<Process config: process beam config: TBP>>=
   procedure :: init_scattering => process_beam_config_init_scattering
 <<Process config: procedures>>=
   subroutine process_beam_config_init_scattering &
        (beam_config, flv_in, sqrts, beam_structure)
     class(process_beam_config_t), intent(out) :: beam_config
     type(flavor_t), dimension(2), intent(in) :: flv_in
     real(default), intent(in) :: sqrts
     type(beam_structure_t), intent(in), optional :: beam_structure
     if (present (beam_structure)) then
        if (beam_structure%polarized ()) then
           call beam_config%data%init_sqrts (sqrts, flv_in, &
                beam_structure%get_smatrix (), beam_structure%get_pol_f ())
        else
           call beam_config%data%init_sqrts (sqrts, flv_in)
        end if
     else
        call beam_config%data%init_sqrts (sqrts, flv_in)
     end if
   end subroutine process_beam_config_init_scattering
 
 @ %def process_beam_config_init_scattering
 @ Initialize the beam setup for a decay process with specified flavor,
 other properties taken from the beam structure object (if present).
 
 For a cascade decay, we set
 [[rest_frame]] to false, indicating a event-wise varying momentum.
 The beam data itself are initialized for the particle at rest.
 <<Process config: process beam config: TBP>>=
   procedure :: init_decay => process_beam_config_init_decay
 <<Process config: procedures>>=
   subroutine process_beam_config_init_decay &
        (beam_config, flv_in, rest_frame, beam_structure)
     class(process_beam_config_t), intent(out) :: beam_config
     type(flavor_t), dimension(1), intent(in) :: flv_in
     logical, intent(in), optional :: rest_frame
     type(beam_structure_t), intent(in), optional :: beam_structure
     if (present (beam_structure)) then
        if (beam_structure%polarized ()) then
           call beam_config%data%init_decay (flv_in, &
                beam_structure%get_smatrix (), beam_structure%get_pol_f (), &
                rest_frame = rest_frame)
        else
           call beam_config%data%init_decay (flv_in, rest_frame = rest_frame)
        end if
     else
        call beam_config%data%init_decay (flv_in, &
             rest_frame = rest_frame)
     end if
     beam_config%lab_is_cm = beam_config%data%lab_is_cm
   end subroutine process_beam_config_init_decay
 
 @ %def process_beam_config_init_decay
 @ Print an informative message.
 <<Process config: process beam config: TBP>>=
   procedure :: startup_message => process_beam_config_startup_message
 <<Process config: procedures>>=
   subroutine process_beam_config_startup_message &
        (beam_config, unit, beam_structure)
     class(process_beam_config_t), intent(in) :: beam_config
     integer, intent(in), optional :: unit
     type(beam_structure_t), intent(in), optional :: beam_structure
     integer :: u
     u = free_unit ()
     open (u, status="scratch", action="readwrite")
     if (present (beam_structure)) then
        call beam_structure%write (u)
     end if
     call beam_config%data%write (u)
     rewind (u)
     do
        read (u, "(1x,A)", end=1)  msg_buffer
        call msg_message ()
     end do
 1   continue
     close (u)
   end subroutine process_beam_config_startup_message
 
 @ %def process_beam_config_startup_message
 @ Allocate the structure-function array.
 <<Process config: process beam config: TBP>>=
   procedure :: init_sf_chain => process_beam_config_init_sf_chain
 <<Process config: procedures>>=
   subroutine process_beam_config_init_sf_chain &
        (beam_config, sf_config, sf_trace_file)
     class(process_beam_config_t), intent(inout) :: beam_config
     type(sf_config_t), dimension(:), intent(in) :: sf_config
     type(string_t), intent(in), optional :: sf_trace_file
     integer :: i
     beam_config%n_strfun = size (sf_config)
     allocate (beam_config%sf (beam_config%n_strfun))
     do i = 1, beam_config%n_strfun
        associate (sf => sf_config(i))
          call beam_config%sf(i)%init (sf%i, sf%data)
          if (.not. sf%data%is_generator ()) then
             beam_config%n_sfpar = beam_config%n_sfpar + sf%data%get_n_par ()
          end if
        end associate
     end do
     if (present (sf_trace_file)) then
        beam_config%sf_trace = .true.
        beam_config%sf_trace_file = sf_trace_file
     end if
   end subroutine process_beam_config_init_sf_chain
 
 @ %def process_beam_config_init_sf_chain
 @ Allocate the structure-function mapping channel array, given the
 requested number of channels.
 <<Process config: process beam config: TBP>>=
   procedure :: allocate_sf_channels => process_beam_config_allocate_sf_channels
 <<Process config: procedures>>=
   subroutine process_beam_config_allocate_sf_channels (beam_config, n_channel)
     class(process_beam_config_t), intent(inout) :: beam_config
     integer, intent(in) :: n_channel
     beam_config%n_channel = n_channel
     call allocate_sf_channels (beam_config%sf_channel, &
          n_channel = n_channel, &
          n_strfun = beam_config%n_strfun)
   end subroutine process_beam_config_allocate_sf_channels
 
 @ %def process_beam_config_allocate_sf_channels
 @ Set a structure-function mapping channel for an array of
 structure-function entries, for a single channel.  (The default is no mapping.)
 <<Process config: process beam config: TBP>>=
   procedure :: set_sf_channel => process_beam_config_set_sf_channel
 <<Process config: procedures>>=
   subroutine process_beam_config_set_sf_channel (beam_config, c, sf_channel)
     class(process_beam_config_t), intent(inout) :: beam_config
     integer, intent(in) :: c
     type(sf_channel_t), intent(in) :: sf_channel
     beam_config%sf_channel(c) = sf_channel
   end subroutine process_beam_config_set_sf_channel
 
 @ %def process_beam_config_set_sf_channel
 @ Print an informative startup message.
 <<Process config: process beam config: TBP>>=
   procedure :: sf_startup_message => process_beam_config_sf_startup_message
 <<Process config: procedures>>=
   subroutine process_beam_config_sf_startup_message &
        (beam_config, sf_string, unit)
     class(process_beam_config_t), intent(in) :: beam_config
     type(string_t), intent(in) :: sf_string
     integer, intent(in), optional :: unit
     if (beam_config%n_strfun > 0) then
        call msg_message ("Beam structure: " // char (sf_string), unit = unit)
        write (msg_buffer, "(A,3(1x,I0,1x,A))") &
             "Beam structure:", &
             beam_config%n_channel, "channels,", &
             beam_config%n_sfpar, "dimensions"
        call msg_message (unit = unit)
        if (beam_config%sf_trace) then
           call msg_message ("Beam structure: tracing &
                &values in '" // char (beam_config%sf_trace_file) // "'")
        end if
     end if
   end subroutine process_beam_config_sf_startup_message
 
 @ %def process_beam_config_startup_message
 @ Return the PDF set currently in use, if any.  This should be unique,
 so we scan the structure functions until we get a nonzero number.
 
 (This implies that if the PDF set is not unique (e.g., proton and
 photon structure used together), this does not work correctly.)
 <<Process config: process beam config: TBP>>=
   procedure :: get_pdf_set => process_beam_config_get_pdf_set
 <<Process config: procedures>>=
   function process_beam_config_get_pdf_set (beam_config) result (pdf_set)
     class(process_beam_config_t), intent(in) :: beam_config
     integer :: pdf_set
     integer :: i
     pdf_set = 0
     if (allocated (beam_config%sf)) then
        do i = 1, size (beam_config%sf)
           pdf_set = beam_config%sf(i)%get_pdf_set ()
           if (pdf_set /= 0)  return
        end do
     end if
   end function process_beam_config_get_pdf_set
 
 @ %def process_beam_config_get_pdf_set
 @ Return the beam file.
 <<Process config: process beam config: TBP>>=
   procedure :: get_beam_file => process_beam_config_get_beam_file
 <<Process config: procedures>>=
   function process_beam_config_get_beam_file (beam_config) result (file)
     class(process_beam_config_t), intent(in) :: beam_config
     type(string_t) :: file
     integer :: i
     file = ""
     if (allocated (beam_config%sf)) then
        do i = 1, size (beam_config%sf)
           file = beam_config%sf(i)%get_beam_file ()
           if (file /= "")  return
        end do
     end if
   end function process_beam_config_get_beam_file
 
 @ %def process_beam_config_get_beam_file
 @ Compute the MD5 sum for the complete beam setup.  We rely on the
 default output of [[write]] to contain all relevant data.
 
 This is done only once, when the MD5 sum is still empty.
 <<Process config: process beam config: TBP>>=
   procedure :: compute_md5sum => process_beam_config_compute_md5sum
 <<Process config: procedures>>=
   subroutine process_beam_config_compute_md5sum (beam_config)
     class(process_beam_config_t), intent(inout) :: beam_config
     integer :: u
     if (beam_config%md5sum == "") then
        u = free_unit ()
        open (u, status = "scratch", action = "readwrite")
        call beam_config%write (u, verbose=.true.)
        rewind (u)
        beam_config%md5sum = md5sum (u)
        close (u)
     end if
   end subroutine process_beam_config_compute_md5sum
 
 @ %def process_beam_config_compute_md5sum
 @
 <<Process config: process beam config: TBP>>=
   procedure :: get_md5sum => process_beam_config_get_md5sum
 <<Process config: procedures>>=
   pure function process_beam_config_get_md5sum (beam_config) result (md5)
     character(32) :: md5
     class(process_beam_config_t), intent(in) :: beam_config
     md5 = beam_config%md5sum
   end function process_beam_config_get_md5sum
 
 @ %def process_beam_config_get_md5sum
 @
 <<Process config: process beam config: TBP>>=
   procedure :: has_structure_function => process_beam_config_has_structure_function
 <<Process config: procedures>>=
   pure function process_beam_config_has_structure_function (beam_config) result (has_sf)
     logical :: has_sf
     class(process_beam_config_t), intent(in) :: beam_config
     has_sf = beam_config%n_strfun > 0
   end function process_beam_config_has_structure_function
 
 @ %def process_beam_config_has_structure_function
 @
 \subsection{Process components}
 A process component is an individual contribution to a process
 (scattering or decay) which needs not be physical.  The sum over all
 components should be physical.
 
 The [[index]] indentifies this component within its parent process.
 
 The actual process component is stored in the [[core]] subobject.  We
 use a polymorphic subobject instead of an extension of
 [[process_component_t]], because the individual entries in the array
 of process components can have different types.  In short,
 [[process_component_t]] is a wrapper for the actual process variants.
 
 If the [[active]] flag is false, we should skip this component.  This happens
 if the associated process has vanishing matrix element.
 
 The index array [[i_term]] points to the individual terms generated by
 this component.  The indices refer to the parent process.
 
 The index [[i_mci]] is the index of the MC integrator and parameter set which
 are associated to this process component.
 <<Process config: public>>=
   public :: process_component_t
 <<Process config: types>>=
   type :: process_component_t
      type(process_component_def_t), pointer :: config => null ()
      integer :: index = 0
      logical :: active = .false.
      integer, dimension(:), allocatable :: i_term
      integer :: i_mci = 0
      class(phs_config_t), allocatable :: phs_config
      character(32) :: md5sum_phs = ""
      integer :: component_type = COMP_DEFAULT
    contains
    <<Process config: process component: TBP>>
   end type process_component_t
 
 @ %def process_component_t
 @ Finalizer.  The MCI template may (potentially) need a finalizer.  The process
 configuration finalizer may include closing an open scratch file.
 <<Process config: process component: TBP>>=
   procedure :: final => process_component_final
 <<Process config: procedures>>=
   subroutine process_component_final (object)
     class(process_component_t), intent(inout) :: object
     if (allocated (object%phs_config)) then
        call object%phs_config%final ()
     end if
   end subroutine process_component_final
 
 @ %def process_component_final
 @ The meaning of [[verbose]] depends on the process variant.
 <<Process config: process component: TBP>>=
   procedure :: write => process_component_write
 <<Process config: procedures>>=
   subroutine process_component_write (object, unit)
     class(process_component_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%config)) then
        write (u, "(1x,A,I0)")  "Component #", object%index
        call object%config%write (u)
        if (object%md5sum_phs /= "") then
           write (u, "(3x,A,A,A)")  "MD5 sum (phs)       = '", &
                object%md5sum_phs, "'"
        end if
     else
        write (u, "(1x,A)") "Process component: [not allocated]"
     end if
     if (.not. object%active) then
        write (u, "(1x,A)") "[Inactive]"
        return
     end if
     write (u, "(1x,A)") "Referenced data:"
     if (allocated (object%i_term)) then
        write (u, "(3x,A,999(1x,I0))") "Terms                    =", &
             object%i_term
     else
        write (u, "(3x,A)") "Terms                    = [undefined]"
     end if
     if (object%i_mci /= 0) then
        write (u, "(3x,A,I0)") "MC dataset               = ", object%i_mci
     else
        write (u, "(3x,A)") "MC dataset               = [undefined]"
     end if
     if (allocated (object%phs_config)) then
        call object%phs_config%write (u)
     end if
   end subroutine process_component_write
 
 @ %def process_component_write
 @ Initialize the component.
 <<Process config: process component: TBP>>=
   procedure :: init => process_component_init
 <<Process config: procedures>>=
   subroutine process_component_init (component, &
        i_component, env, meta, config, &
        active, &
        phs_config_template)
     class(process_component_t), intent(out) :: component
     integer, intent(in) :: i_component
     type(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     type(process_config_data_t), intent(in) :: config
     logical, intent(in) :: active
     class(phs_config_t), intent(in), allocatable :: phs_config_template
 
     type(process_constants_t) :: data
 
     component%index = i_component
     component%config => &
          config%process_def%get_component_def_ptr (i_component)
 
     component%active = active
     if (component%active) then
        allocate (component%phs_config, source = phs_config_template)
        call env%fill_process_constants (meta%id, i_component, data)
        call component%phs_config%init (data, config%model)
     end if
   end subroutine process_component_init
 
 @ %def process_component_init
 @
 <<Process config: process component: TBP>>=
   procedure :: is_active => process_component_is_active
 <<Process config: procedures>>=
   elemental function process_component_is_active (component) result (active)
     logical :: active
     class(process_component_t), intent(in) :: component
     active = component%active
   end function process_component_is_active
 
 @ %def process_component_is_active
 @ Finalize the phase-space configuration.
 <<Process config: process component: TBP>>=
   procedure :: configure_phs => process_component_configure_phs
 <<Process config: procedures>>=
   subroutine process_component_configure_phs &
        (component, sqrts, beam_config, rebuild, &
         ignore_mismatch, subdir)
     class(process_component_t), intent(inout) :: component
     real(default), intent(in) :: sqrts
     type(process_beam_config_t), intent(in) :: beam_config
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     type(string_t), intent(in), optional :: subdir
     logical :: no_strfun
     integer :: nlo_type
     no_strfun = beam_config%n_strfun == 0
     nlo_type = component%config%get_nlo_type ()
     call component%phs_config%configure (sqrts, &
          azimuthal_dependence = beam_config%azimuthal_dependence, &
          sqrts_fixed = no_strfun, &
          lab_is_cm = beam_config%lab_is_cm .and. no_strfun, &
          rebuild = rebuild, ignore_mismatch = ignore_mismatch, &
          nlo_type = nlo_type, &
          subdir = subdir)
   end subroutine process_component_configure_phs
 
 @ %def process_component_configure_phs
 @ The process component possesses two MD5 sums: the checksum of the
 component definition, which should be available when the component is
 initialized, and the phase-space MD5 sum, which is available after
 configuration.
 <<Process config: process component: TBP>>=
   procedure :: compute_md5sum => process_component_compute_md5sum
 <<Process config: procedures>>=
   subroutine process_component_compute_md5sum (component)
     class(process_component_t), intent(inout) :: component
     component%md5sum_phs = component%phs_config%get_md5sum ()
   end subroutine process_component_compute_md5sum
 
 @ %def process_component_compute_md5sum
 @ Match phase-space channels with structure-function channels, where
 applicable.
 
 This calls a method of the [[phs_config]] phase-space implementation.
 <<Process config: process component: TBP>>=
   procedure :: collect_channels => process_component_collect_channels
 <<Process config: procedures>>=
   subroutine process_component_collect_channels (component, coll)
     class(process_component_t), intent(inout) :: component
     type(phs_channel_collection_t), intent(inout) :: coll
     call component%phs_config%collect_channels (coll)
   end subroutine process_component_collect_channels
 
 @ %def process_component_collect_channels
 @
 <<Process config: process component: TBP>>=
   procedure :: get_config => process_component_get_config
 <<Process config: procedures>>=
   function process_component_get_config (component) &
          result (config)
     type(process_component_def_t) :: config
     class(process_component_t), intent(in) :: component
     config = component%config
   end function process_component_get_config
 
 @ %def process_component_get_config
 @
 <<Process config: process component: TBP>>=
   procedure :: get_md5sum => process_component_get_md5sum
 <<Process config: procedures>>=
   pure function process_component_get_md5sum (component) result (md5)
     type(string_t) :: md5
     class(process_component_t), intent(in) :: component
     md5 = component%config%get_md5sum () // component%md5sum_phs
   end function process_component_get_md5sum
 
 @ %def process_component_get_md5sum
 @ Return the number of phase-space parameters.
 <<Process config: process component: TBP>>=
   procedure :: get_n_phs_par => process_component_get_n_phs_par
 <<Process config: procedures>>=
   function process_component_get_n_phs_par (component) result (n_par)
     class(process_component_t), intent(in) :: component
     integer :: n_par
     n_par = component%phs_config%get_n_par ()
   end function process_component_get_n_phs_par
 
 @ %def process_component_get_n_phs_par
 @
 <<Process config: process component: TBP>>=
   procedure :: get_phs_config => process_component_get_phs_config
 <<Process config: procedures>>=
   subroutine process_component_get_phs_config (component, phs_config)
     class(process_component_t), intent(in), target :: component
     class(phs_config_t), intent(out), pointer :: phs_config
     phs_config => component%phs_config
   end subroutine process_component_get_phs_config
 
 @ %def process_component_get_phs_config
 @
 <<Process config: process component: TBP>>=
   procedure :: get_nlo_type => process_component_get_nlo_type
 <<Process config: procedures>>=
   elemental function process_component_get_nlo_type (component) result (nlo_type)
      integer :: nlo_type
      class(process_component_t), intent(in) :: component
      nlo_type = component%config%get_nlo_type ()
   end function process_component_get_nlo_type
 
 @ %def process_component_get_nlo_type
 @
 <<Process config: process component: TBP>>=
   procedure :: needs_mci_entry => process_component_needs_mci_entry
 <<Process config: procedures>>=
   function process_component_needs_mci_entry (component, combined_integration) result (value)
     logical :: value
     class(process_component_t), intent(in) :: component
     logical, intent(in), optional :: combined_integration
     value = component%active
     if (present (combined_integration)) then
        if (combined_integration) &
             value = value .and. component%component_type <= COMP_MASTER
     end if
   end function process_component_needs_mci_entry
 
 @ %def process_component_needs_mci_entry
 @
 <<Process config: process component: TBP>>=
   procedure :: can_be_integrated => process_component_can_be_integrated
 <<Process config: procedures>>=
   elemental function process_component_can_be_integrated (component) result (active)
     logical :: active
     class(process_component_t), intent(in) :: component
     active = component%config%can_be_integrated ()
   end function process_component_can_be_integrated
 
 @ %def process_component_can_be_integrated
 @
 \subsection{Process terms}
 For straightforward tree-level calculations, each process component
 corresponds to a unique elementary interaction.  However, in the case
 of NLO calculations with subtraction terms, a process component may
 split into several separate contributions to the scattering, which are
 qualified by interactions with distinct kinematics and particle
 content.  We represent their configuration as [[process_term_t]]
 objects, the actual instances will be introduced below as
 [[term_instance_t]].  In any case, the process term contains an
 elementary interaction with a definite quantum-number and momentum
 content.
 
 The index [[i_term_global]] identifies the term relative to the
 process.
 
 The index [[i_component]] identifies the process component which
 generates this term, relative to the parent process.
 
 The index [[i_term]] identifies the term relative to the process
 component (not the process).
 
 The [[data]] subobject holds all process constants.
 
 The number of allowed flavor/helicity/color combinations is stored as
 [[n_allowed]].  This is the total number of independent entries in the
 density matrix.  For each combination, the index of the flavor,
 helicity, and color state is stored in the arrays [[flv]], [[hel]],
 and [[col]], respectively.
 
 The flag [[rearrange]] is true if we need to rearrange the particles of the
 hard interaction, to obtain the effective parton state.
 
 The interaction [[int]] holds the quantum state for the (resolved) hard
 interaction, the parent-child relations of the particles, and their momenta.
 The momenta are not filled yet; this is postponed to copies of [[int]] which
 go into the process instances.
 
 If recombination is in effect, we should allocate [[int_eff]] to describe the
 rearranged partonic state.
 
 This type is public only for use in a unit test.
 <<Process config: public>>=
   public :: process_term_t
 <<Process config: types>>=
   type :: process_term_t
      integer :: i_term_global = 0
      integer :: i_component = 0
      integer :: i_term = 0
      integer :: i_sub = 0
      integer :: i_core = 0
      integer :: n_allowed = 0
      type(process_constants_t) :: data
      real(default) :: alpha_s = 0
      integer, dimension(:), allocatable :: flv, hel, col
      integer :: n_sub, n_sub_color, n_sub_spin
      type(interaction_t) :: int
      type(interaction_t), pointer :: int_eff => null ()
    contains
    <<Process config: process term: TBP>>
   end type process_term_t
 
 @ %def process_term_t
 @ For the output, we skip the process constants and the tables of
 allowed quantum numbers.  Those can also be read off from the
 interaction object.
 <<Process config: process term: TBP>>=
   procedure :: write => process_term_write
 <<Process config: procedures>>=
   subroutine process_term_write (term, unit)
     class(process_term_t), intent(in) :: term
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A,I0)")  "Term #", term%i_term_global
     write (u, "(3x,A,I0)")  "Process component index      = ", &
          term%i_component
     write (u, "(3x,A,I0)")  "Term index w.r.t. component  = ", &
          term%i_term
     call write_separator (u)
     write (u, "(1x,A)")  "Hard interaction:"
     call write_separator (u)
     call term%int%basic_write (u)
   end subroutine process_term_write
 
 @ %def process_term_write
 @ Write an account of all quantum number states and their current status.
 <<Process config: process term: TBP>>=
   procedure :: write_state_summary => process_term_write_state_summary
 <<Process config: procedures>>=
   subroutine process_term_write_state_summary (term, core, unit)
     class(process_term_t), intent(in) :: term
     class(prc_core_t), intent(in) :: core
     integer, intent(in), optional :: unit
     integer :: u, i, f, h, c
     type(state_iterator_t) :: it
     character :: sgn
     u = given_output_unit (unit)
     write (u, "(1x,A,I0)")  "Term #", term%i_term_global
     call it%init (term%int%get_state_matrix_ptr ())
     do while (it%is_valid ())
        i = it%get_me_index ()
        f = term%flv(i)
        h = term%hel(i)
        if (allocated (term%col)) then
           c = term%col(i)
        else
           c = 1
        end if
        if (core%is_allowed (term%i_term, f, h, c)) then
           sgn = "+"
        else
           sgn = " "
        end if
        write (u, "(1x,A1,1x,I0,2x)", advance="no")  sgn, i
        call quantum_numbers_write (it%get_quantum_numbers (), u)
        write (u, *)
        call it%advance ()
     end do
   end subroutine process_term_write_state_summary
 
 @ %def process_term_write_state_summary
 @ Finalizer: the [[int]] and potentially [[int_eff]] components have a
 finalizer that we must call.
 <<Process config: process term: TBP>>=
   procedure :: final => process_term_final
 <<Process config: procedures>>=
   subroutine process_term_final (term)
     class(process_term_t), intent(inout) :: term
     call term%int%final ()
   end subroutine process_term_final
 
 @ %def process_term_final
 @ Initialize the term.  We copy the process constants from the [[core]]
 object and set up the [[int]] hard interaction accordingly.
 
 The [[alpha_s]] value is useful for writing external event records.  This is
 the constant value which may be overridden by a event-specific running value.
 If the model does not contain the strong coupling, the value is zero.
 
 The [[rearrange]] part is commented out; this or something equivalent
 could become relevant for NLO algorithms.
 <<Process config: process term: TBP>>=
   procedure :: init => process_term_init
 <<Process config: procedures>>=
   subroutine process_term_init &
        (term, i_term_global, i_component, i_term, core, model, &
         nlo_type, use_beam_pol, subtraction_method, &
         has_pdfs, n_emitters)
     class(process_term_t), intent(inout), target :: term
     integer, intent(in) :: i_term_global
     integer, intent(in) :: i_component
     integer, intent(in) :: i_term
     class(prc_core_t), intent(inout) :: core
     class(model_data_t), intent(in), target :: model
     integer, intent(in), optional :: nlo_type
     logical, intent(in), optional :: use_beam_pol
     type(string_t), intent(in), optional :: subtraction_method
     logical, intent(in), optional :: has_pdfs
     integer, intent(in), optional :: n_emitters
     class(modelpar_data_t), pointer :: alpha_s_ptr
     logical :: use_internal_color
     term%i_term_global = i_term_global
     term%i_component = i_component
     term%i_term = i_term
     call core%get_constants (term%data, i_term)
     alpha_s_ptr => model%get_par_data_ptr (var_str ("alphas"))
     if (associated (alpha_s_ptr)) then
        term%alpha_s = alpha_s_ptr%get_real ()
     else
        term%alpha_s = -1
     end if
     use_internal_color = .false.
     if (present (subtraction_method)) &
          use_internal_color = (char (subtraction_method) == 'omega') &
          .or. (char (subtraction_method) == 'threshold')
     call term%setup_interaction (core, model, nlo_type = nlo_type, &
          pol_beams = use_beam_pol, use_internal_color = use_internal_color, &
          has_pdfs = has_pdfs, n_emitters = n_emitters)
   end subroutine process_term_init
 
 @ %def process_term_init
 @ We fetch the process constants which determine the quantum numbers and
 use those to create the interaction.  The interaction contains
 incoming and outgoing particles, no virtuals.  The incoming particles
 are parents of the outgoing ones.
 
 Keeping previous \whizard\ conventions, we invert the color assignment
 (but not flavor or helicity) for the incoming particles.  When the
 color-flow square matrix is evaluated, this inversion is done again,
 so in the color-flow sequence we get the color assignments of the
 matrix element.
 
 \textbf{Why are these four subtraction entries for structure-function
 aware interactions?} Taking the soft or collinear limit of the real-emission
 matrix element, the behavior of the parton energy fractions has to be
 taken into account. In the pure real case, $x_\oplus$ and $x_\ominus$
 are given by
 \begin{equation*}
   x_\oplus = \frac{\bar{x}_\oplus}{\sqrt{1-\xi}}
              \sqrt{\frac{2 - \xi(1-y)}{2 - \xi(1+y)}},
   \quad
   x_\ominus = \frac{\bar{x}_\ominus}{\sqrt{1-\xi}}
              \sqrt{\frac{2 - \xi(1+y)}{2 - \xi(1-y)}}.
 \end{equation*}
 In the soft limit, $\xi \to 0$, this yields $x_\oplus = \bar{x}_\oplus$
 and $x_\ominus = \bar{x}_\ominus$. In the collinear limit, $y \to 1$,
 it is $x_\oplus = \bar{x}_\oplus / (1 - \xi)$ and $x_\ominus = \bar{x}_\ominus$.
 Likewise, in the anti-collinear limit $y \to -1$, the inverse relation holds.
 We therefore have to distinguish four cases with the PDF assignments
 $f(x_\oplus) \cdot f(x_\ominus)$, $f(\bar{x}_\oplus) \cdot f(\bar{x}_\ominus)$,
 $f\left(\bar{x}_\oplus / (1-\xi)\right) \cdot f(\bar{x}_\ominus)$ and
 $f(\bar{x}_\oplus) \cdot f\left(\bar{x}_\ominus / (1-\xi)\right)$.
 
 The [[n_emitters]] optional argument is provided by the caller if this term
 requires spin-correlated matrix elements, and thus involves additional
 subtractions.
 <<Process config: process term: TBP>>=
   procedure :: setup_interaction => process_term_setup_interaction
 <<Process config: procedures>>=
   subroutine process_term_setup_interaction (term, core, model, &
      nlo_type, pol_beams, has_pdfs, use_internal_color, n_emitters)
     class(process_term_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     class(model_data_t), intent(in), target :: model
     logical, intent(in), optional :: pol_beams
     logical, intent(in), optional :: has_pdfs
     integer, intent(in), optional :: nlo_type
     logical, intent(in), optional :: use_internal_color
     integer, intent(in), optional :: n_emitters
     integer :: n, n_tot
     type(flavor_t), dimension(:), allocatable :: flv
     type(color_t), dimension(:), allocatable :: col
     type(helicity_t), dimension(:), allocatable :: hel
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     logical :: is_pol, use_color
     integer :: nlo_t, n_sub
     is_pol = .false.; if (present (pol_beams)) is_pol = pol_beams
     nlo_t = BORN; if (present (nlo_type)) nlo_t = nlo_type
     n_tot = term%data%n_in + term%data%n_out
     call count_number_of_states ()
     term%n_allowed = n
     call compute_n_sub (n_emitters, has_pdfs)
     call fill_quantum_numbers ()
     call term%int%basic_init &
          (term%data%n_in, 0, term%data%n_out, set_relations = .true.)
     select type (core)
     class is (prc_blha_t)
        call setup_states_blha_olp ()
     type is (prc_threshold_t)
        call setup_states_threshold ()
     class is (prc_external_t)
        call setup_states_other_prc_external ()
     class default
        call setup_states_omega ()
     end select
     call term%int%freeze ()
   contains
     subroutine count_number_of_states ()
       integer :: f, h, c
       n = 0
       select type (core)
       class is (prc_external_t)
          do f = 1, term%data%n_flv
             do h = 1, term%data%n_hel
                do c = 1, term%data%n_col
                   n = n + 1
                end do
             end do
          end do
       class default !!! Omega and all test cores
          do f = 1, term%data%n_flv
             do h = 1, term%data%n_hel
                do c = 1, term%data%n_col
                   if (core%is_allowed (term%i_term, f, h, c))  n = n + 1
                end do
             end do
          end do
       end select
     end subroutine count_number_of_states
 
     subroutine compute_n_sub (n_emitters, has_pdfs)
       integer, intent(in), optional :: n_emitters
       logical, intent(in), optional :: has_pdfs
       logical :: can_have_sub
       integer :: n_sub_color, n_sub_spin
       use_color = .false.; if (present (use_internal_color)) &
            use_color = use_internal_color
       can_have_sub = nlo_t == NLO_VIRTUAL .or. &
            (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
            nlo_t == NLO_MISMATCH
       n_sub_color = 0; n_sub_spin = 0
       if (can_have_sub) then
          if (.not. use_color) n_sub_color = n_tot * (n_tot - 1) / 2
          if (nlo_t == NLO_REAL) then
             if (present (n_emitters)) then
                n_sub_spin = 6 * n_emitters
             end if
          end if
       end if
       n_sub = n_sub_color + n_sub_spin
       !!! For the virtual subtraction we also need the finite virtual contribution
       !!! corresponding to the $\epsilon^0$-pole
       if (nlo_t == NLO_VIRTUAL)  n_sub = n_sub + 1
       if (present (has_pdfs)) then
          if (has_pdfs &
               .and. ((nlo_t == NLO_REAL .and. can_have_sub) &
               .or. nlo_t == NLO_DGLAP)) then
             !!! necessary dummy, needs refactoring,
             !!! c.f. [[term_instance_evaluate_interaction_userdef_tree]]
             n_sub = n_sub + n_beams_rescaled
          end if
       end if
       term%n_sub = n_sub
       term%n_sub_color = n_sub_color
       term%n_sub_spin = n_sub_spin
     end subroutine compute_n_sub
 
     subroutine fill_quantum_numbers ()
       integer :: nn
       logical :: can_have_sub
       select type (core)
       class is (prc_external_t)
          can_have_sub = nlo_t == NLO_VIRTUAL .or. &
               (nlo_t == NLO_REAL .and. term%i_term_global == term%i_sub) .or. &
               nlo_t == NLO_MISMATCH .or. nlo_t == NLO_DGLAP
          if (can_have_sub) then
             nn = (n_sub + 1) * n
          else
             nn = n
          end if
       class default
          nn = n
       end select
       allocate (term%flv (nn), term%col (nn), term%hel (nn))
       allocate (flv (n_tot), col (n_tot), hel (n_tot))
       allocate (qn (n_tot))
     end subroutine fill_quantum_numbers
 
     subroutine setup_states_blha_olp ()
       integer :: s, f, c, h, i
       i = 0
       associate (data => term%data)
          do s = 0, n_sub
              do f = 1, data%n_flv
                 do h = 1, data%n_hel
                    do c = 1, data%n_col
                       i = i + 1
                       term%flv(i) = f
                       term%hel(i) = h
                       !!! Dummy-initialization of color
                       term%col(i) = c
                       call flv%init (data%flv_state (:,f), model)
                       call color_init_from_array (col, &
                            data%col_state(:,:,c), data%ghost_flag(:,c))
                       call col(1:data%n_in)%invert ()
                       if (is_pol) then
                          select type (core)
                          type is (prc_openloops_t)
                             call hel%init (data%hel_state (:,h))
                             call qn%init (flv, hel, col, s)
                          class default
                             call msg_fatal ("Polarized beams only supported by OpenLoops")
                          end select
                       else
                          call qn%init (flv, col, s)
                       end if
                       call qn%tag_hard_process ()
                       call term%int%add_state (qn)
                   end do
                end do
              end do
          end do
       end associate
     end subroutine setup_states_blha_olp
 
     subroutine setup_states_threshold ()
       integer :: s, f, c, h, i
       i = 0
       n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
       associate (data => term%data)
          do s = 0, n_sub
             do f = 1, term%data%n_flv
                do h = 1, data%n_hel
                   do c = 1, data%n_col
                      i = i + 1
                      term%flv(i) = f
                      term%hel(i) = h
                      !!! Dummy-initialization of color
                      term%col(i) = 1
                      call flv%init (term%data%flv_state (:,f), model)
                      if (is_pol) then
                         call hel%init (data%hel_state (:,h))
                         call qn%init (flv, hel, s)
                      else
                         call qn%init (flv, s)
                      end if
                      call qn%tag_hard_process ()
                      call term%int%add_state (qn)
                   end do
                end do
             end do
          end do
       end associate
     end subroutine setup_states_threshold
 
     subroutine setup_states_other_prc_external ()
       integer :: s, f, i, c, h
       if (is_pol) &
          call msg_fatal ("Polarized beams only supported by OpenLoops")
       i = 0
       !!! n_sub = 0; if (nlo_t == NLO_VIRTUAL) n_sub = 1
       associate (data => term%data)
         do s = 0, n_sub
            do f = 1, data%n_flv
               do h = 1, data%n_hel
                  do c = 1, data%n_col
                     i = i + 1
                     term%flv(i) = f
                     term%hel(i) = h
                     !!! Dummy-initialization of color
                     term%col(i) = c
                     call flv%init (data%flv_state (:,f), model)
                     call color_init_from_array (col, &
                          data%col_state(:,:,c), data%ghost_flag(:,c))
                     call col(1:data%n_in)%invert ()
                     call qn%init (flv, col, s)
                     call qn%tag_hard_process ()
                     call term%int%add_state (qn)
                  end do
               end do
            end do
         end do
       end associate
     end subroutine setup_states_other_prc_external
 
     subroutine setup_states_omega ()
       integer :: f, h, c, i
       i = 0
       associate (data => term%data)
          do f = 1, data%n_flv
             do h = 1, data%n_hel
               do c = 1, data%n_col
                  if (core%is_allowed (term%i_term, f, h, c)) then
                     i = i + 1
                     term%flv(i) = f
                     term%hel(i) = h
                     term%col(i) = c
                     call flv%init (data%flv_state(:,f), model)
                     call color_init_from_array (col, &
                          data%col_state(:,:,c), &
                          data%ghost_flag(:,c))
                     call col(:data%n_in)%invert ()
                     call hel%init (data%hel_state(:,h))
                     call qn%init (flv, col, hel)
                     call qn%tag_hard_process ()
                     call term%int%add_state (qn)
                  end if
               end do
             end do
          end do
       end associate
     end subroutine setup_states_omega
 
   end subroutine process_term_setup_interaction
 
 @ %def process_term_setup_interaction
 @
 <<Process config: process term: TBP>>=
   procedure :: get_process_constants => process_term_get_process_constants
 <<Process config: procedures>>=
    subroutine process_term_get_process_constants &
        (term, prc_constants)
     class(process_term_t), intent(inout) :: term
     type(process_constants_t), intent(out) :: prc_constants
     prc_constants = term%data
   end subroutine process_term_get_process_constants
 
 @ %def process_term_get_process_constants
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process call statistics}
 Very simple object for statistics.  Could be moved to a more basic chapter.
 <<[[process_counter.f90]]>>=
 <<File header>>
 
 module process_counter
 
   use io_units
 
 <<Standard module head>>
 
 <<Process counter: public>>
 
 <<Process counter: parameters>>
 
 <<Process counter: types>>
 
 contains
 
 <<Process counter: procedures>>
 
 end module process_counter
 @ %def process_counter
 @ This object can record process calls, categorized by evaluation
 status.  It is a part of the [[mci_entry]] component below.
 <<Process counter: public>>=
   public :: process_counter_t
 <<Process counter: types>>=
   type :: process_counter_t
      integer :: total = 0
      integer :: failed_kinematics = 0
      integer :: failed_cuts = 0
      integer :: has_passed = 0
      integer :: evaluated = 0
      integer :: complete = 0
    contains
    <<Process counter: process counter: TBP>>
   end type process_counter_t
 
 @ %def process_counter_t
 @ Here are the corresponding numeric codes:
 <<Process counter: parameters>>=
   integer, parameter, public :: STAT_UNDEFINED = 0
   integer, parameter, public :: STAT_INITIAL = 1
   integer, parameter, public :: STAT_ACTIVATED = 2
   integer, parameter, public :: STAT_BEAM_MOMENTA = 3
   integer, parameter, public :: STAT_FAILED_KINEMATICS = 4
   integer, parameter, public :: STAT_SEED_KINEMATICS = 5
   integer, parameter, public :: STAT_HARD_KINEMATICS = 6
   integer, parameter, public :: STAT_EFF_KINEMATICS = 7
   integer, parameter, public :: STAT_FAILED_CUTS = 8
   integer, parameter, public :: STAT_PASSED_CUTS = 9
   integer, parameter, public :: STAT_EVALUATED_TRACE = 10
   integer, parameter, public :: STAT_EVENT_COMPLETE = 11
 
 @ %def STAT_UNDEFINED STAT_INITIAL STAT_ACTIVATED
 @ %def STAT_BEAM_MOMENTA STAT_FAILED_KINEMATICS
 @ %def STAT_SEED_KINEMATICS STAT_HARD_KINEMATICS STAT_EFF_KINEMATICS
 @ %def STAT_EVALUATED_TRACE STAT_EVENT_COMPLETE
 @ Output.
 <<Process counter: process counter: TBP>>=
   procedure :: write => process_counter_write
 <<Process counter: procedures>>=
   subroutine process_counter_write (object, unit)
     class(process_counter_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     if (object%total > 0) then
        write (u, "(1x,A)")  "Call statistics (current run):"
        write (u, "(3x,A,I0)")  "total       = ", object%total
        write (u, "(3x,A,I0)")  "failed kin. = ", object%failed_kinematics
        write (u, "(3x,A,I0)")  "failed cuts = ", object%failed_cuts
        write (u, "(3x,A,I0)")  "passed cuts = ", object%has_passed
        write (u, "(3x,A,I0)")  "evaluated   = ", object%evaluated
     else
        write (u, "(1x,A)")  "Call statistics (current run): [no calls]"
     end if
   end subroutine process_counter_write
 
 @ %def process_counter_write
 @ Reset.  Just enforce default initialization.
 <<Process counter: process counter: TBP>>=
   procedure :: reset => process_counter_reset
 <<Process counter: procedures>>=
   subroutine process_counter_reset (counter)
     class(process_counter_t), intent(out) :: counter
     counter%total = 0
     counter%failed_kinematics = 0
     counter%failed_cuts = 0
     counter%has_passed = 0
     counter%evaluated = 0
     counter%complete = 0
   end subroutine process_counter_reset
 
 @ %def process_counter_reset
 @ We record an event according to the lowest status code greater or
 equal to the actual status.  This is actually done by the process
 instance; the process object just copies the instance counter.
 <<Process counter: process counter: TBP>>=
   procedure :: record => process_counter_record
 <<Process counter: procedures>>=
   subroutine process_counter_record (counter, status)
     class(process_counter_t), intent(inout) :: counter
     integer, intent(in) :: status
     if (status <= STAT_FAILED_KINEMATICS) then
        counter%failed_kinematics = counter%failed_kinematics + 1
     else if (status <= STAT_FAILED_CUTS) then
        counter%failed_cuts = counter%failed_cuts + 1
     else if (status <= STAT_PASSED_CUTS) then
        counter%has_passed = counter%has_passed + 1
     else
        counter%evaluated = counter%evaluated + 1
     end if
     counter%total = counter%total + 1
   end subroutine process_counter_record
 
 @ %def process_counter_record
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Multi-channel integration}
 <<[[process_mci.f90]]>>=
 <<File header>>
 
 module process_mci
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use diagnostics
   use physics_defs
   use md5
   use cputime
   use rng_base
   use mci_base
   use variables
   use integration_results
   use process_libraries
   use phs_base
   use process_counter
   use process_config
 
 
 <<Standard module head>>
 
 <<Process mci: public>>
 
 <<Process mci: parameters>>
 
 <<Process mci: types>>
 
 contains
 
 <<Process mci: procedures>>
 
 end module process_mci
 @ %def process_mci
 \subsection{Process MCI entry}
 The [[process_mci_entry_t]] block contains, for each process component that is
 integrated independently, the configuration data for its MC input parameters.
 Each input parameter set is handled by a [[mci_t]] integrator.
 
 The MC input parameter set is broken down into the parameters required by the
 structure-function chain and the parameters required by the phase space of the
 elementary process.
 
 The MD5 sum collects all information about the associated processes
 that may affect the integration.  It does not contain the MCI object
 itself or integration results.
 
 MC integration is organized in passes.  Each pass may consist of
 several iterations, and for each iteration there is a number of
 calls.  We store explicitly the values that apply to the current
 pass.  Previous values are archived in the [[results]] object.
 
 The [[counter]] receives the counter statistics from the associated
 process instance, for diagnostics.
 
 The [[results]] object records results, broken down in passes and iterations.
 <<Process mci: public>>=
   public :: process_mci_entry_t
 <<Process mci: types>>=
   type :: process_mci_entry_t
      integer :: i_mci = 0
      integer, dimension(:), allocatable :: i_component
      integer :: process_type = PRC_UNKNOWN
      integer :: n_par = 0
      integer :: n_par_sf = 0
      integer :: n_par_phs = 0
      character(32) :: md5sum = ""
      integer :: pass = 0
      integer :: n_it = 0
      integer :: n_calls = 0
      logical :: activate_timer = .false.
      real(default) :: error_threshold = 0
      class(mci_t), allocatable :: mci
      type(process_counter_t) :: counter
      type(integration_results_t) :: results
      logical :: negative_weights = .false.
      logical :: combined_integration = .false.
      integer :: real_partition_type = REAL_FULL
      integer :: associated_real_component = 0
    contains
    <<Process mci: process mci entry: TBP>>
   end type process_mci_entry_t
 
 @ %def process_mci_entry_t
 @ Finalizer for the [[mci]] component.
 <<Process mci: process mci entry: TBP>>=
   procedure :: final => process_mci_entry_final
 <<Process mci: procedures>>=
   subroutine process_mci_entry_final (object)
     class(process_mci_entry_t), intent(inout) :: object
     if (allocated (object%mci))  call object%mci%final ()
   end subroutine process_mci_entry_final
 
 @ %def process_mci_entry_final
 @ Output.  Write pass/iteration information only if set (the pass
 index is nonzero).  Write the MCI block only if it exists (for some
 self-tests it does not).  Write results only if there are any.
 <<Process mci: process mci entry: TBP>>=
   procedure :: write => process_mci_entry_write
 <<Process mci: procedures>>=
   subroutine process_mci_entry_write (object, unit, pacify)
     class(process_mci_entry_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: pacify
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A,I0)")  "Associated components = ", object%i_component
     write (u, "(3x,A,I0)")  "MC input parameters   = ", object%n_par
     write (u, "(3x,A,I0)")  "MC parameters (SF)    = ", object%n_par_sf
     write (u, "(3x,A,I0)")  "MC parameters (PHS)   = ", object%n_par_phs
     if (object%pass > 0) then
        write (u, "(3x,A,I0)")  "Current pass          = ", object%pass
        write (u, "(3x,A,I0)")  "Number of iterations  = ", object%n_it
        write (u, "(3x,A,I0)")  "Number of calls       = ", object%n_calls
     end if
     if (object%md5sum /= "") then
        write (u, "(3x,A,A,A)") "MD5 sum (components)  = '", object%md5sum, "'"
     end if
     if (allocated (object%mci)) then
        call object%mci%write (u)
     end if
     call object%counter%write (u)
     if (object%results%exist ()) then
        call object%results%write (u, suppress = pacify)
        call object%results%write_chain_weights (u)
     end if
   end subroutine process_mci_entry_write
 
 @ %def process_mci_entry_write
 @ Configure the MCI entry.  This is intent(inout) since some specific settings
 may be done before this.  The actual [[mci_t]] object is an instance of the
 [[mci_template]] argument, which determines the concrete types.
 
 In a unit-test context, the [[mci_template]] argument may be unallocated.
 
 We obtain the number of channels and the number of parameters, separately for
 the structure-function chain and for the associated process component.  We
 assume that the phase-space object has already been configured.
 
 We assume that there is only one process component directly associated with a
 MCI entry.
 <<Process mci: process mci entry: TBP>>=
   procedure :: configure => process_mci_entry_configure
 <<Process mci: procedures>>=
   subroutine process_mci_entry_configure (mci_entry, mci_template, &
        process_type, i_mci, i_component, component, &
        n_sfpar, rng_factory)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_t), intent(in), allocatable :: mci_template
     integer, intent(in) :: process_type
     integer, intent(in) :: i_mci
     integer, intent(in) :: i_component
     type(process_component_t), intent(in), target :: component
     integer, intent(in) :: n_sfpar
     class(rng_factory_t), intent(inout) :: rng_factory
     class(rng_t), allocatable :: rng
     associate (phs_config => component%phs_config)
       mci_entry%i_mci = i_mci
       call mci_entry%create_component_list (i_component, component%get_config ())
       mci_entry%n_par_sf = n_sfpar
       mci_entry%n_par_phs = phs_config%get_n_par ()
       mci_entry%n_par = mci_entry%n_par_sf + mci_entry%n_par_phs
       mci_entry%process_type = process_type
       if (allocated (mci_template)) then
          allocate (mci_entry%mci, source = mci_template)
          call mci_entry%mci%record_index (mci_entry%i_mci)
          call mci_entry%mci%set_dimensions &
               (mci_entry%n_par, phs_config%get_n_channel ())
          call mci_entry%mci%declare_flat_dimensions &
               (phs_config%get_flat_dimensions ())
          if (phs_config%provides_equivalences) then
             call mci_entry%mci%declare_equivalences &
                  (phs_config%channel, mci_entry%n_par_sf)
          end if
          if (phs_config%provides_chains) then
             call mci_entry%mci%declare_chains (phs_config%chain)
          end if
          call rng_factory%make (rng)
          call mci_entry%mci%import_rng (rng)
       end if
       call mci_entry%results%init (process_type)
     end associate
   end subroutine process_mci_entry_configure
 
 @ %def process_mci_entry_configure
 @
 <<Process mci: parameters>>=
   integer, parameter, public :: REAL_FULL = 0
   integer, parameter, public :: REAL_SINGULAR = 1
   integer, parameter, public :: REAL_FINITE = 2
 @
 <<Process mci: process mci entry: TBP>>=
   procedure :: create_component_list => &
      process_mci_entry_create_component_list
 <<Process mci: procedures>>=
   subroutine process_mci_entry_create_component_list (mci_entry, &
      i_component, component_config)
     class (process_mci_entry_t), intent(inout) :: mci_entry
     integer, intent(in) :: i_component
     type(process_component_def_t), intent(in) :: component_config
     integer, dimension(:), allocatable :: i_list
     integer :: n
     integer, save :: i_rfin_offset = 0
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_mci_entry_create_component_list")
     if (mci_entry%combined_integration) then
        n = get_n_components (mci_entry%real_partition_type)
        allocate (i_list (n))
        if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
             "mci_entry%real_partition_type", mci_entry%real_partition_type)
        select case (mci_entry%real_partition_type)
        case (REAL_FULL)
           i_list = component_config%get_association_list ()
           allocate (mci_entry%i_component (size (i_list)))
           mci_entry%i_component = i_list
        case (REAL_SINGULAR)
           i_list = component_config%get_association_list (ASSOCIATED_REAL_FIN)
           allocate (mci_entry%i_component (size(i_list)))
           mci_entry%i_component = i_list
        case (REAL_FINITE)
           allocate (mci_entry%i_component (1))
           mci_entry%i_component(1) = &
                component_config%get_associated_real_fin () + i_rfin_offset
           i_rfin_offset = i_rfin_offset + 1
        end select
     else
        allocate (mci_entry%i_component (1))
        mci_entry%i_component(1) = i_component
     end if
   contains
     function get_n_components (damping_type) result (n_components)
       integer :: n_components
       integer, intent(in) :: damping_type
       select case (damping_type)
       case (REAL_FULL)
          n_components = size (component_config%get_association_list ())
       case (REAL_SINGULAR)
          n_components = size (component_config%get_association_list &
             (ASSOCIATED_REAL_FIN))
       end select
       if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "n_components", n_components)
     end function get_n_components
   end subroutine process_mci_entry_create_component_list
 
 @ %def process_mci_entry_create_component_list
 @
 <<Process mci: process mci entry: TBP>>=
   procedure :: set_associated_real_component &
       => process_mci_entry_set_associated_real_component
 <<Process mci: procedures>>=
   subroutine process_mci_entry_set_associated_real_component (mci_entry, i)
      class(process_mci_entry_t), intent(inout) :: mci_entry
      integer, intent(in) :: i
      mci_entry%associated_real_component = i
   end subroutine process_mci_entry_set_associated_real_component
 
 @ %def process_mci_entry_set_associated_real_component
 @ Set some additional parameters.
 <<Process mci: process mci entry: TBP>>=
   procedure :: set_parameters => process_mci_entry_set_parameters
 <<Process mci: procedures>>=
   subroutine process_mci_entry_set_parameters (mci_entry, var_list)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     type(var_list_t), intent(in) :: var_list
     integer :: integration_results_verbosity
     real(default) :: error_threshold
     integration_results_verbosity = &
          var_list%get_ival (var_str ("integration_results_verbosity"))
     error_threshold = &
          var_list%get_rval (var_str ("error_threshold"))
     mci_entry%activate_timer = &
          var_list%get_lval (var_str ("?integration_timer"))
     call mci_entry%results%set_verbosity (integration_results_verbosity)
     call mci_entry%results%set_error_threshold (error_threshold)
   end subroutine process_mci_entry_set_parameters
 
 @ %def process_mci_entry_set_parameters
 @ Compute an MD5 sum that summarizes all information that could
 influence integration results, for the associated process components.
 We take the process-configuration MD5 sum which represents parameters,
 cuts, etc., the MD5 sums for the process component definitions and
 their phase space objects (which should be configured), and the beam
 configuration MD5 sum.  (The QCD setup is included in the process
 configuration data MD5 sum.)
 
 Done only once, when the MD5 sum is still empty.
 <<Process mci: process mci entry: TBP>>=
   procedure :: compute_md5sum => process_mci_entry_compute_md5sum
 <<Process mci: procedures>>=
   subroutine process_mci_entry_compute_md5sum (mci_entry, &
        config, component, beam_config)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     type(process_config_data_t), intent(in) :: config
     type(process_component_t), dimension(:), intent(in) :: component
     type(process_beam_config_t), intent(in) :: beam_config
     type(string_t) :: buffer
     integer :: i
     if (mci_entry%md5sum == "") then
        buffer = config%get_md5sum () // beam_config%get_md5sum ()
        do i = 1, size (component)
           if (component(i)%is_active ()) then
              buffer = buffer // component(i)%get_md5sum ()
           end if
        end do
        mci_entry%md5sum = md5sum (char (buffer))
     end if
     if (allocated (mci_entry%mci)) then
        call mci_entry%mci%set_md5sum (mci_entry%md5sum)
     end if
   end subroutine process_mci_entry_compute_md5sum
 
 @ %def process_mci_entry_compute_md5sum
 @ Test the MCI sampler by calling it a given number of time, discarding the
 results.  The instance should be initialized.
 
 The [[mci_entry]] is [[intent(inout)]] because the integrator contains
 the random-number state.
 <<Process mci: process mci entry: TBP>>=
   procedure :: sampler_test => process_mci_entry_sampler_test
 <<Process mci: procedures>>=
   subroutine process_mci_entry_sampler_test (mci_entry, mci_sampler, n_calls)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_sampler_t), intent(inout), target :: mci_sampler
     integer, intent(in) :: n_calls
     call mci_entry%mci%sampler_test (mci_sampler, n_calls)
   end subroutine process_mci_entry_sampler_test
 
 @ %def process_mci_entry_sampler_test
 @ Integrate.
 
 The [[integrate]] method counts as an integration pass; the pass count is
 increased by one.  We transfer the pass parameters (number of iterations and
 number of calls) to the actual integration routine.
 
 The [[mci_entry]] is [[intent(inout)]] because the integrator contains
 the random-number state.
 
 Note: The results are written to screen and to logfile.  This behavior
 is hardcoded.
 <<Process mci: process mci entry: TBP>>=
   procedure :: integrate => process_mci_entry_integrate
   procedure :: final_integration => process_mci_entry_final_integration
 <<Process mci: procedures>>=
   subroutine process_mci_entry_integrate (mci_entry, mci_instance, &
          mci_sampler, n_it, n_calls, &
        adapt_grids, adapt_weights, final, pacify, &
        nlo_type)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_instance_t), intent(inout) :: mci_instance
     class(mci_sampler_t), intent(inout) :: mci_sampler
     integer, intent(in) :: n_it
     integer, intent(in) :: n_calls
     logical, intent(in), optional :: adapt_grids
     logical, intent(in), optional :: adapt_weights
     logical, intent(in), optional :: final, pacify
     integer, intent(in), optional :: nlo_type
     integer :: u_log
     u_log = logfile_unit ()
     mci_entry%pass = mci_entry%pass + 1
     mci_entry%n_it = n_it
     mci_entry%n_calls = n_calls
     if (mci_entry%pass == 1)  &
          call mci_entry%mci%startup_message (n_calls = n_calls)
     call mci_entry%mci%set_timer (active = mci_entry%activate_timer)
     call mci_entry%results%display_init (screen = .true., unit = u_log)
     call mci_entry%results%new_pass ()
     if (present (nlo_type)) then
        select case (nlo_type)
        case (NLO_VIRTUAL, NLO_REAL, NLO_MISMATCH, NLO_DGLAP)
           mci_instance%negative_weights = .true.
        end select
     end if
     call mci_entry%mci%add_pass (adapt_grids, adapt_weights, final)
     call mci_entry%mci%start_timer ()
     call mci_entry%mci%integrate (mci_instance, mci_sampler, n_it, &
          n_calls, mci_entry%results, pacify = pacify)
     call mci_entry%mci%stop_timer ()
     if (signal_is_pending ())  return
   end subroutine process_mci_entry_integrate
 
   subroutine process_mci_entry_final_integration (mci_entry)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     call mci_entry%results%display_final ()
     call mci_entry%time_message ()
   end subroutine process_mci_entry_final_integration
 
 @ %def process_mci_entry_integrate
 @ %def process_mci_entry_final_integration
 @ If appropriate, issue an informative message about the expected time
 for an event sample.
 <<Process mci: process mci entry: TBP>>=
   procedure :: get_time => process_mci_entry_get_time
   procedure :: time_message => process_mci_entry_time_message
 <<Process mci: procedures>>=
   subroutine process_mci_entry_get_time (mci_entry, time, sample)
     class(process_mci_entry_t), intent(in) :: mci_entry
     type(time_t), intent(out) :: time
     integer, intent(in) :: sample
     real(default) :: time_last_pass, efficiency, calls
     time_last_pass = mci_entry%mci%get_time ()
     calls = mci_entry%results%get_n_calls ()
     efficiency = mci_entry%mci%get_efficiency ()
     if (time_last_pass > 0 .and. calls > 0 .and. efficiency > 0) then
        time = nint (time_last_pass / calls / efficiency * sample)
     end if
   end subroutine process_mci_entry_get_time
 
   subroutine process_mci_entry_time_message (mci_entry)
     class(process_mci_entry_t), intent(in) :: mci_entry
     type(time_t) :: time
     integer :: sample
     sample = 10000
     call mci_entry%get_time (time, sample)
     if (time%is_known ()) then
        call msg_message ("Time estimate for generating 10000 events: " &
             // char (time%to_string_dhms ()))
     end if
   end subroutine process_mci_entry_time_message
 
 @ %def process_mci_entry_time_message
 @ Prepare event generation.  (For the test integrator, this does nothing.  It
 is relevant for the VAMP integrator.)
 <<Process mci: process mci entry: TBP>>=
   procedure :: prepare_simulation => process_mci_entry_prepare_simulation
 <<Process mci: procedures>>=
   subroutine process_mci_entry_prepare_simulation (mci_entry)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     call mci_entry%mci%prepare_simulation ()
   end subroutine process_mci_entry_prepare_simulation
 
 @ %def process_mci_entry_prepare_simulation
 @ Generate an event.  The instance should be initialized,
 otherwise event generation is directed by the [[mci]] integrator
 subobject.  The integrator instance is contained in a [[mci_work]]
 subobject of the process instance, which simultaneously serves as the
 sampler object.  (We avoid the anti-aliasing rules if we assume that
 the sampling itself does not involve the integrator instance contained in the
 process instance.)
 
 Regarding weighted events, we only take events which are valid, which
 means that they have valid kinematics and have passed cuts.
 Therefore, we have a rejection loop.  For unweighted events, the
 unweighting routine should already take care of this.
 
 The [[keep_failed]] flag determines whether events which failed cuts
 are nevertheless produced, to be recorded with zero weight.
 Alternatively, failed events are dropped, and this fact is recorded by
 the counter [[n_dropped]].
 <<Process mci: process mci entry: TBP>>=
   procedure :: generate_weighted_event => &
        process_mci_entry_generate_weighted_event
   procedure :: generate_unweighted_event => &
        process_mci_entry_generate_unweighted_event
 <<Process mci: procedures>>=
   subroutine process_mci_entry_generate_weighted_event (mci_entry, &
       mci_instance, mci_sampler, keep_failed)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_instance_t), intent(inout) :: mci_instance
     class(mci_sampler_t), intent(inout) :: mci_sampler
     logical, intent(in) :: keep_failed
     logical :: generate_new
     generate_new = .true.
     call mci_instance%reset_n_event_dropped ()
     REJECTION: do while (generate_new)
        call mci_entry%mci%generate_weighted_event (mci_instance, mci_sampler)
        if (signal_is_pending ())  return
        if (.not. mci_sampler%is_valid()) then
           if (keep_failed) then
              generate_new = .false.
           else
              call mci_instance%record_event_dropped ()
              generate_new = .true.
           end if
        else
           generate_new = .false.
        end if
     end do REJECTION
   end subroutine process_mci_entry_generate_weighted_event
 
   subroutine process_mci_entry_generate_unweighted_event (mci_entry, mci_instance, mci_sampler)
     class(process_mci_entry_t), intent(inout) :: mci_entry
     class(mci_instance_t), intent(inout) :: mci_instance
     class(mci_sampler_t), intent(inout) :: mci_sampler
     call mci_entry%mci%generate_unweighted_event (mci_instance, mci_sampler)
   end subroutine process_mci_entry_generate_unweighted_event
 
 @ %def process_mci_entry_generate_weighted_event
 @ %def process_mci_entry_generate_unweighted_event
 @ Extract results.
 <<Process mci: process mci entry: TBP>>=
   procedure :: has_integral => process_mci_entry_has_integral
   procedure :: get_integral => process_mci_entry_get_integral
   procedure :: get_error => process_mci_entry_get_error
   procedure :: get_accuracy => process_mci_entry_get_accuracy
   procedure :: get_chi2 => process_mci_entry_get_chi2
   procedure :: get_efficiency => process_mci_entry_get_efficiency
 <<Process mci: procedures>>=
   function process_mci_entry_has_integral (mci_entry) result (flag)
     class(process_mci_entry_t), intent(in) :: mci_entry
     logical :: flag
     flag = mci_entry%results%exist ()
   end function process_mci_entry_has_integral
 
   function process_mci_entry_get_integral (mci_entry) result (integral)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: integral
     integral = mci_entry%results%get_integral ()
   end function process_mci_entry_get_integral
 
   function process_mci_entry_get_error (mci_entry) result (error)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: error
     error = mci_entry%results%get_error ()
   end function process_mci_entry_get_error
 
   function process_mci_entry_get_accuracy (mci_entry) result (accuracy)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: accuracy
     accuracy = mci_entry%results%get_accuracy ()
   end function process_mci_entry_get_accuracy
 
   function process_mci_entry_get_chi2 (mci_entry) result (chi2)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: chi2
     chi2 = mci_entry%results%get_chi2 ()
   end function process_mci_entry_get_chi2
 
   function process_mci_entry_get_efficiency (mci_entry) result (efficiency)
     class(process_mci_entry_t), intent(in) :: mci_entry
     real(default) :: efficiency
     efficiency = mci_entry%results%get_efficiency ()
   end function process_mci_entry_get_efficiency
 
 @ %def process_mci_entry_get_integral process_mci_entry_get_error
 @ %def process_mci_entry_get_accuracy process_mci_entry_get_chi2
 @ %def process_mci_entry_get_efficiency
 @ Return the MCI checksum.  This may be the one used for
 configuration, but may also incorporate results, if they change the
 state of the integrator (adaptation).
 <<Process mci: process mci entry: TBP>>=
   procedure :: get_md5sum => process_mci_entry_get_md5sum
 <<Process mci: procedures>>=
   pure function process_mci_entry_get_md5sum (entry) result (md5sum)
     class(process_mci_entry_t), intent(in) :: entry
     character(32) :: md5sum
     md5sum = entry%mci%get_md5sum ()
   end function process_mci_entry_get_md5sum
 
 @ %def process_mci_entry_get_md5sum
 @
 \subsection{MC parameter set and MCI instance}
 For each process component that is associated with a multi-channel integration
 (MCI) object, the [[mci_work_t]] object contains the currently active
 parameter set.  It also holds the implementation of the [[mci_instance_t]]
 that the integrator needs for doing its work.
 <<Process mci: public>>=
   public :: mci_work_t
 <<Process mci: types>>=
   type :: mci_work_t
      type(process_mci_entry_t), pointer :: config => null ()
      real(default), dimension(:), allocatable :: x
      class(mci_instance_t), pointer :: mci => null ()
      type(process_counter_t) :: counter
      logical :: keep_failed_events = .false.
      integer :: n_event_dropped = 0
    contains
    <<Process mci: mci work: TBP>>
   end type mci_work_t
 
 @ %def mci_work_t
 @ First write configuration data, then the current values.
 <<Process mci: mci work: TBP>>=
   procedure :: write => mci_work_write
 <<Process mci: procedures>>=
   subroutine mci_work_write (mci_work, unit, testflag)
     class(mci_work_t), intent(in) :: mci_work
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A,I0,A)")  "Active MCI instance #", &
          mci_work%config%i_mci, " ="
     write (u, "(2x)", advance="no")
     do i = 1, mci_work%config%n_par
        write (u, "(1x,F7.5)", advance="no")  mci_work%x(i)
        if (i == mci_work%config%n_par_sf) &
             write (u, "(1x,'|')", advance="no")
     end do
     write (u, *)
     if (associated (mci_work%mci)) then
        call mci_work%mci%write (u, pacify = testflag)
        call mci_work%counter%write (u)
     end if
   end subroutine mci_work_write
 
 @ %def mci_work_write
 @ The [[mci]] component may require finalization.
 <<Process mci: mci work: TBP>>=
   procedure :: final => mci_work_final
 <<Process mci: procedures>>=
   subroutine mci_work_final (mci_work)
     class(mci_work_t), intent(inout) :: mci_work
     if (associated (mci_work%mci)) then
        call mci_work%mci%final ()
        deallocate (mci_work%mci)
     end if
   end subroutine mci_work_final
 
 @ %def mci_work_final
 @ Initialize with the maximum length that we will need.  Contents are
 not initialized.
 
 The integrator inside the [[mci_entry]] object is responsible for
 allocating and initializing its own instance, which is referred to by
 a pointer in the [[mci_work]] object.
 <<Process mci: mci work: TBP>>=
   procedure :: init => mci_work_init
 <<Process mci: procedures>>=
   subroutine mci_work_init (mci_work, mci_entry)
     class(mci_work_t), intent(out) :: mci_work
     type(process_mci_entry_t), intent(in), target :: mci_entry
     mci_work%config => mci_entry
     allocate (mci_work%x (mci_entry%n_par))
     if (allocated (mci_entry%mci)) then
        call mci_entry%mci%allocate_instance (mci_work%mci)
        call mci_work%mci%init (mci_entry%mci)
     end if
   end subroutine mci_work_init
 
 @ %def mci_work_init
 @ Set parameters explicitly, either all at once, or separately for the
 structure-function and process parts.
 <<Process mci: mci work: TBP>>=
   procedure :: set => mci_work_set
   procedure :: set_x_strfun => mci_work_set_x_strfun
   procedure :: set_x_process => mci_work_set_x_process
 <<Process mci: procedures>>=
   subroutine mci_work_set (mci_work, x)
     class(mci_work_t), intent(inout) :: mci_work
     real(default), dimension(:), intent(in) :: x
     mci_work%x = x
   end subroutine mci_work_set
 
   subroutine mci_work_set_x_strfun (mci_work, x)
     class(mci_work_t), intent(inout) :: mci_work
     real(default), dimension(:), intent(in) :: x
     mci_work%x(1 : mci_work%config%n_par_sf) = x
   end subroutine mci_work_set_x_strfun
 
   subroutine mci_work_set_x_process (mci_work, x)
     class(mci_work_t), intent(inout) :: mci_work
     real(default), dimension(:), intent(in) :: x
     mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par) = x
   end subroutine mci_work_set_x_process
 
 @ %def mci_work_set
 @ %def mci_work_set_x_strfun
 @ %def mci_work_set_x_process
 @ Return the array of active components, i.e., those that correspond
 to the currently selected MC parameter set.
 <<Process mci: mci work: TBP>>=
   procedure :: get_active_components => mci_work_get_active_components
 <<Process mci: procedures>>=
   function mci_work_get_active_components (mci_work) result (i_component)
     class(mci_work_t), intent(in) :: mci_work
     integer, dimension(:), allocatable :: i_component
     allocate (i_component (size (mci_work%config%i_component)))
     i_component = mci_work%config%i_component
   end function mci_work_get_active_components
 
 @ %def mci_work_get_active_components
 @ Return the active parameters as a simple array with correct length.
 Do this separately for the structure-function parameters and the
 process parameters.
 <<Process mci: mci work: TBP>>=
   procedure :: get_x_strfun => mci_work_get_x_strfun
   procedure :: get_x_process => mci_work_get_x_process
 <<Process mci: procedures>>=
   pure function mci_work_get_x_strfun (mci_work) result (x)
     class(mci_work_t), intent(in) :: mci_work
     real(default), dimension(mci_work%config%n_par_sf) :: x
     x = mci_work%x(1 : mci_work%config%n_par_sf)
   end function mci_work_get_x_strfun
 
   pure function mci_work_get_x_process (mci_work) result (x)
     class(mci_work_t), intent(in) :: mci_work
     real(default), dimension(mci_work%config%n_par_phs) :: x
     x = mci_work%x(mci_work%config%n_par_sf + 1 : mci_work%config%n_par)
   end function mci_work_get_x_process
 
 @ %def mci_work_get_x_strfun
 @ %def mci_work_get_x_process
 @ Initialize and finalize event generation for the specified MCI
 entry.  This also resets the counter.
 <<Process mci: mci work: TBP>>=
   procedure :: init_simulation => mci_work_init_simulation
   procedure :: final_simulation => mci_work_final_simulation
 <<Process mci: procedures>>=
   subroutine mci_work_init_simulation (mci_work, safety_factor, keep_failed_events)
     class(mci_work_t), intent(inout) :: mci_work
     real(default), intent(in), optional :: safety_factor
     logical, intent(in), optional :: keep_failed_events
     call mci_work%mci%init_simulation (safety_factor)
     call mci_work%counter%reset ()
     if (present (keep_failed_events)) &
        mci_work%keep_failed_events = keep_failed_events
   end subroutine mci_work_init_simulation
 
   subroutine mci_work_final_simulation (mci_work)
     class(mci_work_t), intent(inout) :: mci_work
     call mci_work%mci%final_simulation ()
   end subroutine mci_work_final_simulation
 
 @ %def mci_work_init_simulation
 @ %def mci_work_final_simulation
 @ Counter.
 <<Process mci: mci work: TBP>>=
   procedure :: reset_counter => mci_work_reset_counter
   procedure :: record_call => mci_work_record_call
   procedure :: get_counter => mci_work_get_counter
 <<Process mci: procedures>>=
   subroutine mci_work_reset_counter (mci_work)
     class(mci_work_t), intent(inout) :: mci_work
     call mci_work%counter%reset ()
   end subroutine mci_work_reset_counter
 
   subroutine mci_work_record_call (mci_work, status)
     class(mci_work_t), intent(inout) :: mci_work
     integer, intent(in) :: status
     call mci_work%counter%record (status)
   end subroutine mci_work_record_call
 
   pure function mci_work_get_counter (mci_work) result (counter)
     class(mci_work_t), intent(in) :: mci_work
     type(process_counter_t) :: counter
     counter = mci_work%counter
   end function mci_work_get_counter
 
 @ %def mci_work_reset_counter
 @ %def mci_work_record_call
 @ %def mci_work_get_counter
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process component manager}
 <<[[pcm.f90]]>>=
 <<File header>>
 
 module pcm
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use constants, only: zero, two
   use diagnostics
   use lorentz
   use io_units, only: free_unit
   use os_interface
   use process_constants, only: process_constants_t
   use physics_defs
   use model_data, only: model_data_t
   use models, only: model_t
   use interactions, only: interaction_t
   use quantum_numbers, only: quantum_numbers_t, quantum_numbers_mask_t
   use flavors, only: flavor_t
   use variables, only: var_list_t
   use nlo_data, only: nlo_settings_t
   use mci_base, only: mci_t
   use phs_base, only: phs_config_t
   use mappings, only: mapping_defaults_t
   use phs_forests, only: phs_parameters_t
   use phs_fks, only: isr_kinematics_t, real_kinematics_t
   use phs_fks, only: phs_identifier_t
   use dispatch_fks, only: dispatch_fks_s
   use fks_regions, only: region_data_t
   use nlo_data, only: fks_template_t
   use phs_fks, only: phs_fks_generator_t
   use phs_fks, only: dalitz_plot_t
   use phs_fks, only: phs_fks_config_t, get_filtered_resonance_histories
   use dispatch_phase_space, only: dispatch_phs
   use process_libraries, only: process_component_def_t
   use real_subtraction, only: real_subtraction_t, soft_mismatch_t
   use real_subtraction, only: FIXED_ORDER_EVENTS, POWHEG
   use real_subtraction, only: real_partition_t, powheg_damping_simple_t
   use real_subtraction, only: real_partition_fixed_order_t
   use virtual, only: virtual_t
   use dglap_remnant, only: dglap_remnant_t
   use prc_threshold, only: threshold_def_t
   use resonances, only: resonance_history_t, resonance_history_set_t
   use nlo_data, only: FKS_DEFAULT, FKS_RESONANCES
   use blha_config, only: blha_master_t
   use blha_olp_interfaces, only: prc_blha_t
 
   use pcm_base
   use process_config
   use process_mci, only: process_mci_entry_t
   use process_mci, only: REAL_SINGULAR, REAL_FINITE
 
 <<Standard module head>>
 
 <<Pcm: public>>
 
 <<Pcm: types>>
 
 contains
 
 <<Pcm: procedures>>
 
 end module pcm
 @ %def pcm
 @
 \subsection{Default process component manager}
 This is the configuration object which has the duty of allocating the
 corresponding instance.  The default version is trivial.
 <<Pcm: public>>=
   public :: pcm_default_t
 <<Pcm: types>>=
   type, extends (pcm_t) :: pcm_default_t
    contains
    <<Pcm: pcm default: TBP>>
   end type pcm_default_t
 
 @ %def pcm_default_t
 <<Pcm: pcm default: TBP>>=
   procedure :: allocate_instance => pcm_default_allocate_instance
 <<Pcm: procedures>>=
   subroutine pcm_default_allocate_instance (pcm, instance)
     class(pcm_default_t), intent(in) :: pcm
     class(pcm_instance_t), intent(inout), allocatable :: instance
     allocate (pcm_instance_default_t :: instance)
   end subroutine pcm_default_allocate_instance
 
 @ %def pcm_default_allocate_instance
 @
 Finalizer: apply to core manager.
 <<Pcm: pcm default: TBP>>=
   procedure :: final => pcm_default_final
 <<Pcm: procedures>>=
   subroutine pcm_default_final (pcm)
     class(pcm_default_t), intent(inout) :: pcm
   end subroutine pcm_default_final
 
 @ %def pcm_default_final
 @
 <<Pcm: pcm default: TBP>>=
   procedure :: is_nlo => pcm_default_is_nlo
 <<Pcm: procedures>>=
   function pcm_default_is_nlo (pcm) result (is_nlo)
     logical :: is_nlo
     class(pcm_default_t), intent(in) :: pcm
     is_nlo = .false.
   end function pcm_default_is_nlo
 
 @ %def pcm_default_is_nlo
 @
 Initialize configuration data, using environment variables.
 <<Pcm: pcm default: TBP>>=
   procedure :: init => pcm_default_init
 <<Pcm: procedures>>=
   subroutine pcm_default_init (pcm, env, meta)
     class(pcm_default_t), intent(out) :: pcm
     type(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     pcm%has_pdfs = env%has_pdfs ()
     call pcm%set_blha_defaults &
          (env%has_polarized_beams (), env%get_var_list_ptr ())
     pcm%os_data = env%get_os_data ()
   end subroutine pcm_default_init
 
 @ %def pcm_default_init
 @
 <<Pcm: types>>=
   type, extends (pcm_instance_t) :: pcm_instance_default_t
   contains
   <<Pcm: pcm instance default: TBP>>
   end type pcm_instance_default_t
 
 @ %def pcm_instance_default_t
 @
 <<Pcm: pcm instance default: TBP>>=
   procedure :: final => pcm_instance_default_final
 <<Pcm: procedures>>=
   subroutine pcm_instance_default_final (pcm_instance)
     class(pcm_instance_default_t), intent(inout) :: pcm_instance
   end subroutine pcm_instance_default_final
 
 @ %def pcm_instance_default_final
 @
 \subsection{Implementations for the default manager}
 Categorize components.  Nothing to do here, all components are of Born type.
 <<Pcm: pcm default: TBP>>=
   procedure :: categorize_components => pcm_default_categorize_components
 <<Pcm: procedures>>=
   subroutine pcm_default_categorize_components (pcm, config)
     class(pcm_default_t), intent(inout) :: pcm
     type(process_config_data_t), intent(in) :: config
   end subroutine pcm_default_categorize_components
 
 @ %def pcm_default_categorize_components
 @
 \subsubsection{Phase-space configuration}
 Default setup for tree processes: a single phase-space configuration that is
 valid for all components.
 <<Pcm: pcm default: TBP>>=
   procedure :: init_phs_config => pcm_default_init_phs_config
 <<Pcm: procedures>>=
   subroutine pcm_default_init_phs_config &
        (pcm, phs_entry, meta, env, phs_par, mapping_defs)
     class(pcm_default_t), intent(inout) :: pcm
     type(process_phs_config_t), &
          dimension(:), allocatable, intent(out) :: phs_entry
     type(process_metadata_t), intent(in) :: meta
     type(process_environment_t), intent(in) :: env
     type(mapping_defaults_t), intent(in) :: mapping_defs
     type(phs_parameters_t), intent(in) :: phs_par
     allocate (phs_entry (1))
     allocate (pcm%i_phs_config (pcm%n_components), source=1)
     call dispatch_phs (phs_entry(1)%phs_config, &
          env%get_var_list_ptr (), &
          env%get_os_data (), &
          meta%id, &
          mapping_defs, phs_par)
   end subroutine pcm_default_init_phs_config
 
 @ %def pcm_default_init_phs_config
 @
 \subsubsection{Core management}
 The default component manager assigns one core per component.  We allocate and
 configure the core objects, using the process-component configuration data.
 <<Pcm: pcm default: TBP>>=
   procedure :: allocate_cores => pcm_default_allocate_cores
 <<Pcm: procedures>>=
   subroutine pcm_default_allocate_cores (pcm, config, core_entry)
     class(pcm_default_t), intent(inout) :: pcm
     type(process_config_data_t), intent(in) :: config
     type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
     type(process_component_def_t), pointer :: component_def
     integer :: i
     allocate (pcm%i_core (pcm%n_components), source = 0)
     pcm%n_cores = pcm%n_components
     allocate (core_entry (pcm%n_cores))
     do i = 1, pcm%n_cores
        pcm%i_core(i) = i
        core_entry(i)%i_component = i
        component_def => config%process_def%get_component_def_ptr (i)
        core_entry(i)%core_def => component_def%get_core_def_ptr ()
        core_entry(i)%active = component_def%can_be_integrated ()
     end do
   end subroutine pcm_default_allocate_cores
 
 @ %def pcm_default_allocate_cores
 @ Extra code is required for certain core types (threshold) or if BLHA uses an
 external OLP (Born only, this case) for getting its matrix elements.
 <<Pcm: pcm default: TBP>>=
   procedure :: prepare_any_external_code => &
        pcm_default_prepare_any_external_code
 <<Pcm: procedures>>=
   subroutine pcm_default_prepare_any_external_code &
        (pcm, core_entry, i_core, libname, model, var_list)
     class(pcm_default_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     integer, intent(in) :: i_core
     type(string_t), intent(in) :: libname
     type(model_data_t), intent(in), target :: model
     type(var_list_t), intent(in) :: var_list
     if (core_entry%active) then
        associate (core => core_entry%core)
          if (core%needs_external_code ()) then
             call core%prepare_external_code &
                  (core%data%flv_state, &
                  var_list, pcm%os_data, libname, model, i_core, .false.)
          end if
          call core%set_equivalent_flv_hel_indices ()
        end associate
     end if
   end subroutine pcm_default_prepare_any_external_code
 
 @ %def pcm_default_prepare_any_external_code
 @ Allocate and configure the BLHA record for a specific core, assuming that
 the core type requires it.  In the default case, this is a Born
 configuration.
 <<Pcm: pcm default: TBP>>=
   procedure :: setup_blha => pcm_default_setup_blha
 <<Pcm: procedures>>=
   subroutine pcm_default_setup_blha (pcm, core_entry)
     class(pcm_default_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     allocate (core_entry%blha_config, source = pcm%blha_defaults)
     call core_entry%blha_config%set_born ()
   end subroutine pcm_default_setup_blha
 
 @ %def pcm_default_setup_blha
 @ Apply the configuration, using [[pcm]] data.
 <<Pcm: pcm default: TBP>>=
   procedure :: prepare_blha_core => pcm_default_prepare_blha_core
 <<Pcm: procedures>>=
   subroutine pcm_default_prepare_blha_core (pcm, core_entry, model)
     class(pcm_default_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     class(model_data_t), intent(in), target :: model
     integer :: n_in
     integer :: n_legs
     integer :: n_flv
     integer :: n_hel
     select type (core => core_entry%core)
     class is (prc_blha_t)
        associate (blha_config => core_entry%blha_config)
          n_in = core%data%n_in
          n_legs = core%data%get_n_tot ()
          n_flv = core%data%n_flv
          n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model)
          call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel)
          call core%init_driver (pcm%os_data)
        end associate
     end select
   end subroutine pcm_default_prepare_blha_core
 
 @ %def pcm_default_prepare_blha_core
 @ Read the method settings from the variable list and store them in the BLHA
 master.  This version: no NLO flag.
 <<Pcm: pcm default: TBP>>=
   procedure :: set_blha_methods => pcm_default_set_blha_methods
 <<Pcm: procedures>>=
   subroutine pcm_default_set_blha_methods (pcm, blha_master, var_list)
     class(pcm_default_t), intent(inout) :: pcm
     type(blha_master_t), intent(inout) :: blha_master
     type(var_list_t), intent(in) :: var_list
     call blha_master%set_methods (.false., var_list)
   end subroutine pcm_default_set_blha_methods
 
 @ %def pcm_default_set_blha_methods
 @ Produce the LO and NLO flavor-state tables (as far as available), as
 appropriate for BLHA configuration.
 
 The default version looks at the first process core only, to get the Born
 data.  (Multiple cores are thus unsupported.)  The NLO flavor table is left
 unallocated.
 <<Pcm: pcm default: TBP>>=
   procedure :: get_blha_flv_states => pcm_default_get_blha_flv_states
 <<Pcm: procedures>>=
   subroutine pcm_default_get_blha_flv_states &
        (pcm, core_entry, flv_born, flv_real)
     class(pcm_default_t), intent(in) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     integer, dimension(:,:), allocatable, intent(out) :: flv_born
     integer, dimension(:,:), allocatable, intent(out) :: flv_real
     flv_born = core_entry(1)%core%data%flv_state
   end subroutine pcm_default_get_blha_flv_states
 
 @ %def pcm_default_get_blha_flv_states
 @ Allocate and configure the MCI (multi-channel integrator) records.  There is
 one record per active process component.  Second procedure: call the MCI
 dispatcher with default-setup arguments.
 <<Pcm: pcm default: TBP>>=
   procedure :: setup_mci => pcm_default_setup_mci
   procedure :: call_dispatch_mci => pcm_default_call_dispatch_mci
 <<Pcm: procedures>>=
   subroutine pcm_default_setup_mci (pcm, mci_entry)
     class(pcm_default_t), intent(inout) :: pcm
     type(process_mci_entry_t), &
          dimension(:), allocatable, intent(out) :: mci_entry
     class(mci_t), allocatable :: mci_template
     integer :: i, i_mci
     pcm%n_mci = count (pcm%component_active)
     allocate (pcm%i_mci (pcm%n_components), source = 0)
     i_mci = 0
     do i = 1, pcm%n_components
        if (pcm%component_active(i)) then
           i_mci = i_mci + 1
           pcm%i_mci(i) = i_mci
        end if
     end do
     allocate (mci_entry (pcm%n_mci))
   end subroutine pcm_default_setup_mci
 
   subroutine pcm_default_call_dispatch_mci (pcm, &
           dispatch_mci, var_list, process_id, mci_template)
     class(pcm_default_t), intent(inout) :: pcm
     procedure(dispatch_mci_proc) :: dispatch_mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     class(mci_t), allocatable, intent(out) :: mci_template
     call dispatch_mci (mci_template, var_list, process_id)
   end subroutine pcm_default_call_dispatch_mci
 
 @ %def pcm_default_setup_mci
 @ %def pcm_default_call_dispatch_mci
 @ Nothing left to do for the default algorithm.
 <<Pcm: pcm default: TBP>>=
   procedure :: complete_setup => pcm_default_complete_setup
 <<Pcm: procedures>>=
   subroutine pcm_default_complete_setup (pcm, core_entry, component, model)
     class(pcm_default_t), intent(inout) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     type(process_component_t), dimension(:), intent(inout) :: component
     type(model_t), intent(in), target :: model
   end subroutine pcm_default_complete_setup
 
 @ %def pcm_default_complete_setup
 @
 \subsubsection{Component management}
 Initialize a single component.  We require all process-configuration blocks,
 and specific templates for the phase-space and integrator configuration.
 
 We also provide the current component index [[i]] and the [[active]] flag.
 
 In the default mode, all components are marked as master components.
 <<Pcm: pcm default: TBP>>=
   procedure :: init_component => pcm_default_init_component
 <<Pcm: procedures>>=
   subroutine pcm_default_init_component &
           (pcm, component, i, active, &
           phs_config, env, meta, config)
     class(pcm_default_t), intent(in) :: pcm
     type(process_component_t), intent(out) :: component
     integer, intent(in) :: i
     logical, intent(in) :: active
     class(phs_config_t), allocatable, intent(in) :: phs_config
     type(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     type(process_config_data_t), intent(in) :: config
     call component%init (i, &
          env, meta, config, &
          active, &
          phs_config)
     component%component_type = COMP_MASTER
   end subroutine pcm_default_init_component
 
 @ %def pcm_default_init_component
 @
 \subsection{NLO process component manager}
 The NLO-aware version of the process-component manager.
 
 This is the configuration object, which has the duty of allocating the
 corresponding instance.  This is the nontrivial NLO version.
 <<Pcm: public>>=
   public :: pcm_nlo_t
 <<Pcm: types>>=
   type, extends (pcm_t) :: pcm_nlo_t
      type(string_t) :: id
      logical :: combined_integration = .false.
      logical :: vis_fks_regions = .false.
      integer, dimension(:), allocatable :: nlo_type
      integer, dimension(:), allocatable :: nlo_type_core
      integer, dimension(:), allocatable :: component_type
      integer :: i_born = 0
      integer :: i_real = 0
      integer :: i_sub = 0
      type(nlo_settings_t) :: settings
      type(region_data_t) :: region_data
      logical :: use_real_partition = .false.
      real(default) :: real_partition_scale = 0
      class(real_partition_t), allocatable :: real_partition
      type(dalitz_plot_t) :: dalitz_plot
      type(quantum_numbers_t), dimension(:,:), allocatable :: qn_real, qn_born
   contains
   <<Pcm: pcm nlo: TBP>>
   end type pcm_nlo_t
 
 @ %def pcm_nlo_t
 @
 Initialize configuration data, using environment variables.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init => pcm_nlo_init
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init (pcm, env, meta)
     class(pcm_nlo_t), intent(out) :: pcm
     type(process_metadata_t), intent(in) :: meta
     type(process_environment_t), intent(in) :: env
     type(var_list_t), pointer :: var_list
     type(fks_template_t) :: fks_template
     pcm%id = meta%id
     pcm%has_pdfs = env%has_pdfs ()
     var_list => env%get_var_list_ptr ()
     call dispatch_fks_s (fks_template, var_list)
     call pcm%settings%init (var_list, fks_template)
     pcm%combined_integration = &
          var_list%get_lval (var_str ('?combined_nlo_integration'))
     pcm%use_real_partition = &
          var_list%get_lval (var_str ("?nlo_use_real_partition"))
     pcm%real_partition_scale = &
          var_list%get_rval (var_str ("real_partition_scale"))
     pcm%vis_fks_regions = &
          var_list%get_lval (var_str ("?vis_fks_regions"))
     call pcm%set_blha_defaults &
          (env%has_polarized_beams (), env%get_var_list_ptr ())
     pcm%os_data = env%get_os_data ()
   end subroutine pcm_nlo_init
 
 @ %def pcm_nlo_init
 @ Init/rewrite NLO settings without the FKS template.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init_nlo_settings => pcm_nlo_init_nlo_settings
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init_nlo_settings (pcm, var_list)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(var_list_t), intent(in), target :: var_list
     call pcm%settings%init (var_list)
   end subroutine pcm_nlo_init_nlo_settings
 
 @ %def pcm_nlo_init_nlo_settings
 @
 As appropriate for the NLO/FKS algorithm, the category defined by the
 process, is called [[nlo_type]].  We refine this by setting the component
 category [[component_type]] separately.
 
 The component types [[COMP_MISMATCH]], [[COMP_PDF]], [[COMP_SUB]] are set only
 if the algorithm uses combined integration.  Otherwise, they are set to
 [[COMP_DEFAULT]].
 
 The component type [[COMP_REAL]] is further distinguished between
 [[COMP_REAL_SING]] or [[COMP_REAL_FIN]], if the algorithm uses real
 partitions.  The former acts as a reference component for the latter, and we
 always assume that it is the first real component.
 
 Each component is assigned its own core.  Exceptions: the finite-real
 component gets the same core as the singular-real component.  The mismatch
 component gets the same core as the subtraction component.
 
 TODO wk 2018: this convention for real components can be improved.  Check whether
 all component types should be assigned, not just for combined
 integration.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: categorize_components => pcm_nlo_categorize_components
 <<Pcm: procedures>>=
   subroutine pcm_nlo_categorize_components (pcm, config)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_config_data_t), intent(in) :: config
     type(process_component_def_t), pointer :: component_def
     integer :: i
     allocate (pcm%nlo_type (pcm%n_components), source = COMPONENT_UNDEFINED)
     allocate (pcm%component_type (pcm%n_components), source = COMP_DEFAULT)
     do i = 1, pcm%n_components
        component_def => config%process_def%get_component_def_ptr (i)
        pcm%nlo_type(i) = component_def%get_nlo_type ()
        if (pcm%combined_integration) then
           select case (pcm%nlo_type(i))
           case (BORN)
              pcm%i_born = i
              pcm%component_type(i) = COMP_MASTER
           case (NLO_REAL)
              pcm%component_type(i) = COMP_REAL
           case (NLO_VIRTUAL)
              pcm%component_type(i) = COMP_VIRT
           case (NLO_MISMATCH)
              pcm%component_type(i) = COMP_MISMATCH
           case (NLO_DGLAP)
              pcm%component_type(i) = COMP_PDF
           case (NLO_SUBTRACTION)
              pcm%component_type(i) = COMP_SUB
              pcm%i_sub = i
           end select
        else
           select case (pcm%nlo_type(i))
           case (BORN)
              pcm%i_born = i
              pcm%component_type(i) = COMP_MASTER
           case (NLO_REAL)
              pcm%component_type(i) = COMP_REAL
           case (NLO_VIRTUAL)
              pcm%component_type(i) = COMP_VIRT
           case (NLO_MISMATCH)
              pcm%component_type(i) = COMP_MISMATCH
           case (NLO_SUBTRACTION)
              pcm%i_sub = i
           end select
        end if
     end do
     call refine_real_type ( &
          pack ([(i, i=1, pcm%n_components)], &
          pcm%component_type==COMP_REAL))
   contains
     subroutine refine_real_type (i_real)
       integer, dimension(:), intent(in) :: i_real
       pcm%i_real = i_real(1)
       if (pcm%use_real_partition) then
          pcm%component_type (i_real(1)) = COMP_REAL_SING
          pcm%component_type (i_real(2:)) = COMP_REAL_FIN
       end if
     end subroutine refine_real_type
   end subroutine pcm_nlo_categorize_components
 
 @ %def pcm_nlo_categorize_components
 @
 \subsubsection{Phase-space initial configuration}
 Setup for the NLO/PHS processes: two phase-space configurations, (1)
 Born/wood, (2) real correction/FKS.  All components use either one of these
 two configurations.
 
 TODO wk 2018: The [[first_real_component]] identifier is really ugly.  Nothing should
 rely on the ordering.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init_phs_config => pcm_nlo_init_phs_config
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init_phs_config &
        (pcm, phs_entry, meta, env, phs_par, mapping_defs)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_phs_config_t), &
          dimension(:), allocatable, intent(out) :: phs_entry
     type(process_metadata_t), intent(in) :: meta
     type(process_environment_t), intent(in) :: env
     type(mapping_defaults_t), intent(in) :: mapping_defs
     type(phs_parameters_t), intent(in) :: phs_par
     integer :: i
     logical :: first_real_component
     allocate (phs_entry (2))
     call dispatch_phs (phs_entry(1)%phs_config, &
          env%get_var_list_ptr (), &
          env%get_os_data (), &
          meta%id, &
          mapping_defs, phs_par, &
          var_str ("wood"))
     call dispatch_phs (phs_entry(2)%phs_config, &
          env%get_var_list_ptr (), &
          env%get_os_data (), &
          meta%id, &
          mapping_defs, phs_par, &
          var_str ("fks"))
     allocate (pcm%i_phs_config (pcm%n_components), source=0)
     first_real_component = .true.
     do i = 1, pcm%n_components
        select case (pcm%nlo_type(i))
        case (BORN, NLO_VIRTUAL, NLO_SUBTRACTION)
           pcm%i_phs_config(i) = 1
        case (NLO_REAL)
           if (first_real_component) then
              pcm%i_phs_config(i) = 2
              if (pcm%use_real_partition)  first_real_component = .false.
           else
              pcm%i_phs_config(i) = 1
           end if
        case (NLO_MISMATCH, NLO_DGLAP, GKS)
           pcm%i_phs_config(i) = 2
        end select
     end do
   end subroutine pcm_nlo_init_phs_config
 
 @ %def pcm_nlo_init_phs_config
 @
 \subsubsection{Core management}
 Allocate the core (matrix-element interface) objects that we will need for
 evaluation.  Every component gets an associated core, except for the
 real-finite and mismatch components (if any).  Those components are associated
 with their previous corresponding real-singular and subtraction cores,
 respectively.
 
 After cores are allocated, configure the region-data block that is maintained
 by the NLO process-component manager.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: allocate_cores => pcm_nlo_allocate_cores
 <<Pcm: procedures>>=
   subroutine pcm_nlo_allocate_cores (pcm, config, core_entry)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_config_data_t), intent(in) :: config
     type(core_entry_t), dimension(:), allocatable, intent(out) :: core_entry
         type(process_component_def_t), pointer :: component_def
     integer :: i, i_core
     allocate (pcm%i_core (pcm%n_components), source = 0)
     pcm%n_cores = pcm%n_components &
          - count (pcm%component_type(:) == COMP_REAL_FIN) &
          - count (pcm%component_type(:) == COMP_MISMATCH)
     allocate (core_entry (pcm%n_cores))
     allocate (pcm%nlo_type_core (pcm%n_cores), source = BORN)
     i_core = 0
     do i = 1, pcm%n_components
        select case (pcm%component_type(i))
        case default
           i_core = i_core + 1
           pcm%i_core(i) = i_core
           pcm%nlo_type_core(i_core) = pcm%nlo_type(i)
           core_entry(i_core)%i_component = i
           component_def => config%process_def%get_component_def_ptr (i)
           core_entry(i_core)%core_def => component_def%get_core_def_ptr ()
           select case (pcm%nlo_type(i))
           case default
              core_entry(i)%active = component_def%can_be_integrated ()
           case (NLO_REAL, NLO_SUBTRACTION)
              core_entry(i)%active = .true.
           end select
        case (COMP_REAL_FIN)
           pcm%i_core(i) = pcm%i_core(pcm%i_real)
        case (COMP_MISMATCH)
           pcm%i_core(i) = pcm%i_core(pcm%i_sub)
        end select
     end do
   end subroutine pcm_nlo_allocate_cores
 
 @ %def pcm_nlo_allocate_cores
 @ Extra code is required for certain core types (threshold) or if BLHA uses an
 external OLP for getting its matrix elements.  OMega matrix elements, by
 definition, do not need extra code.  NLO-virtual or subtraction
 matrix elements always need extra code.
 
 More precisely: for the Born and virtual matrix element, the extra code is
 accessed only if the component is active.  The radiation (real) and the
 subtraction corrections (singular and finite), extra code is accessed in any
 case.
 
 The flavor state is taken from the [[region_data]] table in the [[pcm]]
 record.  We use the Born and real flavor-state tables as appropriate.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: prepare_any_external_code => &
        pcm_nlo_prepare_any_external_code
 <<Pcm: procedures>>=
   subroutine pcm_nlo_prepare_any_external_code &
        (pcm, core_entry, i_core, libname, model, var_list)
     class(pcm_nlo_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     integer, intent(in) :: i_core
     type(string_t), intent(in) :: libname
     type(model_data_t), intent(in), target :: model
     type(var_list_t), intent(in) :: var_list
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     integer :: i
     call pcm%region_data%get_all_flv_states (flv_born, flv_real)
     if (core_entry%active) then
        associate (core => core_entry%core)
          if (core%needs_external_code ()) then
             select case (pcm%nlo_type (core_entry%i_component))
             case default
                call core%data%set_flv_state (flv_born)
             case (NLO_REAL)
                call core%data%set_flv_state (flv_real)
             end select
             call core%prepare_external_code &
                  (core%data%flv_state, &
                  var_list, pcm%os_data, libname, model, i_core, .true.)
          end if
          call core%set_equivalent_flv_hel_indices ()
        end associate
     end if
   end subroutine pcm_nlo_prepare_any_external_code
 
 @ %def pcm_nlo_prepare_any_external_code
 @ Allocate and configure the BLHA record for a specific core, assuming that
 the core type requires it.  The configuration depends on the NLO type of the
 core.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_blha => pcm_nlo_setup_blha
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_blha (pcm, core_entry)
     class(pcm_nlo_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     allocate (core_entry%blha_config, source = pcm%blha_defaults)
     select case (pcm%nlo_type(core_entry%i_component))
     case (BORN)
        call core_entry%blha_config%set_born ()
     case (NLO_REAL)
        call core_entry%blha_config%set_real_trees ()
     case (NLO_VIRTUAL)
        call core_entry%blha_config%set_loop ()
     case (NLO_SUBTRACTION)
        call core_entry%blha_config%set_subtraction ()
        call core_entry%blha_config%set_internal_color_correlations ()
     case (NLO_DGLAP)
        call core_entry%blha_config%set_dglap ()
     end select
   end subroutine pcm_nlo_setup_blha
 
 @ %def pcm_nlo_setup_blha
 @ After phase-space configuration data and core entries are available, we fill
 tables and compute the remaining NLO data that will steer the integration
 and subtraction algorithm.
 
 There are three parts: recognize a threshold-type process core (if it exists),
 prepare the region-data tables (always), and prepare for real partitioning (if
 requested).
 
 The real-component phase space acts as the source for resonance-history
 information, required for the region data.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: complete_setup => pcm_nlo_complete_setup
 <<Pcm: procedures>>=
   subroutine pcm_nlo_complete_setup (pcm, core_entry, component, model)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     type(process_component_t), dimension(:), intent(inout) :: component
     type(model_t), intent(in), target :: model
     integer :: i
     call pcm%handle_threshold_core (core_entry)
     call pcm%setup_region_data &
          (core_entry, component(pcm%i_real)%phs_config, model)
     call pcm%setup_real_partition ()
   end subroutine pcm_nlo_complete_setup
 
 @ %def pcm_nlo_complete_setup
 @ Apply the BLHA configuration to a core object, using the region data from
 [[pcm]] for determining the particle content.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: prepare_blha_core => pcm_nlo_prepare_blha_core
 <<Pcm: procedures>>=
   subroutine pcm_nlo_prepare_blha_core (pcm, core_entry, model)
     class(pcm_nlo_t), intent(in) :: pcm
     type(core_entry_t), intent(inout) :: core_entry
     class(model_data_t), intent(in), target :: model
     integer :: n_in
     integer :: n_legs
     integer :: n_flv
     integer :: n_hel
     select type (core => core_entry%core)
     class is (prc_blha_t)
        associate (blha_config => core_entry%blha_config)
          n_in = core%data%n_in
          select case (pcm%nlo_type(core_entry%i_component))
          case (NLO_REAL)
             n_legs = pcm%region_data%get_n_legs_real ()
             n_flv = pcm%region_data%get_n_flv_real ()
          case default
             n_legs = pcm%region_data%get_n_legs_born ()
             n_flv = pcm%region_data%get_n_flv_born ()
          end select
          n_hel = blha_config%get_n_hel (core%data%flv_state (1:n_in,1), model)
          call core%init_blha (blha_config, n_in, n_legs, n_flv, n_hel)
          call core%init_driver (pcm%os_data)
        end associate
     end select
   end subroutine pcm_nlo_prepare_blha_core
 
 @ %def pcm_nlo_prepare_blha_core
 @ Read the method settings from the variable list and store them in the BLHA
 master.  This version: NLO flag set.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: set_blha_methods => pcm_nlo_set_blha_methods
 <<Pcm: procedures>>=
   subroutine pcm_nlo_set_blha_methods (pcm, blha_master, var_list)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(blha_master_t), intent(inout) :: blha_master
     type(var_list_t), intent(in) :: var_list
     call blha_master%set_methods (.true., var_list)
     call pcm%blha_defaults%set_loop_method (blha_master)
   end subroutine pcm_nlo_set_blha_methods
 
 @ %def pcm_nlo_set_blha_methods
 @ Produce the LO and NLO flavor-state tables (as far as available), as
 appropriate for BLHA configuration.
 
 The NLO version copies the tables from the region data inside [[pcm]].  The
 core array is not needed.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_blha_flv_states => pcm_nlo_get_blha_flv_states
 <<Pcm: procedures>>=
   subroutine pcm_nlo_get_blha_flv_states &
        (pcm, core_entry, flv_born, flv_real)
     class(pcm_nlo_t), intent(in) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     integer, dimension(:,:), allocatable, intent(out) :: flv_born
     integer, dimension(:,:), allocatable, intent(out) :: flv_real
     call pcm%region_data%get_all_flv_states (flv_born, flv_real)
   end subroutine pcm_nlo_get_blha_flv_states
 
 @ %def pcm_nlo_get_blha_flv_states
 @ Allocate and configure the MCI (multi-channel integrator) records.  The
 relation depends on the [[combined_integration]] setting.  If we integrate
 components separately, each component gets its own record, except for the
 subtraction component.  If we do the combination, there is one record for
 the master (Born) component and a second one for the real-finite component, if
 present.
 
 Each entry acquires some NLO-specific initialization.  Generic configuration
 follows later.
 
 Second procedure: call the MCI dispatcher with NLO-setup arguments.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_mci => pcm_nlo_setup_mci
   procedure :: call_dispatch_mci => pcm_nlo_call_dispatch_mci
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_mci (pcm, mci_entry)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_mci_entry_t), &
          dimension(:), allocatable, intent(out) :: mci_entry
     class(mci_t), allocatable :: mci_template
     integer :: i, i_mci
     if (pcm%combined_integration) then
        pcm%n_mci = 1 &
             + count (pcm%component_active(:) &
             &        .and. pcm%component_type(:) == COMP_REAL_FIN)
        allocate (pcm%i_mci (pcm%n_components), source = 0)
        do i = 1, pcm%n_components
           if (pcm%component_active(i)) then
              select case (pcm%component_type(i))
              case (COMP_MASTER)
                 pcm%i_mci(i) = 1
              case (COMP_REAL_FIN)
                 pcm%i_mci(i) = 2
              end select
           end if
        end do
     else
        pcm%n_mci = count (pcm%component_active(:) &
             &             .and. pcm%nlo_type(:) /= NLO_SUBTRACTION)
        allocate (pcm%i_mci (pcm%n_components), source = 0)
        i_mci = 0
        do i = 1, pcm%n_components
           if (pcm%component_active(i)) then
              select case (pcm%nlo_type(i))
              case default
                 i_mci = i_mci + 1
                 pcm%i_mci(i) = i_mci
              case (NLO_SUBTRACTION)
              end select
           end if
        end do
     end if
     allocate (mci_entry (pcm%n_mci))
     mci_entry(:)%combined_integration = pcm%combined_integration
     if (pcm%use_real_partition) then
        do i = 1, pcm%n_components
           i_mci = pcm%i_mci(i)
           if (i_mci > 0) then
              select case (pcm%component_type(i))
              case (COMP_REAL_FIN)
                 mci_entry(i_mci)%real_partition_type = REAL_FINITE
              case default
                 mci_entry(i_mci)%real_partition_type = REAL_SINGULAR
              end select
           end if
        end do
     end if
   end subroutine pcm_nlo_setup_mci
 
   subroutine pcm_nlo_call_dispatch_mci (pcm, &
           dispatch_mci, var_list, process_id, mci_template)
     class(pcm_nlo_t), intent(inout) :: pcm
     procedure(dispatch_mci_proc) :: dispatch_mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     class(mci_t), allocatable, intent(out) :: mci_template
     call dispatch_mci (mci_template, var_list, process_id, is_nlo = .true.)
   end subroutine pcm_nlo_call_dispatch_mci
 
 @ %def pcm_nlo_setup_mci
 @ %def pcm_nlo_call_dispatch_mci
 @ Check for a threshold core and adjust the configuration accordingly, before
 singular region data are considered.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: handle_threshold_core => pcm_nlo_handle_threshold_core
 <<Pcm: procedures>>=
   subroutine pcm_nlo_handle_threshold_core (pcm, core_entry)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     integer :: i
     do i = 1, size (core_entry)
        select type (core => core_entry(i)%core_def)
        type is (threshold_def_t)
           pcm%settings%factorization_mode = FACTORIZATION_THRESHOLD
           return
        end select
     end do
   end subroutine pcm_nlo_handle_threshold_core
 
 @ %def pcm_nlo_handle_threshold_core
 @ Configure the singular-region tables based on the process data for the Born
 and Real (singular) cores, using also the appropriate FKS phase-space
 configuration object.
 
 In passing, we may create a table of resonance histories that are relevant for
 the singular-region configuration.
 
 TODO wk 2018: check whether [[phs_entry]] needs to be intent(inout).
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_region_data => pcm_nlo_setup_region_data
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_region_data (pcm, core_entry, phs_config, model)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(core_entry_t), dimension(:), intent(in) :: core_entry
     class(phs_config_t), intent(inout) :: phs_config
     type(model_t), intent(in), target :: model
     type(process_constants_t) :: data_born, data_real
     integer, dimension (:,:), allocatable :: flavor_born, flavor_real
     type(resonance_history_t), dimension(:), allocatable :: resonance_histories
     type(var_list_t), pointer :: var_list
     logical :: success
     data_born = core_entry(pcm%i_core(pcm%i_born))%core%data
     data_real = core_entry(pcm%i_core(pcm%i_real))%core%data
     call data_born%get_flv_state (flavor_born)
     call data_real%get_flv_state (flavor_real)
     call pcm%region_data%init &
          (data_born%n_in, model, flavor_born, flavor_real, &
          pcm%settings%nlo_correction_type)
     associate (template => pcm%settings%fks_template)
       if (template%mapping_type == FKS_RESONANCES) then
          select type (phs_config)
          type is (phs_fks_config_t)
             call get_filtered_resonance_histories (phs_config, &
                  data_born%n_in, flavor_born, model, &
                  template%excluded_resonances, &
                  resonance_histories, success)
          end select
          if (.not. success) template%mapping_type = FKS_DEFAULT
       end if
       call pcm%region_data%setup_fks_mappings (template, data_born%n_in)
 !!! Check again, mapping_type might have changed
       if (template%mapping_type == FKS_RESONANCES) then
          call pcm%region_data%set_resonance_mappings (resonance_histories)
          call pcm%region_data%init_resonance_information ()
          pcm%settings%use_resonance_mappings = .true.
       end if
     end associate
     if (pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
        call pcm%region_data%set_isr_pseudo_regions ()
        call pcm%region_data%split_up_interference_regions_for_threshold ()
     end if
     call pcm%region_data%compute_number_of_phase_spaces ()
     call pcm%region_data%set_i_phs_to_i_con ()
     call pcm%region_data%write_to_file &
          (pcm%id, pcm%vis_fks_regions, pcm%os_data)
     if (debug_active (D_SUBTRACTION)) &
          call pcm%region_data%check_consistency (.true.)
   end subroutine pcm_nlo_setup_region_data
 
 @ %def pcm_nlo_setup_region_data
 @ After region data are set up, we allocate and configure the
 [[real_partition]] objects, if requested.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_real_partition => pcm_nlo_setup_real_partition
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_real_partition (pcm)
     class(pcm_nlo_t), intent(inout) :: pcm
     if (pcm%use_real_partition) then
        if (.not. allocated (pcm%real_partition)) then
           allocate (real_partition_fixed_order_t :: pcm%real_partition)
           select type (partition => pcm%real_partition)
           type is (real_partition_fixed_order_t)
              call pcm%region_data%get_all_ftuples (partition%fks_pairs)
              partition%scale = pcm%real_partition_scale
           end select
        end if
     end if
   end subroutine pcm_nlo_setup_real_partition
 
 @ %def pcm_nlo_setup_real_partition
 @
 Initialize a single component.  We require all process-configuration blocks,
 and specific templates for the phase-space and integrator configuration.
 
 We also provide the current component index [[i]] and the [[active]] flag.
 For a subtraction component, the [[active]] flag is overridden.
 
 In the nlo mode, the component types have been determined before.
 
 TODO wk 2018: the component type need not be stored in the component; we may remove
 this when everything is controlled by [[pcm]].
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init_component => pcm_nlo_init_component
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init_component &
           (pcm, component, i, active, &
           phs_config, env, meta, config)
     class(pcm_nlo_t), intent(in) :: pcm
     type(process_component_t), intent(out) :: component
     integer, intent(in) :: i
     logical, intent(in) :: active
     class(phs_config_t), allocatable, intent(in) :: phs_config
     type(process_environment_t), intent(in) :: env
     type(process_metadata_t), intent(in) :: meta
     type(process_config_data_t), intent(in) :: config
     logical :: activate
     select case (pcm%nlo_type(i))
     case default;            activate = active
     case (NLO_SUBTRACTION);  activate = .false.
     end select
     call component%init (i, &
          env, meta, config, &
          activate, &
          phs_config)
     component%component_type = pcm%component_type(i)
   end subroutine pcm_nlo_init_component
 
 @ %def pcm_nlo_init_component
 @
 Override the base method: record the active components in the PCM object, and
 report inactive components (except for the subtraction component).
 <<Pcm: pcm nlo: TBP>>=
   procedure :: record_inactive_components => pcm_nlo_record_inactive_components
 <<Pcm: procedures>>=
   subroutine pcm_nlo_record_inactive_components (pcm, component, meta)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(process_component_t), dimension(:), intent(in) :: component
     type(process_metadata_t), intent(inout) :: meta
     integer :: i
     pcm%component_active = component%active
     do i = 1, pcm%n_components
        select case (pcm%nlo_type(i))
        case (NLO_SUBTRACTION)
        case default
           if (.not. component(i)%active)  call meta%deactivate_component (i)
        end select
     end do
   end subroutine pcm_nlo_record_inactive_components
 
 @ %def pcm_nlo_record_inactive_components
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: core_is_radiation => pcm_nlo_core_is_radiation
 <<Pcm: procedures>>=
   function pcm_nlo_core_is_radiation (pcm, i_core) result (is_rad)
     logical :: is_rad
     class(pcm_nlo_t), intent(in) :: pcm
     integer, intent(in) :: i_core
     is_rad = pcm%nlo_type(i_core) == NLO_REAL ! .and. .not. pcm%cm%sub(i_core)
   end function pcm_nlo_core_is_radiation
 
 @ %def pcm_nlo_core_is_radiation
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_n_flv_born => pcm_nlo_get_n_flv_born
 <<Pcm: procedures>>=
   function pcm_nlo_get_n_flv_born (pcm_nlo) result (n_flv)
     integer :: n_flv
     class(pcm_nlo_t), intent(in) :: pcm_nlo
     n_flv = pcm_nlo%region_data%n_flv_born
   end function pcm_nlo_get_n_flv_born
 
 @ %def pcm_nlo_get_n_flv_born
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_n_flv_real => pcm_nlo_get_n_flv_real
 <<Pcm: procedures>>=
   function pcm_nlo_get_n_flv_real (pcm_nlo) result (n_flv)
     integer :: n_flv
     class(pcm_nlo_t), intent(in) :: pcm_nlo
     n_flv = pcm_nlo%region_data%n_flv_real
   end function pcm_nlo_get_n_flv_real
 
 @ %def pcm_nlo_get_n_flv_real
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_n_alr => pcm_nlo_get_n_alr
 <<Pcm: procedures>>=
   function pcm_nlo_get_n_alr (pcm) result (n_alr)
     integer :: n_alr
     class(pcm_nlo_t), intent(in) :: pcm
     n_alr = pcm%region_data%n_regions
   end function pcm_nlo_get_n_alr
 
 @ %def pcm_nlo_get_n_alr
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_flv_states => pcm_nlo_get_flv_states
 <<Pcm: procedures>>=
   function pcm_nlo_get_flv_states (pcm, born) result (flv)
     integer, dimension(:,:), allocatable :: flv
     class(pcm_nlo_t), intent(in) :: pcm
     logical, intent(in) :: born
     if (born) then
        flv = pcm%region_data%get_flv_states_born ()
     else
        flv = pcm%region_data%get_flv_states_real ()
     end if
   end function pcm_nlo_get_flv_states
 
 @ %def pcm_nlo_get_flv_states
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_qn => pcm_nlo_get_qn
 <<Pcm: procedures>>=
   function pcm_nlo_get_qn (pcm, born) result (qn)
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     class(pcm_nlo_t), intent(in) :: pcm
     logical, intent(in) :: born
     if (born) then
        qn = pcm%qn_born
     else
        qn = pcm%qn_real
     end if
   end function pcm_nlo_get_qn
 
 @ %def pcm_nlo_get_qn
 @ Check if there are massive emitters. Since the mass-structure of all
 underlying Born configurations have to be the same (\textbf{This does
 not have to be the case when different components are generated at LO})
 , we just use the first one to determine this.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: has_massive_emitter => pcm_nlo_has_massive_emitter
 <<Pcm: procedures>>=
   function pcm_nlo_has_massive_emitter (pcm) result (val)
     logical :: val
     class(pcm_nlo_t), intent(in) :: pcm
     integer :: i
     val = .false.
     associate (reg_data => pcm%region_data)
        do i = reg_data%n_in + 1, reg_data%n_legs_born
           if (any (i == reg_data%emitters)) &
              val = val .or. reg_data%flv_born(1)%massive(i)
        end do
     end associate
   end function pcm_nlo_has_massive_emitter
 
 @ %def pcm_nlo_has_massive_emitter
 @ Returns an array which specifies if the particle at position [[i]] is massive.
 <<Pcm: pcm nlo: TBP>>=
   procedure :: get_mass_info => pcm_nlo_get_mass_info
 <<Pcm: procedures>>=
   function pcm_nlo_get_mass_info (pcm, i_flv) result (massive)
     class(pcm_nlo_t), intent(in) :: pcm
     integer, intent(in) :: i_flv
     logical, dimension(:), allocatable :: massive
     allocate (massive (size (pcm%region_data%flv_born(i_flv)%massive)))
     massive = pcm%region_data%flv_born(i_flv)%massive
   end function pcm_nlo_get_mass_info
 
 @ %def pcm_nlo_get_mass_info
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: allocate_instance => pcm_nlo_allocate_instance
 <<Pcm: procedures>>=
   subroutine pcm_nlo_allocate_instance (pcm, instance)
     class(pcm_nlo_t), intent(in) :: pcm
     class(pcm_instance_t), intent(inout), allocatable :: instance
     allocate (pcm_instance_nlo_t :: instance)
   end subroutine pcm_nlo_allocate_instance
 
 @ %def pcm_nlo_allocate_instance
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: init_qn => pcm_nlo_init_qn
 <<Pcm: procedures>>=
   subroutine pcm_nlo_init_qn (pcm, model)
     class(pcm_nlo_t), intent(inout) :: pcm
     class(model_data_t), intent(in) :: model
     integer, dimension(:,:), allocatable :: flv_states
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     allocate (flv_states (pcm%region_data%n_legs_born, pcm%region_data%n_flv_born))
     flv_states = pcm%get_flv_states (.true.)
     allocate (pcm%qn_born (size (flv_states, dim = 1), size (flv_states, dim = 2)))
     allocate (flv (size (flv_states, dim = 1)))
     allocate (qn (size (flv_states, dim = 1)))
     do i = 1, pcm%get_n_flv_born ()
        call flv%init (flv_states (:,i), model)
        call qn%init (flv)
        pcm%qn_born(:,i) = qn
     end do
     deallocate (flv); deallocate (qn)
     deallocate (flv_states)
     allocate (flv_states (pcm%region_data%n_legs_real, pcm%region_data%n_flv_real))
     flv_states = pcm%get_flv_states (.false.)
     allocate (pcm%qn_real (size (flv_states, dim = 1), size (flv_states, dim = 2)))
     allocate (flv (size (flv_states, dim = 1)))
     allocate (qn (size (flv_states, dim = 1)))
     do i = 1, pcm%get_n_flv_real ()
        call flv%init (flv_states (:,i), model)
        call qn%init (flv)
        pcm%qn_real(:,i) = qn
     end do
   end subroutine pcm_nlo_init_qn
 
 @ %def pcm_nlo_init_qn
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: allocate_ps_matching => pcm_nlo_allocate_ps_matching
 <<Pcm: procedures>>=
   subroutine pcm_nlo_allocate_ps_matching (pcm)
     class(pcm_nlo_t), intent(inout) :: pcm
     if (.not. allocated (pcm%real_partition)) then
        allocate (powheg_damping_simple_t :: pcm%real_partition)
     end if
   end subroutine pcm_nlo_allocate_ps_matching
 
 @ %def pcm_nlo_allocate_ps_matching
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: activate_dalitz_plot => pcm_nlo_activate_dalitz_plot
 <<Pcm: procedures>>=
   subroutine pcm_nlo_activate_dalitz_plot (pcm, filename)
     class(pcm_nlo_t), intent(inout) :: pcm
     type(string_t), intent(in) :: filename
     call pcm%dalitz_plot%init (free_unit (), filename, .false.)
     call pcm%dalitz_plot%write_header ()
   end subroutine pcm_nlo_activate_dalitz_plot
 
 @ %def pcm_nlo_activate_dalitz_plot
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: register_dalitz_plot => pcm_nlo_register_dalitz_plot
 <<Pcm: procedures>>=
   subroutine pcm_nlo_register_dalitz_plot (pcm, emitter, p)
     class(pcm_nlo_t), intent(inout) :: pcm
     integer, intent(in) :: emitter
     type(vector4_t), intent(in), dimension(:) :: p
     real(default) :: k0_n, k0_np1
     k0_n = p(emitter)%p(0)
     k0_np1 = p(size(p))%p(0)
     call pcm%dalitz_plot%register (k0_n, k0_np1)
   end subroutine pcm_nlo_register_dalitz_plot
 
 @ %def pcm_nlo_register_dalitz_plot
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: setup_phs_generator => pcm_nlo_setup_phs_generator
 <<Pcm: procedures>>=
   subroutine pcm_nlo_setup_phs_generator (pcm, pcm_instance, generator, &
      sqrts, mode, singular_jacobian)
     class(pcm_nlo_t), intent(in) :: pcm
     type(phs_fks_generator_t), intent(inout) :: generator
     type(pcm_instance_nlo_t), intent(in), target :: pcm_instance
     real(default), intent(in) :: sqrts
     integer, intent(in), optional:: mode
     logical, intent(in), optional :: singular_jacobian
     logical :: yorn
     yorn = .false.; if (present (singular_jacobian)) yorn = singular_jacobian
     call generator%connect_kinematics (pcm_instance%isr_kinematics, &
          pcm_instance%real_kinematics, pcm%has_massive_emitter ())
     generator%n_in = pcm%region_data%n_in
     call generator%set_sqrts_hat (sqrts)
     call generator%set_emitters (pcm%region_data%emitters)
     call generator%setup_masses (pcm%region_data%n_legs_born)
     generator%is_massive = pcm%get_mass_info (1)
     generator%singular_jacobian = yorn
     if (present (mode)) generator%mode = mode
     call generator%set_xi_and_y_bounds (pcm%settings%fks_template%xi_min, &
          pcm%settings%fks_template%y_max)
   end subroutine pcm_nlo_setup_phs_generator
 
 @ %def pcm_nlo_setup_phs_generator
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: final => pcm_nlo_final
 <<Pcm: procedures>>=
   subroutine pcm_nlo_final (pcm)
     class(pcm_nlo_t), intent(inout) :: pcm
     if (allocated (pcm%real_partition)) deallocate (pcm%real_partition)
     call pcm%dalitz_plot%final ()
   end subroutine pcm_nlo_final
 
 @ %def pcm_nlo_final
 @
 <<Pcm: pcm nlo: TBP>>=
   procedure :: is_nlo => pcm_nlo_is_nlo
 <<Pcm: procedures>>=
   function pcm_nlo_is_nlo (pcm) result (is_nlo)
     logical :: is_nlo
     class(pcm_nlo_t), intent(in) :: pcm
     is_nlo = .true.
   end function pcm_nlo_is_nlo
 
 @ %def pcm_nlo_is_nlo
 @ As a first implementation, it acts as a wrapper for the NLO controller
 object and the squared matrix-element collector.
 <<Pcm: public>>=
   public :: pcm_instance_nlo_t
 <<Pcm: types>>=
   type, extends (pcm_instance_t) :: pcm_instance_nlo_t
      type(real_kinematics_t), pointer :: real_kinematics => null ()
      type(isr_kinematics_t), pointer :: isr_kinematics => null ()
      type(real_subtraction_t) :: real_sub
      type(virtual_t) :: virtual
      type(soft_mismatch_t) :: soft_mismatch
      type(dglap_remnant_t) :: dglap_remnant
      integer, dimension(:), allocatable :: i_mci_to_real_component
   contains
   <<Pcm: pcm instance: TBP>>
   end type pcm_instance_nlo_t
 
 @ %def pcm_instance_nlo_t
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_radiation_event => pcm_instance_nlo_set_radiation_event
   procedure :: set_subtraction_event => pcm_instance_nlo_set_subtraction_event
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_radiation_event (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%radiation_event = .true.
     pcm_instance%real_sub%subtraction_event = .false.
   end subroutine pcm_instance_nlo_set_radiation_event
 
   subroutine pcm_instance_nlo_set_subtraction_event (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%radiation_event = .false.
     pcm_instance%real_sub%subtraction_event = .true.
   end subroutine pcm_instance_nlo_set_subtraction_event
 
 @ %def pcm_instance_nlo_set_radiation_event
 @ %def pcm_instance_nlo_set_subtraction_event
 <<Pcm: pcm instance: TBP>>=
   procedure :: disable_subtraction => pcm_instance_nlo_disable_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_disable_subtraction (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%subtraction_deactivated = .true.
   end subroutine pcm_instance_nlo_disable_subtraction
 
 @ %def pcm_instance_nlo_disable_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_config => pcm_instance_nlo_init_config
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_config (pcm_instance, active_components, &
      nlo_types, energy, i_real_fin, model)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     logical, intent(in), dimension(:) :: active_components
     integer, intent(in), dimension(:) :: nlo_types
     real(default), intent(in), dimension(:) :: energy
     integer, intent(in) :: i_real_fin
     class(model_data_t), intent(in) :: model
     integer :: i_component
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "pcm_instance_nlo_init_config")
     call pcm_instance%init_real_and_isr_kinematics (energy)
     select type (pcm => pcm_instance%config)
     type is (pcm_nlo_t)
        do i_component = 1, size (active_components)
           if (active_components(i_component) .or. pcm%settings%combined_integration) then
              select case (nlo_types(i_component))
              case (NLO_REAL)
                 if (i_component /= i_real_fin) then
                    call pcm_instance%setup_real_component &
                         (pcm%settings%fks_template%subtraction_disabled)
                 end if
              case (NLO_VIRTUAL)
                 call pcm_instance%init_virtual (model)
              case (NLO_MISMATCH)
                 call pcm_instance%init_soft_mismatch ()
              case (NLO_DGLAP)
                 call pcm_instance%init_dglap_remnant ()
              end select
           end if
        end do
     end select
   end subroutine pcm_instance_nlo_init_config
 
 @ %def pcm_instance_nlo_init_config
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: setup_real_component => pcm_instance_nlo_setup_real_component
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_setup_real_component (pcm_instance, &
      subtraction_disabled)
     class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
     logical, intent(in) :: subtraction_disabled
     call pcm_instance%init_real_subtraction ()
     if (subtraction_disabled)  call pcm_instance%disable_subtraction ()
   end subroutine pcm_instance_nlo_setup_real_component
 
 @ %def pcm_instance_nlo_setup_real_component
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_real_and_isr_kinematics => &
        pcm_instance_nlo_init_real_and_isr_kinematics
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_real_and_isr_kinematics (pcm_instance, energy)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), dimension(:), intent(in) :: energy
     integer :: n_contr
     allocate (pcm_instance%real_kinematics)
     allocate (pcm_instance%isr_kinematics)
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        associate (region_data => config%region_data)
           if (allocated (region_data%alr_contributors)) then
              n_contr = size (region_data%alr_contributors)
           else if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
              n_contr = 2
           else
              n_contr = 1
           end if
           call pcm_instance%real_kinematics%init &
                (region_data%n_legs_real, region_data%n_phs, &
                region_data%n_regions, n_contr)
           if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
              call pcm_instance%real_kinematics%init_onshell &
                   (region_data%n_legs_real, region_data%n_phs)
           pcm_instance%isr_kinematics%n_in = region_data%n_in
        end associate
     end select
     pcm_instance%isr_kinematics%beam_energy = energy
   end subroutine pcm_instance_nlo_init_real_and_isr_kinematics
 
 @ %def pcm_instance_nlo_init_real_and_isr_kinematics
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_real_and_isr_kinematics => &
       pcm_instance_nlo_set_real_and_isr_kinematics
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_real_and_isr_kinematics (pcm_instance, phs_identifiers, sqrts)
     class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     real(default), intent(in) :: sqrts
     call pcm_instance%real_sub%set_real_kinematics &
          (pcm_instance%real_kinematics)
     call pcm_instance%real_sub%set_isr_kinematics &
          (pcm_instance%isr_kinematics)
   end subroutine pcm_instance_nlo_set_real_and_isr_kinematics
 
 @ %def pcm_instance_nlo_set_real_and_isr_kinematics
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_real_subtraction => pcm_instance_nlo_init_real_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_real_subtraction (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        associate (region_data => config%region_data)
           call pcm_instance%real_sub%init (region_data, config%settings)
           if (allocated (config%settings%selected_alr)) then
               associate (selected_alr => config%settings%selected_alr)
                 if (any (selected_alr < 0)) then
                    call msg_fatal ("Fixed alpha region must be non-negative!")
                 else if (any (selected_alr > region_data%n_regions)) then
                    call msg_fatal ("Fixed alpha region is larger than the total"&
                         &" number of singular regions!")
                 else
                    allocate (pcm_instance%real_sub%selected_alr (size (selected_alr)))
                    pcm_instance%real_sub%selected_alr = selected_alr
                 end if
              end associate
           end if
        end associate
     end select
   end subroutine pcm_instance_nlo_init_real_subtraction
 
 @ %def pcm_instance_nlo_init_real_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_momenta_and_scales_virtual => &
      pcm_instance_nlo_set_momenta_and_scales_virtual
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_momenta_and_scales_virtual (pcm_instance, p, &
      ren_scale, fac_scale, es_scale)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: ren_scale, fac_scale, es_scale
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        associate (virtual => pcm_instance%virtual)
           call virtual%set_ren_scale (p, ren_scale)
           call virtual%set_fac_scale (p, fac_scale)
           call virtual%set_ellis_sexton_scale (es_scale)
        end associate
     end select
   end subroutine pcm_instance_nlo_set_momenta_and_scales_virtual
 
 @ %def pcm_instance_nlo_set_momenta_and_scales_virtual
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_fac_scale => pcm_instance_nlo_set_fac_scale
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_fac_scale (pcm_instance, fac_scale)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), intent(in) :: fac_scale
     pcm_instance%isr_kinematics%fac_scale = fac_scale
   end subroutine pcm_instance_nlo_set_fac_scale
 
 @ %def pcm_instance_nlo_set_fac_scale
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_momenta => pcm_instance_nlo_set_momenta
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_momenta (pcm_instance, p_born, p_real, i_phs, cms)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     type(vector4_t), dimension(:), intent(in) :: p_born, p_real
     integer, intent(in) :: i_phs
     logical, intent(in), optional :: cms
     logical :: yorn
     yorn = .false.; if (present (cms)) yorn = cms
     associate (kinematics => pcm_instance%real_kinematics)
        if (yorn) then
           if (.not. kinematics%p_born_cms%initialized) &
                call kinematics%p_born_cms%init (size (p_born), 1)
           if (.not. kinematics%p_real_cms%initialized) &
                call kinematics%p_real_cms%init (size (p_real), 1)
           kinematics%p_born_cms%phs_point(1)%p = p_born
           kinematics%p_real_cms%phs_point(i_phs)%p = p_real
        else
           if (.not. kinematics%p_born_lab%initialized) &
                call kinematics%p_born_lab%init (size (p_born), 1)
           if (.not. kinematics%p_real_lab%initialized) &
                call kinematics%p_real_lab%init (size (p_real), 1)
           kinematics%p_born_lab%phs_point(1)%p = p_born
           kinematics%p_real_lab%phs_point(i_phs)%p = p_real
        end if
     end associate
   end subroutine pcm_instance_nlo_set_momenta
 
 @ %def pcm_instance_nlo_set_momenta
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_momenta => pcm_instance_nlo_get_momenta
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_momenta (pcm_instance, i_phs, born_phsp, cms) result (p)
     type(vector4_t), dimension(:), allocatable :: p
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     integer, intent(in) :: i_phs
     logical, intent(in) :: born_phsp
     logical, intent(in), optional :: cms
     logical :: yorn
     yorn = .false.; if (present (cms)) yorn = cms
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        if (born_phsp) then
           if (yorn) then
              allocate (p (1 : config%region_data%n_legs_born), &
                 source = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p)
           else
              allocate (p (1 : config%region_data%n_legs_born), &
                 source = pcm_instance%real_kinematics%p_born_lab%phs_point(1)%p)
           end if
        else
           if (yorn) then
              allocate (p (1 : config%region_data%n_legs_real), &
                 source = pcm_instance%real_kinematics%p_real_cms%phs_point(i_phs)%p)
           else
              allocate (p ( 1 : config%region_data%n_legs_real), &
                   source = pcm_instance%real_kinematics%p_real_lab%phs_point(i_phs)%p)
           end if
        end if
     end select
   end function pcm_instance_nlo_get_momenta
 
 @ %def pcm_instance_nlo_get_momenta
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_xi_max => pcm_instance_nlo_get_xi_max
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_xi_max (pcm_instance, alr) result (xi_max)
     real(default) :: xi_max
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     integer, intent(in) :: alr
     integer :: i_phs
     i_phs = pcm_instance%real_kinematics%alr_to_i_phs (alr)
     xi_max = pcm_instance%real_kinematics%xi_max (i_phs)
   end function pcm_instance_nlo_get_xi_max
 
 @ %def pcm_instance_nlo_get_xi_max
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_n_born => pcm_instance_nlo_get_n_born
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_n_born (pcm_instance) result (n_born)
     integer :: n_born
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        n_born = config%region_data%n_legs_born
     end select
   end function pcm_instance_nlo_get_n_born
 
 @ %def pcm_instance_nlo_get_n_born
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_n_real => pcm_instance_nlo_get_n_real
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_n_real (pcm_instance) result (n_real)
     integer :: n_real
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        n_real = config%region_data%n_legs_real
     end select
   end function pcm_instance_nlo_get_n_real
 
 @ %def pcm_instance_nlo_get_n_real
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: get_n_regions => pcm_instance_nlo_get_n_regions
 <<Pcm: procedures>>=
   function pcm_instance_nlo_get_n_regions (pcm_instance) result (n_regions)
     integer :: n_regions
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        n_regions = config%region_data%n_regions
     end select
   end function pcm_instance_nlo_get_n_regions
 
 @ %def pcm_instance_nlo_get_n_regions
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_x_rad => pcm_instance_nlo_set_x_rad
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_x_rad (pcm_instance, x_tot)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), intent(in), dimension(:) :: x_tot
     integer :: n_par
     n_par = size (x_tot)
     if (n_par < 3) then
        pcm_instance%real_kinematics%x_rad = zero
     else
        pcm_instance%real_kinematics%x_rad = x_tot (n_par - 2 : n_par)
     end if
   end subroutine pcm_instance_nlo_set_x_rad
 
 @ %def pcm_instance_nlo_set_x_rad
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_virtual => pcm_instance_nlo_init_virtual
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_virtual (pcm_instance, model)
     class(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
     class(model_data_t), intent(in) :: model
     type(nlo_settings_t), pointer :: settings
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        associate (region_data => config%region_data)
          settings => config%settings
          call pcm_instance%virtual%init (region_data%get_flv_states_born (), &
               region_data%n_in, settings, &
               region_data%regions(1)%nlo_correction_type, model, config%has_pdfs)
        end associate
     end select
   end subroutine pcm_instance_nlo_init_virtual
 
 @ %def pcm_instance_nlo_init_virtual
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: disable_virtual_subtraction => pcm_instance_nlo_disable_virtual_subtraction
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_disable_virtual_subtraction (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
   end subroutine pcm_instance_nlo_disable_virtual_subtraction
 
 @ %def pcm_instance_nlo_disable_virtual_subtraction
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_virt => pcm_instance_nlo_compute_sqme_virt
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_compute_sqme_virt (pcm_instance, p, &
          alpha_coupling, separate_uborns, sqme_virt)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: alpha_coupling
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), allocatable, intent(inout) :: sqme_virt
     type(vector4_t), dimension(:), allocatable :: pp
     associate (virtual => pcm_instance%virtual)
        allocate (pp (size (p)))
        if (virtual%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
           pp = pcm_instance%real_kinematics%p_born_onshell%get_momenta (1)
        else
           pp = p
        end if
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           if (separate_uborns) then
              allocate (sqme_virt (config%get_n_flv_born ()))
           else
              allocate (sqme_virt (1))
           end if
           sqme_virt = zero
           call virtual%evaluate (config%region_data, &
                alpha_coupling, pp, separate_uborns, sqme_virt)
        end select
     end associate
   end subroutine pcm_instance_nlo_compute_sqme_virt
 
 @ %def pcm_instance_nlo_compute_sqme_virt
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_mismatch => pcm_instance_nlo_compute_sqme_mismatch
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_compute_sqme_mismatch (pcm_instance, &
            alpha_s, separate_uborns, sqme_mism)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), intent(in) :: alpha_s
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), allocatable, intent(inout) :: sqme_mism
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        if (separate_uborns) then
           allocate (sqme_mism (config%get_n_flv_born ()))
        else
           allocate (sqme_mism (1))
        end if
        sqme_mism = zero
        sqme_mism = pcm_instance%soft_mismatch%evaluate (alpha_s)
     end select
   end subroutine pcm_instance_nlo_compute_sqme_mismatch
 
 @ %def pcm_instance_nlo_compute_sqme_mismatch
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: compute_sqme_dglap_remnant => pcm_instance_nlo_compute_sqme_dglap_remnant
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_compute_sqme_dglap_remnant (pcm_instance, &
             alpha_coupling, separate_uborns, sqme_dglap)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     real(default), intent(in) :: alpha_coupling
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), allocatable, intent(inout) :: sqme_dglap
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        if (separate_uborns) then
           allocate (sqme_dglap (config%get_n_flv_born ()))
        else
           allocate (sqme_dglap (1))
        end if
     end select
     sqme_dglap = zero
     call pcm_instance%dglap_remnant%evaluate (alpha_coupling, separate_uborns, sqme_dglap)
   end subroutine pcm_instance_nlo_compute_sqme_dglap_remnant
 
 @ %def pcm_instance_nlo_compute_sqme_dglap_remnant
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_fixed_order_event_mode => pcm_instance_nlo_set_fixed_order_event_mode
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_fixed_order_event_mode (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%purpose = FIXED_ORDER_EVENTS
   end subroutine pcm_instance_nlo_set_fixed_order_event_mode
 
 <<Pcm: pcm instance: TBP>>=
   procedure :: set_powheg_mode => pcm_instance_nlo_set_powheg_mode
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_set_powheg_mode (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     pcm_instance%real_sub%purpose = POWHEG
   end subroutine pcm_instance_nlo_set_powheg_mode
 
 @ %def pcm_instance_nlo_set_fixed_order_event_mode
 @ %def pcm_instance_nlo_set_powheg_mode
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_soft_mismatch => pcm_instance_nlo_init_soft_mismatch
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_soft_mismatch (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        call pcm_instance%soft_mismatch%init (config%region_data, &
             pcm_instance%real_kinematics, config%settings%factorization_mode)
     end select
   end subroutine pcm_instance_nlo_init_soft_mismatch
 
 @ %def pcm_instance_nlo_init_soft_mismatch
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: init_dglap_remnant => pcm_instance_nlo_init_dglap_remnant
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_init_dglap_remnant (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     select type (config => pcm_instance%config)
     type is (pcm_nlo_t)
        call pcm_instance%dglap_remnant%init ( &
             config%settings, &
             config%region_data, &
             pcm_instance%isr_kinematics)
     end select
   end subroutine pcm_instance_nlo_init_dglap_remnant
 
 @ %def pcm_instance_nlo_init_dglap_remnant
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: is_fixed_order_nlo_events &
        => pcm_instance_nlo_is_fixed_order_nlo_events
 <<Pcm: procedures>>=
   function pcm_instance_nlo_is_fixed_order_nlo_events (pcm_instance) result (is_fnlo)
     logical :: is_fnlo
     class(pcm_instance_nlo_t), intent(in) :: pcm_instance
     is_fnlo = pcm_instance%real_sub%purpose == FIXED_ORDER_EVENTS
   end function pcm_instance_nlo_is_fixed_order_nlo_events
 
 @ %def pcm_instance_nlo_is_fixed_order_nlo_events
 @
 <<Pcm: pcm instance: TBP>>=
   procedure :: final => pcm_instance_nlo_final
 <<Pcm: procedures>>=
   subroutine pcm_instance_nlo_final (pcm_instance)
     class(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     call pcm_instance%real_sub%final ()
     call pcm_instance%virtual%final ()
     call pcm_instance%soft_mismatch%final ()
     call pcm_instance%dglap_remnant%final ()
     if (associated (pcm_instance%real_kinematics)) then
        call pcm_instance%real_kinematics%final ()
        nullify (pcm_instance%real_kinematics)
     end if
     if (associated (pcm_instance%isr_kinematics)) then
        nullify (pcm_instance%isr_kinematics)
     end if
   end subroutine pcm_instance_nlo_final
 
 @ %def pcm_instance_nlo_final
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Kinematics instance}
 In this data type we combine all objects (instances) necessary for
 generating (or recovering) a kinematical configuration.  The
 components work together as an implementation of multi-channel phase
 space.
 
 [[sf_chain]] is an instance of the structure-function chain.  It is
 used both for generating kinematics and, after the proper scale has
 been determined, evaluating the structure function entries.
 
 [[phs]] is an instance of the phase space for the elementary process.
 
 The array [[f]] contains the products of the Jacobians that originate
 from parameter mappings in the structure-function chain or in the
 phase space.  We allocate this explicitly if either [[sf_chain]] or
 [[phs]] are explicitly allocated, otherwise we can take over a pointer.
 
 All components are implemented as pointers to (anonymous) targets.
 For each component, there is a flag that tells whether this component
 is to be regarded as a proper component (`owned' by the object) or as
 a pointer.
 @
 <<[[kinematics.f90]]>>=
 <<File header>>
 
 module kinematics
 
 <<Use kinds>>
 <<Use debug>>
   use format_utils, only: write_separator
   use diagnostics
   use io_units
   use lorentz
   use physics_defs
   use sf_base
   use phs_base
   use interactions
   use mci_base
   use phs_fks
   use fks_regions
   use process_config
   use process_mci
   use pcm, only: pcm_instance_nlo_t
   use ttv_formfactors, only: m1s_to_mpole
 
 <<Standard module head>>
 
 <<Kinematics: public>>
 
 <<Kinematics: types>>
 
 contains
 
 <<Kinematics: procedures>>
 
 end module kinematics
 @ %def kinematics
 <<Kinematics: public>>=
   public :: kinematics_t
 <<Kinematics: types>>=
   type :: kinematics_t
      integer :: n_in = 0
      integer :: n_channel = 0
      integer :: selected_channel = 0
      type(sf_chain_instance_t), pointer :: sf_chain => null ()
      class(phs_t), pointer :: phs => null ()
      real(default), dimension(:), pointer :: f => null ()
      real(default) :: phs_factor
      logical :: sf_chain_allocated = .false.
      logical :: phs_allocated = .false.
      logical :: f_allocated = .false.
      integer :: emitter = -1
      integer :: i_phs = 0
      integer :: i_con = 0
      logical :: only_cm_frame = .false.
      logical :: new_seed = .true.
      logical :: threshold = .false.
    contains
    <<Kinematics: kinematics: TBP>>
   end type kinematics_t
 
 @ %def kinematics_t
 @ Output.  Show only those components which are marked as owned.
 <<Kinematics: kinematics: TBP>>=
   procedure :: write => kinematics_write
 <<Kinematics: procedures>>=
   subroutine kinematics_write (object, unit)
     class(kinematics_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, c
     u = given_output_unit (unit)
     if (object%f_allocated) then
        write (u, "(1x,A)")  "Flux * PHS volume:"
        write (u, "(2x,ES19.12)")  object%phs_factor
        write (u, "(1x,A)")  "Jacobian factors per channel:"
        do c = 1, size (object%f)
           write (u, "(3x,I0,':',1x,ES14.7)", advance="no")  c, object%f(c)
           if (c == object%selected_channel) then
              write (u, "(1x,A)")  "[selected]"
           else
              write (u, *)
           end if
        end do
     end if
     if (object%sf_chain_allocated) then
        call write_separator (u)
        call object%sf_chain%write (u)
     end if
     if (object%phs_allocated) then
        call write_separator (u)
        call object%phs%write (u)
     end if
   end subroutine kinematics_write
 
 @ %def kinematics_write
 @ Finalizer.  Delete only those components which are marked as owned.
 <<Kinematics: kinematics: TBP>>=
   procedure :: final => kinematics_final
 <<Kinematics: procedures>>=
   subroutine kinematics_final (object)
     class(kinematics_t), intent(inout) :: object
     if (object%sf_chain_allocated) then
        call object%sf_chain%final ()
        deallocate (object%sf_chain)
        object%sf_chain_allocated = .false.
     end if
     if (object%phs_allocated) then
        call object%phs%final ()
        deallocate (object%phs)
        object%phs_allocated = .false.
     end if
     if (object%f_allocated) then
        deallocate (object%f)
        object%f_allocated = .false.
     end if
   end subroutine kinematics_final
 
 @ %def kinematics_final
 @ Set the flags indicating whether the phase space shall be set up for the calculation of the real contribution. For this case, also set the emitter.
 <<Kinematics: kinematics: TBP>>=
   procedure :: set_nlo_info => kinematics_set_nlo_info
 <<Kinematics: procedures>>=
   subroutine kinematics_set_nlo_info (k, nlo_type)
     class(kinematics_t), intent(inout) :: k
     integer, intent(in) :: nlo_type
     if (nlo_type == NLO_VIRTUAL)  k%only_cm_frame = .true.
   end subroutine kinematics_set_nlo_info
 
 @ %def kinematics_set_nlo_info
 @ Allocate the structure-function chain instance, initialize it as a
 copy of the [[sf_chain]] template, and prepare it for evaluation.
 
 The [[sf_chain]] remains a target because the (usually constant) beam momenta
 are taken from there.
 <<Kinematics: kinematics: TBP>>=
   procedure :: init_sf_chain => kinematics_init_sf_chain
 <<Kinematics: procedures>>=
   subroutine kinematics_init_sf_chain (k, sf_chain, config, extended_sf)
     class(kinematics_t), intent(inout) :: k
     type(sf_chain_t), intent(in), target :: sf_chain
     type(process_beam_config_t), intent(in) :: config
     logical, intent(in), optional :: extended_sf
     integer :: n_strfun, n_channel
     integer :: c
     k%n_in = config%data%get_n_in ()
     n_strfun = config%n_strfun
     n_channel = config%n_channel
     allocate (k%sf_chain)
     k%sf_chain_allocated = .true.
     call k%sf_chain%init (sf_chain, n_channel)
     if (n_strfun /= 0) then
        do c = 1, n_channel
           call k%sf_chain%set_channel (c, config%sf_channel(c))
        end do
     end if
     call k%sf_chain%link_interactions ()
     call k%sf_chain%exchange_mask ()
     call k%sf_chain%init_evaluators (extended_sf = extended_sf)
   end subroutine kinematics_init_sf_chain
 
 @ %def kinematics_init_sf_chain
 @ Allocate and initialize the phase-space part and the array of
 Jacobian factors.
 <<Kinematics: kinematics: TBP>>=
   procedure :: init_phs => kinematics_init_phs
 <<Kinematics: procedures>>=
   subroutine kinematics_init_phs (k, config)
     class(kinematics_t), intent(inout) :: k
     class(phs_config_t), intent(in), target :: config
     k%n_channel = config%get_n_channel ()
     call config%allocate_instance (k%phs)
     call k%phs%init (config)
     k%phs_allocated = .true.
     allocate (k%f (k%n_channel))
     k%f = 0
     k%f_allocated = .true.
   end subroutine kinematics_init_phs
 
 @ %def kinematics_init_phs
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: evaluate_radiation_kinematics => kinematics_evaluate_radiation_kinematics
 <<Kinematics: procedures>>=
   subroutine kinematics_evaluate_radiation_kinematics (k, r_in)
     class(kinematics_t), intent(inout) :: k
     real(default), intent(in), dimension(:) :: r_in
     select type (phs => k%phs)
     type is (phs_fks_t)
        call phs%generate_radiation_variables &
             (r_in(phs%n_r_born + 1 : phs%n_r_born + 3), threshold = k%threshold)
        call phs%compute_cms_energy ()
     end select
   end subroutine kinematics_evaluate_radiation_kinematics
 
 @ %def kinematics_evaluate_radiation_kinematics
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: compute_xi_ref_momenta => kinematics_compute_xi_ref_momenta
 <<Kinematics: procedures>>=
   subroutine kinematics_compute_xi_ref_momenta (k, reg_data, nlo_type)
     class(kinematics_t), intent(inout) :: k
     type(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: nlo_type
     logical :: use_contributors
     use_contributors = allocated (reg_data%alr_contributors)
     select type (phs => k%phs)
     type is (phs_fks_t)
        if (use_contributors) then
           call phs%compute_xi_ref_momenta (contributors = reg_data%alr_contributors)
        else if (k%threshold) then
           if (.not. is_subtraction_component (k%emitter, nlo_type)) &
                call phs%compute_xi_ref_momenta_threshold ()
        else
           call phs%compute_xi_ref_momenta ()
        end if
     end select
   end subroutine kinematics_compute_xi_ref_momenta
 
 @ %def kinematics_compute_xi_ref_momenta
 @ Generate kinematics, given a phase-space channel and a MC
 parameter set. The main result is the momentum array [[p]], but we
 also fill the momentum entries in the structure-function chain and the
 Jacobian-factor array [[f]].  Regarding phase space, We fill only the
 parameter arrays for the selected channel.
 <<Kinematics: kinematics: TBP>>=
   procedure :: compute_selected_channel => kinematics_compute_selected_channel
 <<Kinematics: procedures>>=
   subroutine kinematics_compute_selected_channel &
        (k, mci_work, phs_channel, p, success)
     class(kinematics_t), intent(inout) :: k
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     type(vector4_t), dimension(:), intent(out) :: p
     logical, intent(out) :: success
     integer :: sf_channel
     k%selected_channel = phs_channel
     sf_channel = k%phs%config%get_sf_channel (phs_channel)
     call k%sf_chain%compute_kinematics (sf_channel, mci_work%get_x_strfun ())
     call k%sf_chain%get_out_momenta (p(1:k%n_in))
     call k%phs%set_incoming_momenta (p(1:k%n_in))
     call k%phs%compute_flux ()
     call k%phs%select_channel (phs_channel)
     call k%phs%evaluate_selected_channel (phs_channel, &
          mci_work%get_x_process ())
 
     select type (phs => k%phs)
     type is (phs_fks_t)
        if (debug_on)  call msg_debug2 (D_REAL, "phase space is phs_FKS")
        if (phs%q_defined) then
           call phs%get_born_momenta (p)
           if (debug_on) then
              call msg_debug2 (D_REAL, "q is defined")
              call msg_debug2 (D_REAL, "get_born_momenta called")
           end if
           k%phs_factor = phs%get_overall_factor ()
           success = .true.
       else
          k%phs_factor = 0
          success = .false.
       end if
     class default
       if (phs%q_defined) then
          call k%phs%get_outgoing_momenta (p(k%n_in + 1 :))
          k%phs_factor = k%phs%get_overall_factor ()
          success = .true.
       else
          k%phs_factor = 0
          success = .false.
       end if
     end select
   end subroutine kinematics_compute_selected_channel
 
 @ %def kinematics_compute_selected_channel
 @ Complete kinematics by filling the non-selected phase-space parameter
 arrays.
 <<Kinematics: kinematics: TBP>>=
   procedure :: compute_other_channels => kinematics_compute_other_channels
 <<Kinematics: procedures>>=
   subroutine kinematics_compute_other_channels (k, mci_work, phs_channel)
     class(kinematics_t), intent(inout) :: k
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     integer :: c, c_sf
     call k%phs%evaluate_other_channels (phs_channel)
     do c = 1, k%n_channel
        c_sf = k%phs%config%get_sf_channel (c)
        k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c)
     end do
   end subroutine kinematics_compute_other_channels
 
 @ %def kinematics_compute_other_channels
 @ Just fetch the outgoing momenta of the [[sf_chain]] subobject, which
 become the incoming (seed) momenta of the hard interaction.
 
 This is a stripped down-version of the above which we use when
 recovering kinematics.  Momenta are known, but no MC parameters yet.
 
 (We do not use the [[get_out_momenta]] method of the chain, since this
 relies on the structure-function interactions, which are not necessary
 filled here.  We do rely on the momenta of the last evaluator in the
 chain, however.)
 <<Kinematics: kinematics: TBP>>=
   procedure :: get_incoming_momenta => kinematics_get_incoming_momenta
 <<Kinematics: procedures>>=
   subroutine kinematics_get_incoming_momenta (k, p)
     class(kinematics_t), intent(in) :: k
     type(vector4_t), dimension(:), intent(out) :: p
     type(interaction_t), pointer :: int
     integer :: i
     int => k%sf_chain%get_out_int_ptr ()
     do i = 1, k%n_in
        p(i) = int%get_momentum (k%sf_chain%get_out_i (i))
     end do
   end subroutine kinematics_get_incoming_momenta
 
 @ %def kinematics_get_incoming_momenta
 @ This inverts the remainder of the above [[compute]] method.  We know
 the momenta and recover the rest, as far as needed.  If we select a
 channel, we can complete the inversion and reconstruct the
 MC parameter set.
 <<Kinematics: kinematics: TBP>>=
   procedure :: recover_mcpar => kinematics_recover_mcpar
 <<Kinematics: procedures>>=
   subroutine kinematics_recover_mcpar (k, mci_work, phs_channel, p)
     class(kinematics_t), intent(inout) :: k
     type(mci_work_t), intent(inout) :: mci_work
     integer, intent(in) :: phs_channel
     type(vector4_t), dimension(:), intent(in) :: p
     integer :: c, c_sf
     real(default), dimension(:), allocatable :: x_sf, x_phs
     c = phs_channel
     c_sf = k%phs%config%get_sf_channel (c)
     k%selected_channel = c
     call k%sf_chain%recover_kinematics (c_sf)
     call k%phs%set_incoming_momenta (p(1:k%n_in))
     call k%phs%compute_flux ()
     call k%phs%set_outgoing_momenta (p(k%n_in+1:))
     call k%phs%inverse ()
     do c = 1, k%n_channel
        c_sf = k%phs%config%get_sf_channel (c)
        k%f(c) = k%sf_chain%get_f (c_sf) * k%phs%get_f (c)
     end do
     k%phs_factor = k%phs%get_overall_factor ()
     c = phs_channel
     c_sf = k%phs%config%get_sf_channel (c)
     allocate (x_sf (k%sf_chain%config%get_n_bound ()))
     allocate (x_phs (k%phs%config%get_n_par ()))
     call k%phs%select_channel (c)
     call k%sf_chain%get_mcpar (c_sf, x_sf)
     call k%phs%get_mcpar (c, x_phs)
     call mci_work%set_x_strfun (x_sf)
     call mci_work%set_x_process (x_phs)
   end subroutine kinematics_recover_mcpar
 
 @ %def kinematics_recover_mcpar
 @ This first part of [[recover_mcpar]]: just handle the sfchain.
 <<Kinematics: kinematics: TBP>>=
   procedure :: recover_sfchain => kinematics_recover_sfchain
 <<Kinematics: procedures>>=
   subroutine kinematics_recover_sfchain (k, channel, p)
     class(kinematics_t), intent(inout) :: k
     integer, intent(in) :: channel
     type(vector4_t), dimension(:), intent(in) :: p
     k%selected_channel = channel
     call k%sf_chain%recover_kinematics (channel)
   end subroutine kinematics_recover_sfchain
 
 @ %def kinematics_recover_sfchain
 @ Retrieve the MC input parameter array for a specific channel.  We assume
 that the kinematics is complete, so this is known for all channels.
 <<Kinematics: kinematics: TBP>>=
   procedure :: get_mcpar => kinematics_get_mcpar
 <<Kinematics: procedures>>=
   subroutine kinematics_get_mcpar (k, phs_channel, r)
     class(kinematics_t), intent(in) :: k
     integer, intent(in) :: phs_channel
     real(default), dimension(:), intent(out) :: r
     integer :: sf_channel, n_par_sf, n_par_phs
     sf_channel = k%phs%config%get_sf_channel (phs_channel)
     n_par_phs = k%phs%config%get_n_par ()
     n_par_sf = k%sf_chain%config%get_n_bound ()
     if (n_par_sf > 0) then
        call k%sf_chain%get_mcpar (sf_channel, r(1:n_par_sf))
     end if
     if (n_par_phs > 0) then
        call k%phs%get_mcpar (phs_channel, r(n_par_sf+1:))
     end if
   end subroutine kinematics_get_mcpar
 
 @ %def kinematics_get_mcpar
 @ Evaluate the structure function chain, assuming that kinematics is known.
 
 The status must be precisely [[SF_DONE_KINEMATICS]].  We thus avoid
 evaluating the chain twice via different pointers to the same target.
 <<Kinematics: kinematics: TBP>>=
   procedure :: evaluate_sf_chain => kinematics_evaluate_sf_chain
 <<Kinematics: procedures>>=
   subroutine kinematics_evaluate_sf_chain (k, fac_scale, negative_sf, sf_rescale)
     class(kinematics_t), intent(inout) :: k
     real(default), intent(in) :: fac_scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(inout), optional :: sf_rescale
     select case (k%sf_chain%get_status ())
     case (SF_DONE_KINEMATICS)
        call k%sf_chain%evaluate (fac_scale, negative_sf = negative_sf, sf_rescale = sf_rescale)
     end select
   end subroutine kinematics_evaluate_sf_chain
 
 @ %def kinematics_evaluate_sf_chain
 @ Recover beam momenta, i.e., return the beam momenta stored in the
 current [[sf_chain]] to their source.  This is a side effect.
 <<Kinematics: kinematics: TBP>>=
   procedure :: return_beam_momenta => kinematics_return_beam_momenta
 <<Kinematics: procedures>>=
   subroutine kinematics_return_beam_momenta (k)
     class(kinematics_t), intent(in) :: k
     call k%sf_chain%return_beam_momenta ()
   end subroutine kinematics_return_beam_momenta
 
 @ %def kinematics_return_beam_momenta
 @ Check wether the phase space is configured in the center-of-mass frame.
 Relevant for using the proper momenta input for BLHA matrix elements.
 <<Kinematics: kinematics: TBP>>=
   procedure :: lab_is_cm => kinematics_lab_is_cm
 <<Kinematics: procedures>>=
   function kinematics_lab_is_cm (k) result (lab_is_cm)
      logical :: lab_is_cm
      class(kinematics_t), intent(in) :: k
      lab_is_cm = k%phs%config%lab_is_cm
   end function kinematics_lab_is_cm
 
 @ %def kinematics_lab_is_cm
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: modify_momenta_for_subtraction => kinematics_modify_momenta_for_subtraction
 <<Kinematics: procedures>>=
   subroutine kinematics_modify_momenta_for_subtraction (k, p_in, p_out)
     class(kinematics_t), intent(inout) :: k
     type(vector4_t), intent(in), dimension(:) :: p_in
     type(vector4_t), intent(out), dimension(:), allocatable :: p_out
     allocate (p_out (size (p_in)))
     if (k%threshold) then
        select type (phs => k%phs)
        type is (phs_fks_t)
           p_out = phs%get_onshell_projected_momenta ()
        end select
     else
        p_out = p_in
     end if
   end subroutine kinematics_modify_momenta_for_subtraction
 
 @ %def kinematics_modify_momenta_for_subtraction
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: threshold_projection => kinematics_threshold_projection
 <<Kinematics: procedures>>=
   subroutine kinematics_threshold_projection (k, pcm_instance, nlo_type)
     class(kinematics_t), intent(inout) :: k
     type(pcm_instance_nlo_t), intent(inout) :: pcm_instance
     integer, intent(in) :: nlo_type
     real(default) :: sqrts, mtop
     type(lorentz_transformation_t) :: L_to_cms
     type(vector4_t), dimension(:), allocatable :: p_tot
     integer :: n_tot
     n_tot = k%phs%get_n_tot ()
     allocate (p_tot (size (pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p)))
     select type (phs => k%phs)
     type is (phs_fks_t)
        p_tot = pcm_instance%real_kinematics%p_born_cms%phs_point(1)%p
     class default
        p_tot(1 : k%n_in) = phs%p
        p_tot(k%n_in + 1 : n_tot) = phs%q
     end select
     sqrts = sum (p_tot (1:k%n_in))**1
     mtop = m1s_to_mpole (sqrts)
     L_to_cms = get_boost_for_threshold_projection (p_tot, sqrts, mtop)
     call pcm_instance%real_kinematics%p_born_cms%set_momenta (1, p_tot)
     associate (p_onshell => pcm_instance%real_kinematics%p_born_onshell%phs_point(1)%p)
        call threshold_projection_born (mtop, L_to_cms, p_tot, p_onshell)
        if (debug2_active (D_THRESHOLD)) then
           print *, 'On-shell projected Born: '
           call vector4_write_set (p_onshell)
        end if
     end associate
   end subroutine kinematics_threshold_projection
 
 @ %def kinematics_threshold_projection
 @
 <<Kinematics: kinematics: TBP>>=
   procedure :: evaluate_radiation => kinematics_evaluate_radiation
 <<Kinematics: procedures>>=
   subroutine kinematics_evaluate_radiation (k, p_in, p_out, success)
     class(kinematics_t), intent(inout) :: k
     type(vector4_t), intent(in), dimension(:) :: p_in
     type(vector4_t), intent(out), dimension(:), allocatable :: p_out
     logical, intent(out) :: success
     type(vector4_t), dimension(:), allocatable :: p_real
     type(vector4_t), dimension(:), allocatable :: p_born
     real(default) :: xi_max_offshell, xi_offshell, y_offshell, jac_rand_dummy, phi
     select type (phs => k%phs)
     type is (phs_fks_t)
        allocate (p_born (size (p_in)))
        if (k%threshold) then
           p_born = phs%get_onshell_projected_momenta ()
        else
           p_born = p_in
        end if
        if (.not. k%phs%lab_is_cm () .and. .not. k%threshold) then
             p_born = inverse (k%phs%lt_cm_to_lab) * p_born
        end if
        call phs%compute_xi_max (p_born, k%threshold)
        if (k%emitter >= 0) then
           allocate (p_real (size (p_born) + 1))
           allocate (p_out (size (p_born) + 1))
           if (k%emitter <= k%n_in) then
              call phs%generate_isr (k%i_phs, p_real)
           else
              if (k%threshold) then
                 jac_rand_dummy = 1._default
                 call compute_y_from_emitter (phs%generator%real_kinematics%x_rad (I_Y), &
                      phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
                      k%n_in, k%emitter, .false., phs%generator%y_max, jac_rand_dummy, &
                      y_offshell)
                 call phs%compute_xi_max (k%emitter, k%i_phs, y_offshell, &
                      phs%generator%real_kinematics%p_born_cms%get_momenta(1), &
                      xi_max_offshell)
                 xi_offshell = xi_max_offshell * phs%generator%real_kinematics%xi_tilde
                 phi = phs%generator%real_kinematics%phi
                 call phs%generate_fsr (k%emitter, k%i_phs, p_real, &
                      xi_y_phi = [xi_offshell, y_offshell, phi], no_jacobians = .true.)
                 call phs%generator%real_kinematics%p_real_cms%set_momenta (k%i_phs, p_real)
                 call phs%generate_fsr_threshold (k%emitter, k%i_phs, p_real)
                 if (debug2_active (D_SUBTRACTION)) &
                      call generate_fsr_threshold_for_other_emitters (k%emitter, k%i_phs)
              else if (k%i_con > 0) then
                 call phs%generate_fsr (k%emitter, k%i_phs, p_real, k%i_con)
              else
                 call phs%generate_fsr (k%emitter, k%i_phs, p_real)
              end if
           end if
           success = check_scalar_products (p_real)
           if (debug2_active (D_SUBTRACTION)) then
              call msg_debug2 (D_SUBTRACTION, "Real phase-space: ")
              call vector4_write_set (p_real)
           end if
           p_out = p_real
        else
           allocate (p_out (size (p_in))); p_out = p_in
           success = .true.
        end if
     end select
   contains
     subroutine generate_fsr_threshold_for_other_emitters (emitter, i_phs)
       integer, intent(in) :: emitter, i_phs
       integer :: ii_phs, this_emitter
       select type (phs => k%phs)
       type is (phs_fks_t)
          do ii_phs = 1, size (phs%phs_identifiers)
             this_emitter = phs%phs_identifiers(ii_phs)%emitter
             if (ii_phs /= i_phs .and. this_emitter /= emitter) &
                  call phs%generate_fsr_threshold (this_emitter, i_phs)
          end do
       end select
     end subroutine
   end subroutine kinematics_evaluate_radiation
 
 @ %def kinematics_evaluate_radiation
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Instances}
 
 <<[[instances.f90]]>>=
 <<File header>>
 
 module instances
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use format_utils, only: write_separator
   use constants
   use diagnostics
   use os_interface
   use numeric_utils
   use lorentz
   use mci_base
   use particles
   use sm_qcd, only: qcd_t
   use interactions
   use quantum_numbers
   use model_data
   use helicities
   use flavors
   use beam_structures
   use variables
   use pdg_arrays, only: is_quark
   use sf_base
   use physics_defs
   use process_constants
   use process_libraries
   use state_matrices
   use integration_results
   use phs_base
   use prc_core, only: prc_core_t, prc_core_state_t
 
   !!! We should depend less on these modules (move it to pcm_nlo_t e.g.)
   use phs_wood, only: phs_wood_t
   use phs_fks
   use blha_olp_interfaces, only: prc_blha_t
   use blha_config, only: BLHA_AMP_COLOR_C
   use prc_external, only: prc_external_t, prc_external_state_t
   use prc_threshold, only: prc_threshold_t
   use blha_olp_interfaces, only: blha_result_array_size
   use prc_openloops, only: prc_openloops_t, openloops_state_t
   use prc_recola, only: prc_recola_t
   use blha_olp_interfaces, only: blha_color_c_fill_offdiag, blha_color_c_fill_diag
 
   use ttv_formfactors, only: m1s_to_mpole
   !!! local modules
   use parton_states
   use process_counter
   use pcm_base
   use pcm
   use process_config
   use process_mci
   use process
   use kinematics
 
 <<Standard module head>>
 
 <<Instances: public>>
 
 <<Instances: types>>
 
 <<Instances: interfaces>>
 
 contains
 
 <<Instances: procedures>>
 
 end module instances
 @ %def instances
 @
 \subsection{Term instance}
 A [[term_instance_t]] object contains all data that describe a term.  Each
 process component consists of one or more distinct terms which may differ in
 kinematics, but whose squared transition matrices have to be added pointwise.
 
 The [[active]] flag is set when this term is connected to an active
 process component.  Inactive terms are skipped for kinematics and evaluation.
 
 The [[k_term]] object is the instance of the kinematics setup
 (structure-function chain, phase space, etc.) that applies
 specifically to this term.  In ordinary cases, it consists of straight
 pointers to the seed kinematics.
 
 The [[amp]] array stores the amplitude values when we get them from evaluating
 the associated matrix-element code.
 
 The [[int_hard]] interaction describes the elementary hard process.
 It receives the momenta and the amplitude entries for each sampling point.
 
 The [[isolated]] object holds the effective parton state for the
 elementary interaction.  The amplitude entries are
 computed from [[int_hard]].
 
 The [[connected]] evaluator set
 convolutes this scattering matrix with the beam (and possibly
 structure-function) density matrix.
 
 The [[checked]] flag is set once we have applied cuts on this term.
 The result of this is stored in the [[passed]] flag.
 
 Although each [[term_instance]] carries a [[weight]], this currently
 always keeps the value $1$ and is only used to be given to routines
 to fulfill their signature.
 <<Instances: types>>=
   type :: term_instance_t
      type(process_term_t), pointer :: config => null ()
      logical :: active = .false.
      type(kinematics_t) :: k_term
      complex(default), dimension(:), allocatable :: amp
      type(interaction_t) :: int_hard
      type(isolated_state_t) :: isolated
      type(connected_state_t) :: connected
      class(prc_core_state_t), allocatable :: core_state
      logical :: checked = .false.
      logical :: passed = .false.
      real(default) :: scale = 0
      real(default) :: fac_scale = 0
      real(default) :: ren_scale = 0
      real(default) :: es_scale = 0
      real(default), allocatable :: alpha_qcd_forced
      real(default) :: weight = 1
      type(vector4_t), dimension(:), allocatable :: p_seed
      type(vector4_t), dimension(:), allocatable :: p_hard
      class(pcm_instance_t), pointer :: pcm_instance => null ()
      integer :: nlo_type = BORN
      integer, dimension(:), allocatable :: same_kinematics
      logical :: negative_sf = .false.
    contains
    <<Instances: term instance: TBP>>
   end type term_instance_t
 
 @ %def term_instance_t
 @
 <<Instances: term instance: TBP>>=
   procedure :: write => term_instance_write
 <<Instances: procedures>>=
   subroutine term_instance_write (term, unit, show_eff_state, testflag)
     class(term_instance_t), intent(in) :: term
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_eff_state
     logical, intent(in), optional :: testflag
     integer :: u
     logical :: state
     u = given_output_unit (unit)
     state = .true.;  if (present (show_eff_state))  state = show_eff_state
     if (term%active) then
        if (associated (term%config)) then
           write (u, "(1x,A,I0,A,I0,A)")  "Term #", term%config%i_term, &
                " (component #", term%config%i_component, ")"
        else
           write (u, "(1x,A)")  "Term [undefined]"
        end if
     else
        write (u, "(1x,A,I0,A)")  "Term #", term%config%i_term, &
             " [inactive]"
     end if
     if (term%checked) then
        write (u, "(3x,A,L1)")      "passed cuts           = ", term%passed
     end if
     if (term%passed) then
        write (u, "(3x,A,ES19.12)")  "overall scale         = ", term%scale
        write (u, "(3x,A,ES19.12)")  "factorization scale   = ", term%fac_scale
        write (u, "(3x,A,ES19.12)")  "renormalization scale = ", term%ren_scale
        if (allocated (term%alpha_qcd_forced)) then
           write (u, "(3x,A,ES19.12)")  "alpha(QCD) forced     = ", &
                term%alpha_qcd_forced
        end if
        write (u, "(3x,A,ES19.12)")  "reweighting factor    = ", term%weight
     end if
     call term%k_term%write (u)
     call write_separator (u)
     write (u, "(1x,A)")  "Amplitude (transition matrix of the &
          &hard interaction):"
     call write_separator (u)
     call term%int_hard%basic_write (u, testflag = testflag)
     if (state .and. term%isolated%has_trace) then
        call write_separator (u)
        write (u, "(1x,A)")  "Evaluators for the hard interaction:"
        call term%isolated%write (u, testflag = testflag)
     end if
     if (state .and. term%connected%has_trace) then
        call write_separator (u)
        write (u, "(1x,A)")  "Evaluators for the connected process:"
        call term%connected%write (u, testflag = testflag)
     end if
   end subroutine term_instance_write
 
 @ %def term_instance_write
 @ The interactions and evaluators must be finalized.
 <<Instances: term instance: TBP>>=
   procedure :: final => term_instance_final
 <<Instances: procedures>>=
   subroutine term_instance_final (term)
     class(term_instance_t), intent(inout) :: term
     if (allocated (term%amp)) deallocate (term%amp)
     if (allocated (term%core_state)) deallocate (term%core_state)
     if (allocated (term%alpha_qcd_forced)) &
        deallocate (term%alpha_qcd_forced)
     if (allocated (term%p_seed)) deallocate(term%p_seed)
     if (allocated (term%p_hard)) deallocate (term%p_hard)
     call term%k_term%final ()
     call term%connected%final ()
     call term%isolated%final ()
     call term%int_hard%final ()
     term%pcm_instance => null ()
   end subroutine term_instance_final
 
 @ %def term_instance_final
 @ For initialization, we make use of defined assignment for the
 [[interaction_t]] type.  This creates a deep copy.
 
 The hard interaction (incoming momenta) is linked to the structure
 function instance.  In the isolated state, we either set pointers to
 both, or we create modified copies ([[rearrange]]) as effective
 structure-function chain and interaction, respectively.
 
 Finally, we set up the [[subevt]] component that will be used for
 evaluating observables, collecting particles from the trace evaluator
 in the effective connected state.  Their quantum numbers must be
 determined by following back source links and set explicitly, since
 they are already eliminated in that trace.
 
 The [[rearrange]] parts are still commented out; they could become
 relevant for a NLO algorithm.
 <<Instances: term instance: TBP>>=
   procedure :: init => term_instance_init
 <<Instances: procedures>>=
   subroutine term_instance_init (term, process, i_term, real_finite)
     class(term_instance_t), intent(inout), target :: term
     type(process_t), intent(in), target:: process
     integer, intent(in) :: i_term
     logical, intent(in), optional :: real_finite
     class(prc_core_t), pointer :: core => null ()
     type(process_beam_config_t) :: beam_config
     type(interaction_t), pointer :: sf_chain_int
     type(interaction_t), pointer :: src_int
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
     type(state_matrix_t), pointer :: state_matrix
     type(flavor_t), dimension(:), allocatable :: flv_int, flv_src, f_in, f_out
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(flavor_t), dimension(:,:), allocatable :: flv_pdf
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn_pdf
     integer :: n_in, n_vir, n_out, n_tot, n_sub
     integer :: n_flv_born, n_flv_real, n_flv_total
     integer :: i, j
     logical :: me_already_squared, keep_fs_flavors
     logical :: decrease_n_tot
     logical :: requires_extended_sf
     me_already_squared = .false.
     keep_fs_flavors = .false.
     term%config => process%get_term_ptr (i_term)
     term%int_hard = term%config%int
     core => process%get_core_term (i_term)
     term%negative_sf = process%get_negative_sf ()
     call core%allocate_workspace (term%core_state)
     select type (core)
     class is (prc_external_t)
        call reduce_interaction (term%int_hard, &
             core%includes_polarization (), .true., .false.)
        me_already_squared = .true.
        allocate (term%amp (term%int_hard%get_n_matrix_elements ()))
     class default
        allocate (term%amp (term%config%n_allowed))
     end select
     if (allocated (term%core_state)) then
        select type (core_state => term%core_state)
        type is (openloops_state_t)
           call core_state%init_threshold (process%get_model_ptr ())
        end select
     end if
     term%amp = cmplx (0, 0, default)
     decrease_n_tot = term%nlo_type == NLO_REAL .and. &
          term%config%i_term_global /= term%config%i_sub
     if (present (real_finite)) then
        if (real_finite) decrease_n_tot = .false.
     end if
     if (decrease_n_tot) then
        allocate (term%p_seed (term%int_hard%get_n_tot () - 1))
     else
        allocate (term%p_seed (term%int_hard%get_n_tot ()))
     end if
     allocate (term%p_hard (term%int_hard%get_n_tot ()))
     sf_chain_int => term%k_term%sf_chain%get_out_int_ptr ()
     n_in = term%int_hard%get_n_in ()
     do j = 1, n_in
        i = term%k_term%sf_chain%get_out_i (j)
        call term%int_hard%set_source_link (j, sf_chain_int, i)
     end do
     call term%isolated%init (term%k_term%sf_chain, term%int_hard)
     allocate (mask_in (n_in))
     mask_in = term%k_term%sf_chain%get_out_mask ()
     select type (phs => term%k_term%phs)
       type is (phs_wood_t)
          if (me_already_squared) then
             call term%isolated%setup_identity_trace &
                  (core, mask_in, .true., .false.)
          else
             call term%isolated%setup_square_trace &
                  (core, mask_in, term%config%col, .false.)
          end if
       type is (phs_fks_t)
          select case (phs%mode)
          case (PHS_MODE_ADDITIONAL_PARTICLE)
             if (me_already_squared) then
                call term%isolated%setup_identity_trace &
                     (core, mask_in, .true., .false.)
             else
                keep_fs_flavors = term%config%data%n_flv > 1
                call term%isolated%setup_square_trace &
                     (core, mask_in, term%config%col, &
                     keep_fs_flavors)
             end if
          case (PHS_MODE_COLLINEAR_REMNANT)
             if (me_already_squared) then
                call term%isolated%setup_identity_trace &
                     (core, mask_in, .true., .false.)
             else
                call term%isolated%setup_square_trace &
                     (core, mask_in, term%config%col, .false.)
             end if
          end select
       class default
          call term%isolated%setup_square_trace &
               (core, mask_in, term%config%col, .false.)
     end select
     if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL .and. &
          term%config%i_term_global == term%config%i_sub) .or. &
          term%nlo_type == NLO_MISMATCH) then
        n_sub = term%get_n_sub ()
     else if (term%nlo_type == NLO_DGLAP) then
        n_sub = n_beams_rescaled
     else
        !!! No integration of real subtraction in interactions yet
        n_sub = 0
     end if
     keep_fs_flavors = keep_fs_flavors .or. me_already_squared
     requires_extended_sf = term%nlo_type == NLO_DGLAP .or. &
          (term%is_subtraction () .and. process%pcm_contains_pdfs ())
     call term%connected%setup_connected_trace (term%isolated, &
          undo_helicities = undo_helicities (core, me_already_squared), &
          keep_fs_flavors = keep_fs_flavors, &
          requires_extended_sf = requires_extended_sf)
     associate (int_eff => term%isolated%int_eff)
       state_matrix => int_eff%get_state_matrix_ptr ()
       n_tot = int_eff%get_n_tot  ()
       flv_int = quantum_numbers_get_flavor &
            (state_matrix%get_quantum_number (1))
       allocate (f_in (n_in))
       f_in = flv_int(1:n_in)
       deallocate (flv_int)
     end associate
     n_in = term%connected%trace%get_n_in ()
     n_vir = term%connected%trace%get_n_vir ()
     n_out = term%connected%trace%get_n_out ()
     allocate (f_out (n_out))
     do j = 1, n_out
        call term%connected%trace%find_source &
             (n_in + n_vir + j, src_int, i)
        if (associated (src_int)) then
           state_matrix => src_int%get_state_matrix_ptr ()
           flv_src = quantum_numbers_get_flavor &
                (state_matrix%get_quantum_number (1))
           f_out(j) = flv_src(i)
           deallocate (flv_src)
        end if
     end do
 
     beam_config = process%get_beam_config ()
 
     call term%connected%setup_subevt (term%isolated%sf_chain_eff, &
          beam_config%data%flv, f_in, f_out)
     call term%connected%setup_var_list &
          (process%get_var_list_ptr (), beam_config%data)
 
     ! Does connected%trace never have any helicity qn?
     call term%init_interaction_qn_index (core, term%connected%trace, n_sub, &
          process%get_model_ptr (), is_polarized = .false.)
     call term%init_interaction_qn_index (core, term%int_hard, n_sub, process%get_model_ptr ())
     if (requires_extended_sf) then
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           n_in = config%region_data%get_n_in ()
           flv_born = config%region_data%get_flv_states_born ()
           flv_real = config%region_data%get_flv_states_real ()
           n_flv_born = config%region_data%get_n_flv_born ()
           n_flv_real = config%region_data%get_n_flv_real ()
           n_flv_total = n_flv_born + n_flv_real
           allocate (flv_pdf(n_in, n_flv_total), &
                qn_pdf(n_in, n_flv_total))
           call flv_pdf(:, :n_flv_born)%init (flv_born(:n_in, :))
           call flv_pdf(:, n_flv_born + 1:n_flv_total)%init (flv_real(:n_in, :))
           call qn_pdf%init (flv_pdf)
           call sf_chain_int%init_qn_index (qn_pdf, n_flv_born, n_flv_real)
        end select
     end if
   contains
 
    function undo_helicities (core, me_squared) result (val)
      logical :: val
      class(prc_core_t), intent(in) :: core
      logical, intent(in) :: me_squared
      select type (core)
      class is (prc_external_t)
         val = me_squared .and. .not. core%includes_polarization ()
      class default
         val = .false.
      end select
    end function undo_helicities
 
    subroutine reduce_interaction (int, polarized_beams, keep_fs_flavors, &
       keep_colors)
      type(interaction_t), intent(inout) :: int
      logical, intent(in) :: polarized_beams
      logical, intent(in) :: keep_fs_flavors, keep_colors
      type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
      logical, dimension(:), allocatable :: mask_f, mask_c, mask_h
      integer :: n_tot, n_in
      n_in = int%get_n_in (); n_tot = int%get_n_tot ()
      allocate (qn_mask (n_tot))
      allocate (mask_f (n_tot), mask_c (n_tot), mask_h (n_tot))
      mask_c = .not. keep_colors
      mask_f (1 : n_in) = .false.
      if (keep_fs_flavors) then
         mask_f (n_in + 1 : ) = .false.
      else
         mask_f (n_in + 1 : ) = .true.
      end if
      if (polarized_beams) then
         mask_h (1 : n_in) = .false.
      else
         mask_h (1 : n_in) = .true.
      end if
      mask_h (n_in + 1 : ) = .true.
      call qn_mask%init (mask_f, mask_c, mask_h)
      call int%reduce_state_matrix (qn_mask, keep_order = .true.)
    end subroutine reduce_interaction
 
 <<Instances: term instance init: procedures>>
   end subroutine term_instance_init
 
 @ %def term_instance_init
 @ Set up index mapping from state matrix to index pair [[i_flv]], [[i_sub]].
 <<Instances: public>>=
   public :: setup_interaction_qn_index
 <<Instances: procedures>>=
   subroutine setup_interaction_qn_index (int, data, qn_config, n_sub, is_polarized)
     class(interaction_t), intent(inout) :: int
     class(process_constants_t), intent(in) :: data
     type(quantum_numbers_t), dimension(:, :), intent(in) :: qn_config
     integer, intent(in) :: n_sub
     logical, intent(in) :: is_polarized
     integer :: i
     type(quantum_numbers_t), dimension(:, :), allocatable :: qn_hel
     if (is_polarized) then
        call setup_interaction_qn_hel (int, data, qn_hel)
        call int%init_qn_index (qn_config, n_sub, qn_hel)
        call int%set_qn_index_helicity_flip (.true.)
     else
        call int%init_qn_index (qn_config, n_sub)
     end if
   end subroutine setup_interaction_qn_index
 
 @ %def setup_interaction_qn_index
 @ Set up beam polarisation quantum numbers, if beam polarisation is required.
 
 We retrieve the full helicity information from [[term%config%data]] and reduce
 the information only to the inital state. Afterwards, we uniquify the initial
 state polarization by a applying an index (hash) table.
 
 The helicity information is fed into an array of quantum numbers to assign
 flavor, helicity and subtraction indices correctly to their matrix element.
 <<Instances: public>>=
   public :: setup_interaction_qn_hel
 <<Instances: procedures>>=
    subroutine setup_interaction_qn_hel (int, data, qn_hel)
      class(interaction_t), intent(in) :: int
      class(process_constants_t), intent(in) :: data
      type(quantum_numbers_t), dimension(:, :), allocatable, intent(out) :: qn_hel
      type(helicity_t), dimension(:), allocatable :: hel
      integer, dimension(:), allocatable :: index_table
      integer, dimension(:, :), allocatable :: hel_state
      integer :: i, j, n_hel_unique
      associate (n_in => int%get_n_in (), n_tot => int%get_n_tot ())
        allocate (hel_state (n_tot, data%get_n_hel ()), &
             source = data%hel_state)
        allocate (index_table (data%get_n_hel ()), &
             source = 0)
        forall (j=1:data%get_n_hel (), i=n_in+1:n_tot) hel_state(i, j) = 0
        n_hel_unique = 0
        HELICITY: do i = 1, data%get_n_hel ()
           do j = 1, data%get_n_hel ()
              if (index_table (j) == 0) then
                 index_table(j) = i; n_hel_unique = n_hel_unique + 1
                 cycle HELICITY
              else if (all (hel_state(:, i) == &
                   hel_state(:, index_table(j)))) then
                 cycle HELICITY
              end if
           end do
        end do HELICITY
        allocate (qn_hel (n_tot, n_hel_unique))
        allocate (hel (n_tot))
        do j = 1, n_hel_unique
           call hel%init (hel_state(:, index_table(j)))
           call qn_hel(:, j)%init (hel)
        end do
      end associate
    end subroutine setup_interaction_qn_hel
 
 @ %def setup_interaction_qn_hel
 @
 <<Instances: term instance: TBP>>=
   procedure :: init_interaction_qn_index => term_instance_init_interaction_qn_index
 <<Instances: procedures>>=
   subroutine term_instance_init_interaction_qn_index (term, core, int, n_sub, &
          model, is_polarized)
     class(term_instance_t), intent(inout), target :: term
     class(prc_core_t), intent(in) :: core
     class(interaction_t), intent(inout) :: int
     integer, intent(in) :: n_sub
     class(model_data_t), intent(in) :: model
     logical, intent(in), optional :: is_polarized
     logical :: polarized
     type(quantum_numbers_t), dimension(:, :), allocatable :: qn_config
     integer, dimension(:,:), allocatable :: flv_born
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     select type (core)
     class is (prc_external_t)
        if (present (is_polarized)) then
           polarized = is_polarized
        else
           polarized = core%includes_polarization ()
        end if
        select type (pcm_instance => term%pcm_instance)
        type is (pcm_instance_nlo_t)
           associate (is_born => .not. (term%nlo_type == NLO_REAL .and. &
                   .not. term%is_subtraction ()))
              select type (config => pcm_instance%config)
              type is (pcm_nlo_t)
                 qn_config = config%get_qn (is_born)
              end select
              call setup_interaction_qn_index (int, term%config%data, &
                   qn_config, n_sub, polarized)
           end associate
        class default
           call term%config%data%get_flv_state (flv_born)
           allocate (flv (size (flv_born, dim = 1)))
           allocate (qn_config (size (flv_born, dim = 1), size (flv_born, dim = 2)))
           do i = 1, core%data%n_flv
              call flv%init (flv_born(:,i), model)
              call qn_config(:, i)%init (flv)
           end do
           call setup_interaction_qn_index (int, term%config%data, &
                qn_config, n_sub, polarized)
        end select
     class default
        call int%init_qn_index ()
     end select
   end subroutine term_instance_init_interaction_qn_index
 
 @ %def term_instance_init_interaction_qn_index
 @
 <<Instances: term instance: TBP>>=
   procedure :: init_from_process => term_instance_init_from_process
 <<Instances: procedures>>=
   subroutine term_instance_init_from_process (term_instance, &
          process, i, pcm_instance, sf_chain)
     class(term_instance_t), intent(inout), target :: term_instance
     type(process_t), intent(in), target :: process
     integer, intent(in) :: i
     class(pcm_instance_t), intent(in), target :: pcm_instance
     type(sf_chain_t), intent(in), target :: sf_chain
     type(process_term_t) :: term
     integer :: i_component
     logical :: requires_extended_sf
     term = process%get_term_ptr (i)
     i_component = term%i_component
     if (i_component /= 0) then
        term_instance%pcm_instance => pcm_instance
        term_instance%nlo_type = process%get_nlo_type_component (i_component)
        requires_extended_sf = term_instance%nlo_type == NLO_DGLAP .or. &
               (term_instance%nlo_type == NLO_REAL .and. process%get_i_sub (i) == i)
        call term_instance%setup_kinematics (sf_chain, &
             process%get_beam_config_ptr (), &
             process%get_phs_config (i_component), &
             requires_extended_sf)
        call term_instance%init (process, i, &
             real_finite = process%component_is_real_finite (i_component))
        select type (phs => term_instance%k_term%phs)
        type is (phs_fks_t)
           call term_instance%set_emitter (process%get_pcm_ptr ())
           call term_instance%setup_fks_kinematics (process%get_var_list_ptr (), &
                process%get_beam_config_ptr ())
        end select
        call term_instance%set_threshold (process%get_pcm_ptr ())
        call term_instance%setup_expressions (process%get_meta (), process%get_config ())
     end if
   end subroutine term_instance_init_from_process
 
 @ %def term_instance_init_from_process
 @ Initialize the seed-kinematics configuration.  All subobjects are
 allocated explicitly.
 <<Instances: term instance: TBP>>=
   procedure :: setup_kinematics => term_instance_setup_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_setup_kinematics (term, sf_chain, &
      beam_config, phs_config, extended_sf)
     class(term_instance_t), intent(inout) :: term
     type(sf_chain_t), intent(in), target :: sf_chain
     type(process_beam_config_t), intent(in), target :: beam_config
     class(phs_config_t), intent(in), target :: phs_config
     logical, intent(in) :: extended_sf
     select type (config => term%pcm_instance%config)
     type is (pcm_nlo_t)
        call term%k_term%init_sf_chain (sf_chain, beam_config, &
             extended_sf = config%has_pdfs .and. extended_sf)
     class default
        call term%k_term%init_sf_chain (sf_chain, beam_config)
     end select
     !!! Add one for additional Born matrix element
     call term%k_term%init_phs (phs_config)
     call term%k_term%set_nlo_info (term%nlo_type)
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        call phs%allocate_momenta (phs_config, &
             .not. (term%nlo_type == NLO_REAL))
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           call config%region_data%init_phs_identifiers (phs%phs_identifiers)
           !!! The triple select type pyramid of doom
           select type (pcm_instance => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              if (allocated (pcm_instance%real_kinematics%alr_to_i_phs)) &
                   call config%region_data%set_alr_to_i_phs (phs%phs_identifiers, &
                        pcm_instance%real_kinematics%alr_to_i_phs)
           end select
        end select
     end select
   end subroutine term_instance_setup_kinematics
 
 @ %def term_instance_setup_kinematics
 @
 <<Instances: term instance: TBP>>=
   procedure :: setup_fks_kinematics => term_instance_setup_fks_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_setup_fks_kinematics (term, var_list, beam_config)
     class(term_instance_t), intent(inout), target :: term
     type(var_list_t), intent(in) :: var_list
     type(process_beam_config_t), intent(in) :: beam_config
     integer :: mode
     logical :: singular_jacobian
     if (.not. (term%nlo_type == NLO_REAL .or. term%nlo_type == NLO_DGLAP .or. &
        term%nlo_type == NLO_MISMATCH)) return
     singular_jacobian = var_list%get_lval (var_str ("?powheg_use_singular_jacobian"))
     if (term%nlo_type == NLO_REAL) then
        mode = check_generator_mode (GEN_REAL_PHASE_SPACE)
     else if (term%nlo_type == NLO_MISMATCH) then
        mode = check_generator_mode (GEN_SOFT_MISMATCH)
     else
        mode = PHS_MODE_UNDEFINED
     end if
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           select type (pcm_instance => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              call config%setup_phs_generator (pcm_instance, &
                   phs%generator, phs%config%sqrts, mode, singular_jacobian)
              if (beam_config%has_structure_function ()) then
                 pcm_instance%isr_kinematics%isr_mode = SQRTS_VAR
              else
                 pcm_instance%isr_kinematics%isr_mode = SQRTS_FIXED
              end if
              if (debug_on) call msg_debug (D_PHASESPACE, "isr_mode: ", pcm_instance%isr_kinematics%isr_mode)
           end select
        end select
     class default
        call msg_fatal ("Phase space should be an FKS phase space!")
     end select
   contains
     function check_generator_mode (gen_mode_default) result (gen_mode)
        integer :: gen_mode
        integer, intent(in) :: gen_mode_default
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           associate (settings => config%settings)
              if (settings%test_coll_limit .and. settings%test_anti_coll_limit) &
                 call msg_fatal ("You cannot check the collinear and anti-collinear limit "&
                      &"at the same time!")
              if (settings%test_soft_limit .and. .not. settings%test_coll_limit &
                   .and. .not. settings%test_anti_coll_limit) then
                 gen_mode = GEN_SOFT_LIMIT_TEST
              else if (.not. settings%test_soft_limit .and. settings%test_coll_limit) then
                 gen_mode = GEN_COLL_LIMIT_TEST
              else if (.not. settings%test_soft_limit .and. settings%test_anti_coll_limit) then
                 gen_mode = GEN_ANTI_COLL_LIMIT_TEST
              else if (settings%test_soft_limit .and. settings%test_coll_limit) then
                 gen_mode = GEN_SOFT_COLL_LIMIT_TEST
              else if (settings%test_soft_limit .and. settings%test_anti_coll_limit) then
                 gen_mode = GEN_SOFT_ANTI_COLL_LIMIT_TEST
              else
                 gen_mode = gen_mode_default
              end if
           end associate
        end select
     end function check_generator_mode
   end subroutine term_instance_setup_fks_kinematics
 
 @ %def term_instance_setup_fks_kinematics
 @ Set up seed kinematics, starting from the MC parameter set given as
 argument.  As a result, the [[k_seed]] kinematics object is evaluated
 (except for the structure-function matrix-element evaluation, which we
 postpone until we know the factorization scale), and we have a valid
 [[p_seed]] momentum array.
 <<Instances: term instance: TBP>>=
   procedure :: compute_seed_kinematics => term_instance_compute_seed_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_compute_seed_kinematics &
        (term, mci_work, phs_channel, success)
     class(term_instance_t), intent(inout), target :: term
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     logical, intent(out) :: success
     call term%k_term%compute_selected_channel &
          (mci_work, phs_channel, term%p_seed, success)
   end subroutine term_instance_compute_seed_kinematics
 
 @ %def term_instance_compute_seed_kinematics
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_radiation_kinematics => term_instance_evaluate_radiation_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_radiation_kinematics (term, x)
     class(term_instance_t), intent(inout) :: term
     real(default), dimension(:), intent(in) :: x
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) &
              call term%k_term%evaluate_radiation_kinematics (x)
     end select
   end subroutine term_instance_evaluate_radiation_kinematics
 
 @ %def term_instance_evaluate_radiation_kinematics
 @
 <<Instances: term instance: TBP>>=
   procedure :: compute_xi_ref_momenta => term_instance_compute_xi_ref_momenta
 <<Instances: procedures>>=
   subroutine term_instance_compute_xi_ref_momenta (term)
     class(term_instance_t), intent(inout) :: term
     select type (pcm => term%pcm_instance%config)
     type is (pcm_nlo_t)
        call term%k_term%compute_xi_ref_momenta (pcm%region_data, term%nlo_type)
     end select
   end subroutine term_instance_compute_xi_ref_momenta
 
 @ %def term_instance_compute_xi_ref_momenta
 @
 <<Instances: term instance: TBP>>=
   procedure :: generate_fsr_in => term_instance_generate_fsr_in
 <<Instances: procedures>>=
   subroutine term_instance_generate_fsr_in (term)
     class(term_instance_t), intent(inout) :: term
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        call phs%generate_fsr_in ()
     end select
   end subroutine term_instance_generate_fsr_in
 
 @ %def term_instance_generate_fsr_in
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_projections => term_instance_evaluate_projections
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_projections (term)
     class(term_instance_t), intent(inout) :: term
     if (term%k_term%threshold .and. term%nlo_type > BORN) then
        if (debug2_active (D_THRESHOLD)) &
             print *, 'Evaluate on-shell projection: ', &
             char (component_status (term%nlo_type))
        select type (pcm_instance => term%pcm_instance)
        type is (pcm_instance_nlo_t)
           call term%k_term%threshold_projection (pcm_instance, term%nlo_type)
        end select
     end if
   end subroutine term_instance_evaluate_projections
 
 @ %def term_instance_evaluate_projections
 @
 <<Instances: term instance: TBP>>=
   procedure :: redo_sf_chain => term_instance_redo_sf_chain
 <<Instances: procedures>>=
   subroutine term_instance_redo_sf_chain (term, mci_work, phs_channel)
     class(term_instance_t), intent(inout) :: term
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     real(default), dimension(:), allocatable :: x
     integer :: sf_channel, n
     real(default) :: xi, y
     n = size (mci_work%get_x_strfun ())
     if (n > 0) then
        allocate (x(n))
        x = mci_work%get_x_strfun ()
        associate (k => term%k_term)
           sf_channel = k%phs%config%get_sf_channel (phs_channel)
           call k%sf_chain%compute_kinematics (sf_channel, x)
           deallocate (x)
        end associate
     end if
   end subroutine term_instance_redo_sf_chain
 
 @ %def term_instance_redo_sf_chain
 @ Inverse: recover missing parts of the kinematics, given a complete
 set of seed momenta.  Select a channel and reconstruct the MC parameter set.
 <<Instances: term instance: TBP>>=
   procedure :: recover_mcpar => term_instance_recover_mcpar
 <<Instances: procedures>>=
   subroutine term_instance_recover_mcpar (term, mci_work, phs_channel)
     class(term_instance_t), intent(inout), target :: term
     type(mci_work_t), intent(inout) :: mci_work
     integer, intent(in) :: phs_channel
     call term%k_term%recover_mcpar (mci_work, phs_channel, term%p_seed)
   end subroutine term_instance_recover_mcpar
 
 @ %def term_instance_recover_mcpar
 @ Part of [[recover_mcpar]], separately accessible.  Reconstruct all
 kinematics data in the structure-function chain instance.
 <<Instances: term instance: TBP>>=
   procedure :: recover_sfchain => term_instance_recover_sfchain
 <<Instances: procedures>>=
   subroutine term_instance_recover_sfchain (term, channel)
     class(term_instance_t), intent(inout), target :: term
     integer, intent(in) :: channel
     call term%k_term%recover_sfchain (channel, term%p_seed)
   end subroutine term_instance_recover_sfchain
 
 @ %def term_instance_recover_sfchain
 @ Compute the momenta in the hard interactions, one for each term that
 constitutes this process component.  In simple cases this amounts to
 just copying momenta.  In more advanced cases, we may generate
 distinct sets of momenta from the seed kinematics.
 
 The interactions in the term instances are accessed individually.  We may
 choose to calculate all terms at once together with the seed kinematics, use
 [[component%core_state]] for storage, and just fill the interactions here.
 <<Instances: term instance: TBP>>=
   procedure :: compute_hard_kinematics => &
        term_instance_compute_hard_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_compute_hard_kinematics (term, skip_term, success)
     class(term_instance_t), intent(inout) :: term
     integer, intent(in), optional :: skip_term
     logical, intent(out) :: success
     type(vector4_t), dimension(:), allocatable :: p
     if (allocated (term%core_state)) &
        call term%core_state%reset_new_kinematics ()
     if (present (skip_term)) then
        if (term%config%i_term_global == skip_term) return
     end if
 
     if (term%nlo_type == NLO_REAL .and. term%k_term%emitter >= 0) then
        call term%k_term%evaluate_radiation (term%p_seed, p, success)
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           if (config%dalitz_plot%active) then
              if (term%k_term%emitter > term%k_term%n_in) then
                 if (p(term%k_term%emitter)**2 > tiny_07) &
                      call config%register_dalitz_plot (term%k_term%emitter, p)
              end if
           end if
        end select
     else if (is_subtraction_component (term%k_term%emitter, term%nlo_type)) then
        call term%k_term%modify_momenta_for_subtraction (term%p_seed, p)
        success = .true.
     else
        allocate (p (size (term%p_seed))); p = term%p_seed
        success = .true.
     end if
     call term%int_hard%set_momenta (p)
     if (debug_on) then
        call msg_debug2 (D_REAL, "inside compute_hard_kinematics")
        if (debug2_active (D_REAL))  call vector4_write_set (p)
     end if
   end subroutine term_instance_compute_hard_kinematics
 
 @ %def term_instance_compute_hard_kinematics
 @ Here, we invert this.  We fetch the incoming momenta which reside
 in the appropriate [[sf_chain]] object, stored within the [[k_seed]]
 subobject.  On the other hand, we have the outgoing momenta of the
 effective interaction.  We rely on the process core to compute the
 remaining seed momenta and to fill the momenta within the hard
 interaction.  (The latter is trivial if hard and effective interaction
 coincide.)
 
 After this is done, the incoming momenta in the trace evaluator that
 corresponds to the hard (effective) interaction, are still
 left undefined.  We remedy this by calling [[receive_kinematics]] once.
 <<Instances: term instance: TBP>>=
   procedure :: recover_seed_kinematics => &
        term_instance_recover_seed_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_recover_seed_kinematics (term)
     class(term_instance_t), intent(inout) :: term
     integer :: n_in
     n_in = term%k_term%n_in
     call term%k_term%get_incoming_momenta (term%p_seed(1:n_in))
     associate (int_eff => term%isolated%int_eff)
        call int_eff%set_momenta (term%p_seed(1:n_in), outgoing = .false.)
        term%p_seed(n_in + 1 : ) = int_eff%get_momenta (outgoing = .true.)
     end associate
     call term%isolated%receive_kinematics ()
   end subroutine term_instance_recover_seed_kinematics
 
 @ %def term_instance_recover_seed_kinematics
 @ Compute the integration parameters for all channels except the selected
 one.
 <<Instances: term instance: TBP>>=
   procedure :: compute_other_channels => &
        term_instance_compute_other_channels
 <<Instances: procedures>>=
   subroutine term_instance_compute_other_channels &
        (term, mci_work, phs_channel)
     class(term_instance_t), intent(inout), target :: term
     type(mci_work_t), intent(in) :: mci_work
     integer, intent(in) :: phs_channel
     call term%k_term%compute_other_channels (mci_work, phs_channel)
   end subroutine term_instance_compute_other_channels
 
 @ %def term_instance_compute_other_channels
 @ Recover beam momenta, i.e., return the beam momenta as currently
 stored in the kinematics subobject to their source.  This is a side effect.
 <<Instances: term instance: TBP>>=
   procedure :: return_beam_momenta => term_instance_return_beam_momenta
 <<Instances: procedures>>=
   subroutine term_instance_return_beam_momenta (term)
     class(term_instance_t), intent(in) :: term
     call term%k_term%return_beam_momenta ()
   end subroutine term_instance_return_beam_momenta
 
 @ %def term_instance_return_beam_momenta
-@
+@ Applies the real partition by computing the real partition function $F(\Phi)$
+and multiplying either $\mathcal{R}_\text{sin} = \mathcal{R} \cdot F$ or
+$\mathcal{R}_\text{fin} = \mathcal{R} \cdot (1-F)$.
 <<Instances: term instance: TBP>>=
   procedure :: apply_real_partition => term_instance_apply_real_partition
 <<Instances: procedures>>=
   subroutine term_instance_apply_real_partition (term, process)
     class(term_instance_t), intent(inout) :: term
     type(process_t), intent(in) :: process
     real(default) :: f, sqme
     integer :: i_component
-    integer :: i_amp, n_amps
+    integer :: i_amp, n_amps, qn_index
     logical :: is_subtraction
     i_component = term%config%i_component
     if (process%component_is_selected (i_component) .and. &
            process%get_component_nlo_type (i_component) == NLO_REAL) then
        is_subtraction = process%get_component_type (i_component) == COMP_REAL_SING &
             .and. term%k_term%emitter < 0
        if (is_subtraction) return
+       select case (process%get_component_type (i_component))
+       case (COMP_REAL_FIN)
+          call term%connected%trace%set_duplicate_flv_zero()
+       end select
        select type (pcm => process%get_pcm_ptr ())
        type is (pcm_nlo_t)
           f = pcm%real_partition%get_f (term%p_hard)
        end select
        n_amps = term%connected%trace%get_n_matrix_elements ()
        do i_amp = 1, n_amps
-          sqme = real (term%connected%trace%get_matrix_element ( &
-               term%connected%trace%get_qn_index (i_amp, i_sub = 0)))
+          qn_index = term%connected%trace%get_qn_index (i_amp, i_sub = 0)
+          sqme = real (term%connected%trace%get_matrix_element (qn_index))
           if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_apply_real_partition")
           select type (pcm => term%pcm_instance%config)
           type is (pcm_nlo_t)
              select case (process%get_component_type (i_component))
              case (COMP_REAL_FIN, COMP_REAL_SING)
                 select case (process%get_component_type (i_component))
                 case (COMP_REAL_FIN)
                    if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real finite")
                    sqme = sqme * (one - f)
                 case (COMP_REAL_SING)
                    if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "Real singular")
                    sqme = sqme * f
                 end select
              end select
           end select
           if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "apply_damping: sqme", sqme)
-          call term%connected%trace%set_matrix_element (i_amp, cmplx (sqme, zero, default))
+          call term%connected%trace%set_matrix_element (qn_index, cmplx (sqme, zero, default))
        end do
     end if
   end subroutine term_instance_apply_real_partition
 
 @ %def term_instance_apply_real_partition
 @
 <<Instances: term instance: TBP>>=
   procedure :: get_lorentz_transformation => term_instance_get_lorentz_transformation
 <<Instances: procedures>>=
   function term_instance_get_lorentz_transformation (term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(term_instance_t), intent(in) :: term
     lt = term%k_term%phs%get_lorentz_transformation ()
   end function term_instance_get_lorentz_transformation
 
 @ %def term_instance_get_lorentz_transformation
 @
 <<Instances: term instance: TBP>>=
   procedure :: get_p_hard => term_instance_get_p_hard
 <<Instances: procedures>>=
   pure function term_instance_get_p_hard (term_instance) result (p_hard)
     type(vector4_t), dimension(:), allocatable :: p_hard
     class(term_instance_t), intent(in) :: term_instance
     allocate (p_hard (size (term_instance%p_hard)))
     p_hard = term_instance%p_hard
   end function term_instance_get_p_hard
 
 @ %def term_instance_get_p_hard
 @
 <<Instances: term instance: TBP>>=
   procedure :: set_emitter => term_instance_set_emitter
 <<Instances: procedures>>=
   subroutine term_instance_set_emitter (term, pcm)
     class(term_instance_t), intent(inout) :: term
     class(pcm_t), intent(in) :: pcm
     integer :: i_phs
     logical :: set_emitter
     select type (pcm)
     type is (pcm_nlo_t)
        !!! Without resonances, i_alr = i_phs
        i_phs = term%config%i_term
        term%k_term%i_phs = term%config%i_term
        select type (phs => term%k_term%phs)
        type is (phs_fks_t)
           set_emitter = i_phs <= pcm%region_data%n_phs .and. term%nlo_type == NLO_REAL
           if (set_emitter) then
              term%k_term%emitter = phs%phs_identifiers(i_phs)%emitter
              select type (pcm => term%pcm_instance%config)
              type is (pcm_nlo_t)
                 if (allocated (pcm%region_data%i_phs_to_i_con)) &
                    term%k_term%i_con = pcm%region_data%i_phs_to_i_con (i_phs)
              end select
           end if
        end select
     end select
   end subroutine term_instance_set_emitter
 
 @ %def term_instance_set_emitter
 @
 <<Instances: term instance: TBP>>=
   procedure :: set_threshold => term_instance_set_threshold
 <<Instances: procedures>>=
   subroutine term_instance_set_threshold (term, pcm)
     class(term_instance_t), intent(inout) :: term
     class(pcm_t), intent(in) :: pcm
     select type (pcm)
     type is (pcm_nlo_t)
        term%k_term%threshold = pcm%settings%factorization_mode == FACTORIZATION_THRESHOLD
     class default
        term%k_term%threshold = .false.
     end select
   end subroutine term_instance_set_threshold
 
 @ %def term_instance_set_threshold
 @ For initializing the expressions, we need the local variable list and the
 parse trees.
 <<Instances: term instance: TBP>>=
   procedure :: setup_expressions => term_instance_setup_expressions
 <<Instances: procedures>>=
   subroutine term_instance_setup_expressions (term, meta, config)
     class(term_instance_t), intent(inout), target :: term
     type(process_metadata_t), intent(in), target :: meta
     type(process_config_data_t), intent(in) :: config
     if (allocated (config%ef_cuts)) &
          call term%connected%setup_cuts (config%ef_cuts)
     if (allocated (config%ef_scale)) &
          call term%connected%setup_scale (config%ef_scale)
     if (allocated (config%ef_fac_scale)) &
          call term%connected%setup_fac_scale (config%ef_fac_scale)
     if (allocated (config%ef_ren_scale)) &
          call term%connected%setup_ren_scale (config%ef_ren_scale)
     if (allocated (config%ef_weight)) &
          call term%connected%setup_weight (config%ef_weight)
   end subroutine term_instance_setup_expressions
 
 @ %def term_instance_setup_expressions
 @ Prepare the extra evaluators that we need for processing events.
 
 The matrix elements we get from OpenLoops and GoSam are already squared
 and summed over color and helicity. They should not be squared again.
 <<Instances: term instance: TBP>>=
   procedure :: setup_event_data => term_instance_setup_event_data
 <<Instances: procedures>>=
   subroutine term_instance_setup_event_data (term, core, model)
     class(term_instance_t), intent(inout), target :: term
     class(prc_core_t), intent(in) :: core
     class(model_data_t), intent(in), target :: model
     integer :: n_in
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in
     n_in = term%int_hard%get_n_in ()
     allocate (mask_in (n_in))
     mask_in = term%k_term%sf_chain%get_out_mask ()
     call setup_isolated (term%isolated, core, model, mask_in, term%config%col)
     call setup_connected (term%connected, term%isolated, term%nlo_type)
   contains
     subroutine setup_isolated (isolated, core, model, mask, color)
       type(isolated_state_t), intent(inout), target :: isolated
       class(prc_core_t), intent(in) :: core
       class(model_data_t), intent(in), target :: model
       type(quantum_numbers_mask_t), intent(in), dimension(:) :: mask
       integer, intent(in), dimension(:) :: color
       select type (core)
       class is (prc_blha_t)
          call isolated%matrix%init_identity(isolated%int_eff)
          isolated%has_matrix = .true.
       class default
          call isolated%setup_square_matrix (core, model, mask, color)
       end select
       !!! TODO (PS-09-10-20) We should not square the flows if they come from BLHA either
       call isolated%setup_square_flows (core, model, mask)
     end subroutine setup_isolated
 
     subroutine setup_connected (connected, isolated, nlo_type)
       type(connected_state_t), intent(inout), target :: connected
       type(isolated_state_t), intent(in), target :: isolated
       integer :: nlo_type
       type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
       call connected%setup_connected_matrix (isolated)
       if (term%nlo_type == NLO_VIRTUAL .or. (term%nlo_type == NLO_REAL &
            .and. term%config%i_term_global == term%config%i_sub) &
            .or. term%nlo_type == NLO_DGLAP) then
          !!! We do not care about the subtraction matrix elements in
          !!! connected%matrix, because all entries there are supposed
          !!! to be squared. To be able to match with flavor quantum numbers,
          !!! we remove the subtraction quantum entries from the state matrix.
          allocate (mask (connected%matrix%get_n_tot()))
          call mask%set_sub (1)
          call connected%matrix%reduce_state_matrix (mask, keep_order = .true.)
       end if
       call term%init_interaction_qn_index (core, connected%matrix, 0, model, &
            is_polarized = .false.)
       call connected%setup_connected_flows (isolated)
       call connected%setup_state_flv (isolated%get_n_out ())
     end subroutine setup_connected
   end subroutine term_instance_setup_event_data
 
 @ %def term_instance_setup_event_data
 @ Color-correlated matrix elements should be obtained from
 the external BLHA provider. According to the standard, the
 matrix elements output is a one-dimensional array. For FKS
 subtraction, we require the  matrix $B_{ij}$. BLHA prescribes
 a mapping $(i, j) \to k$, where $k$ is the index of the matrix
 element in the output array. It focusses on the off-diagonal entries,
 i.e. $i \neq j$. The subroutine [[blha_color_c_fill_offdiag]] realizes
 this mapping. The diagonal entries can simply be obtained as
 the product of the Born matrix element and either $C_A$ or $C_F$,
 which is achieved by [[blha_color_c_fill_diag]].
 For simple processes, i.e. those with only one color line, it is
 $B_{ij} = C_F \cdot B$. For those, we keep the possibility of computing
 color correlations by a multiplication of the Born matrix element with $C_F$.
 It is triggered by the [[use_internal_color_correlations]] flag and should
 be used only for testing purposes. However, it is also used for
 the threshold computation where the process is well-defined and fixed.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_color_correlations => &
      term_instance_evaluate_color_correlations
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_color_correlations (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     integer :: i_flv_born
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           if (debug_on) call msg_debug2 (D_SUBTRACTION, &
                "term_instance_evaluate_color_correlations: " // &
                "use_internal_color_correlations:", &
                config%settings%use_internal_color_correlations)
           if (debug_on) call msg_debug2 (D_SUBTRACTION, "fac_scale", term%fac_scale)
 
           do i_flv_born = 1, config%region_data%n_flv_born
              select case (term%nlo_type)
              case (NLO_REAL)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      pcm_instance%real_sub%sqme_born (i_flv_born), &
                      pcm_instance%real_sub%sqme_born_color_c (:, :, i_flv_born))
              case (NLO_MISMATCH)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      pcm_instance%soft_mismatch%sqme_born (i_flv_born), &
                      pcm_instance%soft_mismatch%sqme_born_color_c (:, :, i_flv_born))
              case (NLO_VIRTUAL)
                 !!! This is just a copy of the above with a different offset and can for sure be unified
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      -one, pcm_instance%virtual%sqme_color_c (:, :, i_flv_born))
              end select
           end do
        end select
     end select
   contains
     function get_trivial_cf_factors (n_tot, flv, factorization_mode) result (beta_ij)
       integer, intent(in) :: n_tot, factorization_mode
       integer, intent(in), dimension(:) :: flv
       real(default), dimension(n_tot, n_tot) :: beta_ij
       if (factorization_mode == NO_FACTORIZATION) then
          beta_ij = get_trivial_cf_factors_default (n_tot, flv)
       else
          beta_ij = get_trivial_cf_factors_threshold (n_tot, flv)
       end if
     end function get_trivial_cf_factors
 
     function get_trivial_cf_factors_default (n_tot, flv) result (beta_ij)
       integer, intent(in) :: n_tot
       integer, intent(in), dimension(:) :: flv
       real(default), dimension(n_tot, n_tot) :: beta_ij
       integer :: i, j
       beta_ij = zero
       if (count (is_quark (flv)) == 2) then
          do i = 1, n_tot
             do j = 1, n_tot
                if (is_quark(flv(i)) .and. is_quark(flv(j))) then
                   if (i == j) then
                      beta_ij(i,j)= -cf
                   else
                      beta_ij(i,j) = cf
                   end if
                end if
             end do
          end do
       end if
     end function get_trivial_cf_factors_default
 
     function get_trivial_cf_factors_threshold (n_tot, flv) result (beta_ij)
       integer, intent(in) :: n_tot
       integer, intent(in), dimension(:) :: flv
       real(default), dimension(n_tot, n_tot) :: beta_ij
       integer :: i
       beta_ij = zero
       do i = 1, 4
          beta_ij(i,i) = -cf
       end do
       beta_ij(1,2) = cf; beta_ij(2,1) = cf
       beta_ij(3,4) = cf; beta_ij(4,3) = cf
     end function get_trivial_cf_factors_threshold
 
     subroutine transfer_me_array_to_bij (pcm, i_flv, &
          sqme_born, sqme_color_c)
       type(pcm_nlo_t), intent(in) :: pcm
       integer, intent(in) :: i_flv
       real(default), intent(in) :: sqme_born
       real(default), dimension(:,:), intent(inout) :: sqme_color_c
       integer :: i_color_c, i_sub, n_offset
       real(default), dimension(:), allocatable :: sqme
       if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "transfer_me_array_to_bij")
       if (pcm%settings%use_internal_color_correlations) then
          !!! A negative value for sqme_born indicates that the Born matrix
          !!! element is multiplied at a different place, e.g. in the case
          !!! of the virtual component
          sqme_color_c = get_trivial_cf_factors &
               (pcm%region_data%get_n_legs_born (), &
               pcm%region_data%get_flv_states_born (i_flv), &
               pcm%settings%factorization_mode)
          if (sqme_born > zero) then
             sqme_color_c = sqme_born * sqme_color_c
          else if (sqme_born == zero) then
             sqme_color_c = zero
          end if
       else
          n_offset = 0
          if (term%nlo_type == NLO_VIRTUAL) then
             n_offset = 1
          else if (pcm%has_pdfs .and. term%is_subtraction ()) then
             n_offset = n_beams_rescaled
          end if
          allocate (sqme (term%get_n_sub_color ()), source = zero)
          do i_sub = 1, term%get_n_sub_color ()
             sqme(i_sub) = real(term%connected%trace%get_matrix_element ( &
                  term%connected%trace%get_qn_index (i_flv, i_sub = i_sub + n_offset)), &
                  default)
          end do
          call blha_color_c_fill_offdiag (pcm%region_data%n_legs_born, &
               sqme, sqme_color_c)
          call blha_color_c_fill_diag (real(term%connected%trace%get_matrix_element ( &
               term%connected%trace%get_qn_index (i_flv, i_sub = 0)), default), &
               pcm%region_data%get_flv_states_born (i_flv), &
               sqme_color_c)
       end if
     end subroutine transfer_me_array_to_bij
   end subroutine term_instance_evaluate_color_correlations
 
 @ %def term_instance_evaluate_color_correlations
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_charge_correlations => &
      term_instance_evaluate_charge_correlations
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_charge_correlations (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     integer :: i_flv_born
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           do i_flv_born = 1, config%region_data%n_flv_born
              select case (term%nlo_type)
              case (NLO_REAL)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      pcm_instance%real_sub%sqme_born (i_flv_born), &
                      pcm_instance%real_sub%sqme_born_charge_c (:, :, i_flv_born))
              case (NLO_MISMATCH)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      pcm_instance%soft_mismatch%sqme_born (i_flv_born), &
                      pcm_instance%soft_mismatch%sqme_born_charge_c (:, :, i_flv_born))
              case (NLO_VIRTUAL)
                 call transfer_me_array_to_bij (config, i_flv_born, &
                      one, pcm_instance%virtual%sqme_charge_c (:, :, i_flv_born))
              end select
           end do
        end select
     end select
   contains
     subroutine transfer_me_array_to_bij (pcm, i_flv, sqme_born, sqme_charge_c)
       type(pcm_nlo_t), intent(in) :: pcm
       integer, intent(in) :: i_flv
       real(default), intent(in) :: sqme_born
       real(default), dimension(:,:), intent(inout) :: sqme_charge_c
       integer :: n_legs_born, i, j
       real(default), dimension(:), allocatable :: sigma
       real(default), dimension(:), allocatable :: Q
       n_legs_born = pcm%region_data%n_legs_born
       associate (flv_born => pcm%region_data%flv_born(i_flv))
          allocate (sigma (n_legs_born), Q (size (flv_born%charge)))
          Q = flv_born%charge
          sigma(1:flv_born%n_in) = -one
          sigma(flv_born%n_in + 1: ) = one
       end associate
       do i = 1, n_legs_born
          do j = 1, n_legs_born
             sqme_charge_c(i, j) = sigma(i) * sigma(j) * Q(i) * Q(j) * (-one)
          end do
       end do
       sqme_charge_c = sqme_charge_c * sqme_born
     end subroutine transfer_me_array_to_bij
   end subroutine term_instance_evaluate_charge_correlations
 
 @ %def term_instance_evaluate_charge_correlations
 @ The information about spin correlations is not stored in the [[nlo_settings]] because
 it is only available after the [[fks_regions]] have been created.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_spin_correlations => term_instance_evaluate_spin_correlations
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_spin_correlations (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     integer :: i_flv, i_sub, i_emitter, emitter
     integer :: n_flv, n_sub_color, n_sub_spin, n_offset,i,j
     real(default), dimension(1:3, 1:3) :: sqme_spin_c
     real(default), dimension(:), allocatable :: sqme_spin_c_all
     real(default), dimension(:), allocatable :: sqme_spin_c_arr
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_spin_correlations")
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        if (pcm_instance%real_sub%requires_spin_correlations () &
             .and. term%nlo_type == NLO_REAL) then
           select type (core)
           type is (prc_openloops_t)
              select type (config => pcm_instance%config)
              type is (pcm_nlo_t)
                 n_flv = term%connected%trace%get_qn_index_n_flv ()
                 n_sub_color = term%get_n_sub_color ()
                 n_sub_spin = term%get_n_sub_spin ()
                 n_offset = 0; if (config%has_pdfs) n_offset = n_beams_rescaled
                 allocate (sqme_spin_c_arr(6))
                 do i_flv = 1, n_flv
                    allocate (sqme_spin_c_all(n_sub_spin))
                    do i_sub = 1, n_sub_spin
                       sqme_spin_c_all(i_sub) = real(term%connected%trace%get_matrix_element &
                            (term%connected%trace%get_qn_index (i_flv, &
                            i_sub = i_sub + n_offset + n_sub_color)), default)
                    end do
                    do i_emitter = 1, config%region_data%n_emitters
                       emitter = config%region_data%emitters(i_emitter)
                       if (emitter > 0) then
                          call split_array (sqme_spin_c_all, sqme_spin_c_arr)
                          do j = 1, size (sqme_spin_c, dim=2)
                             do i = j, size (sqme_spin_c, dim=1)
                                !!! Restoring the symmetric matrix packed into a 1-dim array
                                !!! c.f. [[prc_openloops_compute_sqme_spin_c]]
                                sqme_spin_c(i,j) = sqme_spin_c_arr(j + i * (i - 1) / 2)
                                if (i /= j) sqme_spin_c(j,i) = sqme_spin_c(i,j)
                             end do
                          end do
                          pcm_instance%real_sub%sqme_born_spin_c(:,:,emitter,i_flv) = sqme_spin_c
                       end if
                    end do
                    deallocate (sqme_spin_c_all)
                 end do
              end select
           class default
              call msg_fatal ("Spin correlations so far only supported by OpenLoops.")
           end select
        end if
     end select
   end subroutine term_instance_evaluate_spin_correlations
 
 @ %def term_instance_evaluate_spin_correlations
 @
 <<Instances: term instance: TBP>>=
   procedure :: apply_fks => term_instance_apply_fks
 <<Instances: procedures>>=
   subroutine term_instance_apply_fks (term, alpha_s_sub, alpha_qed_sub)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_s_sub, alpha_qed_sub
     real(default), dimension(:), allocatable :: sqme
     integer :: i, i_phs, emitter
     logical :: is_subtraction
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           if (term%connected%has_matrix) then
              allocate (sqme (config%get_n_alr ()))
           else
              allocate (sqme (1))
           end if
           sqme = zero
           select type (phs => term%k_term%phs)
           type is (phs_fks_t)
              if (pcm_instance%config%has_pdfs .and. &
                   config%settings%use_internal_color_correlations) then
                 call msg_fatal ("Color correlations for proton processes " // &
                      "so far only supported by OpenLoops.")
              end if
              call pcm_instance%set_real_and_isr_kinematics &
                   (phs%phs_identifiers, term%k_term%phs%get_sqrts ())
              if (term%k_term%emitter < 0) then
                 call pcm_instance%set_subtraction_event ()
                 do i_phs = 1, config%region_data%n_phs
                    emitter = phs%phs_identifiers(i_phs)%emitter
                    call pcm_instance%real_sub%compute (emitter, &
                         i_phs, alpha_s_sub, alpha_qed_sub, term%connected%has_matrix, sqme)
                 end do
              else
                 call pcm_instance%set_radiation_event ()
                 emitter = term%k_term%emitter; i_phs = term%k_term%i_phs
                 do i = 1, term%connected%trace%get_qn_index_n_flv ()
                    pcm_instance%real_sub%sqme_real_non_sub (i, i_phs) = &
                      real (term%connected%trace%get_matrix_element ( &
                      term%connected%trace%get_qn_index (i)))
                 end do
                 call pcm_instance%real_sub%compute (emitter, i_phs, alpha_s_sub, &
                      alpha_qed_sub, term%connected%has_matrix, sqme)
              end if
           end select
        end select
     end select
     if (term%connected%has_trace) &
          call term%connected%trace%set_only_matrix_element &
               (1, cmplx (sum(sqme), 0, default))
     select type (config => term%pcm_instance%config)
     type is (pcm_nlo_t)
        is_subtraction = term%k_term%emitter < 0
        if (term%connected%has_matrix) &
            call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
                 config%get_qn (is_subtraction), &
                 config%region_data%get_flavor_indices (is_subtraction), &
                 term%connected%matrix)
        if (term%connected%has_flows) &
             call refill_evaluator (cmplx (sqme * term%weight, 0, default), &
                  config%get_qn (is_subtraction), &
                  config%region_data%get_flavor_indices (is_subtraction), &
                  term%connected%flows)
     end select
   end subroutine term_instance_apply_fks
 
 @ %def term_instance_apply_fks
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_sqme_virt => term_instance_evaluate_sqme_virt
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_sqme_virt (term, alpha_s, alpha_qed)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_s, alpha_qed
     real(default) :: alpha_coupling
     type(vector4_t), dimension(:), allocatable :: p_born
     real(default), dimension(:), allocatable :: sqme_virt
     integer :: i_flv
     if (term%nlo_type /= NLO_VIRTUAL) call msg_fatal &
        ("Trying to evaluate virtual matrix element with unsuited term_instance.")
     if (debug2_active (D_VIRTUAL)) then
        call msg_debug2 (D_VIRTUAL, "Evaluating virtual-subtracted matrix elements")
        print *, 'ren_scale: ', term%ren_scale
        print *, 'fac_scale: ', term%fac_scale
        print *, 'Ellis-Sexton scale:', term%es_scale
     end if
     select type (config => term%pcm_instance%config)
     type is (pcm_nlo_t)
        select type (pcm_instance => term%pcm_instance)
        type is (pcm_instance_nlo_t)
           select case (char (config%region_data%regions(1)%nlo_correction_type))
           case ("QCD")
             alpha_coupling = alpha_s
             if (debug2_active (D_VIRTUAL)) print *, 'alpha_s: ', alpha_coupling
           case ("EW")
              alpha_coupling = alpha_qed
              if (debug2_active (D_VIRTUAL)) print *, 'alpha_qed: ', alpha_coupling
           end select
           allocate (p_born (config%region_data%n_legs_born))
           if (config%settings%factorization_mode == FACTORIZATION_THRESHOLD) then
              p_born = pcm_instance%real_kinematics%p_born_onshell%get_momenta(1)
           else
              p_born = term%int_hard%get_momenta ()
           end if
           call pcm_instance%set_momenta_and_scales_virtual &
                (p_born, term%ren_scale, term%fac_scale, term%es_scale)
           select type (pcm_instance => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              associate (virtual => pcm_instance%virtual)
                do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
                   virtual%sqme_born(i_flv) = &
                        real (term%connected%trace%get_matrix_element ( &
                        term%connected%trace%get_qn_index (i_flv, i_sub = 0)))
                   virtual%sqme_virt_fin(i_flv) = &
                        real (term%connected%trace%get_matrix_element ( &
                        term%connected%trace%get_qn_index (i_flv, i_sub = 1)))
                end do
              end associate
           end select
           call pcm_instance%compute_sqme_virt (term%p_hard, alpha_coupling, &
                term%connected%has_matrix, sqme_virt)
           call term%connected%trace%set_only_matrix_element &
                (1, cmplx (sum(sqme_virt), 0, default))
           if (term%connected%has_matrix) &
                call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%matrix)
           if (term%connected%has_flows) &
                call refill_evaluator (cmplx (sqme_virt * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%flows)
        end select
     end select
   end subroutine term_instance_evaluate_sqme_virt
 
 @ %def term_instance_evaluate_sqme_virt
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_sqme_mismatch => term_instance_evaluate_sqme_mismatch
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_sqme_mismatch (term, alpha_s)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_s
     real(default), dimension(:), allocatable :: sqme_mism
     if (term%nlo_type /= NLO_MISMATCH) call msg_fatal &
        ("Trying to evaluate soft mismatch with unsuited term_instance.")
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        call pcm_instance%compute_sqme_mismatch &
             (alpha_s, term%connected%has_matrix, sqme_mism)
     end select
     call term%connected%trace%set_only_matrix_element &
          (1, cmplx (sum (sqme_mism) * term%weight, 0, default))
     if (term%connected%has_matrix) then
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           if (term%connected%has_matrix) &
                call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%matrix)
           if (term%connected%has_flows) &
                call refill_evaluator (cmplx (sqme_mism * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%flows)
        end select
     end if
   end subroutine term_instance_evaluate_sqme_mismatch
 
 @ %def term_instance_evaluate_sqme_mismatch
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_sqme_dglap => term_instance_evaluate_sqme_dglap
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_sqme_dglap (term, alpha_s, alpha_qed)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_s, alpha_qed
     real(default) :: alpha_coupling
     real(default), dimension(:), allocatable :: sqme_dglap
     integer :: i_flv
     if (term%nlo_type /= NLO_DGLAP) call msg_fatal &
        ("Trying to evaluate DGLAP remnant with unsuited term_instance.")
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "term_instance_evaluate_sqme_dglap")
     select type (config => term%pcm_instance%config)
     type is (pcm_nlo_t)
       select type (pcm_instance => term%pcm_instance)
       type is (pcm_instance_nlo_t)
           select case (char (config%region_data%regions(1)%nlo_correction_type))
           case ("QCD")
             alpha_coupling = alpha_s
           case ("EW")
             alpha_coupling = alpha_qed
           end select
           if (debug2_active (D_PROCESS_INTEGRATION)) then
             associate (n_flv => pcm_instance%dglap_remnant%reg_data%n_flv_born)
                print *, "size(sqme_born) = ", size (pcm_instance%dglap_remnant%sqme_born)
                call term%connected%trace%write ()
                do i_flv = 1, n_flv
                   print *, "i_flv = ", i_flv, ", n_flv = ", n_flv
                   print *, "sqme_born(i_flv) = ", pcm_instance%dglap_remnant%sqme_born(i_flv)
                end do
             end associate
          end if
          call pcm_instance%compute_sqme_dglap_remnant (alpha_coupling, &
             term%connected%has_matrix, sqme_dglap)
       end select
     end select
     call term%connected%trace%set_only_matrix_element &
          (1, cmplx (sum (sqme_dglap) * term%weight, 0, default))
     if (term%connected%has_matrix) then
        select type (config => term%pcm_instance%config)
        type is (pcm_nlo_t)
           if (term%connected%has_matrix) &
                call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%matrix)
           if (term%connected%has_flows) &
                call refill_evaluator (cmplx (sqme_dglap * term%weight, 0, default), &
                     config%get_qn (.true.), &
                     remove_duplicates_from_int_array ( &
                     config%region_data%get_flavor_indices (.true.)), &
                     term%connected%flows)
        end select
     end if
   end subroutine term_instance_evaluate_sqme_dglap
 
 @ %def term_instance_evaluate_sqme_dglap
 @ Reset the term instance: clear the parton-state expressions and deactivate.
 <<Instances: term instance: TBP>>=
   procedure :: reset => term_instance_reset
 <<Instances: procedures>>=
   subroutine term_instance_reset (term)
     class(term_instance_t), intent(inout) :: term
     call term%connected%reset_expressions ()
     if (allocated (term%alpha_qcd_forced))  deallocate (term%alpha_qcd_forced)
     term%active = .false.
   end subroutine term_instance_reset
 
 @ %def term_instance_reset
 @ Force an $\alpha_s$ value that should be used in the matrix-element
 calculation.
 <<Instances: term instance: TBP>>=
   procedure :: set_alpha_qcd_forced => term_instance_set_alpha_qcd_forced
 <<Instances: procedures>>=
   subroutine term_instance_set_alpha_qcd_forced (term, alpha_qcd)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: alpha_qcd
     if (allocated (term%alpha_qcd_forced)) then
        term%alpha_qcd_forced = alpha_qcd
     else
        allocate (term%alpha_qcd_forced, source = alpha_qcd)
     end if
   end subroutine term_instance_set_alpha_qcd_forced
 
 @ %def term_instance_set_alpha_qcd_forced
 @ Complete the kinematics computation for the effective parton states.
 
 We assume that the [[compute_hard_kinematics]] method of the process
 component instance has already been called, so the [[int_hard]]
 contains the correct hard kinematics.  The duty of this procedure is
 first to compute the effective kinematics and store this in the
 [[int_eff]] effective interaction inside the [[isolated]] parton
 state.  The effective kinematics may differ from the kinematics in the hard
 interaction.  It may involve parton recombination or parton splitting.
 The [[rearrange_partons]] method is responsible for this part.
 
 We may also call a method to compute the effective structure-function
 chain at this point.  This is not implemented yet.
 
 In the simple case that no rearrangement is necessary, as indicated by
 the [[rearrange]] flag, the effective interaction is a pointer to the
 hard interaction, and we can skip the rearrangement method.  Similarly
 for the effective structure-function chain.  (If we have an algorithm
 that uses rarrangement, it should evaluate [[k_term]] explicitly.)
 
 The final step of kinematics setup is to transfer the effective
 kinematics to the evaluators and to the [[subevt]].
 <<Instances: term instance: TBP>>=
   procedure :: compute_eff_kinematics => &
        term_instance_compute_eff_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_compute_eff_kinematics (term)
     class(term_instance_t), intent(inout) :: term
     term%checked = .false.
     term%passed = .false.
     call term%isolated%receive_kinematics ()
     call term%connected%receive_kinematics ()
   end subroutine term_instance_compute_eff_kinematics
 
 @ %def term_instance_compute_eff_kinematics
 @ Inverse.  Reconstruct the connected state from the momenta in the
 trace evaluator (which we assume to be set), then reconstruct the
 isolated state as far as possible.  The second part finalizes the
 momentum configuration, using the incoming seed momenta
 <<Instances: term instance: TBP>>=
   procedure :: recover_hard_kinematics => &
        term_instance_recover_hard_kinematics
 <<Instances: procedures>>=
   subroutine term_instance_recover_hard_kinematics (term)
     class(term_instance_t), intent(inout) :: term
     term%checked = .false.
     term%passed = .false.
     call term%connected%send_kinematics ()
     call term%isolated%send_kinematics ()
   end subroutine term_instance_recover_hard_kinematics
 
 @ %def term_instance_recover_hard_kinematics
 @ Check the term whether it passes cuts and, if successful, evaluate
 scales and weights.  The factorization scale is also given to the term
 kinematics, enabling structure-function evaluation.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_expressions => &
        term_instance_evaluate_expressions
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_expressions (term, scale_forced)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in), allocatable, optional :: scale_forced
     call term%connected%evaluate_expressions (term%passed, &
          term%scale, term%fac_scale, term%ren_scale, term%weight, &
          scale_forced, force_evaluation = .true.)
     term%checked = .true.
   end subroutine term_instance_evaluate_expressions
 
 @ %def term_instance_evaluate_expressions
 @ Evaluate the trace: first evaluate the hard interaction, then the trace
 evaluator.  We use the [[evaluate_interaction]] method of the process
 component which generated this term.  The [[subevt]] and cut expressions are
 not yet filled.
 
 The [[component]] argument is intent(inout) because the [[compute_amplitude]]
 method may modify the [[core_state]] workspace object.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction => term_instance_evaluate_interaction
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in), pointer :: core
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction")
     if (term%k_term%only_cm_frame .and. (.not. term%k_term%lab_is_cm())) then
          term%p_hard = term%get_boost_to_cms () * term%int_hard%get_momenta ()
     else
          term%p_hard = term%int_hard%get_momenta ()
     end if
     select type (core)
     class is (prc_external_t)
        call term%evaluate_interaction_userdef (core)
     class default
        call term%evaluate_interaction_default (core)
     end select
     call term%int_hard%set_matrix_element (term%amp)
   end subroutine term_instance_evaluate_interaction
 
 @ %def term_instance_evaluate_interaction
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction_default &
      => term_instance_evaluate_interaction_default
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction_default (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in) :: core
     integer :: i
     do i = 1, term%config%n_allowed
        term%amp(i) = core%compute_amplitude (term%config%i_term, term%p_hard, &
             term%config%flv(i), term%config%hel(i), term%config%col(i), &
             term%fac_scale, term%ren_scale, term%alpha_qcd_forced, &
             term%core_state)
     end do
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        call pcm_instance%set_fac_scale (term%fac_scale)
     end select
   end subroutine term_instance_evaluate_interaction_default
 
 @ %def term_instance_evaluate_interaction_default
 @
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction_userdef &
      => term_instance_evaluate_interaction_userdef
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction_userdef (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction_userdef")
     select type (core_state => term%core_state)
     type is (openloops_state_t)
        select type (core)
        type is (prc_openloops_t)
           call core%compute_alpha_s (core_state, term%ren_scale)
           if (allocated (core_state%threshold_data)) &
                call evaluate_threshold_parameters (core_state, core, term%k_term%phs%get_sqrts ())
        end select
     class is (prc_external_state_t)
        select type (core)
        class is (prc_external_t)
           call core%compute_alpha_s (core_state, term%ren_scale)
        end select
     end select
     call evaluate_threshold_interaction ()
     if (term%nlo_type == NLO_VIRTUAL) then
        call term%evaluate_interaction_userdef_loop (core)
     else
        call term%evaluate_interaction_userdef_tree (core)
     end if
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        call pcm_instance%set_fac_scale (term%fac_scale)
     end select
 
   contains
     subroutine evaluate_threshold_parameters (core_state, core, sqrts)
        type(openloops_state_t), intent(inout) :: core_state
        type(prc_openloops_t), intent(inout) :: core
        real(default), intent(in) :: sqrts
        real(default) :: mtop, wtop
        mtop = m1s_to_mpole (sqrts)
        wtop = core_state%threshold_data%compute_top_width &
               (mtop, core_state%alpha_qcd)
        call core%set_mass_and_width (6, mtop, wtop)
     end subroutine
 
     subroutine evaluate_threshold_interaction ()
        integer :: leg
        select type (core)
        type is (prc_threshold_t)
           if (term%nlo_type > BORN) then
              select type (pcm => term%pcm_instance)
              type is (pcm_instance_nlo_t)
                 if (term%k_term%emitter >= 0) then
                    call core%set_offshell_momenta &
                         (pcm%real_kinematics%p_real_cms%get_momenta(term%config%i_term))
                    leg = thr_leg (term%k_term%emitter)
                    call core%set_leg (leg)
                    call core%set_onshell_momenta &
                         (pcm%real_kinematics%p_real_onshell(leg)%get_momenta(term%config%i_term))
                 else
                    call core%set_leg (0)
                    call core%set_offshell_momenta &
                         (pcm%real_kinematics%p_born_cms%get_momenta(1))
                 end if
              end select
           else
              call core%set_leg (-1)
              call core%set_offshell_momenta (term%p_hard)
           end if
        end select
     end subroutine evaluate_threshold_interaction
   end subroutine term_instance_evaluate_interaction_userdef
 
 @ %def term_instance_evaluate_interaction_userdef
 @ Retrieve the matrix elements from a matrix element provider and place them
 into [[term%amp]].
 
 For the handling of NLO calculations, FKS applies a book keeping handling
 flavor and/or particle type (e.g. for QCD: quark/gluon and quark flavor) in
 order to calculate the subtraction terms. Therefore, we have to insert the
 calculated matrix elements correctly into the state matrix where each entry
 corresponds to a set of quantum numbers. We apply a mapping [[hard_qn_ind]] from a list of
 quantum numbers provided by FKS to the hard process [[int_hard]].
 
 The calculated matrix elements are insert into [[term%amp]] in the following
 way. The first [[n_born]] particles are the matrix element of the hard process.
 In non-trivial beams, we store another [[n_beams_rescaled]] copies of these
 matrix elements as the first [[n_beams_rescaled]] subtractions. This is a remnant
 from times before the method [[term_instance_set_sf_factors]] and these entries are
 not used anymore. However, eliminating these entries involves deeper changes in how
 the connection tables for the evaluator product are set up and should therefore be
 part of a larger refactoring of the interactions \& state matrices.
 The next $n_{\text{born}}\times n_{sub_color}$ are color-correlated Born matrix elements,
 with then again the next $n_{\text{born}}\times n_{emitters}\times n_{sub_spin}$ being
 spin-correlated Born matrix elements.
 
 If two or more flavor structures would produce the same amplitude we only compute
 one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result
 to improve performance.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction_userdef_tree &
      => term_instance_evaluate_interaction_userdef_tree
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction_userdef_tree (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(inout) :: core
     real(default) :: sqme
     real(default), dimension(:), allocatable :: sqme_color_c
     real(default), dimension(:), allocatable :: sqme_spin_c
     real(default), dimension(6) :: sqme_spin_c_tmp
     integer :: n_flv, n_hel, n_sub_color, n_sub_spin, n_pdf_off
     integer :: i_flv, i_hel, i_sub, i_color_c, i_color_c_eqv, i_spin_c, i_spin_c_eqv
     integer :: i_flv_eqv, i_hel_eqv
     integer :: emitter, i_emitter
     logical :: bad_point, bp
     logical, dimension(:,:), allocatable :: eqv_me_evaluated
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction_userdef_tree")
     allocate (sqme_color_c (blha_result_array_size &
          (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
     n_flv = term%int_hard%get_qn_index_n_flv ()
     n_hel = term%int_hard%get_qn_index_n_hel ()
     n_sub_color = term%get_n_sub_color ()
     n_sub_spin = term%get_n_sub_spin ()
     allocate (eqv_me_evaluated(n_flv,n_hel))
     eqv_me_evaluated = .false.
     do i_flv = 1, n_flv
        do i_hel = 1, n_hel
           i_flv_eqv = core%data%eqv_flv_index(i_flv)
           i_hel_eqv = core%data%eqv_hel_index(i_hel)
           if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then
              select type (core)
              class is (prc_external_t)
                 call core%update_alpha_s (term%core_state, term%ren_scale)
                 call core%compute_sqme (i_flv, i_hel, term%p_hard, term%ren_scale, &
                      sqme, bad_point)
                 call term%pcm_instance%set_bad_point (bad_point)
                 associate (i_int => term%int_hard%get_qn_index &
                         (i_flv = i_flv, i_hel = i_hel, i_sub = 0))
                    term%amp(i_int) = cmplx (sqme, 0, default)
                 end associate
              end select
              n_pdf_off = 0
              if (term%pcm_instance%config%has_pdfs .and. &
                   (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
                 n_pdf_off = n_pdf_off + n_beams_rescaled
                 do i_sub = 1, n_pdf_off
                    term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = &
                         term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0))
                 end do
              end if
              if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
                   term%nlo_type == NLO_MISMATCH) then
                 sqme_color_c = zero
                 select type (core)
                 class is (prc_blha_t)
                    call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                         term%p_hard, term%ren_scale, sqme_color_c, bad_point)
                    call term%pcm_instance%set_bad_point (bad_point)
                 class is (prc_recola_t)
                    call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                         term%p_hard, term%ren_scale, sqme_color_c, bad_point)
                    call term%pcm_instance%set_bad_point (bad_point)
                 end select
                 do i_sub = 1, n_sub_color
                    i_color_c = term%int_hard%get_qn_index &
                         (i_flv, i_hel, i_sub + n_pdf_off)
                    term%amp(i_color_c) = cmplx (sqme_color_c(i_sub), 0, default)
                 end do
                 if (n_sub_spin > 0) then
                    bad_point = .false.
                    allocate (sqme_spin_c(0))
                    select type (core)
                    type is (prc_openloops_t)
                       select type (config => term%pcm_instance%config)
                       type is (pcm_nlo_t)
                          do i_emitter = 1, config%region_data%n_emitters
                             emitter = config%region_data%emitters(i_emitter)
                             if (emitter > 0) then
                                call core%compute_sqme_spin_c &
                                     (i_flv, &
                                     i_hel, &
                                     emitter, &
                                     term%p_hard, &
                                     term%ren_scale, &
                                     sqme_spin_c_tmp, &
                                     bp)
                                sqme_spin_c = [sqme_spin_c, sqme_spin_c_tmp]
                                bad_point = bad_point .or. bp
                             end if
                          end do
                       end select
                       do i_sub = 1, n_sub_spin
                          i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, &
                               i_sub + n_pdf_off + n_sub_color)
                          term%amp(i_spin_c) = cmplx &
                               (sqme_spin_c(i_sub), 0, default)
                       end do
                    end select
                    deallocate (sqme_spin_c)
                 end if
              end if
              eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true.
           else
              associate (i_int => term%int_hard%get_qn_index &
                      (i_flv = i_flv, i_hel = i_hel, i_sub = 0), &
                      i_int_eqv => term%int_hard%get_qn_index &
                      (i_flv = i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0))
                 term%amp(i_int) = term%amp(i_int_eqv)
              end associate
              n_pdf_off = 0
              if (term%pcm_instance%config%has_pdfs .and. &
                   (term%is_subtraction () .or. term%nlo_type == NLO_DGLAP)) then
                 n_pdf_off = n_pdf_off + n_beams_rescaled
                 do i_sub = 1, n_pdf_off
                    term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub)) = &
                         term%amp(term%int_hard%get_qn_index (i_flv, i_hel, i_sub = 0))
                 end do
              end if
              if ((term%nlo_type == NLO_REAL .and. term%is_subtraction ()) .or. &
                   term%nlo_type == NLO_MISMATCH) then
                 do i_sub = 1, n_sub_color
                    i_color_c = term%int_hard%get_qn_index &
                         (i_flv, i_hel, i_sub + n_pdf_off)
                    i_color_c_eqv = term%int_hard%get_qn_index &
                         (i_flv_eqv, i_hel_eqv, i_sub + n_pdf_off)
                    term%amp(i_color_c) = term%amp(i_color_c_eqv)
                 end do
                 do i_sub = 1, n_sub_spin
                    i_spin_c = term%int_hard%get_qn_index (i_flv, i_hel, &
                         i_sub + n_pdf_off + n_sub_color)
                    i_spin_c_eqv = term%int_hard%get_qn_index (i_flv_eqv, i_hel_eqv, &
                         i_sub + n_pdf_off + n_sub_color)
                    term%amp(i_spin_c) = term%amp(i_spin_c_eqv)
                 end do
              end if
           end if
        end do
     end do
   end subroutine term_instance_evaluate_interaction_userdef_tree
 
 @ %def term_instance_evaluate_interaction_userdef_tree
 @ Same as for [[term_instance_evaluate_interaction_userdef_tree]], but
 for the integrated-subtraction and finite one-loop terms. We only need
 color-correlated Born matrix elements, but an additional entry per
 flavor structure for the finite one-loop contribution. We thus have
 $2+n_{sub_color}$ entries in the [[term%amp]] for each [[i_flv]] and
 [[i_hel]] combination.
 
 If two or more flavor structures would produce the same amplitude we only compute
 one and use the [[eqv_index]] determined by the [[prc_core]] and just copy the result
 to improve performance.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_interaction_userdef_loop &
      => term_instance_evaluate_interaction_userdef_loop
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_interaction_userdef_loop (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in) :: core
     integer :: n_hel, n_sub, n_flv
     integer :: i, i_flv, i_hel, i_sub, i_virt, i_color_c, i_color_c_eqv
     integer :: i_flv_eqv, i_hel_eqv
     real(default), dimension(4) :: sqme_virt
     real(default), dimension(:), allocatable :: sqme_color_c
     logical :: bad_point
     logical, dimension(:,:), allocatable :: eqv_me_evaluated
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, &
          "term_instance_evaluate_interaction_userdef_loop")
     allocate (sqme_color_c (blha_result_array_size &
          (term%int_hard%get_n_tot (), BLHA_AMP_COLOR_C)))
     n_flv = term%int_hard%get_qn_index_n_flv ()
     n_hel = term%int_hard%get_qn_index_n_hel ()
     n_sub = term%int_hard%get_qn_index_n_sub ()
     allocate (eqv_me_evaluated(n_flv,n_hel))
     eqv_me_evaluated = .false.
     i_virt = 1
     do i_flv = 1, n_flv
        do i_hel = 1, n_hel
           i_flv_eqv = core%data%eqv_flv_index(i_flv)
           i_hel_eqv = core%data%eqv_hel_index(i_hel)
           if (.not. eqv_me_evaluated(i_flv_eqv, i_hel_eqv)) then
              select type (core)
              class is (prc_external_t)
                 call core%compute_sqme_virt (i_flv, i_hel, term%p_hard, &
                      term%ren_scale, term%es_scale, &
                      term%pcm_instance%config%blha_defaults%loop_method, &
                      sqme_virt, bad_point)
                 call term%pcm_instance%set_bad_point (bad_point)
              end select
              associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), &
                      i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt))
                 term%amp(i_loop) = cmplx (sqme_virt(3), 0, default)
                 term%amp(i_born) = cmplx (sqme_virt(4), 0, default)
              end associate
              select type (config => term%pcm_instance%config)
              type is (pcm_nlo_t)
                 select type (core)
                 class is (prc_blha_t)
                    call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                         term%p_hard, term%ren_scale, &
                         sqme_color_c, bad_point)
                    call term%pcm_instance%set_bad_point (bad_point)
                    do i_sub = 1 + i_virt, n_sub
                       i_color_c = term%int_hard%get_qn_index &
                            (i_flv, i_hel = i_hel, i_sub = i_sub)
                       ! Index shift: i_sub - i_virt
                       term%amp(i_color_c) = &
                            cmplx (sqme_color_c(i_sub - i_virt), 0, default)
                    end do
                 type is (prc_recola_t)
                    call core%compute_sqme_color_c_raw (i_flv, i_hel, &
                         term%p_hard, term%ren_scale, sqme_color_c, bad_point)
                    call term%pcm_instance%set_bad_point (bad_point)
                    do i_sub = 1 + i_virt, n_sub
                       i_color_c = term%int_hard%get_qn_index &
                            (i_flv, i_hel = i_hel, i_sub = i_sub)
                       ! Index shift: i_sub - i_virt
                       term%amp(i_color_c) = &
                            cmplx (sqme_color_c(i_sub - i_virt), 0, default)
                    end do
                 end select
              end select
              eqv_me_evaluated(i_flv_eqv, i_hel_eqv) = .true.
           else
              associate (i_born => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = 0), &
                      i_loop => term%int_hard%get_qn_index (i_flv, i_hel = i_hel, i_sub = i_virt), &
                      i_born_eqv => term%int_hard%get_qn_index &
                      (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 0), &
                      i_loop_eqv => term%int_hard%get_qn_index &
                      (i_flv_eqv, i_hel = i_hel_eqv, i_sub = 1))
                 term%amp(i_loop) = term%amp(i_loop_eqv)
                 term%amp(i_born) = term%amp(i_born_eqv)
              end associate
              do i_sub = 1 + i_virt, n_sub
                 i_color_c = term%int_hard%get_qn_index &
                      (i_flv, i_hel = i_hel, i_sub = i_sub)
                 i_color_c_eqv = term%int_hard%get_qn_index &
                      (i_flv_eqv, i_hel = i_hel_eqv, i_sub = i_sub)
                 ! Index shift: i_sub - i_virt
                 term%amp(i_color_c) = term%amp(i_color_c_eqv)
              end do
           end if
        end do
     end do
   end subroutine term_instance_evaluate_interaction_userdef_loop
 
 @ %def term_instance_evaluate_interaction_userdef_loop
 @ Evaluate the trace.  First evaluate the
 structure-function chain (i.e., the density matrix of the incoming
 partons).  Do this twice, in case the sf-chain instances within
 [[k_term]] and [[isolated]] differ.  Next, evaluate the hard
 interaction, then compute the convolution with the initial state.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_trace => term_instance_evaluate_trace
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_trace (term)
     class(term_instance_t), intent(inout) :: term
     call term%k_term%evaluate_sf_chain (term%fac_scale, term%negative_sf)
     call term%evaluate_scaled_sf_chains ()
     call term%isolated%evaluate_sf_chain (term%fac_scale)
     call term%isolated%evaluate_trace ()
     call term%connected%evaluate_trace ()
   end subroutine term_instance_evaluate_trace
 
 @ %def term_instance_evaluate_trace
 @ Include rescaled structure functions due to NLO calculation.
 We rescale the structure function for the real subtraction [[sf_rescale_collinear]],
 the collinear counter terms [[sf_rescale_dglap_t]] and for the case, in which we have
 an emitter in the initial state, we rescale the kinematics for it using [[sf_rescale_real_t]].\\
 References: arXiv:0709.2092, (2.35)-(2.42).\\
 Obviously, it is completely irrelevant, which beam is treated.
 It becomes problematic when handling [[e, p]]-beams.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_scaled_sf_chains => term_instance_evaluate_scaled_sf_chains
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_scaled_sf_chains (term)
     class(term_instance_t), intent(inout) :: term
     class(sf_rescale_t), allocatable :: sf_rescale
     if (.not. term%pcm_instance%config%has_pdfs) return
     if (term%nlo_type == NLO_REAL) then
        if (term%is_subtraction ()) then
           allocate (sf_rescale_collinear_t :: sf_rescale)
           select type (pcm => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              select type (sf_rescale)
              type is (sf_rescale_collinear_t)
                 call sf_rescale%set (pcm%real_kinematics%xi_tilde)
              end select
           end select
           call term%k_term%sf_chain%evaluate (term%fac_scale, term%negative_sf, sf_rescale)
           deallocate (sf_rescale)
        else if (term%k_term%emitter >= 0 .and. term%k_term%emitter <= term%k_term%n_in) then
           allocate (sf_rescale_real_t :: sf_rescale)
           select type (pcm => term%pcm_instance)
           type is (pcm_instance_nlo_t)
              select type (sf_rescale)
              type is (sf_rescale_real_t)
                 call sf_rescale%set (pcm%real_kinematics%xi_tilde * &
                      pcm%real_kinematics%xi_max (term%k_term%i_phs), &
                      pcm%real_kinematics%y (term%k_term%i_phs))
              end select
           end select
           call term%k_term%sf_chain%evaluate (term%fac_scale, term%negative_sf, sf_rescale)
           deallocate (sf_rescale)
        else
           call term%k_term%sf_chain%evaluate (term%fac_scale, term%negative_sf)
        end if
     else if (term%nlo_type == NLO_DGLAP) then
        allocate (sf_rescale_dglap_t :: sf_rescale)
        select type (pcm => term%pcm_instance)
        type is (pcm_instance_nlo_t)
           select type (sf_rescale)
           type is (sf_rescale_dglap_t)
              call sf_rescale%set (pcm%isr_kinematics%z)
           end select
        end select
        call term%k_term%sf_chain%evaluate (term%fac_scale, term%negative_sf, sf_rescale)
        deallocate (sf_rescale)
     end if
   end subroutine term_instance_evaluate_scaled_sf_chains
 
 @ %def term_instance_evaluate_scaled_sf_chains
 @ Evaluate the extra data that we need for processing the object as a
 physical event.
 <<Instances: term instance: TBP>>=
   procedure :: evaluate_event_data => term_instance_evaluate_event_data
 <<Instances: procedures>>=
   subroutine term_instance_evaluate_event_data (term)
     class(term_instance_t), intent(inout) :: term
     logical :: only_momenta
     only_momenta = term%nlo_type > BORN
     call term%isolated%evaluate_event_data (only_momenta)
     call term%connected%evaluate_event_data (only_momenta)
   end subroutine term_instance_evaluate_event_data
 
 @ %def term_instance_evaluate_event_data
 @
 <<Instances: term instance: TBP>>=
   procedure :: set_fac_scale => term_instance_set_fac_scale
 <<Instances: procedures>>=
   subroutine term_instance_set_fac_scale (term, fac_scale)
     class(term_instance_t), intent(inout) :: term
     real(default), intent(in) :: fac_scale
     term%fac_scale = fac_scale
   end subroutine term_instance_set_fac_scale
 
 @ %def term_instance_set_fac_scale
 @ Return data that might be useful for external processing.  The
 factorization scale:
 <<Instances: term instance: TBP>>=
   procedure :: get_fac_scale => term_instance_get_fac_scale
 <<Instances: procedures>>=
   function term_instance_get_fac_scale (term) result (fac_scale)
     class(term_instance_t), intent(in) :: term
     real(default) :: fac_scale
     fac_scale = term%fac_scale
   end function term_instance_get_fac_scale
 
 @ %def term_instance_get_fac_scale
 @ We take the strong coupling from the process core.  The value is calculated
 when a new event is requested, so we should call it only after the event has
 been evaluated.  If it is not available there (a negative number is returned),
 we take the value stored in the term configuration, which should be determined
 by the model.  If the model does not provide a value, the result is zero.
 <<Instances: term instance: TBP>>=
   procedure :: get_alpha_s => term_instance_get_alpha_s
 <<Instances: procedures>>=
   function term_instance_get_alpha_s (term, core) result (alpha_s)
     class(term_instance_t), intent(in) :: term
     class(prc_core_t), intent(in) :: core
     real(default) :: alpha_s
     alpha_s = core%get_alpha_s (term%core_state)
     if (alpha_s < zero)  alpha_s = term%config%alpha_s
   end function term_instance_get_alpha_s
 
 @ %def term_instance_get_alpha_s
 @
 <<Instances: term instance: TBP>>=
   procedure :: reset_phs_identifiers => term_instance_reset_phs_identifiers
 <<Instances: procedures>>=
   subroutine term_instance_reset_phs_identifiers (term)
     class(term_instance_t), intent(inout) :: term
     select type (phs => term%k_term%phs)
     type is (phs_fks_t)
        phs%phs_identifiers%evaluated = .false.
     end select
   end subroutine term_instance_reset_phs_identifiers
 
 @ %def term_instance_reset_phs_identifiers
 @ The second helicity for [[helicities]] comes with a minus sign
 because OpenLoops inverts the helicity index of antiparticles.
 <<Instances: term instance: TBP>>=
   procedure :: get_helicities_for_openloops => term_instance_get_helicities_for_openloops
 <<Instances: procedures>>=
   subroutine term_instance_get_helicities_for_openloops (term, helicities)
     class(term_instance_t), intent(in) :: term
     integer, dimension(:,:), allocatable, intent(out) :: helicities
     type(helicity_t), dimension(:), allocatable :: hel
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     type(quantum_numbers_mask_t) :: qn_mask
     integer :: h, i, j, n_in
     call qn_mask%set_sub (1)
     call term%isolated%trace%get_quantum_numbers_mask (qn_mask, qn)
     n_in = term%int_hard%get_n_in ()
     allocate (helicities (size (qn, dim=1), n_in))
     allocate (hel (n_in))
     do i = 1, size (qn, dim=1)
        do j = 1, n_in
           hel(j) = qn(i, j)%get_helicity ()
           call hel(j)%diagonalize ()
           call hel(j)%get_indices (h, h)
           helicities (i, j) = h
        end do
     end do
   end subroutine term_instance_get_helicities_for_openloops
 
 @ %def term_instance_get_helicities_for_openloops
 @
 <<Instances: term instance: TBP>>=
   procedure :: get_boost_to_lab => term_instance_get_boost_to_lab
 <<Instances: procedures>>=
   function term_instance_get_boost_to_lab (term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(term_instance_t), intent(in) :: term
     lt = term%k_term%phs%get_lorentz_transformation ()
   end function term_instance_get_boost_to_lab
 
 @ %def term_instance_get_boost_to_lab
 @
 <<Instances: term instance: TBP>>=
   procedure :: get_boost_to_cms => term_instance_get_boost_to_cms
 <<Instances: procedures>>=
   function term_instance_get_boost_to_cms (term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(term_instance_t), intent(in) :: term
     lt = inverse (term%k_term%phs%get_lorentz_transformation ())
   end function term_instance_get_boost_to_cms
 
 @ %def term_instance_get_boost_to_cms
 @
 <<Instances: term instance: TBP>>=
   procedure :: get_i_term_global => term_instance_get_i_term_global
 <<Instances: procedures>>=
   elemental function term_instance_get_i_term_global (term) result (i_term)
     integer :: i_term
     class(term_instance_t), intent(in) :: term
     i_term = term%config%i_term_global
   end function term_instance_get_i_term_global
 
 @ %def term_instance_get_i_term_global
 @
 <<Instances: term instance: TBP>>=
   procedure :: is_subtraction => term_instance_is_subtraction
 <<Instances: procedures>>=
   elemental function term_instance_is_subtraction (term) result (sub)
     logical :: sub
     class(term_instance_t), intent(in) :: term
     sub = term%config%i_term_global == term%config%i_sub
   end function term_instance_is_subtraction
 
 @ %def term_instance_is_subtraction
 @ Retrieve [[n_sub]] which was calculated in [[process_term_setup_interaction]].
 <<Instances: term instance: TBP>>=
   procedure :: get_n_sub => term_instance_get_n_sub
   procedure :: get_n_sub_color => term_instance_get_n_sub_color
   procedure :: get_n_sub_spin => term_instance_get_n_sub_spin
 <<Instances: procedures>>=
   function term_instance_get_n_sub (term) result (n_sub)
     integer :: n_sub
     class(term_instance_t), intent(in) :: term
     n_sub = term%config%n_sub
   end function term_instance_get_n_sub
 
   function term_instance_get_n_sub_color (term) result (n_sub_color)
     integer :: n_sub_color
     class(term_instance_t), intent(in) :: term
     n_sub_color = term%config%n_sub_color
   end function term_instance_get_n_sub_color
 
   function term_instance_get_n_sub_spin (term) result (n_sub_spin)
     integer :: n_sub_spin
     class(term_instance_t), intent(in) :: term
     n_sub_spin = term%config%n_sub_spin
   end function term_instance_get_n_sub_spin
 
 @ %def term_instance_get_n_sub
 @ %def term_instance_get_n_sub_color
 @ %def term_instance_get_n_sub_spin
 @
 \subsection{The process instance}
 A process instance contains all process data that depend on the
 sampling point and thus change often.  In essence, it is an event
 record at the elementary (parton) level.  We do not call it such, to
 avoid confusion with the actual event records.  If decays are
 involved, the latter are compositions of several elementary processes
 (i.e., their instances).
 
 We implement the process instance as an extension of the
 [[mci_sampler_t]] that we need for computing integrals and generate
 events.
 
 The base type contains: the [[integrand]], the [[selected_channel]],
 the two-dimensional array [[x]] of parameters, and the one-dimensional
 array [[f]] of Jacobians.  These subobjects are public and used for
 communicating with the multi-channel integrator.
 
 The [[process]] pointer accesses the process of which this record is
 an instance.  It is required whenever the calculation needs invariant
 configuration data, therefore the process should stay in memory for
 the whole lifetime of its instances.
 
 The [[evaluation_status]] code is used to check the current status.
 In particular, failure at various stages is recorded there.
 
 The [[count]] object records process evaluations, broken down
 according to status.
 
 The [[sqme]] value is the single real number that results from
 evaluating and tracing the kinematics and matrix elements.  This
 is the number that is handed over to an integration routine.
 
 The [[weight]] value is the event weight.  It is defined when an event
 has been generated from the process instance, either weighted or
 unweighted.  The value is the [[sqme]] value times Jacobian weights
 from the integration, or unity, respectively.
 
 The [[i_mci]] index chooses a subset of components that are associated with
 a common parameter set and integrator, i.e., that are added coherently.
 
 The [[sf_chain]] subobject is a realization of the beam and
 structure-function configuration in the [[process]] object.  It is not
 used for calculation directly but serves as the template for the
 sf-chain instances that are contained in the [[component]] objects.
 
 The [[component]] subobjects determine the state of each component.
 
 The [[term]] subobjects are workspace for evaluating kinematics,
 matrix elements, cuts etc.
 
 The [[mci_work]] subobject contains the array of real input parameters (random
 numbers) that generates the kinematical point.  It also contains the workspace
 for the MC integrators.  The active entry of the [[mci_work]] array is
 selected by the [[i_mci]] index above.
 
 The [[hook]] pointer accesses a list of after evaluate objects which are
 evalutated after the matrix element.
 <<Instances: public>>=
   public :: process_instance_t
 <<Instances: types>>=
   type, extends (mci_sampler_t) :: process_instance_t
      type(process_t), pointer :: process => null ()
      integer :: evaluation_status = STAT_UNDEFINED
      real(default) :: sqme = 0
      real(default) :: weight = 0
      real(default) :: excess = 0
      integer :: n_dropped = 0
      integer :: i_mci = 0
      integer :: selected_channel = 0
      type(sf_chain_t) :: sf_chain
      type(term_instance_t), dimension(:), allocatable :: term
      type(mci_work_t), dimension(:), allocatable :: mci_work
      class(pcm_instance_t), allocatable :: pcm
      class(process_instance_hook_t), pointer :: hook => null ()
    contains
    <<Instances: process instance: TBP>>
   end type process_instance_t
 
 @ %def process_instance
 @
 Wrapper type for storing pointers to process instance objects in arrays.
 <<Instances: public>>=
   public :: process_instance_ptr_t
 <<Instances: types>>=
   type :: process_instance_ptr_t
      type(process_instance_t), pointer :: p => null ()
   end type process_instance_ptr_t
 
 @ %def process_instance_ptr_t
 @ The process hooks are first-in-last-out list of objects which are evaluated
 after the phase space and matrixelement are evaluated. It is possible to
 retrieve the sampler object and read the sampler information.
 
 The hook object are part of the [[process_instance]] and therefore, share a
 common lifetime. A data transfer, after the usual lifetime of the
 [[process_instance]], is not provided, as such the finalisation procedure has to take care
 of this! E.g. write the object to file from which later the collected
 information can then be retrieved.
 <<Instances: public>>=
   public :: process_instance_hook_t
 <<Instances: types>>=
   type, abstract :: process_instance_hook_t
      class(process_instance_hook_t), pointer :: next => null ()
    contains
      procedure(process_instance_hook_init), deferred :: init
      procedure(process_instance_hook_final), deferred :: final
      procedure(process_instance_hook_evaluate), deferred :: evaluate
   end type process_instance_hook_t
 
 @ %def process_instance_hook_t
 @ We have to provide a [[init]], a [[final]] procedure and, for after evaluation, the
 [[evaluate]] procedure.
 
 The [[init]] procedures accesses [[var_list]] and current [[instance]] object.
 <<Instances: public>>=
   public :: process_instance_hook_final, process_instance_hook_evaluate
 <<Instances: interfaces>>=
   abstract interface
      subroutine process_instance_hook_init (hook, var_list, instance)
        import :: process_instance_hook_t, var_list_t, process_instance_t
        class(process_instance_hook_t), intent(inout), target :: hook
        type(var_list_t), intent(in) :: var_list
        class(process_instance_t), intent(in), target :: instance
      end subroutine process_instance_hook_init
 
      subroutine process_instance_hook_final (hook)
        import :: process_instance_hook_t
        class(process_instance_hook_t), intent(inout) :: hook
      end subroutine process_instance_hook_final
 
      subroutine process_instance_hook_evaluate (hook, instance)
        import :: process_instance_hook_t, process_instance_t
        class(process_instance_hook_t), intent(inout) :: hook
        class(process_instance_t), intent(in), target :: instance
      end subroutine process_instance_hook_evaluate
   end interface
 
 @ %def process_instance_hook_final, process_instance_hook_evaluate
 @ The output routine contains a header with the most relevant
 information about the process, copied from
 [[process_metadata_write]].  We mark the active components by an asterisk.
 
 The next section is the MC parameter input.  The following sections
 are written only if the evaluation status is beyond setting the
 parameters, or if the [[verbose]] option is set.
 <<Instances: process instance: TBP>>=
   procedure :: write_header => process_instance_write_header
   procedure :: write => process_instance_write
 <<Instances: procedures>>=
   subroutine process_instance_write_header (object, unit, testflag)
     class(process_instance_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     call write_separator (u, 2)
     if (associated (object%process)) then
        call object%process%write_meta (u, testflag)
     else
        write (u, "(1x,A)") "Process instance [undefined process]"
        return
     end if
     write (u, "(3x,A)", advance = "no")  "status = "
     select case (object%evaluation_status)
     case (STAT_INITIAL);            write (u, "(A)")  "initialized"
     case (STAT_ACTIVATED);          write (u, "(A)")  "activated"
     case (STAT_BEAM_MOMENTA);       write (u, "(A)")  "beam momenta set"
     case (STAT_FAILED_KINEMATICS);  write (u, "(A)")  "failed kinematics"
     case (STAT_SEED_KINEMATICS);    write (u, "(A)")  "seed kinematics"
     case (STAT_HARD_KINEMATICS);    write (u, "(A)")  "hard kinematics"
     case (STAT_EFF_KINEMATICS);     write (u, "(A)")  "effective kinematics"
     case (STAT_FAILED_CUTS);        write (u, "(A)")  "failed cuts"
     case (STAT_PASSED_CUTS);        write (u, "(A)")  "passed cuts"
     case (STAT_EVALUATED_TRACE);    write (u, "(A)")  "evaluated trace"
        call write_separator (u)
        write (u, "(3x,A,ES19.12)")  "sqme   = ", object%sqme
     case (STAT_EVENT_COMPLETE);   write (u, "(A)")  "event complete"
        call write_separator (u)
        write (u, "(3x,A,ES19.12)")  "sqme   = ", object%sqme
        write (u, "(3x,A,ES19.12)")  "weight = ", object%weight
        if (.not. vanishes (object%excess)) &
             write (u, "(3x,A,ES19.12)")  "excess = ", object%excess
     case default;                 write (u, "(A)")  "undefined"
     end select
     if (object%i_mci /= 0) then
        call write_separator (u)
        call object%mci_work(object%i_mci)%write (u, testflag)
     end if
     call write_separator (u, 2)
   end subroutine process_instance_write_header
 
   subroutine process_instance_write (object, unit, testflag)
     class(process_instance_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u, i
     u = given_output_unit (unit)
     call object%write_header (u)
     if (object%evaluation_status >= STAT_BEAM_MOMENTA) then
        call object%sf_chain%write (u)
        call write_separator (u, 2)
        if (object%evaluation_status >= STAT_SEED_KINEMATICS) then
           if (object%evaluation_status >= STAT_HARD_KINEMATICS) then
              call write_separator (u, 2)
              write (u, "(1x,A)") "Active terms:"
              if (any (object%term%active)) then
                 do i = 1, size (object%term)
                    if (object%term(i)%active) then
                       call write_separator (u)
                       call object%term(i)%write (u, &
                            show_eff_state = &
                            object%evaluation_status >= STAT_EFF_KINEMATICS, &
                            testflag = testflag)
                    end if
                 end do
              end if
           end if
           call write_separator (u, 2)
        end if
     end if
   end subroutine process_instance_write
 
 @ %def process_instance_write_header
 @ %def process_instance_write
 @ Initialization connects the instance with a process.  All initial
 information is transferred from the process object.  The process
 object contains templates for the interaction subobjects (beam and
 term), but no evaluators.  The initialization routine
 creates evaluators for the matrix element trace, other evaluators
 are left untouched.
 
 Before we start generating, we double-check if the process library
 has been updated after the process was initializated
 ([[check_library_sanity]]).  This may happen if between integration
 and event generation the library has been recompiled, so all links
 become broken.
 
 The [[instance]] object must have the [[target]] attribute (also in
 any caller) since the initialization routine assigns various pointers
 to subobject of [[instance]].
 <<Instances: process instance: TBP>>=
   procedure :: init => process_instance_init
 <<Instances: procedures>>=
   subroutine process_instance_init (instance, process)
     class(process_instance_t), intent(out), target :: instance
     type(process_t), intent(inout), target :: process
     integer :: i
     class(pcm_t), pointer :: pcm
     type(process_term_t) :: term
     type(var_list_t), pointer :: var_list
     integer :: i_born, i_real, i_real_fin
     if (debug_on) call msg_debug (D_PROCESS_INTEGRATION, "process_instance_init")
     instance%process => process
     call instance%process%check_library_sanity ()
     call instance%setup_sf_chain (process%get_beam_config_ptr ())
     allocate (instance%mci_work (process%get_n_mci ()))
     do i = 1, size (instance%mci_work)
        call instance%process%init_mci_work (instance%mci_work(i), i)
     end do
     call instance%process%reset_selected_cores ()
     pcm => instance%process%get_pcm_ptr ()
     call pcm%allocate_instance (instance%pcm)
     call instance%pcm%link_config (pcm)
     select type (pcm)
     type is (pcm_nlo_t)
        !!! The process is kept when the integration is finalized, but not the
        !!! process_instance. Thus, we check whether pcm has been initialized
        !!! but set up the pcm_instance each time.
        i_real_fin = process%get_associated_real_fin (1)
        if (.not. pcm%initialized) then
 !          i_born = pcm%get_i_core_nlo_type (BORN)
           i_born = pcm%get_i_core (pcm%i_born)
 !          i_real = pcm%get_i_core_nlo_type (NLO_REAL, include_sub = .false.)
 !          i_real = pcm%get_i_core_nlo_type (NLO_REAL)
           i_real = pcm%get_i_core (pcm%i_real)
           term = process%get_term_ptr (process%get_i_term (i_real))
           call pcm%init_qn (process%get_model_ptr ())
           if (i_real_fin > 0) call pcm%allocate_ps_matching ()
           var_list => process%get_var_list_ptr ()
           if (var_list%get_sval (var_str ("$dalitz_plot")) /= var_str ('')) &
                call pcm%activate_dalitz_plot (var_list%get_sval (var_str ("$dalitz_plot")))
        end if
        pcm%initialized = .true.
        select type (pcm_instance => instance%pcm)
        type is (pcm_instance_nlo_t)
           call pcm_instance%init_config (process%component_can_be_integrated (), &
                process%get_nlo_type_component (), process%get_energy (), &
                i_real_fin, process%get_model_ptr ())
        end select
     end select
     allocate (instance%term (process%get_n_terms ()))
     do i = 1, process%get_n_terms ()
        call instance%term(i)%init_from_process (process, i, instance%pcm, &
             instance%sf_chain)
     end do
     call instance%set_i_mci_to_real_component ()
     call instance%find_same_kinematics ()
     instance%evaluation_status = STAT_INITIAL
   end subroutine process_instance_init
 
 @ %def process_instance_init
 @
 @ Finalize all subobjects that may contain allocated pointers.
 <<Instances: process instance: TBP>>=
   procedure :: final => process_instance_final
 <<Instances: procedures>>=
   subroutine process_instance_final (instance)
     class(process_instance_t), intent(inout) :: instance
     class(process_instance_hook_t), pointer :: current
     integer :: i
     instance%process => null ()
     if (allocated (instance%mci_work)) then
        do i = 1, size (instance%mci_work)
           call instance%mci_work(i)%final ()
        end do
        deallocate (instance%mci_work)
     end if
     call instance%sf_chain%final ()
     if (allocated (instance%term)) then
        do i = 1, size (instance%term)
           call instance%term(i)%final ()
        end do
        deallocate (instance%term)
     end if
     call instance%pcm%final ()
     instance%evaluation_status = STAT_UNDEFINED
     do while (associated (instance%hook))
        current => instance%hook
        call current%final ()
        instance%hook => current%next
        deallocate (current)
     end do
     instance%hook => null ()
   end subroutine process_instance_final
 
 @ %def process_instance_final
 @ Revert the process instance to initial state.  We do not deallocate
 anything, just reset the state index and deactivate all components and
 terms.
 
 We do not reset the choice of the MCI set [[i_mci]] unless this is
 required explicitly.
 <<Instances: process instance: TBP>>=
   procedure :: reset => process_instance_reset
 <<Instances: procedures>>=
   subroutine process_instance_reset (instance, reset_mci)
     class(process_instance_t), intent(inout) :: instance
     logical, intent(in), optional :: reset_mci
     integer :: i
     call instance%process%reset_selected_cores ()
     do i = 1, size (instance%term)
        call instance%term(i)%reset ()
     end do
     instance%term%checked = .false.
     instance%term%passed = .false.
     instance%term%k_term%new_seed = .true.
     if (present (reset_mci)) then
        if (reset_mci)  instance%i_mci = 0
     end if
     instance%selected_channel = 0
     instance%evaluation_status = STAT_INITIAL
   end subroutine process_instance_reset
 
 @ %def process_instance_reset
 @
 \subsubsection{Integration and event generation}
 The sampler test should just evaluate the squared matrix element [[n_calls]]
 times, discarding the results, and return.  This can be done before
 integration, e.g., for timing estimates.
 <<Instances: process instance: TBP>>=
   procedure :: sampler_test => process_instance_sampler_test
 <<Instances: procedures>>=
   subroutine process_instance_sampler_test (instance, i_mci, n_calls)
     class(process_instance_t), intent(inout), target :: instance
     integer, intent(in) :: i_mci
     integer, intent(in) :: n_calls
     integer :: i_mci_work
     i_mci_work = instance%process%get_i_mci_work (i_mci)
     call instance%choose_mci (i_mci_work)
     call instance%reset_counter ()
     call instance%process%sampler_test (instance, n_calls, i_mci_work)
     call instance%process%set_counter_mci_entry (i_mci_work, instance%get_counter ())
   end subroutine process_instance_sampler_test
 
 @ %def process_instance_sampler_test
 @ Generate a weighted event.  We select one of the available MCI
 integrators by its index [[i_mci]] and thus generate an event for the
 associated (group of) process component(s).  The arguments exactly
 correspond to the initializer and finalizer above.
 
 The resulting event is stored in the [[process_instance]] object,
 which also holds the workspace of the integrator.
 
 Note: The [[process]] object contains the random-number state, which
 changes for each event.
 Otherwise, all volatile data are inside the [[instance]] object.
 <<Instances: process instance: TBP>>=
   procedure :: generate_weighted_event => process_instance_generate_weighted_event
 <<Instances: procedures>>=
   subroutine process_instance_generate_weighted_event (instance, i_mci)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     integer :: i_mci_work
     i_mci_work = instance%process%get_i_mci_work (i_mci)
     call instance%choose_mci (i_mci_work)
     associate (mci_work => instance%mci_work(i_mci_work))
        call instance%process%generate_weighted_event &
           (i_mci_work, mci_work, instance, &
            instance%keep_failed_events ())
     end associate
   end subroutine process_instance_generate_weighted_event
 
 @ %def process_instance_generate_weighted_event
 @
 <<Instances: process instance: TBP>>=
   procedure :: generate_unweighted_event => process_instance_generate_unweighted_event
 <<Instances: procedures>>=
   subroutine process_instance_generate_unweighted_event (instance, i_mci)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     integer :: i_mci_work
     i_mci_work = instance%process%get_i_mci_work (i_mci)
     call instance%choose_mci (i_mci_work)
     associate (mci_work => instance%mci_work(i_mci_work))
        call instance%process%generate_unweighted_event &
           (i_mci_work, mci_work, instance)
     end associate
   end subroutine process_instance_generate_unweighted_event
 
 @ %def process_instance_generate_unweighted_event
 @
 This replaces the event generation methods for the situation that the
 process instance object has been filled by other means (i.e., reading
 and/or recalculating its contents).  We just have to fill in missing
 MCI data, especially the event weight.
 <<Instances: process instance: TBP>>=
   procedure :: recover_event => process_instance_recover_event
 <<Instances: procedures>>=
   subroutine process_instance_recover_event (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_mci
     i_mci = instance%i_mci
     call instance%process%set_i_mci_work (i_mci)
     associate (mci_instance => instance%mci_work(i_mci)%mci)
       call mci_instance%fetch (instance, instance%selected_channel)
     end associate
   end subroutine process_instance_recover_event
 
 @ %def process_instance_recover_event
 @
 @ Activate the components and terms that correspond to a currently
 selected MCI parameter set.
 <<Instances: process instance: TBP>>=
   procedure :: activate => process_instance_activate
 <<Instances: procedures>>=
   subroutine process_instance_activate (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i, j
     integer, dimension(:), allocatable :: i_term
     associate (mci_work => instance%mci_work(instance%i_mci))
        call instance%process%select_components (mci_work%get_active_components ())
     end associate
     associate (process => instance%process)
        do i = 1, instance%process%get_n_components ()
           if (instance%process%component_is_selected (i)) then
              allocate (i_term (size (process%get_component_i_terms (i))))
              i_term = process%get_component_i_terms (i)
              do j = 1, size (i_term)
                 instance%term(i_term(j))%active = .true.
              end do
           end if
           if (allocated (i_term)) deallocate (i_term)
        end do
     end associate
     instance%evaluation_status = STAT_ACTIVATED
   end subroutine process_instance_activate
 
 @ %def process_instance_activate
 @
 <<Instances: process instance: TBP>>=
   procedure :: find_same_kinematics => process_instance_find_same_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_find_same_kinematics (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_term1, i_term2, k, n_same
     do i_term1 = 1, size (instance%term)
        if (.not. allocated (instance%term(i_term1)%same_kinematics)) then
           n_same = 1 !!! Index group includes the index of its term_instance
           do i_term2 = 1, size (instance%term)
              if (i_term1 == i_term2) cycle
              if (compare_md5s (i_term1, i_term2)) n_same = n_same + 1
           end do
           allocate (instance%term(i_term1)%same_kinematics (n_same))
           associate (same_kinematics1 => instance%term(i_term1)%same_kinematics)
              same_kinematics1 = 0
              k = 1
              do i_term2 = 1, size (instance%term)
                 if (compare_md5s (i_term1, i_term2)) then
                    same_kinematics1(k) = i_term2
                    k = k + 1
                 end if
              end do
              do k = 1, size (same_kinematics1)
                 if (same_kinematics1(k) == i_term1) cycle
                 i_term2 = same_kinematics1(k)
                 allocate (instance%term(i_term2)%same_kinematics (n_same))
                 instance%term(i_term2)%same_kinematics = same_kinematics1
              end do
           end associate
        end if
     end do
   contains
     function compare_md5s (i, j) result (same)
       logical :: same
       integer, intent(in) :: i, j
       character(32) :: md5sum_1, md5sum_2
       integer :: mode_1, mode_2
       mode_1 = 0; mode_2 = 0
       select type (phs => instance%term(i)%k_term%phs%config)
       type is (phs_fks_config_t)
          md5sum_1 = phs%md5sum_born_config
          mode_1 = phs%mode
       class default
          md5sum_1 = phs%md5sum_phs_config
       end select
       select type (phs => instance%term(j)%k_term%phs%config)
       type is (phs_fks_config_t)
          md5sum_2 = phs%md5sum_born_config
          mode_2 = phs%mode
       class default
          md5sum_2 = phs%md5sum_phs_config
       end select
       same = (md5sum_1 == md5sum_2) .and. (mode_1 == mode_2)
     end function compare_md5s
   end subroutine process_instance_find_same_kinematics
 
 @ %def process_instance_find_same_kinematics
 @
 <<Instances: process instance: TBP>>=
   procedure :: transfer_same_kinematics => process_instance_transfer_same_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_transfer_same_kinematics (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     integer :: i, i_term_same
     associate (same_kinematics => instance%term(i_term)%same_kinematics)
        do i = 1, size (same_kinematics)
           i_term_same = same_kinematics(i)
              instance%term(i_term_same)%p_seed = instance%term(i_term)%p_seed
              associate (phs => instance%term(i_term_same)%k_term%phs)
                 call phs%set_lorentz_transformation &
                      (instance%term(i_term)%k_term%phs%get_lorentz_transformation ())
                 select type (phs)
                 type is (phs_fks_t)
                    call phs%set_momenta (instance%term(i_term_same)%p_seed)
                    if (i_term_same /= i_term) then
                       call phs%set_reference_frames (.false.)
                    end if
                 end select
              end associate
           instance%term(i_term_same)%k_term%new_seed = .false.
        end do
     end associate
   end subroutine process_instance_transfer_same_kinematics
 
 @ %def process_instance_transfer_same_kinematics
 @
 <<Instances: process instance: TBP>>=
   procedure :: redo_sf_chains => process_instance_redo_sf_chains
 <<Instances: procedures>>=
   subroutine process_instance_redo_sf_chains (instance, i_term, phs_channel)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), dimension(:) :: i_term
     integer, intent(in) :: phs_channel
     integer :: i
     do i = 1, size (i_term)
        call instance%term(i_term(i))%redo_sf_chain &
             (instance%mci_work(instance%i_mci), phs_channel)
     end do
   end subroutine process_instance_redo_sf_chains
 
 @ %def process_instance_redo_sf_chains
 @ Integrate the process, using a previously initialized process
 instance.  We select one of the available MCI integrators by its index
 [[i_mci]] and thus integrate over (structure functions and) phase
 space for the associated (group of) process component(s).
 <<Instances: process instance: TBP>>=
   procedure :: integrate => process_instance_integrate
 <<Instances: procedures>>=
   subroutine process_instance_integrate (instance, i_mci, n_it, n_calls, &
        adapt_grids, adapt_weights, final, pacify)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     integer, intent(in) :: n_it
     integer, intent(in) :: n_calls
     logical, intent(in), optional :: adapt_grids
     logical, intent(in), optional :: adapt_weights
     logical, intent(in), optional :: final, pacify
     integer :: nlo_type, i_mci_work
     nlo_type = instance%process%get_component_nlo_type (i_mci)
     i_mci_work = instance%process%get_i_mci_work (i_mci)
     call instance%choose_mci (i_mci_work)
     call instance%reset_counter ()
     associate (mci_work => instance%mci_work(i_mci_work), &
                process => instance%process)
        call process%integrate (i_mci_work, mci_work, &
             instance, n_it, n_calls, adapt_grids, adapt_weights, &
             final, pacify, nlo_type = nlo_type)
        call process%set_counter_mci_entry (i_mci_work, instance%get_counter ())
     end associate
   end subroutine process_instance_integrate
 
 @ %def process_instance_integrate
 @ Subroutine of the initialization above: initialize the beam and
 structure-function chain template.  We establish pointers to the
 configuration data, so [[beam_config]] must have a [[target]]
 attribute.
 
 The resulting chain is not used directly for calculation.  It will
 acquire instances which are stored in the process-component instance
 objects.
 <<Instances: process instance: TBP>>=
   procedure :: setup_sf_chain => process_instance_setup_sf_chain
 <<Instances: procedures>>=
   subroutine process_instance_setup_sf_chain (instance, config)
     class(process_instance_t), intent(inout) :: instance
     type(process_beam_config_t), intent(in), target :: config
     integer :: n_strfun
     n_strfun = config%n_strfun
     if (n_strfun /= 0) then
        call instance%sf_chain%init (config%data, config%sf)
     else
        call instance%sf_chain%init (config%data)
     end if
     if (config%sf_trace) then
        call instance%sf_chain%setup_tracing (config%sf_trace_file)
     end if
   end subroutine process_instance_setup_sf_chain
 
 @ %def process_instance_setup_sf_chain
 @ This initialization routine should be called only for process
 instances which we intend as a source for physical events.  It
 initializes the evaluators in the parton states of the terms.  They
 describe the (semi-)exclusive transition matrix and the distribution
 of color flow for the partonic process, convoluted with the beam and
 structure-function chain.
 
 If the model is not provided explicitly, we may use the model instance that
 belongs to the process.  However, an explicit model allows us to override
 particle settings.
 <<Instances: process instance: TBP>>=
   procedure :: setup_event_data => process_instance_setup_event_data
 <<Instances: procedures>>=
   subroutine process_instance_setup_event_data (instance, model, i_core)
     class(process_instance_t), intent(inout), target :: instance
     class(model_data_t), intent(in), optional, target :: model
     integer, intent(in), optional :: i_core
     class(model_data_t), pointer :: current_model
     integer :: i
     class(prc_core_t), pointer :: core => null ()
     if (present (model)) then
        current_model => model
     else
        current_model => instance%process%get_model_ptr ()
     end if
     do i = 1, size (instance%term)
        associate (term => instance%term(i))
          if (associated (term%config)) then
             core => instance%process%get_core_term (i)
             call term%setup_event_data (core, current_model)
          end if
        end associate
     end do
     core => null ()
   end subroutine process_instance_setup_event_data
 
 @ %def process_instance_setup_event_data
 @ Choose a MC parameter set and the corresponding integrator.
 The choice persists beyond calls of the [[reset]] method above.  This method
 is automatically called here.
 <<Instances: process instance: TBP>>=
   procedure :: choose_mci => process_instance_choose_mci
 <<Instances: procedures>>=
   subroutine process_instance_choose_mci (instance, i_mci)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     instance%i_mci = i_mci
     call instance%reset ()
   end subroutine process_instance_choose_mci
 
 @ %def process_instance_choose_mci
 @ Explicitly set a MC parameter set.  Works only if we are in initial
 state.  We assume that the length of the parameter set is correct.
 
 After setting the parameters, activate the components and terms that
 correspond to the chosen MC parameter set.
 
 The [[warmup_flag]] is used when a dummy phase-space point is computed
 for the warmup of e.g. OpenLoops helicities. The setting of the
 the [[evaluation_status]] has to be avoided then.
 <<Instances: process instance: TBP>>=
   procedure :: set_mcpar => process_instance_set_mcpar
 <<Instances: procedures>>=
   subroutine process_instance_set_mcpar (instance, x, warmup_flag)
     class(process_instance_t), intent(inout) :: instance
     real(default), dimension(:), intent(in) :: x
     logical, intent(in), optional :: warmup_flag
     logical :: activate
     activate = .true.; if (present (warmup_flag)) activate = .not. warmup_flag
     if (instance%evaluation_status == STAT_INITIAL) then
        associate (mci_work => instance%mci_work(instance%i_mci))
           call mci_work%set (x)
        end associate
        if (activate) call instance%activate ()
     end if
   end subroutine process_instance_set_mcpar
 
 @ %def process_instance_set_mcpar
 @ Receive the beam momentum/momenta from a source interaction.  This
 applies to a cascade decay process instance, where the `beam' momentum
 varies event by event.
 
 The master beam momentum array is contained in the main structure
 function chain subobject [[sf_chain]].  The sf-chain instance that
 reside in the components will take their beam momenta from there.
 
 The procedure transforms the instance status into
 [[STAT_BEAM_MOMENTA]].  For process instance with fixed beam, this
 intermediate status is skipped.
 <<Instances: process instance: TBP>>=
   procedure :: receive_beam_momenta => process_instance_receive_beam_momenta
 <<Instances: procedures>>=
   subroutine process_instance_receive_beam_momenta (instance)
     class(process_instance_t), intent(inout) :: instance
     if (instance%evaluation_status >= STAT_INITIAL) then
        call instance%sf_chain%receive_beam_momenta ()
        instance%evaluation_status = STAT_BEAM_MOMENTA
     end if
   end subroutine process_instance_receive_beam_momenta
 
 @ %def process_instance_receive_beam_momenta
 @ Set the beam momentum/momenta explicitly.  Otherwise, analogous to
 the previous procedure.
 <<Instances: process instance: TBP>>=
   procedure :: set_beam_momenta => process_instance_set_beam_momenta
 <<Instances: procedures>>=
   subroutine process_instance_set_beam_momenta (instance, p)
     class(process_instance_t), intent(inout) :: instance
     type(vector4_t), dimension(:), intent(in) :: p
     if (instance%evaluation_status >= STAT_INITIAL) then
        call instance%sf_chain%set_beam_momenta (p)
        instance%evaluation_status = STAT_BEAM_MOMENTA
     end if
   end subroutine process_instance_set_beam_momenta
 
 @ %def process_instance_set_beam_momenta
 @ Recover the initial beam momenta (those in the [[sf_chain]]
 component), given a valid (recovered) [[sf_chain_instance]] in one of
 the active components.  We need to do this only if the lab frame is
 not the c.m.\ frame, otherwise those beams would be fixed anyway.
 <<Instances: process instance: TBP>>=
   procedure :: recover_beam_momenta => process_instance_recover_beam_momenta
 <<Instances: procedures>>=
   subroutine process_instance_recover_beam_momenta (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     if (.not. instance%process%lab_is_cm ()) then
        if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
           call instance%term(i_term)%return_beam_momenta ()
        end if
     end if
   end subroutine process_instance_recover_beam_momenta
 
 @ %def process_instance_recover_beam_momenta
 @ Explicitly choose MC integration channel.  We assume here that the channel
 count is identical for all active components.
 <<Instances: process instance: TBP>>=
   procedure :: select_channel => process_instance_select_channel
 <<Instances: procedures>>=
   subroutine process_instance_select_channel (instance, channel)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: channel
     instance%selected_channel = channel
   end subroutine process_instance_select_channel
 
 @ %def process_instance_select_channel
 @ First step of process evaluation: set up seed kinematics.  That is, for each
 active process component, compute a momentum array from the MC input
 parameters.
 
 If [[skip_term]] is set, we skip the component that accesses this
 term.  We can assume that the associated data have already been
 recovered, and we are just computing the rest.
 <<Instances: process instance: TBP>>=
   procedure :: compute_seed_kinematics => &
        process_instance_compute_seed_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_compute_seed_kinematics (instance, skip_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), optional :: skip_term
     integer :: channel, skip_component, i, j
     logical :: success
     integer, dimension(:), allocatable :: i_term
     channel = instance%selected_channel
     if (channel == 0) then
        call msg_bug ("Compute seed kinematics: undefined integration channel")
     end if
     if (present (skip_term)) then
        skip_component = instance%term(skip_term)%config%i_component
     else
        skip_component = 0
     end if
     if (instance%evaluation_status >= STAT_ACTIVATED) then
        success = .true.
        do i = 1, instance%process%get_n_components ()
           if (i == skip_component)  cycle
           if (instance%process%component_is_selected (i)) then
              allocate (i_term (size (instance%process%get_component_i_terms (i))))
              i_term = instance%process%get_component_i_terms (i)
              do j = 1, size (i_term)
                 if (instance%term(i_term(j))%k_term%new_seed) then
                    call instance%term(i_term(j))%compute_seed_kinematics &
                         (instance%mci_work(instance%i_mci), channel, success)
                    call instance%transfer_same_kinematics (i_term(j))
                 end if
                 if (.not. success)  exit
                 call instance%term(i_term(j))%evaluate_projections ()
                 call instance%term(i_term(j))%evaluate_radiation_kinematics &
                        (instance%mci_work(instance%i_mci)%get_x_process ())
                 call instance%term(i_term(j))%generate_fsr_in ()
                 call instance%term(i_term(j))%compute_xi_ref_momenta ()
              end do
           end if
           if (allocated (i_term)) deallocate (i_term)
        end do
        if (success) then
           instance%evaluation_status = STAT_SEED_KINEMATICS
        else
           instance%evaluation_status = STAT_FAILED_KINEMATICS
        end if
     end if
     associate (mci_work => instance%mci_work(instance%i_mci))
        select type (pcm => instance%pcm)
        class is (pcm_instance_nlo_t)
           call pcm%set_x_rad (mci_work%get_x_process ())
        end select
     end associate
   end subroutine process_instance_compute_seed_kinematics
 
 @ %def process_instance_compute_seed_kinematics
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_x_process => process_instance_get_x_process
 <<Instances: procedures>>=
   pure function process_instance_get_x_process (instance) result (x)
     real(default), dimension(:), allocatable :: x
     class(process_instance_t), intent(in) :: instance
     allocate (x(size (instance%mci_work(instance%i_mci)%get_x_process ())))
     x = instance%mci_work(instance%i_mci)%get_x_process ()
   end function process_instance_get_x_process
 
 @ %def process_instance_get_x_process
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_active_component_type => process_instance_get_active_component_type
 <<Instances: procedures>>=
   pure function process_instance_get_active_component_type (instance) &
          result (nlo_type)
     integer :: nlo_type
     class(process_instance_t), intent(in) :: instance
     nlo_type = instance%process%get_component_nlo_type (instance%i_mci)
   end function process_instance_get_active_component_type
 
 @ %def process_instance_get_active_component_type
 @ Inverse: recover missing parts of the kinematics from the momentum
 configuration, which we know for a single term and component.   Given
 a channel, reconstruct the MC parameter set.
 <<Instances: process instance: TBP>>=
   procedure :: recover_mcpar => process_instance_recover_mcpar
 <<Instances: procedures>>=
   subroutine process_instance_recover_mcpar (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     integer :: channel
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        channel = instance%selected_channel
        if (channel == 0) then
           call msg_bug ("Recover MC parameters: undefined integration channel")
        end if
        call instance%term(i_term)%recover_mcpar &
             (instance%mci_work(instance%i_mci), channel)
     end if
   end subroutine process_instance_recover_mcpar
 
 @ %def process_instance_recover_mcpar
 @ This is part of [[recover_mcpar]], extracted for the case when there is
 no phase space and parameters to recover, but we still need the structure
 function kinematics for evaluation.
 <<Instances: process instance: TBP>>=
   procedure :: recover_sfchain => process_instance_recover_sfchain
 <<Instances: procedures>>=
   subroutine process_instance_recover_sfchain (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     integer :: channel
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        channel = instance%selected_channel
        if (channel == 0) then
           call msg_bug ("Recover sfchain: undefined integration channel")
        end if
        call instance%term(i_term)%recover_sfchain (channel)
     end if
   end subroutine process_instance_recover_sfchain
 
 @ %def process_instance_recover_sfchain
 @ Second step of process evaluation: compute all momenta, for all active
 components, from the seed kinematics.
 <<Instances: process instance: TBP>>=
   procedure :: compute_hard_kinematics => &
        process_instance_compute_hard_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_compute_hard_kinematics (instance, skip_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), optional :: skip_term
     integer :: i
     logical :: success
     success = .true.
     if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
        do i = 1, size (instance%term)
           if (instance%term(i)%active) then
              call instance%term(i)%compute_hard_kinematics (skip_term, success)
              if (.not. success) exit
              !!! Ren scale is zero when this is commented out! Understand!
              if (instance%term(i)%nlo_type == NLO_REAL) &
                   call instance%term(i)%redo_sf_chain (instance%mci_work(instance%i_mci), &
                        instance%selected_channel)
           end if
        end do
        if (success) then
           instance%evaluation_status = STAT_HARD_KINEMATICS
        else
           instance%evaluation_status = STAT_FAILED_KINEMATICS
        end if
     end if
   end subroutine process_instance_compute_hard_kinematics
 
 @ %def process_instance_setup_compute_hard_kinematics
 @ Inverse: recover seed kinematics.  We know the beam momentum
 configuration and the outgoing momenta of the effective interaction,
 for one specific term.
 <<Instances: process instance: TBP>>=
   procedure :: recover_seed_kinematics => &
        process_instance_recover_seed_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_recover_seed_kinematics (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) &
        call instance%term(i_term)%recover_seed_kinematics ()
   end subroutine process_instance_recover_seed_kinematics
 
 @ %def process_instance_recover_seed_kinematics
 @ Third step of process evaluation: compute the effective momentum
 configurations, for all active terms, from the hard kinematics.
 <<Instances: process instance: TBP>>=
   procedure :: compute_eff_kinematics => &
        process_instance_compute_eff_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_compute_eff_kinematics (instance, skip_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), optional :: skip_term
     integer :: i
     if (instance%evaluation_status >= STAT_HARD_KINEMATICS) then
        do i = 1, size (instance%term)
           if (present (skip_term)) then
              if (i == skip_term)  cycle
           end if
           if (instance%term(i)%active) then
              call instance%term(i)%compute_eff_kinematics ()
           end if
        end do
        instance%evaluation_status = STAT_EFF_KINEMATICS
     end if
   end subroutine process_instance_compute_eff_kinematics
 
 @ %def process_instance_setup_compute_eff_kinematics
 @ Inverse: recover the hard kinematics from effective kinematics for
 one term, then compute effective kinematics for the other terms.
 <<Instances: process instance: TBP>>=
   procedure :: recover_hard_kinematics => &
        process_instance_recover_hard_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_recover_hard_kinematics (instance, i_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     integer :: i
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        call instance%term(i_term)%recover_hard_kinematics ()
        do i = 1, size (instance%term)
           if (i /= i_term) then
              if (instance%term(i)%active) then
                 call instance%term(i)%compute_eff_kinematics ()
              end if
           end if
        end do
        instance%evaluation_status = STAT_EFF_KINEMATICS
     end if
   end subroutine process_instance_recover_hard_kinematics
 
 @ %def recover_hard_kinematics
 @ Fourth step of process evaluation: check cuts for all terms.  Where
 successful, compute any scales and weights.  Otherwise, deactive the term.
 If any of the terms has passed, set the state to [[STAT_PASSED_CUTS]].
 
 The argument [[scale_forced]], if present, will override the scale calculation
 in the term expressions.
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_expressions => &
        process_instance_evaluate_expressions
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_expressions (instance, scale_forced)
     class(process_instance_t), intent(inout) :: instance
     real(default), intent(in), allocatable, optional :: scale_forced
     integer :: i
     logical :: passed_real
     if (instance%evaluation_status >= STAT_EFF_KINEMATICS) then
        do i = 1, size (instance%term)
           if (instance%term(i)%active) then
              call instance%term(i)%evaluate_expressions (scale_forced)
           end if
        end do
        call evaluate_real_scales_and_cuts ()
        call set_ellis_sexton_scale ()
        if (.not. passed_real) then
           instance%evaluation_status = STAT_FAILED_CUTS
        else
           if (any (instance%term%passed)) then
              instance%evaluation_status = STAT_PASSED_CUTS
           else
              instance%evaluation_status = STAT_FAILED_CUTS
           end if
        end if
     end if
   contains
     subroutine evaluate_real_scales_and_cuts ()
       integer :: i
       passed_real = .true.
       select type (config => instance%pcm%config)
       type is (pcm_nlo_t)
          do i = 1, size (instance%term)
             if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_REAL) then
                if (config%settings%cut_all_real_sqmes) &
                     passed_real = passed_real .and. instance%term(i)%passed
                if (config%settings%use_born_scale) &
                     call replace_scales (instance%term(i))
             end if
          end do
       end select
     end subroutine evaluate_real_scales_and_cuts
 
     subroutine replace_scales (this_term)
       type(term_instance_t), intent(inout) :: this_term
       integer :: i_sub
       i_sub = this_term%config%i_sub
       if (this_term%config%i_term_global /= i_sub .and. i_sub > 0) then
          this_term%ren_scale = instance%term(i_sub)%ren_scale
          this_term%fac_scale = instance%term(i_sub)%fac_scale
       end if
     end subroutine replace_scales
 
     subroutine set_ellis_sexton_scale ()
       real(default) :: es_scale
       type(var_list_t), pointer :: var_list
       integer :: i
       var_list => instance%process%get_var_list_ptr ()
       es_scale = var_list%get_rval (var_str ("ellis_sexton_scale"))
       do i = 1, size (instance%term)
          if (instance%term(i)%active .and. instance%term(i)%nlo_type == NLO_VIRTUAL) then
             if (es_scale < zero) then
                instance%term(i)%es_scale = instance%term(i)%ren_scale
             else
                instance%term(i)%es_scale = es_scale
             end if
          end if
       end do
     end subroutine set_ellis_sexton_scale
   end subroutine process_instance_evaluate_expressions
 
 @ %def process_instance_evaluate_expressions
 @ Fifth step of process evaluation: fill the parameters for the non-selected
 ,channels, that have not been used for seeding.  We should do this after
 evaluating cuts, since we may save some expensive calculations if the phase
 space point fails the cuts.
 
 If [[skip_term]] is set, we skip the component that accesses this
 term.  We can assume that the associated data have already been
 recovered, and we are just computing the rest.
 <<Instances: process instance: TBP>>=
   procedure :: compute_other_channels => &
        process_instance_compute_other_channels
 <<Instances: procedures>>=
   subroutine process_instance_compute_other_channels (instance, skip_term)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in), optional :: skip_term
     integer :: channel, skip_component, i, j
     integer, dimension(:), allocatable :: i_term
     channel = instance%selected_channel
     if (channel == 0) then
        call msg_bug ("Compute other channels: undefined integration channel")
     end if
     if (present (skip_term)) then
        skip_component = instance%term(skip_term)%config%i_component
     else
        skip_component = 0
     end if
     if (instance%evaluation_status >= STAT_PASSED_CUTS) then
        do i = 1, instance%process%get_n_components ()
           if (i == skip_component)  cycle
           if (instance%process%component_is_selected (i)) then
              allocate (i_term (size (instance%process%get_component_i_terms (i))))
              i_term = instance%process%get_component_i_terms (i)
              do j = 1, size (i_term)
                 call instance%term(i_term(j))%compute_other_channels &
                      (instance%mci_work(instance%i_mci), channel)
              end do
           end if
           if (allocated (i_term)) deallocate (i_term)
        end do
     end if
   end subroutine process_instance_compute_other_channels
 
 @ %def process_instance_compute_other_channels
 @ If not done otherwise, we flag the kinematics as new for the core state,
 such that the routine below will actually compute the matrix element and not
 just look it up.
 <<Instances: process instance: TBP>>=
   procedure :: reset_core_kinematics => process_instance_reset_core_kinematics
 <<Instances: procedures>>=
   subroutine process_instance_reset_core_kinematics (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i
     if (instance%evaluation_status >= STAT_PASSED_CUTS) then
        do i = 1, size (instance%term)
           associate (term => instance%term(i))
             if (term%active .and. term%passed) then
                if (allocated (term%core_state)) &
                     call term%core_state%reset_new_kinematics ()
             end if
           end associate
        end do
     end if
   end subroutine process_instance_reset_core_kinematics
 
 @ %def process_instance_reset_core_kinematics
 @ Sixth step of process evaluation: evaluate the matrix elements, and compute
 the trace (summed over quantum numbers) for all terms.  Finally, sum up the
 terms, iterating over all active process components.
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_trace => process_instance_evaluate_trace
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_trace (instance)
     class(process_instance_t), intent(inout) :: instance
     class(prc_core_t), pointer :: core => null ()
     integer :: i, i_real_fin, i_core
     real(default) :: alpha_s, alpha_qed
     class(prc_core_t), pointer :: core_sub => null ()
     class(model_data_t), pointer :: model => null ()
     logical :: has_pdfs
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_evaluate_trace")
     has_pdfs = instance%process%pcm_contains_pdfs ()
     instance%sqme = zero
     call instance%reset_matrix_elements ()
     if (instance%evaluation_status >= STAT_PASSED_CUTS) then
        do i = 1, size (instance%term)
           associate (term => instance%term(i))
             if (term%active .and. term%passed) then
                core => instance%process%get_core_term (i)
                select type (pcm => instance%process%get_pcm_ptr ())
                class is (pcm_nlo_t)
                   i_core = pcm%get_i_core (pcm%i_sub)
                   core_sub => instance%process%get_core_ptr (i_core)
                end select
                call term%evaluate_interaction (core)
                call term%evaluate_trace ()
                i_real_fin = instance%process%get_associated_real_fin (1)
                if (instance%process%uses_real_partition ()) &
                     call term%apply_real_partition (instance%process)
                if (term%config%i_component /= i_real_fin) then
                   if ((term%nlo_type == NLO_REAL .and. term%k_term%emitter < 0) &
                        .or. term%nlo_type == NLO_MISMATCH &
                        .or. term%nlo_type == NLO_DGLAP) &
                        call term%set_born_sqmes (core)
                   if (term%is_subtraction () .or. &
                        term%nlo_type == NLO_DGLAP) &
                        call term%set_sf_factors (has_pdfs)
                   if (term%nlo_type > BORN) then
                      if (.not. (term%nlo_type == NLO_REAL .and. &
                           term%k_term%emitter >= 0)) then
                         select type (config => term%pcm_instance%config)
                         type is (pcm_nlo_t)
                            if (char (config%settings%nlo_correction_type) == "QCD" .or. &
                                 char (config%settings%nlo_correction_type) == "Full") &
                                 call term%evaluate_color_correlations (core_sub)
                            if (char (config%settings%nlo_correction_type) == "EW" .or. &
                                 char (config%settings%nlo_correction_type) == "Full") &
                                 call term%evaluate_charge_correlations (core_sub)
                         end select
                      end if
                      if (term%is_subtraction ()) then
                         call term%evaluate_spin_correlations (core_sub)
                      end if
                   end if
                   alpha_s = core%get_alpha_s (term%core_state)
                   alpha_qed = core%get_alpha_qed ()
                   if (term%nlo_type > BORN) then
                      select type (config => term%pcm_instance%config)
                      type is (pcm_nlo_t)
                         if (alpha_qed == -1 .and. (&
                              char (config%settings%nlo_correction_type) == "EW" .or. &
                              char (config%settings%nlo_correction_type) == "Full")) then
                            call msg_bug("Attempting to compute EW corrections with alpha_qed = -1")
                         end if
                      end select
                   end if
                   select case (term%nlo_type)
                   case (NLO_REAL)
                      call term%apply_fks (alpha_s, alpha_qed)
                   case (NLO_VIRTUAL)
                      call term%evaluate_sqme_virt (alpha_s, alpha_qed)
                   case (NLO_MISMATCH)
                      call term%evaluate_sqme_mismatch (alpha_s)
                   case (NLO_DGLAP)
                      call term%evaluate_sqme_dglap (alpha_s, alpha_qed)
                   end select
                end if
             end if
             core_sub => null ()
             instance%sqme = instance%sqme + real (sum (&
                  term%connected%trace%get_matrix_element () * &
                  term%weight))
           end associate
        end do
        core => null ()
        if (instance%pcm%is_valid ()) then
           instance%evaluation_status = STAT_EVALUATED_TRACE
        else
           instance%evaluation_status = STAT_FAILED_KINEMATICS
        end if
     else
        !!! Failed kinematics or failed cuts: set sqme to zero
        instance%sqme = zero
     end if
   end subroutine process_instance_evaluate_trace
 
 @ %def process_instance_evaluate_trace
 <<Instances: term instance: TBP>>=
   procedure :: set_born_sqmes => term_instance_set_born_sqmes
 <<Instances: procedures>>=
   subroutine term_instance_set_born_sqmes (term, core)
     class(term_instance_t), intent(inout) :: term
     class(prc_core_t), intent(in) :: core
     integer :: i_flv, ii_flv
     real(default) :: sqme
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        do i_flv = 1, term%connected%trace%get_qn_index_n_flv ()
           ii_flv = term%connected%trace%get_qn_index (i_flv, i_sub = 0)
           sqme = real (term%connected%trace%get_matrix_element (ii_flv))
           select case (term%nlo_type)
           case (NLO_REAL)
              pcm_instance%real_sub%sqme_born(i_flv) = sqme
           case (NLO_MISMATCH)
              pcm_instance%soft_mismatch%sqme_born(i_flv) = sqme
           case (NLO_DGLAP)
              pcm_instance%dglap_remnant%sqme_born(i_flv) = sqme
           end select
        end do
     end select
   end subroutine term_instance_set_born_sqmes
 
 @ %def term_instance_set_born_sqmes
 @ Calculates and then saves the ratio of the value of the (rescaled) real
 structure function chain of each ISR alpha region over the value of the
 corresponding underlying born flavor structure.
 In the case of emitter 0 we also need the rescaled ratio for emitter 1 and 2
 in that region for the (soft-)collinear limits.
 Altough this procedure is implying functionality for general structure functions,
 it should be reviewed for anything else besides PDFs, as there might be complications
 in the details. The general idea of getting the ratio in this way should hold up in
 these cases as well, however.
 <<Instances: term instance: TBP>>=
   procedure :: set_sf_factors => term_instance_set_sf_factors
 <<Instances: procedures>>=
   subroutine term_instance_set_sf_factors (term, has_pdfs)
     class(term_instance_t), intent(inout) :: term
     logical, intent(in) :: has_pdfs
     type(interaction_t), pointer :: sf_chain_int
     real(default) :: factor_born, factor_real
     integer :: n_in, alr, em
     integer :: i_born, i_real
     select type (pcm_instance => term%pcm_instance)
     type is (pcm_instance_nlo_t)
        if (.not. has_pdfs) then
           pcm_instance%real_sub%sf_factors = one
           return
        end if
        select type (config => pcm_instance%config)
        type is (pcm_nlo_t)
           sf_chain_int => term%k_term%sf_chain%get_out_int_ptr ()
           associate (reg_data => config%region_data)
              n_in = reg_data%get_n_in ()
              do alr = 1, reg_data%n_regions
                 em = reg_data%regions(alr)%emitter
                 if (em <= n_in) then
                    i_born = reg_data%regions(alr)%uborn_index
                    i_real = reg_data%regions(alr)%real_index
                    factor_born = sf_chain_int%get_matrix_element &
                         (sf_chain_int%get_sf_qn_index_born (i_born, i_sub = 0))
                    factor_real = sf_chain_int%get_matrix_element &
                         (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em))
                    call set_factor (pcm_instance, alr, em, factor_born, factor_real)
                    if (em == 0) then
                       do em = 1, 2
                          factor_real = sf_chain_int%get_matrix_element &
                               (sf_chain_int%get_sf_qn_index_real (i_real, i_sub = em))
                          call set_factor (pcm_instance, alr, em, factor_born, factor_real)
                       end do
                    end if
                 end if
              end do
           end associate
        end select
     end select
   contains
     subroutine set_factor (pcm_instance, alr, em, factor_born, factor_real)
       type(pcm_instance_nlo_t), intent(inout), target :: pcm_instance
       integer, intent(in) :: alr, em
       real(default), intent(in) :: factor_born, factor_real
       real(default) :: factor
       if (any (vanishes ([factor_real, factor_born], tiny(1._default), tiny(1._default)))) then
          factor = zero
       else
          factor = factor_real / factor_born
       end if
       select case (term%nlo_type)
       case (NLO_REAL)
          pcm_instance%real_sub%sf_factors(alr, em) = factor
       case (NLO_DGLAP)
          pcm_instance%dglap_remnant%sf_factors(alr, em) = factor
       end select
     end subroutine
   end subroutine term_instance_set_sf_factors
 
 @ %def term_instance_set_sf_factors
 @
 <<Instances: process instance: TBP>>=
   procedure :: apply_real_partition => process_instance_apply_real_partition
 <<Instances: procedures>>=
   subroutine process_instance_apply_real_partition (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_component, i_term
     integer, dimension(:), allocatable :: i_terms
     associate (process => instance%process)
        i_component = process%get_first_real_component ()
        if (process%component_is_selected (i_component) .and. &
               process%get_component_nlo_type (i_component) == NLO_REAL) then
           allocate (i_terms (size (process%get_component_i_terms (i_component))))
           i_terms = process%get_component_i_terms (i_component)
           do i_term = 1, size (i_terms)
              call instance%term(i_terms(i_term))%apply_real_partition (process)
           end do
        end if
        if (allocated (i_terms)) deallocate (i_terms)
     end associate
   end subroutine process_instance_apply_real_partition
 
 @ %def process_instance_apply_real_partition
 @
 <<Instances: process instance: TBP>>=
   procedure :: set_i_mci_to_real_component => process_instance_set_i_mci_to_real_component
 <<Instances: procedures>>=
   subroutine process_instance_set_i_mci_to_real_component (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_mci, i_component
     type(process_component_t), pointer :: component => null ()
     select type (pcm_instance => instance%pcm)
     type is (pcm_instance_nlo_t)
        if (allocated (pcm_instance%i_mci_to_real_component)) then
           call msg_warning ("i_mci_to_real_component already allocated - replace it")
           deallocate (pcm_instance%i_mci_to_real_component)
        end if
        allocate (pcm_instance%i_mci_to_real_component (size (instance%mci_work)))
        do i_mci = 1, size (instance%mci_work)
           do i_component = 1, instance%process%get_n_components ()
              component => instance%process%get_component_ptr (i_component)
              if (component%i_mci /= i_mci) cycle
              select case (component%component_type)
              case (COMP_MASTER, COMP_REAL)
                 pcm_instance%i_mci_to_real_component (i_mci) = &
                      component%config%get_associated_real ()
              case (COMP_REAL_FIN)
                 pcm_instance%i_mci_to_real_component (i_mci) = &
                      component%config%get_associated_real_fin ()
              case (COMP_REAL_SING)
                 pcm_instance%i_mci_to_real_component (i_mci) = &
                      component%config%get_associated_real_sing ()
              end select
           end do
        end do
        component => null ()
     end select
   end subroutine process_instance_set_i_mci_to_real_component
 
 @ %def process_instance_set_i_mci_to_real_component
 @ Final step of process evaluation: evaluate the matrix elements, and compute
 the trace (summed over quantum numbers) for all terms.  Finally, sum up the
 terms, iterating over all active process components.
 
 If [[weight]] is provided, we already know the kinematical event
 weight (the MCI weight which depends on the kinematics sampling
 algorithm, but not on the matrix element), so we do not need to take
 it from the MCI record.
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_event_data => process_instance_evaluate_event_data
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_event_data (instance, weight)
     class(process_instance_t), intent(inout) :: instance
     real(default), intent(in), optional :: weight
     integer :: i
     if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
        do i = 1, size (instance%term)
           associate (term => instance%term(i))
             if (term%active) then
                call term%evaluate_event_data ()
             end if
           end associate
        end do
        if (present (weight)) then
           instance%weight = weight
        else
           instance%weight = &
                instance%mci_work(instance%i_mci)%mci%get_event_weight ()
           instance%excess = &
                instance%mci_work(instance%i_mci)%mci%get_event_excess ()
        end if
        instance%n_dropped = &
             instance%mci_work(instance%i_mci)%mci%get_n_event_dropped ()
        instance%evaluation_status = STAT_EVENT_COMPLETE
     else
        !!! failed kinematics etc.: set weight to zero
        instance%weight = zero
        !!! Maybe we want to process and keep the event nevertheless
        if (instance%keep_failed_events ()) then
           do i = 1, size (instance%term)
              associate (term => instance%term(i))
                if (term%active) then
                   call term%evaluate_event_data ()
                end if
              end associate
           end do
 !           do i = 1, size (instance%term)
 !              instance%term(i)%fac_scale = zero
 !           end do
           instance%evaluation_status = STAT_EVENT_COMPLETE
        end if
     end if
   end subroutine process_instance_evaluate_event_data
 
 @ %def process_instance_evaluate_event_data
 @ Computes the real-emission matrix element for externally supplied momenta
 for the term instance with index [[i_term]] and a phase space point set with
 index [[i_phs]]. In addition, for the real emission, each term instance
 corresponds to one emitter. Also, e.g. for Powheg, there is the possibility
 to supply an external $\alpha_s$.
 <<Instances: process instance: TBP>>=
   procedure :: compute_sqme_rad => process_instance_compute_sqme_rad
 <<Instances: procedures>>=
   subroutine process_instance_compute_sqme_rad &
          (instance, i_term, i_phs, is_subtraction, alpha_s_external)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term, i_phs
     logical, intent(in) :: is_subtraction
     real(default), intent(in), optional :: alpha_s_external
     class(prc_core_t), pointer :: core
     integer :: i_real_fin
     logical :: has_pdfs
     has_pdfs = instance%process%pcm_contains_pdfs ()
     if (debug_on) call msg_debug2 (D_PROCESS_INTEGRATION, "process_instance_compute_sqme_rad")
     select type (pcm => instance%pcm)
     type is (pcm_instance_nlo_t)
        associate (term => instance%term(i_term))
           core => instance%process%get_core_term (i_term)
           if (is_subtraction) then
              call pcm%set_subtraction_event ()
           else
              call pcm%set_radiation_event ()
           end if
           call term%int_hard%set_momenta (pcm%get_momenta &
                (i_phs = i_phs, born_phsp = is_subtraction))
           if (allocated (term%core_state)) &
                call term%core_state%reset_new_kinematics ()
           if (present (alpha_s_external)) &
                call term%set_alpha_qcd_forced (alpha_s_external)
           call term%compute_eff_kinematics ()
           call term%evaluate_expressions ()
           call term%evaluate_interaction (core)
           call term%evaluate_trace ()
           if (term%is_subtraction ()) then
              call term%set_sf_factors (has_pdfs)
              select type (config => term%pcm_instance%config)
              type is (pcm_nlo_t)
                 if (char (config%settings%nlo_correction_type) == "QCD" .or. &
                      char (config%settings%nlo_correction_type) == "Full") &
                      call term%evaluate_color_correlations (core)
                 if (char (config%settings%nlo_correction_type) == "EW" .or. &
                      char (config%settings%nlo_correction_type) == "Full") &
                      call term%evaluate_charge_correlations (core)
              end select
              call term%evaluate_spin_correlations (core)
           end if
           i_real_fin = instance%process%get_associated_real_fin (1)
           if (term%config%i_component /= i_real_fin) &
                call term%apply_fks (core%get_alpha_s (term%core_state), &
                                     core%get_alpha_qed ())
           if (instance%process%uses_real_partition ()) &
                call instance%apply_real_partition ()
        end associate
     end select
     core => null ()
   end subroutine process_instance_compute_sqme_rad
 
 @ %def process_instance_compute_sqme_rad
 @ For unweighted event generation, we should reset the reported event
 weight to unity (signed) or zero.  The latter case is appropriate for
 an event which failed for whatever reason.
 <<Instances: process instance: TBP>>=
   procedure :: normalize_weight => process_instance_normalize_weight
 <<Instances: procedures>>=
   subroutine process_instance_normalize_weight (instance)
     class(process_instance_t), intent(inout) :: instance
     if (.not. vanishes (instance%weight)) then
        instance%weight = sign (1._default, instance%weight)
     end if
   end subroutine process_instance_normalize_weight
 
 @ %def process_instance_normalize_weight
 @ This is a convenience routine that performs the computations of the
 steps 1 to 5 in a single step.  The arguments are the input for
 [[set_mcpar]].  After this, the evaluation status should be either
 [[STAT_FAILED_KINEMATICS]], [[STAT_FAILED_CUTS]] or [[STAT_EVALUATED_TRACE]].
 
 Before calling this, we should call [[choose_mci]].
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_sqme => process_instance_evaluate_sqme
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_sqme (instance, channel, x)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: channel
     real(default), dimension(:), intent(in) :: x
     call instance%reset ()
     call instance%set_mcpar (x)
     call instance%select_channel (channel)
     call instance%compute_seed_kinematics ()
     call instance%compute_hard_kinematics ()
     call instance%compute_eff_kinematics ()
     call instance%evaluate_expressions ()
     call instance%compute_other_channels ()
     call instance%evaluate_trace ()
   end subroutine process_instance_evaluate_sqme
 
 @ %def process_instance_evaluate_sqme
 @ This is the inverse.  Assuming that the final trace evaluator
 contains a valid momentum configuration, recover kinematics
 and recalculate the matrix elements and their trace.
 
 To be precise, we first recover kinematics for the given term and
 associated component, then recalculate from that all other terms and
 active components.  The [[channel]] is not really required to obtain
 the matrix element, but it allows us to reconstruct the exact MC
 parameter set that corresponds to the given phase space point.
 
 Before calling this, we should call [[choose_mci]].
 <<Instances: process instance: TBP>>=
   procedure :: recover => process_instance_recover
 <<Instances: procedures>>=
   subroutine process_instance_recover &
        (instance, channel, i_term, update_sqme, recover_phs, scale_forced)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: channel
     integer, intent(in) :: i_term
     logical, intent(in) :: update_sqme
     logical, intent(in) :: recover_phs
     real(default), intent(in), allocatable, optional :: scale_forced
     logical :: skip_phs
     call instance%activate ()
     instance%evaluation_status = STAT_EFF_KINEMATICS
     call instance%recover_hard_kinematics (i_term)
     call instance%recover_seed_kinematics (i_term)
     call instance%select_channel (channel)
     if (recover_phs) then
        call instance%recover_mcpar (i_term)
        call instance%recover_beam_momenta (i_term)
        call instance%compute_seed_kinematics (i_term)
        call instance%compute_hard_kinematics (i_term)
        call instance%compute_eff_kinematics (i_term)
        call instance%compute_other_channels (i_term)
     else
        call instance%recover_sfchain (i_term)
     end if
     call instance%evaluate_expressions (scale_forced)
     if (update_sqme) then
        call instance%reset_core_kinematics ()
        call instance%evaluate_trace ()
     end if
   end subroutine process_instance_recover
 
 @ %def process_instance_recover
 @ The [[evaluate]] method is required by the [[sampler_t]] base type of which
 the process instance is an extension.
 
 The requirement is that after the process instance is evaluated, the
 integrand, the selected channel, the $x$ array, and the $f$ Jacobian array are
 exposed by the [[sampler_t]] object.
 
 We allow for the additional [[hook]] to be called, if associated, for outlying
 object to access information from the current state of the [[sampler]].
 <<Instances: process instance: TBP>>=
   procedure :: evaluate => process_instance_evaluate
 <<Instances: procedures>>=
   subroutine process_instance_evaluate (sampler, c, x_in, val, x, f)
     class(process_instance_t), intent(inout) :: sampler
     integer, intent(in) :: c
     real(default), dimension(:), intent(in) :: x_in
     real(default), intent(out) :: val
     real(default), dimension(:,:), intent(out) :: x
     real(default), dimension(:), intent(out) :: f
     call sampler%evaluate_sqme (c, x_in)
     if (sampler%is_valid ()) then
        call sampler%fetch (val, x, f)
     end if
     call sampler%record_call ()
     call sampler%evaluate_after_hook ()
   end subroutine process_instance_evaluate
 
 @ %def process_instance_evaluate
 @ The phase-space point is valid if the event has valid kinematics and
 has passed the cuts.
 <<Instances: process instance: TBP>>=
   procedure :: is_valid => process_instance_is_valid
 <<Instances: procedures>>=
   function process_instance_is_valid (sampler) result (valid)
     class(process_instance_t), intent(in) :: sampler
     logical :: valid
     valid = sampler%evaluation_status >= STAT_PASSED_CUTS
   end function process_instance_is_valid
 
 @ %def process_instance_is_valid
 @ Add a [[process_instance_hook]] object..
 <<Instances: process instance: TBP>>=
   procedure :: append_after_hook => process_instance_append_after_hook
 <<Instances: procedures>>=
   subroutine process_instance_append_after_hook (sampler, new_hook)
     class(process_instance_t), intent(inout), target :: sampler
     class(process_instance_hook_t), intent(inout), target :: new_hook
     class(process_instance_hook_t), pointer :: last
     if (associated (new_hook%next)) then
        call msg_bug ("process_instance_append_after_hook: reuse of SAME hook object is forbidden.")
     end if
     if (associated (sampler%hook)) then
        last => sampler%hook
        do while (associated (last%next))
           last => last%next
        end do
        last%next => new_hook
     else
        sampler%hook => new_hook
     end if
   end subroutine process_instance_append_after_hook
 
 @ %def process_instance_append_after_evaluate_hook
 @ Evaluate the after hook as first in, last out.
 <<Instances: process instance: TBP>>=
   procedure :: evaluate_after_hook => process_instance_evaluate_after_hook
 <<Instances: procedures>>=
   subroutine process_instance_evaluate_after_hook (sampler)
     class(process_instance_t), intent(in) :: sampler
     class(process_instance_hook_t), pointer :: current
     current => sampler%hook
     do while (associated(current))
        call current%evaluate (sampler)
        current => current%next
     end do
   end subroutine process_instance_evaluate_after_hook
 
 @ %def process_instance_evaluate_after_hook
 @ The [[rebuild]] method should rebuild the kinematics section out of
 the [[x_in]] parameter set.  The integrand value [[val]] should not be
 computed, but is provided as input.
 <<Instances: process instance: TBP>>=
   procedure :: rebuild => process_instance_rebuild
 <<Instances: procedures>>=
   subroutine process_instance_rebuild (sampler, c, x_in, val, x, f)
     class(process_instance_t), intent(inout) :: sampler
     integer, intent(in) :: c
     real(default), dimension(:), intent(in) :: x_in
     real(default), intent(in) :: val
     real(default), dimension(:,:), intent(out) :: x
     real(default), dimension(:), intent(out) :: f
     call msg_bug ("process_instance_rebuild not implemented yet")
     x = 0
     f = 0
   end subroutine process_instance_rebuild
 
 @ %def process_instance_rebuild
 @ This is another method required by the [[sampler_t]] base type:
 fetch the data that are relevant for the MCI record.
 <<Instances: process instance: TBP>>=
   procedure :: fetch => process_instance_fetch
 <<Instances: procedures>>=
   subroutine process_instance_fetch (sampler, val, x, f)
     class(process_instance_t), intent(in) :: sampler
     real(default), intent(out) :: val
     real(default), dimension(:,:), intent(out) :: x
     real(default), dimension(:), intent(out) :: f
     integer, dimension(:), allocatable :: i_terms
     integer :: i, i_term_base, cc
     integer :: n_channel
 
     val = 0
     associate (process => sampler%process)
        FIND_COMPONENT: do i = 1, process%get_n_components ()
          if (sampler%process%component_is_selected (i)) then
             allocate (i_terms (size (process%get_component_i_terms (i))))
             i_terms = process%get_component_i_terms (i)
             i_term_base = i_terms(1)
             associate (k => sampler%term(i_term_base)%k_term)
               n_channel = k%n_channel
               do cc = 1, n_channel
                  call k%get_mcpar (cc, x(:,cc))
               end do
               f = k%f
               val = sampler%sqme * k%phs_factor
             end associate
             if (allocated (i_terms)) deallocate (i_terms)
             exit FIND_COMPONENT
          end if
        end do FIND_COMPONENT
     end associate
   end subroutine process_instance_fetch
 
 @ %def process_instance_fetch
 @ Initialize and finalize event generation for the specified MCI
 entry.
 <<Instances: process instance: TBP>>=
   procedure :: init_simulation => process_instance_init_simulation
   procedure :: final_simulation => process_instance_final_simulation
 <<Instances: procedures>>=
   subroutine process_instance_init_simulation (instance, i_mci, &
      safety_factor, keep_failed_events)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     real(default), intent(in), optional :: safety_factor
     logical, intent(in), optional :: keep_failed_events
     call instance%mci_work(i_mci)%init_simulation (safety_factor, keep_failed_events)
   end subroutine process_instance_init_simulation
 
   subroutine process_instance_final_simulation (instance, i_mci)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_mci
     call instance%mci_work(i_mci)%final_simulation ()
   end subroutine process_instance_final_simulation
 
 @ %def process_instance_init_simulation
 @ %def process_instance_final_simulation
 @
 \subsubsection{Accessing the process instance}
 Once the seed kinematics is complete, we can retrieve the MC input parameters
 for all channels, not just the seed channel.
 
 Note: We choose the first active component.  This makes sense only if the seed
 kinematics is identical for all active components.
 <<Instances: process instance: TBP>>=
   procedure :: get_mcpar => process_instance_get_mcpar
 <<Instances: procedures>>=
   subroutine process_instance_get_mcpar (instance, channel, x)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: channel
     real(default), dimension(:), intent(out) :: x
     integer :: i
     if (instance%evaluation_status >= STAT_SEED_KINEMATICS) then
        do i = 1, size (instance%term)
           if (instance%term(i)%active) then
              call instance%term(i)%k_term%get_mcpar (channel, x)
              return
           end if
        end do
        call msg_bug ("Process instance: get_mcpar: no active channels")
     else
        call msg_bug ("Process instance: get_mcpar: no seed kinematics")
     end if
   end subroutine process_instance_get_mcpar
 
 @ %def process_instance_get_mcpar
 @ Return true if the [[sqme]] value is known.  This also implies that the
 event is kinematically valid and has passed all cuts.
 <<Instances: process instance: TBP>>=
   procedure :: has_evaluated_trace => process_instance_has_evaluated_trace
 <<Instances: procedures>>=
   function process_instance_has_evaluated_trace (instance) result (flag)
     class(process_instance_t), intent(in) :: instance
     logical :: flag
     flag = instance%evaluation_status >= STAT_EVALUATED_TRACE
   end function process_instance_has_evaluated_trace
 
 @ %def process_instance_has_evaluated_trace
 @ Return true if the event is complete.  In particular, the event must
 be kinematically valid, passed all cuts, and the event data have been
 computed.
 <<Instances: process instance: TBP>>=
   procedure :: is_complete_event => process_instance_is_complete_event
 <<Instances: procedures>>=
   function process_instance_is_complete_event (instance) result (flag)
     class(process_instance_t), intent(in) :: instance
     logical :: flag
     flag = instance%evaluation_status >= STAT_EVENT_COMPLETE
   end function process_instance_is_complete_event
 
 @ %def process_instance_is_complete_event
 @ Select the term for the process instance that will provide the basic
 event record (used in [[evt_trivial_make_particle_set]]).  It might be
 necessary to write out additional events corresponding to other terms
 (done in [[evt_nlo]]).
 <<Instances: process instance: TBP>>=
   procedure :: select_i_term => process_instance_select_i_term
 <<Instances: procedures>>=
   function process_instance_select_i_term (instance) result (i_term)
     integer :: i_term
     class(process_instance_t), intent(in) :: instance
     integer :: i_mci
     i_mci = instance%i_mci
     i_term = instance%process%select_i_term (i_mci)
   end function process_instance_select_i_term
 
 @ %def process_instance_select_i_term
 @ Return pointer to the master beam interaction.
 <<Instances: process instance: TBP>>=
   procedure :: get_beam_int_ptr => process_instance_get_beam_int_ptr
 <<Instances: procedures>>=
   function process_instance_get_beam_int_ptr (instance) result (ptr)
     class(process_instance_t), intent(in), target :: instance
     type(interaction_t), pointer :: ptr
     ptr => instance%sf_chain%get_beam_int_ptr ()
   end function process_instance_get_beam_int_ptr
 
 @ %def process_instance_get_beam_int_ptr
 @ Return pointers to the matrix and flows interactions, given a term index.
 <<Instances: process instance: TBP>>=
   procedure :: get_trace_int_ptr => process_instance_get_trace_int_ptr
   procedure :: get_matrix_int_ptr => process_instance_get_matrix_int_ptr
   procedure :: get_flows_int_ptr => process_instance_get_flows_int_ptr
 <<Instances: procedures>>=
   function process_instance_get_trace_int_ptr (instance, i_term) result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(interaction_t), pointer :: ptr
     ptr => instance%term(i_term)%connected%get_trace_int_ptr ()
   end function process_instance_get_trace_int_ptr
 
   function process_instance_get_matrix_int_ptr (instance, i_term) result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(interaction_t), pointer :: ptr
     ptr => instance%term(i_term)%connected%get_matrix_int_ptr ()
   end function process_instance_get_matrix_int_ptr
 
   function process_instance_get_flows_int_ptr (instance, i_term) result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(interaction_t), pointer :: ptr
     ptr => instance%term(i_term)%connected%get_flows_int_ptr ()
   end function process_instance_get_flows_int_ptr
 
 @ %def process_instance_get_trace_int_ptr
 @ %def process_instance_get_matrix_int_ptr
 @ %def process_instance_get_flows_int_ptr
 @ Return the complete account of flavor combinations in the underlying
 interaction object, including beams, radiation, and hard interaction.
 <<Instances: process instance: TBP>>=
   procedure :: get_state_flv => process_instance_get_state_flv
 <<Instances: procedures>>=
   function process_instance_get_state_flv (instance, i_term) result (state_flv)
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     type(state_flv_content_t) :: state_flv
     state_flv = instance%term(i_term)%connected%get_state_flv ()
   end function process_instance_get_state_flv
 
 @ %def process_instance_get_state_flv
 @ Return pointers to the parton states of a selected term.
 <<Instances: process instance: TBP>>=
   procedure :: get_isolated_state_ptr => &
        process_instance_get_isolated_state_ptr
   procedure :: get_connected_state_ptr => &
        process_instance_get_connected_state_ptr
 <<Instances: procedures>>=
   function process_instance_get_isolated_state_ptr (instance, i_term) &
        result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(isolated_state_t), pointer :: ptr
     ptr => instance%term(i_term)%isolated
   end function process_instance_get_isolated_state_ptr
 
   function process_instance_get_connected_state_ptr (instance, i_term) &
        result (ptr)
     class(process_instance_t), intent(in), target :: instance
     integer, intent(in) :: i_term
     type(connected_state_t), pointer :: ptr
     ptr => instance%term(i_term)%connected
   end function process_instance_get_connected_state_ptr
 
 @ %def process_instance_get_isolated_state_ptr
 @ %def process_instance_get_connected_state_ptr
 @ Return the indices of the beam particles and incoming partons within the
 currently active state matrix, respectively.
 <<Instances: process instance: TBP>>=
   procedure :: get_beam_index => process_instance_get_beam_index
   procedure :: get_in_index => process_instance_get_in_index
 <<Instances: procedures>>=
   subroutine process_instance_get_beam_index (instance, i_term, i_beam)
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     integer, dimension(:), intent(out) :: i_beam
     call instance%term(i_term)%connected%get_beam_index (i_beam)
   end subroutine process_instance_get_beam_index
 
   subroutine process_instance_get_in_index (instance, i_term, i_in)
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     integer, dimension(:), intent(out) :: i_in
     call instance%term(i_term)%connected%get_in_index (i_in)
   end subroutine process_instance_get_in_index
 
 @ %def process_instance_get_beam_index
 @ %def process_instance_get_in_index
 @ Return squared matrix element and event weight, and event weight
 excess where applicable.  [[n_dropped]] is a number that can be
 nonzero when a weighted event has been generated, dropping events with
 zero weight (failed cuts) on the fly.
 <<Instances: process instance: TBP>>=
   procedure :: get_sqme => process_instance_get_sqme
   procedure :: get_weight => process_instance_get_weight
   procedure :: get_excess => process_instance_get_excess
   procedure :: get_n_dropped => process_instance_get_n_dropped
 <<Instances: procedures>>=
   function process_instance_get_sqme (instance, i_term) result (sqme)
     real(default) :: sqme
     class(process_instance_t), intent(in) :: instance
     integer, intent(in), optional :: i_term
     if (instance%evaluation_status >= STAT_EVALUATED_TRACE) then
        if (present (i_term)) then
           sqme = instance%term(i_term)%connected%trace%get_matrix_element (1)
        else
           sqme = instance%sqme
        end if
     else
        sqme = 0
     end if
   end function process_instance_get_sqme
 
   function process_instance_get_weight (instance) result (weight)
     real(default) :: weight
     class(process_instance_t), intent(in) :: instance
     if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
        weight = instance%weight
     else
        weight = 0
     end if
   end function process_instance_get_weight
 
   function process_instance_get_excess (instance) result (excess)
     real(default) :: excess
     class(process_instance_t), intent(in) :: instance
     if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
        excess = instance%excess
     else
        excess = 0
     end if
   end function process_instance_get_excess
 
   function process_instance_get_n_dropped (instance) result (n_dropped)
     integer :: n_dropped
     class(process_instance_t), intent(in) :: instance
     if (instance%evaluation_status >= STAT_EVENT_COMPLETE) then
        n_dropped = instance%n_dropped
     else
        n_dropped = 0
     end if
   end function process_instance_get_n_dropped
 
 @ %def process_instance_get_sqme
 @ %def process_instance_get_weight
 @ %def process_instance_get_excess
 @ %def process_instance_get_n_dropped
 @ Return the currently selected MCI channel.
 <<Instances: process instance: TBP>>=
   procedure :: get_channel => process_instance_get_channel
 <<Instances: procedures>>=
   function process_instance_get_channel (instance) result (channel)
     integer :: channel
     class(process_instance_t), intent(in) :: instance
     channel = instance%selected_channel
   end function process_instance_get_channel
 
 @ %def process_instance_get_channel
 @
 <<Instances: process instance: TBP>>=
   procedure :: set_fac_scale => process_instance_set_fac_scale
 <<Instances: procedures>>=
   subroutine process_instance_set_fac_scale (instance, fac_scale)
     class(process_instance_t), intent(inout) :: instance
     real(default), intent(in) :: fac_scale
     integer :: i_term
     i_term = 1
     call instance%term(i_term)%set_fac_scale (fac_scale)
   end subroutine process_instance_set_fac_scale
 
 @ %def process_instance_set_fac_scale
 @ Return factorization scale and strong coupling.  We have to select a
 term instance.
 <<Instances: process instance: TBP>>=
   procedure :: get_fac_scale => process_instance_get_fac_scale
   procedure :: get_alpha_s => process_instance_get_alpha_s
 <<Instances: procedures>>=
   function process_instance_get_fac_scale (instance, i_term) result (fac_scale)
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     real(default) :: fac_scale
     fac_scale = instance%term(i_term)%get_fac_scale ()
   end function process_instance_get_fac_scale
 
   function process_instance_get_alpha_s (instance, i_term) result (alpha_s)
     real(default) :: alpha_s
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     class(prc_core_t), pointer :: core => null ()
     core => instance%process%get_core_term (i_term)
     alpha_s = instance%term(i_term)%get_alpha_s (core)
     core => null ()
   end function process_instance_get_alpha_s
 
 @ %def process_instance_get_fac_scale
 @ %def process_instance_get_alpha_s
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_qcd => process_instance_get_qcd
 <<Instances: procedures>>=
   function process_instance_get_qcd (process_instance) result (qcd)
     type(qcd_t) :: qcd
     class(process_instance_t), intent(in) :: process_instance
     qcd = process_instance%process%get_qcd ()
   end function process_instance_get_qcd
 
 @ %def process_instance_get_qcd
 @ Counter.
 <<Instances: process instance: TBP>>=
   procedure :: reset_counter => process_instance_reset_counter
   procedure :: record_call => process_instance_record_call
   procedure :: get_counter => process_instance_get_counter
 <<Instances: procedures>>=
   subroutine process_instance_reset_counter (process_instance)
     class(process_instance_t), intent(inout) :: process_instance
     call process_instance%mci_work(process_instance%i_mci)%reset_counter ()
   end subroutine process_instance_reset_counter
 
   subroutine process_instance_record_call (process_instance)
     class(process_instance_t), intent(inout) :: process_instance
     call process_instance%mci_work(process_instance%i_mci)%record_call &
          (process_instance%evaluation_status)
   end subroutine process_instance_record_call
 
   pure function process_instance_get_counter (process_instance) result (counter)
     class(process_instance_t), intent(in) :: process_instance
     type(process_counter_t) :: counter
     counter = process_instance%mci_work(process_instance%i_mci)%get_counter ()
   end function process_instance_get_counter
 
 @ %def process_instance_reset_counter
 @ %def process_instance_record_call
 @ %def process_instance_get_counter
 @ Sum up the total number of calls for all MCI records.
 <<Instances: process instance: TBP>>=
   procedure :: get_actual_calls_total => process_instance_get_actual_calls_total
 <<Instances: procedures>>=
   pure function process_instance_get_actual_calls_total (process_instance) &
        result (n)
     class(process_instance_t), intent(in) :: process_instance
     integer :: n
     integer :: i
     type(process_counter_t) :: counter
     n = 0
     do i = 1, size (process_instance%mci_work)
        counter = process_instance%mci_work(i)%get_counter ()
        n = n + counter%total
     end do
   end function process_instance_get_actual_calls_total
 
 @ %def process_instance_get_actual_calls_total
 @
 <<Instances: process instance: TBP>>=
   procedure :: reset_matrix_elements => process_instance_reset_matrix_elements
 <<Instances: procedures>>=
   subroutine process_instance_reset_matrix_elements (instance)
     class(process_instance_t), intent(inout) :: instance
     integer :: i_term
     do i_term = 1, size (instance%term)
        call instance%term(i_term)%connected%trace%set_matrix_element (cmplx (0, 0, default))
        call instance%term(i_term)%connected%matrix%set_matrix_element (cmplx (0, 0, default))
     end do
   end subroutine process_instance_reset_matrix_elements
 
 @ %def process_instance_reset_matrix_elements
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_test_phase_space_point &
      => process_instance_get_test_phase_space_point
 <<Instances: procedures>>=
   subroutine process_instance_get_test_phase_space_point (instance, &
          i_component, i_core, p)
     type(vector4_t), dimension(:), allocatable, intent(out) :: p
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_component, i_core
     real(default), dimension(:), allocatable :: x
     logical :: success
     integer :: i_term
     instance%i_mci = i_component
     i_term = instance%process%get_i_term (i_core)
     associate (term => instance%term(i_term))
        allocate (x (instance%mci_work(i_component)%config%n_par))
        x = 0.5_default
        call instance%set_mcpar (x, .true.)
        call instance%select_channel (1)
        call term%compute_seed_kinematics &
             (instance%mci_work(i_component), 1, success)
        call instance%term(i_term)%evaluate_radiation_kinematics &
               (instance%mci_work(instance%i_mci)%get_x_process ())
        call instance%term(i_term)%compute_hard_kinematics (success = success)
        allocate (p (size (term%p_hard)))
        p = term%int_hard%get_momenta ()
     end associate
   end subroutine process_instance_get_test_phase_space_point
 
 @ %def process_instance_get_test_phase_space_point
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_p_hard => process_instance_get_p_hard
 <<Instances: procedures>>=
   pure function process_instance_get_p_hard (process_instance, i_term) &
          result (p_hard)
     type(vector4_t), dimension(:), allocatable :: p_hard
     class(process_instance_t), intent(in) :: process_instance
     integer, intent(in) :: i_term
     allocate (p_hard (size (process_instance%term(i_term)%get_p_hard ())))
     p_hard = process_instance%term(i_term)%get_p_hard ()
   end function process_instance_get_p_hard
 
 @ %def process_instance_get_p_hard
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_first_active_i_term => process_instance_get_first_active_i_term
 <<Instances: procedures>>=
   function process_instance_get_first_active_i_term (instance) result (i_term)
     integer :: i_term
     class(process_instance_t), intent(in) :: instance
     integer :: i
     i_term = 0
     do i = 1, size (instance%term)
        if (instance%term(i)%active) then
           i_term = i
           exit
        end if
     end do
   end function process_instance_get_first_active_i_term
 
 @ %def process_instance_get_first_active_i_term
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_real_of_mci => process_instance_get_real_of_mci
 <<Instances: procedures>>=
   function process_instance_get_real_of_mci (instance) result (i_real)
     integer :: i_real
     class(process_instance_t), intent(in) :: instance
     select type (pcm => instance%pcm)
     type is (pcm_instance_nlo_t)
        i_real = pcm%i_mci_to_real_component (instance%i_mci)
     end select
   end function process_instance_get_real_of_mci
 
 @ %def process_instance_get_real_of_mci
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_connected_states => process_instance_get_connected_states
 <<Instances: procedures>>=
   function process_instance_get_connected_states (instance, i_component) result (connected)
     type(connected_state_t), dimension(:), allocatable :: connected
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_component
     connected = instance%process%get_connected_states (i_component, &
         instance%term(:)%connected)
   end function process_instance_get_connected_states
 
 @ %def process_instance_get_connected_states
 @ Get the hadronic center-of-mass energy
 <<Instances: process instance: TBP>>=
   procedure :: get_sqrts => process_instance_get_sqrts
 <<Instances: procedures>>=
   function process_instance_get_sqrts (instance) result (sqrts)
     class(process_instance_t), intent(in) :: instance
     real(default) :: sqrts
     sqrts = instance%process%get_sqrts ()
   end function process_instance_get_sqrts
 
 @ %def process_instance_get_sqrts
 @ Get the polarizations
 <<Instances: process instance: TBP>>=
   procedure :: get_polarization => process_instance_get_polarization
 <<Instances: procedures>>=
   function process_instance_get_polarization (instance) result (pol)
     class(process_instance_t), intent(in) :: instance
     real(default), dimension(2) :: pol
     pol = instance%process%get_polarization ()
   end function process_instance_get_polarization
 
 @ %def process_instance_get_polarization
 @ Get the beam spectrum
 <<Instances: process instance: TBP>>=
   procedure :: get_beam_file => process_instance_get_beam_file
 <<Instances: procedures>>=
   function process_instance_get_beam_file (instance) result (file)
     class(process_instance_t), intent(in) :: instance
     type(string_t) :: file
     file = instance%process%get_beam_file ()
   end function process_instance_get_beam_file
 
 @ %def process_instance_get_beam_file
 @ Get the process name
 <<Instances: process instance: TBP>>=
   procedure :: get_process_name => process_instance_get_process_name
 <<Instances: procedures>>=
   function process_instance_get_process_name (instance) result (name)
     class(process_instance_t), intent(in) :: instance
     type(string_t) :: name
     name = instance%process%get_id ()
   end function process_instance_get_process_name
 
 @ %def process_instance_get_process_name
 @
 \subsubsection{Particle sets}
 Here we provide two procedures that convert the process instance
 from/to a particle set.  The conversion applies to the trace evaluator
 which has no quantum-number information, thus it involves only the
 momenta and the parent-child relations.  We keep virtual particles.
 
 If [[n_incoming]] is provided, the status code of the first
 [[n_incoming]] particles will be reset to incoming.  Otherwise, they
 would be classified as virtual.
 
 Nevertheless, it is possible to reconstruct the complete structure
 from a particle set.  The reconstruction implies a re-evaluation of
 the structure function and matrix-element codes.
 
 The [[i_term]] index is needed for both input and output, to select
 among different active trace evaluators.
 
 In both cases, the [[instance]] object must be properly initialized.
 
 NB: The [[recover_beams]] option should be used only when the particle
 set originates from an external event file, and the user has asked for
 it.  It should be switched off when reading from raw event file.
 <<Instances: process instance: TBP>>=
   procedure :: get_trace => process_instance_get_trace
   procedure :: set_trace => process_instance_set_trace
 <<Instances: procedures>>=
   subroutine process_instance_get_trace (instance, pset, i_term, n_incoming)
     class(process_instance_t), intent(in), target :: instance
     type(particle_set_t), intent(out) :: pset
     integer, intent(in) :: i_term
     integer, intent(in), optional :: n_incoming
     type(interaction_t), pointer :: int
     logical :: ok
     int => instance%get_trace_int_ptr (i_term)
     call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
          [0._default, 0._default], .false., .true., n_incoming)
   end subroutine process_instance_get_trace
 
   subroutine process_instance_set_trace &
        (instance, pset, i_term, recover_beams, check_match, success)
     class(process_instance_t), intent(inout), target :: instance
     type(particle_set_t), intent(in) :: pset
     integer, intent(in) :: i_term
     logical, intent(in), optional :: recover_beams, check_match
     logical, intent(out), optional :: success
     type(interaction_t), pointer :: int
     integer :: n_in
     int => instance%get_trace_int_ptr (i_term)
     n_in = instance%process%get_n_in ()
     call pset%fill_interaction (int, n_in, &
          recover_beams = recover_beams, &
          check_match = check_match, &
          state_flv = instance%get_state_flv (i_term), &
          success = success)
   end subroutine process_instance_set_trace
 
 @ %def process_instance_get_trace
 @ %def process_instance_set_trace
 @ This procedure allows us to override any QCD setting of the WHIZARD process
 and directly set the coupling value that comes together with a particle set.
 <<Instances: process instance: TBP>>=
   procedure :: set_alpha_qcd_forced => process_instance_set_alpha_qcd_forced
 <<Instances: procedures>>=
   subroutine process_instance_set_alpha_qcd_forced (instance, i_term, alpha_qcd)
     class(process_instance_t), intent(inout) :: instance
     integer, intent(in) :: i_term
     real(default), intent(in) :: alpha_qcd
     call instance%term(i_term)%set_alpha_qcd_forced (alpha_qcd)
   end subroutine process_instance_set_alpha_qcd_forced
 
 @ %def process_instance_set_alpha_qcd_forced
 @
 <<Instances: process instance: TBP>>=
   procedure :: has_nlo_component => process_instance_has_nlo_component
 <<Instances: procedures>>=
   function process_instance_has_nlo_component (instance) result (nlo)
     class(process_instance_t), intent(in) :: instance
     logical :: nlo
     nlo = instance%process%is_nlo_calculation ()
   end function process_instance_has_nlo_component
 
 @ %def process_instance_has_nlo_component
 @
 <<Instances: process instance: TBP>>=
   procedure :: keep_failed_events => process_instance_keep_failed_events
 <<Instances: procedures>>=
   function process_instance_keep_failed_events (instance) result (keep)
     logical :: keep
     class(process_instance_t), intent(in) :: instance
     keep = instance%mci_work(instance%i_mci)%keep_failed_events
   end function process_instance_keep_failed_events
 
 @ %def process_instance_keep_failed_events
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_term_indices => process_instance_get_term_indices
 <<Instances: procedures>>=
   function process_instance_get_term_indices (instance, nlo_type) result (i_term)
     integer, dimension(:), allocatable :: i_term
     class(process_instance_t), intent(in) :: instance
     integer :: nlo_type
     allocate (i_term (count (instance%term%nlo_type == nlo_type)))
     i_term = pack (instance%term%get_i_term_global (), instance%term%nlo_type == nlo_type)
   end function process_instance_get_term_indices
 
 @ %def process_instance_get_term_indices
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_boost_to_lab => process_instance_get_boost_to_lab
 <<Instances: procedures>>=
   function process_instance_get_boost_to_lab (instance, i_term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     lt = instance%term(i_term)%get_boost_to_lab ()
   end function process_instance_get_boost_to_lab
 
 @ %def process_instance_get_boost_to_lab
 @
 <<Instances: process instance: TBP>>=
   procedure :: get_boost_to_cms => process_instance_get_boost_to_cms
 <<Instances: procedures>>=
   function process_instance_get_boost_to_cms (instance, i_term) result (lt)
     type(lorentz_transformation_t) :: lt
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     lt = instance%term(i_term)%get_boost_to_cms ()
   end function process_instance_get_boost_to_cms
 
 @ %def process_instance_get_boost_to_cms
 @
 <<Instances: process instance: TBP>>=
   procedure :: lab_is_cm => process_instance_lab_is_cm
 <<Instances: procedures>>=
   function process_instance_lab_is_cm (instance, i_term) result (lab_is_cm)
     logical :: lab_is_cm
     class(process_instance_t), intent(in) :: instance
     integer, intent(in) :: i_term
     lab_is_cm = instance%term(i_term)%k_term%phs%lab_is_cm ()
   end function process_instance_lab_is_cm
 
 @ %def process_instance_lab_is_cm
 @
 The [[pacify]] subroutine has the purpose of setting numbers to zero
 which are (by comparing with a [[tolerance]] parameter) considered
 equivalent with zero.  We do this in some unit tests.  Here, we a
 apply this to the phase space subobject of the process instance.
 <<Instances: public>>=
   public :: pacify
 <<Instances: interfaces>>=
   interface pacify
      module procedure pacify_process_instance
   end interface pacify
 
 <<Instances: procedures>>=
   subroutine pacify_process_instance (instance)
     type(process_instance_t), intent(inout) :: instance
     integer :: i
     do i = 1, size (instance%term)
        call pacify (instance%term(i)%k_term%phs)
     end do
   end subroutine pacify_process_instance
 
 @ %def pacify
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[processes_ut.f90]]>>=
 <<File header>>
 
 module processes_ut
   use unit_tests
   use processes_uti
 
 <<Standard module head>>
 
 <<Processes: public test>>
 
 <<Processes: public test auxiliary>>
 
 contains
 
 <<Processes: test driver>>
 
 end module processes_ut
 @ %def processes_ut
 @
 <<[[processes_uti.f90]]>>=
 <<File header>>
 
 module processes_uti
 
 <<Use kinds>>
 <<Use strings>>
   use format_utils, only: write_separator
   use constants, only: TWOPI4
   use physics_defs, only: CONV
   use os_interface
   use sm_qcd
   use lorentz
   use pdg_arrays
   use model_data
   use models
   use var_base, only: vars_t
   use variables, only: var_list_t
   use model_testbed, only: prepare_model
   use particle_specifiers, only: new_prt_spec
   use flavors
   use interactions, only: reset_interaction_counter
   use particles
   use rng_base
   use mci_base
   use mci_none, only: mci_none_t
   use mci_midpoint
   use sf_mappings
   use sf_base
   use phs_base
   use phs_single
   use phs_forests, only: syntax_phs_forest_init, syntax_phs_forest_final
   use phs_wood, only: phs_wood_config_t
   use resonances, only: resonance_history_set_t
   use process_constants
   use prc_core_def, only: prc_core_def_t
   use prc_core
   use prc_test, only: prc_test_create_library
   use prc_template_me, only: template_me_def_t
   use process_libraries
   use prc_test_core
 
   use process_counter
   use process_config, only: process_term_t
   use process, only: process_t
   use instances, only: process_instance_t, process_instance_hook_t
 
   use rng_base_ut, only: rng_test_factory_t
   use sf_base_ut, only: sf_test_data_t
   use mci_base_ut, only: mci_test_t
   use phs_base_ut, only: phs_test_config_t
 
 <<Standard module head>>
 
 <<Processes: public test auxiliary>>
 
 <<Processes: test declarations>>
 
 <<Processes: test types>>
 
 contains
 
 <<Processes: tests>>
 
 <<Processes: test auxiliary>>
 
 end module processes_uti
 
 @ %def processes_uti
 @ API: driver for the unit tests below.
 <<Processes: public test>>=
   public :: processes_test
 <<Processes: test driver>>=
   subroutine processes_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Processes: execute tests>>
   end subroutine processes_test
 
 @ %def processes_test
 \subsubsection{Write an empty process object}
 The most trivial test is to write an uninitialized process object.
 <<Processes: execute tests>>=
   call test (processes_1, "processes_1", &
        "write an empty process object", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_1
 <<Processes: tests>>=
   subroutine processes_1 (u)
     integer, intent(in) :: u
     type(process_t) :: process
 
     write (u, "(A)")  "* Test output: processes_1"
     write (u, "(A)")  "*   Purpose: display an empty process object"
     write (u, "(A)")
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_1"
 
   end subroutine processes_1
 
 @ %def processes_1
 @
 \subsubsection{Initialize a process object}
 Initialize a process and display it.
 <<Processes: execute tests>>=
   call test (processes_2, "processes_2", &
        "initialize a simple process object", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_2
 <<Processes: tests>>=
   subroutine processes_2 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable :: process
     class(mci_t), allocatable :: mci_template
     class(phs_config_t), allocatable :: phs_config_template
 
     write (u, "(A)")  "* Test output: processes_2"
     write (u, "(A)")  "*   Purpose: initialize a simple process object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes2"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     write (u, "(A)")  "* Initialize a process object"
     write (u, "(A)")
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
     call process%set_run_id (var_str ("run_2"))
     call process%setup_test_cores ()
 
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     call process%setup_mci (dispatch_mci_empty)
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_2"
 
   end subroutine processes_2
 
 @ %def processes_2
 @ Trivial for testing: do not allocate the MCI record.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_empty (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
   end subroutine dispatch_mci_empty
 
 @ %def dispatch_mci_empty
 @
 \subsubsection{Compute a trivial matrix element}
 Initialize a process, retrieve some information and compute a matrix
 element.
 
 We use the same trivial process as for the previous test.  All
 momentum and state dependence is trivial, so we just test basic
 functionality.
 <<Processes: execute tests>>=
   call test (processes_3, "processes_3", &
        "retrieve a trivial matrix element", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_3
 <<Processes: tests>>=
   subroutine processes_3 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable :: process
     class(phs_config_t), allocatable :: phs_config_template
     type(process_constants_t) :: data
     type(vector4_t), dimension(:), allocatable :: p
 
     write (u, "(A)")  "* Test output: processes_3"
     write (u, "(A)")  "*   Purpose: create a process &
          &and compute a matrix element"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes3"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
     call process%setup_test_cores ()
 
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
     call process%setup_mci (dispatch_mci_test3)
 
     write (u, "(A)")  "* Return the number of process components"
     write (u, "(A)")
 
     write (u, "(A,I0)")  "n_components = ", process%get_n_components ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Return the number of flavor states"
     write (u, "(A)")
 
     data = process%get_constants (1)
 
     write (u, "(A,I0)")  "n_flv(1) = ", data%n_flv
 
     write (u, "(A)")
     write (u, "(A)")  "* Return the first flavor state"
     write (u, "(A)")
 
     write (u, "(A,4(1x,I0))")  "flv_state(1) =", data%flv_state (:,1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up kinematics &
          &[arbitrary, the matrix element is constant]"
 
     allocate (p (4))
 
     write (u, "(A)")
     write (u, "(A)")  "* Retrieve the matrix element"
     write (u, "(A)")
 
 
     write (u, "(A,F5.3,' + ',F5.3,' I')")  "me (1, p, 1, 1, 1) = ", &
          process%compute_amplitude (1, 1, 1, p, 1, 1, 1)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_3"
 
   end subroutine processes_3
 
 @ %def processes_3
 @ MCI record with some contents.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_test3 (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
     allocate (mci_test_t :: mci)
     select type (mci)
     type is (mci_test_t)
        call mci%set_dimensions (2, 2)
        call mci%set_divisions (100)
     end select
   end subroutine dispatch_mci_test3
 
 @ %def dispatch_mci_test3
 @
 \subsubsection{Generate a process instance}
 Initialize a process and process instance, choose a sampling point and
 fill the process instance.
 
 We use the same trivial process as for the previous test.  All
 momentum and state dependence is trivial, so we just test basic
 functionality.
 <<Processes: execute tests>>=
   call test (processes_4, "processes_4", &
        "create and fill a process instance (partonic event)", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_4
 <<Processes: tests>>=
   subroutine processes_4 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_4"
     write (u, "(A)")  "*   Purpose: create a process &
          &and fill a process instance"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a test process"
     write (u, "(A)")
 
     libname = "processes4"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_empty)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inject a set of random numbers"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%set_mcpar ([0._default, 0._default])
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up hard kinematics"
     write (u, "(A)")
 
     call process_instance%select_channel (1)
     call process_instance%compute_seed_kinematics ()
     call process_instance%compute_hard_kinematics ()
     call process_instance%compute_eff_kinematics ()
     call process_instance%evaluate_expressions ()
     call process_instance%compute_other_channels ()
 
     write (u, "(A)")  "* Evaluate matrix element and square"
     write (u, "(A)")
 
     call process_instance%evaluate_trace ()
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
 
     call process_instance%activate ()
     process_instance%evaluation_status = STAT_EFF_KINEMATICS
     call process_instance%recover_hard_kinematics (i_term = 1)
     call process_instance%recover_seed_kinematics (i_term = 1)
     call process_instance%select_channel (1)
     call process_instance%recover_mcpar (i_term = 1)
 
     call process_instance%compute_seed_kinematics (skip_term = 1)
     call process_instance%compute_hard_kinematics (skip_term = 1)
     call process_instance%compute_eff_kinematics (skip_term = 1)
 
     call process_instance%evaluate_expressions ()
     call process_instance%compute_other_channels (skip_term = 1)
     call process_instance%evaluate_trace ()
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_4"
 
   end subroutine processes_4
 
 @ %def processes_4
 @
 \subsubsection{Structure function configuration}
 Configure structure functions (multi-channel) in a process object.
 <<Processes: execute tests>>=
   call test (processes_7, "processes_7", &
        "process configuration with structure functions", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_7
 <<Processes: tests>>=
   subroutine processes_7 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_channel_t), dimension(2) :: sf_channel
 
     write (u, "(A)")  "* Test output: processes_7"
     write (u, "(A)")  "*   Purpose: initialize a process with &
          &structure functions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes7"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Set beam, structure functions, and mappings"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
 
     pdg_in = 25
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (process%get_model_ptr (), pdg_in)
     end select
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call process%init_sf_chain (sf_config)
     deallocate (sf_config)
 
     call process%test_allocate_sf_channels (3)
 
     call sf_channel(1)%init (2)
     call sf_channel(1)%activate_mapping ([1,2])
     call process%set_sf_channel (2, sf_channel(1))
 
     call sf_channel(2)%init (2)
     call sf_channel(2)%set_s_mapping ([1,2])
     call process%set_sf_channel (3, sf_channel(2))
 
     call process%setup_mci (dispatch_mci_empty)
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_7"
 
   end subroutine processes_7
 
 @ %def processes_7
 @
 \subsubsection{Evaluating a process with structure function}
 Configure structure functions (single-channel) in a process object,
 create an instance, compute kinematics and evaluate.
 
 Note the order of operations when setting up structure functions and
 phase space.  The beams are first, they determine the [[sqrts]] value.
 We can also set up the chain of structure functions.  We then
 configure the phase space.  From this, we can obtain information about
 special configurations (resonances, etc.), which we need for
 allocating the possible structure-function channels (parameterizations
 and mappings).  Finally, we match phase-space channels onto
 structure-function channels.
 
 In the current example, this matching is trivial; we only have one
 structure-function channel.
 <<Processes: execute tests>>=
   call test (processes_8, "processes_8", &
        "process evaluation with structure functions", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_8
 <<Processes: tests>>=
   subroutine processes_8 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_channel_t) :: sf_channel
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_8"
     write (u, "(A)")  "*   Purpose: evaluate a process with &
          &structure functions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes8"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Set beam, structure functions, and mappings"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
 
     pdg_in = 25
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (process%get_model_ptr (), pdg_in)
     end select
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call process%init_sf_chain (sf_config)
     deallocate (sf_config)
 
     call process%configure_phs ()
 
     call process%test_allocate_sf_channels (1)
 
     call sf_channel%init (2)
     call sf_channel%activate_mapping ([1,2])
     call process%set_sf_channel (1, sf_channel)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_mci (dispatch_mci_empty)
     call process%setup_terms ()
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Set up kinematics and evaluate"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%evaluate_sqme (1, &
          [0.8_default, 0.8_default, 0.1_default, 0.2_default])
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (2)
 
     allocate (process_instance)
     call process_instance%init (process)
 
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover &
          (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_8"
 
   end subroutine processes_8
 
 @ %def processes_8
 @
 \subsubsection{Multi-channel phase space and structure function}
 This is an extension of the previous example.  This time, we have two
 distinct structure-function channels which are matched to the two
 distinct phase-space channels.
 <<Processes: execute tests>>=
   call test (processes_9, "processes_9", &
        "multichannel kinematics and structure functions", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_9
 <<Processes: tests>>=
   subroutine processes_9 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_channel_t) :: sf_channel
     real(default), dimension(4) :: x_saved
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_9"
     write (u, "(A)")  "*   Purpose: evaluate a process with &
          &structure functions"
     write (u, "(A)")  "*            in a multi-channel configuration"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes9"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Set beam, structure functions, and mappings"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
 
     pdg_in = 25
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (process%get_model_ptr (), pdg_in)
     end select
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call process%init_sf_chain (sf_config)
     deallocate (sf_config)
 
     call process%configure_phs ()
 
     call process%test_allocate_sf_channels (2)
 
     call sf_channel%init (2)
     call process%set_sf_channel (1, sf_channel)
 
     call sf_channel%init (2)
     call sf_channel%activate_mapping ([1,2])
     call process%set_sf_channel (2, sf_channel)
 
     call process%test_set_component_sf_channel ([1, 2])
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_mci (dispatch_mci_empty)
     call process%setup_terms ()
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Set up kinematics in channel 1 and evaluate"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%evaluate_sqme (1, &
          [0.8_default, 0.8_default, 0.1_default, 0.2_default])
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract MC input parameters"
     write (u, "(A)")
 
     write (u, "(A)")  "Channel 1:"
     call process_instance%get_mcpar (1, x_saved)
     write (u, "(2x,9(1x,F7.5))")  x_saved
 
     write (u, "(A)")  "Channel 2:"
     call process_instance%get_mcpar (2, x_saved)
     write (u, "(2x,9(1x,F7.5))")  x_saved
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up kinematics in channel 2 and evaluate"
     write (u, "(A)")
 
     call process_instance%evaluate_sqme (2, x_saved)
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance for channel 2"
     write (u, "(A)")
 
     call reset_interaction_counter (2)
 
     allocate (process_instance)
     call process_instance%init (process)
 
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover &
          (channel = 2, i_term = 1, update_sqme = .true., recover_phs = .true.)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_9"
 
   end subroutine processes_9
 
 @ %def processes_9
 @
 \subsubsection{Event generation}
 Activate the MC integrator for the process object and use it to
 generate a single event.  Note that the test integrator does not
 require integration in preparation for generating events.
 <<Processes: execute tests>>=
   call test (processes_10, "processes_10", &
        "event generation", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_10
 <<Processes: tests>>=
   subroutine processes_10 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(mci_t), pointer :: mci
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
 
     write (u, "(A)")  "* Test output: processes_10"
     write (u, "(A)")  "*   Purpose: generate events for a process without &
          &structure functions"
     write (u, "(A)")  "*            in a multi-channel configuration"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes10"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
 
     call process%setup_mci (dispatch_mci_test10)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Generate weighted event"
     write (u, "(A)")
 
     call process%test_get_mci_ptr (mci)
     select type (mci)
     type is (mci_test_t)
        ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7
        call mci%rng%init (3)
        ! Include the constant PHS factor in the stored maximum of the integrand
        call mci%set_max_factor (conv * twopi4 &
             / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2))))
     end select
 
     call process_instance%generate_weighted_event (1)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate unweighted event"
     write (u, "(A)")
 
     call process_instance%generate_unweighted_event (1)
     call process%test_get_mci_ptr (mci)
     select type (mci)
     type is (mci_test_t)
        write (u, "(A,I0)")  " Success in try ", mci%tries
        write (u, "(A)")
     end select
 
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_10"
 
   end subroutine processes_10
 
 @ %def processes_10
 @ MCI record with some contents.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_test10 (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
     allocate (mci_test_t :: mci)
     select type (mci)
     type is (mci_test_t);  call mci%set_divisions (100)
     end select
   end subroutine dispatch_mci_test10
 
 @ %def dispatch_mci_test10
 @
 \subsubsection{Integration}
 Activate the MC integrator for the process object and use it to
 integrate over phase space.
 <<Processes: execute tests>>=
   call test (processes_11, "processes_11", &
        "integration", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_11
 <<Processes: tests>>=
   subroutine processes_11 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(mci_t), allocatable :: mci_template
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t), allocatable, target :: process_instance
 
     write (u, "(A)")  "* Test output: processes_11"
     write (u, "(A)")  "*   Purpose: integrate a process without &
          &structure functions"
     write (u, "(A)")  "*            in a multi-channel configuration"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes11"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
 
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
 
     call process%setup_mci (dispatch_mci_test10)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Integrate with default test parameters"
     write (u, "(A)")
 
     call process_instance%integrate (1, n_it=1, n_calls=10000)
     call process%final_integration (1)
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A,ES13.7)")  " Integral divided by phs factor = ", &
          process%get_integral (1) &
          / process_instance%term(1)%k_term%phs_factor
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_11"
 
   end subroutine processes_11
 
 @ %def processes_11
 @
 \subsubsection{Complete events}
 For the purpose of simplifying further tests, we implement a
 convenience routine that initializes a process and prepares a single
 event.  This is a wrapup of the test [[processes_10]].
 
 The procedure is re-exported by the [[processes_ut]] module.
 <<Processes: public test auxiliary>>=
   public :: prepare_test_process
 <<Processes: test auxiliary>>=
   subroutine prepare_test_process &
        (process, process_instance, model, var_list, run_id)
     type(process_t), intent(out), target :: process
     type(process_instance_t), intent(out), target :: process_instance
     class(model_data_t), intent(in), target :: model
     type(var_list_t), intent(inout), optional :: var_list
     type(string_t), intent(in), optional :: run_id
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), allocatable, target :: process_model
     class(mci_t), pointer :: mci
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     libname = "processes_test"
     procname = libname
     call os_data%init ()
     call prc_test_create_library (libname, lib)
     call reset_interaction_counter ()
     allocate (process_model)
     call process_model%init (model%get_name (), &
          model%get_n_real (), &
          model%get_n_complex (), &
          model%get_n_field (), &
          model%get_n_vtx ())
     call process_model%copy_from (model)
     call process%init (procname, lib, os_data, process_model, var_list)
     if (present (run_id))  call process%set_run_id (run_id)
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_test10)
     call process%setup_terms ()
     call process_instance%init (process)
     call process%test_get_mci_ptr (mci)
     select type (mci)
     type is (mci_test_t)
        ! This ensures that the next 'random' numbers are 0.3, 0.5, 0.7
        call mci%rng%init (3)
        ! Include the constant PHS factor in the stored maximum of the integrand
        call mci%set_max_factor (conv * twopi4 &
             / (2 * sqrt (lambda (sqrts **2, 125._default**2, 125._default**2))))
     end select
     call process%reset_library_ptr ()  ! avoid dangling pointer
     call process_model%final ()
   end subroutine prepare_test_process
 
 @ %def prepare_test_process
 @ Here we do the cleanup of the process and process instance emitted
 by the previous routine.
 <<Processes: public test auxiliary>>=
   public :: cleanup_test_process
 <<Processes: test auxiliary>>=
   subroutine cleanup_test_process (process, process_instance)
     type(process_t), intent(inout) :: process
     type(process_instance_t), intent(inout) :: process_instance
     call process_instance%final ()
     call process%final ()
   end subroutine cleanup_test_process
 
 @ %def cleanup_test_process
 @
 This is the actual test.  Prepare the test process and event, fill
 all evaluators, and display the results.  Use a particle set as
 temporary storage, read kinematics and recalculate the event.
 <<Processes: execute tests>>=
   call test (processes_12, "processes_12", &
        "event post-processing", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_12
 <<Processes: tests>>=
   subroutine processes_12 (u)
     integer, intent(in) :: u
     type(process_t), allocatable, target :: process
     type(process_instance_t), allocatable, target :: process_instance
     type(particle_set_t) :: pset
     type(model_data_t), target :: model
 
     write (u, "(A)")  "* Test output: processes_12"
     write (u, "(A)")  "*   Purpose: generate a complete partonic event"
     write (u, "(A)")
 
     call model%init_test ()
 
     write (u, "(A)")  "* Build and initialize process and process instance &
          &and generate event"
     write (u, "(A)")
 
     allocate (process)
     allocate (process_instance)
     call prepare_test_process (process, process_instance, model, &
          run_id = var_str ("run_12"))
     call process_instance%setup_event_data (i_core = 1)
 
     call process%prepare_simulation (1)
     call process_instance%init_simulation (1)
     call process_instance%generate_weighted_event (1)
     call process_instance%evaluate_event_data ()
 
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
 
     call process_instance%final_simulation (1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover kinematics and recalculate"
     write (u, "(A)")
 
     call reset_interaction_counter (2)
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%setup_event_data ()
 
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover &
          (channel = 1, i_term = 1, update_sqme = .true., recover_phs = .true.)
 
     call process_instance%recover_event ()
     call process_instance%evaluate_event_data ()
 
     call process_instance%write (u)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call cleanup_test_process (process, process_instance)
     deallocate (process_instance)
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_12"
 
   end subroutine processes_12
 
 @ %def processes_12
 @
 \subsubsection{Colored interaction}
 This test specifically checks the transformation of process data
 (flavor, helicity, and color) into an interaction in a process term.
 
 We use the [[test_t]] process core (which has no nontrivial
 particles), but call only the [[is_allowed]] method, which always
 returns true.
 <<Processes: execute tests>>=
   call test (processes_13, "processes_13", &
        "colored interaction", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_13
 <<Processes: tests>>=
   subroutine processes_13 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(process_term_t) :: term
     class(prc_core_t), allocatable :: core
 
     write (u, "(A)")  "* Test output: processes_13"
     write (u, "(A)")  "*   Purpose: initialized a colored interaction"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up a process constants block"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_sm_test ()
 
     allocate (test_t :: core)
 
     associate (data => term%data)
       data%n_in = 2
       data%n_out = 3
       data%n_flv = 2
       data%n_hel = 2
       data%n_col = 2
       data%n_cin = 2
 
       allocate (data%flv_state (5, 2))
       data%flv_state (:,1) = [ 1, 21, 1, 21, 21]
       data%flv_state (:,2) = [ 2, 21, 2, 21, 21]
 
       allocate (data%hel_state (5, 2))
       data%hel_state (:,1) = [1, 1, 1, 1, 0]
       data%hel_state (:,2) = [1,-1, 1,-1, 0]
 
       allocate (data%col_state (2, 5, 2))
       data%col_state (:,:,1) = &
            reshape ([[1, 0], [2,-1], [3, 0], [2,-3], [0,0]], [2,5])
       data%col_state (:,:,2) = &
            reshape ([[1, 0], [2,-3], [3, 0], [2,-1], [0,0]], [2,5])
 
       allocate (data%ghost_flag (5, 2))
       data%ghost_flag(1:4,:) = .false.
       data%ghost_flag(5,:) = .true.
 
     end associate
 
     write (u, "(A)")  "* Set up the interaction"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call term%setup_interaction (core, model)
     call term%int%basic_write (u)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_13"
   end subroutine processes_13
 
 @ %def processes_13
 @
 \subsubsection{MD5 sums}
 Configure a process with structure functions (multi-channel) and
 compute MD5 sums
 <<Processes: execute tests>>=
   call test (processes_14, "processes_14", &
        "process configuration and MD5 sum", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_14
 <<Processes: tests>>=
   subroutine processes_14 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_channel_t), dimension(3) :: sf_channel
 
     write (u, "(A)")  "* Test output: processes_14"
     write (u, "(A)")  "*   Purpose: initialize a process with &
          &structure functions"
     write (u, "(A)")  "*            and compute MD5 sum"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes7"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
     call lib%compute_md5sum ()
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_test_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Set beam, structure functions, and mappings"
     write (u, "(A)")
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
 
     pdg_in = 25
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (process%get_model_ptr (), pdg_in)
     end select
 
     call process%test_allocate_sf_channels (3)
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call process%init_sf_chain (sf_config)
     deallocate (sf_config)
 
     call sf_channel(1)%init (2)
     call process%set_sf_channel (1, sf_channel(1))
 
     call sf_channel(2)%init (2)
     call sf_channel(2)%activate_mapping ([1,2])
     call process%set_sf_channel (2, sf_channel(2))
 
     call sf_channel(3)%init (2)
     call sf_channel(3)%set_s_mapping ([1,2])
     call process%set_sf_channel (3, sf_channel(3))
 
     call process%setup_mci (dispatch_mci_empty)
 
     call process%compute_md5sum ()
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_14"
 
   end subroutine processes_14
 
 @ %def processes_14
 @
 \subsubsection{Decay Process Evaluation}
 Initialize an evaluate a decay process.
 <<Processes: execute tests>>=
   call test (processes_15, "processes_15", &
        "decay process", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_15
 <<Processes: tests>>=
   subroutine processes_15 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     type(process_instance_t), allocatable, target :: process_instance
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_15"
     write (u, "(A)")  "*   Purpose: initialize a decay process object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes15"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib, scattering = .false., &
          decay = .true.)
 
     call model%init_test ()
     call model%set_par (var_str ("ff"), 0.4_default)
     call model%set_par (var_str ("mf"), &
          model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
 
     write (u, "(A)")  "* Initialize a process object"
     write (u, "(A)")
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_single_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     call process%setup_beams_decay (i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_empty)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (3)
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inject a set of random numbers"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%set_mcpar ([0._default, 0._default])
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up hard kinematics"
     write (u, "(A)")
 
     call process_instance%select_channel (1)
     call process_instance%compute_seed_kinematics ()
     call process_instance%compute_hard_kinematics ()
 
     write (u, "(A)")  "* Evaluate matrix element and square"
     write (u, "(A)")
 
     call process_instance%compute_eff_kinematics ()
     call process_instance%evaluate_expressions ()
     call process_instance%compute_other_channels ()
     call process_instance%evaluate_trace ()
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (3)
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover (1, 1, .true., .true.)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_15"
 
   end subroutine processes_15
 
 @ %def processes_15
 @
 \subsubsection{Integration: decay}
 Activate the MC integrator for the decay object and use it to
 integrate over phase space.
 <<Processes: execute tests>>=
   call test (processes_16, "processes_16", &
        "decay integration", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_16
 <<Processes: tests>>=
   subroutine processes_16 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     type(process_instance_t), allocatable, target :: process_instance
 
     write (u, "(A)")  "* Test output: processes_16"
     write (u, "(A)")  "*   Purpose: integrate a process without &
          &structure functions"
     write (u, "(A)")  "*            in a multi-channel configuration"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and initialize a process object"
     write (u, "(A)")
 
     libname = "processes16"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib, scattering = .false., &
          decay = .true.)
 
     call reset_interaction_counter ()
 
     call model%init_test ()
     call model%set_par (var_str ("ff"), 0.4_default)
     call model%set_par (var_str ("mf"), &
          model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_single_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     call process%setup_beams_decay (i_core = 1)
     call process%configure_phs ()
 
     call process%setup_mci (dispatch_mci_test_midpoint)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     allocate (process_instance)
     call process_instance%init (process)
 
     write (u, "(A)")  "* Integrate with default test parameters"
     write (u, "(A)")
 
     call process_instance%integrate (1, n_it=1, n_calls=10000)
     call process%final_integration (1)
 
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A,ES13.7)")  " Integral divided by phs factor = ", &
          process%get_integral (1) &
          / process_instance%term(1)%k_term%phs_factor
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_16"
 
   end subroutine processes_16
 
 @ %def processes_16
 @ MCI record prepared for midpoint integrator.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_test_midpoint (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
     allocate (mci_midpoint_t :: mci)
   end subroutine dispatch_mci_test_midpoint
 
 @ %def dispatch_mci_test_midpoint
 @
 \subsubsection{Decay Process Evaluation}
 Initialize an evaluate a decay process for a moving particle.
 <<Processes: execute tests>>=
   call test (processes_17, "processes_17", &
        "decay of moving particle", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_17
 <<Processes: tests>>=
   subroutine processes_17 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     type(process_instance_t), allocatable, target :: process_instance
     type(particle_set_t) :: pset
     type(flavor_t) :: flv_beam
     real(default) :: m, p, E
 
     write (u, "(A)")  "* Test output: processes_17"
     write (u, "(A)")  "*   Purpose: initialize a decay process object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes17"
     procname = libname
 
     call os_data%init ()
 
     call prc_test_create_library (libname, lib, scattering = .false., &
          decay = .true.)
 
     write (u, "(A)")  "* Initialize a process object"
     write (u, "(A)")
 
     call model%init_test ()
     call model%set_par (var_str ("ff"), 0.4_default)
     call model%set_par (var_str ("mf"), &
          model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
 
     allocate (process)
     call process%init (procname, lib, os_data, model)
 
     call process%setup_test_cores ()
     allocate (phs_single_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     write (u, "(A)")  "* Prepare a trivial beam setup"
     write (u, "(A)")
 
     call process%setup_beams_decay (rest_frame = .false., i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_empty)
 
     write (u, "(A)")  "* Complete process initialization"
     write (u, "(A)")
 
     call process%setup_terms ()
     call process%write (.false., u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create a process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (3)
 
     allocate (process_instance)
     call process_instance%init (process)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parent momentum and random numbers"
     write (u, "(A)")
 
     call process_instance%choose_mci (1)
     call process_instance%set_mcpar ([0._default, 0._default])
 
     call flv_beam%init (25, process%get_model_ptr ())
     m = flv_beam%get_mass ()
     p = 3 * m / 4
     E = sqrt (m**2 + p**2)
     call process_instance%set_beam_momenta ([vector4_moving (E, p, 3)])
 
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up hard kinematics"
     write (u, "(A)")
 
     call process_instance%select_channel (1)
     call process_instance%compute_seed_kinematics ()
     call process_instance%compute_hard_kinematics ()
 
     write (u, "(A)")  "* Evaluate matrix element and square"
     write (u, "(A)")
 
     call process_instance%compute_eff_kinematics ()
     call process_instance%evaluate_expressions ()
     call process_instance%compute_other_channels ()
     call process_instance%evaluate_trace ()
     call process_instance%write (u)
 
     call process_instance%get_trace (pset, 1)
     call process_instance%final ()
     deallocate (process_instance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover process instance"
     write (u, "(A)")
 
     call reset_interaction_counter (3)
 
     allocate (process_instance)
     call process_instance%init (process)
 
     call process_instance%choose_mci (1)
     call process_instance%set_trace (pset, 1, check_match = .false.)
     call process_instance%recover (1, 1, .true., .true.)
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call pset%final ()
     call process_instance%final ()
     deallocate (process_instance)
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_17"
 
   end subroutine processes_17
 
 @ %def processes_17
 @
 \subsubsection{Resonances in Phase Space}
 This test demonstrates the extraction of the resonance-history set from the
 generated phase space.  We need a nontrivial process, but no matrix element.
 This is provided by the [[prc_template]] method, using the [[SM]] model.  We
 also need the [[phs_wood]] method, otherwise we would not have resonances in
 the phase space configuration.
 <<Processes: execute tests>>=
   call test (processes_18, "processes_18", &
        "extract resonance history set", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_18
 <<Processes: tests>>=
   subroutine processes_18 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(string_t) :: model_name
     type(os_data_t) :: os_data
     class(model_data_t), pointer :: model
     class(vars_t), pointer :: vars
     type(process_t), pointer :: process
     type(resonance_history_set_t) :: res_set
     integer :: i
 
     write (u, "(A)")  "* Test output: processes_18"
     write (u, "(A)")  "*   Purpose: extra resonance histories"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build and load a test library with one process"
     write (u, "(A)")
 
     libname = "processes_18_lib"
     procname = "processes_18_p"
 
     call os_data%init ()
 
     call syntax_phs_forest_init ()
 
     model_name = "SM"
     model => null ()
     call prepare_model (model, model_name, vars)
 
     write (u, "(A)")  "* Initialize a process library with one process"
     write (u, "(A)")
 
     select type (model)
     class is (model_t)
        call prepare_resonance_test_library (lib, libname, procname, model, os_data, u)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize a process object with phase space"
 
     allocate (process)
     select type (model)
     class is (model_t)
        call prepare_resonance_test_process (process, lib, procname, model, os_data)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract resonance history set"
     write (u, "(A)")
 
     call process%extract_resonance_history_set (res_set)
     call res_set%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process%final ()
     deallocate (process)
 
     call model%final ()
     deallocate (model)
 
     call syntax_phs_forest_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_18"
 
   end subroutine processes_18
 
 @ %def processes_18
 @ Auxiliary subroutine that constructs the process library for the above test.
 <<Processes: test auxiliary>>=
   subroutine prepare_resonance_test_library &
        (lib, libname, procname, model, os_data, u)
     type(process_library_t), target, intent(out) :: lib
     type(string_t), intent(in) :: libname
     type(string_t), intent(in) :: procname
     type(model_t), intent(in), target :: model
     type(os_data_t), intent(in) :: os_data
     integer, intent(in) :: u
     type(string_t), dimension(:), allocatable :: prt_in, prt_out
     class(prc_core_def_t), allocatable :: def
     type(process_def_entry_t), pointer :: entry
 
     call lib%init (libname)
 
     allocate (prt_in (2), prt_out (3))
     prt_in = [var_str ("e+"), var_str ("e-")]
     prt_out = [var_str ("d"), var_str ("ubar"), var_str ("W+")]
 
     allocate (template_me_def_t :: def)
     select type (def)
     type is (template_me_def_t)
        call def%init (model, prt_in, prt_out, unity = .false.)
     end select
     allocate (entry)
     call entry%init (procname, &
          model_name = model%get_name (), &
          n_in = 2, n_components = 1)
     call entry%import_component (1, n_out = size (prt_out), &
          prt_in  = new_prt_spec (prt_in), &
          prt_out = new_prt_spec (prt_out), &
          method  = var_str ("template"), &
          variant = def)
     call entry%write (u)
 
     call lib%append (entry)
 
     call lib%configure (os_data)
     call lib%write_makefile (os_data, force = .true., verbose = .false.)
     call lib%clean (os_data, distclean = .false.)
     call lib%write_driver (force = .true.)
     call lib%load (os_data)
 
   end subroutine prepare_resonance_test_library
 
 @ %def prepare_resonance_test_library
 @ We want a test process which has been initialized up to the point where we
 can evaluate the matrix element.  This is in fact rather complicated.  We copy
 the steps from [[integration_setup_process]] in the [[integrate]] module,
 which is not available at this point.
 <<Processes: test auxiliary>>=
   subroutine prepare_resonance_test_process &
        (process, lib, procname, model, os_data)
     class(process_t), intent(out), target :: process
     type(process_library_t), intent(in), target :: lib
     type(string_t), intent(in) :: procname
     type(model_t), intent(in), target :: model
     type(os_data_t), intent(in) :: os_data
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
 
     call process%init (procname, lib, os_data, model)
 
     allocate (phs_wood_config_t :: phs_config_template)
     call process%init_components (phs_config_template)
 
     call process%setup_test_cores (type_string = var_str ("template"))
 
     sqrts = 1000
     call process%setup_beams_sqrts (sqrts, i_core = 1)
     call process%configure_phs ()
     call process%setup_mci (dispatch_mci_none)
 
     call process%setup_terms ()
 
   end subroutine prepare_resonance_test_process
 
 @ %def prepare_resonance_test_process
 @ MCI record prepared for the none (dummy) integrator.
 <<Processes: test auxiliary>>=
   subroutine dispatch_mci_none (mci, var_list, process_id, is_nlo)
     class(mci_t), allocatable, intent(out) :: mci
     type(var_list_t), intent(in) :: var_list
     type(string_t), intent(in) :: process_id
     logical, intent(in), optional :: is_nlo
     allocate (mci_none_t :: mci)
   end subroutine dispatch_mci_none
 
 @ %def dispatch_mci_none
 @
 \subsubsection{Add after evaluate hook(s)}
 Initialize a process and process instance, add a trivial process hook,
 choose a sampling point and fill the process instance.
 
 We use the same trivial process as for the previous test.  All
 momentum and state dependence is trivial, so we just test basic
 functionality.
 <<Processes: test types>>=
   type, extends(process_instance_hook_t) :: process_instance_hook_test_t
     integer :: unit
     character(len=15) :: name
   contains
     procedure :: init => process_instance_hook_test_init
     procedure :: final => process_instance_hook_test_final
     procedure :: evaluate => process_instance_hook_test_evaluate
   end type process_instance_hook_test_t
 
 @
 <<Processes: test auxiliary>>=
   subroutine process_instance_hook_test_init (hook, var_list, instance)
     class(process_instance_hook_test_t), intent(inout), target :: hook
     type(var_list_t), intent(in) :: var_list
     class(process_instance_t), intent(in), target :: instance
   end subroutine process_instance_hook_test_init
 
   subroutine process_instance_hook_test_final (hook)
     class(process_instance_hook_test_t), intent(inout) :: hook
   end subroutine process_instance_hook_test_final
 
   subroutine process_instance_hook_test_evaluate (hook, instance)
     class(process_instance_hook_test_t), intent(inout) :: hook
     class(process_instance_t), intent(in), target :: instance
     write (hook%unit, "(A)") "Execute hook:"
     write (hook%unit, "(2X,A,1X,A,I0,A)") hook%name, "(", len (trim (hook%name)), ")"
   end subroutine process_instance_hook_test_evaluate
 
 @
 <<Processes: execute tests>>=
   call test (processes_19, "processes_19", &
        "add trivial hooks to a process instance ", &
        u, results)
 <<Processes: test declarations>>=
   public :: processes_19
 <<Processes: tests>>=
   subroutine processes_19 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     class(model_data_t), pointer :: model
     type(process_t), allocatable, target :: process
     class(phs_config_t), allocatable :: phs_config_template
     real(default) :: sqrts
     type(process_instance_t) :: process_instance
     class(process_instance_hook_t), allocatable, target :: process_instance_hook, process_instance_hook2
     type(particle_set_t) :: pset
 
     write (u, "(A)")  "* Test output: processes_19"
     write (u, "(A)")  "*   Purpose: allocate process instance &
          &and add an after evaluate hook"
     write (u, "(A)")
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate a process instance"
     write (u, "(A)")
 
     call process_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate hook and add to process instance"
     write (u, "(A)")
 
     allocate (process_instance_hook_test_t :: process_instance_hook)
     call process_instance%append_after_hook (process_instance_hook)
 
     allocate (process_instance_hook_test_t :: process_instance_hook2)
     call process_instance%append_after_hook (process_instance_hook2)
 
     select type (process_instance_hook)
     type is (process_instance_hook_test_t)
        process_instance_hook%unit = u
        process_instance_hook%name = "Hook 1"
     end select
     select type (process_instance_hook2)
     type is (process_instance_hook_test_t)
        process_instance_hook2%unit = u
        process_instance_hook2%name = "Hook 2"
     end select
 
     write (u, "(A)")  "* Evaluate matrix element and square"
     write (u, "(A)")
 
     call process_instance%evaluate_after_hook ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call process_instance_hook%final ()
     deallocate (process_instance_hook)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: processes_19"
 
   end subroutine processes_19
 
 @ %def processes_19
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Process Stacks}
 
 For storing and handling multiple processes, we define process stacks.
 These are ordinary stacks where new process entries are pushed onto
 the top.  We allow for multiple entries with identical process ID, but
 distinct run ID.
 
 The implementation is essentially identical to the [[prclib_stacks]] module
 above.  Unfortunately, Fortran supports no generic programming, so we do not
 make use of this fact.
 
 When searching for a specific process ID, we will get (a pointer to)
 the topmost process entry with that ID on the stack, which was entered
 last.  Usually, this is the best version of the process (in terms of
 integral, etc.)  Thus the stack terminology makes sense.
 <<[[process_stacks.f90]]>>=
 <<File header>>
 
 module process_stacks
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_utils, only: write_separator
   use diagnostics
   use os_interface
   use sm_qcd
   use model_data
   use rng_base
   use variables
   use observables
   use process_libraries
   use process
 
 <<Standard module head>>
 
 <<Process stacks: public>>
 
 <<Process stacks: types>>
 
 contains
 
 <<Process stacks: procedures>>
 
 end module process_stacks
 @ %def process_stacks
 @
 \subsection{The process entry type}
 A process entry is a process object, augmented by a pointer to the
 next entry.  We do not need specific methods, all relevant methods are
 inherited.
 
 On higher level, processes should be prepared as process entry objects.
 <<Process stacks: public>>=
   public :: process_entry_t
 <<Process stacks: types>>=
   type, extends (process_t) :: process_entry_t
      type(process_entry_t), pointer :: next => null ()
   end type process_entry_t
 
 @ %def process_entry_t
 @
 \subsection{The process stack type}
 For easy conversion and lookup it is useful to store the filling
 number in the object.  The content is stored as a linked list.
 
 The [[var_list]] component stores process-specific results, so they
 can be retrieved as (pseudo) variables.
 
 The process stack can be linked to another one.  This allows us to
 work with stacks of local scope.
 <<Process stacks: public>>=
   public :: process_stack_t
 <<Process stacks: types>>=
   type :: process_stack_t
      integer :: n = 0
      type(process_entry_t), pointer :: first => null ()
      type(var_list_t), pointer :: var_list => null ()
      type(process_stack_t), pointer :: next => null ()
    contains
    <<Process stacks: process stack: TBP>>
   end type process_stack_t
 
 @ %def process_stack_t
 @ Finalize partly: deallocate the process stack and variable list
 entries, but keep the variable list as an empty object.  This way, the
 variable list links are kept.
 <<Process stacks: process stack: TBP>>=
   procedure :: clear => process_stack_clear
 <<Process stacks: procedures>>=
   subroutine process_stack_clear (stack)
     class(process_stack_t), intent(inout) :: stack
     type(process_entry_t), pointer :: process
     if (associated (stack%var_list)) then
        call stack%var_list%final ()
     end if
     do while (associated (stack%first))
        process => stack%first
        stack%first => process%next
        call process%final ()
        deallocate (process)
     end do
     stack%n = 0
   end subroutine process_stack_clear
 
 @ %def process_stack_clear
 @ Finalizer.  Clear and deallocate the variable list.
 <<Process stacks: process stack: TBP>>=
   procedure :: final => process_stack_final
 <<Process stacks: procedures>>=
   subroutine process_stack_final (object)
     class(process_stack_t), intent(inout) :: object
     call object%clear ()
     if (associated (object%var_list)) then
        deallocate (object%var_list)
     end if
   end subroutine process_stack_final
 
 @ %def process_stack_final
 @ Output.  The processes on the stack will be ordered LIFO, i.e.,
 backwards.
 <<Process stacks: process stack: TBP>>=
   procedure :: write => process_stack_write
 <<Process stacks: procedures>>=
   recursive subroutine process_stack_write (object, unit, pacify)
     class(process_stack_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: pacify
     type(process_entry_t), pointer :: process
     integer :: u
     u = given_output_unit (unit)
     call write_separator (u, 2)
     select case (object%n)
     case (0)
        write (u, "(1x,A)")  "Process stack: [empty]"
        call write_separator (u, 2)
     case default
        write (u, "(1x,A)")  "Process stack:"
        process => object%first
        do while (associated (process))
           call process%write (.false., u, pacify = pacify)
           process => process%next
        end do
     end select
     if (associated (object%next)) then
        write (u, "(1x,A)")  "[Processes from context environment:]"
        call object%next%write (u, pacify)
     end if
   end subroutine process_stack_write
 
 @ %def process_stack_write
 @ The variable list is printed by a separate routine, since
 it should be linked to the global variable list, anyway.
 <<Process stacks: process stack: TBP>>=
   procedure :: write_var_list => process_stack_write_var_list
 <<Process stacks: procedures>>=
   subroutine process_stack_write_var_list (object, unit)
     class(process_stack_t), intent(in) :: object
     integer, intent(in), optional :: unit
     if (associated (object%var_list)) then
        call var_list_write (object%var_list, unit)
     end if
   end subroutine process_stack_write_var_list
 
 @ %def process_stack_write_var_list
 @ Short output.
 
 Since this is a stack, the default output ordering for each stack will be
 last-in, first-out.  To enable first-in, first-out, which is more likely to be
 requested, there is an optional [[fifo]] argument.
 <<Process stacks: process stack: TBP>>=
   procedure :: show => process_stack_show
 <<Process stacks: procedures>>=
   recursive subroutine process_stack_show (object, unit, fifo)
     class(process_stack_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: fifo
     type(process_entry_t), pointer :: process
     logical :: reverse
     integer :: u, i, j
     u = given_output_unit (unit)
     reverse = .false.;  if (present (fifo))  reverse = fifo
     select case (object%n)
     case (0)
     case default
        if (.not. reverse) then
           process => object%first
           do while (associated (process))
              call process%show (u, verbose=.false.)
              process => process%next
           end do
        else
           do i = 1, object%n
              process => object%first
              do j = 1, object%n - i
                 process => process%next
              end do
              call process%show (u, verbose=.false.)
           end do
        end if
     end select
     if (associated (object%next))  call object%next%show ()
   end subroutine process_stack_show
 
 @ %def process_stack_show
 @
 \subsection{Link}
 Link the current process stack to a global one.
 <<Process stacks: process stack: TBP>>=
   procedure :: link => process_stack_link
 <<Process stacks: procedures>>=
   subroutine process_stack_link (local_stack, global_stack)
     class(process_stack_t), intent(inout) :: local_stack
     type(process_stack_t), intent(in), target :: global_stack
     local_stack%next => global_stack
   end subroutine process_stack_link
 
 @ %def process_stack_link
 @ Initialize the process variable list and link the main variable list
 to it.
 <<Process stacks: process stack: TBP>>=
   procedure :: init_var_list => process_stack_init_var_list
 <<Process stacks: procedures>>=
   subroutine process_stack_init_var_list (stack, var_list)
     class(process_stack_t), intent(inout) :: stack
     type(var_list_t), intent(inout), optional :: var_list
     allocate (stack%var_list)
     if (present (var_list))  call var_list%link (stack%var_list)
   end subroutine process_stack_init_var_list
 
 @ %def process_stack_init_var_list
 @ Link the process variable list to a global
 variable list.
 <<Process stacks: process stack: TBP>>=
   procedure :: link_var_list => process_stack_link_var_list
 <<Process stacks: procedures>>=
   subroutine process_stack_link_var_list (stack, var_list)
     class(process_stack_t), intent(inout) :: stack
     type(var_list_t), intent(in), target :: var_list
     call stack%var_list%link (var_list)
   end subroutine process_stack_link_var_list
 
 @ %def process_stack_link_var_list
 @
 \subsection{Push}
 We take a process pointer and push it onto the stack.  The previous
 pointer is nullified.  Subsequently, the process is `owned' by the
 stack and will be finalized when the stack is deleted.
 <<Process stacks: process stack: TBP>>=
   procedure :: push => process_stack_push
 <<Process stacks: procedures>>=
   subroutine process_stack_push (stack, process)
     class(process_stack_t), intent(inout) :: stack
     type(process_entry_t), intent(inout), pointer :: process
     process%next => stack%first
     stack%first => process
     process => null ()
     stack%n = stack%n + 1
   end subroutine process_stack_push
 
 @ %def process_stack_push
 @ Inverse: Remove the last process pointer in the list and return it.
 <<Process stacks: process stack: TBP>>=
   procedure :: pop_last => process_stack_pop_last
 <<Process stacks: procedures>>=
   subroutine process_stack_pop_last (stack, process)
     class(process_stack_t), intent(inout) :: stack
     type(process_entry_t), intent(inout), pointer :: process
     type(process_entry_t), pointer :: previous
     integer :: i
     select case (stack%n)
     case (:0)
        process => null ()
     case (1)
        process => stack%first
        stack%first => null ()
        stack%n = 0
     case (2:)
        process => stack%first
        do i = 2, stack%n
           previous => process
           process => process%next
        end do
        previous%next => null ()
        stack%n = stack%n - 1
     end select
   end subroutine process_stack_pop_last
 
 @ %def process_stack_pop_last
 @ Initialize process variables for a given process ID, without setting
 values.
 <<Process stacks: process stack: TBP>>=
   procedure :: init_result_vars => process_stack_init_result_vars
 <<Process stacks: procedures>>=
   subroutine process_stack_init_result_vars (stack, id)
     class(process_stack_t), intent(inout) :: stack
     type(string_t), intent(in) :: id
     call var_list_init_num_id (stack%var_list, id)
     call var_list_init_process_results (stack%var_list, id)
   end subroutine process_stack_init_result_vars
 
 @ %def process_stack_init_result_vars
 @ Fill process variables with values.  This is executed after the
 integration pass.
 
 Note: We set only integral and error.  With multiple MCI records
 possible, the results for [[n_calls]], [[chi2]] etc. are not
 necessarily unique.  (We might set the efficiency, though.)
 <<Process stacks: process stack: TBP>>=
   procedure :: fill_result_vars => process_stack_fill_result_vars
 <<Process stacks: procedures>>=
   subroutine process_stack_fill_result_vars (stack, id)
     class(process_stack_t), intent(inout) :: stack
     type(string_t), intent(in) :: id
     type(process_t), pointer :: process
     process => stack%get_process_ptr (id)
     if (associated (process)) then
        call var_list_init_num_id (stack%var_list, id, process%get_num_id ())
        if (process%has_integral ()) then
           call var_list_init_process_results (stack%var_list, id, &
                integral = process%get_integral (), &
                error = process%get_error ())
        end if
     else
        call msg_bug ("process_stack_fill_result_vars: unknown process ID")
     end if
   end subroutine process_stack_fill_result_vars
 
 @ %def process_stack_fill_result_vars
 @ If one of the result variables has a local image in [[var_list_local]],
 update the value there as well.
 <<Process stacks: process stack: TBP>>=
   procedure :: update_result_vars => process_stack_update_result_vars
 <<Process stacks: procedures>>=
   subroutine process_stack_update_result_vars (stack, id, var_list_local)
     class(process_stack_t), intent(inout) :: stack
     type(string_t), intent(in) :: id
     type(var_list_t), intent(inout) :: var_list_local
     call update ("integral(" // id // ")")
     call update ("error(" // id // ")")
   contains
     subroutine update (var_name)
       type(string_t), intent(in) :: var_name
       real(default) :: value
       if (var_list_local%contains (var_name, follow_link = .false.)) then
          value = stack%var_list%get_rval (var_name)
          call var_list_local%set_real (var_name, value, is_known = .true.)
       end if
     end subroutine update
   end subroutine process_stack_update_result_vars
 
 @ %def process_stack_update_result_vars
 @
 \subsection{Data Access}
 Tell if a process exists.
 <<Process stacks: process stack: TBP>>=
   procedure :: exists => process_stack_exists
 <<Process stacks: procedures>>=
   function process_stack_exists (stack, id) result (flag)
     class(process_stack_t), intent(in) :: stack
     type(string_t), intent(in) :: id
     logical :: flag
     type(process_t), pointer :: process
     process => stack%get_process_ptr (id)
     flag = associated (process)
   end function process_stack_exists
 
 @ %def process_stack_exists
 @ Return a pointer to a process with specific ID.  Look also at a
 linked stack, if necessary.
 <<Process stacks: process stack: TBP>>=
   procedure :: get_process_ptr => process_stack_get_process_ptr
 <<Process stacks: procedures>>=
   recursive function process_stack_get_process_ptr (stack, id) result (ptr)
     class(process_stack_t), intent(in) :: stack
     type(string_t), intent(in) :: id
     type(process_t), pointer :: ptr
     type(process_entry_t), pointer :: entry
     ptr => null ()
     entry => stack%first
     do while (associated (entry))
        if (entry%get_id () == id) then
           ptr => entry%process_t
           return
        end if
        entry => entry%next
     end do
     if (associated (stack%next))  ptr => stack%next%get_process_ptr (id)
   end function process_stack_get_process_ptr
 
 @ %def process_stack_get_process_ptr
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[process_stacks_ut.f90]]>>=
 <<File header>>
 
 module process_stacks_ut
   use unit_tests
   use process_stacks_uti
 
 <<Standard module head>>
 
 <<Process stacks: public test>>
 
 contains
 
 <<Process stacks: test driver>>
 
 end module process_stacks_ut
 @ %def process_stacks_ut
 @
 <<[[process_stacks_uti.f90]]>>=
 <<File header>>
 
 module process_stacks_uti
 
 <<Use strings>>
   use os_interface
   use sm_qcd
   use models
   use model_data
   use variables, only: var_list_t
   use process_libraries
   use rng_base
   use prc_test, only: prc_test_create_library
   use process, only: process_t
   use instances, only: process_instance_t
   use processes_ut, only: prepare_test_process
 
   use process_stacks
 
   use rng_base_ut, only: rng_test_factory_t
 
 <<Standard module head>>
 
 <<Process stacks: test declarations>>
 
 contains
 
 <<Process stacks: tests>>
 
 end module process_stacks_uti
 
 @ %def process_stacks_uti
 @ API: driver for the unit tests below.
 <<Process stacks: public test>>=
   public :: process_stacks_test
 <<Process stacks: test driver>>=
   subroutine process_stacks_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Process stacks: execute tests>>
   end subroutine process_stacks_test
 
 @ %def process_stacks_test
 @
 \subsubsection{Write an empty process stack}
 The most trivial test is to write an uninitialized process stack.
 <<Process stacks: execute tests>>=
   call test (process_stacks_1, "process_stacks_1", &
        "write an empty process stack", &
        u, results)
 <<Process stacks: test declarations>>=
   public :: process_stacks_1
 <<Process stacks: tests>>=
   subroutine process_stacks_1 (u)
     integer, intent(in) :: u
     type(process_stack_t) :: stack
 
     write (u, "(A)")  "* Test output: process_stacks_1"
     write (u, "(A)")  "*   Purpose: display an empty process stack"
     write (u, "(A)")
 
     call stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_stacks_1"
 
   end subroutine process_stacks_1
 
 @ %def process_stacks_1
 @
 \subsubsection{Fill a process stack}
 Fill a process stack with two (identical) processes.
 <<Process stacks: execute tests>>=
   call test (process_stacks_2, "process_stacks_2", &
        "fill a process stack", &
        u, results)
 <<Process stacks: test declarations>>=
   public :: process_stacks_2
 <<Process stacks: tests>>=
   subroutine process_stacks_2 (u)
     integer, intent(in) :: u
     type(process_stack_t) :: stack
     type(process_library_t), target :: lib
     type(string_t) :: libname
     type(string_t) :: procname
     type(os_data_t) :: os_data
     type(model_t), target :: model
     type(var_list_t) :: var_list
     type(process_entry_t), pointer :: process => null ()
 
     write (u, "(A)")  "* Test output: process_stacks_2"
     write (u, "(A)")  "*   Purpose: fill a process stack"
     write (u, "(A)")
 
     write (u, "(A)")  "* Build, initialize and store two test processes"
     write (u, "(A)")
 
     libname = "process_stacks2"
     procname = libname
 
     call os_data%init ()
     call prc_test_create_library (libname, lib)
 
     call model%init_test ()
     call var_list%append_string (var_str ("$run_id"))
     call var_list%append_log (var_str ("?alphas_is_fixed"), .true.)
     call var_list%append_int (var_str ("seed"), 0)
 
     allocate (process)
 
     call var_list%set_string &
          (var_str ("$run_id"), var_str ("run1"), is_known=.true.)
     call process%init (procname, lib, os_data, model, var_list)
     call stack%push (process)
 
     allocate (process)
 
     call var_list%set_string &
          (var_str ("$run_id"), var_str ("run2"), is_known=.true.)
     call process%init (procname, lib, os_data, model, var_list)
     call stack%push (process)
 
     call stack%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call stack%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_stacks_2"
 
   end subroutine process_stacks_2
 
 @ %def process_stacks_2
 @
 \subsubsection{Fill a process stack}
 Fill a process stack with two (identical) processes.
 <<Process stacks: execute tests>>=
   call test (process_stacks_3, "process_stacks_3", &
        "process variables", &
        u, results)
 <<Process stacks: test declarations>>=
   public :: process_stacks_3
 <<Process stacks: tests>>=
   subroutine process_stacks_3 (u)
     integer, intent(in) :: u
     type(process_stack_t) :: stack
     type(model_t), target :: model
     type(string_t) :: procname
     type(process_entry_t), pointer :: process => null ()
     type(process_instance_t), target :: process_instance
 
     write (u, "(A)")  "* Test output: process_stacks_3"
     write (u, "(A)")  "*   Purpose: setup process variables"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process variables"
     write (u, "(A)")
 
     procname = "processes_test"
     call model%init_test ()
 
     write (u, "(A)")  "* Initialize process variables"
     write (u, "(A)")
 
     call stack%init_var_list ()
     call stack%init_result_vars (procname)
     call stack%write_var_list (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Build and integrate a test process"
     write (u, "(A)")
 
     allocate (process)
     call prepare_test_process (process%process_t, process_instance, model)
     call process_instance%integrate (1, 1, 1000)
     call process_instance%final ()
     call process%final_integration (1)
     call stack%push (process)
 
     write (u, "(A)")  "* Fill process variables"
     write (u, "(A)")
 
     call stack%fill_result_vars (procname)
     call stack%write_var_list (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call stack%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_stacks_3"
 
   end subroutine process_stacks_3
 
 @ %def process_stacks_3
 @
 \subsubsection{Linked a process stack}
 Fill two process stack, linked to each other.
 <<Process stacks: execute tests>>=
   call test (process_stacks_4, "process_stacks_4", &
        "linked stacks", &
        u, results)
 <<Process stacks: test declarations>>=
   public :: process_stacks_4
 <<Process stacks: tests>>=
   subroutine process_stacks_4 (u)
     integer, intent(in) :: u
     type(process_library_t), target :: lib
     type(process_stack_t), target :: stack1, stack2
     type(model_t), target :: model
     type(string_t) :: libname
     type(string_t) :: procname1, procname2
     type(os_data_t) :: os_data
     type(process_entry_t), pointer :: process => null ()
 
     write (u, "(A)")  "* Test output: process_stacks_4"
     write (u, "(A)")  "*   Purpose: link process stacks"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize process variables"
     write (u, "(A)")
 
     libname = "process_stacks_4_lib"
     procname1 = "process_stacks_4a"
     procname2 = "process_stacks_4b"
 
     call os_data%init ()
 
     write (u, "(A)")  "* Initialize first process"
     write (u, "(A)")
 
     call prc_test_create_library (procname1, lib)
 
     call model%init_test ()
 
     allocate (process)
     call process%init (procname1, lib, os_data, model)
     call stack1%push (process)
 
     write (u, "(A)")  "* Initialize second process"
     write (u, "(A)")
 
     call stack2%link (stack1)
 
     call prc_test_create_library (procname2, lib)
 
     allocate (process)
 
     call process%init (procname2, lib, os_data, model)
     call stack2%push (process)
 
     write (u, "(A)")  "* Show linked stacks"
     write (u, "(A)")
 
     call stack2%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call stack2%final ()
     call stack1%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: process_stacks_4"
 
   end subroutine process_stacks_4
 
 @ %def process_stacks_4
 @
Index: trunk/src/fks/fks.nw
===================================================================
--- trunk/src/fks/fks.nw	(revision 8732)
+++ trunk/src/fks/fks.nw	(revision 8733)
@@ -1,9928 +1,9943 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: matrix elements and process libraries
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{FKS Subtraction Scheme}
 \includemodulegraph{fks}
 
 The code in this chapter implements the FKS subtraction scheme for use
 with \whizard.
 
 These are the modules:
 \begin{description}
 \item[fks\_regions]
   Given a process definition, identify singular regions in the
   associated phase space.
 \item[virtual]
   Handle the virtual correction matrix element.
 \item[real\_subtraction]
   Handle the real-subtraction matrix element.
 \item[nlo\_data]
   Manage the subtraction objects.
 \end{description}
 
 This chapter deals with next-to-leading order contributions to cross sections.
 Basically, there are three major issues to be adressed: The creation
 of the $N+1$-particle flavor structure, the construction of the
 $N+1$-particle phase space and the actual calculation of the real- and
 virtual-subtracted matrix elements. The first is dealt with using the
 [[auto_components]] class, and it will be shown that the second
 and third issue are connected in FKS subtraction.
 
 \section{Brief outline of FKS subtraction}
 {\em In the current state, this discussion is only concerned with
   lepton collisions. For hadron collisions, renormalization of parton
   distributions has to be taken into account. Further, for QCD
   corrections, initial-state radiation is necessarily
   present.}
 
 The aim is to calculate the next-to-leading order cross section
 according to
 \begin{equation*}
   d\sigma_{\rm{NLO}} = \mathcal{B} + \mathcal{V} +
   \mathcal{R}d\Phi_{\rm{rad}}.
 \end{equation*}
 Analytically, the divergences, in terms of poles in the complex
 quantity $\varepsilon = 2-d/2$, cancel. However, this is in general
 only valid in an arbitrary, complex number of dimensions. This is,
 roughly, the content of the KLN-theorem. \whizard, as any
 other numerical program, is confined to four dimensions. We will
 assume that the KLN-theorem is valid and that there exist subtraction
 terms $\mathcal{C}$ such that
 \begin{equation*}
   d\sigma_{\rm{NLO}} = \mathcal{B} + \underbrace{\mathcal{V} +
     \mathcal{C}}_{\text{finite}} + \underbrace{\mathcal{R} -
     \mathcal{C}}_{\text{finite}},
 \end{equation*}
 i.e. the subtraction terms correspond to the divergent limits of the
 real and virtual matrix element.
 
 Because $\mathcal{C}$ subtracts the divergences of $\mathcal{R}$ as
 well as those of $\mathcal{V}$, it suffices to consider one of them,
 so we focus on $\mathcal{R}$. For this purpose, $\mathcal{R}$ is
 rewritten as
 \begin{equation*}
   \mathcal{R} = \frac{1}{\xi^2}\frac{1}{1-y} \left(\xi^2
     (1-y)\mathcal{R}\right) =
   \frac{1}{\xi^2}\frac{1}{1-y}\tilde{\mathcal{R}},
 \end{equation*}
 with $\xi = \left(2k_{\rm{rad}}^0\right)/\sqrt{s}$ and $y =
 \cos\theta$, where $k_{\rm{rad}}^0$ denotes the energy of the radiated
 parton and $\theta$ is the angle between emitter and radiated
 parton. $\tilde{\mathcal{R}}$ is finite, therefore the whole
 singularity structure is contained in the prefactor
 $\xi^{-2}(1-y)^{-1}$. Combined with the $d$-dimensional phase space
 element,
 \begin{equation*}
   \frac{d^{d-1}k}{2k^0(2\pi)^{d-1}} =
   \frac{s^{1-\varepsilon}}{(4\pi)^{d-1}}\xi^{1-2\varepsilon}\left(1-y^2\right)^{-\varepsilon}
   d\xi dy d\Omega^{d-2},
 \end{equation*}
 this yields
 \begin{equation*}
   d\Phi_{\rm{rad}} \mathcal{R} = dy (1-y)^{-1-\varepsilon} d\xi
   \xi^{-1-2\varepsilon} \tilde{R}.
 \end{equation*}
 This can further be rewritten in terms of plus-distributions,
 \begin{align*}
 \xi^{-1-2\varepsilon} &= -\frac{1}{2\varepsilon}\delta(\xi) +
 \left(\frac{1}{\xi}\right)_+ -
 2\varepsilon\left(\frac{\log\xi}{\xi}\right)_+ +
 \mathcal{O}(\varepsilon^2),\\
 (1-y)^{-1-\varepsilon} &= -\frac{2^{-\varepsilon}}{\varepsilon}
 \delta(1-y) + \left(\frac{1}{1-y}\right)_+ - \varepsilon
 \left(\frac{1}{1-y}\right)_+\log(1-y) + \mathcal{O}(\varepsilon^2),
 \end{align*}
 (imagine that all this is written inside of integrals, which are
 spared for ease of notation) such that
 \begin{align*}
 d\Phi_{\rm{rad}} \mathcal{R} &= -\frac{1}{2\varepsilon} dy
 (1-y)^{-1-\varepsilon}\tilde{R} (0,y) -
 d\xi\left[\frac{2^{-\varepsilon}}{\varepsilon}\left(\frac{1}{\xi}\right)_+
   - 2\left(\frac{\log\xi}{\xi}\right)_+\right] \tilde{R}(\xi,1) \\
                               &+ dy d\xi \left(\frac{1}{\xi}\right)_+
                               \left(\frac{1}{1-y}\right)_+
                               \tilde{R}(\xi, y) +
                               \mathcal{O}(\varepsilon).\\
 \end{align*}
 The summand in the second line is of order $\mathcal{O}(1)$ and is the
 only one to reproduce $\mathcal{R}(\xi,y)$. It thus constitutes the
 sum of the real matrix element and the corresponding counterterms.
 The first summand consequently consists of the subtraction terms to
 the virtual matrix elements. Above formula thus allows to calculate
 all quantities to render the matrix elements finite.
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Identifying singular regions}
 In the FKS subtraction scheme, the phase space is decomposed into
 disjoint singular regions, such that
 \begin{equation}
 \label{eq:S_complete}
   \sum_i \mathcal{S}_i + \sum_{ij}\mathcal{S}_{ij} = 1.
 \end{equation}
 The quantities $\mathcal{S}_i$ and $\mathcal{S}_{ij}$ are functions of
 phase space corresponding to a pair of particles indices which can
 make up a divergent phase space region. We call such an index pair a
 fundamental tuple. For example, the process $e^+ \, e^- \rightarrow u
 \, \bar{u} \, g$ has two singular regions, $(3,5)$ and $(4,5)$,
 indicating that the gluon can be soft or collinear with respect to
 either the quark or the anti-quark. Therefore, the functions $S_{ij}$
 have to be chosen in such a way that their contribution makes up most
 of \eqref{eq:S_complete} in phase-space configurations where
 (final-state) particle $j$ is collinear to particle $i$ or/and
 particle $j$ is soft. The functions $S_i$ is the corresponding
 quantity for initial-state divergences.
 
 As a singular region we understand the collection of real flavor
 structures associated with an emitter and a list of all possible
 fundamental tuples. As an example, consider the process $e^+ \, e^-
 \rightarrow u \, \bar{u} \, g$. At next-to-leading order, processes
 with an additionally radiated particle have to be considered. In this
 case, these are $e^+ \, e^- \rightarrow u \, \bar{u}, \, g \, g$,
 and $e^+ \, e^- \rightarrow u \, \bar{u} \, u \, \bar{u}$ (or the same
 process with any other quark). Table \ref{table:singular regions} sums
 up all possible singular regions for this problem.
 \begin{table}
 \begin{tabular}{|c|c|c|c|}
   \hline
   \texttt{alr} & \texttt{flst\_alr} & \texttt{emitter} &
   \texttt{ftuple\_list}\\ \hline
   1 & [-11,11,2,-2,21,21] & 3 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
   2 & [-11,11,2,-2,21,21] & 4 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
   3 & [-11,11,2,-2,21,21] & 5 & {(3,5), (3,6), (4,5), (4,6), (5,6)} \\ \hline
   4 & [-11,11,2,-2,2,-2]  & 5 & {(3,4), (3,6), (4,5), (5,6)} \\
   \hline
 \end{tabular}
 \caption{List of singular regions. The particles are represented by
   their PDG codes. The third column contains the emitter for the
   specific singular region. For the process involving an additional
   gluon, the gluon can either be emitted from one of the quarks or
   from the first gluon. Each emitter yields the same list of
   fundamental tuples, five in total. The last singular region
   corresponds to the process where the gluon splits up into two
   quarks. As the matrix element for this process has no information
   on which quarks originate from a gluon splitting, there are ftuples
   for all the quark pairs and not just those involving the emitter.}
 \label{table:singular regions}
 \end{table}
 \\
 \begin{table}
 \begin{tabular}{|c|c|c|c|}
   \hline
   \texttt{alr} & \texttt{ftuple} & \texttt{emitter} &
   \texttt{flst\_alr} \\ \hline
   1 & $(3,5)$ & 5 & [-11,11,-2,21,2,21] \\ \hline
   2 & $(4,5)$ & 5 & [-11,11,2,21,-2,21] \\ \hline
   3 & $(3,6)$ & 5 & [-11,11,-2,21,2,21] \\ \hline
   4 & $(4,6)$ & 5 & [-11,11,2,21,-2,21] \\ \hline
   5 & $(5,6)$ & 5 & [-11,11,2,-2,21,21] \\ \hline
   6 & $(5,6)$ & 5 & [-11,11,2,-2,2,-2] \\ \hline
 \end{tabular}
 \caption{Initial list of singular regions}
 \label{table:ftuples and flavors}
 \end{table}
 Thus, during the preparation of a NLO-calculation, the possible
 singular regions have to be identified. [[fks_regions.f90]] deals
 with this issue.
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{FKS Regions}
 <<[[fks_regions.f90]]>>=
 <<File header>>
 
 module fks_regions
 
 <<Use kinds>>
   use format_utils, only: write_separator
   use numeric_utils
   use string_utils, only: str
   use io_units
   use os_interface
 <<Use strings>>
 <<Use debug>>
   use constants
   use permutations
   use diagnostics
   use flavors
   use process_constants
   use lorentz
   use pdg_arrays
   use models
   use physics_defs
   use resonances, only: resonance_contributors_t, resonance_history_t
   use phs_fks, only: phs_identifier_t, check_for_phs_identifier
 
   use nlo_data
 
 <<Standard module head>>
 
 <<fks regions: public>>
 
 <<fks regions: parameters>>
 
 <<fks regions: types>>
 
 <<fks regions: interfaces>>
 
 contains
 
 <<fks regions: procedures>>
 
 end module fks_regions
 @ %def fks_regions
 @ There are three fundamental splitting types: $q \rightarrow qg$, $g \rightarrow gg$ and
 $g \rightarrow qq$ for FSR and additionally $q \rightarrow gq$ for ISR which is different
 from $q \rightarrow qg$ by which particle enters the hard process.
 <<fks regions: parameters>>=
   integer, parameter :: UNDEFINED_SPLITTING = 0
   integer, parameter :: F_TO_FV = 1
   integer, parameter :: V_TO_VV = 2
   integer, parameter :: V_TO_FF = 3
   integer, parameter :: F_TO_VF = 4
 
 @
 @ We group the indices of the emitting and the radiated particle in
 the [[ftuple]]-object.
 <<fks regions: public>>=
   public :: ftuple_t
 <<fks regions: types>>=
   type :: ftuple_t
     integer, dimension(2) :: ireg = [-1,-1]
     integer :: i_res = 0
     integer :: splitting_type
     logical :: pseudo_isr = .false.
   contains
   <<fks regions: ftuple: TBP>>
   end type ftuple_t
 
 @ %def ftuple_t
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure ftuple_assign
   end interface
 
   interface operator(==)
      module procedure ftuple_equal
   end interface
 
   interface operator(>)
      module procedure ftuple_greater
   end interface
 
   interface operator(<)
      module procedure ftuple_less
   end interface
 
 <<fks regions: procedures>>=
   pure subroutine ftuple_assign (ftuple_out, ftuple_in)
     type(ftuple_t), intent(out) :: ftuple_out
     type(ftuple_t), intent(in) :: ftuple_in
     ftuple_out%ireg = ftuple_in%ireg
     ftuple_out%i_res = ftuple_in%i_res
     ftuple_out%splitting_type = ftuple_in%splitting_type
     ftuple_out%pseudo_isr = ftuple_in%pseudo_isr
   end subroutine ftuple_assign
 
 @ %def ftuple_assign
 @
 <<fks regions: procedures>>=
   elemental function ftuple_equal (f1, f2) result (value)
     logical :: value
     type(ftuple_t), intent(in) :: f1, f2
     value = all (f1%ireg == f2%ireg) .and. f1%i_res == f2%i_res &
          .and. f1%splitting_type == f2%splitting_type &
          .and. (f1%pseudo_isr .eqv. f2%pseudo_isr)
   end function ftuple_equal
 
 @ %def ftuple_equal
 @
 <<fks regions: procedures>>=
   elemental function ftuple_equal_ireg (f1, f2) result (value)
     logical :: value
     type(ftuple_t), intent(in) :: f1, f2
     value = all (f1%ireg == f2%ireg)
   end function ftuple_equal_ireg
 
 @ %def ftuple_equal_ireg
 @
 <<fks regions: procedures>>=
   elemental function ftuple_greater (f1, f2) result (greater)
     logical :: greater
     type(ftuple_t), intent(in) :: f1, f2
     if (f1%ireg(1) == f2%ireg(1)) then
        greater = f1%ireg(2) > f2%ireg(2)
     else
        greater = f1%ireg(1) > f2%ireg(1)
     end if
   end function ftuple_greater
 
 @ %def ftuple_greater
 @
 <<fks regions: procedures>>=
   elemental function ftuple_less (f1, f2) result (less)
     logical :: less
     type(ftuple_t), intent(in) :: f1, f2
     if (f1%ireg(1) == f2%ireg(1)) then
        less = f1%ireg(2) < f2%ireg(2)
     else
        less = f1%ireg(1) < f2%ireg(1)
     end if
   end function ftuple_less
 
 @ %def ftuple_less
 <<fks regions: procedures>>=
   subroutine ftuple_sort_array (ftuple_array, equivalences)
     type(ftuple_t), intent(inout), dimension(:), allocatable :: ftuple_array
     logical, intent(inout), dimension(:,:), allocatable :: equivalences
     type(ftuple_t) :: ftuple_tmp
     logical, dimension(:), allocatable :: eq_tmp
     integer :: i1, i2, n
     n = size (ftuple_array)
     allocate (eq_tmp (n))
     do i1 = 2, n
        i2 = i1
        do while (ftuple_array(i2 - 1) > ftuple_array(i2))
           ftuple_tmp = ftuple_array(i2 - 1)
           eq_tmp = equivalences(i2, :)
           ftuple_array(i2 - 1) = ftuple_array(i2)
           ftuple_array(i2) = ftuple_tmp
           equivalences(i2 - 1, :) = equivalences(i2, :)
           equivalences(i2, :) = eq_tmp
           i2 = i2 - 1
           if (i2 == 1) exit
        end do
     end do
   end subroutine ftuple_sort_array
 
 @ %def ftuple_sort_array
 @
 <<fks regions: ftuple: TBP>>=
   procedure :: write => ftuple_write
 <<fks regions: procedures>>=
   subroutine ftuple_write (ftuple, unit, newline)
     class(ftuple_t), intent(in) :: ftuple
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: newline
     integer :: u
     logical :: nl
     u = given_output_unit (unit); if (u < 0) return
     nl = .true.; if (present(newline)) nl = newline
     if (all (ftuple%ireg > -1)) then
        if (ftuple%i_res > 0) then
           if (nl) then
              write (u, "(A1,I1,A1,I1,A1,I1,A1)") &
                  '(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')'
           else
              write (u, "(A1,I1,A1,I1,A1,I1,A1)", advance = "no") &
                  '(', ftuple%ireg(1), ',', ftuple%ireg(2), ';', ftuple%i_res, ')'
           end if
        else
           if (nl) then
              write (u, "(A1,I1,A1,I1,A1)") &
                   '(', ftuple%ireg(1), ',', ftuple%ireg(2), ')'
           else
              write (u, "(A1,I1,A1,I1,A1)", advance = "no") &
                   '(', ftuple%ireg(1), ',', ftuple%ireg(2), ')'
           end if
        end if
     else
        write (u, "(A)") "(Empty)"
     end if
   end subroutine ftuple_write
 
 @ %def ftuple_write
 @
 <<fks regions: procedures>>=
   function ftuple_string (ftuples, latex)
     type(string_t) :: ftuple_string
     type(ftuple_t), intent(in), dimension(:) :: ftuples
     logical, intent(in) :: latex
     integer :: i, nreg
     if (latex) then
        ftuple_string = var_str ("$\left\{")
     else
        ftuple_string = var_str ("{")
     end if
     nreg = size(ftuples)
     do i = 1, nreg
        if (ftuples(i)%i_res == 0) then
           ftuple_string = ftuple_string // var_str ("(") // &
                str (ftuples(i)%ireg(1)) // var_str (",") // &
                str (ftuples(i)%ireg(2)) // var_str (")")
        else
           ftuple_string = ftuple_string // var_str ("(") // &
                str (ftuples(i)%ireg(1)) // var_str (",") // &
                str (ftuples(i)%ireg(2)) // var_str (";") // &
                str (ftuples(i)%i_res) // var_str (")")
        end if
        if (ftuples(i)%pseudo_isr) ftuple_string = ftuple_string // var_str ("*")
        if (i < nreg) ftuple_string = ftuple_string // var_str (",")
     end do
     if (latex) then
        ftuple_string = ftuple_string // var_str ("\right\}$")
     else
        ftuple_string = ftuple_string // var_str ("}")
     end if
   end function ftuple_string
 
 @ %def ftuple_string
 @
 <<fks regions: ftuple: TBP>>=
   procedure :: get => ftuple_get
 <<fks regions: procedures>>=
   subroutine ftuple_get (ftuple, pos1, pos2)
     class(ftuple_t), intent(in) :: ftuple
     integer, intent(out) :: pos1, pos2
     pos1 = ftuple%ireg(1)
     pos2 = ftuple%ireg(2)
   end subroutine ftuple_get
 
 @ %def ftuple_get
 @
 <<fks regions: ftuple: TBP>>=
   procedure :: set => ftuple_set
 <<fks regions: procedures>>=
   subroutine ftuple_set (ftuple, pos1, pos2)
     class(ftuple_t), intent(inout) :: ftuple
     integer, intent(in) ::  pos1, pos2
     ftuple%ireg(1) = pos1
     ftuple%ireg(2) = pos2
   end subroutine ftuple_set
 
 @ %def ftuple_set
 @ Determines the splitting type for FSR. There are three different types of splittings
 relevant here: $g \to gg$ tagged [[V_TO_VV]], $g \to qq$ tagged [[V_TO_FF]] and
 $q \to qg$ tagged [[F_TO_FV]]. For FSR, there is no need to differentiate between
 $q \to qg$ and $q \to gq$ splittings.
 <<fks regions: ftuple: TBP>>=
   procedure :: determine_splitting_type_fsr => ftuple_determine_splitting_type_fsr
 <<fks regions: procedures>>=
   subroutine ftuple_determine_splitting_type_fsr (ftuple, flv, i, j)
     class(ftuple_t), intent(inout) :: ftuple
     type(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i, j
     associate (flst => flv%flst)
        if (is_vector (flst(i)) .and. is_vector (flst(j))) then
           ftuple%splitting_type = V_TO_VV
        else if (flst(i)+flst(j) == 0 &
              .and. is_fermion (flst(i))) then
           ftuple%splitting_type = V_TO_FF
        else if (is_fermion(flst(i)) .and. is_massless_vector (flst(j)) &
              .or. is_fermion(flst(j)) .and. is_massless_vector (flst(i))) then
           ftuple%splitting_type = F_TO_FV
        else
           ftuple%splitting_type = UNDEFINED_SPLITTING
        end if
     end associate
   end subroutine ftuple_determine_splitting_type_fsr
 
 @ %def ftuple_determine_splitting_type_fsr
 @ Determines the splitting type for ISR. There are four different types of splittings
 relevant here: $g \to gg$ tagged [[V_TO_VV]], $g \to qq$ tagged [[V_TO_FF]], $q \to qg$
 tagged [[F_TO_FV]] and $q \to gq$ tagged [[F_TO_VF]]. The latter two need to be considered
 separately for ISR as they differ with respect to which particle enters the hard process.
 A splitting [[F_TO_FV]] may lead to soft divergences while [[F_TO_VF]] does not.\\
 We also want to emphasize that the splitting type naming convention for ISR names the
 splittings considering backwards evolution. So in the splitting [[V_TO_FF]], it is the
 \textit{gluon} that enteres the hard process!\\
 Special treatment here is required if emitter $0$ is assigned. This is the case only when a
 gluon was radiated from any of the IS particles. In this case, both splittings are soft divergent
 so we can equivalently choose $1$ or $2$ as the emitter here even if both have different flavors.
 <<fks regions: ftuple: TBP>>=
   procedure :: determine_splitting_type_isr => ftuple_determine_splitting_type_isr
 <<fks regions: procedures>>=
   subroutine ftuple_determine_splitting_type_isr (ftuple, flv, i, j)
     class(ftuple_t), intent(inout) :: ftuple
     type(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i, j
     integer :: em
     em = i; if (i == 0) em = 1
     associate (flst => flv%flst)
        if (is_vector (flst(em)) .and. is_vector (flst(j))) then
           ftuple%splitting_type = V_TO_VV
        else if (is_massless_vector(flst(em)) .and. is_fermion(flst(j))) then
           ftuple%splitting_type = F_TO_VF
        else if (is_fermion(flst(em)) .and. is_massless_vector(flst(j))) then
           ftuple%splitting_type = F_TO_FV
        else if (is_fermion(flst(em)) .and. is_fermion(flst(j))) then
           ftuple%splitting_type = V_TO_FF
        else
           ftuple%splitting_type = UNDEFINED_SPLITTING
        end if
     end associate
   end subroutine ftuple_determine_splitting_type_isr
 
 @ %def ftuple_determine_splitting_type_isr
 @ Two debug functions to check the consistency of [[ftuples]]
 <<fks regions: ftuple: TBP>>=
   procedure :: has_negative_elements => ftuple_has_negative_elements
   procedure :: has_identical_elements => ftuple_has_identical_elements
 <<fks regions: procedures>>=
   elemental function ftuple_has_negative_elements (ftuple) result (value)
     logical :: value
     class(ftuple_t), intent(in) :: ftuple
     value = any (ftuple%ireg < 0)
   end function ftuple_has_negative_elements
 
   elemental function ftuple_has_identical_elements (ftuple) result (value)
     logical :: value
     class(ftuple_t), intent(in) :: ftuple
     value = ftuple%ireg(1) == ftuple%ireg(2)
   end function ftuple_has_identical_elements
 
 @ %def ftuple_has_negative_elements, ftuple_has_identical_elements
 @ Each singular region can have a different number of
 emitter-radiation pairs. This is coped with using the linked list
 [[ftuple_list]].
 <<fks regions: types>>=
   type :: ftuple_list_t
     integer :: index = 0
     type(ftuple_t) :: ftuple
     type(ftuple_list_t), pointer :: next => null ()
     type(ftuple_list_t), pointer :: prev => null ()
     type(ftuple_list_t), pointer :: equiv => null ()
   contains
    <<fks regions: ftuple list: TBP>>
   end type ftuple_list_t
 
 @ %def ftuple_list_t
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: write => ftuple_list_write
 <<fks regions: procedures>>=
   subroutine ftuple_list_write (list, unit, verbose)
     class(ftuple_list_t), intent(in), target :: list
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     type(ftuple_list_t), pointer :: current
     logical :: verb
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     verb = .false.; if (present (verbose)) verb = verbose
     select type (list)
     type is (ftuple_list_t)
        current => list
        do
           call current%ftuple%write (unit = u, newline = .false.)
           if (verb .and. associated (current%equiv)) write (u, '(A)', advance = "no") "'"
           if (associated (current%next)) then
              current => current%next
           else
              exit
           end if
        end do
        write (u, *) ""
     end select
   end subroutine ftuple_list_write
 
 @ %def ftuple_list_write
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: append => ftuple_list_append
 <<fks regions: procedures>>=
   subroutine ftuple_list_append (list, ftuple)
    class(ftuple_list_t), intent(inout), target :: list
    type(ftuple_t), intent(in) :: ftuple
    type(ftuple_list_t), pointer :: current
 
    select type (list)
    type is (ftuple_list_t)
    if (list%index == 0) then
       nullify (list%next)
       list%index = 1
       list%ftuple = ftuple
    else
       current => list
       do
        if (associated (current%next)) then
           current => current%next
        else
           allocate (current%next)
           nullify (current%next%next)
           nullify (current%next%equiv)
           current%next%prev => current
           current%next%index = current%index + 1
           current%next%ftuple = ftuple
           exit
        end if
      end do
    end if
    end select
   end subroutine ftuple_list_append
 
 @ %def ftuple_list_append
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: get_n_tuples => ftuple_list_get_n_tuples
 <<fks regions: procedures>>=
   impure elemental function ftuple_list_get_n_tuples (list) result(n_tuples)
     integer :: n_tuples
     class(ftuple_list_t), intent(in), target :: list
     type(ftuple_list_t), pointer :: current
     n_tuples = 0
     select type (list)
     type is (ftuple_list_t)
        current => list
        if (current%index > 0) then
           n_tuples = 1
           do
              if (associated (current%next)) then
                 current => current%next
                 n_tuples = n_tuples + 1
              else
                 exit
              end if
           end do
        end if
      end select
   end function ftuple_list_get_n_tuples
 
 @ %def ftuple_list_get_n_tuples
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: get_entry => ftuple_list_get_entry
 <<fks regions: procedures>>=
   function ftuple_list_get_entry (list, index) result (entry)
     type(ftuple_list_t), pointer :: entry
     class(ftuple_list_t), intent(in), target :: list
     integer, intent(in) :: index
     type(ftuple_list_t), pointer :: current
     integer :: i
     entry => null()
     select type (list)
     type is (ftuple_list_t)
        current => list
        if (index == 1) then
           entry => current
        else
           do i = 1, index - 1
              current => current%next
           end do
           entry => current
        end if
     end select
   end function ftuple_list_get_entry
 
 @ %def ftuple_list_get_entry
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: get_ftuple => ftuple_list_get_ftuple
 <<fks regions: procedures>>=
   function ftuple_list_get_ftuple (list, index)  result (ftuple)
     type(ftuple_t) :: ftuple
     class(ftuple_list_t), intent(in), target :: list
     integer, intent(in) :: index
     type(ftuple_list_t), pointer :: entry
     entry => list%get_entry (index)
     ftuple = entry%ftuple
   end function ftuple_list_get_ftuple
 
 @ %def ftuple_list_get_ftuple
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: set_equiv => ftuple_list_set_equiv
 <<fks regions: procedures>>=
   subroutine ftuple_list_set_equiv (list, i1, i2)
     class(ftuple_list_t), intent(in) :: list
     integer, intent(in) :: i1, i2
     type(ftuple_list_t), pointer :: list1, list2 => null ()
     select type (list)
     type is (ftuple_list_t)
        if (list%get_ftuple (i1) > list%get_ftuple (i2)) then
           list1 => list%get_entry (i2)
           list2 => list%get_entry (i1)
        else
           list1 => list%get_entry (i1)
           list2 => list%get_entry (i2)
        end if
        do
           if (associated (list1%equiv)) then
              list1 => list1%equiv
           else
              exit
           end if
        end do
        list1%equiv => list2
     end select
   end subroutine ftuple_list_set_equiv
 
 @ %def ftuple_list_set_equiv
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: check_equiv => ftuple_list_check_equiv
 <<fks regions: procedures>>=
   function ftuple_list_check_equiv(list, i1, i2) result(eq)
     class(ftuple_list_t), intent(in) :: list
     integer, intent(in) :: i1, i2
     logical :: eq
     type(ftuple_list_t), pointer :: current
     eq = .false.
     select type (list)
     type is (ftuple_list_t)
        current => list%get_entry (i1)
        do
           if (associated (current%equiv)) then
              current => current%equiv
              if (current%index == i2) then
                 eq = .true.
                 exit
              end if
           else
              exit
           end if
        end do
     end select
   end function ftuple_list_check_equiv
 
 @ %def ftuple_list_sort
 @
 <<fks regions: ftuple list: TBP>>=
   procedure :: to_array => ftuple_list_to_array
 <<fks regions: procedures>>=
   subroutine ftuple_list_to_array (ftuple_list, ftuple_array, equivalences, ordered)
     class(ftuple_list_t), intent(in), target :: ftuple_list
     type(ftuple_t), intent(out), dimension(:), allocatable :: ftuple_array
     logical, intent(out), dimension(:,:), allocatable :: equivalences
     logical, intent(in) :: ordered
     integer :: i_tuple, n
     type(ftuple_list_t), pointer :: current => null ()
     integer :: i1, i2
     type(ftuple_t) :: ftuple_tmp
     logical, dimension(:), allocatable :: eq_tmp
     n = ftuple_list%get_n_tuples ()
     allocate (ftuple_array (n), equivalences (n, n))
     equivalences = .false.
     select type (ftuple_list)
     type is (ftuple_list_t)
        current => ftuple_list
        i_tuple = 1
        do
           ftuple_array(i_tuple) = current%ftuple
           if (associated (current%equiv)) then
              i1 = current%index
              i2 = current%equiv%index
              equivalences (i1, i2) = .true.
           end if
           if (associated (current%next)) then
              current => current%next
              i_tuple = i_tuple + 1
           else
              exit
           end if
        end do
     end select
     if (ordered) call ftuple_sort_array (ftuple_array, equivalences)
   end subroutine ftuple_list_to_array
 
 @ %def ftuple_list_to_array
 @
 <<fks regions: procedures>>=
   subroutine print_equivalence_matrix (ftuple_array, equivalences)
     type(ftuple_t), intent(in), dimension(:) :: ftuple_array
     logical, intent(in), dimension(:,:) :: equivalences
     integer :: i, i1, i2
     print *, 'Equivalence matrix: '
     do i = 1, size (ftuple_array)
        call ftuple_array(i)%get(i1,i2)
        print *, 'i: ', i, '(', i1, i2, '): ', equivalences(i,:)
     end do
   end subroutine print_equivalence_matrix
 
 @ %def print_equivalence_matrix
 @ Class for working with the flavor specification arrays.
 <<fks regions: public>>=
   public :: flv_structure_t
 <<fks regions: types>>=
   type :: flv_structure_t
     integer, dimension(:), allocatable :: flst
     integer, dimension(:), allocatable :: tag
     integer :: nlegs = 0
     integer :: n_in = 0
     logical, dimension(:), allocatable :: massive
     logical, dimension(:), allocatable :: colored
     real(default), dimension(:), allocatable :: charge
     real(default) :: prt_symm_fs = 1._default
     integer :: eqv_index = 0
   contains
   <<fks regions: flv structure: TBP>>
   end type flv_structure_t
 
 @ %def flv_structure_t
 @
 Returns \texttt{true} if the two particles at position \texttt{i}
 and \texttt{j} in the flavor array can originate from the same
 splitting. For this purpose, the function first checks whether the splitting is
 allowed at all. If this is the case, the emitter is removed from the
 flavor array. If the resulting array is equivalent to the Born flavor
 structure \texttt{flv\_born}, the pair is accepted as a valid
 splitting.
 
 We first check whether the splitting is possible. The array
 [[flv_orig]] contains all particles which share a vertex with the
 particles at position [[i]] and [[j]]. If any of these particles belongs
 to the initial state, a PDG-ID flip is necessary to correctly recognize
 the vertex. If its size is equal to zero, no splitting is possible and
 the subroutine is exited. Otherwise, we loop over all possible underlying
 Born flavor structures and check if any of them equals the actual underlying
 Born flavor structure. For a quark emitting a gluon, [[flv_orig]] contains
 the PDG code of the anti-quark. To be on the safe side, a second array is created,
 which contains both the positively and negatively signed PDG
 codes. Then, the origial tuple $(i,j)$ is removed from the real flavor
 structure and the particles in [[flv_orig2]] are inserted.
 If the resulting Born configuration is equal to the underlying Born
 configuration, up to a permutation of final-state particles, the tuple
 $(i,j)$ is accepted as valid.
 <<fks regions: flv structure: TBP>>=
   procedure :: valid_pair => flv_structure_valid_pair
 <<fks regions: procedures>>=
   function flv_structure_valid_pair &
      (flv, i, j, flv_ref, model) result (valid)
     logical :: valid
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i,j
     type(flv_structure_t), intent(in) :: flv_ref
     type(model_t), intent(in) :: model
     integer :: k, n_orig
     type(flv_structure_t) :: flv_test
     integer, dimension(:), allocatable :: flv_orig
     valid = .false.
     if (all ([i, j] <= flv%n_in)) return
     if (i <= flv%n_in .and. is_fermion(flv%flst(i))) then
        call model%match_vertex (-flv%flst(i), flv%flst(j), flv_orig)
     else if (j <= flv%n_in .and. is_fermion(flv%flst(j))) then
        call model%match_vertex (flv%flst(i), -flv%flst(j), flv_orig)
     else
        call model%match_vertex (flv%flst(i), flv%flst(j), flv_orig)
     end if
     n_orig = size (flv_orig)
     if (n_orig == 0) then
        return
     else
       do k = 1, n_orig
          if (any ([i, j] <= flv%n_in)) then
             flv_test = flv%insert_particle_isr (i, j, flv_orig(k))
          else
             flv_test = flv%insert_particle_fsr (i, j, flv_orig(k))
          end if
          valid = flv_ref .equiv. flv_test
          call flv_test%final ()
          if (valid) return
       end do
     end if
     deallocate (flv_orig)
   end function flv_structure_valid_pair
 
 @ %def flv_structure_valid_pair
 @ This function checks whether two flavor arrays are the same up to a
 permutation of the final-state particles
 <<fks regions: procedures>>=
   function flv_structure_equivalent (flv1, flv2, with_tag) result(equiv)
     logical :: equiv
     type(flv_structure_t), intent(in) :: flv1, flv2
     logical, intent(in) :: with_tag
     type(flavor_permutation_t) :: perm
     integer :: n
     n = size (flv1%flst)
     equiv = .true.
     if (n /= size (flv2%flst)) then
        call msg_fatal &
             ('flv_structure_equivalent: flavor arrays do not have equal lengths')
     else if (flv1%n_in /= flv2%n_in) then
        call msg_fatal &
             ('flv_structure_equivalent: flavor arrays do not have equal n_in')
     else
        call perm%init (flv1, flv2, flv1%n_in, flv1%nlegs, with_tag)
        equiv = perm%test (flv2, flv1, with_tag)
        call perm%final ()
     end if
   end function flv_structure_equivalent
 
 @ %def flv_structure_equivalent
 @
 <<fks regions: procedures>>=
   function flv_structure_equivalent_no_tag (flv1, flv2) result(equiv)
     logical :: equiv
     type(flv_structure_t), intent(in) :: flv1, flv2
     equiv = flv_structure_equivalent (flv1, flv2, .false.)
   end function flv_structure_equivalent_no_tag
 
   function flv_structure_equivalent_with_tag (flv1, flv2) result(equiv)
     logical :: equiv
     type(flv_structure_t), intent(in) :: flv1, flv2
     equiv = flv_structure_equivalent (flv1, flv2, .true.)
   end function flv_structure_equivalent_with_tag
 
 
 @ %def flv_structure_equivalent_no_tag, flv_structure_equivalent_with_tag
 @
 <<fks regions: procedures>>=
   pure subroutine flv_structure_assign_flv (flv_out, flv_in)
     type(flv_structure_t), intent(out) :: flv_out
     type(flv_structure_t), intent(in) :: flv_in
     flv_out%nlegs = flv_in%nlegs
     flv_out%n_in = flv_in%n_in
     flv_out%prt_symm_fs = flv_in%prt_symm_fs
     if (allocated (flv_in%flst)) then
        allocate (flv_out%flst (size (flv_in%flst)))
        flv_out%flst = flv_in%flst
     end if
     if (allocated (flv_in%tag)) then
        allocate (flv_out%tag (size (flv_in%tag)))
        flv_out%tag = flv_in%tag
     end if
     if (allocated (flv_in%massive)) then
        allocate (flv_out%massive (size (flv_in%massive)))
        flv_out%massive = flv_in%massive
     end if
     if (allocated (flv_in%colored)) then
        allocate (flv_out%colored (size (flv_in%colored)))
        flv_out%colored = flv_in%colored
     end if
   end subroutine flv_structure_assign_flv
 
 @ %def flv_structure_assign_flv
 @
 <<fks regions: procedures>>=
   pure subroutine flv_structure_assign_integer (flv_out, iarray)
     type(flv_structure_t), intent(out) :: flv_out
     integer, intent(in), dimension(:) :: iarray
     integer :: i
     flv_out%nlegs = size (iarray)
     allocate (flv_out%flst (flv_out%nlegs))
     allocate (flv_out%tag (flv_out%nlegs))
     flv_out%flst = iarray
     flv_out%tag = [(i, i = 1, flv_out%nlegs)]
   end subroutine flv_structure_assign_integer
 
 @ %def flv_structure_assign_integer
 @ Returs a new flavor array with the particle at position
 \texttt{index} removed.
 <<fks regions: flv structure: TBP>>=
   procedure :: remove_particle => flv_structure_remove_particle
 <<fks regions: procedures>>=
   function flv_structure_remove_particle (flv, index) result(flv_new)
     type(flv_structure_t) :: flv_new
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: index
     integer :: n1, n2
     integer :: i, removed_tag
     n1 = size (flv%flst); n2 = n1 - 1
     allocate (flv_new%flst (n2), flv_new%tag (n2))
     flv_new%nlegs = n2
     flv_new%n_in = flv%n_in
     removed_tag = flv%tag(index)
     if (index == 1) then
        flv_new%flst(1 : n2) = flv%flst(2 : n1)
        flv_new%tag(1 : n2) = flv%tag(2 : n1)
     else if (index == n1) then
        flv_new%flst(1 : n2) = flv%flst(1 : n2)
        flv_new%tag(1 : n2) = flv%tag(1 : n2)
     else
        flv_new%flst(1 : index - 1) = flv%flst(1 : index - 1)
        flv_new%flst(index : n2) = flv%flst(index + 1 : n1)
        flv_new%tag(1 : index - 1) = flv%tag(1 : index - 1)
        flv_new%tag(index : n2) = flv%tag(index + 1 : n1)
     end if
     do i = 1, n2
        if (flv_new%tag(i) > removed_tag) &
             flv_new%tag(i) = flv_new%tag(i) - 1
     end do
     call flv_new%compute_prt_symm_fs (flv_new%n_in)
   end function flv_structure_remove_particle
 
 @ %def flv_structure_remove_particle
 @ Removes the particles at position i1 and i2 and inserts a new
 particle of matching flavor at position i1.
 <<fks regions: flv structure: TBP>>=
   procedure :: insert_particle_fsr => flv_structure_insert_particle_fsr
 <<fks regions: procedures>>=
   function flv_structure_insert_particle_fsr (flv, i1, i2, flv_add) result (flv_new)
     type(flv_structure_t) :: flv_new
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i1, i2, flv_add
     if (flv%flst(i1) + flv_add == 0 .or. flv%flst(i2) + flv_add == 0) then
        flv_new = flv%insert_particle (i1, i2, -flv_add)
     else
        flv_new = flv%insert_particle (i1, i2, flv_add)
     end if
   end function flv_structure_insert_particle_fsr
 
 @ %def flv_structure_insert_particle_fsr
 @ Same as [[insert_particle_fsr]] but for ISR, the two particles are not exchangable.
 <<fks regions: flv structure: TBP>>=
   procedure :: insert_particle_isr => flv_structure_insert_particle_isr
 <<fks regions: procedures>>=
   function flv_structure_insert_particle_isr (flv, i_in, i_out, flv_add) result (flv_new)
     type(flv_structure_t) :: flv_new
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i_in, i_out, flv_add
     if (flv%flst(i_in) + flv_add == 0) then
        flv_new = flv%insert_particle (i_in, i_out, -flv_add)
     else
        flv_new = flv%insert_particle (i_in, i_out, flv_add)
     end if
   end function flv_structure_insert_particle_isr
 
 @ %def flv_structure_insert_particle_isr
 @ Removes the particles at position i1 and i2 and inserts a new
 particle at position i1.
 <<fks regions: flv structure: TBP>>=
   procedure :: insert_particle => flv_structure_insert_particle
 <<fks regions: procedures>>=
   function flv_structure_insert_particle (flv, i1, i2, particle) result (flv_new)
     type(flv_structure_t) :: flv_new
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: i1, i2, particle
     type(flv_structure_t) :: flv_tmp
     integer :: n1, n2
     integer :: new_tag
     n1 = size (flv%flst); n2 = n1 - 1
     allocate (flv_new%flst (n2), flv_new%tag (n2))
     flv_new%nlegs = n2
     flv_new%n_in = flv%n_in
     new_tag = maxval(flv%tag) + 1
     if (i1 < i2) then
        flv_tmp = flv%remove_particle (i1)
        flv_tmp = flv_tmp%remove_particle (i2 - 1)
     else if(i2 < i1) then
        flv_tmp = flv%remove_particle(i2)
        flv_tmp = flv_tmp%remove_particle(i1 - 1)
     else
        call msg_fatal ("flv_structure_insert_particle: Indices are identical!")
     end if
     if (i1 == 1) then
        flv_new%flst(1) = particle
        flv_new%flst(2 : n2) = flv_tmp%flst(1 : n2 - 1)
        flv_new%tag(1) = new_tag
        flv_new%tag(2 : n2) = flv_tmp%tag(1 : n2 - 1)
     else if (i1 == n1 .or. i1 == n2) then
        flv_new%flst(1 : n2 - 1) = flv_tmp%flst(1 : n2 - 1)
        flv_new%flst(n2) = particle
        flv_new%tag(1 : n2 - 1) = flv_tmp%tag(1 : n2 - 1)
        flv_new%tag(n2) = new_tag
     else
        flv_new%flst(1 : i1 - 1) = flv_tmp%flst(1 : i1 - 1)
        flv_new%flst(i1) = particle
        flv_new%flst(i1 + 1 : n2) = flv_tmp%flst(i1 : n2 - 1)
        flv_new%tag(1 : i1 - 1) = flv_tmp%tag(1 : i1 - 1)
        flv_new%tag(i1) = new_tag
        flv_new%tag(i1 + 1 : n2) = flv_tmp%tag(i1 : n2 - 1)
     end if
     call flv_new%compute_prt_symm_fs (flv_new%n_in)
   end function flv_structure_insert_particle
 
 @ %def flv_structure_insert_particle
 @ Counts the number of occurances of a particle in a
 flavor array
 <<fks regions: flv structure: TBP>>=
   procedure :: count_particle => flv_structure_count_particle
 <<fks regions: procedures>>=
   function flv_structure_count_particle (flv, part) result (n)
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: part
     integer :: n
     n = count (flv%flst == part)
   end function flv_structure_count_particle
 
 @ %def flv_structure_count_particle
 @ Initializer for flavor structures
 <<fks regions: flv structure: TBP>>=
   procedure :: init => flv_structure_init
 <<fks regions: procedures>>=
   subroutine flv_structure_init (flv, aval, n_in, tags)
     class(flv_structure_t), intent(inout) :: flv
     integer, intent(in), dimension(:) :: aval
     integer, intent(in) :: n_in
     integer, intent(in), dimension(:), optional :: tags
     integer :: i, n
     integer, dimension(:), allocatable :: aval_unique
     integer, dimension(:), allocatable :: mult
     n = size (aval)
     allocate (flv%flst (n), flv%tag (n))
     flv%flst = aval
     if (present (tags)) then
        flv%tag = tags
     else
        do i = 1, n
           flv%tag(i) = i
        end do
     end if
     flv%nlegs = n
     flv%n_in = n_in
     call flv%compute_prt_symm_fs (flv%n_in)
   end subroutine flv_structure_init
 
 @ %def flv_structure_init
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: compute_prt_symm_fs => flv_structure_compute_prt_symm_fs
 <<fks regions: procedures>>=
   subroutine flv_structure_compute_prt_symm_fs (flv, n_in)
     class(flv_structure_t), intent(inout) :: flv
     integer, intent(in) :: n_in
     integer, dimension(:), allocatable :: flst_unique
     integer, dimension(:), allocatable :: mult
     integer :: i
     flst_unique = remove_duplicates_from_int_array (flv%flst(n_in + 1 :))
     allocate (mult(size (flst_unique)))
     do i = 1, size (flst_unique)
        mult(i) = count (flv%flst(n_in + 1 :) == flst_unique(i))
     end do
     flv%prt_symm_fs = one / product (gamma (real (mult + 1, default)))
   end subroutine flv_structure_compute_prt_symm_fs
 
 @ %def flv_structure_compute_prt_symm_fs
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: write => flv_structure_write
 <<fks regions: procedures>>=
   subroutine flv_structure_write (flv, unit)
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     write (u, '(A)') char (flv%to_string ())
   end subroutine flv_structure_write
 
 @ %def flv_structure_write
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: to_string => flv_structure_to_string
 <<fks regions: procedures>>=
   function flv_structure_to_string (flv) result (flv_string)
     type(string_t) :: flv_string
     class(flv_structure_t), intent(in) :: flv
     integer :: i, n
     if (allocated (flv%flst)) then
        flv_string = var_str ("[")
        n = size (flv%flst)
        do i = 1, n - 1
           flv_string = flv_string // str (flv%flst(i)) // var_str(",")
        end do
        flv_string = flv_string // str (flv%flst(n)) // var_str("]")
     else
        flv_string = var_str ("[not allocated]")
     end if
   end function flv_structure_to_string
 
 @ %def flv_structure_to_string
 @ Creates the underlying Born flavor structure for a given real flavor
 structure if the particle at position \texttt{emitter} is removed
 <<fks regions: flv structure: TBP>>=
   procedure :: create_uborn => flv_structure_create_uborn
 <<fks regions: procedures>>=
   function flv_structure_create_uborn (flv, emitter, nlo_correction_type) result(flv_uborn)
     type(flv_structure_t) :: flv_uborn
     class(flv_structure_t), intent(in) :: flv
     type(string_t), intent(in) :: nlo_correction_type
     integer, intent(in) :: emitter
     integer n_legs
     integer :: f1, f2
     integer :: gauge_boson
 
     n_legs = size(flv%flst)
     allocate (flv_uborn%flst (n_legs - 1), flv_uborn%tag (n_legs - 1))
     gauge_boson = determine_gauge_boson_to_be_inserted ()
 
     if (emitter > flv%n_in) then
        f1 = flv%flst(n_legs); f2 = flv%flst(n_legs - 1)
        if (is_massless_vector (f1)) then
           !!! Emitted particle is a gluon or photon => just remove it
           flv_uborn = flv%remove_particle(n_legs)
        else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 + f2 == 0) then
           !!! Emission type is a gauge boson splitting into two fermions
           flv_uborn = flv%insert_particle(n_legs - 1, n_legs, gauge_boson)
        else
           call msg_error ("Create underlying Born: Unsupported splitting type.")
           call msg_error (char (str (flv%flst)))
           call msg_fatal ("FKS - FAIL")
        end if
     else if (emitter > 0) then
        f1 = flv%flst(n_legs); f2 = flv%flst(emitter)
        if (is_massless_vector (f1)) then
           flv_uborn = flv%remove_particle(n_legs)
        else if (is_fermion (f1) .and. is_massless_vector (f2)) then
           flv_uborn = flv%insert_particle (emitter, n_legs, -f1)
        else if (is_fermion (f1) .and. is_fermion (f2) .and. f1 == f2) then
           flv_uborn = flv%insert_particle(emitter, n_legs, gauge_boson)
        end if
     else
        flv_uborn = flv%remove_particle (n_legs)
     end if
 
   contains
     integer function determine_gauge_boson_to_be_inserted ()
       select case (char (nlo_correction_type))
       case ("QCD")
          determine_gauge_boson_to_be_inserted = GLUON
       case ("EW")
          determine_gauge_boson_to_be_inserted = PHOTON
       case ("Full")
          call msg_fatal ("NLO correction type 'Full' not yet implemented!")
       case default
          call msg_fatal ("Invalid NLO correction type! Valid inputs are: QCD, EW and Full (default: QCD)")
       end select
     end function determine_gauge_boson_to_be_inserted
 
   end function flv_structure_create_uborn
 
 @ %def flv_structure_create_uborn
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: init_mass_color_and_charge => flv_structure_init_mass_color_and_charge
 <<fks regions: procedures>>=
   subroutine flv_structure_init_mass_color_and_charge (flv, model)
     class(flv_structure_t), intent(inout) :: flv
     type(model_t), intent(in) :: model
     integer :: i
     type(flavor_t) :: flavor
     allocate (flv%massive (flv%nlegs), flv%colored(flv%nlegs), flv%charge(flv%nlegs))
     do i = 1, flv%nlegs
        call flavor%init (flv%flst(i), model)
        flv%massive(i) = flavor%get_mass () > 0
        flv%colored(i) = &
             is_quark (flv%flst(i)) .or. is_gluon (flv%flst(i))
        flv%charge(i) = flavor%get_charge ()
     end do
   end subroutine flv_structure_init_mass_color_and_charge
 
 @ %def flv_structure_init_mass_color_and_charge
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: get_last_two => flv_structure_get_last_two
 <<fks regions: procedures>>=
   function flv_structure_get_last_two (flv, n) result (flst_last)
     integer, dimension(2) :: flst_last
     class(flv_structure_t), intent(in) :: flv
     integer, intent(in) :: n
     flst_last = [flv%flst(n - 1), flv%flst(n)]
   end function flv_structure_get_last_two
 
 @ %def flv_structure_get_last_two
 @
 <<fks regions: flv structure: TBP>>=
   procedure :: final => flv_structure_final
 <<fks regions: procedures>>=
   subroutine flv_structure_final (flv)
     class(flv_structure_t), intent(inout) :: flv
     if (allocated (flv%flst)) deallocate (flv%flst)
     if (allocated (flv%tag)) deallocate (flv%tag)
     if (allocated (flv%massive)) deallocate (flv%massive)
     if (allocated (flv%colored)) deallocate (flv%colored)
     if (allocated (flv%charge)) deallocate (flv%charge)
   end subroutine flv_structure_final
 
 @ %def flv_structure_final
 @
 <<fks regions: public>>=
   public :: flavor_permutation_t
 <<fks regions: types>>=
   type :: flavor_permutation_t
     integer, dimension(:,:), allocatable :: perms
   contains
   <<fks regions: flavor permutation: TBP>>
   end type flavor_permutation_t
 
 @ %def flavor_permutation_t
 @
 <<fks regions: flavor permutation: TBP>>=
   procedure :: init => flavor_permutation_init
 <<fks regions: procedures>>=
   subroutine flavor_permutation_init (perm, flv_in, flv_ref, n_first, n_last, with_tag)
     class(flavor_permutation_t), intent(out) :: perm
     type(flv_structure_t), intent(in) :: flv_in, flv_ref
     integer, intent(in) :: n_first, n_last
     logical, intent(in) :: with_tag
     integer :: flv1, flv2, tmp
     integer :: tag1, tag2
     integer :: i, j, j_min, i_perm
     integer, dimension(:,:), allocatable :: perm_list_tmp
     type(flv_structure_t) :: flv_copy
     logical :: condition
     logical, dimension(:), allocatable :: already_correct
     flv_copy = flv_in
     allocate (perm_list_tmp (factorial (n_last - n_first - 1), 2))
     allocate (already_correct (flv_in%nlegs))
     already_correct = flv_in%flst == flv_ref%flst
     if (with_tag) &
          already_correct = already_correct .and. (flv_in%tag == flv_ref%tag)
     j_min = n_first + 1
     i_perm = 0
     do i = n_first + 1, n_last
        flv1 = flv_ref%flst(i)
        tag1 = flv_ref%tag(i)
        do j = j_min, n_last
           if (already_correct(i) .or. already_correct(j)) cycle
           flv2 = flv_copy%flst(j)
           tag2 = flv_copy%tag(j)
           condition = (flv1 == flv2) .and. i /= j
           if (with_tag) condition = condition .and. (tag1 == tag2)
           if (condition) then
              i_perm = i_perm + 1
              tmp = flv_copy%flst(i)
              flv_copy%flst(i) = flv2
              flv_copy%flst(j) = tmp
              tmp = flv_copy%tag(i)
              flv_copy%tag(i) = tag2
              flv_copy%tag(j) = tmp
              perm_list_tmp (i_perm, 1) = i
              perm_list_tmp (i_perm, 2) = j
              exit
           end if
        end do
        j_min = j_min + 1
     end do
     allocate (perm%perms (i_perm, 2))
     perm%perms = perm_list_tmp (1 : i_perm, :)
     deallocate (perm_list_tmp)
     call flv_copy%final ()
   end subroutine flavor_permutation_init
 
 @ %def flavor_permutation_init
 @
 <<fks regions: flavor permutation: TBP>>=
   procedure :: write => flavor_permutation_write
 <<fks regions: procedures>>=
   subroutine flavor_permutation_write (perm, unit)
     class(flavor_permutation_t), intent(in) :: perm
     integer, intent(in), optional :: unit
     integer :: i, n, u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(A)") "Flavor permutation list: "
     n = size (perm%perms, dim = 1)
     if (n > 0) then
        do i = 1, n
           write (u, "(A1,I1,1X,I1,A1)", advance = "no") "[", perm%perms(i,1), perm%perms(i,2), "]"
           if (i < n) write (u, "(A4)", advance = "no") " // "
        end do
        write (u, "(A)") ""
     else
        write (u, "(A)") "[Empty]"
     end if
   end subroutine flavor_permutation_write
 
 @ %def flavor_permutation_write
 @
 <<fks regions: flavor permutation: TBP>>=
   procedure :: reset => flavor_permutation_final
   procedure :: final => flavor_permutation_final
 <<fks regions: procedures>>=
   subroutine flavor_permutation_final (perm)
     class(flavor_permutation_t), intent(inout) :: perm
     if (allocated (perm%perms)) deallocate (perm%perms)
   end subroutine flavor_permutation_final
 
 @ %def flavor_permutation_final
 @
 <<fks regions: flavor permutation: TBP>>=
   generic :: apply => apply_permutation, &
          apply_flavor, apply_integer, apply_ftuple
   procedure :: apply_permutation => flavor_permutation_apply_permutation
   procedure :: apply_flavor => flavor_permutation_apply_flavor
   procedure :: apply_integer => flavor_permutation_apply_integer
   procedure :: apply_ftuple => flavor_permutation_apply_ftuple
 <<fks regions: procedures>>=
   elemental function flavor_permutation_apply_permutation (perm_1, perm_2) &
          result (perm_out)
     type(flavor_permutation_t) :: perm_out
     class(flavor_permutation_t), intent(in) :: perm_1
     type(flavor_permutation_t), intent(in) :: perm_2
     integer :: n1, n2
     n1 = size (perm_1%perms, dim = 1)
     n2 = size (perm_2%perms, dim = 1)
     allocate (perm_out%perms (n1 + n2, 2))
     perm_out%perms (1 : n1, :) = perm_1%perms
     perm_out%perms (n1 + 1: n1 + n2, :) = perm_2%perms
   end function flavor_permutation_apply_permutation
 
 @ %def flavor_permutation_apply_permutation
 @
 <<fks regions: procedures>>=
   elemental function flavor_permutation_apply_flavor (perm, flv_in, invert) &
          result (flv_out)
     type(flv_structure_t) :: flv_out
     class(flavor_permutation_t), intent(in) :: perm
     type(flv_structure_t), intent(in) :: flv_in
     logical, intent(in), optional :: invert
     integer :: i, i1, i2
     integer :: p1, p2, incr
     integer :: flv_tmp, tag_tmp
     logical :: inv
     inv = .false.; if (present(invert)) inv = invert
     flv_out = flv_in
     if (inv) then
        p1 = 1
        p2 = size (perm%perms, dim = 1)
        incr = 1
     else
        p1 = size (perm%perms, dim = 1)
        p2 = 1
        incr = -1
     end if
     do i = p1, p2, incr
        i1 = perm%perms(i,1)
        i2 = perm%perms(i,2)
        flv_tmp = flv_out%flst(i1)
        tag_tmp = flv_out%tag(i1)
        flv_out%flst(i1) = flv_out%flst(i2)
        flv_out%flst(i2) = flv_tmp
        flv_out%tag(i1) = flv_out%tag(i2)
        flv_out%tag(i2) = tag_tmp
     end do
   end function flavor_permutation_apply_flavor
 
 @ %def flavor_permutation_apply_flavor
 @
 <<fks regions: procedures>>=
   elemental function flavor_permutation_apply_integer (perm, i_in) result (i_out)
     integer :: i_out
     class(flavor_permutation_t), intent(in) :: perm
     integer, intent(in) :: i_in
     integer :: i, i1, i2
     i_out = i_in
     do i = size (perm%perms(:,1)), 1, -1
        i1 = perm%perms(i,1)
        i2 = perm%perms(i,2)
        if (i_out == i1) then
           i_out = i2
        else if (i_out == i2) then
           i_out = i1
        end if
     end do
   end function flavor_permutation_apply_integer
 
 @ %def flavor_permutation_apply_integer
 @
 <<fks regions: procedures>>=
   elemental function flavor_permutation_apply_ftuple (perm, f_in) result (f_out)
     type(ftuple_t) :: f_out
     class(flavor_permutation_t), intent(in) :: perm
     type(ftuple_t), intent(in) :: f_in
     integer :: i, i1, i2
     f_out = f_in
     do i = size (perm%perms, dim = 1), 1, -1
        i1 = perm%perms(i,1)
        i2 = perm%perms(i,2)
        if (f_out%ireg(1) == i1) then
           f_out%ireg(1) = i2
        else if (f_out%ireg(1) == i2) then
           f_out%ireg(1) = i1
        end if
        if (f_out%ireg(2) == i1) then
           f_out%ireg(2) = i2
        else if (f_out%ireg(2) == i2) then
           f_out%ireg(2) = i1
        end if
     end do
     if (f_out%ireg(1) > f_out%ireg(2)) f_out%ireg = f_out%ireg([2,1])
   end function flavor_permutation_apply_ftuple
 
 @ %def flavor_permutation_apply_ftuple
 @
 <<fks regions: flavor permutation: TBP>>=
   procedure :: test => flavor_permutation_test
 <<fks regions: procedures>>=
   function flavor_permutation_test (perm, flv1, flv2, with_tag) result (valid)
     logical :: valid
     class(flavor_permutation_t), intent(in) :: perm
     type(flv_structure_t), intent(in) :: flv1, flv2
     logical, intent(in) :: with_tag
     type(flv_structure_t) :: flv_test
     flv_test = perm%apply (flv2, invert = .true.)
     valid = all (flv_test%flst == flv1%flst)
     if (with_tag) valid = valid .and. all (flv_test%tag == flv1%tag)
     call flv_test%final ()
   end function flavor_permutation_test
 
 @ %def flavor_permutation_test
 @ A singular region is a partition of phase space which is associated with
 an individual emitter and, if relevant, resonance. It is associated with
 an $\alpha_r$- and resonance-index, with a real flavor structure and
 its underlying Born flavor structure. To compute the FKS weights, it is
 relevant to know all the other particle indices which can result in a
 divergenent phase space configuration, which are collected in the
 [[ftuples]]-array.
 
 Some singular regions might behave physically identical. E.g. a real
 flavor structure associated with three-jet production is $[11,-11,2,-2,21,21]$.
 Here, there are two possible [[ftuples]] which contribute to the same
 $u \rightarrow u g$ splitting, namely $(3,5)$ and $(3,6)$. The resulting
 singular regions will be identical. To avoid this, one singular region
 is associated with the multiplicity factor [[mult]]. When computing the
 subtraction terms for each singular region, the result is then simply
 multiplied by this factor.\\
 The [[double_fsr]]-flag indicates whether the singular region should
 also be supplied by a symmetry factor, explained below.
 <<fks regions: public>>=
   public :: singular_region_t
 <<fks regions: types>>=
   type :: singular_region_t
     integer :: alr
     integer :: i_res
     type(flv_structure_t) :: flst_real
     type(flv_structure_t) :: flst_uborn
     integer :: mult
     integer :: emitter
     integer :: nregions
     integer :: real_index
     type(ftuple_t), dimension(:), allocatable :: ftuples
     integer :: uborn_index
     logical :: double_fsr = .false.
     logical :: soft_divergence = .false.
     logical :: coll_divergence = .false.
     type(string_t) :: nlo_correction_type
     integer, dimension(:), allocatable :: i_reg_to_i_con
     logical :: pseudo_isr = .false.
     logical :: sc_required = .false.
     integer :: eqv_index = 0
   contains
   <<fks regions: singular region: TBP>>
   end type singular_region_t
 
 @ %def singular_region_t
 @
 <<fks regions: singular region: TBP>>=
   procedure :: init => singular_region_init
 <<fks regions: procedures>>=
   subroutine singular_region_init (sregion, alr, mult, i_res, &
          flst_real, flst_uborn, flv_born, emitter, ftuples, equivalences, &
          nlo_correction_type)
     class(singular_region_t), intent(out) :: sregion
     integer, intent(in) :: alr, mult, i_res
     type(flv_structure_t), intent(in) :: flst_real
     type(flv_structure_t), intent(in) :: flst_uborn
     type(flv_structure_t), dimension(:), intent(in) :: flv_born
     integer, intent(in) :: emitter
     type(ftuple_t), intent(inout), dimension(:) :: ftuples
     logical, intent(inout), dimension(:,:) :: equivalences
     type(string_t), intent(in) :: nlo_correction_type
     integer :: i
     call debug_input_values ()
     sregion%alr = alr
     sregion%mult = mult
     sregion%i_res = i_res
     sregion%flst_real = flst_real
     sregion%flst_uborn = flst_uborn
     sregion%emitter = emitter
     sregion%nlo_correction_type = nlo_correction_type
     sregion%nregions = size (ftuples)
     allocate (sregion%ftuples (sregion%nregions))
     sregion%ftuples = ftuples
     do i = 1, size(flv_born)
        if (flv_born (i) .equiv. sregion%flst_uborn) then
           sregion%uborn_index = i
           exit
        end if
     end do
     sregion%sc_required = any (sregion%flst_uborn%flst == GLUON) .or. &
             any (sregion%flst_uborn%flst == PHOTON)
   contains
     subroutine debug_input_values()
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "singular_region_init")
       if (debug2_active (D_SUBTRACTION)) then
          print *, 'alr =    ', alr
          print *, 'mult =    ', mult
          print *, 'i_res =    ', i_res
          call flst_real%write ()
          call flst_uborn%write ()
          print *, 'emitter =    ', emitter
          call print_equivalence_matrix (ftuples, equivalences)
       end if
     end subroutine debug_input_values
   end subroutine singular_region_init
 
 @ %def singular_region_init
 <<fks regions: singular region: TBP>>=
   procedure :: write => singular_region_write
 <<fks regions: procedures>>=
   subroutine singular_region_write (sregion, unit, maxnregions)
     class(singular_region_t), intent(in) :: sregion
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: maxnregions
     character(len=7), parameter :: flst_format = "(I3,A1)"
     character(len=7), parameter :: ireg_space_format = "(7X,A1)"
     integer :: nreal, nborn, i, u, mr
     integer :: nleft, nright, nreg, nreg_diff
     u = given_output_unit (unit); if (u < 0) return
     mr = sregion%nregions; if (present (maxnregions))  mr = maxnregions
     nreal = size (sregion%flst_real%flst)
     nborn = size (sregion%flst_uborn%flst)
     call write_vline (u)
     write (u, '(A1)', advance = 'no') '['
     do i = 1, nreal - 1
        write (u, flst_format, advance = 'no') sregion%flst_real%flst(i), ','
     end do
     write (u, flst_format, advance = 'no') sregion%flst_real%flst(nreal), ']'
     call write_vline (u)
     write (u, '(I6)', advance = 'no') sregion%real_index
     call write_vline (u)
     write (u, '(I3)', advance = 'no') sregion%emitter
     call write_vline (u)
     write (u, '(I3)', advance = 'no') sregion%mult
     call write_vline (u)
     write (u, '(I4)', advance = 'no') sregion%nregions
     call write_vline (u)
     if (sregion%i_res > 0) then
        write (u, '(I3)', advance = 'no') sregion%i_res
        call write_vline (u)
     end if
     nreg = sregion%nregions
     if (nreg == mr) then
        nleft = 0
        nright = 0
     else
        nreg_diff = mr - nreg
        nleft = nreg_diff / 2
        if (mod(nreg_diff , 2) == 0) then
           nright = nleft
        else
           nright = nleft + 1
        end if
     end if
     if (nleft > 0) then
        do i = 1, nleft
           write(u, ireg_space_format, advance='no') ' '
        end do
     end if
     write (u, '(A)', advance = 'no') char (ftuple_string (sregion%ftuples, .false.))
     call write_vline (u)
     write (u,'(A1)',advance = 'no') '['
     do i = 1, nborn - 1
        write(u, flst_format, advance = 'no') sregion%flst_uborn%flst(i), ','
     end do
     write (u, flst_format, advance = 'no') sregion%flst_uborn%flst(nborn), ']'
     call write_vline (u)
     write (u, '(I7)', advance = 'no') sregion%uborn_index
     write (u, '(A)')
   end subroutine singular_region_write
 
 @ %def singular_region_write
 @
 <<fks regions: singular region: TBP>>=
   procedure :: write_latex => singular_region_write_latex
 <<fks regions: procedures>>=
   subroutine singular_region_write_latex (region, unit)
     class(singular_region_t), intent(in) :: region
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(I2,A3,A,A3,I2,A3,I1,A3,I1,A3,A,A3,I2,A3,A,A3)") &
            region%alr, " & ", char (region%flst_real%to_string ()), &
            " & ", region%real_index, " & ", region%emitter, " & ", &
            region%mult, " & ", char (ftuple_string (region%ftuples, .true.)), &
            " & ", region%uborn_index, " & ",  char (region%flst_uborn%to_string ()), &
            " \\"
   end subroutine singular_region_write_latex
 
 @ %def singular_region_write_latex
 @ In case of a $g \rightarrow gg$ splitting, the factor
 \begin{equation*}
  \frac{2E_{\rm{em}}}{E_{\rm{em}} + E_{\rm{rad}}}
 \end{equation*}
 is multiplied to the real matrix element. This way, the symmetry of the splitting is used
 and only one singular region has to be taken into account. However, the factor ensures that
 there is only a soft singularity if the radiated parton becomes soft.
 <<fks regions: singular region: TBP>>=
   procedure :: set_splitting_info => singular_region_set_splitting_info
 <<fks regions: procedures>>=
   subroutine singular_region_set_splitting_info (region, n_in)
     class(singular_region_t), intent(inout) :: region
     integer, intent(in) :: n_in
     integer :: i1, i2
     integer :: reg
     region%double_fsr = .false.
     region%soft_divergence = .false.
     associate (ftuple => region%ftuples)
        do reg = 1, region%nregions
           call ftuple(reg)%get (i1, i2)
           if (i1 /= region%emitter .or. i2 /= region%flst_real%nlegs) then
              cycle
           else
              if (ftuple(reg)%splitting_type == V_TO_VV .or.  &
                  ftuple(reg)%splitting_type == F_TO_FV ) then
                 region%soft_divergence = .true.
              end if
 
              if (i1 == 0) then
                 region%coll_divergence = .not. all (region%flst_real%massive(1:n_in))
              else
                 region%coll_divergence = .not. region%flst_real%massive(i1)
              end if
 
              if (ftuple(reg)%splitting_type == V_TO_VV) then
                 if (all (ftuple(reg)%ireg > n_in))  &
                      region%double_fsr = all (is_gluon (region%flst_real%flst(ftuple(reg)%ireg)))
                 exit
              else if (ftuple(reg)%splitting_type == UNDEFINED_SPLITTING) then
                 call msg_fatal ("All splittings should be defined!")
              end if
           end if
        end do
        if (.not. region%soft_divergence .and. .not. region%coll_divergence) &
             call msg_fatal ("Singular region defined without divergence!")
      end associate
   end subroutine singular_region_set_splitting_info
 
 @ %def singular_region_set_splitting_info
 @
 <<fks regions: singular region: TBP>>=
   procedure :: double_fsr_factor => singular_region_double_fsr_factor
 <<fks regions: procedures>>=
   function singular_region_double_fsr_factor (region, p) result (val)
     class(singular_region_t), intent(in) :: region
     type(vector4_t), intent(in), dimension(:) :: p
     real(default) :: val
     real(default) :: E_rad, E_em
     if (region%double_fsr) then
        E_em = energy (p(region%emitter))
        E_rad = energy (p(region%flst_real%nlegs))
        val = two * E_em / (E_em + E_rad)
     else
        val = one
     end if
   end function singular_region_double_fsr_factor
 
 @ %def singular_region_double_fsr_factor
 @
 <<fks regions: singular region: TBP>>=
   procedure :: has_soft_divergence => singular_region_has_soft_divergence
 <<fks regions: procedures>>=
   function singular_region_has_soft_divergence (region) result (div)
      logical :: div
      class(singular_region_t), intent(in) :: region
      div = region%soft_divergence
   end function singular_region_has_soft_divergence
 
 @ %def singular_region_has_soft_divergence
 @
 <<fks regions: singular region: TBP>>=
   procedure :: has_collinear_divergence => &
          singular_region_has_collinear_divergence
 <<fks regions: procedures>>=
   function singular_region_has_collinear_divergence (region) result (div)
     logical :: div
     class(singular_region_t), intent(in) :: region
     div = region%coll_divergence
   end function singular_region_has_collinear_divergence
 
 @ %def singular_region_has_collinear_divergence
 @
 <<fks regions: singular region: TBP>>=
   procedure :: has_identical_ftuples => singular_region_has_identical_ftuples
 <<fks regions: procedures>>=
   elemental function singular_region_has_identical_ftuples (sregion) result (value)
     logical :: value
     class(singular_region_t), intent(in) :: sregion
     integer :: alr
     value = .false.
     do alr = 1, sregion%nregions
        value = value .or. (count (sregion%ftuples(alr) == sregion%ftuples) > 1)
     end do
   end function singular_region_has_identical_ftuples
 
 @ %def singular_region_has_identical_ftuples
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure singular_region_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine singular_region_assign (reg_out, reg_in)
     type(singular_region_t), intent(out) :: reg_out
     type(singular_region_t), intent(in) :: reg_in
     reg_out%alr = reg_in%alr
     reg_out%i_res = reg_in%i_res
     reg_out%flst_real = reg_in%flst_real
     reg_out%flst_uborn = reg_in%flst_uborn
     reg_out%mult = reg_in%mult
     reg_out%emitter = reg_in%emitter
     reg_out%nregions = reg_in%nregions
     reg_out%real_index = reg_in%real_index
     reg_out%uborn_index = reg_in%uborn_index
     reg_out%double_fsr = reg_in%double_fsr
     reg_out%soft_divergence = reg_in%soft_divergence
     reg_out%coll_divergence = reg_in%coll_divergence
     reg_out%nlo_correction_type = reg_in%nlo_correction_type
     if (allocated (reg_in%ftuples)) then
        allocate (reg_out%ftuples (size (reg_in%ftuples)))
        reg_out%ftuples = reg_in%ftuples
     else
        call msg_bug ("singular_region_assign: Trying to copy a singular region without allocated ftuples!")
     end if
   end subroutine singular_region_assign
 @ %def singular_region_assign
 @ Two singular regions match if they would produce the same amplitude.
 For this we have to check that their real and underlying Born flavor
 structures are equivalent, as determined by the [[prc_core]]. However,
 since there are more aspects of a singular region that make it unique,
 we have to check other attributes as well.
 <<fks regions: interfaces>>=
   interface operator(.match.)
      module procedure singular_region_match
   end interface
 
 <<fks regions: procedures>>=
   function singular_region_match (reg1, reg2) result (match)
     type(singular_region_t), intent(in) :: reg1, reg2
     logical :: match
     match = all ([reg1%flst_real%eqv_index, reg2%flst_real%eqv_index] > 0)
     match = match .and. (reg1%flst_real%eqv_index == reg2%flst_real%eqv_index)
     match = match .and. (reg1%flst_uborn%eqv_index == reg2%flst_uborn%eqv_index)
     match = match .and. (reg1%mult == reg2%mult)
     match = match .and. (reg1%emitter == reg2%emitter)
     match = match .and. (reg1%nregions == reg2%nregions)
     match = match .and. (reg1%double_fsr .eqv. reg2%double_fsr)
     match = match .and. (reg1%soft_divergence .eqv. reg2%soft_divergence)
     match = match .and. (reg1%coll_divergence .eqv. reg2%coll_divergence)
     match = match .and. (char (reg1%nlo_correction_type) == char (reg2%nlo_correction_type))
     if (match) match = match .and. (all (reg1%ftuples == reg2%ftuples))
   end function singular_region_match
 
 @ %def singular_region_match
 @
 <<fks regions: types>>=
   type :: resonance_mapping_t
     type(resonance_history_t), dimension(:), allocatable :: res_histories
     integer, dimension(:), allocatable :: alr_to_i_res
     integer, dimension(:,:), allocatable :: i_res_to_alr
     type(vector4_t), dimension(:), allocatable :: p_res
   contains
   <<fks regions: resonance mapping: TBP>>
   end type resonance_mapping_t
 
 @ %def resonance_mapping_t
 @ Testing: Init resonance mapping for $\mu \mu b b$ final state.
 <<fks regions: resonance mapping: TBP>>=
   procedure :: init => resonance_mapping_init
 <<fks regions: procedures>>=
   subroutine resonance_mapping_init (res_map, res_hist)
     class(resonance_mapping_t), intent(inout) :: res_map
     type(resonance_history_t), intent(in), dimension(:) :: res_hist
     integer :: n_hist, i_hist1, i_hist2, n_contributors
     n_contributors = 0
     n_hist = size (res_hist)
     allocate (res_map%res_histories (n_hist))
     do i_hist1 = 1, n_hist
        if (i_hist1 + 1 <= n_hist) then
           do i_hist2 = i_hist1 + 1, n_hist
              if (.not. (res_hist(i_hist1) .contains. res_hist(i_hist2))) &
                 n_contributors = n_contributors + res_hist(i_hist2)%n_resonances
           end do
        else
           n_contributors = n_contributors + res_hist(i_hist1)%n_resonances
        end if
     end do
     allocate (res_map%p_res (n_contributors))
     res_map%res_histories = res_hist
     res_map%p_res = vector4_null
   end subroutine resonance_mapping_init
 
 @ %def resonance_mapping_init
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: set_alr_to_i_res => resonance_mapping_set_alr_to_i_res
 <<fks regions: procedures>>=
   subroutine resonance_mapping_set_alr_to_i_res (res_map, regions, alr_new_to_old)
      class(resonance_mapping_t), intent(inout) :: res_map
      type(singular_region_t), intent(in), dimension(:) :: regions
      integer, intent(out), dimension(:), allocatable :: alr_new_to_old
      integer :: alr, i_res
      integer :: alr_new, n_alr_res
      integer :: k
      if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_set_alr_to_i_res")
      n_alr_res = 0
      do alr = 1, size (regions)
         do i_res = 1, size (res_map%res_histories)
            if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) &
               n_alr_res = n_alr_res + 1
         end do
      end do
 
      allocate (res_map%alr_to_i_res (n_alr_res))
      allocate (res_map%i_res_to_alr (size (res_map%res_histories), 10))
      res_map%i_res_to_alr = 0
      allocate (alr_new_to_old (n_alr_res))
      alr_new = 1
      do alr = 1, size (regions)
         do i_res = 1, size (res_map%res_histories)
            if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then
               res_map%alr_to_i_res (alr_new) = i_res
               alr_new_to_old (alr_new) = alr
               alr_new = alr_new  + 1
            end if
         end do
      end do
 
      do i_res = 1, size (res_map%res_histories)
         k = 1
         do alr = 1, size (regions)
            if (res_map%res_histories(i_res)%contains_leg (regions(alr)%emitter)) then
               res_map%i_res_to_alr (i_res, k) = alr
               k = k + 1
            end if
         end do
      end do
      if (debug_active (D_SUBTRACTION)) then
         print *, 'i_res_to_alr:'
         do i_res = 1, size(res_map%i_res_to_alr, dim=1)
            print *, res_map%i_res_to_alr (i_res, :)
         end do
         print *, 'alr_new_to_old:', alr_new_to_old
      end if
   end subroutine resonance_mapping_set_alr_to_i_res
 
 @ %def resonance_mapping_set_alr_to_i_res
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_resonance_history => resonance_mapping_get_resonance_history
 <<fks regions: procedures>>=
   function resonance_mapping_get_resonance_history (res_map, alr) result (res_hist)
      type(resonance_history_t) :: res_hist
      class(resonance_mapping_t), intent(in) :: res_map
      integer, intent(in) :: alr
      res_hist = res_map%res_histories(res_map%alr_to_i_res (alr))
   end function resonance_mapping_get_resonance_history
 
 @ %def resonance_mapping_get_resonance_history
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: write => resonance_mapping_write
 <<fks regions: procedures>>=
   subroutine resonance_mapping_write (res_map)
     class(resonance_mapping_t), intent(in) :: res_map
     integer :: i_res
     do i_res = 1, size (res_map%res_histories)
        call res_map%res_histories(i_res)%write ()
     end do
   end subroutine resonance_mapping_write
 
 @ %def resonance_mapping_write
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_resonance_value => resonance_mapping_get_resonance_value
 <<fks regions: procedures>>=
   function resonance_mapping_get_resonance_value (res_map, i_res, p, i_gluon) result (p_map)
     real(default) :: p_map
     class(resonance_mapping_t), intent(in) :: res_map
     integer, intent(in) :: i_res
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), optional :: i_gluon
     p_map = res_map%res_histories(i_res)%mapping (p, i_gluon)
   end function resonance_mapping_get_resonance_value
 
 @ %def resonance_mapping_get_resonance_value
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_resonance_all => resonance_mapping_get_resonance_all
 <<fks regions: procedures>>=
   function resonance_mapping_get_resonance_all (res_map, alr, p, i_gluon) result (p_map)
     real(default) :: p_map
     class(resonance_mapping_t), intent(in) :: res_map
     integer, intent(in) :: alr
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), optional :: i_gluon
     integer :: i_res
     p_map = zero
     do i_res = 1, size (res_map%res_histories)
        associate (res => res_map%res_histories(i_res))
           if (any (res_map%i_res_to_alr (i_res, :) == alr)) &
              p_map = p_map + res%mapping (p, i_gluon)
        end associate
     end do
   end function resonance_mapping_get_resonance_all
 
 @ %def resonance_mapping_get_resonance_all
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_weight => resonance_mapping_get_weight
 <<fks regions: procedures>>=
   function resonance_mapping_get_weight (res_map, alr, p) result (pfr)
     real(default) :: pfr
     class(resonance_mapping_t), intent(in) :: res_map
     integer, intent(in) :: alr
     type(vector4_t), intent(in), dimension(:) :: p
     real(default) :: sumpfr
     integer :: i_res
     sumpfr = zero
     do i_res = 1, size (res_map%res_histories)
        sumpfr = sumpfr + res_map%get_resonance_value (i_res, p)
     end do
     pfr = res_map%get_resonance_value (res_map%alr_to_i_res (alr), p) / sumpfr
   end function resonance_mapping_get_weight
 
 @ %def resonance_mapping_get_weight
 @
 <<fks regions: resonance mapping: TBP>>=
   procedure :: get_resonance_alr => resonance_mapping_get_resonance_alr
 <<fks regions: procedures>>=
   function resonance_mapping_get_resonance_alr (res_map, alr, p, i_gluon) result (p_map)
     real(default) :: p_map
     class(resonance_mapping_t), intent(in) :: res_map
     integer, intent(in) :: alr
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), optional :: i_gluon
     integer :: i_res
     i_res = res_map%alr_to_i_res (alr)
     p_map = res_map%res_histories(i_res)%mapping (p, i_gluon)
   end function resonance_mapping_get_resonance_alr
 
 @ %def resonance_mapping_get_resonance_alr
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure resonance_mapping_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine resonance_mapping_assign (res_map_out, res_map_in)
     type(resonance_mapping_t), intent(out) :: res_map_out
     type(resonance_mapping_t), intent(in) :: res_map_in
     if (allocated (res_map_in%res_histories)) then
        allocate (res_map_out%res_histories (size (res_map_in%res_histories)))
        res_map_out%res_histories = res_map_in%res_histories
     end if
     if (allocated (res_map_in%alr_to_i_res)) then
        allocate (res_map_out%alr_to_i_res (size (res_map_in%alr_to_i_res)))
        res_map_out%alr_to_i_res = res_map_in%alr_to_i_res
     end if
     if (allocated (res_map_in%i_res_to_alr)) then
        allocate (res_map_out%i_res_to_alr &
           (size (res_map_in%i_res_to_alr, 1), size (res_map_in%i_res_to_alr, 2)))
        res_map_out%i_res_to_alr = res_map_in%i_res_to_alr
     end if
     if (allocated (res_map_in%p_res)) then
        allocate (res_map_out%p_res (size (res_map_in%p_res)))
        res_map_out%p_res = res_map_in%p_res
     end if
   end subroutine resonance_mapping_assign
 
 @ %def resonance_mapping_assign
 @ Every FKS mapping should store the $\sum_\alpha d_{ij}^{-1}$ and
 $\sum_\alpha d_{ij,\rm{soft}}^{-1}$.
 Also we keep the option open to use a normlization factor, which ensures
 $\sum_\alpha S_\alpha = 1$.
 <<fks regions: types>>=
   type, abstract :: fks_mapping_t
      real(default) :: sumdij
      real(default) :: sumdij_soft
      logical :: pseudo_isr = .false.
      real(default) :: normalization_factor = one
   contains
   <<fks regions: fks mapping: TBP>>
   end type fks_mapping_t
 
 @ %def fks_mapping_t
 @
 <<fks regions: public>>=
   public :: fks_mapping_default_t
 <<fks regions: types>>=
   type, extends (fks_mapping_t) :: fks_mapping_default_t
     real(default) :: exp_1, exp_2
     integer :: n_in
   contains
   <<fks regions: fks mapping default: TBP>>
   end type fks_mapping_default_t
 
 @ %def fks_mapping_default_t
 @
 <<fks regions: public>>=
   public :: fks_mapping_resonances_t
 <<fks regions: types>>=
   type, extends (fks_mapping_t) :: fks_mapping_resonances_t
     real(default) :: exp_1, exp_2
     type(resonance_mapping_t) :: res_map
     integer :: i_con = 0
   contains
   <<fks regions: fks mapping resonances: TBP>>
   end type fks_mapping_resonances_t
 
 @ %def fks_mapping_resonances_t
 @
 <<fks regions: public>>=
   public :: operator(.equiv.)
   public :: operator(.equivtag.)
 <<fks regions: interfaces>>=
   interface operator(.equiv.)
     module procedure flv_structure_equivalent_no_tag
   end interface
 
   interface operator(.equivtag.)
     module procedure flv_structure_equivalent_with_tag
   end interface
 
   interface assignment(=)
     module procedure flv_structure_assign_flv
     module procedure flv_structure_assign_integer
   end interface
 
 @ %def operator_equiv
 @
 <<fks regions: public>>=
   public :: region_data_t
 <<fks regions: types>>=
   type :: region_data_t
     type(singular_region_t), dimension(:), allocatable :: regions
     type(flv_structure_t), dimension(:), allocatable :: flv_born
     type(flv_structure_t), dimension(:), allocatable :: flv_real
     integer, dimension(:), allocatable :: eqv_flv_index_born
     integer, dimension(:), allocatable :: eqv_flv_index_real
     integer, dimension(:), allocatable :: emitters
     integer :: n_regions = 0
     integer :: n_emitters = 0
     integer :: n_flv_born = 0
     integer :: n_flv_real = 0
     integer :: n_in = 0
     integer :: n_legs_born = 0
     integer :: n_legs_real = 0
     integer :: n_phs = 0
     class(fks_mapping_t), allocatable :: fks_mapping
     integer, dimension(:), allocatable :: resonances
     type(resonance_contributors_t), dimension(:), allocatable :: alr_contributors
     integer, dimension(:), allocatable :: alr_to_i_contributor
     integer, dimension(:), allocatable :: i_phs_to_i_con
   contains
   <<fks regions: reg data: TBP>>
   end type region_data_t
 
 @ %def region_data_t
 @
 <<fks regions: reg data: TBP>>=
   procedure :: allocate_fks_mappings => region_data_allocate_fks_mappings
 <<fks regions: procedures>>=
   subroutine region_data_allocate_fks_mappings (reg_data, mapping_type)
     class(region_data_t), intent(inout) :: reg_data
     integer, intent(in) :: mapping_type
 
     select case (mapping_type)
     case (FKS_DEFAULT)
        allocate (fks_mapping_default_t :: reg_data%fks_mapping)
     case (FKS_RESONANCES)
        allocate (fks_mapping_resonances_t :: reg_data%fks_mapping)
     case default
        call msg_fatal ("Init region_data: FKS mapping not implemented!")
     end select
   end subroutine region_data_allocate_fks_mappings
 
 @ %def region_data_allocate_fks_mappings
 @
 <<fks regions: reg data: TBP>>=
   procedure :: init => region_data_init
 <<fks regions: procedures>>=
   subroutine region_data_init (reg_data, n_in, model, flavor_born, &
          flavor_real, nlo_correction_type)
     class(region_data_t), intent(inout) :: reg_data
     integer, intent(in) :: n_in
     type(model_t), intent(in) :: model
     integer, intent(in), dimension(:,:) :: flavor_born, flavor_real
     type(ftuple_list_t), dimension(:), allocatable :: ftuples
     integer, dimension(:), allocatable :: emitter
     type(flv_structure_t), dimension(:), allocatable :: flst_alr
     integer :: i
     integer :: n_flv_real_before_check
     type(string_t), intent(in) :: nlo_correction_type
     reg_data%n_in = n_in
     reg_data%n_flv_born = size (flavor_born, dim = 2)
     reg_data%n_legs_born = size (flavor_born, dim = 1)
     reg_data%n_legs_real = reg_data%n_legs_born + 1
     n_flv_real_before_check = size (flavor_real, dim = 2)
     allocate (reg_data%flv_born (reg_data%n_flv_born))
     allocate (reg_data%flv_real (n_flv_real_before_check))
     do i = 1, reg_data%n_flv_born
        call reg_data%flv_born(i)%init (flavor_born (:, i), n_in)
     end do
     do i = 1, n_flv_real_before_check
        call reg_data%flv_real(i)%init (flavor_real (:, i), n_in)
     end do
 
     call reg_data%find_regions (model, ftuples, emitter, flst_alr)
     call reg_data%init_singular_regions (ftuples, emitter, flst_alr, nlo_correction_type)
     reg_data%n_flv_real = maxval (reg_data%regions%real_index)
     call reg_data%find_emitters ()
     call reg_data%set_mass_color_and_charge (model)
     call reg_data%set_splitting_info ()
 
   end subroutine region_data_init
 
 @ %def region_data_init
 @
 <<fks regions: reg data: TBP>>=
   procedure :: init_resonance_information => region_data_init_resonance_information
 <<fks regions: procedures>>=
   subroutine region_data_init_resonance_information (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     call reg_data%enlarge_singular_regions_with_resonances ()
     call reg_data%find_resonances ()
   end subroutine region_data_init_resonance_information
 
 @ %def region_data_init_resonance_information
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_resonance_mappings => region_data_set_resonance_mappings
 <<fks regions: procedures>>=
   subroutine region_data_set_resonance_mappings (reg_data, resonance_histories)
     class(region_data_t), intent(inout) :: reg_data
     type(resonance_history_t), intent(in), dimension(:) :: resonance_histories
     select type (map => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        call map%res_map%init (resonance_histories)
     end select
   end subroutine region_data_set_resonance_mappings
 
 @ %def region_data_set_resonance_mappings
 @
 <<fks regions: reg data: TBP>>=
   procedure :: setup_fks_mappings => region_data_setup_fks_mappings
 <<fks regions: procedures>>=
   subroutine region_data_setup_fks_mappings (reg_data, template, n_in)
     class(region_data_t), intent(inout) :: reg_data
     type(fks_template_t), intent(in) :: template
     integer, intent(in) :: n_in
     call reg_data%allocate_fks_mappings (template%mapping_type)
     select type (map => reg_data%fks_mapping)
     type is (fks_mapping_default_t)
        call map%set_parameter (n_in, template%fks_dij_exp1, template%fks_dij_exp2)
     end select
   end subroutine region_data_setup_fks_mappings
 
 @ %def region_data_setup_fks_mappings
 @ So far, we have only created singular regions for a non-resonant case. When
 resonance mappings are required, we have more singular regions, since they
 must now be identified by their emitter-resonance pair index, where the emitter
 must be compatible with the resonance.
 <<fks regions: reg data: TBP>>=
   procedure :: enlarge_singular_regions_with_resonances &
      => region_data_enlarge_singular_regions_with_resonances
 <<fks regions: procedures>>=
   subroutine region_data_enlarge_singular_regions_with_resonances (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr
     integer, dimension(:), allocatable :: alr_new_to_old
     integer :: n_alr_new
     type(singular_region_t), dimension(:), allocatable :: save_regions
     if (debug_on) call msg_debug (D_SUBTRACTION, "region_data_enlarge_singular_regions_with_resonances")
     call debug_input_values ()
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_default_t)
        return
     type is (fks_mapping_resonances_t)
        allocate (save_regions (reg_data%n_regions))
        do alr = 1, reg_data%n_regions
           save_regions(alr) = reg_data%regions(alr)
        end do
 
        associate (res_map => fks_mapping%res_map)
           call res_map%set_alr_to_i_res (reg_data%regions, alr_new_to_old)
           deallocate (reg_data%regions)
           n_alr_new = size (alr_new_to_old)
           reg_data%n_regions = n_alr_new
           allocate (reg_data%regions (n_alr_new))
           do alr = 1, n_alr_new
              reg_data%regions(alr) = save_regions(alr_new_to_old (alr))
              reg_data%regions(alr)%i_res = res_map%alr_to_i_res (alr)
           end do
        end associate
     end select
 
   contains
 
     subroutine debug_input_values ()
       if (debug2_active (D_SUBTRACTION)) then
          call reg_data%write ()
       end if
     end subroutine debug_input_values
 
   end subroutine region_data_enlarge_singular_regions_with_resonances
 
 @ %def region_data_enlarge_singular_regions_with_resonances
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_isr_pseudo_regions => region_data_set_isr_pseudo_regions
 <<fks regions: procedures>>=
   subroutine region_data_set_isr_pseudo_regions (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr
     integer :: n_alr_new
     !!! Subroutine called for threshold factorization ->
     !!! Size of singular regions at this point is fixed
     type(singular_region_t), dimension(2) :: save_regions
     integer, dimension(4) :: alr_new_to_old
     do alr = 1, reg_data%n_regions
        save_regions(alr) = reg_data%regions(alr)
     end do
     n_alr_new = reg_data%n_regions * 2
     alr_new_to_old = [1, 1, 2, 2]
     deallocate (reg_data%regions)
     allocate (reg_data%regions (n_alr_new))
     reg_data%n_regions = n_alr_new
     do alr = 1, n_alr_new
        reg_data%regions(alr) = save_regions(alr_new_to_old (alr))
        call add_pseudo_emitters (reg_data%regions(alr))
        if (mod (alr, 2) == 0) reg_data%regions(alr)%pseudo_isr = .true.
     end do
   contains
     subroutine add_pseudo_emitters (sregion)
       type(singular_region_t), intent(inout) :: sregion
       type(ftuple_t), dimension(2) :: ftuples_save
       integer :: alr
       do alr = 1, 2
          ftuples_save(alr) = sregion%ftuples(alr)
       end do
       deallocate (sregion%ftuples)
       sregion%nregions = sregion%nregions * 2
       allocate (sregion%ftuples (sregion%nregions))
       do alr = 1, sregion%nregions
          sregion%ftuples(alr) = ftuples_save (alr_new_to_old(alr))
          if (mod (alr, 2) == 0) sregion%ftuples(alr)%pseudo_isr = .true.
       end do
     end subroutine add_pseudo_emitters
   end subroutine region_data_set_isr_pseudo_regions
 
 @ %def region_data_set_isr_pseudo_regions
 @ This subroutine splits up the ftuple-list of the singular regions into interference-free
 lists, i.e. lists which only contain the same emitter. This is relevant for factorized
 NLO calculations. In the current implementation, it is hand-tailored for the threshold
 computation, but should be generalized further in the future.
 <<fks regions: reg data: TBP>>=
   procedure :: split_up_interference_regions_for_threshold => &
        region_data_split_up_interference_regions_for_threshold
 <<fks regions: procedures>>=
   subroutine region_data_split_up_interference_regions_for_threshold (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr, i_ftuple
     integer :: current_emitter
     integer :: i1, i2
     integer :: n_new_reg
     type(ftuple_t), dimension(2) :: ftuples
     do alr = 1, reg_data%n_regions
        associate (region => reg_data%regions(alr))
           current_emitter = region%emitter
           n_new_reg = 0
           do i_ftuple = 1, region%nregions
              call region%ftuples(i_ftuple)%get (i1, i2)
              if (i1 == current_emitter) then
                 n_new_reg = n_new_reg + 1
                 ftuples(n_new_reg) = region%ftuples(i_ftuple)
              end if
           end do
           deallocate (region%ftuples)
           allocate (region%ftuples(n_new_reg))
           region%ftuples = ftuples (1 : n_new_reg)
           region%nregions = n_new_reg
        end associate
     end do
     reg_data%fks_mapping%normalization_factor = 0.5_default
   end subroutine region_data_split_up_interference_regions_for_threshold
 
 @ %def region_data_split_up_interference_regions_for_threshold
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_mass_color_and_charge => region_data_set_mass_color_and_charge
 <<fks regions: procedures>>=
   subroutine region_data_set_mass_color_and_charge (reg_data, model)
     class(region_data_t), intent(inout) :: reg_data
     type(model_t), intent(in) :: model
     integer :: i
     do i = 1, reg_data%n_regions
        associate (region => reg_data%regions(i))
           call region%flst_uborn%init_mass_color_and_charge (model)
           call region%flst_real%init_mass_color_and_charge (model)
        end associate
     end do
     do i = 1, reg_data%n_flv_born
        call reg_data%flv_born(i)%init_mass_color_and_charge (model)
     end do
     do i = 1, size (reg_data%flv_real)
        call reg_data%flv_real(i)%init_mass_color_and_charge (model)
     end do
   end subroutine region_data_set_mass_color_and_charge
 
 @ %def region_data_set_mass_color_and_charge
 @
 <<fks regions: reg data: TBP>>=
   procedure :: uses_resonances => region_data_uses_resonances
 <<fks regions: procedures>>=
   function region_data_uses_resonances (reg_data) result (val)
     logical :: val
     class(region_data_t), intent(in) :: reg_data
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        val = .true.
     class default
        val = .false.
     end select
   end function region_data_uses_resonances
 
 @ %def region_data_uses_resonances
 @ Creates a list containing the emitter of each singular region.
 <<fks regions: reg data: TBP>>=
   procedure :: get_emitter_list => region_data_get_emitter_list
 <<fks regions: procedures>>=
   pure function region_data_get_emitter_list (reg_data) result (emitters)
     class(region_data_t), intent(in) :: reg_data
     integer, dimension(:), allocatable :: emitters
     integer :: i
     allocate (emitters (reg_data%n_regions))
     do i = 1, reg_data%n_regions
        emitters(i) = reg_data%regions(i)%emitter
     end do
   end function region_data_get_emitter_list
 
 @ %def region_data_get_emitter_list
 @ Returns the number of emitters not equal to 0 to avoid double counting
 between emitters 0, 1 and 2.
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_emitters_sc => region_data_get_n_emitters_sc
 <<fks regions: procedures>>=
   function region_data_get_n_emitters_sc (reg_data) result (n_emitters_sc)
     class(region_data_t), intent(in) :: reg_data
     integer :: n_emitters_sc
     n_emitters_sc = count (reg_data%emitters /= 0)
   end function region_data_get_n_emitters_sc
 
 @ %def region_data_get_n_emitters_sc
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_associated_resonances => region_data_get_associated_resonances
 <<fks regions: procedures>>=
   function region_data_get_associated_resonances (reg_data, emitter) result (res)
     integer, dimension(:), allocatable :: res
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: emitter
     integer :: alr, i
     integer :: n_res
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        n_res = 0
 
        do alr = 1, reg_data%n_regions
           if (reg_data%regions(alr)%emitter == emitter) &
              n_res = n_res + 1
        end do
 
        if (n_res > 0) then
           allocate (res (n_res))
        else
           return
        end if
        i = 1
 
        do alr = 1, reg_data%n_regions
           if (reg_data%regions(alr)%emitter == emitter) then
              res (i) = fks_mapping%res_map%alr_to_i_res (alr)
              i = i + 1
           end if
        end do
     end select
   end function region_data_get_associated_resonances
 
 @ %def region_data_get_associated_resonances
 @
 <<fks regions: reg data: TBP>>=
   procedure :: emitter_is_compatible_with_resonance => &
      region_data_emitter_is_compatible_with_resonance
 <<fks regions: procedures>>=
   function region_data_emitter_is_compatible_with_resonance &
      (reg_data, i_res, emitter) result (compatible)
      logical :: compatible
      class(region_data_t), intent(in) :: reg_data
      integer, intent(in) :: i_res, emitter
      integer :: i_res_alr, alr
      compatible = .false.
      select type (fks_mapping => reg_data%fks_mapping)
      type is (fks_mapping_resonances_t)
         do alr = 1, reg_data%n_regions
            i_res_alr = fks_mapping%res_map%alr_to_i_res (alr)
            if (i_res_alr == i_res .and. reg_data%get_emitter(alr) == emitter) then
               compatible = .true.
               exit
            end if
         end do
      end select
   end function region_data_emitter_is_compatible_with_resonance
 
 @ %def region_data_emitter_is_compatible_with_resonance
 @
 <<fks regions: reg data: TBP>>=
   procedure :: emitter_is_in_resonance => region_data_emitter_is_in_resonance
 <<fks regions: procedures>>=
   function region_data_emitter_is_in_resonance (reg_data, i_res, emitter) result (exist)
     logical :: exist
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_res, emitter
     integer :: i
     exist = .false.
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        associate (res_history => fks_mapping%res_map%res_histories(i_res))
           do i = 1, res_history%n_resonances
              exist = exist .or. any (res_history%resonances(i)%contributors%c == emitter)
           end do
       end associate
     end select
   end function region_data_emitter_is_in_resonance
 
 @ %def region_data_emitter_is_in_resonance
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_contributors => region_data_get_contributors
 <<fks regions: procedures>>=
   subroutine region_data_get_contributors (reg_data, i_res, emitter, c, success)
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_res, emitter
     integer, intent(inout), dimension(:), allocatable :: c
     logical, intent(out) :: success
     integer :: i
     success = .false.
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        associate (res_history => fks_mapping%res_map%res_histories (i_res))
           do i = 1, res_history%n_resonances
              if (any (res_history%resonances(i)%contributors%c == emitter)) then
                 allocate (c (size (res_history%resonances(i)%contributors%c)))
                 c = res_history%resonances(i)%contributors%c
                 success = .true.
                 exit
              end if
           end do
        end associate
     end select
   end subroutine region_data_get_contributors
 
 @ %def region_data_get_contributors
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_emitter => region_data_get_emitter
 <<fks regions: procedures>>=
   pure function region_data_get_emitter (reg_data, alr) result (emitter)
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: alr
     integer :: emitter
     emitter = reg_data%regions(alr)%emitter
   end function region_data_get_emitter
 
 @ %def region_data_get_emitter
 @
 <<fks regions: reg data: TBP>>=
   procedure :: map_real_to_born_index => region_data_map_real_to_born_index
 <<fks regions: procedures>>=
   function region_data_map_real_to_born_index (reg_data, real_index) result (uborn_index)
     integer :: uborn_index
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: real_index
     integer :: alr
     uborn_index = 0
     do alr = 1, size (reg_data%regions)
        if (reg_data%regions(alr)%real_index == real_index) then
           uborn_index = reg_data%regions(alr)%uborn_index
           exit
        end if
     end do
   end function region_data_map_real_to_born_index
 
 @ %def region_data_map_real_to_born_index
 @
 <<fks regions: reg data: TBP>>=
   generic :: get_flv_states_born => get_flv_states_born_single, get_flv_states_born_array
   procedure :: get_flv_states_born_single => region_data_get_flv_states_born_single
   procedure :: get_flv_states_born_array => region_data_get_flv_states_born_array
 <<fks regions: procedures>>=
   function region_data_get_flv_states_born_array (reg_data) result (flv_states)
     integer, dimension(:,:), allocatable :: flv_states
     class(region_data_t), intent(in) :: reg_data
     integer :: i_flv
     allocate (flv_states (reg_data%n_legs_born, reg_data%n_flv_born))
     do i_flv = 1, reg_data%n_flv_born
        flv_states (:, i_flv) = reg_data%flv_born(i_flv)%flst
     end do
   end function region_data_get_flv_states_born_array
 
   function region_data_get_flv_states_born_single (reg_data, i_flv) result (flv_states)
     integer, dimension(:), allocatable :: flv_states
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_flv
     allocate (flv_states (reg_data%n_legs_born))
     flv_states = reg_data%flv_born(i_flv)%flst
   end function region_data_get_flv_states_born_single
 
 @ %def region_data_get_flv_states_born
 @
 <<fks regions: reg data: TBP>>=
   generic :: get_flv_states_real => get_flv_states_real_single, get_flv_states_real_array
   procedure :: get_flv_states_real_single => region_data_get_flv_states_real_single
   procedure :: get_flv_states_real_array => region_data_get_flv_states_real_array
 <<fks regions: procedures>>=
   function region_data_get_flv_states_real_single (reg_data, i_flv) result (flv_states)
     integer, dimension(:), allocatable :: flv_states
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_flv
     integer :: i_reg
     allocate (flv_states (reg_data%n_legs_real))
     do i_reg = 1, reg_data%n_regions
        if (i_flv == reg_data%regions(i_reg)%real_index) then
           flv_states = reg_data%regions(i_reg)%flst_real%flst
           exit
        end if
     end do
   end function region_data_get_flv_states_real_single
 
   function region_data_get_flv_states_real_array (reg_data) result (flv_states)
     integer, dimension(:,:), allocatable :: flv_states
     class(region_data_t), intent(in) :: reg_data
     integer :: i_flv
     allocate (flv_states (reg_data%n_legs_real, reg_data%n_flv_real))
     do i_flv = 1, reg_data%n_flv_real
        flv_states (:, i_flv) = reg_data%get_flv_states_real (i_flv)
     end do
   end function region_data_get_flv_states_real_array
 
 @ %def region_data_get_flv_states_real
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_all_flv_states => region_data_get_all_flv_states
 <<fks regions: procedures>>=
   subroutine region_data_get_all_flv_states (reg_data, flv_born, flv_real)
      class(region_data_t), intent(in) :: reg_data
      integer, dimension(:,:), allocatable, intent(out) :: flv_born, flv_real
      allocate (flv_born (reg_data%n_legs_born, reg_data%n_flv_born))
      flv_born = reg_data%get_flv_states_born ()
      allocate (flv_real (reg_data%n_legs_real, reg_data%n_flv_real))
      flv_real = reg_data%get_flv_states_real ()
   end subroutine region_data_get_all_flv_states
 
 @ %def region_data_get_all_flv_states
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_in => region_data_get_n_in
 <<fks regions: procedures>>=
   function region_data_get_n_in (reg_data) result (n_in)
     integer :: n_in
     class(region_data_t), intent(in) :: reg_data
     n_in = reg_data%n_in
   end function region_data_get_n_in
 
 @ %def region_data_get_n_in
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_legs_real => region_data_get_n_legs_real
 <<fks regions: procedures>>=
   function region_data_get_n_legs_real (reg_data) result (n_legs)
     integer :: n_legs
     class(region_data_t), intent(in) :: reg_data
     n_legs = reg_data%n_legs_real
   end function region_data_get_n_legs_real
 
 @ %def region_data_get_n_legs_real
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_legs_born => region_data_get_n_legs_born
 <<fks regions: procedures>>=
   function region_data_get_n_legs_born (reg_data) result (n_legs)
     integer :: n_legs
     class(region_data_t), intent(in) :: reg_data
     n_legs = reg_data%n_legs_born
   end function region_data_get_n_legs_born
 
 @ %def region_data_get_n_legs_born
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_flv_real => region_data_get_n_flv_real
 <<fks regions: procedures>>=
   function region_data_get_n_flv_real (reg_data) result (n_flv)
     integer :: n_flv
     class(region_data_t), intent(in) :: reg_data
     n_flv = reg_data%n_flv_real
   end function region_data_get_n_flv_real
 
 @ %def region_data_get_n_flv_real
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_flv_born => region_data_get_n_flv_born
 <<fks regions: procedures>>=
   function region_data_get_n_flv_born (reg_data) result (n_flv)
     integer :: n_flv
     class(region_data_t), intent(in) :: reg_data
     n_flv = reg_data%n_flv_born
   end function region_data_get_n_flv_born
 
 @ %def region_data_get_n_flv_born
 
 @ Returns $S_i = \frac{1}{\mathcal{D}d_i}$ or $S_{ij} =
 \frac{1}{\mathcal{D}d_{ij}}$ for one particular singular region.  At
 this point, the flavor array should be rearranged in such a way that
 the emitted particle is at the last position of
 the flavor structure list.
 <<fks regions: reg data: TBP>>=
   generic :: get_svalue => get_svalue_last_pos, get_svalue_ij
   procedure :: get_svalue_last_pos => region_data_get_svalue_last_pos
   procedure :: get_svalue_ij => region_data_get_svalue_ij
 <<fks regions: procedures>>=
   function region_data_get_svalue_ij (reg_data, p_real, alr, i, j, i_res) result (sval)
     class(region_data_t), intent(inout) :: reg_data
     type(vector4_t), intent(in), dimension(:) :: p_real
     integer, intent(in) :: alr, i, j
     integer, intent(in) :: i_res
     real(default) :: sval
     associate (map => reg_data%fks_mapping)
        call map%compute_sumdij (reg_data%regions(alr), p_real)
        select type (map)
        type is (fks_mapping_resonances_t)
           map%i_con = reg_data%alr_to_i_contributor (alr)
        end select
        map%pseudo_isr = reg_data%regions(alr)%pseudo_isr
        sval = map%svalue (p_real, i, j, i_res) * map%normalization_factor
     end associate
   end function region_data_get_svalue_ij
 
   function region_data_get_svalue_last_pos (reg_data, p, alr, emitter, i_res) result (sval)
     class(region_data_t), intent(inout) :: reg_data
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: alr, emitter
     integer, intent(in) :: i_res
     real(default) :: sval
     sval = reg_data%get_svalue (p, alr, emitter, reg_data%n_legs_real, i_res)
   end function region_data_get_svalue_last_pos
 
 @ %def region_data_get_svalue
 @ The same as above, but for the soft limit.
 <<fks regions: reg data: TBP>>=
   procedure :: get_svalue_soft => region_data_get_svalue_soft
 <<fks regions: procedures>>=
   function region_data_get_svalue_soft &
        (reg_data, p_born, p_soft, alr, emitter, i_res) result (sval)
     class(region_data_t), intent(inout) :: reg_data
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     integer, intent(in) :: alr, emitter, i_res
     real(default) :: sval
     associate (map => reg_data%fks_mapping)
        call map%compute_sumdij_soft (reg_data%regions(alr), p_born, p_soft)
        select type (map)
        type is (fks_mapping_resonances_t)
           map%i_con = reg_data%alr_to_i_contributor (alr)
        end select
        map%pseudo_isr = reg_data%regions(alr)%pseudo_isr
        sval = map%svalue_soft (p_born, p_soft, emitter, i_res) * map%normalization_factor
     end associate
   end function region_data_get_svalue_soft
 
 @ %def region_data_get_svalue_soft
 @ This subroutine starts with a specification of $N$- and
 $N+1$-particle configurations, [[flst_born]] and [[flst_real]], saved
 in [[reg_data]]. From these, it creates a list of fundamental tuples,
 a list of emitters and a list containing the $N+1$-particle
 configuration, rearranged  in such a way that the emitter-radiation
 pair is last ([[flst_alr]]). For the $e^+ \, e^- \, \rightarrow u \,
 \bar{u} \, g$- example, the generated objects are shown in table
 \ref{table:ftuples and flavors}. Note that at this point, [[flst_alr]]
 is arranged in such a way that the emitter can only be equal to
 $n_{legs}-1$ for final-state radiation or 0, 1, or 2 for initial-state
 radiation. Further, it occurs that regions can be equivalent. For
 example in table \ref{table:ftuples and flavors} the regions
 corresponding to \texttt{alr} = 1 and \texttt{alr} = 3 as well as
 \texttt{alr} = 2 and \texttt{alr} = 4 describe the same physics and
 are therefore equivalent.
 @
 <<fks regions: reg data: TBP>>=
   procedure :: find_regions => region_data_find_regions
 <<fks regions: procedures>>=
   subroutine region_data_find_regions &
        (reg_data, model, ftuples, emitters, flst_alr)
     class(region_data_t), intent(in) :: reg_data
     type(model_t), intent(in) :: model
     type(ftuple_list_t), intent(out), dimension(:), allocatable :: ftuples
     integer, intent(out), dimension(:), allocatable :: emitters
     type(flv_structure_t), intent(out), dimension(:), allocatable :: flst_alr
     type(ftuple_list_t), dimension(:,:), allocatable :: ftuples_tmp
     integer, dimension(:,:), allocatable :: ftuple_index
     integer :: n_born, n_real
     integer :: n_legreal
     integer :: i_born, i_real, i_ftuple
     integer :: last_registered_i_born, last_registered_i_real
 
     n_born = size (reg_data%flv_born)
     n_real = size (reg_data%flv_real)
     n_legreal = size (reg_data%flv_real(1)%flst)
     allocate (emitters (0))
     allocate (flst_alr (0))
     allocate (ftuples (0))
     i_ftuple = 0
     last_registered_i_born = 0; last_registered_i_real = 0
 
     do i_real = 1, n_real
        do i_born = 1, n_born
           call setup_flsts_emitters_and_ftuples_fsr &
                (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples)
           call setup_flsts_emitters_and_ftuples_isr &
                (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples)
        end do
     end do
 
   contains
     function incr_i_ftuple_if_required (i_born, i_real, i_ftuple_in) result (i_ftuple)
       integer :: i_ftuple
       integer, intent(in) :: i_born, i_real, i_ftuple_in
       if (last_registered_i_born /= i_born .or. last_registered_i_real /= i_real) then
          last_registered_i_born = i_born
          last_registered_i_real = i_real
          i_ftuple = i_ftuple_in + 1
       else
          i_ftuple = i_ftuple_in
       end if
     end function incr_i_ftuple_if_required
 
     subroutine setup_flsts_emitters_and_ftuples_fsr &
            (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples)
       integer, intent(in) :: i_real, i_born
       integer, intent(inout) :: i_ftuple
       type(flv_structure_t), intent(inout), dimension(:), allocatable :: flst_alr
       integer, intent(inout), dimension(:), allocatable :: emitters
       type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
       type(ftuple_list_t) :: ftuples_tmp
       type(flv_structure_t) :: flst_alr_tmp
       type(ftuple_t) :: current_ftuple
       integer :: leg1, leg2
       logical :: valid
       associate (flv_born => reg_data%flv_born(i_born), &
               flv_real => reg_data%flv_real(i_real))
          do leg1 = reg_data%n_in + 1, n_legreal
             do leg2 = leg1 + 1, n_legreal
                valid = flv_real%valid_pair(leg1, leg2, flv_born, model)
                if (valid) then
                   if (is_vector(flv_real%flst(leg1)) .and. &
                      is_fermion(flv_real%flst(leg2))) then
                      flst_alr_tmp = create_alr (flv_real, &
                           reg_data%n_in, leg2, leg1)
                   else
                      flst_alr_tmp = create_alr (flv_real, &
                           reg_data%n_in, leg1, leg2)
                   end if
                   flst_alr = [flst_alr, flst_alr_tmp]
                   emitters = [emitters, n_legreal - 1]
                   call current_ftuple%set (leg1, leg2)
                   call current_ftuple%determine_splitting_type_fsr &
                        (flv_real, leg1, leg2)
                   i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple)
                   if (i_ftuple > size (ftuples)) then
                      call ftuples_tmp%append (current_ftuple)
                      ftuples = [ftuples, ftuples_tmp]
                   else
                      call ftuples(i_ftuple)%append (current_ftuple)
                   end if
                end if
             end do
          end do
       end associate
     end subroutine setup_flsts_emitters_and_ftuples_fsr
 
     subroutine setup_flsts_emitters_and_ftuples_isr &
            (i_real, i_born, i_ftuple, flst_alr, emitters, ftuples)
       integer, intent(in) :: i_real, i_born
       integer, intent(inout) :: i_ftuple
       type(flv_structure_t), intent(inout), dimension(:), allocatable :: flst_alr
       integer, intent(inout), dimension(:), allocatable :: emitters
       type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
       type(ftuple_list_t) :: ftuples_tmp
       type(flv_structure_t) :: flst_alr_tmp
       type(ftuple_t) :: current_ftuple
       integer :: leg, emitter
       logical :: valid1, valid2
       associate (flv_born => reg_data%flv_born(i_born), &
               flv_real => reg_data%flv_real(i_real))
          do leg = reg_data%n_in + 1, n_legreal
             valid1 = flv_real%valid_pair(1, leg, flv_born, model)
             if (reg_data%n_in > 1) then
                valid2 = flv_real%valid_pair(2, leg, flv_born, model)
             else
                valid2 = .false.
             end if
             if (valid1 .and. valid2) then
                emitter = 0
             else if (valid1 .and. .not. valid2) then
                emitter = 1
             else if (.not. valid1 .and. valid2) then
                emitter = 2
             else
                emitter = -1
             end if
             if (valid1 .or. valid2) then
                flst_alr_tmp = create_alr (flv_real, reg_data%n_in, emitter, leg)
                flst_alr = [flst_alr, flst_alr_tmp]
                emitters = [emitters, emitter]
                call current_ftuple%set(emitter, leg)
                call current_ftuple%determine_splitting_type_isr &
                     (flv_real, emitter, leg)
                i_ftuple = incr_i_ftuple_if_required (i_born, i_real, i_ftuple)
                if (i_ftuple > size (ftuples)) then
                   call ftuples_tmp%append (current_ftuple)
                   ftuples = [ftuples, ftuples_tmp]
                else
                   call ftuples(i_ftuple)%append (current_ftuple)
                end if
             end if
          end do
       end associate
     end subroutine setup_flsts_emitters_and_ftuples_isr
 
   end subroutine region_data_find_regions
 
 @ %def region_data_find_regions
 @ We transfer the mapping of flavor structures that lead to the same amplitude
 (with structure functions already accounted for!) to the Born and real
 [[flv_structure]] of each [[singular_region]].
 We then use this information, besides other data of each [[singular_region]],
 to determine which produce the same amplitude for the non-subtracted real
 and real subtraction terms and set up the equivalence index mapping for
 each region.
 <<fks regions: reg data: TBP>>=
   procedure :: find_eqv_regions => region_data_find_eqv_regions
 <<fks regions: procedures>>=
   subroutine region_data_find_eqv_regions (reg_data, optimize)
     class(region_data_t), intent(inout) :: reg_data
     logical, intent(in) :: optimize
     integer :: n_reg, alr1, alr2
     n_reg = reg_data%n_regions
     if (optimize) then
        do alr1 = 1, n_reg
           reg_data%regions(alr1)%flst_uborn%eqv_index = &
                reg_data%eqv_flv_index_born(reg_data%regions(alr1)%uborn_index)
           reg_data%regions(alr1)%flst_real%eqv_index = &
                reg_data%eqv_flv_index_real(reg_data%regions(alr1)%real_index)
        end do
        do alr1 = 1, n_reg
           do alr2 = 1, alr1
              if (reg_data%regions(alr2) .match. reg_data%regions(alr1)) then
                 reg_data%regions(alr1)%eqv_index = alr2
                 exit
              end if
           end do
        end do
     else
        do alr1 = 1, n_reg
           reg_data%regions(alr1)%eqv_index = alr1
        end do
     end if
   end subroutine region_data_find_eqv_regions
 
 @ %def region_data_find_eqv_regions
 @ Creates singular regions according to table \ref{table:singular
 regions}. It scans all regions in table \ref{table:ftuples and
 flavors} and records the real flavor structures. If they are
 equivalent, the flavor structure is not recorded, but the multiplicity
 of the present one is increased.
 <<fks regions: reg data: TBP>>=
   procedure :: init_singular_regions => region_data_init_singular_regions
 <<fks regions: procedures>>=
   subroutine region_data_init_singular_regions &
          (reg_data, ftuples, emitter, flv_alr, nlo_correction_type)
     class(region_data_t), intent(inout) :: reg_data
     type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
     type(string_t), intent(in) :: nlo_correction_type
     integer :: n_independent_flv
     integer, intent(in), dimension(:) :: emitter
     type(flv_structure_t), intent(in), dimension(:) :: flv_alr
     type(flv_structure_t), dimension(:), allocatable :: flv_uborn, flv_alr_registered
     integer, dimension(:), allocatable :: mult
     integer, dimension(:), allocatable :: flst_emitter
     integer :: n_regions, maxregions
     integer, dimension(:), allocatable :: index
     integer :: i, i_flv, n_legs
     logical :: equiv, valid_fs_splitting
     integer :: i_first, i_reg, i_reg_prev
     integer, dimension(:), allocatable :: region_to_ftuple, alr_limits
     integer, dimension(:), allocatable :: equiv_index
 
     maxregions = size (emitter)
     n_legs = flv_alr(1)%nlegs
 
     allocate (flv_uborn (maxregions))
     allocate (flv_alr_registered (maxregions))
     allocate (mult (maxregions))
     mult = 0
     allocate (flst_emitter (maxregions))
     allocate (index (0))
     allocate (region_to_ftuple (maxregions))
     allocate (equiv_index (maxregions))
 
     call setup_region_mappings (n_independent_flv, alr_limits, region_to_ftuple)
     i_first = 1
     i_reg = 1
     SCAN_FLAVORS: do i_flv = 1, n_independent_flv
        SCAN_FTUPLES: do i = i_first, i_first + alr_limits (i_flv) - 1
           equiv = .false.
           if (i == i_first) then
              flv_alr_registered(i_reg) = flv_alr(i)
              mult(i_reg) = mult(i_reg) + 1
              flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), nlo_correction_type)
              flst_emitter(i_reg) = emitter(i)
              index = [index, region_to_real_index(ftuples, i)]
              equiv_index(i_reg) = region_to_ftuple(i)
              i_reg  = i_reg + 1
           else
              !!! Check for equivalent flavor structures
              do i_reg_prev = 1, i_reg - 1
                 if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) > reg_data%n_in) then
                    valid_fs_splitting = check_fs_splitting (flv_alr(i)%get_last_two(n_legs), &
                           flv_alr_registered(i_reg_prev)%get_last_two(n_legs), &
                           flv_alr(i)%tag(n_legs - 1), flv_alr_registered(i_reg_prev)%tag(n_legs - 1))
                    if ((flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) &
                         .and. valid_fs_splitting) then
                       mult(i_reg_prev) = mult(i_reg_prev) + 1
                       equiv = .true.
                       call ftuples(region_to_real_index(ftuples, i))%set_equiv &
                            (equiv_index(i_reg_prev), region_to_ftuple(i))
                       exit
                    end if
                 else if (emitter(i) == flst_emitter(i_reg_prev) .and. emitter(i) <= reg_data%n_in) then
                    if (flv_alr(i) .equiv. flv_alr_registered(i_reg_prev)) then
                       mult(i_reg_prev) = mult(i_reg_prev) + 1
                       equiv = .true.
                       call ftuples(region_to_real_index(ftuples, i))%set_equiv &
                            (equiv_index(i_reg_prev), region_to_ftuple(i))
                       exit
                    end if
                 end if
              end do
              if (.not. equiv) then
                 flv_alr_registered(i_reg) = flv_alr(i)
                 mult(i_reg) = mult(i_reg) + 1
                 flv_uborn(i_reg) = flv_alr(i)%create_uborn (emitter(i), nlo_correction_type)
                 flst_emitter(i_reg) = emitter(i)
                 index = [index, region_to_real_index(ftuples, i)]
                 equiv_index (i_reg) = region_to_ftuple(i)
                 i_reg = i_reg + 1
              end if
           end if
        end do SCAN_FTUPLES
        i_first = i_first + alr_limits(i_flv)
     end do SCAN_FLAVORS
     n_regions = i_reg - 1
 
     allocate (reg_data%regions (n_regions))
     reg_data%n_regions = n_regions
     call account_for_regions_from_other_uborns (ftuples)
     call init_regions_with_permuted_flavors ()
     call assign_real_indices ()
 
     deallocate (flv_uborn)
     deallocate (flv_alr_registered)
     deallocate (mult)
     deallocate (flst_emitter)
     deallocate (index)
     deallocate (region_to_ftuple)
     deallocate (equiv_index)
 
   contains
 
     subroutine account_for_regions_from_other_uborns (ftuples)
       type(ftuple_list_t), intent(inout), dimension(:), allocatable :: ftuples
       integer :: alr1, alr2, i
       type(ftuple_t), dimension(:), allocatable :: ftuples_alr1, ftuples_alr2
       type(flavor_permutation_t) :: perm_list
       logical, dimension(:,:), allocatable :: equivalences
       do alr1 = 1, n_regions
          do alr2 = 1, n_regions
             if (index(alr1) == index(alr2)) cycle
             if (flv_alr_registered(alr1) .equiv. flv_alr_registered(alr2)) then
                call ftuples(index(alr1))%to_array (ftuples_alr1, equivalences, .false.)
                call ftuples(index(alr2))%to_array (ftuples_alr2, equivalences, .false.)
                do i = 1, size (ftuples_alr2)
                   if (.not. any (ftuple_equal_ireg (ftuples_alr1, ftuples_alr2(i)))) then
                      call ftuples(index(alr1))%append (ftuples_alr2(i))
                   end if
                end do
             end if
          end do
       end do
     end subroutine account_for_regions_from_other_uborns
 
     subroutine setup_region_mappings (n_independent_flv, &
            alr_limits, region_to_ftuple)
        integer, intent(inout) :: n_independent_flv
        integer, intent(inout), dimension(:), allocatable :: alr_limits
        integer, intent(inout), dimension(:), allocatable :: region_to_ftuple
        integer :: i, j, i_flv
        if (any (ftuples%get_n_tuples() == 0)) &
             call msg_fatal ("Inconsistent collection of FKS pairs!")
        n_independent_flv = size (ftuples)
        alr_limits = ftuples%get_n_tuples()
        if (.not. (sum (alr_limits) == maxregions)) &
             call msg_fatal ("Too many regions!")
        j = 1
        do i_flv = 1, n_independent_flv
           do i = 1, alr_limits(i_flv)
              region_to_ftuple(j) = i
              j = j + 1
           end do
        end do
     end subroutine setup_region_mappings
 
     subroutine check_permutation (perm, flv_perm, flv_orig, i_reg)
       type(flavor_permutation_t), intent(in) :: perm
       type(flv_structure_t), intent(in) :: flv_perm, flv_orig
       integer, intent(in) :: i_reg
       type(flv_structure_t) :: flv_test
       flv_test = perm%apply (flv_orig, invert = .true.)
       if (.not. all (flv_test%flst == flv_perm%flst)) then
          print *, 'Fail at: ', i_reg
          print *, 'Original flavor structure: ', flv_orig%flst
          call perm%write ()
          print *, 'Permuted flavor: ', flv_perm%flst
          print *, 'Should be: ', flv_test%flst
          call msg_fatal ("Permutation does not reproduce original flavor!")
       end if
     end subroutine check_permutation
 
     subroutine init_regions_with_permuted_flavors ()
        type(flavor_permutation_t) :: perm_list
        type(ftuple_t), dimension(:), allocatable :: ftuple_array
        logical, dimension(:,:), allocatable :: equivalences
        integer :: i, j
        do j = 1, n_regions
           do i = 1, reg_data%n_flv_born
              if (reg_data%flv_born (i) .equiv. flv_uborn (j)) then
                 call perm_list%reset ()
                 call perm_list%init (reg_data%flv_born(i), flv_uborn(j), &
                      reg_data%n_in, reg_data%n_legs_born, .true.)
                 flv_uborn(j) = perm_list%apply (flv_uborn(j))
                 flv_alr_registered(j) = perm_list%apply (flv_alr_registered(j))
                 flst_emitter(j) = perm_list%apply (flst_emitter(j))
              end if
           end do
           call ftuples(index(j))%to_array (ftuple_array, equivalences, .false.)
           do i = 1, size (reg_data%flv_real)
              if (reg_data%flv_real(i) .equiv. flv_alr_registered(j)) then
                 call perm_list%reset ()
                 call perm_list%init (flv_alr_registered(j), reg_data%flv_real(i), &
                      reg_data%n_in, reg_data%n_legs_real, .false.)
                 if (debug_active (D_SUBTRACTION)) call check_permutation &
                      (perm_list, reg_data%flv_real(i), flv_alr_registered(j), j)
                 ftuple_array = perm_list%apply (ftuple_array)
                 call ftuple_sort_array (ftuple_array, equivalences)
              end if
           end do
           call reg_data%regions(j)%init (j, mult(j), 0, flv_alr_registered(j), &
                flv_uborn(j), reg_data%flv_born, flst_emitter(j), ftuple_array, &
                equivalences, nlo_correction_type)
           if (allocated (ftuple_array)) deallocate (ftuple_array)
           if (allocated (equivalences)) deallocate (equivalences)
        end do
     end subroutine init_regions_with_permuted_flavors
 
     subroutine assign_real_indices ()
       type(flv_structure_t) :: current_flv_real
       type(flv_structure_t), dimension(:), allocatable :: these_flv
       integer :: i_real, current_uborn_index
       integer :: i, j, this_i_real
       allocate (these_flv (size (flv_alr_registered)))
       i_real = 1
       associate (regions => reg_data%regions)
          do i = 1, reg_data%n_regions
             do j = 1, size (these_flv)
                if (.not. allocated (these_flv(j)%flst)) then
                   this_i_real = i_real
                   call these_flv(i_real)%init (flv_alr_registered(i)%flst, reg_data%n_in)
                   i_real = i_real + 1
                   exit
                else if (all (these_flv(j)%flst == flv_alr_registered(i)%flst)) then
                   this_i_real = j
                   exit
                end if
             end do
             regions(i)%real_index = this_i_real
          end do
       end associate
       deallocate (these_flv)
     end subroutine assign_real_indices
 
     subroutine write_perm_list (perm_list)
       integer, intent(in), dimension(:,:) :: perm_list
       integer :: i
       do i = 1, size (perm_list(:,1))
          write (*,'(I1,1x,I1,A)', advance = "no" ) perm_list(i,1), perm_list(i,2), '/'
       end do
       print *, ''
     end subroutine write_perm_list
 
     function check_fs_splitting (flv1, flv2, tag1, tag2) result (valid)
       logical :: valid
       integer, intent(in), dimension(2) :: flv1, flv2
       integer, intent(in) :: tag1, tag2
       if (flv1(1) + flv1(2) == 0) then
          valid = abs(flv1(1)) == abs(flv2(1)) .and. abs(flv1(2)) == abs(flv2(2))
       else
          valid = flv1(1) == flv2(1) .and. flv1(2) == flv2(2) .and. tag1 == tag2
       end if
     end function check_fs_splitting
   end subroutine region_data_init_singular_regions
 
 @ %def region_data_init_singular_regions
 @ Create an array containing all emitters and resonances of [[region_data]].
 <<fks regions: reg data: TBP>>=
   procedure :: find_emitters => region_data_find_emitters
 <<fks regions: procedures>>=
   subroutine region_data_find_emitters (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr, j, n_em, em
     integer, dimension(:), allocatable :: em_count
     allocate (em_count(reg_data%n_regions))
     em_count = -1
     n_em = 0
 
     !!!Count the number of different emitters
     do alr = 1, reg_data%n_regions
        em = reg_data%regions(alr)%emitter
        if (.not. any (em_count == em)) then
           n_em = n_em + 1
           em_count(alr) = em
        end if
     end do
 
     if (n_em < 1) call msg_fatal ("region_data_find_emitters: No emitters found!")
     reg_data%n_emitters = n_em
     allocate (reg_data%emitters (reg_data%n_emitters))
     reg_data%emitters = -1
 
     j = 1
     do alr = 1, size (reg_data%regions)
        em = reg_data%regions(alr)%emitter
        if (.not. any (reg_data%emitters == em)) then
           reg_data%emitters(j) = em
           j = j + 1
        end if
     end do
   end subroutine region_data_find_emitters
 
 @ %def region_data_find_emitters
 @
 <<fks regions: reg data: TBP>>=
   procedure :: find_resonances => region_data_find_resonances
 <<fks regions: procedures>>=
   subroutine region_data_find_resonances (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr, j, k, n_res, n_contr
     integer :: res
     integer, dimension(10) :: res_count
     type(resonance_contributors_t), dimension(10) :: contributors_count
     type(resonance_contributors_t) :: contributors
     integer :: i_res, emitter
     logical :: share_emitter
     res_count = -1
     n_res = 0; n_contr = 0
 
     !!! Count the number of different resonances
     do alr = 1, reg_data%n_regions
        select type (fks_mapping => reg_data%fks_mapping)
        type is (fks_mapping_resonances_t)
           res = fks_mapping%res_map%alr_to_i_res (alr)
           if (.not. any (res_count == res)) then
              n_res = n_res + 1
              res_count(alr) = res
           end if
        end select
     end do
 
     if (n_res > 0) allocate (reg_data%resonances (n_res))
 
     j = 1
     select type (fks_mapping => reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        do alr = 1, size (reg_data%regions)
           res = fks_mapping%res_map%alr_to_i_res (alr)
           if (.not. any (reg_data%resonances == res)) then
              reg_data%resonances(j) = res
              j = j + 1
           end if
        end do
 
        allocate (reg_data%alr_to_i_contributor (size (reg_data%regions)))
        do alr = 1, size (reg_data%regions)
           i_res = fks_mapping%res_map%alr_to_i_res (alr)
           emitter = reg_data%regions(alr)%emitter
           call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
           if (.not. share_emitter) cycle
           if (.not. any (contributors_count == contributors)) then
              n_contr = n_contr + 1
              contributors_count(alr) = contributors
           end if
           if (allocated (contributors%c)) deallocate (contributors%c)
        end do
        allocate (reg_data%alr_contributors (n_contr))
        j = 1
        do alr = 1, size (reg_data%regions)
           i_res = fks_mapping%res_map%alr_to_i_res (alr)
           emitter = reg_data%regions(alr)%emitter
           call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
           if (.not. share_emitter) cycle
           if (.not. any (reg_data%alr_contributors == contributors)) then
              reg_data%alr_contributors(j) = contributors
              reg_data%alr_to_i_contributor (alr) = j
              j = j + 1
           else
              do k = 1, size (reg_data%alr_contributors)
                 if (reg_data%alr_contributors(k) == contributors) exit
              end do
              reg_data%alr_to_i_contributor (alr) = k
           end if
           if (allocated (contributors%c)) deallocate (contributors%c)
        end do
     end select
     call reg_data%extend_ftuples (n_res)
     call reg_data%set_contributors ()
 
   end subroutine region_data_find_resonances
 
 @ %def region_data_find_resonances
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_i_phs_to_i_con => region_data_set_i_phs_to_i_con
 <<fks regions: procedures>>=
   subroutine region_data_set_i_phs_to_i_con (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: alr
     integer :: i_res, emitter, i_con, i_phs, i_em
     type(phs_identifier_t), dimension(:), allocatable :: phs_id_tmp
     logical :: share_emitter, phs_exist
     type(resonance_contributors_t) :: contributors
     allocate (phs_id_tmp (reg_data%n_phs))
     if (allocated (reg_data%resonances)) then
        allocate (reg_data%i_phs_to_i_con (reg_data%n_phs))
        do i_em = 1, size (reg_data%emitters)
           emitter = reg_data%emitters(i_em)
           do i_res = 1, size (reg_data%resonances)
              if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then
                 alr = find_alr (emitter, i_res)
                 if (alr == 0) call msg_fatal ("Could not find requested alpha region!")
                 i_con = reg_data%alr_to_i_contributor (alr)
                 call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
                 if (.not. share_emitter) cycle
                 call check_for_phs_identifier &
                    (phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
                 if (phs_id_tmp(i_phs)%emitter < 0) then
                    phs_id_tmp(i_phs)%emitter = emitter
                    allocate (phs_id_tmp(i_phs)%contributors (size (contributors%c)))
                    phs_id_tmp(i_phs)%contributors = contributors%c
                 end if
                 reg_data%i_phs_to_i_con (i_phs) = i_con
              end if
              if (allocated (contributors%c)) deallocate (contributors%c)
           end do
        end do
     end if
   contains
     function find_alr (emitter, i_res) result (alr)
        integer :: alr
        integer, intent(in) :: emitter, i_res
        integer :: i
        do i = 1, reg_data%n_regions
           if (reg_data%regions(i)%emitter == emitter .and. &
               reg_data%regions(i)%i_res == i_res) then
              alr = i
              return
           end if
        end do
        alr = 0
     end function find_alr
   end subroutine region_data_set_i_phs_to_i_con
 
 @ %def region_data_set_i_phs_to_i_con
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_alr_to_i_phs => region_data_set_alr_to_i_phs
 <<fks regions: procedures>>=
   subroutine region_data_set_alr_to_i_phs (reg_data, phs_identifiers, alr_to_i_phs)
     class(region_data_t), intent(inout) :: reg_data
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     integer, intent(out), dimension(:) :: alr_to_i_phs
     integer :: alr, i_phs
     integer :: emitter, i_res
     type(resonance_contributors_t) :: contributors
     logical :: share_emitter, phs_exist
     do alr = 1, reg_data%n_regions
        associate (region => reg_data%regions(alr))
           emitter = region%emitter
           i_res = region%i_res
           if (i_res /= 0) then
              call reg_data%get_contributors (i_res, emitter, &
                 contributors%c, share_emitter)
              if (.not. share_emitter) cycle
           end if
           if (allocated (contributors%c)) then
              call check_for_phs_identifier (phs_identifiers, reg_data%n_in, &
                 emitter, contributors%c, phs_exist = phs_exist, i_phs = i_phs)
           else
              call check_for_phs_identifier (phs_identifiers, reg_data%n_in, &
                 emitter, phs_exist = phs_exist, i_phs = i_phs)
           end if
           if (.not. phs_exist) &
              call msg_fatal ("phs identifiers are not set up correctly!")
           alr_to_i_phs(alr) = i_phs
        end associate
        if (allocated (contributors%c)) deallocate (contributors%c)
     end do
   end subroutine region_data_set_alr_to_i_phs
 
 @ %def region_data_set_alr_to_i_phs
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_contributors => region_data_set_contributors
 <<fks regions: procedures>>=
   subroutine region_data_set_contributors (reg_data)
      class(region_data_t), intent(inout) :: reg_data
      integer :: alr, i_res, i_reg, i_con
      integer :: i1, i2, i_em
      integer, dimension(:), allocatable :: contributors
      logical :: share_emitter
      do alr = 1, size (reg_data%regions)
         associate (sregion => reg_data%regions(alr))
            allocate (sregion%i_reg_to_i_con (sregion%nregions))
            do i_reg = 1, sregion%nregions
               call sregion%ftuples(i_reg)%get (i1, i2)
               i_em = get_emitter_index (i1, i2, reg_data%n_legs_real)
               i_res = sregion%ftuples(i_reg)%i_res
               call reg_data%get_contributors (i_res, i_em, contributors, share_emitter)
               !!! Lookup contributor index
               do i_con = 1, size (reg_data%alr_contributors)
                  if (all (reg_data%alr_contributors(i_con)%c == contributors)) then
                     sregion%i_reg_to_i_con (i_reg) = i_con
                     exit
                  end if
               end do
               deallocate (contributors)
            end do
         end associate
      end do
   contains
      function get_emitter_index (i1, i2, n) result (i_em)
        integer :: i_em
        integer, intent(in) :: i1, i2, n
        if (i1 == n) then
           i_em = i2
        else
           i_em = i1
        end if
      end function get_emitter_index
   end subroutine region_data_set_contributors
 
 @ %def region_data_set_contributors
 @ This extension of the ftuples is still too naive as it assumes that the same
 resonances are possible for all ftuples
 <<fks regions: reg data: TBP>>=
   procedure :: extend_ftuples => region_data_extend_ftuples
 <<fks regions: procedures>>=
   subroutine region_data_extend_ftuples (reg_data, n_res)
     class(region_data_t), intent(inout) :: reg_data
     integer, intent(in) :: n_res
     integer :: alr, n_reg_save
     integer :: i_reg, i_res, i_em, k
     type(ftuple_t), dimension(:), allocatable :: ftuple_save
     integer :: n_new
     do alr = 1, size (reg_data%regions)
        associate (sregion => reg_data%regions(alr))
           n_reg_save = sregion%nregions
           allocate (ftuple_save (n_reg_save))
           ftuple_save = sregion%ftuples
           n_new = count_n_new_ftuples (sregion, n_res)
           deallocate (sregion%ftuples)
           sregion%nregions = n_new
           allocate (sregion%ftuples (n_new))
           k = 1
           do i_res = 1, n_res
              do i_reg = 1, n_reg_save
                 associate (ftuple_new => sregion%ftuples(k))
                    i_em = ftuple_save(i_reg)%ireg(1)
                    if (reg_data%emitter_is_in_resonance (i_res, i_em)) then
                       call ftuple_new%set (i_em, ftuple_save(i_reg)%ireg(2))
                       ftuple_new%i_res = i_res
                       ftuple_new%splitting_type = ftuple_save(i_reg)%splitting_type
                       k = k + 1
                    end if
                 end associate
              end do
           end do
        end associate
        deallocate (ftuple_save)
     end do
   contains
     function count_n_new_ftuples (sregion, n_res) result (n_new)
       integer :: n_new
       type(singular_region_t), intent(in) :: sregion
       integer, intent(in) :: n_res
       integer :: i_reg, i_res, i_em
       n_new = 0
       do i_reg = 1, sregion%nregions
          do i_res = 1, n_res
             i_em = sregion%ftuples(i_reg)%ireg(1)
             if (reg_data%emitter_is_in_resonance (i_res, i_em)) &
                n_new = n_new + 1
          end do
       end do
     end function count_n_new_ftuples
   end subroutine region_data_extend_ftuples
 
 @ %def region_data_extend_ftuples
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_flavor_indices => region_data_get_flavor_indices
 <<fks regions: procedures>>=
   function region_data_get_flavor_indices (reg_data, born) result (i_flv)
     integer, dimension(:), allocatable :: i_flv
     class(region_data_t), intent(in) :: reg_data
     logical, intent(in) :: born
     allocate (i_flv (reg_data%n_regions))
     if (born) then
        i_flv = reg_data%regions%uborn_index
     else
        i_flv = reg_data%regions%real_index
     end if
   end function region_data_get_flavor_indices
 
 @ %def region_data_get_flavor_indices
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_matrix_element_index => region_data_get_matrix_element_index
 <<fks regions: procedures>>=
   function region_data_get_matrix_element_index (reg_data, i_reg) result (i_me)
     integer :: i_me
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: i_reg
     i_me = reg_data%regions(i_reg)%real_index
   end function region_data_get_matrix_element_index
 
 @ %def region_data_get_matrix_element_index
 @
 <<fks regions: reg data: TBP>>=
   procedure :: compute_number_of_phase_spaces &
      => region_data_compute_number_of_phase_spaces
 <<fks regions: procedures>>=
   subroutine region_data_compute_number_of_phase_spaces (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     integer :: i_em, i_res, i_phs
     integer :: emitter
     type(resonance_contributors_t) :: contributors
     integer, parameter :: n_max_phs = 10
     type(phs_identifier_t), dimension(n_max_phs) :: phs_id_tmp
     logical :: share_emitter, phs_exist
     if (allocated (reg_data%resonances)) then
        reg_data%n_phs = 0
        do i_em = 1, size (reg_data%emitters)
           emitter = reg_data%emitters(i_em)
           do i_res = 1, size (reg_data%resonances)
              if (reg_data%emitter_is_compatible_with_resonance (i_res, emitter)) then
                 call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
                 if (.not. share_emitter) cycle
                 call check_for_phs_identifier &
                    (phs_id_tmp, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
                 if (.not. phs_exist) then
                    reg_data%n_phs = reg_data%n_phs + 1
                    if (reg_data%n_phs > n_max_phs) call msg_fatal &
                       ("Buffer of phase space identifieres: Too much phase spaces!")
                    call phs_id_tmp(i_phs)%init (emitter, contributors%c)
                 end if
              end if
              if (allocated (contributors%c)) deallocate (contributors%c)
           end do
        end do
     else
        reg_data%n_phs = size (remove_duplicates_from_int_array (reg_data%emitters))
     end if
   end subroutine region_data_compute_number_of_phase_spaces
 
 @ %def region_data_compute_number_of_phase_spaces
 @
 <<fks regions: reg data: TBP>>=
   procedure :: get_n_phs => region_data_get_n_phs
 <<fks regions: procedures>>=
   function region_data_get_n_phs (reg_data) result (n_phs)
     integer :: n_phs
     class(region_data_t), intent(in) :: reg_data
     n_phs = reg_data%n_phs
   end function region_data_get_n_phs
 
 @ %def region_data_get_n_phs
 @
 <<fks regions: reg data: TBP>>=
   procedure :: set_splitting_info => region_data_set_splitting_info
 <<fks regions: procedures>>=
   subroutine region_data_set_splitting_info (reg_data)
      class(region_data_t), intent(inout) :: reg_data
      integer :: alr
      do alr = 1, reg_data%n_regions
         call reg_data%regions(alr)%set_splitting_info (reg_data%n_in)
      end do
    end subroutine region_data_set_splitting_info
 
 @ %def region_data_set_splitting_info
 @
 <<fks regions: reg data: TBP>>=
   procedure :: init_phs_identifiers => region_data_init_phs_identifiers
 <<fks regions: procedures>>=
   subroutine region_data_init_phs_identifiers (reg_data, phs_id)
     class(region_data_t), intent(in) :: reg_data
     type(phs_identifier_t), intent(out), dimension(:), allocatable :: phs_id
     integer :: i_em, i_res, i_phs
     integer :: emitter
     type(resonance_contributors_t) :: contributors
     logical :: share_emitter, phs_exist
     allocate (phs_id (reg_data%n_phs))
     do i_em = 1, size (reg_data%emitters)
        emitter = reg_data%emitters(i_em)
        if (allocated (reg_data%resonances)) then
           do i_res = 1, size (reg_data%resonances)
              call reg_data%get_contributors (i_res, emitter, contributors%c, share_emitter)
              if (.not. share_emitter) cycle
              call check_for_phs_identifier &
                 (phs_id, reg_data%n_in, emitter, contributors%c, phs_exist, i_phs)
              if (.not. phs_exist) &
                 call phs_id(i_phs)%init (emitter, contributors%c)
              if (allocated (contributors%c)) deallocate (contributors%c)
           end do
        else
           call check_for_phs_identifier (phs_id, reg_data%n_in, emitter, &
              phs_exist = phs_exist, i_phs = i_phs)
           if (.not. phs_exist) call phs_id(i_phs)%init (emitter)
        end if
     end do
   end subroutine region_data_init_phs_identifiers
 
 @ %def region_data_init_phs_identifiers
-@
+@ Gathers all ftuples from all ALRs.
+There are at most $n \cdot (n-1)$ ftuples with $i$ and $j$ in the final state
+and up to $3n$ ftuples with $i$ in the initial state.
 <<fks regions: reg data: TBP>>=
   procedure :: get_all_ftuples => region_data_get_all_ftuples
 <<fks regions: procedures>>=
   subroutine region_data_get_all_ftuples (reg_data, ftuples)
     class(region_data_t), intent(in) :: reg_data
     type(ftuple_t), intent(inout), dimension(:), allocatable :: ftuples
     type(ftuple_t), dimension(:), allocatable :: ftuple_tmp
-    integer :: i, j, alr
-    !!! Can have at most n * (n-1) ftuples
+    integer :: i, j, alr, n_fs
     j = 0
-    allocate (ftuple_tmp (reg_data%n_legs_real * (reg_data%n_legs_real - 1)))
+    n_fs = reg_data%n_legs_real - reg_data%n_in
+    allocate (ftuple_tmp (n_fs * (n_fs - 1) + 3 * n_fs))
     do i = 1, reg_data%n_regions
        associate (region => reg_data%regions(i))
           do alr = 1, region%nregions
-             if (.not. any (region%ftuples(alr) == ftuple_tmp)) then
+             if (.not. any (ftuple_equal_ireg (region%ftuples(alr), ftuple_tmp))) then
                 j = j + 1
                 ftuple_tmp(j) = region%ftuples(alr)
              end if
           end do
        end associate
     end do
     allocate (ftuples (j))
     ftuples = ftuple_tmp(1:j)
     deallocate (ftuple_tmp)
   end subroutine region_data_get_all_ftuples
 
 @ %def region_data_get_all_ftuples
 @
 <<fks regions: reg data: TBP>>=
   procedure :: write_to_file => region_data_write_to_file
 <<fks regions: procedures>>=
   subroutine region_data_write_to_file (reg_data, proc_id, latex, os_data)
      class(region_data_t), intent(inout) :: reg_data
      type(string_t), intent(in) :: proc_id
      logical, intent(in) :: latex
      type(os_data_t), intent(in) :: os_data
      type(string_t) :: filename
      integer :: u
      integer :: status
 
      if (latex) then
          filename = proc_id // "_fks_regions.tex"
      else
         filename = proc_id // "_fks_regions.out"
      end if
      u = free_unit ()
      open (u, file=char(filename), action = "write", status="replace")
      if (latex) then
         call reg_data%write_latex (u)
         close (u)
         call os_data%build_latex_file &
              (proc_id // "_fks_regions", stat_out = status)
         if (status /= 0) &
              call msg_error (char ("Failed to compile " // filename))
      else
         call reg_data%write (u)
         close (u)
      end if
   end subroutine region_data_write_to_file
 
 @ %def region_data_write_to_file
 @
 <<fks regions: reg data: TBP>>=
   procedure :: write_latex => region_data_write_latex
 <<fks regions: procedures>>=
   subroutine region_data_write_latex (reg_data, unit)
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in), optional :: unit
     integer :: i, u
     u = given_output_unit (); if (present (unit)) u = unit
     write (u, "(A)") "\documentclass{article}"
     write (u, "(A)") "\begin{document}"
     write (u, "(A)") "%FKS region data, automatically created by WHIZARD"
     write (u, "(A)") "\begin{table}"
     write (u, "(A)") "\begin{center}"
     write (u, "(A)") "\begin{tabular} {|c|c|c|c|c|c|c|c|}"
     write (u, "(A)") "\hline"
     write (u, "(A)") "$\alpha_r$ & $f_r$ & $i_r$ & $\varepsilon$ & $\varsigma$ & $\mathcal{P}_{\rm{FKS}}$ & $i_b$ & $f_b$ \\"
     write (u, "(A)") "\hline"
     do i = 1, reg_data%n_regions
        call reg_data%regions(i)%write_latex (u)
     end do
     write (u, "(A)") "\hline"
     write (u, "(A)") "\end{tabular}"
     write (u, "(A)") "\caption{List of singular regions}"
     write (u, "(A)") "\begin{description}"
     write (u, "(A)") "\item[$\alpha_r$] Index of the singular region"
     write (u, "(A)") "\item[$f_r$] Real flavor structure"
     write (u, "(A)") "\item[$i_r$] Index of the associated real flavor structure"
     write (u, "(A)") "\item[$\varepsilon$] Emitter"
     write (u, "(A)") "\item[$\varsigma$] Multiplicity" !!! The symbol used by 0908.4272 for multiplicities
     write (u, "(A)") "\item[$\mathcal{P}_{\rm{FKS}}$] The set of singular FKS-pairs"
     write (u, "(A)") "\item[$i_b$] Underlying Born index"
     write (u, "(A)") "\item[$f_b$] Underlying Born flavor structure"
     write (u, "(A)") "\end{description}"
     write (u, "(A)") "\end{center}"
     write (u, "(A)") "\end{table}"
     write (u, "(A)") "\end{document}"
   end subroutine region_data_write_latex
 
 @ %def region_data_write_latex
 @ Creates a table with information about all singular regions and
 writes it to a file.
 <<fks regions: reg data: TBP>>=
   procedure :: write => region_data_write
 <<fks regions: procedures>>=
   subroutine region_data_write (reg_data, unit)
      class(region_data_t), intent(in) :: reg_data
      integer, intent(in), optional :: unit
      integer :: j
      integer :: maxnregions, i_reg_max
      type(string_t) :: flst_title, ftuple_title
      integer :: n_res, u
      u = given_output_unit (unit); if (u < 0) return
      maxnregions = 1; i_reg_max = 1
      do j = 1, reg_data%n_regions
         if (size (reg_data%regions(j)%ftuples) > maxnregions) then
            maxnregions = reg_data%regions(j)%nregions
            i_reg_max = j
         end if
      end do
      flst_title = '(A' // flst_title_format(reg_data%n_legs_real) // ')'
      ftuple_title = '(A' // ftuple_title_format() // ')'
      write (u,'(A,1X,I4)') 'Total number of regions: ', size(reg_data%regions)
      write (u, '(A4)', advance = 'no') ' alr'
      call write_vline (u)
      write (u, char (flst_title), advance = 'no') 'flst_real'
      call write_vline (u)
      write (u, '(A6)', advance = 'no') 'i_real'
      call write_vline (u)
      write (u, '(A3)', advance = 'no') 'em'
      call write_vline (u)
      write (u, '(A3)', advance = 'no') 'mult'
      call write_vline (u)
      write (u, '(A4)', advance = 'no') 'nreg'
      call write_vline (u)
      if (allocated (reg_data%fks_mapping)) then
         select type (fks_mapping => reg_data%fks_mapping)
         type is (fks_mapping_resonances_t)
            write (u, '(A3)', advance = 'no') 'res'
            call write_vline (u)
         end select
      end if
      write (u, char (ftuple_title), advance = 'no') 'ftuples'
      call write_vline (u)
      flst_title = '(A' // flst_title_format(reg_data%n_legs_born) // ')'
      write (u, char (flst_title), advance = 'no') 'flst_born'
      call write_vline (u)
      write (u, '(A7)') 'i_born'
      do j = 1, reg_data%n_regions
         write (u, '(I4)', advance = 'no') j
         call reg_data%regions(j)%write (u, maxnregions)
      end do
      call write_separator (u)
      if (allocated (reg_data%fks_mapping)) then
         select type (fks_mapping => reg_data%fks_mapping)
         type is (fks_mapping_resonances_t)
            write (u, '(A)')
            write (u, '(A)') "The FKS regions are combined with resonance information: "
            n_res = size (fks_mapping%res_map%res_histories)
            write (u, '(A,1X,I1)') "Number of QCD resonance histories: ", n_res
            do j = 1, n_res
               write (u, '(A,1X,I1)') "i_res = ", j
               call fks_mapping%res_map%res_histories(j)%write (u)
               call write_separator (u)
            end do
         end select
      end if
 
    contains
 
      function flst_title_format (n) result (frmt)
        integer, intent(in) :: n
        type(string_t) :: frmt
        character(len=2) :: frmt_char
        write (frmt_char, '(I2)') 4 * n + 1
        frmt = var_str (frmt_char)
      end function flst_title_format
 
     function ftuple_title_format () result (frmt)
        type(string_t) :: frmt
        integer :: n_ftuple_char
        !!! An ftuple (x,x) consists of five characters. In the string, they
        !!! are separated by maxregions - 1 commas. In total these are
        !!! 5 * maxnregions + maxnregions - 1 = 6 * maxnregions - 1 characters.
        !!! The {} brackets at add two additional characters.
        n_ftuple_char = 6 * maxnregions + 1
        !!! If there are resonances, each ftuple with a resonance adds a ";x"
        !!! to the ftuple
        n_ftuple_char = n_ftuple_char + 2 * count (reg_data%regions(i_reg_max)%ftuples%i_res > 0)
        !!! Pseudo-ISR regions are denoted with a * at the end
        n_ftuple_char = n_ftuple_char + count (reg_data%regions(i_reg_max)%ftuples%pseudo_isr)
        frmt = str (n_ftuple_char)
     end function ftuple_title_format
 
   end subroutine region_data_write
 
 @ %def region_data_write
 @
 <<fks regions: procedures>>=
   subroutine write_vline (u)
     integer, intent(in) :: u
     character(len=10), parameter :: sep_format = "(1X,A2,1X)"
     write (u, sep_format, advance = 'no') '||'
   end subroutine write_vline
 
 @ %def write_vline
 @
 <<fks regions: public>>=
   public :: assignment(=)
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure region_data_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine region_data_assign (reg_data_out, reg_data_in)
     type(region_data_t), intent(out) :: reg_data_out
     type(region_data_t), intent(in) :: reg_data_in
     integer :: i
     if (allocated (reg_data_in%regions)) then
        allocate (reg_data_out%regions (size (reg_data_in%regions)))
        do i = 1, size (reg_data_in%regions)
           reg_data_out%regions(i) = reg_data_in%regions(i)
        end do
     else
        call msg_warning ("Copying region data without allocated singular regions!")
     end if
     if (allocated (reg_data_in%flv_born)) then
        allocate (reg_data_out%flv_born (size (reg_data_in%flv_born)))
        do i = 1, size (reg_data_in%flv_born)
           reg_data_out%flv_born(i) = reg_data_in%flv_born(i)
        end do
     else
        call msg_warning ("Copying region data without allocated born flavor structure!")
     end if
     if (allocated (reg_data_in%flv_real)) then
        allocate (reg_data_out%flv_real (size (reg_data_in%flv_real)))
        do i = 1, size (reg_data_in%flv_real)
           reg_data_out%flv_real(i) = reg_data_in%flv_real(i)
        end do
     else
        call msg_warning ("Copying region data without allocated real flavor structure!")
     end if
     if (allocated (reg_data_in%emitters)) then
        allocate (reg_data_out%emitters (size (reg_data_in%emitters)))
        do i = 1, size (reg_data_in%emitters)
           reg_data_out%emitters(i) = reg_data_in%emitters(i)
        end do
     else
        call msg_warning ("Copying region data without allocated emitters!")
     end if
     reg_data_out%n_regions = reg_data_in%n_regions
     reg_data_out%n_emitters = reg_data_in%n_emitters
     reg_data_out%n_flv_born = reg_data_in%n_flv_born
     reg_data_out%n_flv_real = reg_data_in%n_flv_real
     reg_data_out%n_in = reg_data_in%n_in
     reg_data_out%n_legs_born = reg_data_in%n_legs_born
     reg_data_out%n_legs_real = reg_data_in%n_legs_real
     if (allocated (reg_data_in%fks_mapping)) then
        select type (fks_mapping_in => reg_data_in%fks_mapping)
        type is (fks_mapping_default_t)
           allocate (fks_mapping_default_t :: reg_data_out%fks_mapping)
           select type (fks_mapping_out => reg_data_out%fks_mapping)
           type is (fks_mapping_default_t)
              fks_mapping_out = fks_mapping_in
           end select
        type is (fks_mapping_resonances_t)
           allocate (fks_mapping_resonances_t :: reg_data_out%fks_mapping)
           select type (fks_mapping_out => reg_data_out%fks_mapping)
           type is (fks_mapping_resonances_t)
              fks_mapping_out = fks_mapping_in
           end select
        end select
     else
        call msg_warning ("Copying region data without allocated FKS regions!")
     end if
     if (allocated (reg_data_in%resonances)) then
        allocate (reg_data_out%resonances (size (reg_data_in%resonances)))
        reg_data_out%resonances = reg_data_in%resonances
     end if
     reg_data_out%n_phs = reg_data_in%n_phs
     if (allocated (reg_data_in%alr_contributors)) then
        allocate (reg_data_out%alr_contributors (size (reg_data_in%alr_contributors)))
        reg_data_out%alr_contributors = reg_data_in%alr_contributors
     end if
     if (allocated (reg_data_in%alr_to_i_contributor)) then
        allocate (reg_data_out%alr_to_i_contributor &
           (size (reg_data_in%alr_to_i_contributor)))
        reg_data_out%alr_to_i_contributor = reg_data_in%alr_to_i_contributor
     end if
   end subroutine region_data_assign
 
 @ %def region_data_assign
 @ Returns the index of the real flavor structure an ftuple belogs to.
 <<fks regions: procedures>>=
   function region_to_real_index (list, i) result(index)
     type(ftuple_list_t), intent(in), dimension(:), allocatable :: list
     integer, intent(in) :: i
     integer, dimension(:), allocatable :: nreg
     integer :: index, j
     allocate (nreg (0))
     index = 0
     do j = 1, size (list)
        nreg = [nreg, sum (list(:j)%get_n_tuples ())]
        if (j == 1) then
           if (i <= nreg(j)) then
              index = j
              exit
           end if
        else
           if (i > nreg(j - 1) .and. i <= nreg(j)) then
              index = j
              exit
           end if
        end if
     end do
   end function region_to_real_index
 
 @ %def region_to_real_index
 @ Final state emission: Rearrange the flavor array in such a way that
 the emitted particle is last and the emitter is second last. [[i1]] is
 the index of the emitter, [[i2]] is the index of the emitted particle.
 
 Initial state emission: Just put the emitted particle to the last
 position.
 <<fks regions: procedures>>=
   function create_alr (flv1, n_in, i_em, i_rad) result(flv2)
     type(flv_structure_t), intent(in) :: flv1
     integer, intent(in) :: n_in
     integer, intent(in) :: i_em, i_rad
     type(flv_structure_t) :: flv2
     integer :: n
     n = size (flv1%flst)
     allocate (flv2%flst (n), flv2%tag (n))
     flv2%nlegs = n
     flv2%n_in = n_in
     if (i_em > n_in) then
        flv2%flst(1 : n_in) = flv1%flst(1 : n_in)
        flv2%flst(n - 1) = flv1%flst(i_em)
        flv2%flst(n) = flv1%flst(i_rad)
        flv2%tag(1 : n_in) = flv1%tag(1 : n_in)
        flv2%tag(n - 1) = flv1%tag(i_em)
        flv2%tag(n) = flv1%tag(i_rad)
        call fill_remaining_flavors (n_in, .true.)
     else
        flv2%flst(1 : n_in) = flv1%flst(1 : n_in)
        flv2%flst(n) = flv1%flst(i_rad)
        flv2%tag(1 : n_in) = flv1%tag(1 : n_in)
        flv2%tag(n) = flv1%tag(i_rad)
        call fill_remaining_flavors (n_in, .false.)
     end if
     call flv2%compute_prt_symm_fs (flv2%n_in)
   contains
 @ Order remaining particles according to their original position
 <<fks regions: procedures>>=
     subroutine fill_remaining_flavors (n_in, final_final)
       integer, intent(in) :: n_in
       logical, intent(in) :: final_final
       integer :: i, j
       logical :: check
       j = n_in + 1
       do i = n_in + 1, n
          if (final_final) then
             check = (i /= i_em .and. i /= i_rad)
          else
             check = (i /= i_rad)
          end if
          if (check) then
             flv2%flst(j) = flv1%flst(i)
             flv2%tag(j) = flv1%tag(i)
             j = j + 1
          end if
       end do
     end subroutine fill_remaining_flavors
   end function create_alr
 
 @ %def create_alr
 @
 <<fks regions: reg data: TBP>>=
   procedure :: has_pseudo_isr => region_data_has_pseudo_isr
 <<fks regions: procedures>>=
   function region_data_has_pseudo_isr (reg_data) result (val)
     logical :: val
     class(region_data_t), intent(in) :: reg_data
     val = any (reg_data%regions%pseudo_isr)
   end function region_data_has_pseudo_isr
 
 @ %def region_data_has_pseudo_isr
 @ Performs consistency checks on [[region_data]]. Up to now only
 checks that no [[ftuple]] appears more than once.
 <<fks regions: reg data: TBP>>=
   procedure :: check_consistency => region_data_check_consistency
 <<fks regions: procedures>>=
   subroutine region_data_check_consistency (reg_data, fail_fatal, unit)
     class(region_data_t), intent(in) :: reg_data
     logical, intent(in) :: fail_fatal
     integer, intent(in), optional :: unit
     integer :: u
     integer :: i_reg, alr
     integer :: i1, f1, f2
     logical :: undefined_ftuples, same_ftuple_indices, valid_splitting
     logical, dimension(4) :: no_fail
     u = given_output_unit(unit); if (u < 0) return
     no_fail = .true.
     call msg_message ("Check that no negative ftuple indices occur", unit = u)
     do i_reg = 1, reg_data%n_regions
        if (any (reg_data%regions(i_reg)%ftuples%has_negative_elements ())) then
           !!! This error is so severe that we stop immediately
           call msg_fatal ("Negative ftuple indices!")
        end if
     end do
     call msg_message ("Success!", unit = u)
     call msg_message ("Check that there is no ftuple with identical elements", unit = u)
     do i_reg = 1, reg_data%n_regions
        if (any (reg_data%regions(i_reg)%ftuples%has_identical_elements ())) then
           !!! This error is so severe that we stop immediately
           call msg_fatal ("Identical ftuple indices!")
        end if
     end do
     call msg_message ("Success!", unit = u)
     call msg_message ("Check that there are no duplicate ftuples in a region", unit = u)
     do i_reg = 1, reg_data%n_regions
        if (reg_data%regions(i_reg)%has_identical_ftuples ()) then
           if (no_fail(1)) then
              call msg_error ("FAIL: ", unit = u)
              no_fail(1) = .false.
           end if
           write (u, '(A,1x,I3)') 'i_reg:', i_reg
        end if
     end do
     if (no_fail(1)) call msg_message ("Success!", unit = u)
     call msg_message ("Check that ftuples add up to a valid splitting", unit = u)
     do i_reg = 1, reg_data%n_regions
        do alr = 1, reg_data%regions(i_reg)%nregions
           associate (region => reg_data%regions(i_reg))
              i1 = region%ftuples(alr)%ireg(1)
              if (i1 == 0) i1 = 1 !!! Gluon emission from both initial-state particles
              f1 = region%flst_real%flst(i1)
              f2 = region%flst_real%flst(region%ftuples(alr)%ireg(2))
              ! Flip PDG sign of IS fermions to allow a q -> g q splitting
              ! in which the ftuple has the flavors (q,q).
              if (i1 <= reg_data%n_in .and. is_fermion(f1)) then
                 f1 = -f1
              end if
              valid_splitting = f1 + f2 == 0 &
                   .or. (is_gluon(f1) .and. is_gluon(f2)) &
                   .or. (is_massive_vector(f1) .and. is_photon(f2)) &
                   .or. is_fermion_vector_splitting (f1, f2)
              if (.not. valid_splitting) then
                 if (no_fail(2)) then
                    call msg_error ("FAIL: ", unit = u)
                    no_fail(2) = .false.
                 end if
                 write (u, '(A,1x,I3)') 'i_reg:', i_reg
                 exit
              end if
           end associate
        end do
     end do
     if (no_fail(2)) call msg_message ("Success!", unit = u)
     call msg_message ("Check that at least one ftuple contains the emitter", unit = u)
     do i_reg = 1, reg_data%n_regions
        associate (region => reg_data%regions(i_reg))
           if (.not. any (region%emitter == region%ftuples%ireg(1))) then
              if (no_fail(3)) then
                 call msg_error ("FAIL: ", unit = u)
                 no_fail(3) = .false.
              end if
              write (u, '(A,1x,I3)') 'i_reg:', i_reg
           end if
        end associate
     end do
     if (no_fail(3)) call msg_message ("Success!", unit = u)
     call msg_message ("Check that each region has at least one ftuple &
          &with index n + 1", unit = u)
     do i_reg = 1, reg_data%n_regions
        if (.not. any (reg_data%regions(i_reg)%ftuples%ireg(2) == reg_data%n_legs_real)) then
           if (no_fail(4)) then
              call msg_error ("FAIL: ", unit = u)
              no_fail(4) = .false.
           end if
           write (u, '(A,1x,I3)') 'i_reg:', i_reg
        end if
     end do
     if (no_fail(4)) call msg_message ("Success!", unit = u)
     if (.not. all (no_fail)) &
          call abort_with_message ("Stop due to inconsistent region data!")
 
   contains
     subroutine abort_with_message (msg)
       character(len=*), intent(in) :: msg
       if (fail_fatal) then
          call msg_fatal (msg)
       else
          call msg_error (msg, unit = u)
       end if
     end subroutine abort_with_message
 
     function is_fermion_vector_splitting (pdg_1, pdg_2) result (value)
       logical :: value
       integer, intent(in) :: pdg_1, pdg_2
       value = (is_fermion (pdg_1) .and. is_massless_vector (pdg_2)) .or. &
            (is_fermion (pdg_2) .and. is_massless_vector (pdg_1))
     end function
   end subroutine region_data_check_consistency
 
 @ %def region_data_check_consistency
 @
 <<fks regions: reg data: TBP>>=
   procedure :: requires_spin_correlations => region_data_requires_spin_correlations
 <<fks regions: procedures>>=
   function region_data_requires_spin_correlations (reg_data) result (val)
     class(region_data_t), intent(in) :: reg_data
     logical :: val
     integer :: alr
     val = .false.
     do alr = 1, reg_data%n_regions
        val = reg_data%regions(alr)%sc_required
        if (val) return
     end do
   end function region_data_requires_spin_correlations
 
 @ %def region_data_requires_spin_correlations
 @ We have to apply the symmetry factor for identical particles of the
 real flavor structure to the born squared matrix element. The corresponding
 factor from the born flavor structure has to be cancelled.
 <<fks regions: reg data: TBP>>=
   procedure :: born_to_real_symm_factor_fs => region_data_born_to_real_symm_factor_fs
 <<fks regions: procedures>>=
   function region_data_born_to_real_symm_factor_fs (reg_data, alr) result (factor)
     class(region_data_t), intent(in) :: reg_data
     integer, intent(in) :: alr
     real(default) :: factor
     associate (flv_real => reg_data%regions(alr)%flst_real, &
             flv_uborn => reg_data%regions(alr)%flst_uborn)
        factor = flv_real%prt_symm_fs / flv_uborn%prt_symm_fs
     end associate
   end function region_data_born_to_real_symm_factor_fs
 
 @ %def region_data_born_to_real_symm_factor_fs
 @
 <<fks regions: reg data: TBP>>=
   procedure :: final => region_data_final
 <<fks regions: procedures>>=
   subroutine region_data_final (reg_data)
     class(region_data_t), intent(inout) :: reg_data
     if (allocated (reg_data%regions)) deallocate (reg_data%regions)
     if (allocated (reg_data%flv_born)) deallocate (reg_data%flv_born)
     if (allocated (reg_data%flv_real)) deallocate (reg_data%flv_real)
     if (allocated (reg_data%emitters)) deallocate (reg_data%emitters)
     if (allocated (reg_data%fks_mapping)) deallocate (reg_data%fks_mapping)
     if (allocated (reg_data%resonances)) deallocate (reg_data%resonances)
     if (allocated (reg_data%alr_contributors)) deallocate (reg_data%alr_contributors)
     if (allocated (reg_data%alr_to_i_contributor)) deallocate (reg_data%alr_to_i_contributor)
   end subroutine region_data_final
 
 @ %def region_data_final
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_dij), deferred :: dij
 <<fks regions: interfaces>>=
   abstract interface
     function fks_mapping_dij (map, p, i, j, i_con) result (d)
       import
       real(default) :: d
       class(fks_mapping_t), intent(in) :: map
       type(vector4_t), intent(in), dimension(:) :: p
       integer, intent(in) :: i, j
       integer, intent(in), optional :: i_con
     end function fks_mapping_dij
   end interface
 
 @ %def fks_mapping_dij
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_compute_sumdij), deferred :: compute_sumdij
 <<fks regions: interfaces>>=
   abstract interface
     subroutine fks_mapping_compute_sumdij (map, sregion, p_real)
       import
       class(fks_mapping_t), intent(inout) :: map
       type(singular_region_t), intent(in) :: sregion
       type(vector4_t), intent(in), dimension(:) :: p_real
     end subroutine fks_mapping_compute_sumdij
   end interface
 
 @ %def fks_mapping_compute_sumdij
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_svalue), deferred :: svalue
 <<fks regions: interfaces>>=
   abstract interface
     function fks_mapping_svalue (map, p, i, j, i_res) result (value)
       import
       real(default) :: value
       class(fks_mapping_t), intent(in) :: map
       type(vector4_t), intent(in), dimension(:) :: p
       integer, intent(in) :: i, j
       integer, intent(in), optional :: i_res
     end function fks_mapping_svalue
   end interface
 
 @ %def fks_mapping_svalue
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_dij_soft), deferred :: dij_soft
 <<fks regions: interfaces>>=
   abstract interface
     function fks_mapping_dij_soft (map, p_born, p_soft, em, i_con) result (d)
       import
       real(default) :: d
       class(fks_mapping_t), intent(in) :: map
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(in) :: p_soft
       integer, intent(in) :: em
       integer, intent(in), optional :: i_con
     end function fks_mapping_dij_soft
   end interface
 
 @ %def fks_mapping_dij_soft
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_compute_sumdij_soft), deferred :: compute_sumdij_soft
 <<fks regions: interfaces>>=
   abstract interface
     subroutine fks_mapping_compute_sumdij_soft (map, sregion, p_born, p_soft)
       import
       class(fks_mapping_t), intent(inout) :: map
       type(singular_region_t), intent(in) :: sregion
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(in) :: p_soft
     end subroutine fks_mapping_compute_sumdij_soft
   end interface
 @ %def fks_mapping_compute_sumdij_soft
 @
 <<fks regions: fks mapping: TBP>>=
   procedure (fks_mapping_svalue_soft), deferred :: svalue_soft
 <<fks regions: interfaces>>=
   abstract interface
     function fks_mapping_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
       import
       real(default) :: value
       class(fks_mapping_t), intent(in) :: map
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(in) :: p_soft
       integer, intent(in) :: em
       integer, intent(in), optional :: i_res
     end function fks_mapping_svalue_soft
   end interface
 
 @ %def fks_mapping_svalue_soft
 @
 <<fks regions: fks mapping default: TBP>>=
   procedure :: set_parameter => fks_mapping_default_set_parameter
 <<fks regions: procedures>>=
   subroutine fks_mapping_default_set_parameter (map, n_in, dij_exp1, dij_exp2)
     class(fks_mapping_default_t), intent(inout) :: map
     integer, intent(in) :: n_in
     real(default), intent(in) :: dij_exp1, dij_exp2
     map%n_in = n_in
     map%exp_1 = dij_exp1
     map%exp_2 = dij_exp2
   end subroutine fks_mapping_default_set_parameter
 
 @ %def fks_mapping_default_set_parameter
 @ Computes the $d_{ij}$-quantities defined als follows:
 \begin{align*}
   d_{0i} &= \left[E_i^2\left(1-y_i\right)\right]^{p_2}\\,
   d_{1i} &= \left[2E_i^2\left(1-y_i\right)\right]^{p_2}\\,
   d_{2i} &= \left[2E_i^2\left(1+y_i\right)\right]^{p_2}\\,
 \end{align*}
 for initial state regions and
 \begin{align*}
   d_{ij} = \left[2(k_i \cdot k_j) \frac{E_i E_j}{(E_i+E_j)^2}\right]^{p_1}
 \end{align*}
 for final state regions, c.f. [1002.2581, Eq. 4.23f].
 The exponents $p_1$ and $p_2$ can be used for
 tuning the efficiency of the mapping and are set to $1$ per default.
 <<fks regions: fks mapping default: TBP>>=
   procedure :: dij => fks_mapping_default_dij
 <<fks regions: procedures>>=
   function fks_mapping_default_dij (map, p, i, j, i_con) result (d)
     real(default) :: d
     class(fks_mapping_default_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: i, j
     integer, intent(in), optional :: i_con
     d = zero
     if (map%pseudo_isr) then
        d = dij_threshold_gluon_from_top (i, j, p, map%exp_1)
     else if (i > map%n_in .and. j > map%n_in) then
        d = dij_fsr (p(i), p(j), map%exp_1)
     else
        d = dij_isr (map%n_in, i, j, p, map%exp_2)
     end if
   contains
 
     function dij_fsr (p1, p2, expo) result (d_ij)
       real(default) :: d_ij
       type(vector4_t), intent(in) :: p1, p2
       real(default), intent(in) :: expo
       real(default) :: E1, E2
       E1 = p1%p(0); E2 = p2%p(0)
       d_ij = (two * p1 * p2 * E1 * E2 / (E1 + E2)**2)**expo
     end function dij_fsr
 
     function dij_threshold_gluon_from_top (i, j, p, expo) result (d_ij)
       real(default) :: d_ij
       integer, intent(in) :: i, j
       type(vector4_t), intent(in), dimension(:) :: p
       real(default), intent(in) :: expo
       type(vector4_t) :: p_top
       if (i == THR_POS_B) then
          p_top = p(THR_POS_WP) + p(THR_POS_B)
       else
          p_top = p(THR_POS_WM) + p(THR_POS_BBAR)
       end if
       d_ij = dij_fsr (p_top, p(j), expo)
     end function dij_threshold_gluon_from_top
 
     function dij_isr (n_in, i, j, p, expo) result (d_ij)
       real(default) :: d_ij
       integer, intent(in) :: n_in, i, j
       type(vector4_t), intent(in), dimension(:) :: p
       real(default), intent(in) :: expo
       real(default) :: E, y
       select case (n_in)
       case (1)
          call get_emitter_variables (1, i, j, p, E, y)
          d_ij = (E**2 * (one - y**2))**expo
       case (2)
          if ((i == 0 .and. j > 2) .or. (j == 0 .and. i > 2)) then
             call get_emitter_variables (0, i, j, p, E, y)
             d_ij = (E**2 * (one - y**2))**expo
          else if ((i == 1 .and. j > 2) .or. (j == 1 .and. i > 2)) then
             call get_emitter_variables (1, i, j, p, E, y)
             d_ij = (two * E**2 * (one - y))**expo
          else if ((i == 2 .and. j > 2) .or. (j == 2 .and. i > 2)) then
             call get_emitter_variables (2, i, j, p, E, y)
             d_ij = (two * E**2 * (one + y))**expo
          end if
       end select
     end function dij_isr
 
     subroutine get_emitter_variables (i_check, i, j, p, E, y)
        integer, intent(in) :: i_check, i, j
        type(vector4_t), intent(in), dimension(:) :: p
        real(default), intent(out) :: E, y
        if (j == i_check) then
            E = energy (p(i))
            y = polar_angle_ct (p(i))
        else
            E = energy (p(j))
            y = polar_angle_ct(p(j))
        end if
     end subroutine get_emitter_variables
 
   end function fks_mapping_default_dij
 
 @  %def fks_mapping_default_dij
 @ Computes the quantity
 \begin{equation*}
   \mathcal{D} = \sum_k \frac{1}{d_{0k}} + \sum_{kl} \frac{1}{d_{kl}}.
 \end{equation*}
 where the sum goes over all ftuples of a single singular region.
 <<fks regions: fks mapping default: TBP>>=
   procedure :: compute_sumdij => fks_mapping_default_compute_sumdij
 <<fks regions: procedures>>=
   subroutine fks_mapping_default_compute_sumdij (map, sregion, p_real)
     class(fks_mapping_default_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p_real
     real(default) :: d
     integer :: i_ftuple, i, j
 
     associate (ftuples => sregion%ftuples)
       d = zero
       do i_ftuple = 1, sregion%nregions
          call ftuples(i_ftuple)%get (i, j)
          map%pseudo_isr = ftuples(i_ftuple)%pseudo_isr
          d = d + one / map%dij (p_real, i, j)
       end do
     end associate
     map%sumdij = d
   end subroutine fks_mapping_default_compute_sumdij
 
 @ %def fks_mapping_default_compute_sumdij
 @ Computes
 \begin{equation*}
   S_i = \frac{1}{\mathcal{D} d_{0i}}
 \end{equation*}
 or
 \begin{equation*}
   S_{ij} = \frac{1}{\mathcal{D} d_{ij}},
 \end{equation*}
 respectively.
 <<fks regions: fks mapping default: TBP>>=
   procedure :: svalue => fks_mapping_default_svalue
 <<fks regions: procedures>>=
   function fks_mapping_default_svalue (map, p, i, j, i_res) result (value)
     real(default) :: value
     class(fks_mapping_default_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: i, j
     integer, intent(in), optional :: i_res
     value = one / (map%dij (p, i, j) * map%sumdij)
   end function fks_mapping_default_svalue
 
 @ %def fks_mapping_default_svalue
 @ In the soft limit, our treatment of the divergencies requires a
 modification of the mapping functions. Recall that there, the ratios of
 the $d$-functions must approach either $1$ or $0$. This means
 \begin{equation*}
   \frac{d_{lm}}{d_{0m}} = \frac{(2k_l \cdot k_m) \left[E_lE_m /(E_l + E_m)^2\right]}{E_m^2 (1-y^2)}
     \overset {k_m = E_m \hat{k}} {=} \frac{E_l E_m^2}{(E_l + E_m)^2} \frac{2k_l \cdot \hat{k}}{E_m^2 (1-y^2)}
     \overset {E_m \to 0}{=} \frac{2k_l \cdot \hat{k}}{E_l}{(1-y^2)},
 \end{equation*}
 where we have written the gluon momentum in terms of the soft momentum
 $\hat{k}$. In the same limit
 \begin{equation*}
   \frac{d_{lm}}{d_{nm}} = \frac{k_l \cdot \hat{k}}{k_n \cdot \hat{k}} \frac{E_n}{E_l}.
 \end{equation*}
 From these equations we can deduce the soft limit of $d$:
 \begin{align*}
   d_0^{\rm{soft}} &= 1 - y^2,\\
   d_1^{\rm{soft}} &= 2(1-y),\\
   d_2^{\rm{soft}} &= 2(1+y),\\
   d_i^{\rm{soft}} &= \frac{2 k_i \cdot \hat{k}}{E_i}.
 \end{align*}
 <<fks regions: fks mapping default: TBP>>=
   procedure :: dij_soft => fks_mapping_default_dij_soft
 <<fks regions: procedures>>=
   function fks_mapping_default_dij_soft (map, p_born, p_soft, em, i_con) result (d)
     real(default) :: d
     class(fks_mapping_default_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     integer, intent(in) :: em
     integer, intent(in), optional :: i_con
     if (map%pseudo_isr) then
        d = dij_soft_threshold_gluon_from_top (em, p_born, p_soft, map%exp_1)
     else if (em <= map%n_in) then
        d = dij_soft_isr (map%n_in, p_soft, map%exp_2)
     else
        d = dij_soft_fsr (p_born(em), p_soft, map%exp_1)
     end if
   contains
 
     function dij_soft_threshold_gluon_from_top (em, p_born, p_soft, expo) result (dij_soft)
       real(default) :: dij_soft
       integer, intent(in) :: em
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(in) :: p_soft
       real(default), intent(in) :: expo
       type(vector4_t) :: p_top
       if (em == THR_POS_B) then
          p_top = p_born(THR_POS_WP) + p_born(THR_POS_B)
       else
          p_top = p_born(THR_POS_WM) + p_born(THR_POS_BBAR)
       end if
       dij_soft = dij_soft_fsr (p_top, p_soft, expo)
     end function dij_soft_threshold_gluon_from_top
 
     function dij_soft_fsr (p_em, p_soft, expo) result (dij_soft)
       real(default) :: dij_soft
       type(vector4_t), intent(in) :: p_em, p_soft
       real(default), intent(in) :: expo
       dij_soft = (two * p_em * p_soft / p_em%p(0))**expo
     end function dij_soft_fsr
 
     function dij_soft_isr (n_in, p_soft, expo) result (dij_soft)
        real(default) :: dij_soft
        integer, intent(in) :: n_in
        type(vector4_t), intent(in) :: p_soft
        real(default), intent(in) :: expo
        real(default) :: y
        y = polar_angle_ct (p_soft)
        select case (n_in)
        case (1)
           dij_soft = one - y**2
        case (2)
           select case (em)
           case (0)
              dij_soft = one - y**2
           case (1)
              dij_soft = two * (one - y)
           case (2)
              dij_soft = two * (one + y)
           case default
              dij_soft = zero
              call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2")
           end select
        case default
           dij_soft = zero
           call msg_fatal ("fks_mappings_default_dij_soft: n_in > 2")
        end select
        dij_soft = dij_soft**expo
     end function dij_soft_isr
   end function fks_mapping_default_dij_soft
 
 @ %def fks_mapping_default_dij_soft
 @ Computes the sum of all soft [[dij]]s required to normalize the soft S functions
 [[s_alpha_soft]] similar to [[fks_mapping_default_compute_sumdij]].
 In the soft limit however, we need to skip all ftuples $(i,j)$ in which $j$ does
 not correspond to the emitted particle because those $d_{ij}$s are finite and thus
 their contribution to the soft S function vanishes in the limit of soft radiation.
 Technically, they would not vanish if computed here because the fixed [[p_soft]]
 at this point would not fit their actual emitter.
 <<fks regions: fks mapping default: TBP>>=
   procedure :: compute_sumdij_soft => fks_mapping_default_compute_sumdij_soft
 <<fks regions: procedures>>=
   subroutine fks_mapping_default_compute_sumdij_soft (map, sregion, p_born, p_soft)
     class(fks_mapping_default_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     real(default) :: d
     integer :: i_ftuple, i, j
     integer :: nlegs
     d = zero
     nlegs = size (sregion%flst_real%flst)
     associate (ftuples => sregion%ftuples)
       do i_ftuple = 1, sregion%nregions
          call ftuples(i_ftuple)%get (i ,j)
          if (j == nlegs) then
             map%pseudo_isr = ftuples(i_ftuple)%pseudo_isr
             d = d + one / map%dij_soft (p_born, p_soft, i)
          end if
       end do
     end associate
     map%sumdij_soft = d
   end subroutine fks_mapping_default_compute_sumdij_soft
 
 @ %def fks_mapping_default_compute_sumdij_soft
 @
 <<fks regions: fks mapping default: TBP>>=
   procedure :: svalue_soft => fks_mapping_default_svalue_soft
 <<fks regions: procedures>>=
   function fks_mapping_default_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
     real(default) :: value
     class(fks_mapping_default_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     integer, intent(in) :: em
     integer, intent(in), optional :: i_res
     value = one / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em))
   end function fks_mapping_default_svalue_soft
 
 @ %def fks_mapping_default_svalue_soft
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure fks_mapping_default_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine fks_mapping_default_assign (fks_map_out, fks_map_in)
     type(fks_mapping_default_t), intent(out) :: fks_map_out
     type(fks_mapping_default_t), intent(in) :: fks_map_in
     fks_map_out%exp_1 = fks_map_in%exp_1
     fks_map_out%exp_2 = fks_map_in%exp_2
     fks_map_out%n_in = fks_map_in%n_in
   end subroutine fks_mapping_default_assign
 
 @ %def fks_mapping_default_assign
 @ The $d_{ij,k}$-functions for the resonance mapping are basically the same
 as in the default case, but the kinematical values here must be evaluated
 in the resonance frame of reference. The energy of parton $i$ in a given
 resonance frame with momentum $p_{res}$ is
 \begin{equation*}
    E_i = \frac{p_i^0 \cdot p_{res}}{m_{res}}.
 \end{equation*}
 However, since the expressions only depend on ratios of four-momenta, we
 leave out the denominator because it will cancel out anyway.
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: dij => fks_mapping_resonances_dij
 <<fks regions: procedures>>=
   function fks_mapping_resonances_dij (map, p, i, j, i_con) result (d)
     real(default) :: d
     class(fks_mapping_resonances_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: i, j
     integer, intent(in), optional :: i_con
     real(default) :: E1, E2
     integer :: ii_con
     if (present (i_con)) then
        ii_con = i_con
     else
        call msg_fatal ("Resonance mappings require resonance index as input!")
     end if
     d = 0
     if (i /= j) then
        if (i > 2 .and. j > 2) then
           associate (p_res => map%res_map%p_res (ii_con))
              E1 = p(i) * p_res
              E2 = p(j) * p_res
              d = two * p(i) * p(j) * E1 * E2 / (E1 + E2)**2
           end associate
        else
           call msg_fatal ("Resonance mappings are not implemented for ISR")
        end if
     end if
   end function fks_mapping_resonances_dij
 
 @ %def fks_mapping_resonances_dij
 @ Computes
 \begin{equation*}
   S_\alpha = \frac{P^{f_r(\alpha)}d^{-1}(\alpha)}
      {\sum_{f_r' \in T(F_r(\alpha))}P^{f_r'}\sum_{\alpha' \in Sr(f_r')}d^{-1}(\alpha)}.
 \end{equation*}
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: compute_sumdij => fks_mapping_resonances_compute_sumdij
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_compute_sumdij (map, sregion, p_real)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p_real
     real(default) :: d, pfr
     integer :: i_res, i_reg, i, j, i_con
     integer :: nlegreal
 
     nlegreal = size (p_real)
     d = zero
     do i_reg = 1, sregion%nregions
        associate (ftuple => sregion%ftuples(i_reg))
           call ftuple%get (i, j)
           i_res = ftuple%i_res
        end associate
        pfr = map%res_map%get_resonance_value (i_res, p_real, nlegreal)
        i_con = sregion%i_reg_to_i_con (i_reg)
        d = d + pfr / map%dij (p_real, i, j, i_con)
     end do
     map%sumdij = d
   end subroutine fks_mapping_resonances_compute_sumdij
 
 @ %def fks_mapping_resonances_compute_sumdij
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: svalue => fks_mapping_resonances_svalue
 <<fks regions: procedures>>=
   function fks_mapping_resonances_svalue (map, p, i, j, i_res) result (value)
     real(default) :: value
     class(fks_mapping_resonances_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: i, j
     integer, intent(in), optional :: i_res
     real(default) :: pfr
     integer :: i_gluon
     i_gluon = size (p)
     pfr = map%res_map%get_resonance_value (i_res, p, i_gluon)
     value = pfr / (map%dij (p, i, j, map%i_con) * map%sumdij)
   end function fks_mapping_resonances_svalue
 
 @ %def fks_mapping_resonances_svalue
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: get_resonance_weight => fks_mapping_resonances_get_resonance_weight
 <<fks regions: procedures>>=
   function fks_mapping_resonances_get_resonance_weight (map, alr, p) result (pfr)
     real(default) :: pfr
     class(fks_mapping_resonances_t), intent(in) :: map
     integer, intent(in) :: alr
     type(vector4_t), intent(in), dimension(:) :: p
     pfr = map%res_map%get_weight (alr, p)
   end function fks_mapping_resonances_get_resonance_weight
 
 @ %def fks_mapping_resonances_get_resonance_weight
 @ As above, the soft limit of $d_{ij,k}$ must be computed in the resonance frame of
 reference.
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: dij_soft => fks_mapping_resonances_dij_soft
 <<fks regions: procedures>>=
   function fks_mapping_resonances_dij_soft (map, p_born, p_soft, em, i_con) result (d)
      real(default) :: d
      class(fks_mapping_resonances_t), intent(in) :: map
      type(vector4_t), intent(in), dimension(:) :: p_born
      type(vector4_t), intent(in) :: p_soft
      integer, intent(in) :: em
      integer, intent(in), optional :: i_con
      real(default) :: E1, E2
      integer :: ii_con
      type(vector4_t) :: pb
      if (present (i_con)) then
         ii_con = i_con
      else
         call msg_fatal ("fks_mapping_resonances requires resonance index")
      end if
      associate (p_res => map%res_map%p_res(ii_con))
         pb = p_born(em)
         E1 = pb * p_res
         E2 = p_soft * p_res
         d = two * pb * p_soft * E1 * E2 / E1**2
      end associate
   end function fks_mapping_resonances_dij_soft
 
 @ %def fks_mapping_resonances_dij_soft
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: compute_sumdij_soft => fks_mapping_resonances_compute_sumdij_soft
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_compute_sumdij_soft (map, sregion, p_born, p_soft)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     real(default) :: d
     real(default) :: pfr
     integer :: i_res, i, j, i_reg, i_con
     integer :: nlegs
 
     d = zero
     nlegs = size (sregion%flst_real%flst)
     do i_reg = 1, sregion%nregions
        associate (ftuple => sregion%ftuples(i_reg))
           call ftuple%get(i, j)
           i_res = ftuple%i_res
        end associate
        pfr = map%res_map%get_resonance_value (i_res, p_born)
        i_con = sregion%i_reg_to_i_con (i_reg)
        if (j == nlegs) d = d + pfr / map%dij_soft (p_born, p_soft, i, i_con)
     end do
     map%sumdij_soft = d
   end subroutine fks_mapping_resonances_compute_sumdij_soft
 
 @ %def fks_mapping_resonances_compute_sumdij_soft
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: svalue_soft => fks_mapping_resonances_svalue_soft
 <<fks regions: procedures>>=
   function fks_mapping_resonances_svalue_soft (map, p_born, p_soft, em, i_res) result (value)
     real(default) :: value
     class(fks_mapping_resonances_t), intent(in) :: map
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(in) :: p_soft
     integer, intent(in) :: em
     integer, intent(in), optional :: i_res
     real(default) :: pfr
     pfr = map%res_map%get_resonance_value (i_res, p_born)
     value = pfr / (map%sumdij_soft * map%dij_soft (p_born, p_soft, em, map%i_con))
   end function fks_mapping_resonances_svalue_soft
 
 @ %def fks_mapping_resonances_svalue_soft
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: set_resonance_momentum => fks_mapping_resonances_set_resonance_momentum
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_set_resonance_momentum (map, p)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(vector4_t), intent(in) :: p
     map%res_map%p_res = p
   end subroutine fks_mapping_resonances_set_resonance_momentum
 
 @ %def fks_mapping_resonances_set_resonance_momentum
 @
 <<fks regions: fks mapping resonances: TBP>>=
   procedure :: set_resonance_momenta => fks_mapping_resonances_set_resonance_momenta
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_set_resonance_momenta (map, p)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(vector4_t), intent(in), dimension(:) :: p
     map%res_map%p_res = p
   end subroutine fks_mapping_resonances_set_resonance_momenta
 
 @ %def fks_mapping_resonances_set_resonance_momenta
 @
 <<fks regions: interfaces>>=
   interface assignment(=)
      module procedure fks_mapping_resonances_assign
   end interface
 
 <<fks regions: procedures>>=
   subroutine fks_mapping_resonances_assign (fks_map_out, fks_map_in)
     type(fks_mapping_resonances_t), intent(out) :: fks_map_out
     type(fks_mapping_resonances_t), intent(in) :: fks_map_in
     fks_map_out%exp_1 = fks_map_in%exp_1
     fks_map_out%exp_2 = fks_map_in%exp_2
     fks_map_out%res_map = fks_map_in%res_map
   end subroutine fks_mapping_resonances_assign
 
 @ %def fks_mapping_resonances_assign
 @
 <<fks regions: public>>=
   public :: create_resonance_histories_for_threshold
 <<fks regions: procedures>>=
   function create_resonance_histories_for_threshold () result (res_history)
     type(resonance_history_t) :: res_history
     res_history%n_resonances = 2
     allocate (res_history%resonances (2))
     allocate (res_history%resonances(1)%contributors%c(2))
     allocate (res_history%resonances(2)%contributors%c(2))
     res_history%resonances(1)%contributors%c = [THR_POS_WP, THR_POS_B]
     res_history%resonances(2)%contributors%c = [THR_POS_WM, THR_POS_BBAR]
   end function create_resonance_histories_for_threshold
 
 @ %def create_resonance_histories_for_threshold
 @
 <<fks regions: public>>=
   public :: setup_region_data_for_test
 <<fks regions: procedures>>=
   subroutine setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, nlo_corr_type)
     integer, intent(in) :: n_in
     integer, intent(in), dimension(:,:) :: flv_born, flv_real
     type(string_t), intent(in) :: nlo_corr_type
     type(region_data_t), intent(out) :: reg_data
     type(model_t), pointer :: test_model => null ()
     call create_test_model (var_str ("SM"), test_model)
     call test_model%set_real (var_str ("me"), 0._default)
     call test_model%set_real (var_str ("mmu"), 0._default)
     call test_model%set_real (var_str ("mtau"), 0._default)
     call test_model%set_real (var_str ("ms"), 0._default)
     call test_model%set_real (var_str ("mc"), 0._default)
     call test_model%set_real (var_str ("mb"), 0._default)
     call reg_data%init (n_in, test_model, flv_born, flv_real, nlo_corr_type)
   end subroutine setup_region_data_for_test
 
 @ %def setup_region_data_for_test
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \subsection{Unit tests}
 \clearpage
 <<[[fks_regions_ut.f90]]>>=
 <<File header>>
 
 module fks_regions_ut
   use unit_tests
   use fks_regions_uti
 
 <<Standard module head>>
 
 <<fks regions: public test>>
 
 contains
 
 <<fks regions: test driver>>
 
 end module fks_regions_ut
 @ %def fks_regions_ut
 @
 <<[[fks_regions_uti.f90]]>>=
 <<File header>>
 
 module fks_regions_uti
 
 <<Use strings>>
   use format_utils, only: write_separator
   use os_interface
   use models
 
   use fks_regions
 
 <<Standard module head>>
 
 <<fks regions: test declarations>>
 
 contains
 
 <<fks regions: tests>>
 
 end module fks_regions_uti
 @ %def fks_regions_uti
 @
 <<fks regions: public test>>=
   public :: fks_regions_test
 <<fks regions: test driver>>=
   subroutine fks_regions_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
     call test(fks_regions_1, "fks_regions_1", &
          "Test flavor structure utilities", u, results)
     call test(fks_regions_2, "fks_regions_2", &
          "Test singular regions for final-state radiation for n = 2", &
          u, results)
     call test(fks_regions_3, "fks_regions_3", &
          "Test singular regions for final-state radiation for n = 3", &
          u, results)
     call test(fks_regions_4, "fks_regions_4", &
          "Test singular regions for final-state radiation for n = 4", &
          u, results)
     call test(fks_regions_5, "fks_regions_5", &
          "Test singular regions for final-state radiation for n = 5", &
          u, results)
     call test(fks_regions_6, "fks_regions_6", &
          "Test singular regions for initial-state radiation", &
          u, results)
     call test(fks_regions_7, "fks_regions_7", &
          "Check Latex output", u, results)
     call test(fks_regions_8, "fks_regions_8", &
          "Test singular regions for initial-state photon contributions", &
          u, results)
   end subroutine fks_regions_test
 
 @ %def fks_regions_test
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_1
 <<fks regions: tests>>=
   subroutine fks_regions_1 (u)
     integer, intent(in) :: u
     type(flv_structure_t) :: flv_born, flv_real
     type(model_t), pointer :: test_model => null ()
     write (u, "(A)") "* Test output: fks_regions_1"
     write (u, "(A)") "* Purpose: Test utilities of flavor structure manipulation"
     write (u, "(A)")
 
     call create_test_model (var_str ("SM"), test_model)
 
     flv_born = [11, -11, 2, -2]
     flv_real = [11, -11, 2, -2, 21]
     flv_born%n_in = 2; flv_real%n_in = 2
     write (u, "(A)") "* Valid splittings of ee -> uu"
     write (u, "(A)") "Born Flavors: "
     call flv_born%write (u)
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "3, 4 (2, -2) : ", flv_real%valid_pair (3, 4, flv_born, test_model)
     write (u, "(A,L1)") "4, 3 (-2, 2) : ", flv_real%valid_pair (4, 3, flv_born, test_model)
     write (u, "(A,L1)") "3, 5 (2, 21) : ", flv_real%valid_pair (3, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 3 (21, 2) : ", flv_real%valid_pair (5, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 5 (-2, 21): ", flv_real%valid_pair (4, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 4 (21, -2): ", flv_real%valid_pair (5, 4, flv_born, test_model)
     call write_separator (u)
 
     call flv_born%final ()
     call flv_real%final ()
 
     flv_born = [2, -2, 11, -11]
     flv_real = [2, -2, 11, -11, 21]
     flv_born%n_in = 2; flv_real%n_in = 2
     write (u, "(A)") "* Valid splittings of uu -> ee"
     write (u, "(A)") "Born Flavors: "
     call flv_born%write (u)
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "1, 2 (2, -2) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 1 (-2, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
     write (u, "(A,L1)") "5, 2 (21, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 5 (-2, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model)
     write (u, "(A,L1)") "1, 5 (21, 2) : " , flv_real%valid_pair (5, 1, flv_born, test_model)
     write (u, "(A,L1)") "5, 1 (2, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model)
     call flv_real%final ()
     flv_real = [21, -2, 11, -11, -2]
     flv_real%n_in = 2
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "1, 2 (21, -2): " , flv_real%valid_pair (1, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 1 (-2, 21): " , flv_real%valid_pair (2, 1, flv_born, test_model)
     write (u, "(A,L1)") "5, 2 (-2, -2): " , flv_real%valid_pair (5, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 5 (-2, -2): " , flv_real%valid_pair (2, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 1 (-2, 21): " , flv_real%valid_pair (5, 1, flv_born, test_model)
     write (u, "(A,L1)") "1, 5 (21, -2): " , flv_real%valid_pair (1, 5, flv_born, test_model)
     call flv_real%final ()
     flv_real = [2, 21, 11, -11, 2]
     flv_real%n_in = 2
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "1, 2 (2, 21) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 1 (21, 2) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
     write (u, "(A,L1)") "5, 2 (2, 21) : " , flv_real%valid_pair (5, 2, flv_born, test_model)
     write (u, "(A,L1)") "2, 5 (21, 2) : " , flv_real%valid_pair (2, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 1 (2, 2)  : " , flv_real%valid_pair (5, 1, flv_born, test_model)
     write (u, "(A,L1)") "1, 5 (2, 2)  : " , flv_real%valid_pair (1, 5, flv_born, test_model)
     call write_separator (u)
 
     call flv_born%final ()
     call flv_real%final ()
 
     flv_born = [11, -11, 2, -2, 21]
     flv_real = [11, -11, 2, -2, 21, 21]
     flv_born%n_in = 2; flv_real%n_in = 2
     write (u, "(A)") "* Valid splittings of ee -> uug"
     write (u, "(A)") "Born Flavors: "
     call flv_born%write (u)
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
     write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
     write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 5 (-2, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 4 (21, -2): " , flv_real%valid_pair (5, 4, flv_born, test_model)
     write (u, "(A,L1)") "3, 6 (2, 21) : " , flv_real%valid_pair (3, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 3 (21, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 6 (-2, 21): " , flv_real%valid_pair (4, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 4 (21, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model)
     write (u, "(A,L1)") "5, 6 (21, 21): " , flv_real%valid_pair (5, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 5 (21, 21): " , flv_real%valid_pair (6, 5, flv_born, test_model)
     call flv_real%final ()
     flv_real = [11, -11, 2, -2, 1, -1]
     flv_real%n_in = 2
     write (u, "(A)") "Real Flavors (exemplary g -> dd splitting): "
     call flv_real%write (u)
     write (u, "(A,L1)") "3, 4 (2, -2) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
     write (u, "(A,L1)") "4, 3 (-2, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
     write (u, "(A,L1)") "3, 5 (2, 1)  : " , flv_real%valid_pair (3, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 3 (1, 2)  : " , flv_real%valid_pair (5, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 5 (-2, 1) : " , flv_real%valid_pair (4, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 4 (1, -2) : " , flv_real%valid_pair (5, 4, flv_born, test_model)
     write (u, "(A,L1)") "3, 6 (2, -1) : " , flv_real%valid_pair (3, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 3 (-1, 2) : " , flv_real%valid_pair (6, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 6 (-2, -1): " , flv_real%valid_pair (4, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 4 (-1, -2): " , flv_real%valid_pair (6, 4, flv_born, test_model)
     write (u, "(A,L1)") "5, 6 (1, -1) : " , flv_real%valid_pair (5, 6, flv_born, test_model)
     write (u, "(A,L1)") "6, 5 (-1, 1) : " , flv_real%valid_pair (6, 5, flv_born, test_model)
     call write_separator (u)
 
     call flv_born%final ()
     call flv_real%final ()
 
     flv_born = [6, -5, 2, -1 ]
     flv_real = [6, -5, 2, -1, 21]
     flv_born%n_in = 1; flv_real%n_in = 1
     write (u, "(A)") "* Valid splittings of t -> b u d~"
     write (u, "(A)") "Born Flavors: "
     call flv_born%write (u)
     write (u, "(A)") "Real Flavors: "
     call flv_real%write (u)
     write (u, "(A,L1)") "1, 2 (6, -5) : " , flv_real%valid_pair (1, 2, flv_born, test_model)
     write (u, "(A,L1)") "1, 3 (6, 2)  : " , flv_real%valid_pair (1, 3, flv_born, test_model)
     write (u, "(A,L1)") "1, 4 (6, -1) : " , flv_real%valid_pair (1, 4, flv_born, test_model)
     write (u, "(A,L1)") "2, 1 (-5, 6) : " , flv_real%valid_pair (2, 1, flv_born, test_model)
     write (u, "(A,L1)") "3, 1 (2, 6)  : " , flv_real%valid_pair (3, 1, flv_born, test_model)
     write (u, "(A,L1)") "4, 1 (-1, 6) : " , flv_real%valid_pair (4, 1, flv_born, test_model)
     write (u, "(A,L1)") "2, 3 (-5, 2) : " , flv_real%valid_pair (2, 3, flv_born, test_model)
     write (u, "(A,L1)") "2, 4 (-5, -1): " , flv_real%valid_pair (2, 4, flv_born, test_model)
     write (u, "(A,L1)") "3, 2 (2, -5) : " , flv_real%valid_pair (3, 2, flv_born, test_model)
     write (u, "(A,L1)") "4, 2 (-1, -5): " , flv_real%valid_pair (4, 2, flv_born, test_model)
     write (u, "(A,L1)") "3, 4 (2, -1) : " , flv_real%valid_pair (3, 4, flv_born, test_model)
     write (u, "(A,L1)") "4, 3 (-1, 2) : " , flv_real%valid_pair (4, 3, flv_born, test_model)
     write (u, "(A,L1)") "1, 5 (6, 21) : " , flv_real%valid_pair (1, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 1 (21, 6) : " , flv_real%valid_pair (5, 1, flv_born, test_model)
     write (u, "(A,L1)") "2, 5 (-5, 21): " , flv_real%valid_pair (2, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 2 (21, 5) : " , flv_real%valid_pair (5, 2, flv_born, test_model)
     write (u, "(A,L1)") "3, 5 (2, 21) : " , flv_real%valid_pair (3, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 3 (21, 2) : " , flv_real%valid_pair (5, 3, flv_born, test_model)
     write (u, "(A,L1)") "4, 5 (-1, 21): " , flv_real%valid_pair (4, 5, flv_born, test_model)
     write (u, "(A,L1)") "5, 4 (21, -1): " , flv_real%valid_pair (5, 4, flv_born, test_model)
 
     call flv_born%final ()
     call flv_real%final ()
 
   end subroutine fks_regions_1
 
 @ %def fks_regions_1
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_2
 <<fks regions: tests>>=
   subroutine fks_regions_2 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_2"
     write (u, "(A)") "* Create singular regions for processes with up to four singular regions"
     write (u, "(A)") "* ee -> qq with QCD corrections"
     write (u, "(A)")
 
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
 
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, 2, -2]
     flv_real (:, 1) = [11, -11, 2, -2, 21]
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> qq with EW corrections"
     write (u, "(A)")
 
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, 2, -2]
     flv_real (:, 1) = [11, -11, 2, -2, 22]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> tt"
     write (u, "(A)")
     write (u, "(A)") "* This process has four singular regions because they are not equivalent."
 
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 6; n_legs_real = 7
     n_in = 2
 
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, 6, -6, 6, -6]
     flv_real (:, 1) = [11, -11, 6, -6, 6, -6, 21]
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
   end subroutine fks_regions_2
 
 @ %def fks_regions_2
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_3
 <<fks regions: tests>>=
   subroutine fks_regions_3 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in, i, j
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_3"
     write (u, "(A)") "* Create singular regions for processes with three final-state particles"
 
     write (u, "(A)") "* ee -> qqg"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 2
     n_legs_born = 5; n_legs_real = 6
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1) = [11, -11, 2, -2, 21]
     flv_real (:, 1) = [11, -11, 2, -2, 21, 21]
     flv_real (:, 2) = [11, -11, 2, -2, 1, -1]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> qqA"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 2
     n_legs_born = 5; n_legs_real = 6
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1) = [11, -11, 2, -2, 22]
     flv_real (:, 1) = [11, -11, 2, -2, 22, 22]
     flv_real (:, 2) = [11, -11, 2, -2, 11, -11]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> jet jet jet"
     write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
     write (u, "(A)")
     n_flv_born = 5; n_flv_real = 22
     n_legs_born = 5; n_legs_real = 6
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1)  = [11, -11, -4, 4, 21]
     flv_born (:, 2)  = [11, -11, -2, 2, 21]
     flv_born (:, 3)  = [11, -11, -5, 5, 21]
     flv_born (:, 4)  = [11, -11, -3, 3, 21]
     flv_born (:, 5)  = [11, -11, -1, 1, 21]
     flv_real (:, 1)  = [11, -11, -4, -4, 4, 4]
     flv_real (:, 2)  = [11, -11, -4, -2, 2, 4]
     flv_real (:, 3)  = [11, -11, -4, 4, 21, 21]
     flv_real (:, 4)  = [11, -11, -4, -5, 4, 5]
     flv_real (:, 5)  = [11, -11, -4, -3, 4, 3]
     flv_real (:, 6)  = [11, -11, -4, -1, 2, 3]
     flv_real (:, 7)  = [11, -11, -4, -1, 4, 1]
     flv_real (:, 8)  = [11, -11, -2, -2, 2, 2]
     flv_real (:, 9)  = [11, -11, -2, 2, 21, 21]
     flv_real (:, 10) = [11, -11, -2, -5, 2, 5]
     flv_real (:, 11) = [11, -11, -2, -3, 2, 3]
     flv_real (:, 12) = [11, -11, -2, -3, 4, 1]
     flv_real (:, 13) = [11, -11, -2, -1, 2, 1]
     flv_real (:, 14) = [11, -11, -5, -5, 5, 5]
     flv_real (:, 15) = [11, -11, -5, -3, 3, 5]
     flv_real (:, 16) = [11, -11, -5, -1, 1, 5]
     flv_real (:, 17) = [11, -11, -5, 5, 21, 21]
     flv_real (:, 18) = [11, -11, -3, -3, 3, 3]
     flv_real (:, 19) = [11, -11, -3, -1, 1, 3]
     flv_real (:, 20) = [11, -11, -3, 3, 21, 21]
     flv_real (:, 21) = [11, -11, -1, -1, 1, 1]
     flv_real (:, 22) = [11, -11, -1, 1, 21, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> L L A"
     write (u, "(A)") "* with L = e2:E2:e3:E3"
     write (u, "(A)")
     n_flv_born = 2; n_flv_real = 6
     n_legs_born = 5; n_legs_real = 6
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1) = [11, -11, -15, 15, 22]
     flv_born (:, 2) = [11, -11, -13, 13, 22]
 
     flv_real (:, 1) = [11, -11, -15, -15, 15, 15]
     flv_real (:, 2) = [11, -11, -15, -13, 13, 13]
     flv_real (:, 3) = [11, -11, -13, -15, 13, 15]
     flv_real (:, 4) = [11, -11, -15, 15, 22, 22]
     flv_real (:, 5) = [11, -11, -13, -13, 13, 13]
     flv_real (:, 6) = [11, -11, -13, 13, 22, 22]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
   end subroutine fks_regions_3
 
 @ %def fks_regions_3
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_4
 <<fks regions: tests>>=
   subroutine fks_regions_4 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_4"
     write (u, "(A)") "* Create singular regions for processes with four final-state particles"
     write (u, "(A)") "* ee -> 4 jet"
     write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
     write (u, "(A)")
     n_flv_born = 22; n_flv_real = 22
     n_legs_born = 6; n_legs_real = 7
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1)   = [11, -11, -4, -4, 4, 4]
     flv_born (:, 2)   = [11, -11, -4, -2, 2, 4]
     flv_born (:, 3)   = [11, -11, -4, 4, 21, 21]
     flv_born (:, 4)   = [11, -11, -4, -5, 4, 5]
     flv_born (:, 5)   = [11, -11, -4, -3, 4, 3]
     flv_born (:, 6)   = [11, -11, -4, -1, 2, 3]
     flv_born (:, 7)   = [11, -11, -4, -1, 4, 1]
     flv_born (:, 8)   = [11, -11, -2, -2, 2, 2]
     flv_born (:, 9)   = [11, -11, -2, 2, 21, 21]
     flv_born (:, 10)  = [11, -11, -2, -5, 2, 5]
     flv_born (:, 11)  = [11, -11, -2, -3, 2, 3]
     flv_born (:, 12)  = [11, -11, -2, -3, 4, 1]
     flv_born (:, 13)  = [11, -11, -2, -1, 2, 1]
     flv_born (:, 14)  = [11, -11, -5, -5, 5, 5]
     flv_born (:, 15)  = [11, -11, -5, -3, 3, 5]
     flv_born (:, 16)  = [11, -11, -5, -1, 1, 5]
     flv_born (:, 17)  = [11, -11, -5, 5, 21, 21]
     flv_born (:, 18)  = [11, -11, -3, -3, 3, 3]
     flv_born (:, 19)  = [11, -11, -3, -1, 1, 3]
     flv_born (:, 20)  = [11, -11, -3, -3, 21, 21]
     flv_born (:, 21)  = [11, -11, -1, -1, 1, 1]
     flv_born (:, 22)  = [11, -11, -1, 1, 21, 21]
     flv_real (:, 1)   = [11, -11, -4, -4, 4, 4, 21]
     flv_real (:, 2)   = [11, -11, -4, -2, 2, 4, 21]
     flv_real (:, 3)   = [11, -11, -4, 4, 21, 21, 21]
     flv_real (:, 4)   = [11, -11, -4, -5, 4, 5, 21]
     flv_real (:, 5)   = [11, -11, -4, -3, 4, 3, 21]
     flv_real (:, 6)   = [11, -11, -4, -1, 2, 3, 21]
     flv_real (:, 7)   = [11, -11, -4, -1, 4, 1, 21]
     flv_real (:, 8)   = [11, -11, -2, -2, 2, 2, 21]
     flv_real (:, 9)   = [11, -11, -2, 2, 21, 21, 21]
     flv_real (:, 10)  = [11, -11, -2, -5, 2, 5, 21]
     flv_real (:, 11)  = [11, -11, -2, -3, 2, 3, 21]
     flv_real (:, 12)  = [11, -11, -2, -3, 4, 1, 21]
     flv_real (:, 13)  = [11, -11, -2, -1, 2, 1, 21]
     flv_real (:, 14)  = [11, -11, -5, -5, 5, 5, 21]
     flv_real (:, 15)  = [11, -11, -5, -3, 3, 5, 21]
     flv_real (:, 16)  = [11, -11, -5, -1, 1, 5, 21]
     flv_real (:, 17)  = [11, -11, -5, 5, 21, 21, 21]
     flv_real (:, 18)  = [11, -11, -3, -3, 3, 3, 21]
     flv_real (:, 19)  = [11, -11, -3, -1, 1, 3, 21]
     flv_real (:, 20)  = [11, -11, -3, 3, 21, 21, 21]
     flv_real (:, 21)  = [11, -11, -1, -1, 1, 1, 21]
     flv_real (:, 22)  = [11, -11, -1, 1, 21, 21, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> bbmumu with QCD corrections"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 6; n_legs_real = 7
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1)   = [11, -11, -5, 5, -13, 13]
     flv_real (:, 1)   = [11, -11, -5, 5, -13, 13, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
     call write_separator (u)
 
     write (u, "(A)") "* ee -> bbmumu with EW corrections"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 6; n_legs_real = 7
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1)   = [11, -11, -5, 5, -13, 13]
     flv_real (:, 1)   = [11, -11, -5, 5, -13, 13, 22]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
   end subroutine fks_regions_4
 
 @ %def fks_regions_4
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_5
 <<fks regions: tests>>=
   subroutine fks_regions_5 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_5"
     write (u, "(A)") "* Create singular regions for processes with five final-state particles"
     write (u, "(A)") "* ee -> 5 jet"
     write (u, "(A)") "* with jet = u:U:d:D:s:S:c:C:b:B:gl"
     write (u, "(A)")
     n_flv_born = 22; n_flv_real = 67
     n_legs_born = 7; n_legs_real = 8
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
 
     flv_born (:,1)  = [11,-11,-4,-4,4,4,21]
     flv_born (:,2)  = [11,-11,-4,-2,2,4,21]
     flv_born (:,3)  = [11,-11,-4,4,21,21,21]
     flv_born (:,4)  = [11,-11,-4,-5,4,5,21]
     flv_born (:,5)  = [11,-11,-4,-3,4,3,21]
     flv_born (:,6)  = [11,-11,-4,-1,2,3,21]
     flv_born (:,7)  = [11,-11,-4,-1,4,1,21]
     flv_born (:,8)  = [11,-11,-2,-2,2,2,21]
     flv_born (:,9)  = [11,-11,-2,2,21,21,21]
     flv_born (:,10) = [11,-11,-2,-5,2,5,21]
     flv_born (:,11) = [11,-11,-2,-3,2,3,21]
     flv_born (:,12) = [11,-11,-2,-3,4,1,21]
     flv_born (:,13) = [11,-11,-2,-1,2,1,21]
     flv_born (:,14) = [11,-11,-5,-5,5,5,21]
     flv_born (:,15) = [11,-11,-5,-3,3,5,21]
     flv_born (:,16) = [11,-11,-5,-1,1,5,21]
     flv_born (:,17) = [11,-11,-5,5,21,21,21]
     flv_born (:,18) = [11,-11,-3,-3,3,3,21]
     flv_born (:,19) = [11,-11,-3,-1,1,3,21]
     flv_born (:,20) = [11,-11,-3,3,21,21,21]
     flv_born (:,21) = [11,-11,-1,-1,1,1,21]
     flv_born (:,22) = [11,-11,-1,1,21,21,21]
 
     flv_real (:,1)  = [11,-11,-4,-4,-4,4,4,4]
     flv_real (:,2)  = [11,-11,-4,-4,-2,2,4,4]
     flv_real (:,3)  = [11,-11,-4,-4,4,4,21,21]
     flv_real (:,4)  = [11,-11,-4,-4,-5,4,4,5]
     flv_real (:,5)  = [11,-11,-4,-4,-3,4,4,3]
     flv_real (:,6)  = [11,-11,-4,-4,-1,2,4,3]
     flv_real (:,7)  = [11,-11,-4,-4,-1,4,4,1]
     flv_real (:,8)  = [11,-11,-4,-2,-2,2,2,4]
     flv_real (:,9)  = [11,-11,-4,-2,2,4,21,21]
     flv_real (:,10) = [11,-11,-4,-2,-5,2,4,5]
     flv_real (:,11) = [11,-11,-4,-2,-3,2,4,3]
     flv_real (:,12) = [11,-11,-4,-2,-3,4,4,1]
     flv_real (:,13) = [11,-11,-4,-2,-1,2,2,3]
     flv_real (:,14) = [11,-11,-4,-2,-1,2,4,1]
     flv_real (:,15) = [11,-11,-4,4,21,21,21,21]
     flv_real (:,16) = [11,-11,-4,-5,4,5,21,21]
     flv_real (:,17) = [11,-11,-4,-5,-5,4,5,5]
     flv_real (:,18) = [11,-11,-4,-5,-3,4,3,5]
     flv_real (:,19) = [11,-11,-4,-5,-1,2,3,5]
     flv_real (:,20) = [11,-11,-4,-5,-1,4,1,5]
     flv_real (:,21) = [11,-11,-4,-3,4,3,21,21]
     flv_real (:,22) = [11,-11,-4,-3,-3,4,3,3]
     flv_real (:,23) = [11,-11,-4,-3,-1,2,3,3]
     flv_real (:,24) = [11,-11,-4,-3,-1,4,1,3]
     flv_real (:,25) = [11,-11,-4,-1,2,3,21,21]
     flv_real (:,26) = [11,-11,-4,-1,4,1,21,21]
     flv_real (:,27) = [11,-11,-4,-1,-1,2,1,3]
     flv_real (:,28) = [11,-11,-4,-1,-1,4,1,1]
     flv_real (:,29) = [11,-11,-2,-2,-2,2,2,2]
     flv_real (:,30) = [11,-11,-2,-2,2,2,21,21]
     flv_real (:,31) = [11,-11,-2,-2,-5,2,2,5]
     flv_real (:,32) = [11,-11,-2,-2,-3,2,2,3]
     flv_real (:,33) = [11,-11,-2,-2,-3,2,4,1]
     flv_real (:,34) = [11,-11,-2,-2,-1,2,2,1]
     flv_real (:,35) = [11,-11,-2,2,21,21,21,21]
     flv_real (:,36) = [11,-11,-2,-5,2,5,21,21]
     flv_real (:,37) = [11,-11,-2,-5,-5,2,5,5]
     flv_real (:,38) = [11,-11,-2,-5,-3,2,3,5]
     flv_real (:,39) = [11,-11,-2,-5,-3,4,1,5]
     flv_real (:,40) = [11,-11,-2,-5,-1,2,1,5]
     flv_real (:,41) = [11,-11,-2,-3,2,3,21,21]
     flv_real (:,42) = [11,-11,-2,-3,4,1,21,21]
     flv_real (:,43) = [11,-11,-2,-3,-3,2,3,3]
     flv_real (:,44) = [11,-11,-2,-3,-3,4,1,3]
     flv_real (:,45) = [11,-11,-2,-3,-1,2,1,3]
     flv_real (:,46) = [11,-11,-2,-3,-1,4,1,1]
     flv_real (:,47) = [11,-11,-2,-1,2,1,21,21]
     flv_real (:,48) = [11,-11,-2,-1,-1,2,1,1]
     flv_real (:,49) = [11,-11,-5,-5,-5,5,5,5]
     flv_real (:,50) = [11,-11,-5,-5,-3,3,5,5]
     flv_real (:,51) = [11,-11,-5,-5,-1,1,5,5]
     flv_real (:,52) = [11,-11,-5,-5,5,5,21,21]
     flv_real (:,53) = [11,-11,-5,-3,-3,3,3,5]
     flv_real (:,54) = [11,-11,-5,-3,-1,1,3,5]
     flv_real (:,55) = [11,-11,-5,-3,3,5,21,21]
     flv_real (:,56) = [11,-11,-5,-1,-1,1,1,5]
     flv_real (:,57) = [11,-11,-5,-1,1,5,21,21]
     flv_real (:,58) = [11,-11,-5,5,21,21,21,21]
     flv_real (:,59) = [11,-11,-3,-3,-3,3,3,3]
     flv_real (:,60) = [11,-11,-3,-3,-1,1,3,3]
     flv_real (:,61) = [11,-11,-3,-3,3,3,21,21]
     flv_real (:,62) = [11,-11,-3,-1,-1,1,1,3]
     flv_real (:,63) = [11,-11,-3,-1,1,3,21,21]
     flv_real (:,64) = [11,-11,-3,3,21,21,21,21]
     flv_real (:,65) = [11,-11,-1,-1,-1,1,1,1]
     flv_real (:,66) = [11,-11,-1,-1,1,1,21,21]
     flv_real (:,67) = [11,-11,-1,1,21,21,21,21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
   end subroutine fks_regions_5
 
 @ %def fks_regions_5
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_6
 <<fks regions: tests>>=
   subroutine fks_regions_6 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     integer :: i, j
     integer, dimension(10) :: flavors
     write (u, "(A)") "* Test output: fks_regions_6"
     write (u, "(A)") "* Create table of singular regions for Drell Yan"
     write (u, "(A)")
 
     n_flv_born = 10; n_flv_real = 30
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flavors = [-5, -4, -3, -2, -1, 1, 2, 3, 4, 5]
     do i = 1, n_flv_born
        flv_born (3:4, i) = [11, -11]
     end do
     do j = 1, n_flv_born
        flv_born (1, j) = flavors (j)
        flv_born (2, j) = -flavors (j)
     end do
 
     do i = 1, n_flv_real
        flv_real (3:4, i) = [11, -11]
     end do
     i = 1
     do j = 1, n_flv_real
        if (mod (j, 3) == 1) then
           flv_real (1, j) = flavors (i)
           flv_real (2, j) = -flavors (i)
           flv_real (5, j) = 21
        else if (mod (j, 3) == 2) then
           flv_real (1, j) = flavors (i)
           flv_real (2, j) = 21
           flv_real (5, j) = flavors (i)
        else
           flv_real (1, j) = 21
           flv_real (2, j) = -flavors (i)
           flv_real (5, j) = -flavors (i)
           i = i + 1
        end if
     end do
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     call write_separator (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
     write (u, "(A)") "* Create table of singular regions for hadronic top decay"
     write (u, "(A)")
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 4; n_legs_real = 5
     n_in = 1
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
 
     flv_born (:, 1) = [6, -5, 2, -1]
     flv_real (:, 1) = [6, -5, 2, -1, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
 
     call write_separator (u)
 
     deallocate (flv_born, flv_real)
     call reg_data%final ()
 
     write (u, "(A)") "* Create table of singular regions for dijet s sbar -> jet jet"
     write (u, "(A)") "* With jet = u:d:gl"
     write (u, "(A)")
 
     n_flv_born = 3; n_flv_real = 3
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     do i = 1, n_flv_born
        flv_born (1:2, i) = [3, -3]
     end do
     flv_born (3, :) = [1, 2, 21]
     flv_born (4, :) = [-1, -2, 21]
 
     do i = 1, n_flv_real
        flv_real (1:2, i) = [3, -3]
     end do
     flv_real (3, :) = [1, 2, 21]
     flv_real (4, :) = [-1, -2, 21]
     flv_real (5, :) = [21, 21, 21]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
     call reg_data%final ()
 
   end subroutine fks_regions_6
 
 @ %def fks_regions_6
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_7
 <<fks regions: tests>>=
   subroutine fks_regions_7 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     write (u, "(A)") "* Test output: fks_regions_7"
     write (u, "(A)") "* Create table of singular regions for ee -> qq"
     write (u, "(A)")
 
     n_flv_born = 1; n_flv_real = 1
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
 
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, 2, -2]
     flv_real (:, 1) = [11, -11, 2, -2, 21]
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("QCD"))
     call reg_data%write_latex (u)
     call reg_data%final ()
 
   end subroutine fks_regions_7
 
 @ %def fks_regions_7
 @
 <<fks regions: test declarations>>=
   public :: fks_regions_8
 <<fks regions: tests>>=
   subroutine fks_regions_8 (u)
     integer, intent(in) :: u
     integer :: n_flv_born, n_flv_real
     integer :: n_legs_born, n_legs_real
     integer :: n_in
     integer, dimension(:,:), allocatable :: flv_born, flv_real
     type(region_data_t) :: reg_data
     integer :: i, j
     integer, dimension(10) :: flavors
     write (u, "(A)") "* Test output: fks_regions_8"
     write (u, "(A)") "* Create table of singular regions for ee -> ee"
     write (u, "(A)")
 
     n_flv_born = 1; n_flv_real = 3
     n_legs_born = 4; n_legs_real = 5
     n_in = 2
     allocate (flv_born (n_legs_born, n_flv_born))
     allocate (flv_real (n_legs_real, n_flv_real))
     flv_born (:, 1) = [11, -11, -11, 11]
 
     flv_real (:, 1) = [11, -11, -11, 11, 22]
     flv_real (:, 2) = [11, 22, -11, 11, 11]
     flv_real (:, 3) = [22, -11, 11, -11, -11]
 
     call setup_region_data_for_test (n_in, flv_born, flv_real, reg_data, var_str ("EW"))
     call reg_data%check_consistency (.false., u)
     call reg_data%write (u)
     call reg_data%final ()
 
   end subroutine fks_regions_8
 
 @ %def fks_regions_8
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Virtual contribution to the cross section}
 <<[[virtual.f90]]>>=
 <<File header>>
 
 module virtual
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use numeric_utils
   use constants
   use diagnostics
   use pdg_arrays
   use models
   use model_data, only: model_data_t, field_data_t
   use physics_defs
   use sm_physics
   use lorentz
   use flavors
   use nlo_data, only: get_threshold_momenta, nlo_settings_t
   use nlo_data, only: ASSOCIATED_LEG_PAIR
   use fks_regions
 
 <<Standard module head>>
 
 <<virtual: public>>
 
 <<virtual: parameters>>
 
 <<virtual: types>>
 
 contains
 
 <<virtual: procedures>>
 
 end module virtual
 @ %def virtual
 @
 <<virtual: public>>=
   public :: virtual_t
 <<virtual: types>>=
   type :: virtual_t
      type(nlo_settings_t), pointer :: settings
      real(default), dimension(:,:), allocatable :: gamma_0, gamma_p, c_flv
      real(default) :: ren_scale2, fac_scale, es_scale2
      integer, dimension(:), allocatable :: n_is_neutrinos
      integer :: n_in, n_legs, n_flv
      logical :: bad_point = .false.
      type(string_t) :: selection
      real(default), dimension(:), allocatable :: sqme_born
      real(default), dimension(:), allocatable :: sqme_virt_fin
      real(default), dimension(:,:,:), allocatable :: sqme_color_c
      real(default), dimension(:,:,:), allocatable :: sqme_charge_c
      logical :: has_pdfs = .false.
    contains
    <<virtual: virtual: TBP>>
   end type virtual_t
 
 @ %def virtual_t
 @
 <<virtual: virtual: TBP>>=
   procedure :: init => virtual_init
 <<virtual: procedures>>=
   subroutine virtual_init (virt, flv_born, n_in, settings, &
       nlo_corr_type, model, has_pdfs)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in), dimension(:,:) :: flv_born
     integer, intent(in) :: n_in
     type(nlo_settings_t), intent(in), pointer :: settings
     type(string_t), intent(in) :: nlo_corr_type
     class(model_data_t), intent(in) :: model
     logical, intent(in) :: has_pdfs
     integer :: i_flv
     virt%n_legs = size (flv_born, 1); virt%n_flv = size (flv_born, 2)
     virt%n_in = n_in
     allocate (virt%sqme_born (virt%n_flv))
     allocate (virt%sqme_virt_fin (virt%n_flv))
     allocate (virt%sqme_color_c (virt%n_legs, virt%n_legs, virt%n_flv))
     allocate (virt%sqme_charge_c (virt%n_legs, virt%n_legs, virt%n_flv))
     allocate (virt%gamma_0 (virt%n_legs, virt%n_flv), &
        virt%gamma_p (virt%n_legs, virt%n_flv), &
        virt%c_flv (virt%n_legs, virt%n_flv))
     call virt%init_constants (flv_born, settings%fks_template%n_f, nlo_corr_type, model)
     allocate (virt%n_is_neutrinos (virt%n_flv))
     virt%n_is_neutrinos = 0
     do i_flv = 1, virt%n_flv
        if (is_neutrino (flv_born(1, i_flv))) &
           virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1
        if (is_neutrino (flv_born(2, i_flv))) &
           virt%n_is_neutrinos(i_flv) = virt%n_is_neutrinos(i_flv) + 1
     end do
     select case (char (settings%virtual_selection))
     case ("Full", "OLP", "Subtraction")
        virt%selection = settings%virtual_selection
     case default
        call msg_fatal ('Virtual selection: Possible values are "Full", "OLP" or "Subtraction')
     end select
     virt%settings => settings
     virt%has_pdfs = has_pdfs
   contains
 
     function is_neutrino (flv) result (neutrino)
       integer, intent(in) :: flv
       logical :: neutrino
       neutrino = (abs(flv) == 12 .or. abs(flv) == 14 .or. abs(flv) == 16)
     end function is_neutrino
 
   end subroutine virtual_init
 
 @ %def virtual_init
 @ The virtual subtraction terms contain Casimir operators and derived constants, listed
 below:
 \begin{align}
   \label{eqn:C(q)}
   C(q) = C(\bar{q}) &= C_F, \\
   \label{eqn:C(g)}
   C(g) &= C_A,\\
   \label{eqn:gamma(q)}
   \gamma(q) = \gamma(\bar{q}) &= \frac{3}{2} C_F,\\
   \label{eqn:gamma(g)}
   \gamma(g) &= \frac{11}{6} C_A - \frac{2}{3} T_F N_f,\\
   \label{eqn:gammap(q)}
   \gamma'(q) = \gamma'(\bar{q}) &= \left(\frac{13}{2} - \frac{2\pi^2}{3}\right) C_F, \\
   \label{eqn:gammap(g)}
   \gamma'(g) &= \left(\frac{67}{9} - \frac{2\pi^2}{3}\right) C_A - \frac{23}{9} T_F N_f.
 \end{align}
 For uncolored particles, [[virtual_init_constants]] sets $C$, $\gamma$ and $\gamma'$ to zero.
 <<virtual: virtual: TBP>>=
   procedure :: init_constants => virtual_init_constants
 <<virtual: procedures>>=
   subroutine virtual_init_constants (virt, flv_born, nf_input, nlo_corr_type, model)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in), dimension(:,:) :: flv_born
     integer, intent(in) :: nf_input
     type(string_t), intent(in) :: nlo_corr_type
     class(model_data_t), intent(in) :: model
     type(field_data_t), pointer :: field
     integer :: i_part, i_flv, pdg
     real(default) :: nf, CA_factor, TR_sum
     real(default), dimension(:,:), allocatable :: CF_factor, TR_factor
     type(flavor_t) :: flv
     allocate (CF_factor (size (flv_born, 1), size (flv_born, 2)), &
          TR_factor (size (flv_born, 1), size (flv_born, 2)))
     TR_sum = 0
     select case (char (nlo_corr_type))
     case ("QCD")
        CA_factor = CA; CF_factor = CF; TR_factor = TR
        nf = real(nf_input, default)
        TR_sum = nf * TR
     case ("EW")
        CA_factor = zero
        do i_flv = 1, size (flv_born, 2)
           do i_part = 1, size (flv_born, 1)
              call flv%init (flv_born(i_part, i_flv), model)
              CF_factor(i_part, i_flv) = (flv%get_charge ())**2
              TR_factor(i_part, i_flv) = (flv%get_charge ())**2
              if (is_quark (flv_born (i_part, i_flv))) &
                   TR_factor(i_part, i_flv) = NC * TR_factor(i_part, i_flv)
           end do
        end do
        do pdg = 1, nf_input
           field => model%get_field_ptr (pdg)
           TR_sum = TR_sum + NC*field%get_charge()**2
        end do
        do pdg = 11, 15, 2
           field => model%get_field_ptr (pdg)
           if (field%get_mass() > 0) exit
           TR_sum = TR_sum + field%get_charge()**2
        end do
     end select
     do i_flv = 1, size (flv_born, 2)
        do i_part = 1, size (flv_born, 1)
           if (is_massless_vectorboson (flv_born(i_part, i_flv), nlo_corr_type)) then
              virt%gamma_0(i_part, i_flv) = 11._default / 6._default * CA_factor &
                   - two / three * TR_sum
              virt%gamma_p(i_part, i_flv) = (67._default / 9._default &
                   - two * pi**2 / three) * CA_factor &
                   - 23._default / 9._default * TR_sum
              virt%c_flv(i_part, i_flv) = CA_factor
           else if (is_corresponding_fermion (flv_born(i_part, i_flv), nlo_corr_type)) then
              virt%gamma_0(i_part, i_flv) = 1.5_default * CF_factor(i_part, i_flv)
              virt%gamma_p(i_part, i_flv) = (6.5_default - two * pi**2 / three) * CF_factor(i_part, i_flv)
              virt%c_flv(i_part, i_flv) = CF_factor(i_part, i_flv)
           else if (is_massive_vectorboson (flv_born(i_part, i_flv), nlo_corr_type)) then
              virt%gamma_0(i_part, i_flv) = zero
              virt%gamma_p(i_part, i_flv) = zero
              virt%c_flv(i_part, i_flv) = CF_factor(i_part, i_flv)
           else
              virt%gamma_0(i_part, i_flv) = zero
              virt%gamma_p(i_part, i_flv) = zero
              virt%c_flv(i_part, i_flv) = zero
           end if
        end do
     end do
   contains
     function is_massless_vectorboson (pdg_nr, nlo_corr_type)
       logical :: is_massless_vectorboson
       integer, intent(in) :: pdg_nr
       type(string_t), intent(in) :: nlo_corr_type
       is_massless_vectorboson = .false.
       if (nlo_corr_type == "QCD") then
          is_massless_vectorboson = is_gluon (pdg_nr)
       else if (nlo_corr_type == "EW") then
          is_massless_vectorboson = is_photon (pdg_nr)
       end if
     end function is_massless_vectorboson
     function is_corresponding_fermion (pdg_nr, nlo_corr_type)
       logical :: is_corresponding_fermion
       integer, intent(in) :: pdg_nr
       type(string_t), intent(in) :: nlo_corr_type
       is_corresponding_fermion = .false.
       if (nlo_corr_type == "QCD") then
          is_corresponding_fermion = is_quark (pdg_nr)
       else if (nlo_corr_type == "EW") then
          is_corresponding_fermion = is_fermion (pdg_nr)
       end if
     end function is_corresponding_fermion
     function is_massive_vectorboson (pdg_nr, nlo_corr_type)
       logical :: is_massive_vectorboson
       integer, intent(in) :: pdg_nr
       type(string_t), intent(in) :: nlo_corr_type
       is_massive_vectorboson = .false.
       if (nlo_corr_type == "EW") then
          is_massive_vectorboson = is_massive_vector (pdg_nr)
       end if
     end function is_massive_vectorboson
   end subroutine virtual_init_constants
 
 @ %def virtual_init_constants
 @ Set the renormalization scale. If the input is zero, use the
 center-of-mass energy.
 <<virtual: virtual: TBP>>=
   procedure :: set_ren_scale => virtual_set_ren_scale
 <<virtual: procedures>>=
   subroutine virtual_set_ren_scale (virt, p, ren_scale)
     class(virtual_t), intent(inout) :: virt
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: ren_scale
     if (ren_scale > 0) then
       virt%ren_scale2 = ren_scale**2
     else
       virt%ren_scale2 = (p(1) + p(2))**2
     end if
   end subroutine virtual_set_ren_scale
 
 @ %def virtual_set_ren_scale
 @
 <<virtual: virtual: TBP>>=
   procedure :: set_fac_scale => virtual_set_fac_scale
 <<virtual: procedures>>=
   subroutine virtual_set_fac_scale (virt, p, fac_scale)
     class(virtual_t), intent(inout) :: virt
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), optional :: fac_scale
     if (present (fac_scale)) then
        virt%fac_scale = fac_scale
     else
        virt%fac_scale = (p(1) + p(2))**1
     end if
   end subroutine virtual_set_fac_scale
 
 @ %def virtual_set_fac_scale
 <<virtual: virtual: TBP>>=
   procedure :: set_ellis_sexton_scale => virtual_set_ellis_sexton_scale
 <<virtual: procedures>>=
   subroutine virtual_set_ellis_sexton_scale (virt, Q)
     class(virtual_t), intent(inout) :: virt
     real(default), intent(in) :: Q
     virt%es_scale2 = Q * Q
   end subroutine virtual_set_ellis_sexton_scale
 
 @ %def virtual_set_ellis_sexton_scale
 @ The virtual-subtracted matrix element is given by the equation
 \begin{equation}
   \label{eqn:virt_sub}
   \mathcal{V} = \frac{\alpha_s}{2\pi}\left(\mathcal{Q}\mathcal{B} +
   \sum \mathcal{I}_{ij}\mathcal{B}_{ij} + \mathcal{V}_{fin}\right),
 \end{equation}
 The expressions for $\mathcal{Q}$ can be found in equations \ref{eqn:virt_Q_isr}
 and \ref{eqn:virt_Q_fsr}.
 The expressions for $\mathcal{I}_{ij}$ can be found in equations
 (\ref{I_00}), (\ref{I_mm}), (\ref{I_0m}), depending on whether the
 particles involved in the radiation process are massive or massless.
 
 If two or more flavor structures would produce the same amplitude we only compute
 one and use the [[eqv_index]] to copy the result to the others (if [[reuse_amplitudes_fks]]
 is true).
 <<virtual: virtual: TBP>>=
   procedure :: evaluate => virtual_evaluate
 <<virtual: procedures>>=
   subroutine virtual_evaluate (virt, reg_data, alpha_coupling, &
          p_born, separate_uborns, sqme_virt)
     class(virtual_t), intent(inout) :: virt
     type(region_data_t), intent(in) :: reg_data
     real(default), intent(in) :: alpha_coupling
     type(vector4_t), intent(in), dimension(:)  :: p_born
     logical, intent(in) :: separate_uborns
     real(default), dimension(:), intent(inout) :: sqme_virt
     integer, dimension(:), allocatable :: eqv_flv_index
     real(default), dimension(:), allocatable :: sqme_virt_arr
     real(default) :: s, s_o_Q2
     real(default), dimension(reg_data%n_flv_born) :: QB, BI
     integer :: i_flv, ii_flv
     logical, dimension(:), allocatable :: flv_evaluated
     QB = zero; BI = zero
     allocate (flv_evaluated(reg_data%n_flv_born))
     allocate (sqme_virt_arr(reg_data%n_flv_born))
     sqme_virt_arr = zero
     flv_evaluated = .false.
     if (virt%bad_point) return
     if (debug2_active (D_VIRTUAL)) then
        print *, 'Compute virtual component using alpha = ', alpha_coupling
        print *, 'Virtual selection: ', char (virt%selection)
        print *, 'virt%es_scale2 =    ', virt%es_scale2 !!! Debugging
     end if
     s = sum (p_born(1 : virt%n_in))**2
     if (virt%settings%factorization_mode == FACTORIZATION_THRESHOLD) &
          call set_s_for_threshold ()
     s_o_Q2 = s / virt%es_scale2 * virt%settings%fks_template%xi_cut**2
     eqv_flv_index = reg_data%eqv_flv_index_born
     do i_flv = 1, reg_data%n_flv_born
        if (.not. flv_evaluated(eqv_flv_index(i_flv))) then
           if (virt%selection == var_str ("Full") .or. virt%selection == var_str ("OLP")) then
              !!! A factor of alpha_coupling/twopi is assumed to be included in vfin
              sqme_virt_arr(i_flv) = sqme_virt_arr(i_flv) + virt%sqme_virt_fin(i_flv)
           end if
           if (virt%selection == var_str ("Full") .or. &
                virt%selection == var_str ("Subtraction")) then
              call virt%evaluate_initial_state (i_flv, QB)
              call virt%compute_collinear_contribution (i_flv, p_born, sqrt(s), reg_data, QB)
              select case (virt%settings%factorization_mode)
              case (FACTORIZATION_THRESHOLD)
                 call virt%compute_eikonals_threshold (i_flv, p_born, s_o_Q2, QB, BI)
              case default
                 call virt%compute_massive_self_eikonals (i_flv, p_born, s_o_Q2, reg_data, QB)
                 call virt%compute_eikonals (i_flv, p_born, s_o_Q2, reg_data, BI)
              end select
              if (debug2_active (D_VIRTUAL)) then
                 print *, 'Evaluate i_flv: ', i_flv
                 print *, 'sqme_born: ', virt%sqme_born (i_flv)
                 print *, 'Q * sqme_born: ', alpha_coupling / twopi * QB(i_flv)
                 print *, 'BI: ', alpha_coupling / twopi * BI(i_flv)
                 print *, 'vfin: ', virt%sqme_virt_fin (i_flv)
              end if
              sqme_virt_arr(i_flv) = &
                   sqme_virt_arr(i_flv) + alpha_coupling / twopi * (QB(i_flv) + BI(i_flv))
           end if
           if (.not. (debug_active (D_VIRTUAL) .or. &
                debug2_active (D_VIRTUAL))) flv_evaluated(eqv_flv_index(i_flv)) = .true.
        else
           sqme_virt_arr(i_flv) = sqme_virt_arr(eqv_flv_index(i_flv))
        end if
        if (separate_uborns) then
           sqme_virt(i_flv) = sqme_virt(i_flv) + sqme_virt_arr(i_flv)
        else
           sqme_virt(1) = sqme_virt(1) + sqme_virt_arr(i_flv)
        end if
     end do
     if (debug2_active (D_VIRTUAL)) then
        call msg_debug2 (D_VIRTUAL, "virtual-subtracted matrix element(s): ")
        print *, sqme_virt
     end if
     do i_flv = 1, reg_data%n_flv_born
        if (virt%n_is_neutrinos(i_flv) > 0) &
             sqme_virt = sqme_virt * virt%n_is_neutrinos(i_flv) * two
     end do
   contains
     subroutine set_s_for_threshold ()
       use ttv_formfactors, only: m1s_to_mpole
       real(default) :: mtop2
       mtop2 = m1s_to_mpole (sqrt(s))**2
       if (s < four * mtop2) s = four * mtop2
     end subroutine set_s_for_threshold
 
   end subroutine virtual_evaluate
 
 @ %def virtual_evaluate
 @
 <<virtual: virtual: TBP>>=
   procedure :: compute_eikonals => virtual_compute_eikonals
 <<virtual: procedures>>=
   subroutine virtual_compute_eikonals (virtual, i_flv, &
            p_born, s_o_Q2, reg_data, BI)
     class(virtual_t), intent(inout) :: virtual
     integer, intent(in) :: i_flv
     type(vector4_t), intent(in), dimension(:)  :: p_born
     real(default), intent(in) :: s_o_Q2
     type(region_data_t), intent(in) :: reg_data
     real(default), intent(inout), dimension(:) :: BI
     integer :: i, j
     real(default) :: I_ij, BI_tmp
     BI_tmp = zero
     ! TODO vincent_r: Split the procedure into one computing QCD eikonals and one computing QED eikonals.
     ! TODO vincent_r: In the best case, remove the dependency on reg_data completely.
     associate (flst_born => reg_data%flv_born(i_flv), &
             nlo_corr_type => reg_data%regions(1)%nlo_correction_type)
        do i = 1, virtual%n_legs
           do j = 1, virtual%n_legs
              if (i /= j) then
                 if (nlo_corr_type == "QCD") then
                    if (flst_born%colored(i) .and. flst_born%colored(j)) then
                       I_ij = compute_eikonal_factor (p_born, flst_born%massive, &
                            i, j, s_o_Q2)
                       BI_tmp = BI_tmp + virtual%sqme_color_c (i, j, i_flv) * I_ij
                       if (debug2_active (D_VIRTUAL)) &
                            print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
                    end if
                 else if (nlo_corr_type == "EW") then
                    I_ij = compute_eikonal_factor (p_born, flst_born%massive, &
                         i, j, s_o_Q2)
                    BI_tmp = BI_tmp + virtual%sqme_charge_c (i, j, i_flv) * I_ij
                    if (debug2_active (D_VIRTUAL)) &
                         print *, 'b_ij: ', virtual%sqme_charge_c (i, j, i_flv), 'I_ij: ', I_ij
                 end if
              else if (debug2_active (D_VIRTUAL)) then
                 if (nlo_corr_type == "QCD") then
                    print *, 'b_ij: ', i, j, virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
                 else if (nlo_corr_type == "EW") then
                    print *, 'b_ij: ', i, j, virtual%sqme_charge_c (i, j, i_flv), 'I_ij: ', I_ij
                 end if
              end if
           end do
        end do
        if (virtual%settings%use_internal_color_correlations .or. nlo_corr_type == "EW") &
             BI_tmp = BI_tmp * virtual%sqme_born (i_flv)
     end associate
     BI(i_flv) = BI(i_flv) + BI_tmp
   end subroutine virtual_compute_eikonals
 
 @ %def virtual_compute_eikonals
 @
 <<virtual: virtual: TBP>>=
   procedure :: compute_eikonals_threshold => virtual_compute_eikonals_threshold
 <<virtual: procedures>>=
   subroutine virtual_compute_eikonals_threshold (virtual, i_flv, &
          p_born, s_o_Q2, QB, BI)
     class(virtual_t), intent(in) :: virtual
     integer, intent(in) :: i_flv
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: s_o_Q2
     real(default), intent(inout), dimension(:) :: QB
     real(default), intent(inout), dimension(:) :: BI
     type(vector4_t), dimension(4) :: p_thr
     integer :: leg
     BI = zero; p_thr = get_threshold_momenta (p_born)
     call compute_massive_self_eikonals (virtual%sqme_born(i_flv), QB(i_flv))
     do leg = 1, 2
        BI(i_flv) = BI(i_flv) + evaluate_leg_pair (ASSOCIATED_LEG_PAIR(leg), i_flv)
     end do
   contains
     subroutine compute_massive_self_eikonals (sqme_born, QB)
       real(default), intent(in) :: sqme_born
       real(default), intent(inout) :: QB
       integer :: i
       if (debug_on) call msg_debug2 (D_VIRTUAL, "compute_massive_self_eikonals")
       if (debug_on) call msg_debug2 (D_VIRTUAL, "s_o_Q2", s_o_Q2)
       if (debug_on) call msg_debug2 (D_VIRTUAL, "log (s_o_Q2)", log (s_o_Q2))
       do i = 1, 4
          QB = QB - (cf * (log (s_o_Q2) - 0.5_default * I_m_eps (p_thr(i)))) &
               * sqme_born
       end do
     end subroutine compute_massive_self_eikonals
 
     function evaluate_leg_pair (i_start, i_flv) result (b_ij_times_I)
       real(default) :: b_ij_times_I
       integer, intent(in) :: i_start, i_flv
       real(default) :: I_ij
       integer :: i, j
       b_ij_times_I = zero
       do i = i_start, i_start + 1
          do j = i_start, i_start + 1
             if (i /= j) then
                I_ij = compute_eikonal_factor &
                     (p_thr, [.true., .true., .true., .true.], i, j, s_o_Q2)
                b_ij_times_I = b_ij_times_I + &
                     virtual%sqme_color_c (i, j, i_flv) * I_ij
                if (debug2_active (D_VIRTUAL)) &
                   print *, 'b_ij: ', virtual%sqme_color_c (i, j, i_flv), 'I_ij: ', I_ij
             end if
          end do
       end do
       if (virtual%settings%use_internal_color_correlations) &
            b_ij_times_I = b_ij_times_I * virtual%sqme_born (i_flv)
       if (debug2_active (D_VIRTUAL)) then
          print *, 'internal color: ', virtual%settings%use_internal_color_correlations
          print *, 'b_ij_times_I =    ', b_ij_times_I
          print *, 'QB           =    ', QB
       end if
     end function evaluate_leg_pair
   end subroutine virtual_compute_eikonals_threshold
 
 @ %def virtual_compute_eikonals_threshold
 @
 <<virtual: virtual: TBP>>=
   procedure :: set_bad_point => virtual_set_bad_point
 <<virtual: procedures>>=
   subroutine virtual_set_bad_point (virt, value)
      class(virtual_t), intent(inout) :: virt
      logical, intent(in) :: value
      virt%bad_point = value
   end subroutine virtual_set_bad_point
 
 @  %def virtual_set_bad_point
 @ The collinear limit of $\tilde{\mathcal{R}}$ can be integrated over the radiation
 degrees of freedom, giving the collinear contribution to the virtual component. Its
 general structure is $\mathcal{Q} \cdot \mathcal{B}$. The initial-state contribution
 to $\mathcal{Q}$ is simply given by
 \begin{equation}
   \label{eqn:virt_Q_isr}
   \mathcal{Q} = -\log\frac{\mu_F^2}{Q^2} \left(\gamma(\mathcal{I}_1) + 2 C (\mathcal{I}_1) \log(\xi_{\text{cut}}) + \gamma(\mathcal{I}_2) + 2 C (\mathcal{I}_2) \log(\xi_{\text{cut}}) \right),
 \end{equation}
 where $Q^2$ is the Ellis-Sexton scale and $\gamma$ is as in eqns. \ref{eqn:gamma(q)}
 and \ref{eqn:gamma(g)}.\\
 [[virtual_evaluate_initial_state]] computes this quantity. The loop over the
 initial-state particles is only executed if we are
 dealing with a scattering process, because for decays there are no virtual
 initial-initial interactions.
 <<virtual: virtual: TBP>>=
   procedure :: evaluate_initial_state => virtual_evaluate_initial_state
 <<virtual: procedures>>=
   subroutine virtual_evaluate_initial_state (virt, i_flv, QB)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in) :: i_flv
     real(default), intent(inout), dimension(:) :: QB
     integer :: i
     if (virt%n_in == 2) then
        do i = 1, virt%n_in
           QB(i_flv) = QB(i_flv) - (virt%gamma_0 (i, i_flv) + two * virt%c_flv(i, i_flv) &
                * log (virt%settings%fks_template%xi_cut)) &
                * log(virt%fac_scale**2 / virt%es_scale2) * virt%sqme_born (i_flv)
        end do
     end if
   end subroutine virtual_evaluate_initial_state
 
 @ %def virtual_evaluate_initial_state
 @ Same as above, but for final-state particles. The collinear limit for final-state
 particles follows from the integral
 \begin{equation*}
   I_{+,\alpha_r} = \int d\Phi_{n+1} \frac{\xi_+^{-1-2\epsilon}}{\xi^{-1-2\epsilon}} \mathcal{R}_{\alpha_r}.
 \end{equation*}
 We can distinguish three situations:
 \begin{enumerate}
   \item $\alpha_r$ contains a massive emitter. In this case, no collinear subtraction term is required and
         the integral above is irrelevant.
   \item $\alpha_r$ contains a massless emitter, but resonances are not taken into account in the subtraction.
         Here, $\xi_{max} = \frac{2E_{em}}{\sqrt{s}}$ is the upper bound on $\xi$.
   \item $\alpha_r$ contains a massless emitter and resonance-aware subtraction is used. Here,
         $\xi_{max} = \frac{2E_{em}}{\sqrt{k_{res}^2}}$.
 \end{enumerate}
 Before version 2.4, only situations 1 and 2 were covered. The difference between situation 2 and 3 comes
 from the expansion of the plus-distribution in the integral above,
 \begin{equation*}
   \xi_+^{-1-2\epsilon} = \xi^{-1-2\epsilon} + \frac{1}{2\epsilon}\delta(\xi)
        = \xi_{max}^{-1-2\epsilon}\left[(1-z)^{-1-2\epsilon} + \frac{\xi_{max}^{2\epsilon}}{2\epsilon}\delta(1-z)\right].
 \end{equation*}
 The expression from the standard FKS literature is given by
 $\mathcal{Q}$ is given by
 \begin{equation}
   \label{eqn:virt_Q_fsr_old}
   \begin{split}
    \mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k)
         - \log\frac{s\delta_o}{2Q^2}\left(\gamma(\mathcal{I}_k)
         - 2C(\mathcal{I}_k) \log\frac{2E_k}{\xi_{\text{cut}}\sqrt{s}}\right) \right.\\
         + \left. 2C(\mathcal{I}_k) \left( \log^2\frac{2E_k}{\sqrt{s}} - \log^2 \xi_{\text{cut}} \right)
         - 2\gamma(\mathcal{I}_k)\log\frac{2E_k}{\sqrt{s}}\right].
   \end{split}
 \end{equation}
 $n_L^{(B)}$ is the number of legs at Born level.
 Here, $\xi_{max}$ is implicitly present in the ratios in the logarithms. Using the resonance-aware $\xi_{max}$ yields
 \begin{equation}
   \label{eqn:virt_Q_fsr}
   \begin{split}
     \mathcal{Q} = \sum_{k=n_{in}}^{n_L^{(B)}} \left[\gamma'(\mathcal{I}_k)
          + 2\left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max}\right)
            \left(\log\frac{\sqrt{s}}{2E_{em}} + \log\xi_{max} + \log\frac{Q^2}{s}\right) C(\mathcal{I}_k) \right.\\
          + \left. 2 \log\xi_{max} \left(\log\xi_{max} - \log\frac{Q^2}{k_{res}^2}\right) C(\mathcal{I}_k)
          + \left(\log\frac{Q^2}{k_{res}^2} - 2 \log\xi_{max}\right) \gamma(\mathcal{I}_k)\right].
   \end{split}
 \end{equation}
 Equation \ref{eqn:virt_Q_fsr} leads to \ref{eqn:virt_Q_fsr_old} with the substitutions $\xi_{max} \rightarrow \frac{2E_{em}}{\sqrt{s}}$ and $k_{res}^2 \rightarrow s$.
 [[virtual_compute_collinear_contribution]] only implements the second one.
 <<virtual: virtual: TBP>>=
   procedure :: compute_collinear_contribution &
      => virtual_compute_collinear_contribution
 <<virtual: procedures>>=
   subroutine virtual_compute_collinear_contribution (virt, i_flv, &
            p_born, sqrts, reg_data, QB)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in) :: i_flv
     type(vector4_t), dimension(:), intent(in) :: p_born
     real(default), intent(in) :: sqrts
     type(region_data_t), intent(in) :: reg_data
     real(default), intent(inout), dimension(:) :: QB
     real(default) :: s1, s2, s3, s4, s5
     integer :: alr, em
     real(default) :: E_em, xi_max, log_xi_max, E_tot2
     logical, dimension(virt%n_flv, virt%n_legs) :: evaluated
     integer :: i_contr
     type(vector4_t) :: k_res
     type(lorentz_transformation_t) :: L_to_resonance
     evaluated = .false.
     do alr = 1, reg_data%n_regions
        if (i_flv /= reg_data%regions(alr)%uborn_index) cycle
        em = reg_data%regions(alr)%emitter
        if (em <= virt%n_in) cycle
        if (evaluated(i_flv, em)) cycle
        !!! Collinear terms only for massless particles
        if (reg_data%regions(alr)%flst_uborn%massive(em)) cycle
        E_em = p_born(em)%p(0)
        if (allocated (reg_data%alr_contributors)) then
           i_contr = reg_data%alr_to_i_contributor (alr)
           k_res = get_resonance_momentum (p_born, reg_data%alr_contributors(i_contr)%c)
           E_tot2 = k_res%p(0)**2
           L_to_resonance = inverse (boost (k_res, k_res**1))
           xi_max = two * space_part_norm (L_to_resonance * p_born(em)) / k_res%p(0)
        else
           E_tot2 = sqrts**2
           xi_max = two * E_em / sqrts
        end if
        log_xi_max = log (xi_max)
        associate (xi_cut => virt%settings%fks_template%xi_cut, delta_o => virt%settings%fks_template%delta_o)
          if (virt%settings%virtual_resonance_aware_collinear) then
             if (debug_active (D_VIRTUAL)) &
                  call msg_debug (D_VIRTUAL, "Using resonance-aware collinear subtraction")
             s1 = virt%gamma_p(em, i_flv)
             s2 = two * (log (sqrts / (two * E_em)) + log_xi_max) * &
                  (log (sqrts / (two * E_em)) + log_xi_max + log (virt%es_scale2 / sqrts**2)) &
                  * virt%c_flv(em, i_flv)
             s3 = two * log_xi_max * &
                  (log_xi_max - log (virt%es_scale2 / E_tot2)) * virt%c_flv(em, i_flv)
             s4 = (log (virt%es_scale2 / E_tot2) - two * log_xi_max) * virt%gamma_0(em, i_flv)
             QB(i_flv) = QB(i_flv) + (s1 + s2 + s3 + s4) * virt%sqme_born(i_flv)
          else
             if (debug_active (D_VIRTUAL)) &
                  call msg_debug (D_VIRTUAL, "Using old-fashioned collinear subtraction")
             s1 = virt%gamma_p(em, i_flv)
             s2 = log (delta_o * sqrts**2 / (two * virt%es_scale2)) * virt%gamma_0(em,i_flv)
             s3 = log (delta_o * sqrts**2 / (two * virt%es_scale2)) * two * virt%c_flv(em,i_flv) * &
                  log (two * E_em / (xi_cut * sqrts))
             ! s4 = two * virt%c_flv(em,i_flv) * (log (two * E_em / sqrts)**2 - log (xi_cut)**2)
             s4 = two * virt%c_flv(em,i_flv) * & ! a**2 - b**2 = (a - b) * (a + b), for better numerical performance
                  (log (two * E_em / sqrts) + log (xi_cut)) * (log (two * E_em / sqrts) - log (xi_cut))
             s5 = two * virt%gamma_0(em,i_flv) * log (two * E_em / sqrts)
             QB(i_flv) = QB(i_flv) + (s1 - s2 + s3 + s4 - s5) * virt%sqme_born(i_flv)
          end if
        end associate
        evaluated(i_flv, em) = .true.
     end do
   end subroutine virtual_compute_collinear_contribution
 
 @ %def virtual_compute_collinear_contribution
 @ For the massless-massive case and $i = j$ we get the massive self-eikonal of (A.10) in arXiv:0908.4272, given as
 \begin{equation}
   \mathcal{I}_{ii} = \log \frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{\beta} \log \frac{1 + \beta}{1 - \beta}.
 \end{equation}
 <<virtual: virtual: TBP>>=
   procedure :: compute_massive_self_eikonals => virtual_compute_massive_self_eikonals
 <<virtual: procedures>>=
   subroutine virtual_compute_massive_self_eikonals (virt, i_flv, &
            p_born, s_over_Q2, reg_data,  QB)
     class(virtual_t), intent(inout) :: virt
     integer, intent(in) :: i_flv
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: s_over_Q2
     type(region_data_t), intent(in) :: reg_data
     real(default), intent(inout), dimension(:) :: QB
     integer :: i
     logical :: massive
     do i = 1, virt%n_legs
        massive = reg_data%flv_born(i_flv)%massive(i)
        if (massive) then
           QB(i_flv) = QB(i_flv) - (virt%c_flv (i, i_flv) &
                * (log (s_over_Q2) - 0.5_default * I_m_eps (p_born(i)))) &
                * virt%sqme_born (i_flv)
        end if
     end do
   end subroutine virtual_compute_massive_self_eikonals
 
 @ %def virtual_compute_massive_self_eikonals
 @ The following code implements the $\mathcal{I}_{ij}$-function.
 The complete formulas can be found in arXiv:0908.4272 (A.1-A.17) and are also discussed in arXiv:1002.2581 in Appendix A.
 The implementation may differ in the detail from the formulas presented in the above paper.
 The parameter $\xi_{\text{cut}}$ is unphysically and cancels with appropriate factors in the real subtraction.
 We keep the additional parameter for debug usage.
 The implemented formulas are then defined as follows:
 \begin{itemize}
 \item[massless-massless case]
   $p^2 = 0, k^2 = 0,$
   \begin{equation}
     \begin{split}
     \mathcal{I}_{ij} &= \frac{1}{2}\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} + \log\frac{\xi^2_{\text{cut}}s}{Q^2}\log\frac{k_ik_j}{2E_iE_j} - \rm{Li}_2\left(\frac{k_ik_j}{2E_iE_j}\right) \\
                      &+ \frac{1}{2}\log^2\frac{k_ik_j}{2E_iE_j} - \log\left(1-\frac{k_ik_j}{2E_iE_j}\right) \log\frac{k_ik_j}{2E_iE_j}.
     \end{split}
     \label{I_00}
   \end{equation}
 \item[massive-massive case]
   $p^2 \neq 0, k^2 \neq 0,$
   \begin{equation}
      \mathcal{I}_{ij} = \frac{1}{2}I_0(k_i, k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j)
      \label{I_mm}
   \end{equation}
   with
   \begin{equation}
     I_0(k_i, k_j) = \frac{1}{\beta}\log\frac{1+\beta}{1-\beta}, \qquad \beta = \sqrt{1-\frac{k_i^2k_j^2}{(k_i \cdot k_j)^2}}
   \end{equation}
   and a rather involved expression for $I_\epsilon$:
   \begin{align}
     \allowdisplaybreaks
     I_\epsilon(k_i, k_j) &= \left(K(z_j)-K(z_i)\right) \frac{1-\vec{\beta_i}\cdot\vec{\beta_j}}{\sqrt{a(1-b)}}, \\
     \vec{\beta_i} &= \frac{\vec{k}_i}{k_i^0}, \\
     a &= \beta_i^2 + \beta_j^2 - 2\vec{\beta}_i \cdot \vec{\beta}_j, \\
     x_i &= \frac{\beta_i^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a}, \\
     x_j &= \frac{\beta_j^2 -\vec{\beta}_i \cdot \vec{\beta}_j}{a} = 1-x_j, \\
     b &= \frac{\beta_i^2\beta_j^2 - (\vec{\beta}_i\cdot\vec{\beta}_j)^2}{a}, \\
     c &= \sqrt{\frac{b}{4a}}, \\
     z_+ &= \frac{1+\sqrt{1-b}}{\sqrt{b}}, \\
     z_- &= \frac{1-\sqrt{1-b}}{\sqrt{b}}, \\
     z_i &= \frac{\sqrt{x_i^2 + 4c^2} - x_i}{2c}, \\
     z_j &= \frac{\sqrt{x_j^2 + 4c^2} + x_j}{2c}, \\
     K(z) = &-\frac{1}{2}\log^2\frac{(z-z_-)(z_+-z)}{(z_++z)(z_-+z)} - 2Li_2\left(\frac{2z_-(z_+-z)}{(z_+-z_-)(z_-+z)}\right) \\
            &-2Li_2\left(-\frac{2z_+(z_-+z)}{(z_+-z_-)(z_+-z)}\right)
   \end{align}
 
 \item[massless-massive case]
   $p^2 = 0, k^2 \neq 0,$
   \begin{equation}
      \mathcal{I}_{ij} = \frac{1}{2}\left[\frac{1}{2}\log^2\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{\pi^2}{6}\right] + \frac{1}{2}I_0(k_i,k_j)\log\frac{\xi^2_{\text{cut}}s}{Q^2} - \frac{1}{2}I_\epsilon(k_i,k_j)
      \label{I_0m}
   \end{equation}
   with
   \begin{align}
      I_0(p,k) &= \log\frac{(\hat{p}\cdot\hat{k})^2}{\hat{k}^2}, \\
      I_\varepsilon(p,k) &= -2\left[\frac{1}{4}\log^2\frac{1-\beta}{1+\beta} + \log\frac{\hat{p}\cdot\hat{k}}{1+\beta}\log\frac{\hat{p}\cdot\hat{k}}{1-\beta} + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1+\beta}\right) + \rm{Li}_2\left(1-\frac{\hat{p}\cdot\hat{k}}{1-\beta}\right)\right],
   \end{align}
   using
   \begin{align}
     \hat{p} = \frac{p}{p^0}, \quad \hat{k} = \frac{k}{k^0}, \quad \beta = \frac{|\vec{k}|}{k_0}, \\
     \rm{Li}_2(1 - x) + \rm{Li}_2(1 - x^{-1}) = -\frac{1}{2} \log^2 x.
   \end{align}
 
 \end{itemize}
 
 <<virtual: procedures>>=
   function compute_eikonal_factor (p_born, massive, i, j, s_o_Q2) result (I_ij)
     real(default) :: I_ij
     type(vector4_t), intent(in), dimension(:) :: p_born
     logical, dimension(:), intent(in) :: massive
     integer, intent(in) :: i, j
     real(default), intent(in) :: s_o_Q2
     if (massive(i) .and. massive(j)) then
        I_ij = compute_Imm (p_born(i), p_born(j), s_o_Q2)
     else if (.not. massive(i) .and. massive(j)) then
        I_ij = compute_I0m (p_born(i), p_born(j), s_o_Q2)
     else if (massive(i) .and. .not. massive(j)) then
        I_ij = compute_I0m (p_born(j), p_born(i), s_o_Q2)
     else
        I_ij = compute_I00 (p_born(i), p_born(j), s_o_Q2)
     end if
   end function compute_eikonal_factor
 
   function compute_I00 (pi, pj, s_o_Q2) result (I)
     type(vector4_t), intent(in) :: pi, pj
     real(default), intent(in) :: s_o_Q2
     real(default) :: I
     real(default) :: Ei, Ej
     real(default) :: pij, Eij
     real(default) :: s1, s2, s3, s4, s5
     real(default) :: arglog
     real(default), parameter :: tiny_value = epsilon(1.0)
     s1 = 0; s2 = 0; s3 = 0; s4 = 0; s5 = 0
     Ei = pi%p(0); Ej = pj%p(0)
     pij = pi * pj; Eij = Ei * Ej
     s1 = 0.5_default * log(s_o_Q2)**2
     s2 = log(s_o_Q2) * log(pij / (two * Eij))
     s3 = Li2 (pij / (two * Eij))
     s4 = 0.5_default * log (pij / (two * Eij))**2
     arglog = one - pij / (two * Eij)
     if (arglog > tiny_value) then
       s5 = log(arglog) * log(pij / (two * Eij))
     else
       s5 = zero
     end if
     I = s1 + s2 - s3 + s4 - s5
   end function compute_I00
 
   function compute_I0m (ki, kj, s_o_Q2) result (I)
     type(vector4_t), intent(in) :: ki, kj
     real(default), intent(in) :: s_o_Q2
     real(default) :: I
     real(default) :: logsomu
     real(default) :: s1, s2, s3
     s1 = 0; s2 = 0; s3 = 0
     logsomu = log(s_o_Q2)
     s1 = 0.5 * (0.5 * logsomu**2 - pi**2 / 6)
     s2 = 0.5 * I_0m_0 (ki, kj) * logsomu
     s3 = 0.5 * I_0m_eps (ki, kj)
     I = s1 + s2 - s3
   end function compute_I0m
 
   function compute_Imm (pi, pj, s_o_Q2) result (I)
     type(vector4_t), intent(in) :: pi, pj
     real(default), intent(in) :: s_o_Q2
     real(default) :: I
     real(default) :: s1, s2
     s1 = 0.5 * log(s_o_Q2) * I_mm_0(pi, pj)
     s2 = 0.5 * I_mm_eps(pi, pj)
     I = s1 - s2
   end function compute_Imm
 
   function I_m_eps (p) result (I)
     type(vector4_t), intent(in) :: p
     real(default) :: I
     real(default) :: beta
     beta = space_part_norm (p)/p%p(0)
     if (beta < tiny_07) then
        I = four * (one + beta**2/3 + beta**4/5 + beta**6/7)
     else
        I = two * log((one + beta) / (one - beta)) / beta
     end if
   end function I_m_eps
 
   function I_0m_eps (p, k) result (I)
     type(vector4_t), intent(in) :: p, k
     real(default) :: I
     type(vector4_t) :: pp, kp
     real(default) :: beta
 
     pp = p / p%p(0); kp = k / k%p(0)
 
     beta = sqrt (one - kp*kp)
     I = -2*(log((one - beta) / (one + beta))**2/4 + log((pp*kp) / (one + beta))*log((pp*kp) / (one - beta)) &
         + Li2(one - (pp*kp) / (one + beta)) + Li2(one - (pp*kp) / (one - beta)))
   end function I_0m_eps
 
   function I_0m_0 (p, k) result (I)
     type(vector4_t), intent(in) :: p, k
     real(default) :: I
     type(vector4_t) :: pp, kp
 
     pp = p / p%p(0); kp = k / k%p(0)
     I = log((pp*kp)**2 / kp**2)
   end function I_0m_0
 
   function I_mm_eps (p1, p2) result (I)
     type(vector4_t), intent(in) :: p1, p2
     real(default) :: I
     type(vector3_t) :: beta1, beta2
     real(default) :: a, b, b2
     real(default) :: zp, zm, z1, z2, x1, x2
     real(default) :: zmb, z1b
     real(default) :: K1, K2
 
     beta1 = space_part (p1) / energy(p1)
     beta2 = space_part (p2) / energy(p2)
     a = beta1**2 + beta2**2 - 2 * beta1 * beta2
     b = beta1**2 * beta2**2 - (beta1 * beta2)**2
     if (beta1**1 > beta2**1) call switch_beta (beta1, beta2)
     if (beta1 == vector3_null) then
        b2 = beta2**1
        I = (-0.5 * log ((one - b2) / (one + b2))**2 - two * Li2 (-two * b2 / (one - b2))) &
            * one / sqrt (a - b)
        return
     end if
     x1 = beta1**2 - beta1 * beta2
     x2 = beta2**2 - beta1 * beta2
     zp = sqrt (a) + sqrt (a - b)
     zm = sqrt (a) - sqrt (a - b)
     zmb = one  / zp
     z1 = sqrt (x1**2 + b) - x1
     z2 = sqrt (x2**2 + b) + x2
     z1b = one / (sqrt (x1**2 + b) + x1)
     K1 = - 0.5 * log (((z1b - zmb) * (zp - z1)) / ((zp + z1) * (z1b + zmb)))**2 &
           - two * Li2 ((two * zmb * (zp - z1)) / ((zp - zm) * (zmb + z1b))) &
           - two * Li2 ((-two * zp * (zm + z1)) / ((zp - zm) * (zp - z1)))
     K2 = - 0.5 * log ((( z2 - zm) * (zp - z2)) / ((zp + z2) * (z2 + zm)))**2 &
           - two * Li2 ((two * zm * (zp - z2)) / ((zp - zm) * (zm + z2))) &
           - two * Li2 ((-two * zp * (zm + z2)) / ((zp - zm) * (zp - z2)))
     I = (K2 - K1) * (one - beta1 * beta2) / sqrt (a - b)
   contains
     subroutine switch_beta (beta1, beta2)
       type(vector3_t), intent(inout) :: beta1, beta2
       type(vector3_t) :: beta_tmp
       beta_tmp = beta1
       beta1 = beta2
       beta2 = beta_tmp
     end subroutine switch_beta
   end function I_mm_eps
 
   function I_mm_0 (k1, k2) result (I)
     type(vector4_t), intent(in) :: k1, k2
     real(default) :: I
     real(default) :: beta
     beta = sqrt (one - k1**2 * k2**2 / (k1 * k2)**2)
     I = log ((one + beta) / (one - beta)) / beta
   end function I_mm_0
 
 @ %def I_mm_0
 @
 <<virtual: virtual: TBP>>=
   procedure :: final => virtual_final
 <<virtual: procedures>>=
   subroutine virtual_final (virtual)
     class(virtual_t), intent(inout) :: virtual
     if (allocated (virtual%gamma_0)) deallocate (virtual%gamma_0)
     if (allocated (virtual%gamma_p)) deallocate (virtual%gamma_p)
     if (allocated (virtual%c_flv)) deallocate (virtual%c_flv)
     if (allocated (virtual%n_is_neutrinos)) deallocate (virtual%n_is_neutrinos)
   end subroutine virtual_final
 
 @ %def virtual_final
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Real Subtraction}
 <<[[real_subtraction.f90]]>>=
 <<File header>>
 
 module real_subtraction
 
 <<Use kinds with double>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use format_defs, only: FMT_15
   use string_utils
   use constants
   use numeric_utils
   use diagnostics
   use pdg_arrays
   use models
   use physics_defs
   use sm_physics
   use lorentz
   use flavors
   use phs_fks, only: real_kinematics_t, isr_kinematics_t
   use phs_fks, only: I_PLUS, I_MINUS
   use phs_fks, only: SQRTS_VAR, SQRTS_FIXED
   use phs_fks, only: phs_point_set_t
   use ttv_formfactors, only: m1s_to_mpole
 
   use fks_regions
   use nlo_data
 
 <<Standard module head>>
 
 <<real subtraction: public>>
 
 <<real subtraction: parameters>>
 
 <<real subtraction: types>>
 
 <<real subtraction: interfaces>>
 
 contains
 
 <<real subtraction: procedures>>
 
 end module real_subtraction
 @ %def real_subtraction
 @
 \subsubsection{Soft subtraction terms}
 <<real subtraction: parameters>>=
   integer, parameter, public :: INTEGRATION = 0
   integer, parameter, public :: FIXED_ORDER_EVENTS = 1
   integer, parameter, public :: POWHEG = 2
 
 @ %def real subtraction parameters
 @
 <<real subtraction: public>>=
   public :: this_purpose
 <<real subtraction: procedures>>=
   function this_purpose (purpose)
     type(string_t) :: this_purpose
     integer, intent(in) :: purpose
     select case (purpose)
     case (INTEGRATION)
        this_purpose = var_str ("Integration")
     case (FIXED_ORDER_EVENTS)
        this_purpose = var_str ("Fixed order NLO events")
     case (POWHEG)
        this_purpose = var_str ("Powheg events")
     case default
        this_purpose = var_str ("Undefined!")
     end select
   end function this_purpose
 
 @ %def this_purpose
 @
 In the soft limit, the real matrix element behaves as
 \begin{equation*}
   \mathcal{R}_{\rm{soft}} = 4\pi\alpha_s \left[\sum_{i \neq j}
   \mathcal{B}_{ij} \frac{k_i \cdot k_j}{(k_i \cdot k)(k_j \cdot k)}
    - \mathcal{B} \sum_{i} \frac{k_i^2}{(k_i \cdot k)^2}C_i\right],
 \end{equation*}
 where $k$ denotes the momentum of the emitted parton. The quantity $\mathcal{B}_{ij}$ is called the color-correlated Born matrix element defined as
 \begin{equation*}
   \mathcal{B}_{ij} = \frac{1}{2s} \sum_{\stackrel{colors}{spins}} \mathcal{M}_{\{c_k\}}\left(\mathcal{M}^\dagger_{\{c_k\}}\right)_{\stackrel{c_i \rightarrow c_i'}{c_j \rightarrow c_j'}} T^a_{c_i,c_i'} T^a_{c_j,c_j'}.
 \end{equation*}
 <<real subtraction: types>>=
   type :: soft_subtraction_t
     type(region_data_t), pointer :: reg_data => null ()
     real(default), dimension(:,:), allocatable :: momentum_matrix
     logical :: use_resonance_mappings = .false.
     type(vector4_t) :: p_soft = vector4_null
     logical :: use_internal_color_correlations = .true.
     logical :: use_internal_spin_correlations = .false.
     logical :: xi2_expanded = .true.
     integer :: factorization_mode = NO_FACTORIZATION
   contains
   <<real subtraction: soft sub: TBP>>
   end type soft_subtraction_t
 
 @ %def soft_subtraction_t
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: init => soft_subtraction_init
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_init (sub_soft, reg_data)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(region_data_t), intent(in), target :: reg_data
     sub_soft%reg_data => reg_data
     allocate (sub_soft%momentum_matrix (reg_data%n_legs_born, &
          reg_data%n_legs_born))
   end subroutine soft_subtraction_init
 
 @ %def soft_subtraction_init
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: requires_boost => soft_subtraction_requires_boost
 <<real subtraction: procedures>>=
   function soft_subtraction_requires_boost (sub_soft, sqrts) result (requires_boost)
     logical :: requires_boost
     class(soft_subtraction_t), intent(in) :: sub_soft
     real(default), intent(in) :: sqrts
     real(default) :: mtop
     logical :: above_threshold
     if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then
        mtop = m1s_to_mpole (sqrts)
        above_threshold = sqrts**2 - four * mtop**2 > zero
     else
        above_threshold = .false.
     end if
     requires_boost = sub_soft%use_resonance_mappings .or. above_threshold
   end function soft_subtraction_requires_boost
 
 @ %def soft_subtraction_requires_boost
 @ The treatment of the momentum $k$ follows the discussion about the
 soft limit of the partition functions (see [1002.2581], p. 29 and
 C. Weiss' PhD Thesis, p. 24).  The parton momentum is
 pulled out, $k = E \hat{k}$. In fact, we will substitute $\hat{k}$ for
 $k$ throughout the code, because the energy will factor out of the
 equation when the soft $\mathcal{S}$-function is multiplied.  The
 momentum [[p_soft]] represents the soft limit of the radiated particle
 divided by its energy. It is a unit vector, because
 $k^2 = \left(k^0\right)^2 - \left(k^0\right)^2\hat{\vec{k}}^2 = 0$.
 
 The soft momentum is constructed by first creating a unit vector
 parallel to the emitter's Born momentum. This unit vector is then
 rotated about the corresponding angles $y$ and $\phi$ to match
 the direction of the real radiation in the soft limit.
 <<real subtraction: soft sub: TBP>>=
   procedure :: create_softvec_fsr => soft_subtraction_create_softvec_fsr
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_create_softvec_fsr &
      (sub_soft, p_born, y, phi, emitter, xi_ref_momentum)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: y, phi
     integer, intent(in) :: emitter
     type(vector4_t), intent(in) :: xi_ref_momentum
     type(vector3_t) :: dir
     type(vector4_t) :: p_em
     type(lorentz_transformation_t) :: rot
     type(lorentz_transformation_t) :: boost_to_rest_frame
     logical :: requires_boost
     associate (p_soft => sub_soft%p_soft)
        p_soft%p(0) = one
        requires_boost = sub_soft%requires_boost (two * p_born(1)%p(0))
        if (requires_boost) then
           boost_to_rest_frame = inverse (boost (xi_ref_momentum, xi_ref_momentum**1))
           p_em = boost_to_rest_frame * p_born(emitter)
        else
           p_em = p_born(emitter)
        end if
        p_soft%p(1:3) = p_em%p(1:3) / space_part_norm (p_em)
        dir = create_orthogonal (space_part (p_em))
        rot = rotation (y, sqrt(one - y**2), dir)
        p_soft = rot * p_soft
        if (.not. vanishes (phi)) then
          dir = space_part (p_em) / space_part_norm (p_em)
          rot = rotation (cos(phi), sin(phi), dir)
          p_soft = rot * p_soft
        end if
        if (requires_boost) p_soft = inverse (boost_to_rest_frame) * p_soft
     end associate
   end subroutine soft_subtraction_create_softvec_fsr
 
 @ %def soft_subtraction_create_softvec_fsr
 @ For initial-state emissions, the soft vector is just a unit vector
 with the same direction as the radiated particle.
 As $y$ for ISR is defined independently of the emitter, also [[p_soft]]
 is the same for all initial state emitters.
 <<real subtraction: soft sub: TBP>>=
   procedure :: create_softvec_isr => soft_subtraction_create_softvec_isr
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_create_softvec_isr (sub_soft, y, phi)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     real(default), intent(in) :: y, phi
     real(default) :: sin_theta
     sin_theta = sqrt(one - y**2)
     associate (p => sub_soft%p_soft%p)
        p(0) = one
        p(1) = sin_theta * sin(phi)
        p(2) = sin_theta * cos(phi)
        p(3) = y
     end associate
   end subroutine soft_subtraction_create_softvec_isr
 
 @ %def soft_subtraction_create_softvec_isr
 @ The soft vector for the real mismatch is basically the same as for usual FSR,
 except for the scaling with the total gluon energy. Moreover, the resulting
 vector is rotated into the frame where the 3-axis points along the direction
 of the emitter. This is necessary because in the collinear limit, the approximation
 \begin{equation*}
   k_i = \frac{k_i^0}{\bar{k}_j^0} \bar{k}_j = \frac{\xi\sqrt{s}}{2\bar{k}_j^0}\bar{k}_j
 \end{equation*}
 is used. The collinear limit is not included in the soft mismatch yet, but we keep
 the rotation for future usage here already (the performance loss is negligible).
 <<real subtraction: soft sub: TBP>>=
   procedure :: create_softvec_mismatch => &
      soft_subtraction_create_softvec_mismatch
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_create_softvec_mismatch (sub_soft, E, y, phi, p_em)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     real(default), intent(in) :: E, phi, y
     type(vector4_t), intent(in) :: p_em
     real(default) :: sin_theta
     type(lorentz_transformation_t) :: rot_em_off_3_axis
     sin_theta = sqrt (one - y**2)
     associate (p => sub_soft%p_soft%p)
        p(0) = E
        p(1) = E * sin_theta * sin(phi)
        p(2) = E * sin_theta * cos(phi)
        p(3) = E * y
     end associate
     rot_em_off_3_axis = rotation_to_2nd (3, space_part (p_em))
     sub_soft%p_soft = rot_em_off_3_axis * sub_soft%p_soft
   end subroutine soft_subtraction_create_softvec_mismatch
 
 @ %def soft_subtraction_create_softvec_mismatch
 @ Computation of the soft limit of $R_\alpha$. Note that what we are
 actually integrating (in the case of final-state radiation) is the
 quantity $f(0,y) / \xi$, where
 \begin{equation*}
   f(\xi,y) = \frac{J(\xi,y,\phi)}{\xi} \xi^2 R_\alpha.
 \end{equation*}
 $J/\xi$ is computed by the phase space generator. The additional factor
 of $\xi^{-1}$ is supplied in the [[evaluate_region_fsr]]-routine. Thus,
 we are left with a factor of $\xi^2$. A look on the expression for the
 soft limit of $R_\alpha$ below reveals that we are factoring out the gluon
 energy $E_i$ in the denominator. Therefore, we have a factor
 $\xi^2 / E_i^2 = 4 / q^2$.\\
 Note that the same routine is used also for the computation of the soft
 mismatch. There, the gluon energy is not factored out from the soft vector,
 so that we are left with the $\xi^2$-factor, which will eventually be
 cancelled out again. So, we just multiply with 1. Both cases are
 distinguished by the flag [[xi2_expanded]].
 
 Note that for the soft subtraction term, also the S functions are computed
 in the soft limit. The input momenta are thus the real momenta in the soft limit,
 i.e. the Born momenta given by [[p_born]].
 <<real subtraction: soft sub: TBP>>=
   procedure :: compute => soft_subtraction_compute
 <<real subtraction: procedures>>=
   function soft_subtraction_compute (sub_soft, p_born, &
      born_ij, y, q2, alpha_coupling, alr, emitter, i_res) result (sqme)
     real(default) :: sqme
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in), dimension(:,:) :: born_ij
     real(default), intent(in) :: y
     real(default), intent(in) :: q2, alpha_coupling
     integer, intent(in) :: alr, emitter, i_res
     real(default) :: s_alpha_soft
     real(default) :: kb
     real(default) :: xi2_factor
 
     if (.not. vector_set_is_cms (p_born, sub_soft%reg_data%n_in)) then
        call vector4_write_set (p_born, show_mass = .true., &
               check_conservation = .true.)
        call msg_fatal ("Soft subtraction: phase space point must be in CMS")
     end if
     if (debug2_active (D_SUBTRACTION)) then
        select case (char (sub_soft%reg_data%regions(alr)%nlo_correction_type))
        case ("QCD")
           print *, 'Compute soft subtraction using alpha_s = ', alpha_coupling
        case ("EW")
           print *, 'Compute soft subtraction using alpha_qed = ', alpha_coupling
        end select
     end if
 
     s_alpha_soft = sub_soft%reg_data%get_svalue_soft (p_born, &
          sub_soft%p_soft, alr, emitter, i_res)
     if (s_alpha_soft > one + tiny_07) call msg_fatal ("s_alpha_soft > 1!")
     if (debug2_active (D_SUBTRACTION)) &
          call msg_print_color ('s_alpha_soft', s_alpha_soft, COL_YELLOW)
     select case (sub_soft%factorization_mode)
     case (NO_FACTORIZATION)
        kb = sub_soft%evaluate_factorization_default (p_born, born_ij)
     case (FACTORIZATION_THRESHOLD)
        kb = sub_soft%evaluate_factorization_threshold (thr_leg(emitter), p_born, born_ij)
     end select
     if (debug_on) call msg_debug2 (D_SUBTRACTION, 'KB', kb)
     sqme = four * pi * alpha_coupling * s_alpha_soft * kb
     if (sub_soft%xi2_expanded) then
        xi2_factor = four / q2
     else
        xi2_factor = one
     end if
     if (emitter <= sub_soft%reg_data%n_in) then
        sqme = xi2_factor * (one - y**2) * sqme
     else
        sqme = xi2_factor * (one - y) * sqme
     end if
     if (sub_soft%reg_data%regions(alr)%double_fsr) sqme = sqme * two
   end function soft_subtraction_compute
 
 @ %def soft_subtraction_compute
 @ We loop over all external legs and do not take care to leave out non-colored
 ones because [[born_ij]] is constructed in such a way that it is only
 non-zero for colored entries.
 <<real subtraction: soft sub: TBP>>=
   procedure :: evaluate_factorization_default => &
      soft_subtraction_evaluate_factorization_default
 <<real subtraction: procedures>>=
   function soft_subtraction_evaluate_factorization_default &
      (sub_soft, p, born_ij) result (kb)
     real(default) :: kb
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in), dimension(:,:) :: born_ij
     integer :: i, j
     kb = zero
     call sub_soft%compute_momentum_matrix (p)
     do i = 1, size (p)
        do j = 1, size (p)
           kb = kb + sub_soft%momentum_matrix (i, j) * born_ij (i, j)
        end do
     end do
   end function soft_subtraction_evaluate_factorization_default
 
 @ %def soft_subtraction_evaluate_factorization_default
 @ We have to multiply this with $\xi^2(1-y)$. Further, when applying
 the soft $\mathcal{S}$-function, the energy of the radiated particle
 is factored out. Thus we have $\xi^2/E_{em}^2(1-y) = 4/q_0^2(1-y)$.
 Computes the quantity $\mathcal{K}_{ij} = \frac{k_i \cdot
 k_j}{(k_i\cdot k)(k_j\cdot k)}$.
 <<real subtraction: soft sub: TBP>>=
   procedure :: compute_momentum_matrix => &
        soft_subtraction_compute_momentum_matrix
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_compute_momentum_matrix &
        (sub_soft, p_born)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default) :: num, deno1, deno2
     integer :: i, j
     do i = 1, sub_soft%reg_data%n_legs_born
        do j = 1, sub_soft%reg_data%n_legs_born
           if (i <= j) then
              num = p_born(i) * p_born(j)
              deno1 = p_born(i) * sub_soft%p_soft
              deno2 = p_born(j) * sub_soft%p_soft
              sub_soft%momentum_matrix(i, j) = num / (deno1 * deno2)
           else
              !!! momentum matrix is symmetric.
             sub_soft%momentum_matrix(i, j) = sub_soft%momentum_matrix(j, i)
           end if
        end do
     end do
   end subroutine soft_subtraction_compute_momentum_matrix
 
 @ %def soft_subtraction_compute_momentum_matrx
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: evaluate_factorization_threshold => &
      soft_subtraction_evaluate_factorization_threshold
 <<real subtraction: procedures>>=
   function soft_subtraction_evaluate_factorization_threshold &
      (sub_soft, leg, p_born, born_ij) result (kb)
     real(default) :: kb
     class(soft_subtraction_t), intent(inout) :: sub_soft
     integer, intent(in) :: leg
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in), dimension(:,:) :: born_ij
     type(vector4_t), dimension(4) :: p
     p = get_threshold_momenta (p_born)
     kb = evaluate_leg_pair (ASSOCIATED_LEG_PAIR (leg))
     if (debug2_active (D_SUBTRACTION))  call show_debug ()
 
   contains
 
     function evaluate_leg_pair (i_start) result (kbb)
       real(default) :: kbb
       integer, intent(in) :: i_start
       integer :: i1, i2
       real(default) :: numerator, deno1, deno2
       kbb = zero
       do i1 = i_start, i_start + 1
          do i2 = i_start, i_start + 1
             numerator = p(i1) * p(i2)
             deno1 = p(i1) * sub_soft%p_soft
             deno2 = p(i2) * sub_soft%p_soft
             kbb = kbb +  numerator * born_ij (i1, i2) / deno1 / deno2
          end do
       end do
       if (debug2_active (D_SUBTRACTION)) then
          do i1 = i_start, i_start + 1
             do i2 = i_start, i_start + 1
                call msg_print_color('i1', i1, COL_PEACH)
                call msg_print_color('i2', i2, COL_PEACH)
                call msg_print_color('born_ij (i1,i2)', born_ij (i1,i2), COL_PINK)
                print *, 'Top momentum: ', p(1)%p
             end do
          end do
       end if
     end function evaluate_leg_pair
 
     subroutine show_debug ()
       integer :: i
       call msg_print_color ('soft_subtraction_evaluate_factorization_threshold', COL_GREEN)
       do i = 1, 4
          print *, 'sqrt(p(i)**2) =    ', sqrt(p(i)**2)
       end do
     end subroutine show_debug
 
   end function soft_subtraction_evaluate_factorization_threshold
 
 @ %def soft_subtraction_evaluate_factorization_threshold
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: i_xi_ref => soft_subtraction_i_xi_ref
 <<real subtraction: procedures>>=
   function soft_subtraction_i_xi_ref (sub_soft, alr, i_phs) result (i_xi_ref)
     integer :: i_xi_ref
     class(soft_subtraction_t), intent(in) :: sub_soft
     integer, intent(in) :: alr, i_phs
     if (sub_soft%use_resonance_mappings) then
        i_xi_ref = sub_soft%reg_data%alr_to_i_contributor (alr)
     else if (sub_soft%factorization_mode == FACTORIZATION_THRESHOLD) then
        i_xi_ref = i_phs
     else
        i_xi_ref = 1
     end if
   end function soft_subtraction_i_xi_ref
 
 @ %def soft_subtraction_i_xi_ref
 @
 <<real subtraction: soft sub: TBP>>=
   procedure :: final => soft_subtraction_final
 <<real subtraction: procedures>>=
   subroutine soft_subtraction_final (sub_soft)
     class(soft_subtraction_t), intent(inout) :: sub_soft
     if (associated (sub_soft%reg_data)) nullify (sub_soft%reg_data)
     if (allocated (sub_soft%momentum_matrix)) deallocate (sub_soft%momentum_matrix)
   end subroutine soft_subtraction_final
 
 @ %def soft_subtraction_final
 @
 \subsection{Soft mismatch}
 <<real subtraction: public>>=
   public :: soft_mismatch_t
 <<real subtraction: types>>=
   type :: soft_mismatch_t
     type(region_data_t), pointer :: reg_data => null ()
     real(default), dimension(:), allocatable :: sqme_born
     real(default), dimension(:,:,:), allocatable :: sqme_born_color_c
     real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c
     type(real_kinematics_t), pointer :: real_kinematics => null ()
     type(soft_subtraction_t) :: sub_soft
   contains
   <<real subtraction: soft mismatch: TBP>>
   end type soft_mismatch_t
 
 @ %def soft_mismatch_t
 @
 <<real subtraction: soft mismatch: TBP>>=
   procedure :: init => soft_mismatch_init
 <<real subtraction: procedures>>=
   subroutine soft_mismatch_init (soft_mismatch, reg_data, &
        real_kinematics, factorization_mode)
     class(soft_mismatch_t), intent(inout) :: soft_mismatch
     type(region_data_t), intent(in), target :: reg_data
     type(real_kinematics_t), intent(in), target :: real_kinematics
     integer, intent(in) :: factorization_mode
     soft_mismatch%reg_data => reg_data
     allocate (soft_mismatch%sqme_born (reg_data%n_flv_born))
     allocate (soft_mismatch%sqme_born_color_c (reg_data%n_legs_born, &
          reg_data%n_legs_born, reg_data%n_flv_born))
     allocate (soft_mismatch%sqme_born_charge_c (reg_data%n_legs_born, &
          reg_data%n_legs_born, reg_data%n_flv_born))
     call soft_mismatch%sub_soft%init (reg_data)
     soft_mismatch%sub_soft%xi2_expanded = .false.
     soft_mismatch%real_kinematics => real_kinematics
     soft_mismatch%sub_soft%factorization_mode = factorization_mode
   end subroutine soft_mismatch_init
 
 @ %def soft_mismatch_init
 @ Main routine to compute the soft mismatch. Loops over all singular regions.
 There, it first creates the soft vector, then the necessary soft real matrix element.
 These inputs are then used to get the numerical value of the soft mismatch.
 <<real subtraction: soft mismatch: TBP>>=
   procedure :: evaluate => soft_mismatch_evaluate
 <<real subtraction: procedures>>=
   function soft_mismatch_evaluate (soft_mismatch, alpha_s) result (sqme_mismatch)
     real(default) :: sqme_mismatch
     class(soft_mismatch_t), intent(inout) :: soft_mismatch
     real(default), intent(in) :: alpha_s
     integer :: alr, i_born, emitter, i_res, i_phs, i_con
     real(default) :: xi, y, q2, s
     real(default) :: E_gluon
     type(vector4_t) :: p_em
     real(default) :: sqme_alr, sqme_soft
     type(vector4_t), dimension(:), allocatable :: p_born
     sqme_mismatch = zero
     associate (real_kinematics => soft_mismatch%real_kinematics)
        xi = real_kinematics%xi_mismatch
        y = real_kinematics%y_mismatch
        s = real_kinematics%cms_energy2
        E_gluon = sqrt (s) * xi / two
 
        if (debug_active (D_MISMATCH)) then
           print *, 'Evaluating soft mismatch: '
           print *, 'Phase space: '
           call vector4_write_set (real_kinematics%p_born_cms%get_momenta(1), &
                show_mass = .true.)
           print *, 'xi: ', xi, 'y: ', y, 's: ', s, 'E_gluon: ', E_gluon
        end if
 
        allocate (p_born (soft_mismatch%reg_data%n_legs_born))
 
        do alr = 1, soft_mismatch%reg_data%n_regions
 
            i_phs = real_kinematics%alr_to_i_phs (alr)
            if (soft_mismatch%reg_data%has_pseudo_isr ()) then
               i_con = 1
               p_born = soft_mismatch%real_kinematics%p_born_onshell%get_momenta(1)
            else
               i_con = soft_mismatch%reg_data%alr_to_i_contributor (alr)
               p_born = soft_mismatch%real_kinematics%p_born_cms%get_momenta(1)
            end if
            q2 = real_kinematics%xi_ref_momenta(i_con)**2
            emitter = soft_mismatch%reg_data%regions(alr)%emitter
            p_em = p_born (emitter)
            i_res = soft_mismatch%reg_data%regions(alr)%i_res
            i_born = soft_mismatch%reg_data%regions(alr)%uborn_index
 
            call print_debug_alr ()
 
            call soft_mismatch%sub_soft%create_softvec_mismatch &
                 (E_gluon, y, real_kinematics%phi, p_em)
            if (debug_active (D_MISMATCH)) &
                 print *, 'Created soft vector: ', soft_mismatch%sub_soft%p_soft%p
 
            select type (fks_mapping => soft_mismatch%reg_data%fks_mapping)
            type is (fks_mapping_resonances_t)
               call fks_mapping%set_resonance_momentum &
                    (real_kinematics%xi_ref_momenta(i_con))
            end select
 
            sqme_soft = soft_mismatch%sub_soft%compute &
                 (p_born, soft_mismatch%sqme_born_color_c(:,:,i_born), y, &
                 q2, alpha_s, alr, emitter, i_res)
 
            sqme_alr = soft_mismatch%compute (alr, xi, y, p_em, &
                 real_kinematics%xi_ref_momenta(i_con), soft_mismatch%sub_soft%p_soft, &
                 soft_mismatch%sqme_born(i_born), sqme_soft, &
                 alpha_s, s)
 
            if (debug_on) call msg_debug (D_MISMATCH, 'sqme_alr: ', sqme_alr)
            sqme_mismatch = sqme_mismatch + sqme_alr
 
        end do
     end associate
   contains
     subroutine print_debug_alr ()
       if (debug_active (D_MISMATCH)) then
          print *, 'alr: ', alr
          print *, 'i_phs: ', i_phs, 'i_con: ', i_con, 'i_res: ', i_res
          print *, 'emitter: ', emitter, 'i_born: ', i_born
          print *, 'emitter momentum: ', p_em%p
          print *, 'resonance momentum: ', &
             soft_mismatch%real_kinematics%xi_ref_momenta(i_con)%p
          print *, 'q2: ', q2
       end if
     end subroutine print_debug_alr
   end function soft_mismatch_evaluate
 
 @ %def soft_mismatch_evaluate
 @ Computes the soft mismatch in a given $\alpha_r$,
 \begin{align*}
   I_{s+,\alpha_r} &= \int d\Phi_B \int_0^\infty d\xi \int_{-1}^1 dy \int_0^{2\pi} d\phi
      \frac{s\xi}{(4\pi)^3} \\
    &\times \left\lbrace\tilde{R}_{\alpha_r}
     \left(e^{-\frac{2k_\gamma \cdot k_{res}}{k_{res}}^2} - e^{-\xi}\right)
   - \frac{32 \pi \alpha_s C_{em}}{s\xi^2} B_{f_b(\alpha_r)} (1-y)^{-1}
     \left[e^{-\frac{2\bar{k}_{em} \cdot k_{res}}{k_{res}^2} \frac{k_\gamma^0}{k_{em}^0}} - e^{-\xi}\right]\right\rbrace.
 \end{align*}
 <<real subtraction: soft mismatch: TBP>>=
   procedure :: compute => soft_mismatch_compute
 <<real subtraction: procedures>>=
   function soft_mismatch_compute (soft_mismatch, alr, xi, y, p_em, p_res, p_soft, &
      sqme_born, sqme_soft, alpha_s, s) result (sqme_mismatch)
     real(default) :: sqme_mismatch
     class(soft_mismatch_t), intent(in) :: soft_mismatch
     integer, intent(in) :: alr
     real(default), intent(in) :: xi, y
     type(vector4_t), intent(in) :: p_em, p_res, p_soft
     real(default), intent(in) :: sqme_born, sqme_soft
     real(default), intent(in) :: alpha_s, s
     real(default) :: q2, expo, sm1, sm2, jacobian
 
     q2 = p_res**2
     expo = - two * p_soft * p_res / q2
     !!! Divide by 1 - y to factor out the corresponding
     !!! factor in the soft matrix element
     sm1 = sqme_soft / (one - y) * ( exp(expo) - exp(- xi) )
     if (debug_on) call msg_debug2 (D_MISMATCH, 'sqme_soft in mismatch ', sqme_soft)
 
     sm2 = zero
     if (soft_mismatch%reg_data%regions(alr)%has_collinear_divergence ()) then
        expo = - two * p_em * p_res / q2 * &
           p_soft%p(0) / p_em%p(0)
        sm2 = 32 * pi * alpha_s * cf / (s * xi**2) * sqme_born * &
           ( exp(expo) - exp(- xi) ) / (one - y)
     end if
 
     jacobian = soft_mismatch%real_kinematics%jac_mismatch * s * xi / (8 * twopi3)
     sqme_mismatch = (sm1 - sm2) * jacobian
 
   end function soft_mismatch_compute
 
 @ %def soft_mismatch_compute
 @
 <<real subtraction: soft mismatch: TBP>>=
   procedure :: final => soft_mismatch_final
 <<real subtraction: procedures>>=
   subroutine soft_mismatch_final (soft_mismatch)
     class(soft_mismatch_t), intent(inout) :: soft_mismatch
     call soft_mismatch%sub_soft%final ()
     if (associated (soft_mismatch%reg_data)) nullify (soft_mismatch%reg_data)
     if (allocated (soft_mismatch%sqme_born)) deallocate (soft_mismatch%sqme_born)
     if (allocated (soft_mismatch%sqme_born_color_c)) deallocate (soft_mismatch%sqme_born_color_c)
     if (allocated (soft_mismatch%sqme_born_charge_c)) deallocate (soft_mismatch%sqme_born_charge_c)
     if (associated (soft_mismatch%real_kinematics)) nullify (soft_mismatch%real_kinematics)
   end subroutine soft_mismatch_final
 
 @ %def soft_mismatch_final
 @
 \subsection{Collinear and soft-collinear subtraction terms}
 This data type deals with the calculation of the collinear and
 soft-collinear contribution to the cross section.
 <<real subtraction: public>>=
   public :: coll_subtraction_t
 <<real subtraction: types>>=
   type :: coll_subtraction_t
     integer :: n_in, n_alr
     logical :: use_resonance_mappings = .false.
     real(default) :: CA = 0, CF = 0, TR = 0
   contains
   <<real subtraction: coll sub: TBP>>
   end type coll_subtraction_t
 
 @ %def coll_subtraction_t
 @
 <<real subtraction: coll sub: TBP>>=
   procedure :: init => coll_subtraction_init
 <<real subtraction: procedures>>=
   subroutine coll_subtraction_init (coll_sub, n_alr, n_in)
     class(coll_subtraction_t), intent(inout) :: coll_sub
     integer, intent(in) :: n_alr, n_in
     coll_sub%n_in = n_in
     coll_sub%n_alr = n_alr
   end subroutine coll_subtraction_init
 
 @ %def coll_subtraction_init
 @ Set the corresponding algebra parameters of the underlying gauge group of the correction.
 <<real subtraction: coll sub: TBP>>=
   procedure :: set_parameters => coll_subtraction_set_parameters
 <<real subtraction: procedures>>=
   subroutine coll_subtraction_set_parameters (coll_sub, CA, CF, TR)
     class(coll_subtraction_t), intent(inout) :: coll_sub
     real(default), intent(in) :: CA, CF, TR
     coll_sub%CA = CA
     coll_sub%CF = CF
     coll_sub%TR = TR
   end subroutine coll_subtraction_set_parameters
 
 @ %def coll_subtraction_set_parameters
 @ This subroutine computes the collinear limit of $g^\alpha(\xi,y)$ introduced
 in eq.~\ref{fks: sub: real}. Care is given to also enable the usage for
 the soft-collinear limit. This, we write all formulas in terms of soft-finite
 quantities.
 
 We have to compute
 \begin{equation*}
   \frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]|_{y = 1}.
 \end{equation*}
 The Jacobian $J$ is proportional to $\xi$, due to the $d^3 k_{n+1} / k_{n+1}^0$ factor
 in the integration measure. It cancels the factor of $\xi$ in the denominator.
 The remaining part of the Jacobian is multiplied in [[evaluate_region_fsr]] and is
 not relevant here.
 Inserting the splitting functions exemplarily for $q \to qg$ yields
 \begin{equation*}
   g^\alpha = \frac{8\pi\alpha_s}{k_{\mathrm{em}}^2} C_F (1-y) \xi^2
              \frac{1+(1-z)^2}{z} \mathcal{B},
 \end{equation*}
 where we have chosen $z = E_\mathrm{rad} / \bar{E}_\mathrm{em}$ and $\bar{E}_\mathrm{em}$ denotes the emitter energy in the Born frame.
 The collinear final state imposes $\bar{k}_n = k_{n} + k_{n + 1}$ for the
 connection between $\Phi_n$- and $\Phi_{n+1}$-phasepace and we get $1 - z = E_\mathrm{em} / \bar{E}_\mathrm{em}$.
 The denominator can be rewritten by the constraint $\bar{k}_n^2 = (k_n +
 k_{n+1})^2 = 0$ to
 \begin{equation*}
   k_{\mathrm{em}}^2 = 2 E_\mathrm{rad} E_\mathrm{em} (1-y)
 \end{equation*}
 which cancels the $(1-y)$ factor in the numerator, thus showing that
 the whole expression is indeed collinear-finite. We can further transform
 \begin{equation*}
   E_\mathrm{rad} E_\mathrm{em} = z (1-z) \bar{E}_\mathrm{em}^2
 \end{equation*}
 so that in total we have
 \begin{equation*}
   g^\alpha = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} C_F \left(\frac{\xi}{z}\right)^2
              (1 + (1-z)^2) \mathcal{B}
 \end{equation*}
 Follow up calculations give us
 \begin{align*}
   g^{\alpha, g \rightarrow gg} & = \frac{4\pi\alpha_s}{1-z}\frac{1}{\bar{k}_{\text{em}}^2}
                                  C_{\mathrm{A}} \frac{\xi}{z} \left\lbrace 2 \left( \frac{z}{1 - z} \xi + \frac{1 - z}{\frac{z}{\xi}} \right) \mathcal{B} + 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace, \\
   g^{\alpha, g \rightarrow qq} & = \frac{4\pi\alpha_s}{1-z} \frac{1}{\bar{k}_{\text{em}}^2} T_{\mathrm{R}}
                                  \frac{\xi}{z} \left\lbrace \xi \mathcal{B} - 4\xi z(1 - z) \hat{k}_{\perp}^{\mu} \hat{k}_{\perp}^{\nu} \mathcal{B}_{\mu\nu} \right\rbrace.
 \end{align*}
 The ratio $z / \xi$ is finite in the soft limit
 \begin{equation*}
   \frac{z}{\xi} = \frac{q^0}{2\bar{E}_\mathrm{em}}
 \end{equation*}
 so that $\xi$ does not appear explicitly in the computation.
 
 The argumentation above is valid for $q \to qg$--splittings, but the general
 factorization is valid for general splittings, also for those involving spin
 correlations and QED splittings. Note that care has to be given to the definition
 of $z$. Further, we have factored out a factor of $z$ to include in the
 ratio $z/\xi$, which has to be taken into account in the implementation of
 the splitting functions.
 <<real subtraction: coll sub: TBP>>=
   procedure :: compute_fsr => coll_subtraction_compute_fsr
 <<real subtraction: procedures>>=
   function coll_subtraction_compute_fsr &
      (coll_sub, emitter, flst, p_res, p_born, sqme_born, mom_times_sqme_spin_c, &
      xi, alpha_coupling, double_fsr) result (sqme)
     real(default) :: sqme
     class(coll_subtraction_t), intent(in) :: coll_sub
     integer, intent(in) :: emitter
     integer, dimension(:), intent(in) :: flst
     type(vector4_t), intent(in) :: p_res
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: sqme_born, mom_times_sqme_spin_c
     real(default), intent(in) :: xi, alpha_coupling
     logical, intent(in) :: double_fsr
     real(default) :: q0, z, p0, z_o_xi, onemz
     integer :: nlegs, flv_em, flv_rad
     nlegs = size (flst)
     flv_rad = flst(nlegs); flv_em = flst(emitter)
     q0 = p_res**1
     p0 = p_res * p_born(emitter) / q0
     !!! Here, z corresponds to 1-z in the formulas of arXiv:1002.2581;
     !!! the integrand is symmetric under this variable change
     z_o_xi = q0 / (two * p0)
     z = xi * z_o_xi; onemz = one - z
     if (is_gluon (flv_em) .and. is_gluon (flv_rad)) then
        sqme = coll_sub%CA * ( two * ( z / onemz * xi + onemz / z_o_xi ) * sqme_born &
             + four * xi * z * onemz * mom_times_sqme_spin_c )
     else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then
        sqme = coll_sub%TR * xi * (sqme_born - four * z * onemz * mom_times_sqme_spin_c)
     else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
        sqme = sqme_born * coll_sub%CF * (one + onemz**2) / z_o_xi
     else
        sqme = zero
     end if
     sqme = sqme / (p0**2 * onemz * z_o_xi)
     sqme = sqme * four * pi * alpha_coupling
     if (double_fsr) sqme = sqme * onemz * two
   end function coll_subtraction_compute_fsr
 
 @ %def coll_subtraction_compute_fsr
 @ Like in the context of [[coll_subtraction_compute_fsr]] we compute
 the quantity
 \begin{equation*}
   \lim_{y\to\pm1}{\left\{\frac{J(\Phi_n,\xi,y,\phi)}{\xi}
   \left[(1-y^2)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]\right\}},
 \end{equation*}
 where the $(1-y^2)$ accounts for both $y=\pm1$. Again, the Jacobian is proportional to $\xi$, so we
 drop the $J / \xi$ factor. Note that it is important to take into account this missing
 factor of $\xi$ in the computation of the Jacobian during phase-space generation
 both for fixed-beam and structure ISR. We consider only a $q \to qg$ splitting
 arguing that other splittings are identical in terms of the
 factors which cancel. It is given by
 \begin{equation*}
   g^\alpha = \frac{8\pi\alpha_s}{-k_{\mathrm{em}}^2} C_F (1-y^2) \xi^2
              \frac{1+z^2}{1-z} \mathcal{B},
 \end{equation*}
 where $g^\alpha$ is defined akin to the one for FSR in eq.~\ref{fks: sub: real}.
 Note the negative sign of $k_\mathrm{em}^2$ to compensate the negative
 virtuality of the initial-state emitter.
 For ISR, $z$ is defined with respect to the emitter energy entering the hard
 interaction, i.e.
 \begin{equation*}
   z = \frac{E_\mathrm{beam} - E_\mathrm{rad}}{E_\mathrm{beam}} =
       1 - \frac{E_\mathrm{rad}}{E_\mathrm{beam}}.
 \end{equation*}
 Because $E_\mathrm{rad} = E_\mathrm{beam} \cdot \xi$, it is
 $z = 1 - \xi$, thus one factor of $\xi$ is cancelled by $(1-z)$ in the denominator of $g^\alpha$.
 The factor $k_\mathrm{em}^2$ in the denominator is rewritten as
 \begin{equation*}
   k_\mathrm{em}^2 = \left(p_\mathrm{beam} - p_\mathrm{rad}\right)^2
                   = - 2 p_\mathrm{beam} \cdot p_\mathrm{rad}
                   = - 2 E_\mathrm{beam} E_\mathrm{rad} (1\pm y)
                   = - 2 E_\mathrm{beam}^2 (1-z) (1\pm y),
 \end{equation*}
 where we used
 \begin{equation*}
   E_\mathrm{beam} E_\mathrm{rad} = E_\mathrm{beam}^2 (1-z).
 \end{equation*}
 This leads to the cancellation of the corresponding $(1\pm y)$ factor in
 $(1-y^2)$, with the other factor becoming a simple factor of $2$, and
 the remaining factor of $\xi$ in the numerator. We thus end up with
 \begin{equation*}
   g^\alpha = \frac{8\pi\alpha_s}{E_\mathrm{beam}^2} C_F \left(1 + z^2\right)\mathcal{B},
 \end{equation*}
 which is soft-finite.
 
 Note that here in [[compute_isr]], [[sqme_born]] is supposed to be
 the squared Born matrix element convoluted with the real PDF.
 <<real subtraction: coll sub: TBP>>=
   procedure :: compute_isr => coll_subtraction_compute_isr
 <<real subtraction: procedures>>=
   function coll_subtraction_compute_isr &
      (coll_sub, emitter, flst, p_born, sqme_born, mom_times_sqme_spin_c, &
      xi, alpha_coupling, isr_mode) result (sqme)
     real(default) :: sqme
     class(coll_subtraction_t), intent(in) :: coll_sub
     integer, intent(in) :: emitter
     integer, dimension(:), intent(in) :: flst
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: sqme_born
     real(default), intent(in) :: mom_times_sqme_spin_c
     real(default), intent(in) :: xi, alpha_coupling
     integer, intent(in) :: isr_mode
     real(default) :: z, onemz, p02
     integer :: nlegs, flv_em, flv_rad
     !!! p_born must be in lab frame.
     nlegs = size (flst)
     flv_rad = flst(nlegs); flv_em = flst(emitter)
     !!! No need to pay attention to n_in = 1, because this case always has a
     !!! massive initial-state particle and thus no collinear divergence.
     p02 = p_born(1)%p(0) * p_born(2)%p(0) / two
     z = one - xi; onemz = xi
     if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then
        sqme = coll_sub%CA * (two * (z + z * onemz**2) * sqme_born + four * onemz**2 &
           / z * mom_times_sqme_spin_c)
     else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
        sqme = coll_sub%CF * (one + z**2) * sqme_born
     else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then
        sqme = coll_sub%CF * (z * onemz * sqme_born + four * onemz**2 / z * mom_times_sqme_spin_c)
     else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then
        sqme = coll_sub%TR * (z**2 + onemz**2) * onemz * sqme_born
     else
        sqme = zero
     end if
     if (isr_mode == SQRTS_VAR) then
        sqme = sqme / p02 * z
     else
        !!! We have no idea why this seems to work as there should be no factor
        !!! of z for the fixed-beam settings. This should definitely be understood in the
        !!! future!
        sqme = sqme / p02 / z
     end if
     sqme = sqme * four * pi * alpha_coupling
   end function coll_subtraction_compute_isr
 
 @ %def coll_subtraction_compute_isr
 @
 <<real subtraction: coll sub: TBP>>=
   procedure :: final => coll_subtraction_final
 <<real subtraction: procedures>>=
   subroutine coll_subtraction_final (sub_coll)
     class(coll_subtraction_t), intent(inout) :: sub_coll
     sub_coll%use_resonance_mappings = .false.
   end subroutine coll_subtraction_final
 
 @ %def coll_subtraction_final
 @
 \subsection{Real Subtraction}
 
 We store a pointer to the [[nlo_settings_t]] object which holds tuning parameters, e.g. cutoffs for the subtraction terms.
 <<real subtraction: public>>=
   public :: real_subtraction_t
 <<real subtraction: types>>=
   type :: real_subtraction_t
      type(nlo_settings_t), pointer :: settings => null ()
      type(region_data_t), pointer :: reg_data => null ()
      type(real_kinematics_t), pointer :: real_kinematics => null ()
      type(isr_kinematics_t), pointer :: isr_kinematics => null ()
      type(real_scales_t) :: scales
      real(default), dimension(:,:), allocatable :: sqme_real_non_sub
      real(default), dimension(:), allocatable :: sqme_born
      real(default), dimension(:,:), allocatable :: sf_factors
      real(default), dimension(:,:,:), allocatable :: sqme_born_color_c
      real(default), dimension(:,:,:), allocatable :: sqme_born_charge_c
      real(default), dimension(:,:,:,:), allocatable :: sqme_born_spin_c
      type(soft_subtraction_t) :: sub_soft
      type(coll_subtraction_t) :: sub_coll
      logical, dimension(:), allocatable :: sc_required
      logical :: subtraction_deactivated = .false.
      integer :: purpose = INTEGRATION
      logical :: radiation_event = .true.
      logical :: subtraction_event = .false.
      integer, dimension(:), allocatable :: selected_alr
   contains
   <<real subtraction: real subtraction: TBP>>
   end type real_subtraction_t
 
 @ %def real_subtraction_t
 @ Initializer
 <<real subtraction: real subtraction: TBP>>=
   procedure :: init => real_subtraction_init
 <<real subtraction: procedures>>=
   subroutine real_subtraction_init (rsub, reg_data, settings)
     class(real_subtraction_t), intent(inout), target :: rsub
     type(region_data_t), intent(in), target :: reg_data
     type(nlo_settings_t), intent(in), target :: settings
     integer :: alr
     if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_init")
     if (debug_on) call msg_debug (D_SUBTRACTION, "n_in", reg_data%n_in)
     if (debug_on) call msg_debug (D_SUBTRACTION, "nlegs_born", reg_data%n_legs_born)
     if (debug_on) call msg_debug (D_SUBTRACTION, "nlegs_real", reg_data%n_legs_real)
     if (debug_on) call msg_debug (D_SUBTRACTION, "reg_data%n_regions", reg_data%n_regions)
     if (debug2_active (D_SUBTRACTION))  call reg_data%write ()
     rsub%reg_data => reg_data
     allocate (rsub%sqme_born (reg_data%n_flv_born))
     rsub%sqme_born = zero
     allocate (rsub%sf_factors (reg_data%n_regions, 0:reg_data%n_in))
     rsub%sf_factors = zero
     allocate (rsub%sqme_born_color_c (reg_data%n_legs_born, reg_data%n_legs_born, &
          reg_data%n_flv_born))
     rsub%sqme_born_color_c = zero
     allocate (rsub%sqme_born_charge_c (reg_data%n_legs_born, reg_data%n_legs_born, &
          reg_data%n_flv_born))
     rsub%sqme_born_charge_c = zero
     allocate (rsub%sqme_real_non_sub (reg_data%n_flv_real, reg_data%n_phs))
     rsub%sqme_real_non_sub = zero
     allocate (rsub%sc_required (reg_data%n_regions))
     do alr = 1, reg_data%n_regions
        rsub%sc_required(alr) = reg_data%regions(alr)%sc_required
     end do
     if (rsub%requires_spin_correlations ()) then
        allocate (rsub%sqme_born_spin_c (1:3, 1:3, reg_data%n_legs_born, reg_data%n_flv_born))
        rsub%sqme_born_spin_c = zero
     end if
     call rsub%sub_soft%init (reg_data)
     call rsub%sub_coll%init (reg_data%n_regions, reg_data%n_in)
     rsub%settings => settings
     rsub%sub_soft%use_resonance_mappings = settings%use_resonance_mappings
     rsub%sub_coll%use_resonance_mappings = settings%use_resonance_mappings
     rsub%sub_soft%factorization_mode = settings%factorization_mode
   end subroutine real_subtraction_init
 
 @ %def real_subtraction_init
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: set_real_kinematics => real_subtraction_set_real_kinematics
 <<real subtraction: procedures>>=
   subroutine real_subtraction_set_real_kinematics (rsub, real_kinematics)
     class(real_subtraction_t), intent(inout) :: rsub
     type(real_kinematics_t), intent(in), target :: real_kinematics
     rsub%real_kinematics => real_kinematics
   end subroutine real_subtraction_set_real_kinematics
 
 @ %def real_subtraction_set_real_kinematics
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: set_isr_kinematics => real_subtraction_set_isr_kinematics
 <<real subtraction: procedures>>=
   subroutine real_subtraction_set_isr_kinematics (rsub, fractions)
     class(real_subtraction_t), intent(inout) :: rsub
     type(isr_kinematics_t), intent(in), target :: fractions
     rsub%isr_kinematics => fractions
   end subroutine real_subtraction_set_isr_kinematics
 
 @ %def real_subtraction_set_isr_kinematics
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: get_i_res => real_subtraction_get_i_res
 <<real subtraction: procedures>>=
   function real_subtraction_get_i_res (rsub, alr) result (i_res)
     integer :: i_res
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr
     select type (fks_mapping => rsub%reg_data%fks_mapping)
     type is (fks_mapping_resonances_t)
        i_res = fks_mapping%res_map%alr_to_i_res (alr)
     class default
        i_res = 0
     end select
   end function real_subtraction_get_i_res
 
 @ %def real_subtraction_get_i_res
 @
 \subsection{The real contribution to the cross section}
 In each singular region $\alpha$, the real contribution to $\sigma$ is
 given by the second summand of eqn. \ref{fks: sub: complete},
 \begin{equation}
   \label{fks: sub: real}
   \sigma^\alpha_{\text{real}} = \int d\Phi_n \int_0^{2\pi} d\phi
   \int_{-1}^1 dy \int_0^{\xi_{\text{max}}} d\xi
   \left(\frac{1}{\xi}\right)_+ \left(\frac{1}{1-y}\right)_+
   \underbrace{\frac{J(\Phi_n, \xi, y, \phi)}{\xi}
     \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]}_{g^\alpha(\xi,y)}.
 \end{equation}
 Writing out the plus-distribution and introducing $\tilde{\xi} =
 \xi/\xi_{\text{max}}$ to set the upper integration limit to 1,  this
 turns out to be equal to
 \begin{equation}
   \begin{split}
     \sigma^\alpha_{\rm{real}} &= \int d\Phi_n \int_0^{2\pi}d\phi
     \int_{-1}^1 \frac{dy}{1-y} \Bigg\{\int_0^1
     d\tilde{\xi}\Bigg[\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},y)}{\tilde{\xi}}
     - \underbrace{\frac{g^\alpha(0,y)}{\tilde{\xi}}}_{\text{soft}} -
     \underbrace{\frac{g^\alpha(\tilde{\xi}\xi_{\rm{max}},1)}{\tilde{\xi}}}_{\text{coll.}}
     +
     \underbrace{\frac{g^\alpha(0,1)}{\tilde{\xi}}}_{\text{coll.+soft}}\Bigg]
     \\
 &+ \left[\log\xi_{\rm{max}}(y)g^\alpha(0,y) - \log\xi_{\rm{max}}(1)g^\alpha(0,1)\right]\Bigg\}.
   \end{split}
 \end{equation}
 This formula is implemented in \texttt{compute\_sqme\_real\_fin}
 
 If two or more singular regions would produce the same amplitude we only compute
 one and use the [[eqv_index]] to copy the result to the others (if [[reuse_amplitudes_fks]]
 is true).
 <<real subtraction: real subtraction: TBP>>=
   procedure :: compute => real_subtraction_compute
 <<real subtraction: procedures>>=
   subroutine real_subtraction_compute (rsub, emitter, i_phs, alpha_s, &
            alpha_qed, separate_alrs, sqme)
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: emitter, i_phs
     logical, intent(in) :: separate_alrs
     real(default), intent(inout), dimension(:) :: sqme
     real(default), dimension(:), allocatable :: sqme_alr_arr
     real(default), intent(in) :: alpha_s, alpha_qed
     real(default) :: sqme_alr, alpha_coupling
     integer :: alr, i_con, i_res, this_emitter
     logical :: same_emitter
     logical, dimension(:), allocatable :: alr_evaluated
     allocate (alr_evaluated(rsub%reg_data%n_regions))
     allocate (sqme_alr_arr(rsub%reg_data%n_regions))
     sqme_alr_arr = zero
     alr_evaluated = .false.
     do alr = 1, rsub%reg_data%n_regions
        if (.not. alr_evaluated(rsub%reg_data%regions(alr)%eqv_index)) then
           if (allocated (rsub%selected_alr)) then
              if (.not. any (rsub%selected_alr == alr)) cycle
           end if
           sqme_alr = zero
           if (emitter > rsub%isr_kinematics%n_in) then
              same_emitter = emitter == rsub%reg_data%regions(alr)%emitter
           else
              same_emitter = rsub%reg_data%regions(alr)%emitter <= rsub%isr_kinematics%n_in
           end if
           select case (char(rsub%reg_data%regions(alr)%nlo_correction_type))
           case ("QCD")
              alpha_coupling = alpha_s
           case ("EW")
              alpha_coupling = alpha_qed
           end select
           if (same_emitter .and. i_phs == rsub%real_kinematics%alr_to_i_phs (alr)) then
              i_res = rsub%get_i_res (alr)
              this_emitter = rsub%reg_data%regions(alr)%emitter
              sqme_alr = rsub%evaluate_emitter_region (alr, this_emitter, i_phs, i_res, &
                   alpha_coupling)
              if (rsub%purpose == INTEGRATION .or. rsub%purpose == FIXED_ORDER_EVENTS) then
                 i_con = rsub%get_i_contributor (alr)
                 sqme_alr = sqme_alr * rsub%get_phs_factor (i_con)
              end if
           end if
           sqme_alr_arr(alr) = sqme_alr_arr(alr) + sqme_alr
           if (.not. (debug_active (D_SUBTRACTION) .or. debug2_active (D_SUBTRACTION))) then
              if (.not. allocated (rsub%selected_alr)) &
                   alr_evaluated(rsub%reg_data%regions(alr)%eqv_index) = .true.
           end if
        else
           sqme_alr_arr(alr) = sqme_alr_arr(rsub%reg_data%regions(alr)%eqv_index)
        end if
        if (separate_alrs) then
           sqme(alr) = sqme(alr) + sqme_alr_arr(alr)
        else
           sqme(1) = sqme(1) + sqme_alr_arr(alr)
        end if
     end do
     if (debug_on) then
        if (debug2_active (D_SUBTRACTION)) call check_s_alpha_consistency ()
     end if
   contains
     subroutine check_s_alpha_consistency ()
       real(default) :: sum_s_alpha, sum_s_alpha_soft
       integer :: i_ftuple
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "Check consistency of s_alpha: ")
       do alr = 1, rsub%reg_data%n_regions
          sum_s_alpha = rsub%sum_up_s_alpha(alr, i_phs)
          call msg_debug2 (D_SUBTRACTION, 'sum_s_alpha', sum_s_alpha)
          if (.not. nearly_equal(sum_s_alpha, one)) then
             call msg_bug ("The sum of all S functions should be equal to one!")
          end if
          sum_s_alpha_soft = rsub%sum_up_s_alpha_soft(alr, i_phs)
          call msg_debug2 (D_SUBTRACTION, 'sum_s_alpha_soft', sum_s_alpha_soft)
          if (.not. nearly_equal(sum_s_alpha_soft, one)) then
             call msg_bug ("The sum of all soft S functions should be equal to one!")
          end if
       end do
     end subroutine check_s_alpha_consistency
   end subroutine real_subtraction_compute
 
 @ %def real_subtraction_compute
 @ The emitter is fixed. We now have to decide whether we evaluate in ISR or FSR
 region, and also if resonances are used.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_emitter_region => real_subtraction_evaluate_emitter_region
 <<real subtraction: procedures>>=
   function real_subtraction_evaluate_emitter_region (rsub, alr, emitter, &
       i_phs, i_res, alpha_coupling) result (sqme)
     real(default) :: sqme
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     if (emitter <= rsub%isr_kinematics%n_in) then
        sqme = rsub%evaluate_region_isr (alr, emitter, i_phs, i_res, alpha_coupling)
     else
        select type (fks_mapping => rsub%reg_data%fks_mapping)
        type is (fks_mapping_resonances_t)
           call fks_mapping%set_resonance_momenta &
                (rsub%real_kinematics%xi_ref_momenta)
        end select
        sqme = rsub%evaluate_region_fsr (alr, emitter, i_phs, i_res, alpha_coupling)
     end if
   end function real_subtraction_evaluate_emitter_region
 
 @ %def real_subtraction_evaluate_emitter_region
 @ Sums up $\sum_{i_1, i_2} S_{i_1 i_2}$ for the given [[alr]].
 <<real subtraction: real subtraction: TBP>>=
   procedure :: sum_up_s_alpha => real_subtraction_sum_up_s_alpha
 <<real subtraction: procedures>>=
   function real_subtraction_sum_up_s_alpha (rsub, alr, i_phs) result (sum_s_alpha)
     real(default) :: sum_s_alpha
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, i_phs
     type(vector4_t), dimension(:), allocatable :: p_real
     integer :: i_res, i_ftuple, i1, i2
     allocate (p_real (rsub%reg_data%n_legs_real))
     if (rsub%reg_data%has_pseudo_isr ()) then
        p_real = rsub%real_kinematics%p_real_onshell(i_phs)%get_momenta (i_phs)
     else
        p_real = rsub%real_kinematics%p_real_cms%get_momenta (i_phs)
     end if
     i_res = rsub%get_i_res (alr)
     sum_s_alpha = zero
     do i_ftuple = 1, rsub%reg_data%regions(alr)%nregions
        call rsub%reg_data%regions(alr)%ftuples(i_ftuple)%get (i1, i2)
        sum_s_alpha = sum_s_alpha + rsub%reg_data%get_svalue (p_real, alr, i1, i2, i_res)
     end do
   end function real_subtraction_sum_up_s_alpha
 
 @ %def real_subtraction_sum_up_s_alpha
 @ Sums up $\sum_{i_1, i_2} S_{i_1 i_2}$ for the given [[alr]].
 The soft S functions take the real momenta in the soft limit, i.e. the Born momenta.
 For each summand of [[sum_s_alpha_soft]] we take [[p_soft]] constructed from the
 emitter of the given alpha region also for ftuples in which the first integer [[i1]]
 does not coincide with the emitter. This is necessary because only if we keep [[p_soft]]
 fixed, all soft S functions are computed with the same denominator and thus add up to 1.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: sum_up_s_alpha_soft => real_subtraction_sum_up_s_alpha_soft
 <<real subtraction: procedures>>=
   function real_subtraction_sum_up_s_alpha_soft (rsub, alr, i_phs) result (sum_s_alpha_soft)
     real(default) :: sum_s_alpha_soft
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, i_phs
     type(vector4_t), dimension(:), allocatable :: p_born
     integer :: i_res, i_ftuple, i1, i2, emitter, nlegs
     allocate (p_born (rsub%reg_data%n_legs_born))
     if (rsub%reg_data%has_pseudo_isr ()) then
        p_born = rsub%real_kinematics%p_born_onshell%get_momenta (1)
     else
        p_born = rsub%real_kinematics%p_born_cms%get_momenta (1)
     end if
     i_res = rsub%get_i_res (alr)
     emitter = rsub%reg_data%regions(alr)%emitter
     associate (r => rsub%real_kinematics)
        if (emitter > rsub%sub_soft%reg_data%n_in) then
           call rsub%sub_soft%create_softvec_fsr (p_born, r%y_soft(i_phs), r%phi, &
                emitter, r%xi_ref_momenta(rsub%sub_soft%i_xi_ref (alr, i_phs)))
        else
           call rsub%sub_soft%create_softvec_isr (r%y_soft(i_phs), r%phi)
        end if
     end associate
     nlegs = rsub%reg_data%n_legs_real
     sum_s_alpha_soft = zero
     do i_ftuple = 1, rsub%reg_data%regions(alr)%nregions
        call rsub%reg_data%regions(alr)%ftuples(i_ftuple)%get (i1, i2)
        if (i2 == nlegs) then
           sum_s_alpha_soft = sum_s_alpha_soft + rsub%reg_data%get_svalue_soft &
             (p_born, rsub%sub_soft%p_soft, alr, i1, i_res)
        end if
     end do
   end function real_subtraction_sum_up_s_alpha_soft
 
 @ %def real_subtraction_sum_up_s_alpha_soft
 @ This subroutine computes the finite part of the real matrix element in
 an individual singular region.
 First, the radiation variables are fetched and $\mathcal{R}$ is
 multiplied by the appropriate $S_\alpha$-factors,
 region multiplicities and double-FSR factors.
 Then, it computes the soft, collinear, soft-collinear and remnant matrix
 elements and supplies the corresponding factor $1/\xi/(1-y)$ as well as
 the corresponding Jacobians.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_region_fsr => real_subtraction_evaluate_region_fsr
 <<real subtraction: procedures>>=
   function real_subtraction_evaluate_region_fsr (rsub, alr, emitter, i_phs, &
        i_res, alpha_coupling) result (sqme_tot)
     real(default) :: sqme_tot
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     real(default) :: sqme_rad, sqme_soft, sqme_coll, sqme_cs, sqme_remn
     sqme_rad = zero; sqme_soft = zero; sqme_coll = zero
     sqme_cs = zero; sqme_remn = zero
     associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template)
       if (rsub%radiation_event) then
          sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs)
          call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, &
               alr, i_phs, emitter, i_res)
          call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, &
               rsub%real_kinematics, i_phs, .false., rsub%reg_data%has_pseudo_isr (), &
               emitter)
       end if
       if (rsub%subtraction_event .and. .not. rsub%subtraction_deactivated) then
          if (debug2_active (D_SUBTRACTION)) then
             print *, "[real_subtraction_evaluate_region_fsr]"
             print *, "xi: ", rsub%real_kinematics%xi_max(i_phs) * rsub%real_kinematics%xi_tilde
             print *, "y: ", rsub%real_kinematics%y(i_phs)
          end if
          call rsub%evaluate_subtraction_terms_fsr (alr, emitter, i_phs, i_res, alpha_coupling, &
               sqme_soft, sqme_coll, sqme_cs)
          call apply_kinematic_factors_subtraction_fsr (sqme_soft, sqme_coll, sqme_cs, &
               rsub%real_kinematics, i_phs)
          associate (symm_factor_fs => rsub%reg_data%born_to_real_symm_factor_fs (alr))
             sqme_soft = sqme_soft * symm_factor_fs
             sqme_coll = sqme_coll * symm_factor_fs
             sqme_cs = sqme_cs * symm_factor_fs
          end associate
          sqme_remn = compute_sqme_remnant_fsr (sqme_soft, sqme_cs, &
               rsub%real_kinematics%xi_max(i_phs), template%xi_cut, rsub%real_kinematics%xi_tilde)
          select case (rsub%purpose)
          case (INTEGRATION)
             sqme_tot = sqme_rad - sqme_soft - sqme_coll + sqme_cs + sqme_remn
          case (FIXED_ORDER_EVENTS)
             sqme_tot = - sqme_soft - sqme_coll + sqme_cs + sqme_remn
          case default
             sqme_tot = zero
             call msg_bug ("real_subtraction_evaluate_region_fsr: " // &
                  "Undefined rsub%purpose")
          end select
       else
          sqme_tot = sqme_rad
       end if
       sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand(i_phs)
       sqme_tot = sqme_tot * rsub%reg_data%regions(alr)%mult
     end associate
     if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then
        call real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad, sqme_soft, &
             sqme_coll=sqme_coll, sqme_cs=sqme_cs)
     else if (debug2_active (D_SUBTRACTION)) then
        call write_computation_status_fsr ()
     end if
   contains
   <<real subtraction: real subtraction evaluate region fsr: procedures>>
     subroutine write_computation_status_fsr (passed, total, region_type, full)
       integer, intent(in), optional :: passed, total
       character(*), intent(in), optional :: region_type
       integer :: i_born
       integer :: u
       real(default) :: xi
       logical :: yorn
       logical, intent(in), optional :: full
       yorn = .true.
       if (present (full)) yorn = full
       if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_region_fsr")
       u = given_output_unit (); if (u < 0) return
       i_born = rsub%reg_data%regions(alr)%uborn_index
       xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde
       write (u,'(A,I2)') 'rsub%purpose: ', rsub%purpose
       write (u,'(A,I4)') 'alr: ', alr
       write (u,'(A,I3)') 'emitter: ', emitter
       write (u,'(A,I3)') 'i_phs: ', i_phs
       write (u,'(A,F6.4)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs)
       write (u,'(A,F6.4)') 'xi_cut: ', rsub%real_kinematics%xi_max(i_phs) * rsub%settings%fks_template%xi_cut
       write (u,'(A,F6.4,2X,A,F6.4)') 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs)
       if (yorn) then
          write (u,'(A,ES16.9)')  'sqme_born: ', rsub%sqme_born(i_born)
          write (u,'(A,ES16.9)')  'sqme_real: ', sqme_rad
          write (u,'(A,ES16.9)')  'sqme_soft: ', sqme_soft
          write (u,'(A,ES16.9)')  'sqme_coll: ', sqme_coll
          write (u,'(A,ES16.9)')  'sqme_coll-soft: ', sqme_cs
          write (u,'(A,ES16.9)')  'sqme_remn: ', sqme_remn
          write (u,'(A,ES16.9)')  'sqme_tot: ', sqme_tot
          if (present (passed) .and. present (total) .and. &
               present (region_type)) &
               write (u,'(A)') char (str (passed) // " of " // str (total) // &
               " " // region_type // " points passed in total")
       end if
       write (u,'(A,ES16.9)')  'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1)
       write (u,'(A,ES16.9)')  'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2)
       write (u,'(A,ES16.9)')  'jacobian - coll: ', rsub%real_kinematics%jac(i_phs)%jac(3)
     end subroutine write_computation_status_fsr
   end function real_subtraction_evaluate_region_fsr
 
 @ %def real_subtraction_evalute_region_fsr
 @ Compares the real matrix element to the subtraction terms in the soft, the collinear
 or the soft-collinear limits. Used for debug purposes if [[?test_anti_coll_limit]],
 [[?test_coll_limit]] and/or [[?test_soft_limit]] are set in the Sindarin.
 [[sqme_soft]] and [[sqme_cs]] need to be provided if called for FSR and [[sqme_coll_plus]],
 [[sqme_coll_minus]], [[sqme_cs_plus]] as well as [[sqme_cs_minus]] need to be provided if called for ISR.
 <<real subtraction: procedures>>=
   subroutine real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad, sqme_soft,&
       sqme_coll, sqme_cs, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
     class(real_subtraction_t), intent(in) :: rsub
     integer, intent(in) :: alr, emitter, i_phs
     real(default), intent(in) :: sqme_rad, sqme_soft
     real(default), intent(in), optional :: sqme_coll, sqme_cs, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus
     real(default), dimension(:), allocatable, save :: sqme_rad_store
     logical :: is_soft, is_collinear_plus, is_collinear_minus, is_fsr
     real(default), parameter :: soft_threshold = 0.001_default
     real(default), parameter :: coll_threshold = 0.99_default
     real(default), parameter :: rel_smallness = 0.01_default
     real(default) :: sqme_dummy, this_sqme_rad, y, xi_tilde
     logical, dimension(:), allocatable, save :: count_alr
 
     if (.not. allocated (sqme_rad_store)) then
        allocate (sqme_rad_store (rsub%reg_data%n_regions))
        sqme_rad_store = zero
     end if
     if (rsub%radiation_event) then
        sqme_rad_store(alr) = sqme_rad
     else
        if (.not. allocated (count_alr)) then
           allocate (count_alr (rsub%reg_data%n_regions))
           count_alr = .false.
        end if
 
        if (is_massless_vector (rsub%reg_data%regions(alr)%flst_real%flst(rsub%reg_data%n_legs_real))) then
           xi_tilde = rsub%real_kinematics%xi_tilde
           is_soft = xi_tilde < soft_threshold
        else
           is_soft = .false.
        end if
        y = rsub%real_kinematics%y(i_phs)
        is_collinear_plus = y > coll_threshold .and. &
             rsub%reg_data%regions(alr)%has_collinear_divergence()
        is_collinear_minus = -y > coll_threshold .and. &
             rsub%reg_data%regions(alr)%has_collinear_divergence()
 
        is_fsr = emitter > rsub%isr_kinematics%n_in
 
        if (is_fsr) then
           if (.not. present(sqme_coll) .or. .not. present(sqme_cs)) &
              call msg_error ("real_subtraction_register_debug_sqme: Wrong arguments for FSR")
        else
           if (.not. present(sqme_coll_plus) .or. .not. present(sqme_coll_minus) &
                .or. .not. present(sqme_cs_plus) .or. .not. present(sqme_cs_minus)) &
              call msg_error ("real_subtraction_register_debug_sqme: Wrong arguments for ISR")
        end if
 
        this_sqme_rad = sqme_rad_store(alr)
        if (is_soft .and. .not. is_collinear_plus .and. .not. is_collinear_minus) then
           if ( .not. nearly_equal (this_sqme_rad, sqme_soft, &
                abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
              call msg_print_color (char ("Soft MEs do not match in region " // str (alr)), COL_RED)
           else
              call msg_print_color (char ("sqme_soft OK in region " // str (alr)), COL_GREEN)
           end if
           print *, 'this_sqme_rad, sqme_soft =    ', this_sqme_rad, sqme_soft
        end if
 
        if (is_collinear_plus .and. .not. is_soft) then
           if (is_fsr) then
              if ( .not. nearly_equal (this_sqme_rad, sqme_coll, &
                  abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                call msg_print_color (char ("sqme_coll OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_coll =    ', this_sqme_rad, sqme_coll
           else
              if ( .not. nearly_equal (this_sqme_rad, sqme_coll_plus, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
              call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_coll_plus OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_coll_plus =    ', this_sqme_rad, sqme_coll_plus
           end if
        end if
 
        if (is_collinear_minus .and. .not. is_soft) then
           if (.not. is_fsr) then
              if ( .not. nearly_equal (this_sqme_rad, sqme_coll_minus, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                 call msg_print_color (char ("Collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_coll_minus OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_coll_minus =    ', this_sqme_rad, sqme_coll_minus
           end if
        end if
 
        if (is_soft .and. is_collinear_plus) then
           if (is_fsr) then
              if ( .not. nearly_equal (this_sqme_rad, sqme_cs, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                 call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_cs OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_cs =    ', this_sqme_rad, sqme_cs
           else
              if ( .not. nearly_equal (this_sqme_rad, sqme_cs_plus, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                 call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_cs_plus OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_cs_plus =    ', this_sqme_rad, sqme_cs_plus
           end if
        end if
 
        if (is_soft .and. is_collinear_minus) then
           if (.not. is_fsr) then
              if ( .not. nearly_equal (this_sqme_rad, sqme_cs_minus, &
                   abs_smallness=tiny(1._default), rel_smallness=rel_smallness)) then
                 call msg_print_color (char ("Soft-collinear MEs do not match in region " // str (alr)), COL_RED)
              else
                 call msg_print_color (char ("sqme_cs_minus OK in region " // str (alr)), COL_GREEN)
              end if
              print *, 'this_sqme_rad, sqme_cs_minus =    ', this_sqme_rad, sqme_cs_minus
           end if
        end if
 
        count_alr (alr) = .true.
        if (all (count_alr)) then
           deallocate (count_alr)
           deallocate (sqme_rad_store)
        end if
     end if
   end subroutine real_subtraction_register_debug_sqme
 
 @ %def real_subtraction_register_debug_sqme
 @ For final state radiation, the subtraction remnant cross section is
 \begin{equation}
   \sigma_{\text{remn}} = \left(\sigma_{\text{soft}} - \sigma_{\text{soft-coll}}\right)
       \log (\xi_{\text{max}}) \cdot \frac{\tilde{\xi}}{\xi_{\text{cut}}}.
 \end{equation}
 There is only one factor of $\log (\xi_{\text{max}})$ for both limits
 as $\xi_{\text{max}}$ does not depend on $y$ in the case of FSR.
 We use the already computed [[sqme_soft]] and [[sqme_cs]] with a factor of
 $\tilde{\xi}$ which we have to compensate. We also need a factor $1/\xi_{\text{cut}}$ here
 to assure that the cross section is independent of this free cutoff parameter.
 However, it still remains to be motivated analytically.
 <<real subtraction: real subtraction evaluate region fsr: procedures>>=
   function compute_sqme_remnant_fsr (sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde) result (sqme_remn)
     real(default) :: sqme_remn
     real(default), intent(in) :: sqme_soft, sqme_cs, xi_max, xi_cut, xi_tilde
     if (debug_on) call msg_debug (D_SUBTRACTION, "compute_sqme_remnant_fsr")
     sqme_remn = (sqme_soft - sqme_cs) * log (xi_max) * xi_tilde / xi_cut
   end function compute_sqme_remnant_fsr
 
 @ %def compute_sqme_remnant_fsr
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_region_isr => real_subtraction_evaluate_region_isr
 <<real subtraction: procedures>>=
   function real_subtraction_evaluate_region_isr (rsub, alr, emitter, i_phs, i_res, alpha_coupling) &
        result (sqme_tot)
     real(default) :: sqme_tot
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     real(default) :: sqme_rad, sqme_soft, sqme_coll_plus, sqme_coll_minus
     real(default) :: sqme_cs_plus, sqme_cs_minus
     real(default) :: sqme_remn
     sqme_rad = zero; sqme_soft = zero;
     sqme_coll_plus = zero; sqme_coll_minus = zero
     sqme_cs_plus = zero; sqme_cs_minus = zero
     sqme_remn = zero
     associate (region => rsub%reg_data%regions(alr), template => rsub%settings%fks_template)
       if (rsub%radiation_event) then
          sqme_rad = rsub%sqme_real_non_sub (rsub%reg_data%get_matrix_element_index (alr), i_phs)
          call evaluate_fks_factors (sqme_rad, rsub%reg_data, rsub%real_kinematics, &
               alr, i_phs, emitter, i_res)
          call apply_kinematic_factors_radiation (sqme_rad, rsub%purpose, rsub%real_kinematics, &
               i_phs, .true., .false.)
       end if
       if (rsub%subtraction_event .and. .not. rsub%subtraction_deactivated) then
          call rsub%evaluate_subtraction_terms_isr (alr, emitter, i_phs, i_res, alpha_coupling, &
               sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
          call apply_kinematic_factors_subtraction_isr (sqme_soft, sqme_coll_plus, &
               sqme_coll_minus, sqme_cs_plus, sqme_cs_minus, rsub%real_kinematics, i_phs)
          associate (symm_factor_fs => rsub%reg_data%born_to_real_symm_factor_fs (alr))
             sqme_soft = sqme_soft * symm_factor_fs
             sqme_coll_plus = sqme_coll_plus * symm_factor_fs
             sqme_coll_minus = sqme_coll_minus * symm_factor_fs
             sqme_cs_plus = sqme_cs_plus * symm_factor_fs
             sqme_cs_minus = sqme_cs_minus * symm_factor_fs
          end associate
          sqme_remn = compute_sqme_remnant_isr (rsub%isr_kinematics%isr_mode, &
               sqme_soft, sqme_cs_plus, sqme_cs_minus, &
               rsub%isr_kinematics, rsub%real_kinematics, i_phs, template%xi_cut)
          sqme_tot = sqme_rad - sqme_soft - sqme_coll_plus - sqme_coll_minus &
               + sqme_cs_plus + sqme_cs_minus + sqme_remn
       else
          sqme_tot = sqme_rad
       end if
     end associate
     sqme_tot = sqme_tot * rsub%real_kinematics%jac_rand (i_phs)
     sqme_tot = sqme_tot * rsub%reg_data%regions(alr)%mult
     if (debug_active (D_SUBTRACTION) .and. .not. debug2_active (D_SUBTRACTION)) then
        call real_subtraction_register_debug_sqme (rsub, alr, emitter, i_phs, sqme_rad,&
             sqme_soft, sqme_coll_plus=sqme_coll_plus, sqme_coll_minus=sqme_coll_minus,&
             sqme_cs_plus=sqme_cs_plus, sqme_cs_minus=sqme_cs_minus)
     else if (debug2_active (D_SUBTRACTION)) then
        call write_computation_status_isr ()
     end if
   contains
   <<real subtraction: evaluate region isr: procedures>>
     subroutine write_computation_status_isr (unit)
        integer, intent(in), optional :: unit
        integer :: i_born
        integer :: u
        real(default) :: xi
        u = given_output_unit (unit); if (u < 0) return
        i_born = rsub%reg_data%regions(alr)%uborn_index
        xi = rsub%real_kinematics%xi_max (i_phs) * rsub%real_kinematics%xi_tilde
        write (u,'(A,I4)') 'alr: ', alr
        write (u,'(A,I2)') 'emitter: ', emitter
        write (u,'(A,F4.2)') 'xi_max: ', rsub%real_kinematics%xi_max (i_phs)
        print *, 'xi: ', xi, 'y: ', rsub%real_kinematics%y (i_phs)
        print *, 'xb1: ', rsub%isr_kinematics%x(1), 'xb2: ', rsub%isr_kinematics%x(2)
        print *, 'random jacobian: ', rsub%real_kinematics%jac_rand (i_phs)
        write (u,'(A,ES16.9)')  'sqme_born: ', rsub%sqme_born(i_born)
        write (u,'(A,ES16.9)')  'sqme_real: ', sqme_rad
        write (u,'(A,ES16.9)')  'sqme_soft: ', sqme_soft
        write (u,'(A,ES16.9)')  'sqme_coll_plus: ', sqme_coll_plus
        write (u,'(A,ES16.9)')  'sqme_coll_minus: ', sqme_coll_minus
        write (u,'(A,ES16.9)')  'sqme_cs_plus: ', sqme_cs_plus
        write (u,'(A,ES16.9)')  'sqme_cs_minus: ', sqme_cs_minus
        write (u,'(A,ES16.9)')  'sqme_remn: ', sqme_remn
        write (u,'(A,ES16.9)')  'sqme_tot: ', sqme_tot
        write (u,'(A,ES16.9)')  'jacobian - real: ', rsub%real_kinematics%jac(i_phs)%jac(1)
        write (u,'(A,ES16.9)')  'jacobian - soft: ', rsub%real_kinematics%jac(i_phs)%jac(2)
        write (u,'(A,ES16.9)')  'jacobian - collplus: ', rsub%real_kinematics%jac(i_phs)%jac(3)
        write (u,'(A,ES16.9)')  'jacobian - collminus: ', rsub%real_kinematics%jac(i_phs)%jac(4)
     end subroutine write_computation_status_isr
   end function real_subtraction_evaluate_region_isr
 
 @ %def real_subtraction_evaluate_region_isr
 @ Computes the soft remnant for ISR. The formulas can be found in arXiv:1002.2581, eq. 4.21.
 and arXiv:0709.2092, sec. 5.1.2.
 This results in
 \begin{equation}
   \sigma_{\text{remn}}^{\text{ISR}} = \log(\xi_{\text{max}}(y)) \sigma_{\text{soft}}
   - \frac{1}{2} \log(\xi_{\text{max}}(1)) \sigma^{\text{soft-coll}}_{\oplus}
   - \frac{1}{2} \log(\xi_{\text{max}}(-1)) \sigma^{\text{soft-coll}}_{\ominus}
 \end{equation}
 where for ISR, $\xi_{\text{max}}$ does explicitly depend on $y$
 due to the rescaling of the $x$ values from the Born to the real partonic system according to
 \begin{equation}
   x_\oplus = \frac{\overline{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1-y)}{2-\xi(1+y)}}
   , \qquad
   x_\ominus = \frac{\overline{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1+y)}{2-\xi(1-y)}}
 \end{equation}
 As $\xi_{\text{max}}$ is determined by the fact that the real $x_\oplus,x_\ominus$ have to
 stay in a physically meaningful regime, i.e. $x_\oplus,x_\ominus < 1$, this leads to
 \begin{align}
 \label{eqn:xi_max_isr}
 \xi_\text{max} = 1 - \text{max}
   &\left\{\frac{2(1+y)\overline{x}_\oplus^2}{\sqrt{(1+\overline{x}_\oplus^2)^2(1-y)^2 + 16y\overline{x}_\oplus^2} + (1-y)(1-\overline{x}_\oplus^2)}\right., \\
   &\left.\frac{2(1-y)\overline{x}_\oplus^2}{\sqrt{(1+\overline{x}_\oplus^2)^2(1+y)^2 - 16y\overline{x}_\oplus^2} + (1+y)(1-\overline{x}_\oplus^2)}\right\}
 \end{align}
 and thus
 \begin{align}
   \xi_{\text{max}}(y=1) &= 1 - \overline{x}_\oplus \\
   \xi_{\text{max}}(y=-1) &= 1 - \overline{x}_\ominus
 \end{align}
 So we need to use the unrescaled $\overline{x}_\oplus,\overline{x}_\ominus$ here.
 Factors of $\frac{1}{2}$ and $\frac{1}{\tilde{\xi}}$
 are already included in the matrix elements from [[apply_kinematic_factors_subtraction_isr]].
 We keep the former and remove the latter by multiplying with $\tilde{\xi}$.
 The factor $1/\xi_{\text{cut}}$ is probably needed to assure that the cross section is
 independent of this free cutoff parameter in analogy to the FSR case.
 However, it still remains to be motivated analytically and to be validated.
 <<real subtraction: evaluate region isr: procedures>>=
   function compute_sqme_remnant_isr (isr_mode, sqme_soft, sqme_cs_plus, sqme_cs_minus, &
      isr_kinematics, real_kinematics, i_phs, xi_cut) result (sqme_remn)
     real(default) :: sqme_remn
     integer, intent(in) :: isr_mode
     real(default), intent(in) :: sqme_soft, sqme_cs_plus, sqme_cs_minus
     type(isr_kinematics_t), intent(in) :: isr_kinematics
     type(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: i_phs
     real(default), intent(in) :: xi_cut
     real(default) :: xi_tilde, xi_max, xi_max_plus, xi_max_minus, xb_plus, xb_minus
     xi_max = real_kinematics%xi_max (i_phs)
     xi_tilde = real_kinematics%xi_tilde
     select case (isr_mode)
     case (SQRTS_VAR)
        xb_plus = isr_kinematics%x(I_PLUS)
        xb_minus = isr_kinematics%x(I_MINUS)
        xi_max_plus = one - xb_plus
        xi_max_minus = one - xb_minus
     case (SQRTS_FIXED)
        xi_max_plus = real_kinematics%xi_max (i_phs)
        xi_max_minus = real_kinematics%xi_max (i_phs)
     end select
     sqme_remn = log (xi_max) * xi_tilde * sqme_soft &
          - log (xi_max_plus) * xi_tilde * sqme_cs_plus &
          - log (xi_max_minus) * xi_tilde * sqme_cs_minus
     sqme_remn = sqme_remn / xi_cut
   end function compute_sqme_remnant_isr
 
 @ %def compute_sqme_remnant_isr
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_subtraction_terms_fsr => &
        real_subtraction_evaluate_subtraction_terms_fsr
 <<real subtraction: procedures>>=
   subroutine real_subtraction_evaluate_subtraction_terms_fsr (rsub, &
        alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll, sqme_cs)
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     real(default), intent(out) :: sqme_soft, sqme_coll, sqme_cs
     if (debug_on) call msg_debug (D_SUBTRACTION, "real_subtraction_evaluate_subtraction_terms_fsr")
     sqme_soft = zero; sqme_coll = zero; sqme_cs = zero
     associate (xi_tilde => rsub%real_kinematics%xi_tilde, &
          y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template)
       if (template%xi_cut > xi_tilde) &
            sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling)
       if (y - 1 + template%delta_o > 0) &
            sqme_coll = rsub%compute_sub_coll (alr, emitter, i_phs, alpha_coupling)
       if (template%xi_cut > xi_tilde .and. y - 1 + template%delta_o > 0) &
            sqme_cs = rsub%compute_sub_coll_soft (alr, emitter, i_phs, alpha_coupling)
       if (debug2_active (D_SUBTRACTION)) then
          print *, "FSR Cutoff:"
          print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")"
          print *, "sub_coll: ", (y - 1 + template%delta_o) > 0, "(ME: ", sqme_coll, ")"
          print *, "sub_coll_soft: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_o) > 0, &
               "(ME: ", sqme_cs, ")"
       end if
     end associate
   end subroutine real_subtraction_evaluate_subtraction_terms_fsr
 
 @ %def real_subtraction_evaluate_subtraction_terms_fsr
 @
 <<real subtraction: procedures>>=
   subroutine evaluate_fks_factors (sqme, reg_data, real_kinematics, &
       alr, i_phs, emitter, i_res)
     real(default), intent(inout) :: sqme
     type(region_data_t), intent(inout) :: reg_data
     type(real_kinematics_t), intent(in), target :: real_kinematics
     integer, intent(in) :: alr, i_phs, emitter, i_res
     real(default) :: s_alpha
     type(phs_point_set_t), pointer :: p_real => null ()
     if (reg_data%has_pseudo_isr ()) then
        p_real => real_kinematics%p_real_onshell (i_phs)
     else
        p_real => real_kinematics%p_real_cms
     end if
     s_alpha = reg_data%get_svalue (p_real%get_momenta(i_phs), alr, emitter, i_res)
     if (debug2_active (D_SUBTRACTION)) call msg_print_color('s_alpha', s_alpha, COL_YELLOW)
     if (s_alpha > one + tiny_07) call msg_fatal ("s_alpha > 1!")
     sqme = sqme * s_alpha
     associate (region => reg_data%regions(alr))
        if (emitter > reg_data%n_in) then
           if (debug2_active (D_SUBTRACTION)) &
                print *, 'Double FSR: ', region%double_fsr_factor (p_real%get_momenta(i_phs))
           sqme = sqme * region%double_fsr_factor (p_real%get_momenta(i_phs))
        end if
     end associate
   end subroutine evaluate_fks_factors
 
 @ %def evaluate_fks_factors
 @
 <<real subtraction: procedures>>=
   subroutine apply_kinematic_factors_radiation (sqme, purpose, real_kinematics, &
          i_phs, isr, threshold, emitter)
     real(default), intent(inout) :: sqme
     integer, intent(in) :: purpose
     type(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: i_phs
     logical, intent(in) :: isr, threshold
     integer, intent(in), optional :: emitter
     real(default) :: xi, xi_tilde, s
     xi_tilde = real_kinematics%xi_tilde
     xi = xi_tilde * real_kinematics%xi_max (i_phs)
     select case (purpose)
     case (INTEGRATION, FIXED_ORDER_EVENTS)
        sqme = sqme * xi**2 / xi_tilde * real_kinematics%jac(i_phs)%jac(1)
     case (POWHEG)
        if (.not. isr) then
           s = real_kinematics%cms_energy2
           sqme = sqme * real_kinematics%jac(i_phs)%jac(1) * s / (8 * twopi3) * xi
        else
           call msg_fatal ("POWHEG with initial-state radiation not implemented yet")
        end if
     end select
   end subroutine apply_kinematic_factors_radiation
 
 @ %def apply_kinematics_factors_radiation
 @ This routine applies the factors in the integrand of eq. 4.20
 in arXiv:1002.2581 to the matrix elements.
 <<real subtraction: procedures>>=
   subroutine apply_kinematic_factors_subtraction_fsr &
      (sqme_soft, sqme_coll, sqme_cs, real_kinematics, i_phs)
     real(default), intent(inout) :: sqme_soft, sqme_coll, sqme_cs
     type(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: i_phs
     real(default) :: xi_tilde, onemy
     xi_tilde = real_kinematics%xi_tilde
     onemy = one - real_kinematics%y(i_phs)
     sqme_soft = sqme_soft / onemy / xi_tilde
     sqme_coll = sqme_coll / onemy / xi_tilde
     sqme_cs = sqme_cs / onemy / xi_tilde
     associate (jac => real_kinematics%jac(i_phs)%jac)
        sqme_soft = sqme_soft * jac(2)
        sqme_coll = sqme_coll * jac(3)
        sqme_cs = sqme_cs * jac(2)
     end associate
   end subroutine apply_kinematic_factors_subtraction_fsr
 
 @ %def apply_kinematic_factors_subtraction_fsr
 @ This routine applies the factors in the integrand of eq. 4.21
 in arXiv:1002.2581 to the matrix elements.
 <<real subtraction: procedures>>=
   subroutine apply_kinematic_factors_subtraction_isr &
      (sqme_soft, sqme_coll_plus, sqme_coll_minus, sqme_cs_plus, &
       sqme_cs_minus, real_kinematics, i_phs)
     real(default), intent(inout) :: sqme_soft, sqme_coll_plus, sqme_coll_minus
     real(default), intent(inout) :: sqme_cs_plus, sqme_cs_minus
     type(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: i_phs
     real(default) :: xi_tilde, y, onemy, onepy
     xi_tilde = real_kinematics%xi_tilde
     y = real_kinematics%y (i_phs)
     onemy = one - y; onepy = one + y
     associate (jac => real_kinematics%jac(i_phs)%jac)
        sqme_soft = sqme_soft / (one - y**2) / xi_tilde * jac(2)
        sqme_coll_plus = sqme_coll_plus / onemy / xi_tilde / two * jac(3)
        sqme_coll_minus = sqme_coll_minus / onepy / xi_tilde / two * jac(4)
        sqme_cs_plus = sqme_cs_plus / onemy / xi_tilde / two * jac(2)
        sqme_cs_minus = sqme_cs_minus / onepy / xi_tilde / two * jac(2)
     end associate
   end subroutine apply_kinematic_factors_subtraction_isr
 
 @ %def apply_kinematic_factors_subtraction_isr
 @ This subroutine evaluates the soft and collinear subtraction terms for ISR.
 References:
 \begin{itemize}
   \item arXiv:0709.2092, sec. 2.4.2
   \item arXiv:0908.4272, sec. 4.2
 \end{itemize}
 For the collinear terms, the procedure is as follows:
 
 If the emitter is 0, then a gluon was radiated from one of the incoming partons.
 Gluon emissions require two counter terms:
 One for emission in the direction of the first incoming parton $\oplus$
 and a second for emission in the direction of the second incoming parton $\ominus$
 because in both cases, there are divergent diagrams contributing to the matrix element.
 So in this case both, [[sqme_coll_plus]] and [[sqme_coll_minus]], are non-zero.
 
 If the emitter is 1 or 2, then a quark was emitted instead of a gluon.
 This only leads to a divergence collinear to the emitter because for anti-collinear
 quark emission, there are simply no divergent diagrams in the same region as two
 collinear quarks that cannot originate in the same splitting are non-divergent.
 This means that in case the emitter is 1, we need non-zero [[sqme_coll_plus]]
 and in case the emitter is 2, we need non-zero [[sqme_coll_minus]].
 
 At this point, we want to remind ourselves that in case of initial state divergences,
 $y$ is just the polar angle, so the [[sqme_coll_minus]] terms are there to counter emissions in
 the direction of the second incoming parton $\ominus$ and \textbf{not} to counter in general
 anti-collinear divergences.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_subtraction_terms_isr => &
       real_subtraction_evaluate_subtraction_terms_isr
 <<real subtraction: procedures>>=
   subroutine real_subtraction_evaluate_subtraction_terms_isr (rsub, &
       alr, emitter, i_phs, i_res, alpha_coupling, sqme_soft, sqme_coll_plus, &
       sqme_coll_minus, sqme_cs_plus, sqme_cs_minus)
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     real(default), intent(out) :: sqme_soft
     real(default), intent(out) :: sqme_coll_plus, sqme_coll_minus
     real(default), intent(out) :: sqme_cs_plus, sqme_cs_minus
     sqme_coll_plus = zero; sqme_cs_plus = zero
     sqme_coll_minus = zero; sqme_cs_minus = zero
     associate (xi_tilde => rsub%real_kinematics%xi_tilde, &
          y => rsub%real_kinematics%y(i_phs), template => rsub%settings%fks_template)
       if (template%xi_cut > xi_tilde) &
            sqme_soft = rsub%compute_sub_soft (alr, emitter, i_phs, i_res, alpha_coupling)
       if (emitter /= 2) then
          if (y - 1 + template%delta_i > 0) then
             sqme_coll_plus = rsub%compute_sub_coll (alr, 1, i_phs, alpha_coupling)
             if (template%xi_cut > xi_tilde) then
                sqme_cs_plus = rsub%compute_sub_coll_soft (alr, 1, i_phs, alpha_coupling)
             end if
          end if
       end if
       if (emitter /= 1) then
          if (-y - 1 + template%delta_i > 0) then
             sqme_coll_minus = rsub%compute_sub_coll (alr, 2, i_phs, alpha_coupling)
             if (template%xi_cut > xi_tilde) then
                sqme_cs_minus = rsub%compute_sub_coll_soft (alr, 2, i_phs, alpha_coupling)
             end if
          end if
       end if
       if (debug2_active (D_SUBTRACTION)) then
          print *, "ISR Cutoff:"
          print *, "y: ", y
          print *, "delta_i: ", template%delta_i
          print *, "emitter: ", emitter
          print *, "sub_soft: ", template%xi_cut > xi_tilde, "(ME: ", sqme_soft, ")"
          print *, "sub_coll_plus: ", (y - 1 + template%delta_i) > 0, "(ME: ", sqme_coll_plus, ")"
          print *, "sub_coll_minus: ", (-y - 1 + template%delta_i) > 0, "(ME: ", sqme_coll_minus, ")"
          print *, "sub_coll_soft_plus: ", template%xi_cut > xi_tilde .and. (y - 1 + template%delta_i) > 0, &
               "(ME: ", sqme_cs_plus, ")"
          print *, "sub_coll_soft_minus: ", template%xi_cut > xi_tilde .and. (-y - 1 + template%delta_i) > 0, &
               "(ME: ", sqme_cs_minus, ")"
       end if
     end associate
   end subroutine real_subtraction_evaluate_subtraction_terms_isr
 
 @ %def real_subtraction_evaluate_subtraction_terms_isr
 @ This is basically the global part of the real Jacobian corresponding to
 \begin{equation*}
   \frac{q^2}{8 (2\pi)^3}.
 \end{equation*}
 We interpret it as the additional phase space factor of the real component,
 to be more consistent with the evaluation of the Born phase space.
 
 We specifically use the Born center-of-mass energy here.
 The real center-of-mass energy is only different from the Born center-of-mass
 energy in case of ISR. The missing factor $\frac{1}{1 - \xi}$ for this
 conversion is supplied in [[apply_kinematic_factors_radiation]] and
 [[phs_fks_generator_generate_isr]].
 <<real subtraction: real subtraction: TBP>>=
   procedure :: get_phs_factor => real_subtraction_get_phs_factor
 <<real subtraction: procedures>>=
   function real_subtraction_get_phs_factor (rsub, i_con) result (factor)
     real(default) :: factor
     class(real_subtraction_t), intent(in) :: rsub
     integer, intent(in) :: i_con
     real(default) :: s
     s = rsub%real_kinematics%xi_ref_momenta (i_con)**2
     factor = s / (8 * twopi3)
   end function real_subtraction_get_phs_factor
 
 @ %def real_subtraction_get_phs_factor
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: get_i_contributor => real_subtraction_get_i_contributor
 <<real subtraction: procedures>>=
   function real_subtraction_get_i_contributor (rsub, alr) result (i_con)
     integer :: i_con
     class(real_subtraction_t), intent(in) :: rsub
     integer, intent(in) :: alr
     if (allocated (rsub%reg_data%alr_to_i_contributor)) then
        i_con = rsub%reg_data%alr_to_i_contributor (alr)
     else
        i_con = 1
     end if
   end function real_subtraction_get_i_contributor
 
 @ %def real_subtraction_get_i_contributor
 @ Computes the soft subtraction term.
 If there is an initial state emission having a soft divergence, then a gluon
 has to have been emitted. A gluon can always be emitted from both IS partons
 and thus, we can take the [[sf_factor]] for emitter $0$ in this case.
 Be aware that this approach will not work for $pe$ collisions.
 <<real subtraction: real subtraction: TBP>>=
   procedure :: compute_sub_soft => real_subtraction_compute_sub_soft
 <<real subtraction: procedures>>=
   function real_subtraction_compute_sub_soft (rsub, alr, emitter, &
        i_phs, i_res, alpha_coupling) result (sqme_soft)
     real(default) :: sqme_soft
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, emitter, i_phs, i_res
     real(default), intent(in) :: alpha_coupling
     integer :: i_xi_ref, i_born
     real(default) :: q2, sf_factor
     type(vector4_t), dimension(:), allocatable :: p_born
     associate (real_kinematics => rsub%real_kinematics, &
             nlo_corr_type => rsub%reg_data%regions(alr)%nlo_correction_type, &
             sregion => rsub%reg_data%regions(alr))
       sqme_soft = zero
       if (sregion%has_soft_divergence ()) then
          i_xi_ref = rsub%sub_soft%i_xi_ref (alr, i_phs)
          q2 = real_kinematics%xi_ref_momenta (i_xi_ref)**2
          allocate (p_born (rsub%reg_data%n_legs_born))
          if (rsub%reg_data%has_pseudo_isr ()) then
             p_born = real_kinematics%p_born_onshell%get_momenta (1)
          else
             p_born = real_kinematics%p_born_cms%get_momenta (1)
          end if
          if (emitter > rsub%sub_soft%reg_data%n_in) then
             call rsub%sub_soft%create_softvec_fsr &
                  (p_born, real_kinematics%y_soft(i_phs), &
                  real_kinematics%phi, emitter, &
                  real_kinematics%xi_ref_momenta(i_xi_ref))
             sf_factor = one
          else
             call rsub%sub_soft%create_softvec_isr &
                  (real_kinematics%y_soft(i_phs), real_kinematics%phi)
             sf_factor = rsub%sf_factors(alr, 0)
          end if
          i_born = sregion%uborn_index
          select case (char (nlo_corr_type))
          case ("QCD")
             sqme_soft = rsub%sub_soft%compute &
             (p_born, rsub%sqme_born_color_c(:,:,i_born) * &
             sf_factor, real_kinematics%y(i_phs), &
             q2, alpha_coupling, alr, emitter, i_res)
          case ("EW")
             sqme_soft = rsub%sub_soft%compute &
             (p_born, rsub%sqme_born_charge_c(:,:,i_born) * &
             sf_factor, real_kinematics%y(i_phs), &
             q2, alpha_coupling, alr, emitter, i_res)
          end select
       end if
     end associate
     if (debug2_active (D_SUBTRACTION)) call check_soft_vector ()
   contains
     subroutine check_soft_vector ()
       !!! p_soft = p_gluon / E_gluon only in the soft limit
       !!! This check only has to be passed for ISR or for FSR if ?test_soft_limit = true is set.
       type(vector4_t) :: p_gluon
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "Compare soft vector: ")
       print *, 'p_soft: ', rsub%sub_soft%p_soft%p
       print *, 'Normalized gluon momentum: '
       if (rsub%reg_data%has_pseudo_isr ()) then
          p_gluon = rsub%real_kinematics%p_real_onshell(thr_leg(emitter))%get_momentum &
               (i_phs, rsub%reg_data%n_legs_real)
       else
          p_gluon = rsub%real_kinematics%p_real_cms%get_momentum &
               (i_phs, rsub%reg_data%n_legs_real)
       end if
       call vector4_write (p_gluon / p_gluon%p(0), show_mass = .true.)
     end subroutine check_soft_vector
   end function real_subtraction_compute_sub_soft
 
 @ %def real_subtraction_compute_sub_soft
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: get_spin_correlation_term => real_subtraction_get_spin_correlation_term
 <<real subtraction: procedures>>=
   function real_subtraction_get_spin_correlation_term (rsub, alr, i_born, emitter) &
         result (mom_times_sqme)
     real(default) :: mom_times_sqme
     class(real_subtraction_t), intent(in) :: rsub
     integer, intent(in) :: alr, i_born, emitter
     real(default), dimension(0:3) :: k_perp
     integer :: mu, nu
     if (rsub%sc_required(alr)) then
        if (debug2_active(D_SUBTRACTION)) call check_me_consistency ()
        associate (real_kin => rsub%real_kinematics)
          if (emitter > rsub%reg_data%n_in) then
             k_perp = real_subtraction_compute_k_perp_fsr ( &
                  real_kin%p_born_lab%get_momentum(1, emitter), &
                  rsub%real_kinematics%phi)
          else
             k_perp = real_subtraction_compute_k_perp_isr ( &
                  real_kin%p_born_lab%get_momentum(1, emitter), &
                  rsub%real_kinematics%phi)
          end if
        end associate
        mom_times_sqme = zero
        do mu = 1, 3
           do nu = 1, 3
              mom_times_sqme = mom_times_sqme + &
                   k_perp(mu) * k_perp(nu) * rsub%sqme_born_spin_c (mu, nu, emitter, i_born)
           end do
        end do
     else
        mom_times_sqme = zero
     end if
   contains
     subroutine check_me_consistency ()
       real(default) ::  sqme_sum
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "Spin-correlation: Consistency check")
       sqme_sum = &
                - rsub%sqme_born_spin_c(1,1,emitter,i_born) &
                - rsub%sqme_born_spin_c(2,2,emitter,i_born) &
                - rsub%sqme_born_spin_c(3,3,emitter,i_born)
       if (.not. nearly_equal (sqme_sum, -rsub%sqme_born(i_born))) then
          print *, 'Spin-correlated matrix elements are not consistent: '
          print *, 'emitter: ', emitter
          print *, 'g^{mu,nu} B_{mu,nu}: ', -sqme_sum
          print *, 'all Born matrix elements: ', rsub%sqme_born
          call msg_fatal ("FAIL")
       else
          call msg_print_color ("Success", COL_GREEN)
       end if
     end subroutine check_me_consistency
   end function real_subtraction_get_spin_correlation_term
 
 @ %def real_subtraction_get_spin_correlation_term
 @ Construct a normalised momentum perpendicular to momentum [[p]] and rotate by
 an arbitrary angle [[phi]]. The angular conventions we use here are
 equivalent to those used by POWHEG.
 <<real subtraction: public>>=
   public :: real_subtraction_compute_k_perp_fsr, &
        real_subtraction_compute_k_perp_isr
 <<real subtraction: procedures>>=
   function real_subtraction_compute_k_perp_fsr (p, phi) result (k_perp_fsr)
     real(default), dimension(0:3) :: k_perp_fsr
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: phi
     type(vector4_t) :: k
     type(vector3_t) :: vec
     type(lorentz_transformation_t) :: rot
     vec = p%p(1:3) / p%p(0)
     k%p(0) = zero
     k%p(1) = p%p(1); k%p(2) = p%p(2)
     k%p(3) = - (p%p(1)**2 + p%p(2)**2) / p%p(3)
     rot = rotation (cos(phi), sin(phi), vec)
     k = rot * k
     k%p(1:3) = k%p(1:3) / space_part_norm (k)
     k_perp_fsr = k%p
   end function real_subtraction_compute_k_perp_fsr
 
   function real_subtraction_compute_k_perp_isr (p, phi) result (k_perp_isr)
     real(default), dimension(0:3) :: k_perp_isr
     type(vector4_t), intent(in) :: p
     real(default), intent(in) :: phi
     k_perp_isr(0) = zero
     k_perp_isr(1) = sin(phi)
     k_perp_isr(2) = cos(phi)
     k_perp_isr(3) = zero
   end function real_subtraction_compute_k_perp_isr
 
 @ %def real_subtraction_compute_k_perp_fsr, real_subtraction_compute_k_perp_isr
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: compute_sub_coll => real_subtraction_compute_sub_coll
 <<real subtraction: procedures>>=
   function real_subtraction_compute_sub_coll (rsub, alr, em, i_phs, alpha_coupling) &
          result (sqme_coll)
     real(default) :: sqme_coll
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, em, i_phs
     real(default), intent(in) :: alpha_coupling
     real(default) :: xi, xi_max
     real(default) :: mom_times_sqme_spin_c
     real(default) :: N_col
     integer :: i_con
     real(default) :: pfr
     associate (sregion => rsub%reg_data%regions(alr))
       sqme_coll = zero
       N_col = 1
       if (sregion%has_collinear_divergence ()) then
          xi = rsub%real_kinematics%xi_tilde * rsub%real_kinematics%xi_max(i_phs)
          if (rsub%sub_coll%use_resonance_mappings) then
             i_con = rsub%reg_data%alr_to_i_contributor (alr)
          else
             i_con = 1
          end if
          mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em)
          if (em <= rsub%sub_coll%n_in) then
             select case (rsub%isr_kinematics%isr_mode)
             case (SQRTS_FIXED)
                xi_max = rsub%real_kinematics%xi_max(i_phs)
             case (SQRTS_VAR)
                xi_max = one - rsub%isr_kinematics%x(em)
             end select
             xi = rsub%real_kinematics%xi_tilde * xi_max
             if (sregion%nlo_correction_type == "QCD") then
                call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
             else if (sregion%nlo_correction_type == "EW") then
                if (is_quark (sregion%flst_real%flst(size(sregion%flst_real%flst)))) N_col = 3
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(em)**2, &
                     TR = N_col*sregion%flst_real%charge(size(sregion%flst_real%flst))**2)
             end if
             sqme_coll = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, &
                  rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
                  rsub%sqme_born(sregion%uborn_index) * rsub%sf_factors(alr, em), &
                  mom_times_sqme_spin_c * rsub%sf_factors(alr, em), &
                  xi, alpha_coupling, rsub%isr_kinematics%isr_mode)
          else
             if (sregion%nlo_correction_type == "QCD") then
                call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
             else if (sregion%nlo_correction_type == "EW") then
                if (is_quark (sregion%flst_real%flst(sregion%emitter))) N_col = 3
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(sregion%emitter)**2, &
                     TR = N_col*sregion%flst_real%charge(sregion%emitter)**2)
             end if
             sqme_coll = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, &
                  rsub%real_kinematics%xi_ref_momenta (i_con), &
                  rsub%real_kinematics%p_born_lab%get_momenta(1), &
                  rsub%sqme_born(sregion%uborn_index), &
                  mom_times_sqme_spin_c, &
                  xi, alpha_coupling, sregion%double_fsr)
             if (rsub%sub_coll%use_resonance_mappings) then
                select type (fks_mapping => rsub%reg_data%fks_mapping)
                type is (fks_mapping_resonances_t)
                   pfr = fks_mapping%get_resonance_weight (alr, &
                        rsub%real_kinematics%p_born_cms%get_momenta(1))
                end select
                sqme_coll = sqme_coll * pfr
             end if
          end if
       end if
     end associate
   end function real_subtraction_compute_sub_coll
 
 @ %def real_subtraction_compute_sub_coll
 @ Computes the soft-collinear subtraction term. For alpha regions with emitter
 $0$, this routine is called with [[em == 1]] and [[em == 2]] separately.
 To still be able to use the unrescaled pdf factors stored in [[sf_factors(alr, 0)]]
 in this case, we need to differentiate between [[em]] and [[em_pdf]].
 <<real subtraction: real subtraction: TBP>>=
   procedure :: compute_sub_coll_soft => real_subtraction_compute_sub_coll_soft
 <<real subtraction: procedures>>=
   function real_subtraction_compute_sub_coll_soft (rsub, alr, em, i_phs, alpha_coupling) &
        result (sqme_cs)
     real(default) :: sqme_cs
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: alr, em, i_phs
     real(default), intent(in) :: alpha_coupling
     real(default) :: mom_times_sqme_spin_c
     real(default) :: N_col
     integer :: i_con, em_pdf
     associate (sregion => rsub%reg_data%regions(alr))
       sqme_cs = zero
       N_col = 1
       if (sregion%has_collinear_divergence ()) then
          if (rsub%sub_coll%use_resonance_mappings) then
             i_con = rsub%reg_data%alr_to_i_contributor (alr)
          else
             i_con = 1
          end if
          mom_times_sqme_spin_c = rsub%get_spin_correlation_term (alr, sregion%uborn_index, em)
          if (em <= rsub%sub_coll%n_in) then
             em_pdf = sregion%emitter
             if (sregion%nlo_correction_type == "QCD") then
                call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
             else if (sregion%nlo_correction_type == "EW") then
                if (is_quark (sregion%flst_real%flst(size(sregion%flst_real%flst)))) N_col = 3
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(em)**2, &
                     TR = N_col*sregion%flst_real%charge(size(sregion%flst_real%flst))**2)
             end if
             sqme_cs = rsub%sub_coll%compute_isr (em, sregion%flst_real%flst, &
                  rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
                  rsub%sqme_born(sregion%uborn_index) * rsub%sf_factors(alr, em_pdf), &
                  mom_times_sqme_spin_c * rsub%sf_factors(alr, em_pdf), &
                  zero, alpha_coupling, rsub%isr_kinematics%isr_mode)
          else
             if (sregion%nlo_correction_type == "QCD") then
                call rsub%sub_coll%set_parameters (CA = CA, CF = CF, TR = TR)
             else if (sregion%nlo_correction_type == "EW") then
                if (is_quark (sregion%flst_real%flst(sregion%emitter))) N_col = 3
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(sregion%emitter)**2, &
                     TR = N_col*sregion%flst_real%charge(sregion%emitter)**2)
             end if
             sqme_cs = rsub%sub_coll%compute_fsr (sregion%emitter, sregion%flst_real%flst, &
                  rsub%real_kinematics%xi_ref_momenta(i_con), &
                  rsub%real_kinematics%p_born_lab%phs_point(1)%p, &
                  rsub%sqme_born(sregion%uborn_index), &
                  mom_times_sqme_spin_c, &
                  zero, alpha_coupling, sregion%double_fsr)
          end if
       end if
     end associate
   end function real_subtraction_compute_sub_coll_soft
 
 @ %def real_subtraction_compute_sub_coll_soft
 <<real subtraction: real subtraction: TBP>>=
   procedure :: requires_spin_correlations => &
        real_subtraction_requires_spin_correlations
 <<real subtraction: procedures>>=
   function real_subtraction_requires_spin_correlations (rsub) result (val)
     logical :: val
     class(real_subtraction_t), intent(in) :: rsub
     val = any (rsub%sc_required)
   end function real_subtraction_requires_spin_correlations
 
 @ %def real_subtraction_requires_spin_correlations
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: final => real_subtraction_final
 <<real subtraction: procedures>>=
   subroutine real_subtraction_final (rsub)
     class(real_subtraction_t), intent(inout) :: rsub
     call rsub%sub_soft%final ()
     call rsub%sub_coll%final ()
     !!! Finalization of region data is done in pcm_nlo_final
     if (associated (rsub%reg_data)) nullify (rsub%reg_data)
     !!! Finalization of real kinematics is done in pcm_instance_nlo_final
     if (associated (rsub%real_kinematics)) nullify (rsub%real_kinematics)
     if (associated (rsub%isr_kinematics)) nullify (rsub%isr_kinematics)
     if (allocated (rsub%sqme_real_non_sub)) deallocate (rsub%sqme_real_non_sub)
     if (allocated (rsub%sqme_born)) deallocate (rsub%sqme_born)
     if (allocated (rsub%sf_factors)) deallocate (rsub%sf_factors)
     if (allocated (rsub%sqme_born_color_c)) deallocate (rsub%sqme_born_color_c)
     if (allocated (rsub%sqme_born_charge_c)) deallocate (rsub%sqme_born_charge_c)
     if (allocated (rsub%sc_required)) deallocate (rsub%sc_required)
     if (allocated (rsub%selected_alr)) deallocate (rsub%selected_alr)
   end subroutine real_subtraction_final
 
 @ %def real_subtraction_final
 @ \subsubsection{Partitions of the real matrix element and Powheg damping}
 <<real subtraction: public>>=
   public :: real_partition_t
 <<real subtraction: types>>=
   type, abstract :: real_partition_t
   contains
   <<real subtraction: real partition: TBP>>
   end type real_partition_t
 
 @ %def real partition_t
 @
 <<real subtraction: real partition: TBP>>=
   procedure (real_partition_init), deferred :: init
 <<real subtraction: interfaces>>=
   abstract interface
      subroutine real_partition_init (partition, scale, reg_data)
        import
        class(real_partition_t), intent(out) :: partition
        real(default), intent(in) :: scale
        type(region_data_t), intent(in) :: reg_data
      end subroutine real_partition_init
   end interface
 
 @ %def real_partition_init
 @
 <<real subtraction: real partition: TBP>>=
   procedure (real_partition_write), deferred :: write
 <<real subtraction: interfaces>>=
   abstract interface
      subroutine real_partition_write (partition, unit)
        import
        class(real_partition_t), intent(in) :: partition
        integer, intent(in), optional :: unit
      end subroutine real_partition_write
   end interface
 
 @ %def real_partition_write
 @ To allow really arbitrary damping functions, [[get_f]] should get the
 full real phase space as argument and not just some [[pt2]] that is
 extracted higher up.
 <<real subtraction: real partition: TBP>>=
   procedure (real_partition_get_f), deferred :: get_f
 <<real subtraction: interfaces>>=
   abstract interface
     function real_partition_get_f (partition, p) result (f)
        import
        real(default) :: f
        class(real_partition_t), intent(in) :: partition
        type(vector4_t), intent(in), dimension(:) :: p
     end function real_partition_get_f
   end interface
 
 @ %def real_partition_get_f
 @
 <<real subtraction: public>>=
   public :: powheg_damping_simple_t
 <<real subtraction: types>>=
   type, extends (real_partition_t) :: powheg_damping_simple_t
      real(default) :: h2 = 5._default
      integer :: emitter
   contains
   <<real subtraction: powheg damping simple: TBP>>
   end type powheg_damping_simple_t
 
 @ %def powheg_damping_simple_t
 @
 <<real subtraction: powheg damping simple: TBP>>=
   procedure :: get_f => powheg_damping_simple_get_f
 <<real subtraction: procedures>>=
   function powheg_damping_simple_get_f (partition, p) result (f)
     real(default) :: f
     class(powheg_damping_simple_t), intent(in) :: partition
     type(vector4_t), intent(in), dimension(:) :: p
     !!! real(default) :: pt2
     f = 1
     call msg_bug ("Simple damping currently not available")
     !!! TODO (cw-2017-03-01) Compute pt2 from emitter)
     !!! f = partition%h2 / (pt2 + partition%h2)
   end function powheg_damping_simple_get_f
 
 @ %def powheg_damping_simple_get_f
 @
 <<real subtraction: powheg damping simple: TBP>>=
   procedure :: init => powheg_damping_simple_init
 <<real subtraction: procedures>>=
   subroutine powheg_damping_simple_init (partition, scale, reg_data)
     class(powheg_damping_simple_t), intent(out) :: partition
     real(default), intent(in) :: scale
     type(region_data_t), intent(in) :: reg_data
     partition%h2 = scale**2
   end subroutine powheg_damping_simple_init
 
 @ %def powheg_damping_simple_init
 @
 <<real subtraction: powheg damping simple: TBP>>=
   procedure :: write => powheg_damping_simple_write
 <<real subtraction: procedures>>=
   subroutine powheg_damping_simple_write (partition, unit)
     class(powheg_damping_simple_t), intent(in) :: partition
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(1x,A)") "Powheg damping simple: "
     write (u, "(1x,A, "// FMT_15 // ")") "scale h2: ", partition%h2
   end subroutine powheg_damping_simple_write
 
 @ %def powheg_damping_simple_write
 @
 <<real subtraction: public>>=
   public :: real_partition_fixed_order_t
 <<real subtraction: types>>=
   type, extends (real_partition_t) :: real_partition_fixed_order_t
      real(default) :: scale
      type(ftuple_t), dimension(:), allocatable :: fks_pairs
   contains
   <<real subtraction: real partition fixed order: TBP>>
   end type real_partition_fixed_order_t
 
 @ %def real_partition_fixed_order_t
 @
 <<real subtraction: real partition fixed order: TBP>>=
   procedure :: init => real_partition_fixed_order_init
 <<real subtraction: procedures>>=
   subroutine real_partition_fixed_order_init (partition, scale, reg_data)
     class(real_partition_fixed_order_t), intent(out) :: partition
     real(default), intent(in) :: scale
     type(region_data_t), intent(in) :: reg_data
   end subroutine real_partition_fixed_order_init
 
 @ %def real_partition_fixed_order_init
 @
 <<real subtraction: real partition fixed order: TBP>>=
   procedure :: write => real_partition_fixed_order_write
 <<real subtraction: procedures>>=
   subroutine real_partition_fixed_order_write (partition, unit)
     class(real_partition_fixed_order_t), intent(in) :: partition
     integer, intent(in), optional :: unit
   end subroutine real_partition_fixed_order_write
 
 @ %def real_partition_fixed_order_write
-@
+@ Implements the suppression factor
+\begin{equation}
+  F(\Phi_{n+1}) = 1 - \prod_{(i,j) \in P_{FKS}} \theta \left[ m_i + m_j + h - \sqrt{(p_j + p_j)^2} \right]
+\end{equation}
+to split the real matrix element into singular and finite part.
 <<real subtraction: real partition fixed order: TBP>>=
   procedure :: get_f => real_partition_fixed_order_get_f
 <<real subtraction: procedures>>=
   function real_partition_fixed_order_get_f (partition, p) result (f)
     real(default) :: f
     class(real_partition_fixed_order_t), intent(in) :: partition
     type(vector4_t), intent(in), dimension(:) :: p
-    integer :: i
+    integer :: i, em
     f = zero
-    do i = 1, size (partition%fks_pairs)
+    PAIRS: do i = 1, size (partition%fks_pairs)
        associate (ii => partition%fks_pairs(i)%ireg)
-          if ((p(ii(1)) + p(ii(2)))**1 < p(ii(1))**1 + p(ii(2))**1 + partition%scale) then
-             f = one
-             exit
+          if (ii(1) == 0) then
+            IS: do em = 1, 2
+               if ((p(em) + p(ii(2)))**1 < p(em)**1 + p(ii(2))**1 + partition%scale) then
+                  f = one
+                  exit PAIRS
+               end if
+            end do IS
+          else
+             if ((p(ii(1)) + p(ii(2)))**1 < p(ii(1))**1 + p(ii(2))**1 + partition%scale) then
+                f = one
+                exit PAIRS
+             end if
           end if
        end associate
-    end do
+    end do PAIRS
   end function real_partition_fixed_order_get_f
 
 @ %def real_partition_fixed_order_get_f
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[real_subtraction_ut.f90]]>>=
 <<File header>>
 
 module real_subtraction_ut
   use unit_tests
   use real_subtraction_uti
 
 <<Standard module head>>
 
 <<Real subtraction: public test>>
 
 contains
 
 <<Real subtraction: test driver>>
 
 end module real_subtraction_ut
 @ %def real_subtraction_ut
 @
 <<[[real_subtraction_uti.f90]]>>=
 <<File header>>
 
 module real_subtraction_uti
 <<Use kinds>>
 
   use physics_defs
   use lorentz
   use numeric_utils
   use real_subtraction
 
 <<Standard module head>>
 
 <<Real subtraction: test declarations>>
 
 contains
 
 <<Real subtraction: tests>>
 
 end module real_subtraction_uti
 @ %def real_subtraction_ut
 @ API: driver for the unit tests below.
 <<Real subtraction: public test>>=
   public :: real_subtraction_test
 <<Real subtraction: test driver>>=
   subroutine real_subtraction_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Real subtraction: execute tests>>
   end subroutine real_subtraction_test
 
 @ %def real_subtraction_test
 @ Test the final-state collinear subtraction.
 <<Real subtraction: execute tests>>=
   call test (real_subtraction_1, "real_subtraction_1", &
        "final-state collinear subtraction", &
        u, results)
 <<Real subtraction: test declarations>>=
   public :: real_subtraction_1
 <<Real subtraction: tests>>=
   subroutine real_subtraction_1 (u)
     integer, intent(in) :: u
 
     type(coll_subtraction_t) :: coll_sub
     real(default) :: sqme_coll
     type(vector4_t) :: p_res
     type(vector4_t), dimension(5) :: p_born
     real(default), dimension(4) :: k_perp
     real(default), dimension(4,4) :: b_munu
     integer :: mu, nu
     real(default) :: born, born_c
     integer, dimension(6) :: flst
 
     p_born(1)%p = [500, 0, 0, 500]
     p_born(2)%p = [500, 0, 0, -500]
     p_born(3)%p = [3.7755E+02, 2.2716E+02, -95.4172, 2.8608E+02]
     p_born(4)%p = [4.9529E+02, -2.739E+02, 84.8535, -4.0385E+02]
     p_born(5)%p = [1.2715E+02, 46.7375, 10.5637, 1.1778E+02]
     p_res = p_born(1) + p_born(2)
     flst = [11, -11 , -2, 2, -2, 2]
 
     b_munu(1, :) = [0., 0., 0., 0.]
     b_munu(2, :) = [0., 1., 1., 1.]
     b_munu(3, :) = [0., 1., 1., 1.]
     b_munu(4, :) = [0., 1., 1., 1.]
 
     k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default)
     born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4)
     born_c = 0.
     do mu = 1, 4
        do nu = 1, 4
           born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu)
        end do
     end do
 
     write (u, "(A)") "* Test output: real_subtraction_1"
     write (u, "(A)") "*   Purpose: final-state collinear subtraction"
     write (u, "(A)")
 
     write (u, "(A, L1)") "* vanishing scalar-product of 3-momenta k_perp and p_born(emitter): ", &
          nearly_equal (dot_product (p_born(5)%p(1:3), k_perp(2:4)), 0._default)
 
     call coll_sub%init (n_alr = 1, n_in = 2)
     call coll_sub%set_parameters (CA, CF, TR)
 
     write (u, "(A)")
     write (u, "(A)") "* g -> qq splitting"
     write (u, "(A)")
 
     sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, &
          born, born_c, 0.5_default, 0.25_default, .false.)
 
     write (u, "(A,F15.12)") "ME: ", sqme_coll
 
     write (u, "(A)")
     write (u, "(A)") "* g -> gg splitting"
     write (u, "(A)")
 
     b_munu(1, :) = [0., 0., 0., 0.]
     b_munu(2, :) = [0., 0., 0., 1.]
     b_munu(3, :) = [0., 0., 1., 1.]
     b_munu(4, :) = [0., 0., 1., 1.]
 
     k_perp = real_subtraction_compute_k_perp_fsr (p = p_born(5), phi = 0.5_default)
     born = - b_munu(1, 1) + b_munu(2, 2) + b_munu(3, 3) + b_munu(4, 4)
     born_c = 0.
     do mu = 1, 4
        do nu = 1, 4
           born_c = born_c + k_perp(mu) * k_perp(nu) * b_munu(mu, nu)
        end do
     end do
 
     flst = [11, -11, 2, -2, 21, 21]
     sqme_coll = coll_sub%compute_fsr(5, flst, p_res, p_born, &
          born, born_c, 0.5_default, 0.25_default, .true.)
 
     write (u, "(A,F15.12)") "ME: ", sqme_coll
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: real_subtraction_1"
     write (u, "(A)")
   end subroutine real_subtraction_1
 
 @ %def real_subtraction_1
 @
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Combining the FKS Pieces}
 <<[[nlo_data.f90]]>>=
 <<File header>>
 
 module nlo_data
 
 <<Use kinds>>
 <<Use strings>>
   use diagnostics
   use constants, only: zero
   use string_utils, only: split_string, read_ival, string_contains_word
   use io_units
   use lorentz
   use variables, only: var_list_t
   use format_defs, only: FMT_15
   use physics_defs, only: THR_POS_WP, THR_POS_WM
   use physics_defs, only: THR_POS_B, THR_POS_BBAR
   use physics_defs, only: NO_FACTORIZATION, FACTORIZATION_THRESHOLD
 
 <<Standard module head>>
 
 <<nlo data: public>>
 
 <<nlo data: parameters>>
 
 <<nlo data: types>>
 <<nlo data: interfaces>>
 
 contains
 
 <<nlo data: procedures>>
 
 end module nlo_data
 
 @ %def nlo_data
 @
 <<nlo data: parameters>>=
   integer, parameter, public :: FKS_DEFAULT = 1
   integer, parameter, public :: FKS_RESONANCES = 2
 
   integer, dimension(2), parameter, public :: ASSOCIATED_LEG_PAIR = [1, 3]
 
 @ %def parameters
 @
 <<nlo data: public>>=
   public :: fks_template_t
 <<nlo data: types>>=
   type :: fks_template_t
     logical :: subtraction_disabled = .false.
     integer :: mapping_type = FKS_DEFAULT
     logical :: count_kinematics = .false.
     real(default) :: fks_dij_exp1
     real(default) :: fks_dij_exp2
     real(default) :: xi_min
     real(default) :: y_max
     real(default) :: xi_cut, delta_o, delta_i
     type(string_t), dimension(:), allocatable :: excluded_resonances
     integer :: n_f
   contains
   <<nlo data: fks template: TBP>>
   end type fks_template_t
 
 @ %def fks_template_t
 @
 <<nlo data: fks template: TBP>>=
   procedure :: write => fks_template_write
 <<nlo data: procedures>>=
   subroutine fks_template_write (template, unit)
     class(fks_template_t), intent(in) :: template
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u,'(1x,A)') 'FKS Template: '
     write (u,'(1x,A)', advance = 'no') 'Mapping Type: '
     select case (template%mapping_type)
     case (FKS_DEFAULT)
        write (u,'(A)') 'Default'
     case (FKS_RESONANCES)
        write (u,'(A)') 'Resonances'
     case default
        write (u,'(A)') 'Unkown'
     end select
     write (u,'(1x,A,ES4.3,ES4.3)') 'd_ij exponentials: ', &
        template%fks_dij_exp1, template%fks_dij_exp2
     write (u, '(1x,A,ES4.3,ES4.3)') 'xi_cut: ', &
        template%xi_cut
     write (u, '(1x,A,ES4.3,ES4.3)') 'delta_o: ', &
        template%delta_o
     write (u, '(1x,A,ES4.3,ES4.3)') 'delta_i: ', &
          template%delta_i
   end subroutine fks_template_write
 
 @ %def fks_template_write
 @ Set FKS parameters. $\xi_{\text{cut}}, \delta_o$ and $\delta_{\mathrm{I}}$ steer the ratio of the integrated and real subtraction.
 <<nlo data: fks template: TBP>>=
   procedure :: set_parameters => fks_template_set_parameters
 <<nlo data: procedures>>=
   subroutine fks_template_set_parameters (template, exp1, exp2, xi_min, &
     y_max, xi_cut, delta_o, delta_i)
     class(fks_template_t), intent(inout) :: template
     real(default), intent(in) :: exp1, exp2
     real(default), intent(in) :: xi_min, y_max, &
          xi_cut, delta_o, delta_i
     template%fks_dij_exp1 = exp1
     template%fks_dij_exp2 = exp2
     template%xi_min = xi_min
     template%y_max = y_max
     template%xi_cut = xi_cut
     template%delta_o = delta_o
     template%delta_i = delta_i
   end subroutine fks_template_set_parameters
 
 @ %def fks_template_set_parameters
 <<nlo data: fks template: TBP>>=
   procedure :: set_mapping_type => fks_template_set_mapping_type
 <<nlo data: procedures>>=
   subroutine fks_template_set_mapping_type (template, val)
     class(fks_template_t), intent(inout) :: template
     integer, intent(in) :: val
     template%mapping_type = val
   end subroutine fks_template_set_mapping_type
 
 @ %def fks_template_set_mapping_type
 @
 <<nlo data: fks template: TBP>>=
   procedure :: set_counter => fks_template_set_counter
 <<nlo data: procedures>>=
   subroutine fks_template_set_counter (template)
     class(fks_template_t), intent(inout) :: template
     template%count_kinematics = .true.
   end subroutine fks_template_set_counter
 
 @ %def fks_template_set_counter
 @
 <<nlo data: public>>=
   public :: real_scales_t
 <<nlo data: types>>=
   type :: real_scales_t
      real(default) :: scale
      real(default) :: ren_scale
      real(default) :: fac_scale
      real(default) :: scale_born
      real(default) :: fac_scale_born
      real(default) :: ren_scale_born
   end type real_scales_t
 
 @ %def real_scales_t
 @
 <<nlo data: public>>=
   public :: get_threshold_momenta
 <<nlo data: procedures>>=
   function get_threshold_momenta (p) result (p_thr)
     type(vector4_t), dimension(4) :: p_thr
     type(vector4_t), intent(in), dimension(:) :: p
     p_thr(1) = p(THR_POS_WP) + p(THR_POS_B)
     p_thr(2) = p(THR_POS_B)
     p_thr(3) = p(THR_POS_WM) + p(THR_POS_BBAR)
     p_thr(4) = p(THR_POS_BBAR)
   end function get_threshold_momenta
 
 @ %def get_threshold_momenta
 @
 \subsection{Putting it together}
 <<nlo data: public>>=
   public :: nlo_settings_t
 <<nlo data: types>>=
   type :: nlo_settings_t
      logical :: use_internal_color_correlations = .true.
      logical :: use_internal_spin_correlations = .false.
      logical :: use_resonance_mappings = .false.
      logical :: combined_integration = .false.
      logical :: fixed_order_nlo = .false.
      logical :: test_soft_limit = .false.
      logical :: test_coll_limit = .false.
      logical :: test_anti_coll_limit = .false.
      integer, dimension(:), allocatable :: selected_alr
      integer :: factorization_mode = NO_FACTORIZATION
      !!! Probably not the right place for this. Revisit after refactoring
      real(default) :: powheg_damping_scale = zero
      type(fks_template_t) :: fks_template
      type(string_t) :: virtual_selection
      logical :: virtual_resonance_aware_collinear = .true.
      logical :: use_born_scale = .false.
      logical :: cut_all_real_sqmes = .false.
      type(string_t) :: nlo_correction_type
      logical :: reuse_amplitudes_fks = .false.
   contains
   <<nlo data: nlo settings: TBP>>
   end type nlo_settings_t
 
 @ %def nlo_settings_t
 @
 <<nlo data: nlo settings: TBP>>=
 procedure :: init => nlo_settings_init
 <<nlo data: procedures>>=
   subroutine nlo_settings_init (nlo_settings, var_list, fks_template)
     class(nlo_settings_t), intent(inout) :: nlo_settings
     type(var_list_t), intent(in) :: var_list
     type(fks_template_t), intent(in), optional :: fks_template
     type(string_t) :: color_method
     if (present (fks_template)) nlo_settings%fks_template = fks_template
     color_method = var_list%get_sval (var_str ('$correlation_me_method'))
     if (color_method == "")  color_method = var_list%get_sval (var_str ('$method'))
     nlo_settings%use_internal_color_correlations = color_method == 'omega' &
            .or. color_method == 'threshold'
     nlo_settings%combined_integration = var_list%get_lval &
            (var_str ("?combined_nlo_integration"))
     nlo_settings%fixed_order_nlo = var_list%get_lval &
            (var_str ("?fixed_order_nlo_events"))
     nlo_settings%test_soft_limit = var_list%get_lval (var_str ('?test_soft_limit'))
     nlo_settings%test_coll_limit = var_list%get_lval (var_str ('?test_coll_limit'))
     nlo_settings%test_anti_coll_limit = var_list%get_lval (var_str ('?test_anti_coll_limit'))
     call setup_alr_selection ()
     nlo_settings%virtual_selection = var_list%get_sval (var_str ('$virtual_selection'))
     nlo_settings%virtual_resonance_aware_collinear = &
          var_list%get_lval (var_str ('?virtual_collinear_resonance_aware'))
     nlo_settings%powheg_damping_scale = &
          var_list%get_rval (var_str ('powheg_damping_scale'))
     nlo_settings%use_born_scale = &
          var_list%get_lval (var_str ("?nlo_use_born_scale"))
     nlo_settings%cut_all_real_sqmes = &
          var_list%get_lval (var_str ("?nlo_cut_all_real_sqmes"))
     nlo_settings%nlo_correction_type = var_list%get_sval (var_str ('$nlo_correction_type'))
     nlo_settings%reuse_amplitudes_fks = var_list%get_lval (var_str ('?nlo_reuse_amplitudes_fks'))
   contains
     subroutine setup_alr_selection ()
       type(string_t) :: alr_selection
       type(string_t), dimension(:), allocatable :: alr_split
       integer :: i, i1, i2
       alr_selection = var_list%get_sval (var_str ('$select_alpha_regions'))
       if (string_contains_word (alr_selection, var_str (","))) then
          call split_string (alr_selection, var_str (","), alr_split)
          allocate (nlo_settings%selected_alr (size (alr_split)))
          do i = 1, size (alr_split)
             nlo_settings%selected_alr(i) = read_ival(alr_split(i))
          end do
       else if (string_contains_word (alr_selection, var_str (":"))) then
          call split_string (alr_selection, var_str (":"), alr_split)
          if (size (alr_split) == 2) then
             i1 = read_ival (alr_split(1))
             i2 = read_ival (alr_split(2))
             allocate (nlo_settings%selected_alr (i2 - i1 + 1))
             do i = 1, i2 - i1 + 1
                nlo_settings%selected_alr(i) = read_ival (alr_split(i))
             end do
          else
             call msg_fatal ("select_alpha_regions: ':' specifies a range!")
          end if
       else if (len(alr_selection) == 1) then
          allocate (nlo_settings%selected_alr (1))
          nlo_settings%selected_alr(1) = read_ival (alr_selection)
       end if
       if (allocated (alr_split)) deallocate (alr_split)
     end subroutine setup_alr_selection
   end subroutine nlo_settings_init
 
 @ %def nlo_settings_init
 @
 <<nlo data: nlo settings: TBP>>=
   procedure :: write => nlo_settings_write
 <<nlo data: procedures>>=
   subroutine nlo_settings_write (nlo_settings, unit)
     class(nlo_settings_t), intent(in) :: nlo_settings
     integer, intent(in), optional :: unit
     integer :: i, u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, '(A)') 'nlo_settings:'
     write (u, '(3X,A,L1)') 'internal_color_correlations = ', &
          nlo_settings%use_internal_color_correlations
     write (u, '(3X,A,L1)') 'internal_spin_correlations = ', &
          nlo_settings%use_internal_spin_correlations
     write (u, '(3X,A,L1)') 'use_resonance_mappings = ', &
          nlo_settings%use_resonance_mappings
     write (u, '(3X,A,L1)') 'combined_integration = ', &
          nlo_settings%combined_integration
     write (u, '(3X,A,L1)') 'test_soft_limit = ', &
          nlo_settings%test_soft_limit
     write (u, '(3X,A,L1)') 'test_coll_limit = ', &
          nlo_settings%test_coll_limit
     write (u, '(3X,A,L1)') 'test_anti_coll_limit = ', &
          nlo_settings%test_anti_coll_limit
     if (allocated (nlo_settings%selected_alr)) then
        write (u, '(3x,A)', advance = "no") 'selected alpha regions = ['
        do i = 1, size (nlo_settings%selected_alr)
           write (u, '(A,I0)', advance = "no") ",", nlo_settings%selected_alr(i)
        end do
        write (u, '(A)') "]"
     end if
     write (u, '(3X,A,' // FMT_15 // ')') 'powheg_damping_scale = ', &
          nlo_settings%powheg_damping_scale
     write (u, '(3X,A,A)') 'virtual_selection = ', &
          char (nlo_settings%virtual_selection)
     write (u, '(3X,A,A)') 'Real factorization mode = ', &
          char (factorization_mode (nlo_settings%factorization_mode))
   contains
     function factorization_mode (fm)
       type(string_t) :: factorization_mode
       integer, intent(in) :: fm
       select case (fm)
       case (NO_FACTORIZATION)
          factorization_mode = var_str ("None")
       case (FACTORIZATION_THRESHOLD)
          factorization_mode = var_str ("Threshold")
       case default
          factorization_mode = var_str ("Undefined!")
       end select
     end function factorization_mode
   end subroutine nlo_settings_write
 
 @ %def nlo_settings_write
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Contribution of divergencies due to PDF Evolution}
 
 References:
 \begin{itemize}
 \item arXiv:hep-ph/9512328, (2.1)-(2.5), (4.29)-(4.53)
 \item arXiv:0709.2092, (2.102)-(2.106)
 \end{itemize}
 
 The parton distrubition densities have to be evaluated at NLO, too.
 The NLO PDF evolution is given by
 \begin{equation}
   \label{eqn:pdf_nlo}
   f (\bar{x}) = \int_0^1 \int_0^1 dx dz f(x) \Gamma(z) \delta (\bar{x} - x z),
 \end{equation}
 where $\Gamma$ are the DGLAP evolution kernels for an $a \to d$ splitting,
 \begin{equation}
   \label{eqn:dglap}
   \Gamma_a^{(d)} = \delta_{ad}\delta(1-x) - \frac{\alpha_s}{2\pi} \left(\frac{1}{\epsilon} P_{ad}(x,0) - K_{ad}(x)\right) + \mathcal{O}(\alpha_s^2).
 \end{equation}
 $K_{ad}$ is a renormalization scheme matching factor, which is exactly zero in $\overline{\text{MS}}$.
 Let the leading-order hadronic cross section be given by
 \begin{equation}
   \label{eqn:xsec_hadro_lo}
   d\sigma^{(0)}(s) = \int dx_\oplus dx_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus) d\tilde{\sigma}^{(0)} (x_\oplus x_\ominus s),
 \end{equation}
 then the NLO hadronic cross section is
 \begin{equation}
   \label{eqn:xsec_hadro_nlo}
   d\sigma^{(1)}(s) = \int dx_\oplus dx_\ominus dz_\oplus dz_\ominus f_\oplus (x_\oplus) f_\ominus (x_\ominus)
                      \underbrace{\Gamma_\oplus (z_\oplus) \Gamma_\ominus (z_\ominus) d\tilde{\sigma}^{(1)} (z_\oplus z_\ominus s)}_{d\hat{\sigma}^{(1)}}.
 \end{equation}
 $d\hat{\sigma}$ is called the subtracted partonic cross section. Expanding in $\alpha_s$ we find
 \begin{align}
   d\hat{\sigma}^{(0)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(0)} (k_1, k_2), \\
   d\hat{\sigma}^{(1)}_{ab}(k_1, k_2) &= d\tilde{\sigma}_{ab}^{(1)} (k_1, k_2) \\
                                      &+ \frac{\alpha_s}{2\pi} \sum_d \int dx \left (\frac{1}{\epsilon} P_{da}(x,0) - K_{da}(x)\right) d\tilde{\sigma}_{db}^{(0)}(xk_1, k_2)\\
                                      &+ \frac{\alpha_s}{2\pi} \sum_d \int \left (\frac{1}{\epsilon} P_{db} (x, 0) - K_{db}(x)\right) d\tilde{\sigma}_{ad}^{(0)}(k_1, xk_2).\\
                                      &= d\tilde{\sigma}_{ab}^{(1)} + d\tilde{\sigma}_{ab}^{(cnt,+)} + d\tilde{\sigma}_{ab}^{(cnt,-)}
 \end{align}
 
 Let us now turn to the soft-subtracted real part of the cross section. For ease of notation, it is constrained to one singular region,
 \begin{align*}
   \label{eqn:R-in}
   d\sigma^{(in)}_\alpha &= \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon\left(\frac{\log \xi}{\xi}\right)_{c}\right] (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha \\
                  &\times  \frac{1}{2(2\pi)^{3-2\epsilon}} \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \left( 1 - y^2\right)^{-1-\epsilon} d\phi d\xi dy d\Omega^{2-2\epsilon},
 \end{align*}
 where we regularize collinear divergencies using the identity
 \begin{equation*}
   \left (1 - y^2 \right)^{-1-\epsilon} = -\frac{2^{-\epsilon}}{2\epsilon} \left (\delta(1-y) + \delta(1+y)\right)
      + \underbrace{\frac{1}{2} \left[ \left (\frac {1}{1-y}\right)_{c} + \left (\frac{1}{1+y}\right)_{c} \right]}_{\mathcal{P}(y)}.
 \end{equation*}
 This enables us to split the cross section into a finite and a singular part. The latter can further be separated into a contribution of the incoming and of the outgoing particles,
 \begin{equation*}
   d\sigma^{(in)}_\alpha = d\sigma^{(in,+)}_\alpha + d\sigma^{(in,-)}_\alpha + d\sigma^{(in,f)}_\alpha.
 \end{equation*}
 They are given by
 \begin{align}
   d\sigma^{(in,f)}_\alpha = & \mathcal{P}(y) \left[\left(\frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \frac{1}{2(2\pi)^{3-2\epsilon}}
      \left(\frac{\sqrt{s}}{2}\right)^{2-2\epsilon} \nonumber\\
      & \times (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon}
   \label{eqn:sigma-f}
 \end{align}
 and
 \begin{align}
   d\sigma^{(in,\pm)}_\alpha &= -\frac{2^{-\epsilon}}{2\epsilon} \delta (1 \mp y) \left[ \left( \frac{1}{\xi}\right)_{c} - 2\epsilon \left(\frac{\log\xi}{\xi}\right)_{c}\right] \nonumber\\
                     & \times \frac{1}{2(2\pi)^{3-2\epsilon}} \left( \frac{\sqrt{s}}{2}\right)^{2-2\epsilon} (1-y^2)\xi^2 \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy d\Omega^{2-2\epsilon}.
   \label{eqn:sigma-pm}
 \end{align}
 Equation \ref{eqn:sigma-f} is the contribution to the real cross section which is computed in [[evaluate_region_isr]]. It is regularized both in the soft and collinear limit via the plus distributions.
 Equation \ref{eqn:sigma-pm} is a different contribution. It is only present exactly in the collinear limit, due to the delta function. The divergences present in this term do not completely cancel out
 divergences in the virtual matrix element, because the beam axis is distinguished. Thus, the conditions in which the KLN theorem applies are not met. To see this, we carry out the collinear limit, obtaining
 \begin{equation*}
   \lim_{y \to 1} (1-y^2)\xi^2\mathcal{R}_\alpha = 8\pi\alpha_s \mu^{2\epsilon} \left(\frac{2}{\sqrt{s}}\right)^2 \xi P^<(1-\xi, \epsilon) \mathcal{R}_\alpha,
 \end{equation*}
 with the Altarelli-Parisi splitting kernel for $z < 1$, $P^<(z,\epsilon)$. Moreover, $\lim_{\vec{k} \parallel \vec{k}_1} d\phi = d\phi_3$ violates spatial averaging. The integration over the spherical angle $d\Omega$ can be carried out easily, yielding a factor of $2\pi^{1-\epsilon} / \Gamma(1-\epsilon)$.
 This allows us to redefine $\epsilon$,
 \begin{equation}
   \frac{1}{\epsilon} - \gamma_E + \log(4\pi) \to \frac{1}{\epsilon}.
 \end{equation}
 Coming back to $d\tilde{\sigma}_{ab}^{(cnt,+)}$ in order to make a connection to $d{\sigma}^{(in,+)}_\alpha$, we relate $P_{ab}(z,0)$ to $P^<_{ab}(z,0)$ via the equation
 \begin{equation*}
   P_{ab}(z,0) = (1-z)P_{ab}^<(z,0)\left(\frac{1}{1-z}\right)_+ + \gamma(a)\delta_{ab}\delta(1-z),
 \end{equation*}
 which yields
 \begin{equation} \label{eqn:sigma-cnt}
   d\tilde{\sigma}^{(cnt,+)}_{\alpha} = \frac{\alpha_s}{2\pi} \sum_d \left\lbrace -K_{da}(1-\xi) + \frac{1}{\epsilon} \left[\left(\frac{1}{\xi}\right)_+ \xi P_{da}^<(1-\xi,0)
                            + \delta_{da}\delta(\xi)\gamma(d)\right]\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy.
 \end{equation}
 This term has the same pole structure as eqn. \ref{eqn:sigma-pm}. This makes clear that the quantity
 \begin{equation}
   d\hat{\sigma}^{(in,+)} = d\tilde{\sigma}^{(in,+)} + d\tilde{\sigma}^{(cnt,+)}
 \end{equation}
 has no collinear poles. Therefore, our task is to add up eqns. \ref{eqn:sigma-pm} and \ref{eqn:sigma-cnt} in order to compute the finite remainder. This is the integrand which is evaluated in the [[dglap_remnant]] component.\\
 So, we have to perform an expansion of $d\hat{\sigma}^{(in,+)}$ in $\epsilon$. Hereby, we must not neglect the implicit $\epsilon$-dependence of $P^<$, which leads to additional terms involving the
 first derivative,
 \begin{equation*}
   P_{ab}^<(z,\epsilon) = P_{ab}^<(z,0) + \epsilon \frac{\partial P_{ab}^<(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} + \mathcal{O}(\alpha_s^2).
 \end{equation*}
 This finally gives us the equation for the collinear remnant. Note that there is still one soft $1/\epsilon$-pole, which cancels out with the corresponding expression in the soft-virtual terms.
 \begin{align} \label{eqn:sigma-in-p-final}
   d\hat{\sigma}^{(in,+)} &= \frac{\alpha_s}{2\pi} \frac{1}{\epsilon} \gamma(a) \mathcal{R}_\alpha \mathcal{S}_\alpha \nonumber\\
                          &+ \frac{\alpha_s}{2\pi} \sum_d \left\lbrace (1-z) P_{da}^<(z,0)\left[\left(\frac{1}{1-z}\right)_{c} \log\frac{s\delta_{\mathrm{I}}}{2\mu^2} + 2 \left(\frac{\log(1-z)}{1-z}\right)_{c}\right] \right. \nonumber\\
                          &\left . -(1-z)\frac{\partial P_{da}^<(z,\epsilon)}{\partial \epsilon} \left(\frac{1}{1-z}\right)_{c} - K_{da}(z)\right\rbrace \mathcal{R}_\alpha \mathcal{S}_\alpha d\phi d\xi dy
 \end{align}
 
 
 <<[[dglap_remnant.f90]]>>=
 <<File header>>
 
 module dglap_remnant
 
 <<Use kinds with double>>
 <<Use strings>>
   use numeric_utils
   use diagnostics
   use constants
   use physics_defs
   use pdg_arrays
   use phs_fks, only: isr_kinematics_t
   use fks_regions, only: region_data_t
 
   use nlo_data
 
 <<Standard module head>>
 
 <<dglap remnant: public>>
 
 <<dglap remnant: types>>
 
 contains
 
 <<dglap remnant: procedures>>
 
 end module dglap_remnant
 
 @ %def module dglap_remnant
 @
 <<dglap remnant: public>>=
   public :: dglap_remnant_t
 <<dglap remnant: types>>=
   type :: dglap_remnant_t
      type(nlo_settings_t), pointer :: settings => null ()
      type(region_data_t), pointer :: reg_data => null ()
      type(isr_kinematics_t), pointer :: isr_kinematics => null ()
      real(default) :: CA = 0, CF = 0, TR = 0
      real(default), dimension(:), allocatable :: sqme_born
      real(default), dimension(:,:), allocatable :: sf_factors
    contains
    <<dglap remnant: dglap remnant: TBP>>
   end type dglap_remnant_t
 
 @ %def dglap_remnant_t
 @
 <<dglap remnant: dglap remnant: TBP>>=
   procedure :: init => dglap_remnant_init
 <<dglap remnant: procedures>>=
   subroutine dglap_remnant_init (dglap, settings, reg_data, isr_kinematics)
     class(dglap_remnant_t), intent(inout) :: dglap
     type(nlo_settings_t), intent(in), target :: settings
     type(region_data_t), intent(in), target :: reg_data
     integer :: n_flv_born
     type(isr_kinematics_t), intent(in), target :: isr_kinematics
     dglap%reg_data => reg_data
     n_flv_born = reg_data%get_n_flv_born ()
     allocate (dglap%sf_factors (reg_data%n_regions, 0:reg_data%n_in))
     dglap%sf_factors = zero
     dglap%settings => settings
     allocate (dglap%sqme_born(n_flv_born))
     dglap%sqme_born = zero
     dglap%isr_kinematics => isr_kinematics
   end subroutine dglap_remnant_init
 
 @ %def dglap_remnant_init
 <<dglap remnant: dglap remnant: TBP>>=
   procedure :: set_parameters => dglap_remnant_set_parameters
 <<dglap remnant: procedures>>=
   subroutine dglap_remnant_set_parameters (dglap, CA, CF, TR)
     class(dglap_remnant_t), intent(inout) :: dglap
     real(default), intent(in) :: CA, CF, TR
     dglap%CA = CA
     dglap%CF = CF
     dglap%TR = TR
 end subroutine dglap_remnant_set_parameters
 
 @ %def dglap_remnant_set_parameters
 @ Evaluates formula \ref{eqn:sigma-in-p-final}. Note that, as also in the case for the
 real subtraction, we have to take into account an additional term, occuring because the
 integral the plus distribution is evaluated over is not constrained on the interval $[0,1]$.
 Explicitly, this means (see JHEP 06(2010)043, (4.11)-(4.12))
 \begin{align}
   \int_{\bar{x}_\oplus}^1 dz \left( \frac{1}{1-z} \right)_{\xi_{\text{cut}}} & = \log \frac{1-\bar{x}_\oplus}{\xi_{\text{cut}}} f(1) + \int_{\bar{x}_\oplus}^1 \frac{f(z) - f(1)}{1-z}, \\
   \int_{\bar{x}_\oplus}^1 dz \left(\frac{\log(1-z)}{1-z}\right)_{\xi_{\text{cut}}} f(z) & = \frac{1}{2}\left( \log^2(1-\bar{x}_\oplus) - \log^2 (\xi_{\text{cut}}) \right)f(1) + \int_{\bar{x}_\oplus}^1 \frac{\log(1-z)[f(z) - f(1)]}{1-z},
 \end{align}
 and the same of course for $\bar{x}_\ominus$. These two terms are stored in the [[plus_dist_remnant]] variable below.
 
 The option [[separate_uborns]] allows to compute the contribution of the DGLAP remnant
 separately for each underlying Born flavor structure. We need this option during
 event generation to generate counter events with a specific Born flavor structure.
 <<dglap remnant: dglap remnant: TBP>>=
   procedure :: evaluate => dglap_remnant_evaluate
 <<dglap remnant: procedures>>=
   subroutine dglap_remnant_evaluate (dglap, alpha_coupling, separate_uborns, sqme_dglap)
     class(dglap_remnant_t), intent(inout) :: dglap
     real(default), intent(in) :: alpha_coupling
     logical, intent(in) :: separate_uborns
     real(default), intent(inout), dimension(:) :: sqme_dglap
     integer :: alr, emitter
     real(default) :: sqme_alr
     logical, dimension(:,:,:), allocatable :: evaluated
     real(default) :: sb, fac_scale2
     sb = dglap%isr_kinematics%sqrts_born**2
     fac_scale2 = dglap%isr_kinematics%fac_scale**2
     allocate (evaluated(dglap%reg_data%get_n_flv_born (), dglap%reg_data%get_n_flv_real (), &
          dglap%reg_data%n_in))
     evaluated = .false.
     do alr = 1, dglap%reg_data%n_regions
        if (allocated (dglap%settings%selected_alr)) then
           if (.not. any (dglap%settings%selected_alr == alr)) cycle
        end if
        sqme_alr = zero
        emitter = dglap%reg_data%regions(alr)%emitter
        if (emitter > dglap%reg_data%n_in) cycle
        associate (i_flv_born => dglap%reg_data%regions(alr)%uborn_index, &
                i_flv_real => dglap%reg_data%regions(alr)%real_index)
           if (emitter == 0) then
              do emitter = 1, 2
                 if (evaluated(i_flv_born, i_flv_real, emitter)) cycle
                 call evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated)
              end do
           else if (emitter > 0) then
              if (evaluated(i_flv_born, i_flv_real, emitter)) cycle
              call evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated)
           end if
           if (separate_uborns) then
              sqme_dglap(i_flv_born) = sqme_dglap(i_flv_born) + alpha_coupling / twopi * sqme_alr
           else
              sqme_dglap(1) = sqme_dglap(1) + alpha_coupling / twopi * sqme_alr
           end if
        end associate
     end do
 
   contains
   <<dglap remnant: dglap remnant evaluate: procedures>>
   end subroutine dglap_remnant_evaluate
 
 @ %def dglap_remnant_evaluate
 @ We introduce $\hat{P}(z, \epsilon) = (1 - z) P(z, \epsilon)$ and have
 \begin{align}
   \hat{P}_{g\to gg}(z) & = 2C_A \left[z + \frac{(1-z)^2}{z} + z(1-z)^2\right], \\
   \hat{P}_{g\to qq}(z) & = C_F (1-z) \frac{1 + (1-z)^2}{z}, \\
   \hat{P}_{q\to gq}(z) & = T_F (1 - z - 2z(1-z)^2), \\
   \hat{P}_{q\to qg}(z) & = C_F (1 + z^2).
 \end{align}
 <<dglap remnant: dglap remnant evaluate: procedures>>=
   function p_hat_gtogg (z)
     real(default) :: p_hat_gtogg
   <<p variables>>
     p_hat_gtogg = two * dglap%CA * (z + onemz**2 / z + z * onemz**2)
   end function p_hat_gtogg
 
   function p_hat_gtoqq (z)
     real(default) :: p_hat_gtoqq
   <<p variables>>
     p_hat_gtoqq = dglap%CF * onemz / z * (one + onemz**2)
   end function p_hat_gtoqq
 
   function p_hat_qtogq (z)
     real(default) :: p_hat_qtogq
   <<p variables>>
     p_hat_qtogq = dglap%TR * (onemz - two * z * onemz**2)
   end function p_hat_qtogq
 
   function p_hat_qtoqg (z)
     real(default) :: p_hat_qtoqg
     real(default), intent(in) :: z
     p_hat_qtoqg = dglap%CF * (one + z**2)
   end function p_hat_qtoqg
 
 @ %def p_hat_qtoqg, p_hat_qtogq, p_hat_gtoqq, p_hat_gtogg
 @
 \begin{align}
   \frac{\partial P_{g\to gg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = 0, \\
   \frac{\partial P_{g\to qq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F z, \\
   \frac{\partial P_{q\to gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -
 2 T_F z (1-z), \\
   \frac{\partial P_{q\to qg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F (1-z).\\
 \end{align}
 <<dglap remnant: dglap remnant evaluate: procedures>>=
   function p_derived_gtogg (z)
     real(default) :: p_derived_gtogg
     real(default), intent(in) :: z
     p_derived_gtogg = zero
   end function p_derived_gtogg
 
   function p_derived_gtoqq (z)
     real(default) :: p_derived_gtoqq
     real(default), intent(in) :: z
     p_derived_gtoqq = -dglap%CF * z
   end function p_derived_gtoqq
 
   function p_derived_qtogq (z)
     real(default) :: p_derived_qtogq
   <<p variables>>
     p_derived_qtogq = -two * dglap%TR * z * onemz
   end function p_derived_qtogq
 
   function p_derived_qtoqg (z)
     real(default) :: p_derived_qtoqg
   <<p variables>>
     p_derived_qtoqg = -dglap%CF * onemz
   end function p_derived_qtoqg
 
 @ %def p_derived_gtogg, p_derived_gtoqq, p_derived_qtogq, p_derived_qtoqg
 @
 <<dglap remnant: dglap remnant evaluate: procedures>>=
 subroutine evaluate_alr (alr, emitter, i_flv_born, i_flv_real, sqme_alr, evaluated)
   integer, intent(in) :: alr, emitter, i_flv_born, i_flv_real
   real(default), intent(inout) :: sqme_alr
   logical, intent(inout), dimension(:,:,:) :: evaluated
   real(default) :: z, jac
   real(default) :: factor, factor_soft, plus_dist_remnant
   real(default) :: xb, onemz
   real(default) :: sqme_scaled
   real(default) :: charge_rad2, charge_em2
   integer :: flv_em, flv_rad, N_col
   N_col = 1
   associate (template => dglap%settings%fks_template)
      z = dglap%isr_kinematics%z(emitter)
      flv_rad = dglap%reg_data%regions(alr)%flst_real%flst(dglap%reg_data%n_legs_real)
      flv_em = dglap%reg_data%regions(alr)%flst_real%flst(emitter)
      charge_rad2 = dglap%reg_data%regions(alr)%flst_real%charge(dglap%reg_data%n_legs_real)**2
      charge_em2 = dglap%reg_data%regions(alr)%flst_real%charge(emitter)**2
      if (dglap%reg_data%regions(alr)%nlo_correction_type == "QCD") then
         call dglap%set_parameters (CA = CA, CF = CF, TR = TR)
      else if (dglap%reg_data%regions(alr)%nlo_correction_type == "EW") then
         if (is_quark(flv_rad)) N_col = NC
         call dglap%set_parameters (CA = zero, CF = charge_em2, TR = N_col*charge_rad2)
      end if
      jac = dglap%isr_kinematics%jacobian(emitter)
      onemz = one - z
      factor = log (sb * template%delta_i / two / z / fac_scale2) / &
           onemz + two * log (onemz) / onemz
      factor_soft = log (sb * template%delta_i / two / fac_scale2) / &
           onemz + two * log (onemz) / onemz
      xb = dglap%isr_kinematics%x(emitter)
      plus_dist_remnant = log ((one - xb) / template%xi_cut) * log (sb * template%delta_i / &
           two / fac_scale2) + (log (one - xb)**2 - log (template%xi_cut)**2)
   end associate
   sqme_scaled = dglap%sqme_born(i_flv_born) * dglap%sf_factors(alr, emitter)
   if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then
      sqme_alr = sqme_alr + p_hat_gtogg(z) * factor / z * sqme_scaled * jac &
           - p_hat_gtogg(one) * factor_soft * dglap%sqme_born(i_flv_born) * jac &
           + p_hat_gtogg(one) * plus_dist_remnant * dglap%sqme_born(i_flv_born)
   else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
      sqme_alr = sqme_alr + p_hat_qtoqg(z) * factor / z * sqme_scaled * jac &
           - p_derived_qtoqg(z) / z * sqme_scaled * jac &
           - p_hat_qtoqg(one) * factor_soft * dglap%sqme_born(i_flv_born) * jac &
           + p_hat_qtoqg(one) * plus_dist_remnant * dglap%sqme_born(i_flv_born)
   else if (is_fermion (flv_em) .and. is_fermion (flv_rad)) then
      sqme_alr = sqme_alr + (p_hat_gtoqq(z) * factor - p_derived_gtoqq(z)) / z * jac * &
           sqme_scaled
   else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then
      sqme_alr = sqme_alr + (p_hat_qtogq(z) * factor - p_derived_qtogq(z)) / z * sqme_scaled * jac
   else
      sqme_alr = sqme_alr + zero
   end if
   evaluated(i_flv_born, i_flv_real, emitter) = .true.
 end subroutine evaluate_alr
 @ %dglap_remnant_evaluate_alr
 @
 <<p variables>>=
   real(default), intent(in) :: z
   real(default) :: onemz
   onemz = one - z
 
 @ %def variables
 @
 <<dglap remnant: dglap remnant: TBP>>=
   procedure :: final => dglap_remnant_final
 <<dglap remnant: procedures>>=
   subroutine dglap_remnant_final (dglap)
     class(dglap_remnant_t), intent(inout) :: dglap
     if (associated (dglap%isr_kinematics)) nullify (dglap%isr_kinematics)
     if (associated (dglap%reg_data)) nullify (dglap%reg_data)
     if (associated (dglap%settings)) nullify (dglap%settings)
     if (allocated (dglap%sqme_born)) deallocate (dglap%sqme_born)
     if (allocated (dglap%sf_factors)) deallocate (dglap%sf_factors)
   end subroutine dglap_remnant_final
 
 @ %def dglap_remnant_final
 @
 \section{Dispatch}
 @
 <<[[dispatch_fks.f90]]>>=
 <<File header>>
 
 module dispatch_fks
 
 <<Use kinds>>
 <<Use strings>>
   use string_utils, only: split_string
   use variables, only: var_list_t
   use nlo_data, only: fks_template_t, FKS_DEFAULT, FKS_RESONANCES
 
 <<Standard module head>>
 
 <<Dispatch fks: public>>
 
 contains
 
 <<Dispatch fks: procedures>>
 
 end module dispatch_fks
 @ %def dispatch_fks
 @ Initialize parameters used to optimize FKS calculations.
 <<Dispatch fks: public>>=
   public :: dispatch_fks_s
 <<Dispatch fks: procedures>>=
   subroutine dispatch_fks_s (fks_template, var_list)
     type(fks_template_t), intent(inout) :: fks_template
     type(var_list_t), intent(in) :: var_list
     real(default) :: fks_dij_exp1, fks_dij_exp2
     type(string_t) :: fks_mapping_type
     logical :: subtraction_disabled
     type(string_t) :: exclude_from_resonance
     fks_dij_exp1 = &
          var_list%get_rval (var_str ("fks_dij_exp1"))
     fks_dij_exp2 = &
          var_list%get_rval (var_str ("fks_dij_exp2"))
     fks_mapping_type = &
          var_list%get_sval (var_str ("$fks_mapping_type"))
     subtraction_disabled = &
          var_list%get_lval (var_str ("?disable_subtraction"))
     exclude_from_resonance = &
          var_list%get_sval (var_str ("$resonances_exclude_particles"))
     if (exclude_from_resonance /= var_str ("default")) &
        call split_string (exclude_from_resonance, var_str (":"), &
        fks_template%excluded_resonances)
     call fks_template%set_parameters ( &
          exp1 = fks_dij_exp1, exp2 = fks_dij_exp2, &
          xi_min = var_list%get_rval (var_str ("fks_xi_min")), &
          y_max = var_list%get_rval (var_str ("fks_y_max")), &
          xi_cut = var_list%get_rval (var_str ("fks_xi_cut")), &
          delta_o = var_list%get_rval (var_str ("fks_delta_o")), &
          delta_i = var_list%get_rval (var_str ("fks_delta_i")))
     select case (char (fks_mapping_type))
     case ("default")
        call fks_template%set_mapping_type (FKS_DEFAULT)
     case ("resonances")
        call fks_template%set_mapping_type (FKS_RESONANCES)
     end select
     fks_template%subtraction_disabled = subtraction_disabled
     fks_template%n_f = var_list%get_ival (var_str ("alphas_nf"))
   end subroutine dispatch_fks_s
 
 @ %def dispatch_fks_s
 @
Index: trunk/src/particles/particles.nw
===================================================================
--- trunk/src/particles/particles.nw	(revision 8732)
+++ trunk/src/particles/particles.nw	(revision 8733)
@@ -1,8527 +1,8524 @@
 %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: particle objects
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Particles}
 \includemodulegraph{particles}
 
 This chapter collects modules that implement particle objects, for use in
 event records.
 
 While within interactions, all correlations are
 manifest, a particle array is derived by selecting a particular
 quantum number set.  This involves tracing over all other particles,
 as far as polarization is concerned.  Thus, a particle has definite
 flavor, color, and a single-particle density matrix for polarization.
 \begin{description}
 \item[su\_algebra]
   We make use of $su(N)$ generators as the basis for representing
   polarization matrices.  This module defines the basis and provides
   the necessary transformation routines.
 \item[bloch\_vectors]
   This defines polarization objects in Bloch representation.  The
   object describes the spin density matrix of a particle,
   currently restricted to spin $0\ldots 2$.
 \item[polarizations]
   This extends the basic polarization object such that it supports
   properties of physical particles and appropriate constructors.
 \item[particles]
   Particle objects and particle lists, as the base of event records.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{$su(N)$ Algebra}
 We need a specific choice of basis for a well-defined component
 representation.  The matrix elements of $T^a$ are
 ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to
 lowest weight, for both row and column.
 
 We list first the generators of the $su(2)$ subalgebras which leave
 $|m|$ invariant ($|m|\neq 0$):
 \begin{equation}
   T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3}
 \end{equation}
 acting on the respective subspace $|m|=\ell,\ell-1,\ldots$ for
 $b=0,1,\ldots$.  This defines generators $T^a$ for $a=1,\ldots 3N/2$
 ($\ldots 3(N-1)/2$) for $N$ even (odd), respectively.
 
 The following generators successively extend this to $su(4)$, $su(6)$,
 \ldots until $su(N)$ by adding first the missing off-diagonal and then
 diagonal generators.  The phase conventions are analogous.
 
 (It should be possible to code these conventions for generic spin, but
 in the current implementation we restrict ourselves to $s\leq 2$, i.e.,
 $N\leq 5$.)
 <<[[su_algebra.f90]]>>=
 <<File header>>
 
 module su_algebra
 
 <<Use kinds>>
   use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
 
 <<Standard module head>>
 
 <<su algebra: public>>
 
 contains
 
 <<su algebra: procedures>>
 
 end module su_algebra
 @ %def su_algebra
 @
 \subsection{$su(N)$ fundamental representation}
 The dimension of the basis for a given spin type.  consecutively, starting at
 [[SCALAR=1]].
 <<su algebra: public>>=
   public :: algebra_dimension
 <<su algebra: procedures>>=
   function algebra_dimension (s) result (n)
     integer :: n
     integer, intent(in) :: s
     n = fundamental_dimension (s) ** 2 - 1
   end function algebra_dimension
 
 @ %def algebra_dimension
 @ The dimension of the fundamental (defining) representation that we
 use.  This implementation assumes that the spin type is numerically
 equal to the fundamental dimension.
 <<su algebra: public>>=
   public :: fundamental_dimension
 <<su algebra: procedures>>=
   function fundamental_dimension (s) result (d)
     integer :: d
     integer, intent(in) :: s
     d = s
   end function fundamental_dimension
 
 @ %def fundamental_dimension
 @
 \subsection{Mapping between helicity and matrix index}
 Return the helicity that corresponds to a particular entry in the
 polarization matrix representation.  Helicities are counted downwards,
 in integers, and zero helicity is included (omitted) for odd (even)
 spin, respectively.
 <<su algebra: public>>=
   public :: helicity_value
 <<su algebra: procedures>>=
   function helicity_value (s, i) result (h)
     integer :: h
     integer, intent(in) :: s, i
     integer, dimension(1), parameter :: hh1 = [0]
     integer, dimension(2), parameter :: hh2 = [1, -1]
     integer, dimension(3), parameter :: hh3 = [1,  0, -1]
     integer, dimension(4), parameter :: hh4 = [2,  1, -1, -2]
     integer, dimension(5), parameter :: hh5 = [2,  1,  0, -1, -2]
     h = 0
     select case (s)
     case (SCALAR)
        select case (i)
        case (1:1);  h = hh1(i)
        end select
     case (SPINOR)
        select case (i)
        case (1:2);  h = hh2(i)
        end select
     case (VECTOR)
        select case (i)
        case (1:3);  h = hh3(i)
        end select
     case (VECTORSPINOR)
        select case (i)
        case (1:4);  h = hh4(i)
        end select
     case (TENSOR)
        select case (i)
        case (1:5);  h = hh5(i)
        end select
     end select
   end function helicity_value
 
 @ %def helicity_value
 @ Inverse: return the index that corresponds to a certain
 helicity value in the chosen representation.
 <<su algebra: public>>=
   public :: helicity_index
 <<su algebra: procedures>>=
   function helicity_index (s, h) result (i)
     integer, intent(in) :: s, h
     integer :: i
     integer, dimension(0:0), parameter :: hi1 = [1]
     integer, dimension(-1:1), parameter :: hi2 = [2, 0, 1]
     integer, dimension(-1:1), parameter :: hi3 = [3, 2, 1]
     integer, dimension(-2:2), parameter :: hi4 = [4, 3, 0, 2, 1]
     integer, dimension(-2:2), parameter :: hi5 = [5, 4, 3, 2, 1]
     select case (s)
     case (SCALAR)
        i = hi1(h)
     case (SPINOR)
        i = hi2(h)
     case (VECTOR)
        i = hi3(h)
     case (VECTORSPINOR)
        i = hi4(h)
     case (TENSOR)
        i = hi5(h)
     end select
   end function helicity_index
 
 @ %def helicity_index
 @
 \subsection{Generator Basis: Cartan Generators}
 For each supported spin type, we return specific properties of the
 set of generators via inquiry functions.  This is equivalent to using
 explicit representations of the generators.
 
 For easy access, the properties are hard-coded and selected via case
 expressions.
 
 Return true if the generator \#[[i]] is in the Cartan subalgebra,
 i.e., a diagonal matrix for spin type [[s]].
 <<su algebra: public>>=
   public :: is_cartan_generator
 <<su algebra: procedures>>=
   elemental function is_cartan_generator (s, i) result (cartan)
     logical :: cartan
     integer, intent(in) :: s, i
     select case (s)
     case (SCALAR)
     case (SPINOR)
        select case (i)
        case (3);  cartan = .true.
        case default
           cartan = .false.
        end select
     case (VECTOR)
        select case (i)
        case (3,8);  cartan = .true.
        case default
           cartan = .false.
        end select
     case (VECTORSPINOR)
        select case (i)
        case (3,6,15);  cartan = .true.
        case default
           cartan = .false.
        end select
     case (TENSOR)
        select case (i)
        case (3,6,15,24);  cartan = .true.
        case default
           cartan = .false.
        end select
     case default
        cartan = .false.
     end select
   end function is_cartan_generator
 
 @ %def is_cartan_generator
 @ Return the index of Cartan generator \#[[k]] in the chosen
 representation.  This has to conform to [[cartan]] above.
 <<su algebra: public>>=
   public :: cartan_index
 <<su algebra: procedures>>=
   elemental function cartan_index (s, k) result (ci)
     integer :: ci
     integer, intent(in) :: s, k
     integer, dimension(1), parameter :: ci2 = [3]
     integer, dimension(2), parameter :: ci3 = [3,8]
     integer, dimension(3), parameter :: ci4 = [3,6,15]
     integer, dimension(4), parameter :: ci5 = [3,6,15,24]
     select case (s)
     case (SPINOR)
        ci = ci2(k)
     case (VECTOR)
        ci = ci3(k)
     case (VECTORSPINOR)
        ci = ci4(k)
     case (TENSOR)
        ci = ci5(k)
     case default
        ci = 0
     end select
   end function cartan_index
 
 @ %def cartan_index
 @ The element \#[[k]] of the result vector [[a]] is equal to the
 $(h,h)$ diagonal entry of the generator matrix $T^k$.  That is,
 evaluating this for all allowed values of [[h]], we recover the set of
 Cartan generator matrices.
 <<su algebra: public>>=
   public :: cartan_element
 <<su algebra: procedures>>=
   function cartan_element (s, h) result (a)
     real(default), dimension(:), allocatable :: a
     integer, intent(in) :: s, h
     real(default), parameter :: sqrt2 = sqrt (2._default)
     real(default), parameter :: sqrt3 = sqrt (3._default)
     real(default), parameter :: sqrt10 = sqrt (10._default)
     allocate (a (algebra_dimension (s)), source = 0._default)
     select case (s)
     case (SCALAR)
     case (SPINOR)
        select case (h)
        case (1)
           a(3) =  1._default / 2
        case (-1)
           a(3) = -1._default / 2
        end select
     case (VECTOR)
        select case (h)
        case (1)
           a(3) =  1._default / 2
           a(8) =  1._default / (2 * sqrt3)
        case (-1)
           a(3) = -1._default / 2
           a(8) =  1._default / (2 * sqrt3)
        case (0)
           a(8) = -1._default / sqrt3
        end select
     case (VECTORSPINOR)
        select case (h)
        case (2)
           a(3)  =  1._default / 2
           a(15) =  1._default / (2 * sqrt2)
        case (-2)
           a(3)  = -1._default / 2
           a(15) =  1._default / (2 * sqrt2)
        case (1)
           a(6)  =  1._default / 2
           a(15) = -1._default / (2 * sqrt2)
        case (-1)
           a(6)  = -1._default / 2
           a(15) = -1._default / (2 * sqrt2)
        end select
     case (TENSOR)
        select case (h)
        case (2)
           a(3)  =  1._default / 2
           a(15) =  1._default / (2 * sqrt2)
           a(24) =  1._default / (2 * sqrt10)
        case (-2)
           a(3)  = -1._default / 2
           a(15) =  1._default / (2 * sqrt2)
           a(24) =  1._default / (2 * sqrt10)
        case (1)
           a(6)  =  1._default / 2
           a(15) = -1._default / (2 * sqrt2)
           a(24) =  1._default / (2 * sqrt10)
        case (-1)
           a(6)  = -1._default / 2
           a(15) = -1._default / (2 * sqrt2)
           a(24) =  1._default / (2 * sqrt10)
        case (0)
           a(24) = -4._default / (2 * sqrt10)
        end select
     end select
   end function cartan_element
 
 @ %def cartan_element
 @ Given an array of diagonal matrix elements [[rd]] of a generator,
 compute the array [[a]] of basis coefficients.  The array must be
 ordered as defined by [[helicity_value]], i.e., highest weight first.
 The calculation is organized such that the trace of the generator,
 i.e., the sum of [[rd]] values, drops out.  The result array [[a]] has
 coefficients for all basis generators, but only Cartan generators can
 get a nonzero coefficient.
 <<su algebra: public>>=
   public :: cartan_coeff
 <<su algebra: procedures>>=
   function cartan_coeff (s, rd) result (a)
     real(default), dimension(:), allocatable :: a
     integer, intent(in) :: s
     real(default), dimension(:), intent(in) :: rd
     real(default), parameter :: sqrt2 = sqrt (2._default)
     real(default), parameter :: sqrt3 = sqrt (3._default)
     real(default), parameter :: sqrt10 = sqrt (10._default)
     integer :: n
     n = algebra_dimension (s)
     allocate (a (n), source = 0._default)
     select case (s)
     case (SPINOR)
        a(3) = rd(1) - rd(2)
     case (VECTOR)
        a(3) = rd(1) - rd(3)
        a(8) = (rd(1) - 2 * rd(2) + rd(3)) / sqrt3
     case (VECTORSPINOR)
        a(3) = rd(1) - rd(4)
        a(6) = rd(2) - rd(3)
        a(15) = (rd(1) - rd(2) - rd(3) + rd(4)) / sqrt2
     case (TENSOR)
        a(3) = rd(1) - rd(5)
        a(6) = rd(2) - rd(4)
        a(15) = (rd(1) - rd(2) - rd(4) + rd(5)) / sqrt2
        a(24) = (rd(1) + rd(2) - 4 * rd(3) + rd(4) + rd(5)) / sqrt10
     end select
   end function cartan_coeff
 
 @ %def cartan_coeff
 @
 \subsection{Roots (Off-Diagonal Generators)}
 Return the appropriate generator index for a given off-diagonal helicity
 combination.  We require $h_1>h_2$.  We return the index of the
 appropriate real-valued generator if [[r]] is true, else the
 complex-valued one.
 
 This is separate from the [[cartan_coeff]] function above.  The reason
 is that the off-diagonal generators have only a single nonzero matrix
 element, so there is a one-to-one correspondence of helicity and index.
 <<su algebra: public>>=
   public :: root_index
 <<su algebra: procedures>>=
   function root_index (s, h1, h2, r) result (ai)
     integer :: ai
     integer, intent(in) :: s, h1, h2
     logical :: r
     ai = 0
     select case (s)
     case (SCALAR)
     case (SPINOR)
        select case (h1)
        case (1)
           select case (h2)
           case (-1);  ai = 1
           end select
        end select
     case (VECTOR)
        select case (h1)
        case (1)
           select case (h2)
           case (-1);  ai = 1
           case (0);   ai = 4
           end select
        case (0)
           select case (h2)
           case (-1);  ai = 6
           end select
        end select
     case (VECTORSPINOR)
        select case (h1)
        case (2)
           select case (h2)
           case (-2);  ai = 1
           case (1);   ai = 7
           case (-1);  ai = 11
           end select
        case (1)
           select case (h2)
           case (-1);  ai = 4
           case (-2);  ai = 13
           end select
        case (-1)
           select case (h2)
           case (-2);  ai = 9
           end select
        end select
     case (TENSOR)
        select case (h1)
        case (2)
           select case (h2)
           case (-2);  ai = 1
           case (1);   ai = 7
           case (-1);  ai = 11
           case (0);   ai = 16
           end select
        case (1)
           select case (h2)
           case (-1);  ai = 4
           case (-2);  ai = 13
           case (0);   ai = 20
           end select
        case (-1)
           select case (h2)
           case (-2);  ai = 9
           end select
        case (0)
           select case (h2)
           case (-2);  ai = 18
           case (-1);  ai = 22
           end select
        end select
     end select
     if (ai /= 0 .and. .not. r)  ai = ai + 1
   end function root_index
 
 @ %def root_index
 @ Inverse: return the helicity values ($h_2>h_1$) for an off-diagonal
 generator.  The flag [[r]] tells whether this is a real or diagonal
 generator.   The others are Cartan generators.
 <<su algebra: public>>=
   public :: root_helicity
 <<su algebra: procedures>>=
   subroutine root_helicity (s, i, h1, h2, r)
     integer, intent(in) :: s, i
     integer, intent(out) :: h1, h2
     logical, intent(out) :: r
     h1 = 0
     h2 = 0
     r  = .false.
     select case (s)
     case (SCALAR)
     case (SPINOR)
        select case (i)
        case ( 1, 2);  h1 =  1;  h2 = -1;  r = i == 1
        end select
     case (VECTOR)
        select case (i)
        case ( 1, 2);  h1 =  1;  h2 = -1;  r = i == 1
        case ( 4, 5);  h1 =  1;  h2 =  0;  r = i == 4
        case ( 6, 7);  h1 =  0;  h2 = -1;  r = i == 6
        end select
     case (VECTORSPINOR)
        select case (i)
        case ( 1, 2);  h1 =  2;  h2 = -2;  r = i == 1
        case ( 4, 5);  h1 =  1;  h2 = -1;  r = i == 4
        case ( 7, 8);  h1 =  2;  h2 =  1;  r = i == 7
        case ( 9,10);  h1 = -1;  h2 = -2;  r = i == 9
        case (11,12);  h1 =  2;  h2 = -1;  r = i ==11
        case (13,14);  h1 =  1;  h2 = -2;  r = i ==13
        end select
     case (TENSOR)
        select case (i)
        case ( 1, 2);  h1 =  2;  h2 = -2;  r = i == 1
        case ( 4, 5);  h1 =  1;  h2 = -1;  r = i == 4
        case ( 7, 8);  h1 =  2;  h2 =  1;  r = i == 7
        case ( 9,10);  h1 = -1;  h2 = -2;  r = i == 9
        case (11,12);  h1 =  2;  h2 = -1;  r = i ==11
        case (13,14);  h1 =  1;  h2 = -2;  r = i ==13
        case (16,17);  h1 =  2;  h2 =  0;  r = i ==16
        case (18,19);  h1 =  0;  h2 = -2;  r = i ==18
        case (20,21);  h1 =  1;  h2 =  0;  r = i ==20
        case (22,23);  h1 =  0;  h2 = -1;  r = i ==22
        end select
     end select
   end subroutine root_helicity
 
 @ %def root_helicity
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[su_algebra_ut.f90]]>>=
 <<File header>>
 
 module su_algebra_ut
   use unit_tests
   use su_algebra_uti
 
 <<Standard module head>>
 
 <<su algebra: public test>>
 
 contains
 
 <<su algebra: test driver>>
 
 end module su_algebra_ut
 @ %def su_algebra_ut
 @
 <<[[su_algebra_uti.f90]]>>=
 <<File header>>
 
 module su_algebra_uti
 
 <<Use kinds>>
   use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
   use su_algebra
 
 <<Standard module head>>
 
 <<su algebra: test declarations>>
 
 contains
 
 <<su algebra: tests>>
 
 end module su_algebra_uti
 @ %def su_algebra_ut
 @ API: driver for the unit tests below.
 <<su algebra: public test>>=
   public :: su_algebra_test
 <<su algebra: test driver>>=
   subroutine su_algebra_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<su algebra: execute tests>>
   end subroutine su_algebra_test
 
 @  %def su_algebra_test
 @
 \subsubsection{Generator Ordering}
 Show the position of Cartan generators in the sequence of basis generators.
 <<su algebra: execute tests>>=
   call test (su_algebra_1, "su_algebra_1", &
        "generator ordering", &
        u, results)
 <<su algebra: test declarations>>=
   public :: su_algebra_1
 <<su algebra: tests>>=
   subroutine su_algebra_1 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: su_algebra_1"
     write (u, "(A)")  "*   Purpose: test su(N) algebra implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* su(N) generators: &
          &list and mark Cartan subalgebra"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 0"
     call cartan_check (SCALAR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call cartan_check (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call cartan_check (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call cartan_check (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call cartan_check (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: su_algebra_1"
 
   contains
 
     subroutine cartan_check (s)
       integer, intent(in) :: s
       integer :: i
       write (u, *)
       do i = 1, algebra_dimension (s)
          write (u, "(1x,L1)", advance="no")  is_cartan_generator (s, i)
       end do
       write (u, *)
 
     end subroutine cartan_check
 
   end subroutine su_algebra_1
 
 @ %def su_algebra_1
 @
 \subsubsection{Cartan Generator Basis}
 Show the explicit matrix representation for all Cartan generators and
 check their traces and Killing products.
 
 Also test helicity index mappings.
 <<su algebra: execute tests>>=
   call test (su_algebra_2, "su_algebra_2", &
        "Cartan generator representation", &
        u, results)
 <<su algebra: test declarations>>=
   public :: su_algebra_2
 <<su algebra: tests>>=
   subroutine su_algebra_2 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: su_algebra_2"
     write (u, "(A)")  "*   Purpose: test su(N) algebra implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* diagonal su(N) generators: &
          &show explicit representation"
     write (u, "(A)")  "* and check trace and Killing form"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call cartan_show (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call cartan_show (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call cartan_show (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call cartan_show (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: su_algebra_2"
 
   contains
 
     subroutine cartan_show (s)
       integer, intent(in) :: s
       real(default), dimension(:,:), allocatable :: rd
       integer, dimension(:), allocatable :: ci
       integer :: n, d, h, i, j, k, l
 
       n = algebra_dimension (s)
       d = fundamental_dimension (s)
 
       write (u, *)
       write (u, "(A2,5X)", advance="no")  "h:"
       do i = 1, d
          j = helicity_index (s, helicity_value (s, i))
          write (u, "(1x,I2,5X)", advance="no")  helicity_value (s, j)
       end do
       write (u, "(8X)", advance="no")
       write (u, "(1X,A)")  "tr"
 
       allocate (rd (n,d), source = 0._default)
       do i = 1, d
          h = helicity_value (s, i)
          rd(:,i) = cartan_element (s, h)
       end do
 
       allocate (ci (d-1), source = 0)
       do k = 1, d-1
          ci(k) = cartan_index (s, k)
       end do
 
       write (u, *)
       do k = 1, d-1
          write (u, "('T',I2,':',1X)", advance="no")  ci(k)
          do i = 1, d
             write (u, 1, advance="no")  rd(ci(k),i)
          end do
          write (u, "(8X)", advance="no")
          write (u, 1)  sum (rd(ci(k),:))
       end do
 
       write (u, *)
       write (u, "(6X)", advance="no")
       do k = 1, d-1
          write (u, "(2X,'T',I2,3X)", advance="no")  ci(k)
       end do
       write (u, *)
 
       do k = 1, d-1
          write (u, "('T',I2,2X)", advance="no")  ci(k)
          do l = 1, d-1
             write (u, 1, advance="no")  dot_product (rd(ci(k),:), rd(ci(l),:))
          end do
          write (u, *)
       end do
 
 1     format (1x,F7.4)
 
     end subroutine cartan_show
 
   end subroutine su_algebra_2
 
 @ %def su_algebra_2
 @
 \subsubsection{Bloch Representation: Cartan Generators}
 Transform from Bloch vectors to matrix and back, considering Cartan
 generators only.
 <<su algebra: execute tests>>=
   call test (su_algebra_3, "su_algebra_3", &
        "Cartan generator mapping", &
        u, results)
 <<su algebra: test declarations>>=
   public :: su_algebra_3
 <<su algebra: tests>>=
   subroutine su_algebra_3 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: su_algebra_3"
     write (u, "(A)")  "*   Purpose: test su(N) algebra implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* diagonal su(N) generators: &
          &transform to matrix and back"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call cartan_expand (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call cartan_expand (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call cartan_expand (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call cartan_expand (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: su_algebra_3"
 
   contains
 
     subroutine cartan_expand (s)
       integer, intent(in) :: s
       real(default), dimension(:,:), allocatable :: rd
       integer, dimension(:), allocatable :: ci
       real(default), dimension(:), allocatable :: a
       logical, dimension(:), allocatable :: mask
       integer :: n, d, h, i, k, l
 
       n = algebra_dimension (s)
       d = fundamental_dimension (s)
 
       allocate (rd (n,d), source = 0._default)
       do i = 1, d
          h = helicity_value (s, i)
          rd(:,i) = cartan_element (s, h)
       end do
 
       allocate (ci (d-1), source = 0)
       do k = 1, d-1
          ci(k) = cartan_index (s, k)
       end do
 
       allocate (a (n))
 
       write (u, *)
       do k = 1, d-1
          a(:) = cartan_coeff (s, rd(ci(k),:))
          write (u, "('T',I2,':',1X)", advance="no")  ci(k)
          do i = 1, n
             if (is_cartan_generator (s, i)) then
                write (u, 1, advance="no")  a(i)
             else if (a(i) /= 0) then
                ! this should not happen (nonzero non-Cartan entry)
                write (u, "(1X,':',I2,':',3X)", advance="no")  i
             end if
          end do
          write (u, *)
       end do
 
 1     format (1X,F7.4)
 
     end subroutine cartan_expand
 
   end subroutine su_algebra_3
 
 @ %def su_algebra_3
 @
 \subsubsection{Bloch Representation: Roots}
 List the mapping between helicity transitions and (real) off-diagonal
 generators.
 <<su algebra: execute tests>>=
   call test (su_algebra_4, "su_algebra_4", &
        "Root-helicity mapping", &
        u, results)
 <<su algebra: test declarations>>=
   public :: su_algebra_4
 <<su algebra: tests>>=
   subroutine su_algebra_4 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: su_algebra_4"
     write (u, "(A)")  "*   Purpose: test su(N) algebra implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* off-diagonal su(N) generators: &
          &mapping from/to helicity pair"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call root_expand (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call root_expand (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call root_expand (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call root_expand (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: su_algebra_4"
 
   contains
 
     subroutine root_expand (s)
       integer, intent(in) :: s
       integer :: n, d, i, j, h1, h2
       logical :: r
 
       n = algebra_dimension (s)
 
       write (u, *)
       do i = 1, n
          if (is_cartan_generator (s, i))  cycle
          call root_helicity (s, i, h1, h2, r)
          j = root_index (s, h1, h2, r)
          write (u, "('T',I2,':')", advance="no")  j
          write (u, "(2(1x,I2))", advance="no")  h1, h2
          if (r) then
             write (u, *)
          else
             write (u, "('*')")
          end if
       end do
 
     end subroutine root_expand
 
   end subroutine su_algebra_4
 
 @ %def su_algebra_4
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Bloch Representation}
 Particle polarization is determined by a particular quantum state
 which has just helicity information.  Physically, this is the spin
 density matrix $\rho$, where we do not restrict ourselves to pure
 states.
 
 We adopt the phase convention for a spin-1/2 particle that
 \begin{equation}
   \rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma)
 \end{equation}
 with the polarization axis $\vec\alpha$.  For a particle with
 arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above
 definition to generalized Bloch form
 \begin{equation}
   \rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right)
 \end{equation}
 where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra
 generators.  These $N\times N$ matrices are hermitean, traceless, and
 orthogonal via
 \begin{equation}
   \mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab}
 \end{equation}
 In the spin-1/2 case, this reduces to the above (standard Bloch)
 representation since $T^a = \sigma^a/2$, $a=1,2,3$.  For the spin-1
 case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices,
 \begin{equation}
   \rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right),
 \end{equation}
 The normalization is chosen that $|alpha|\leq 1$ for allowed density
 matrix, where $|\alpha|=1$ is a necessary, but not sufficient,
 condition for a pure state.
 
 We need a specific choice of basis for a well-defined component
 representation.  The matrix elements of $T^a$ are
 ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to
 lowest weight, for both row and column.
 
 We list first the generators of the $su(2)$ subalgebras which leave
 $|m|$ invariant ($|m|\neq 0$):
 \begin{equation}
   T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3}
 \end{equation}
 acting on the respective subspace $|m|=\ell,\ell-1,\ldots$ for
 $b=0,1,\ldots$.  This defines generators $T^a$ for $a=1,\ldots 3N/2$
 ($\ldots 3(N-1)/2$) for $N$ even (odd), respectively.
 
 The following generators successively extend this to $su(4)$, $su(6)$,
 \ldots until $su(N)$ by adding first the missing off-diagonal and then
 diagonal generators.  The phase conventions are analogous.
 
 (It should be possible to code these conventions for generic spin, but
 in the current implementation we restrict ourselves to $s\leq 2$, i.e.,
 $N\leq 5$.)
 
 Particle polarization is determined by a particular quantum state
 which has just helicity information.  Physically, this is the spin
 density matrix $\rho$, where we do not restrict ourselves to pure
 states.
 
 We adopt the phase convention for a spin-1/2 particle that
 \begin{equation}
   \rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma)
 \end{equation}
 with the polarization axis $\vec\alpha$.  For a particle with
 arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above
 definition to generalized Bloch form
 \begin{equation}
   \rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right)
 \end{equation}
 where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra
 generators.  These $N\times N$ matrices are hermitean, traceless, and
 orthogonal via
 \begin{equation}
   \mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab}
 \end{equation}
 In the spin-1/2 case, this reduces to the above (standard Bloch)
 representation since $T^a = \sigma^a/2$, $a=1,2,3$.  For the spin-1
 case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices,
 \begin{equation}
   \rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right),
 \end{equation}
 The normalization is chosen that $|alpha|\leq 1$ for allowed density
 matrix, where $|\alpha|=1$ is a necessary, but not sufficient,
 condition for a pure state.
 <<[[bloch_vectors.f90]]>>=
 <<File header>>
 
 module bloch_vectors
 
 <<Use kinds>>
   use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
   use su_algebra
 
 <<Standard module head>>
 
 <<Bloch vectors: public>>
 
 <<Bloch vectors: types>>
 
 contains
 
 <<Bloch vectors: procedures>>
 
 end module bloch_vectors
 @ %def bloch_vectors
 @
 \subsection{Preliminaries}
 The normalization factor $\sqrt{2N(N-1)}/N$ that enters the Bloch
 representation.
 <<Bloch vectors: procedures>>=
   function bloch_factor (s) result (f)
     real(default) :: f
     integer, intent(in) :: s
     select case (s)
     case (SCALAR)
        f = 0
     case (SPINOR)
        f = 1
     case (VECTOR)
        f = 2 * sqrt (3._default) / 3
     case (VECTORSPINOR)
        f = 2 * sqrt (6._default) / 4
     case (TENSOR)
        f = 2 * sqrt (10._default) / 5
     case default
        f = 0
     end select
   end function bloch_factor
 
 @ %def bloch_factor
 @
 \subsection{The basic polarization type}
 The basic polarization object holds just the entries of the Bloch
 vector as an allocatable array.
 
 Bloch is active whenever the coefficient array is allocated.
 For convenience, we store the spin type ($2s$) and the multiplicity
 ($N$) together with the coefficient array ($\alpha$).  We have to allow for
 the massless case where $s$ is arbitrary $>0$ but $N=2$, and
 furthermore the chiral massless case where $N=1$.  In the latter case,
 the array remains deallocated but the chirality is set to $\pm 1$.
 
 In the Bloch vector implementation, we do not distinguish between
 particle and antiparticle.  If the distinction applies, it must be
 made by the caller when transforming between density matrix and Bloch vector.
 <<Bloch vectors: public>>=
   public :: bloch_vector_t
 <<Bloch vectors: types>>=
   type :: bloch_vector_t
      private
      integer :: spin_type = UNKNOWN
      real(default), dimension(:), allocatable :: a
    contains
    <<Bloch vectors: bloch vector: TBP>>
 end type bloch_vector_t
 
 @ %def bloch_vector_t
 @
 \subsection{Direct Access}
 This basic initializer just sets the spin type, leaving the Bloch vector
 unallocated.  The object therefore does not support nonzero polarization.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: init_unpolarized => bloch_vector_init_unpolarized
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_init_unpolarized (pol, spin_type)
     class(bloch_vector_t), intent(out) :: pol
     integer, intent(in) :: spin_type
     pol%spin_type = spin_type
   end subroutine bloch_vector_init_unpolarized
 
 @ %def bloch_vector_init_unpolarized
 @ The standard initializer allocates the Bloch vector and initializes
 with zeros, so we can define a polarization later.  We make sure that
 this works only for the supported spin type.  Initializing with
 [[UNKNOWN]] spin type resets the Bloch vector to undefined, i.e.,
 unpolarized state.
 <<Bloch vectors: bloch vector: TBP>>=
   generic :: init => bloch_vector_init
   procedure, private :: bloch_vector_init
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_init (pol, spin_type)
     class(bloch_vector_t), intent(out) :: pol
     integer, intent(in) :: spin_type
     pol%spin_type = spin_type
     select case (spin_type)
     case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
        allocate (pol%a (algebra_dimension (spin_type)), source = 0._default)
     end select
   end subroutine bloch_vector_init
 
 @ %def bloch_vector_init
 @
 Fill the Bloch vector from an array, no change of normalization.  No
 initialization and no check, we assume that the shapes do match.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: from_array => bloch_vector_from_array
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_from_array (pol, a)
     class(bloch_vector_t), intent(inout) :: pol
     real(default), dimension(:), allocatable, intent(in) :: a
     pol%a(:) = a
   end subroutine bloch_vector_from_array
 
 @ %def bloch_vector_from_array
 @
 Transform to an array of reals, i.e., extract the Bloch vector as-is.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: to_array => bloch_vector_to_array
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_to_array (pol, a)
     class(bloch_vector_t), intent(in) :: pol
     real(default), dimension(:), allocatable, intent(out) :: a
     if (pol%is_defined ())  allocate (a (size (pol%a)), source = pol%a)
   end subroutine bloch_vector_to_array
 
 @ %def bloch_vector_to_array
 @
 \subsection{Raw I/O}
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: write_raw => bloch_vector_write_raw
   procedure :: read_raw => bloch_vector_read_raw
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_write_raw (pol, u)
     class(bloch_vector_t), intent(in) :: pol
     integer, intent(in) :: u
     write (u) pol%spin_type
     write (u) allocated (pol%a)
     if (allocated (pol%a)) then
        write (u) pol%a
     end if
   end subroutine bloch_vector_write_raw
 
   subroutine bloch_vector_read_raw (pol, u, iostat)
     class(bloch_vector_t), intent(out) :: pol
     integer, intent(in) :: u
     integer, intent(out) :: iostat
     integer :: s
     logical :: polarized
     read (u, iostat=iostat) s
     read (u, iostat=iostat) polarized
     if (iostat /= 0)  return
     if (polarized) then
        call pol%init (s)
        read (u, iostat=iostat) pol%a
     else
        call pol%init_unpolarized (s)
     end if
   end subroutine bloch_vector_read_raw
 
 @ %def bloch_vector_write_raw
 @ %def bloch_vector_read_raw
 @
 \subsection{Properties}
 Re-export algebra functions that depend on the spin type.  These
 functions do not depend on the Bloch vector being allocated.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: get_n_states
   procedure :: get_length
   procedure :: hel_index => bv_helicity_index
   procedure :: hel_value => bv_helicity_value
   procedure :: bloch_factor => bv_factor
 <<Bloch vectors: procedures>>=
   function get_n_states (pol) result (n)
     class(bloch_vector_t), intent(in) :: pol
     integer :: n
     n = fundamental_dimension (pol%spin_type)
   end function get_n_states
 
   function get_length (pol) result (n)
     class(bloch_vector_t), intent(in) :: pol
     integer :: n
     n = algebra_dimension (pol%spin_type)
   end function get_length
 
   function bv_helicity_index (pol, h) result (i)
     class(bloch_vector_t), intent(in) :: pol
     integer, intent(in) :: h
     integer :: i
     i = helicity_index (pol%spin_type, h)
   end function bv_helicity_index
 
   function bv_helicity_value (pol, i) result (h)
     class(bloch_vector_t), intent(in) :: pol
     integer, intent(in) :: i
     integer :: h
     h = helicity_value (pol%spin_type, i)
   end function bv_helicity_value
 
   function bv_factor (pol) result (f)
     class(bloch_vector_t), intent(in) :: pol
     real(default) :: f
     f = bloch_factor (pol%spin_type)
   end function bv_factor
 
 @ %def get_n_states
 @ %def helicity_index
 @ %def helicity_value
 @ If the Bloch vector object is defined, the spin type is anything else but
 [[UNKNOWN]].  This allows us the provide the representation-specific
 functions above.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: is_defined => bloch_vector_is_defined
 <<Bloch vectors: procedures>>=
   function bloch_vector_is_defined (pol) result (flag)
     class(bloch_vector_t), intent(in) :: pol
     logical :: flag
     flag = pol%spin_type /= UNKNOWN
   end function bloch_vector_is_defined
 
 @ %def bloch_vector_is_defined
 @ If the Bloch vector object is (technically) polarized, it is
 defined, and the vector coefficient array has been allocated.
 However, the vector value may be zero.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: is_polarized => bloch_vector_is_polarized
 <<Bloch vectors: procedures>>=
   function bloch_vector_is_polarized (pol) result (flag)
     class(bloch_vector_t), intent(in) :: pol
     logical :: flag
     flag = allocated (pol%a)
   end function bloch_vector_is_polarized
 
 @ %def bloch_vector_is_polarized
 @ Return true if the polarization is diagonal, i.e., all entries in
 the density matrix are on the diagonal.  This is equivalent to
 requiring that only Cartan generator coefficients are nonzero in the
 Bloch vector.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: is_diagonal => bloch_vector_is_diagonal
 <<Bloch vectors: procedures>>=
   function bloch_vector_is_diagonal (pol) result (diagonal)
     class(bloch_vector_t), intent(in) :: pol
     logical :: diagonal
     integer :: s, i
     s = pol%spin_type
     diagonal = .true.
     if (pol%is_polarized ()) then
        do i = 1, size (pol%a)
           if (is_cartan_generator (s, i))  cycle
           if (pol%a(i) /= 0) then
              diagonal = .false.
              return
           end if
        end do
     end if
   end function bloch_vector_is_diagonal
 
 @ %def bloch_vector_is_diagonal
 @
 Return the Euclidean norm of the Bloch vector.  This is equal to the
 Killing form value of the corresponding algebra generator.  We assume
 that the polarization object has been initialized.
 
 For a pure state, the norm is unity.  All other allowed states have a
 norm less than unity.  (For $s\geq 1$, this is a necessary but not
 sufficient condition.)
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: get_norm => bloch_vector_get_norm
 <<Bloch vectors: procedures>>=
   function bloch_vector_get_norm (pol) result (norm)
     class(bloch_vector_t), intent(in) :: pol
     real(default) :: norm
     select case (pol%spin_type)
     case (SPINOR,VECTOR,VECTORSPINOR,TENSOR)
        norm = sqrt (dot_product (pol%a, pol%a))
     case default
        norm = 1
     end select
   end function bloch_vector_get_norm
 
 @ %def bloch_vector_get_norm
 @
 \subsection{Diagonal density matrix}
 This initializer takes a diagonal density matrix, represented by a
 real-valued array.  We assume that the trace is unity, and that the
 array has the correct shape for the given [[spin_type]].
 
 The [[bloch_factor]] renormalization is necessary such that a pure
 state maps to a Bloch vector with unit norm.
 <<Bloch vectors: bloch vector: TBP>>=
   generic :: init => bloch_vector_init_diagonal
   procedure, private :: bloch_vector_init_diagonal
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_init_diagonal (pol, spin_type, rd)
     class(bloch_vector_t), intent(out) :: pol
     integer, intent(in) :: spin_type
     real(default), dimension(:), intent(in) :: rd
     call pol%init (spin_type)
     call pol%set (rd)
   end subroutine bloch_vector_init_diagonal
 
 @ %def bloch_vector_init_diagonal
 @ Set a Bloch vector, given a diagonal density matrix as a real array.
 The Bloch vector must be initialized with correct characteristics.
 <<Bloch vectors: bloch vector: TBP>>=
   generic :: set => bloch_vector_set_diagonal
   procedure, private :: bloch_vector_set_diagonal
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_set_diagonal (pol, rd)
     class(bloch_vector_t), intent(inout) :: pol
     real(default), dimension(:), intent(in) :: rd
     integer :: s
     s = pol%spin_type
     select case (s)
     case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
        pol%a(:) = cartan_coeff (s, rd) / bloch_factor (s)
     end select
   end subroutine bloch_vector_set_diagonal
 
 @ %def bloch_vector_set_diagonal
 @
 @
 \subsection{Massless density matrix}
 This is a specific variant which initializes an equipartition for
 the maximum helicity, corresponding to an unpolarized massless particle.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: init_max_weight => bloch_vector_init_max_weight
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_init_max_weight (pol, spin_type)
     class(bloch_vector_t), intent(out) :: pol
     integer, intent(in) :: spin_type
     call pol%init (spin_type)
     select case (spin_type)
     case (VECTOR)
        call pol%set ([0.5_default, 0._default, 0.5_default])
     case (VECTORSPINOR)
        call pol%set ([0.5_default, 0._default, 0._default, 0.5_default])
     case (TENSOR)
        call pol%set ([0.5_default, 0._default, 0._default, 0._default, 0.5_default])
     end select
   end subroutine bloch_vector_init_max_weight
 
 @ %def bloch_vector_init_max_weight
 @ Initialize the maximum-weight submatrix with a three-component Bloch
 vector.  This is not as trivial as it seems because we need the above
 initialization for the generalized Bloch in order to remove the lower
 weights from the density matrix.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: init_vector => bloch_vector_init_vector
   procedure :: to_vector => bloch_vector_to_vector
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_init_vector (pol, s, a)
     class(bloch_vector_t), intent(out) :: pol
     integer, intent(in) :: s
     real(default), dimension(3), intent(in) :: a
     call pol%init_max_weight (s)
     select case (s)
     case (SPINOR, VECTOR, VECTORSPINOR, TENSOR)
        pol%a(1:3) = a / bloch_factor (s)
     end select
   end subroutine bloch_vector_init_vector
 
   subroutine bloch_vector_to_vector (pol, a)
     class(bloch_vector_t), intent(in) :: pol
     real(default), dimension(3), intent(out) :: a
     integer :: s
     s = pol%spin_type
     select case (s)
     case (SPINOR, VECTOR, VECTORSPINOR, TENSOR)
        a = pol%a(1:3) * bloch_factor (s)
     case default
        a = 0
     end select
   end subroutine bloch_vector_to_vector
 
 @ %def bloch_vector_init_vector
 @ %def bloch_vector_to_vector
 @
 \subsection{Arbitrary density matrix}
 Initialize the Bloch vector from a density matrix.  We assume that the
 density is valid.  In particular, the shape should match, the matrix
 should be hermitian, and the trace should be unity.
 
 We first fill the diagonal, then add the off-diagonal parts.
 <<Bloch vectors: bloch vector: TBP>>=
   generic :: init => bloch_vector_init_matrix
   procedure, private :: bloch_vector_init_matrix
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_init_matrix (pol, spin_type, r)
     class(bloch_vector_t), intent(out) :: pol
     integer, intent(in) :: spin_type
     complex(default), dimension(:,:), intent(in) :: r
     select case (spin_type)
     case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
        call pol%init (spin_type)
        call pol%set (r)
     case default
        call pol%init (UNKNOWN)
     end select
   end subroutine bloch_vector_init_matrix
 
 @ %def bloch_vector_init_matrix
 @ Set a Bloch vector, given an arbitrary density matrix as a real
 array.  The Bloch vector must be initialized with correct
 characteristics.
 <<Bloch vectors: bloch vector: TBP>>=
   generic :: set => bloch_vector_set_matrix
   procedure, private :: bloch_vector_set_matrix
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_set_matrix (pol, r)
     class(bloch_vector_t), intent(inout) :: pol
     complex(default), dimension(:,:), intent(in) :: r
     real(default), dimension(:), allocatable :: rd
     integer :: s, d, i, j, h1, h2, ir, ii
     s = pol%spin_type
     select case (s)
     case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
        d = fundamental_dimension (s)
        allocate (rd (d))
        do i = 1, d
           rd(i) = r(i,i)
        end do
        call pol%set (rd)
        do i = 1, d
           h1 = helicity_value (s, i)
           do j = i+1, d
              h2 = helicity_value (s, j)
              ir = root_index (s, h1, h2, .true.)
              ii = root_index (s, h1, h2, .false.)
              pol%a(ir) = real (r(j,i) + r(i,j)) / bloch_factor (s)
              pol%a(ii) = aimag (r(j,i) - r(i,j)) / bloch_factor (s)
           end do
        end do
     end select
   end subroutine bloch_vector_set_matrix
 
 @ %def bloch_vector_set_matrix
 @ Allocate and fill the density matrix [[r]] (with the index ordering as
 defined in [[su_algebra]]) that corresponds to a given Bloch vector.
 
 If the optional [[only_max_weight]] is set, the resulting matrix has
 entries only for $\pm h_\text{max}$, as appropriate for a massless
 particle (for spin $\geq 1$).  Note that we always add the unit
 matrix, as this is part of the Bloch-vector definition.
 <<Bloch vectors: bloch vector: TBP>>=
   procedure :: to_matrix => bloch_vector_to_matrix
 <<Bloch vectors: procedures>>=
   subroutine bloch_vector_to_matrix (pol, r, only_max_weight)
     class(bloch_vector_t), intent(in) :: pol
     complex(default), dimension(:,:), intent(out), allocatable :: r
     logical, intent(in), optional :: only_max_weight
     integer :: d, s, h0, ng, ai, h, h1, h2, i, j
     logical :: is_real, only_max
     complex(default) :: val
     if (.not. pol%is_polarized ())  return
     s = pol%spin_type
     only_max = .false.
     select case (s)
     case (VECTOR, VECTORSPINOR, TENSOR)
        if (present (only_max_weight))  only_max = only_max_weight
     end select
     if (only_max) then
        ng = 2
        h0 = helicity_value (s, 1)
     else
        ng = algebra_dimension (s)
        h0 = 0
     end if
     d = fundamental_dimension (s)
     allocate (r (d, d), source = (0._default, 0._default))
     do i = 1, d
        h = helicity_value (s, i)
        if (abs (h) < h0)  cycle
        r(i,i) = 1._default / d &
             + dot_product (cartan_element (s, h), pol%a) * bloch_factor (s)
     end do
     do ai = 1, ng
        if (is_cartan_generator (s, ai))  cycle
        call root_helicity (s, ai, h1, h2, is_real)
        i = helicity_index (s, h1)
        j = helicity_index (s, h2)
        if (is_real) then
           val = cmplx (pol%a(ai) / 2 * bloch_factor (s), 0._default, &
                kind=default)
           r(i,j) = r(i,j) + val
           r(j,i) = r(j,i) + val
        else
           val = cmplx (0._default, pol%a(ai) / 2 * bloch_factor (s), &
                kind=default)
           r(i,j) = r(i,j) - val
           r(j,i) = r(j,i) + val
        end if
     end do
   end subroutine bloch_vector_to_matrix
 
 @ %def bloch_vector_to_matrix
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[bloch_vectors_ut.f90]]>>=
 <<File header>>
 
 module bloch_vectors_ut
   use unit_tests
   use bloch_vectors_uti
 
 <<Standard module head>>
 
 <<Bloch vectors: public test>>
 
 contains
 
 <<Bloch vectors: test driver>>
 
 end module bloch_vectors_ut
 @ %def bloch_vectors_ut
 @
 <<[[bloch_vectors_uti.f90]]>>=
 <<File header>>
 
 module bloch_vectors_uti
 
 <<Use kinds>>
   use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
   use su_algebra, only: algebra_dimension, fundamental_dimension, helicity_value
 
   use bloch_vectors
 
 <<Standard module head>>
 
 <<Bloch vectors: test declarations>>
 
 contains
 
 <<Bloch vectors: tests>>
 
 end module bloch_vectors_uti
 @ %def bloch_vectors_ut
 @ API: driver for the unit tests below.
 <<Bloch vectors: public test>>=
   public :: bloch_vectors_test
 <<Bloch vectors: test driver>>=
   subroutine bloch_vectors_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Bloch vectors: execute tests>>
   end subroutine bloch_vectors_test
 
 @  %def bloch_vectors_test
 @
 \subsubsection{Initialization}
 Initialize the Bloch vector for any spin type.  First as unpolarized
 (no array), then as polarized but with zero polarization.
 <<Bloch vectors: execute tests>>=
   call test (bloch_vectors_1, "bloch_vectors_1", &
        "initialization", &
        u, results)
 <<Bloch vectors: test declarations>>=
   public :: bloch_vectors_1
 <<Bloch vectors: tests>>=
   subroutine bloch_vectors_1 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: bloch_vectors_1"
     write (u, "(A)")  "*   Purpose: test Bloch-vector &
          &polarization implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization (unpolarized)"
 
     write (u, "(A)")
     write (u, "(A)")  "* unknown"
     call bloch_init (UNKNOWN)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 0"
     call bloch_init (SCALAR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call bloch_init (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call bloch_init (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call bloch_init (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call bloch_init (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: bloch_vectors_1"
 
   contains
 
     subroutine bloch_init (s)
       integer, intent(in) :: s
       type(bloch_vector_t) :: pol
       real(default), dimension(:), allocatable :: a
       integer :: i
       write (u, *)
       write (u, "(1X,L1,L1)", advance="no") &
            pol%is_defined (), pol%is_polarized ()
       call pol%init_unpolarized (s)
       write (u, "(1X,L1,L1)", advance="no") &
            pol%is_defined (), pol%is_polarized ()
       call pol%init (s)
       write (u, "(1X,L1,L1)", advance="no") &
            pol%is_defined (), pol%is_polarized ()
       write (u, *)
       call pol%to_array (a)
       if (allocated (a)) then
          write (u, "(*(F7.4))")  a
          a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))]
          call pol%from_array (a)
          call pol%to_array (a)
          write (u, "(*(F7.4))")  a
       else
          write (u, *)
          write (u, *)
       end if
     end subroutine bloch_init
 
   end subroutine bloch_vectors_1
 
 @ %def bloch_vectors_1
 @
 \subsubsection{Pure state (diagonal)}
 Initialize the Bloch vector with a pure state of definite helicity and
 check the normalization.
 <<Bloch vectors: execute tests>>=
   call test (bloch_vectors_2, "bloch_vectors_2", &
        "pure state (diagonal)", &
        u, results)
 <<Bloch vectors: test declarations>>=
   public :: bloch_vectors_2
 <<Bloch vectors: tests>>=
   subroutine bloch_vectors_2 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: bloch_vectors_2"
     write (u, "(A)")  "*   Purpose: test Bloch-vector &
          &polarization implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization (polarized, diagonal): &
          &display vector and norm"
     write (u, "(A)")  "*   transform back"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 0"
     call bloch_diagonal (SCALAR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call bloch_diagonal (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call bloch_diagonal (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call bloch_diagonal (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call bloch_diagonal (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: bloch_vectors_2"
 
   contains
 
     subroutine bloch_diagonal (s)
       integer, intent(in) :: s
       type(bloch_vector_t) :: pol
       real(default), dimension(:), allocatable :: a
       real(default), dimension(:), allocatable :: rd
       complex(default), dimension(:,:), allocatable :: r
       integer :: i, j, d
       real(default) :: rj
       real, parameter :: tolerance = 1.E-14_default
       d = fundamental_dimension (s)
       do i = 1, d
          allocate (rd (d), source = 0._default)
          rd(i) = 1
          call pol%init (s, rd)
          call pol%to_array (a)
          write (u, *)
          write (u, "(A,1X,I2)")  "h:", helicity_value (s, i)
          write (u, 1, advance="no")  a
          write (u, "(1X,L1)")  pol%is_diagonal ()
          write (u, 1)  pol%get_norm ()
          call pol%to_matrix (r)
          do j = 1, d
             rj = real (r(j,j))
             if (abs (rj) < tolerance)  rj = 0
             write (u, 1, advance="no")  rj
          end do
          write (u, "(1X,L1)")  matrix_is_diagonal (r)
          deallocate (a, rd, r)
       end do
 1     format (99(1X,F7.4,:))
     end subroutine bloch_diagonal
 
     function matrix_is_diagonal (r) result (diagonal)
       complex(default), dimension(:,:), intent(in) :: r
       logical :: diagonal
       integer :: i, j
       diagonal = .true.
       do j = 1, size (r, 2)
          do i = 1, size (r, 1)
             if (i == j)  cycle
             if (r(i,j) /= 0) then
                diagonal = .false.
                return
             end if
          end do
       end do
     end function matrix_is_diagonal
 
   end subroutine bloch_vectors_2
 
 @ %def bloch_vectors_2
 @
 \subsubsection{Pure state (arbitrary)}
 Initialize the Bloch vector with an arbitrarily chosen pure state,
 check the normalization, and transform back to the density matrix.
 <<Bloch vectors: execute tests>>=
   call test (bloch_vectors_3, "bloch_vectors_3", &
        "pure state (arbitrary)", &
        u, results)
 <<Bloch vectors: test declarations>>=
   public :: bloch_vectors_3
 <<Bloch vectors: tests>>=
   subroutine bloch_vectors_3 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: bloch_vectors_3"
     write (u, "(A)")  "*   Purpose: test Bloch-vector &
          &polarization implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization (pure polarized, arbitrary):"
     write (u, "(A)")  "*   input matrix, transform, display norm, transform back"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 0"
     call bloch_arbitrary (SCALAR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call bloch_arbitrary (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call bloch_arbitrary (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call bloch_arbitrary (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call bloch_arbitrary (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: bloch_vectors_3"
 
   contains
 
     subroutine bloch_arbitrary (s)
       integer, intent(in) :: s
       type(bloch_vector_t) :: pol
       complex(default), dimension(:,:), allocatable :: r
       integer :: d
       d = fundamental_dimension (s)
       write (u, *)
       call init_matrix (d, r)
       call write_matrix (d, r)
       call pol%init (s, r)
       write (u, *)
       write (u, 2)  pol%get_norm (), pol%is_diagonal ()
       write (u, *)
       call pol%to_matrix (r)
       call write_matrix (d, r)
 2     format (1X,F7.4,1X,L1)
     end subroutine bloch_arbitrary
 
     subroutine init_matrix (d, r)
       integer, intent(in) :: d
       complex(default), dimension(:,:), allocatable, intent(out) :: r
       complex(default), dimension(:), allocatable :: a
       real(default) :: norm
       integer :: i, j
       allocate (a (d))
       norm = 0
       do i = 1, d
          a(i) = cmplx (2*i-1, 2*i, kind=default)
          norm = norm + conjg (a(i)) * a(i)
       end do
       a = a / sqrt (norm)
       allocate (r (d,d))
       do i = 1, d
          do j = 1, d
             r(i,j) = conjg (a(i)) * a(j)
          end do
       end do
     end subroutine init_matrix
 
     subroutine write_matrix (d, r)
       integer, intent(in) :: d
       complex(default), dimension(:,:), intent(in) :: r
       integer :: i, j
       do i = 1, d
          do j = 1, d
             write (u, 1, advance="no")  r(i,j)
          end do
          write (u, *)
       end do
 1     format (99(1X,'(',F7.4,',',F7.4,')',:))
     end subroutine write_matrix
 
   end subroutine bloch_vectors_3
 
 @ %def bloch_vectors_3
 @
 \subsubsection{Raw I/O}
 Check correct input/output in raw format.
 <<Bloch vectors: execute tests>>=
   call test (bloch_vectors_4, "bloch_vectors_4", &
        "raw I/O", &
        u, results)
 <<Bloch vectors: test declarations>>=
   public :: bloch_vectors_4
 <<Bloch vectors: tests>>=
   subroutine bloch_vectors_4 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: bloch_vectors_4"
     write (u, "(A)")  "*   Purpose: test Bloch-vector &
          &polarization implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Raw I/O"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 0"
     call bloch_io (SCALAR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call bloch_io (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call bloch_io (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call bloch_io (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call bloch_io (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: bloch_vectors_4"
 
   contains
 
     subroutine bloch_io (s)
       integer, intent(in) :: s
       type(bloch_vector_t) :: pol
       real(default), dimension(:), allocatable :: a
       integer :: n, i, utmp, iostat
       n = algebra_dimension (s)
       allocate (a (n))
       a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))]
       write (u, *)
       write (u, "(*(F7.4))")  a
       call pol%init (s)
       call pol%from_array (a)
       open (newunit = utmp, status = "scratch", action = "readwrite", &
            form = "unformatted")
       call pol%write_raw (utmp)
       rewind (utmp)
       call pol%read_raw (utmp, iostat=iostat)
       close (utmp)
       call pol%to_array (a)
       write (u, "(*(F7.4))")  a
     end subroutine bloch_io
 
   end subroutine bloch_vectors_4
 
 @ %def bloch_vectors_4
 @
 \subsubsection{Convenience Methods}
 Check some further TBP that are called by the [[polarizations]]
 module.
 <<Bloch vectors: execute tests>>=
   call test (bloch_vectors_5, "bloch_vectors_5", &
        "massless state (unpolarized)", &
        u, results)
 <<Bloch vectors: test declarations>>=
   public :: bloch_vectors_5
 <<Bloch vectors: tests>>=
   subroutine bloch_vectors_5 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: bloch_vectors_5"
     write (u, "(A)")  "*   Purpose: test Bloch-vector &
          &polarization implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Massless states: equipartition"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 0"
     call bloch_massless_unpol (SCALAR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call bloch_massless_unpol (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call bloch_massless_unpol (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call bloch_massless_unpol (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call bloch_massless_unpol (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: bloch_vectors_5"
 
   contains
 
     subroutine bloch_massless_unpol (s)
       integer, intent(in) :: s
       type(bloch_vector_t) :: pol
       complex(default), dimension(:,:), allocatable :: r
       real(default), dimension(:), allocatable :: a
       integer :: d
       d = fundamental_dimension (s)
       call pol%init_max_weight (s)
       call pol%to_matrix (r, only_max_weight = .false.)
       write (u, *)
       where (abs (r) < 1.e-14_default)  r = 0
       call write_matrix (d, r)
       call pol%to_matrix (r, only_max_weight = .true.)
       write (u, *)
       call write_matrix (d, r)
     end subroutine bloch_massless_unpol
 
     subroutine write_matrix (d, r)
       integer, intent(in) :: d
       complex(default), dimension(:,:), intent(in) :: r
       integer :: i, j
       do i = 1, d
          do j = 1, d
             write (u, 1, advance="no")  r(i,j)
          end do
          write (u, *)
       end do
 1     format (99(1X,'(',F7.4,',',F7.4,')',:))
     end subroutine write_matrix
 
   end subroutine bloch_vectors_5
 
 @ %def bloch_vectors_5
 @
 \subsubsection{Massless state (arbitrary)}
 Initialize the Bloch vector with an arbitrarily chosen pure state
 which consists only of highest-weight components.  Transform back to
 the density matrix.
 <<Bloch vectors: execute tests>>=
   call test (bloch_vectors_6, "bloch_vectors_6", &
        "massless state (arbitrary)", &
        u, results)
 <<Bloch vectors: test declarations>>=
   public :: bloch_vectors_6
 <<Bloch vectors: tests>>=
   subroutine bloch_vectors_6 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: bloch_vectors_6"
     write (u, "(A)")  "*   Purpose: test Bloch-vector &
          &polarization implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization (pure polarized massless, arbitrary):"
     write (u, "(A)")  "*   input matrix, transform, display norm, transform back"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 0"
     call bloch_massless (SCALAR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call bloch_massless (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call bloch_massless (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call bloch_massless (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call bloch_massless (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: bloch_vectors_6"
 
   contains
 
     subroutine bloch_massless (s)
       integer, intent(in) :: s
       type(bloch_vector_t) :: pol
       complex(default), dimension(:,:), allocatable :: r
       integer :: d
       d = fundamental_dimension (s)
       write (u, *)
       call init_matrix (d, r)
       call write_matrix (d, r)
       call pol%init (s, r)
       write (u, *)
       write (u, 2)  pol%get_norm (), pol%is_diagonal ()
       write (u, *)
       call pol%to_matrix (r, only_max_weight = .true.)
       call write_matrix (d, r)
 2     format (1X,F7.4,1X,L1)
     end subroutine bloch_massless
 
     subroutine init_matrix (d, r)
       integer, intent(in) :: d
       complex(default), dimension(:,:), allocatable, intent(out) :: r
       complex(default), dimension(:), allocatable :: a
       real(default) :: norm
       integer :: i, j
       allocate (a (d), source = (0._default, 0._default))
       norm = 0
       do i = 1, d, max (d-1, 1)
          a(i) = cmplx (2*i-1, 2*i, kind=default)
          norm = norm + conjg (a(i)) * a(i)
       end do
       a = a / sqrt (norm)
       allocate (r (d,d), source = (0._default, 0._default))
       do i = 1, d, max (d-1, 1)
          do j = 1, d, max (d-1, 1)
             r(i,j) = conjg (a(i)) * a(j)
          end do
       end do
     end subroutine init_matrix
 
     subroutine write_matrix (d, r)
       integer, intent(in) :: d
       complex(default), dimension(:,:), intent(in) :: r
       integer :: i, j
       do i = 1, d
          do j = 1, d
             write (u, 1, advance="no")  r(i,j)
          end do
          write (u, *)
       end do
 1     format (99(1X,'(',F7.4,',',F7.4,')',:))
     end subroutine write_matrix
 
   end subroutine bloch_vectors_6
 
 @ %def bloch_vectors_6
 @
 \subsubsection{Massless state (Bloch vector)}
 Initialize the (generalized) Bloch vector with an ordinary
 three-component Bloch vector that applies to the highest-weight part only.
 <<Bloch vectors: execute tests>>=
   call test (bloch_vectors_7, "bloch_vectors_7", &
        "massless state (vector)", &
        u, results)
 <<Bloch vectors: test declarations>>=
   public :: bloch_vectors_7
 <<Bloch vectors: tests>>=
   subroutine bloch_vectors_7 (u)
     integer, intent(in) :: u
 
     write (u, "(A)")  "* Test output: bloch_vectors_7"
     write (u, "(A)")  "*   Purpose: test Bloch-vector &
          &polarization implementation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialization &
          &(pure polarized massless, arbitrary Bloch vector):"
     write (u, "(A)")  "*   input vector, transform, display norm, &
          &transform back"
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 0"
     call bloch_massless_vector (SCALAR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1/2"
     call bloch_massless_vector (SPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 1"
     call bloch_massless_vector (VECTOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 3/2"
     call bloch_massless_vector (VECTORSPINOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* s = 2"
     call bloch_massless_vector (TENSOR)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: bloch_vectors_7"
 
   contains
 
     subroutine bloch_massless_vector (s)
       integer, intent(in) :: s
       type(bloch_vector_t) :: pol
       real(default), dimension(3) :: a
       complex(default), dimension(:,:), allocatable :: r
       write (u, *)
       a =  [1._default, 2._default, 4._default]
       a = a / sqrt (sum (a ** 2))
       write (u, 2)  a
       call pol%init_vector (s, a)
       write (u, 2)  pol%get_norm ()
       call pol%to_vector (a)
       write (u, 2)  a
       call pol%to_matrix (r, only_max_weight = .false.)
       write (u, *)
       where (abs (r) < 1.e-14_default)  r = 0
       call write_matrix (r)
       call pol%to_matrix (r, only_max_weight = .true.)
       write (u, *)
       call write_matrix (r)
 2     format (99(1X,F7.4,:))
     end subroutine bloch_massless_vector
 
     subroutine write_matrix (r)
       complex(default), dimension(:,:), intent(in) :: r
       integer :: i, j
       do i = 1, size (r, 1)
          do j = 1, size (r, 2)
             write (u, 1, advance="no")  r(i,j)
          end do
          write (u, *)
       end do
 1     format (99(1X,'(',F7.4,',',F7.4,')',:))
     end subroutine write_matrix
 
   end subroutine bloch_vectors_7
 
 @ %def bloch_vectors_7
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Polarization}
 Using generalized Bloch vectors and the $su(N)$ algebra (see above)
 for the internal representation, we can define various modes of
 polarization.  For
 spin-1/2, and analogously for massless spin-$s$ particles, we introduce
 \begin{enumerate}
 \item Trivial polarization: $\vec\alpha=0$. [This is unpolarized, but
   distinct from the particular undefined polarization matrix which has
   the same meaning.]
 \item Circular polarization: $\vec\alpha$ points in $\pm z$ direction.
 \item Transversal polarization: $\vec\alpha$ points orthogonal to the
   $z$ direction, with a phase $\phi$ that is $0$ for the $x$ axis, and
   $\pi/2=90^\circ$ for the $y$ axis.  For antiparticles, the phase
   switches sign, corresponding to complex conjugation.
 \item Axis polarization, where we explicitly give $\vec\alpha$.
 \end{enumerate}
 For higher spin, we retain this definition, but apply it to the two
 components with maximum and minimum weight.  In effect, we concentrate
 on the first three entries in the $\alpha^a$ array.  For massless
 particles, this is sufficient.  For massive particles, we then add the
 possibilities:
 \begin{enumerate}\setcounter{enumi}{4}
 \item Longitudinal polarization: Only the 0-component is set.  This is
   possible only for bosons.
 \item Diagonal polarization: Explicitly specify all components in the
   helicity basis.  The $su(N)$ representation consists of diagonal
   generators only, the Cartan subalgebra.
 \end{enumerate}
 Obviously, this does not exhaust the possible density matrices for
 higher spin, but it should cover practical applications.
 <<[[polarizations.f90]]>>=
 <<File header>>
 
 module polarizations
 
 <<Use kinds>>
   use io_units
   use format_defs, only: FMT_19
   use diagnostics
   use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
   use flavors
   use helicities
   use quantum_numbers
   use state_matrices
   use bloch_vectors
 
 <<Standard module head>>
 
 <<Polarizations: public>>
 
 <<Polarizations: types>>
 
 <<Polarizations: interfaces>>
 
 contains
 
 <<Polarizations: procedures>>
 
 end module polarizations
 @ %def polarizations
 @
 \subsection{The polarization type}
 Polarization is active whenever the coefficient array is allocated.
 For convenience, we store the spin type ($2s$) and the multiplicity
 ($N$) together with the coefficient array ($\alpha$).  We have to allow for
 the massless case where $s$ is arbitrary $>0$ but $N=2$, and
 furthermore the chiral massless case where $N=1$.  In the latter case,
 the array remains deallocated but the chirality is set to $\pm 1$.
 
 There is a convention that an antiparticle transforms according to the
 complex conjugate representation.  We apply this only when
 transforming from/to polarization defined by a three-vector.  For
 antiparticles, the two-component flips sign in that case.  When
 transforming from/to a state matrix or [[pmatrix]] representation, we
 do not apply this sign flip.
 <<Polarizations: public>>=
   public :: polarization_t
 <<Polarizations: types>>=
   type :: polarization_t
      private
      integer :: spin_type = SCALAR
      integer :: multiplicity = 1
      integer :: chirality = 0
      logical :: anti = .false.
      type(bloch_vector_t) :: bv
    contains
    <<Polarizations: polarization: TBP>>
   end type polarization_t
 
 @ %def polarization_t
 @
 \subsection{Basic initializer and finalizer}
 We need the particle flavor for determining the allowed helicity
 values.  The Bloch vector is left undefined, so this initializer (in
 two versions) creates an unpolarized particle.  Exception: a chiral
 particle is always polarized with definite helicity, it doesn't need a
 Bloch vector.
 
 This is private.
 <<Polarizations: polarization: TBP>>=
   generic, private :: init => polarization_init, polarization_init_flv
   procedure, private :: polarization_init
   procedure, private :: polarization_init_flv
 <<Polarizations: procedures>>=
   subroutine polarization_init (pol, spin_type, multiplicity, &
        anti, left_handed, right_handed)
     class(polarization_t), intent(out) :: pol
     integer, intent(in) :: spin_type
     integer, intent(in) :: multiplicity
     logical, intent(in) :: anti
     logical, intent(in) :: left_handed
     logical, intent(in) :: right_handed
     pol%spin_type = spin_type
     pol%multiplicity = multiplicity
     pol%anti = anti
     select case (pol%multiplicity)
     case (1)
        if (left_handed) then
           pol%chirality = -1
        else if (right_handed) then
           pol%chirality = 1
        end if
     end select
     select case (pol%chirality)
     case (0)
        call pol%bv%init_unpolarized (spin_type)
     end select
   end subroutine polarization_init
 
   subroutine polarization_init_flv (pol, flv)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     call pol%init ( &
          spin_type = flv%get_spin_type (), &
          multiplicity = flv%get_multiplicity (), &
          anti = flv%is_antiparticle (), &
          left_handed = flv%is_left_handed (), &
          right_handed = flv%is_right_handed ())
   end subroutine polarization_init_flv
 
 @ %def polarization_init polarization_init_flv
 @ Generic polarization: as before, but create a polarized particle
 (Bloch vector defined) with initial polarization zero.
 <<Polarizations: polarization: TBP>>=
   generic :: init_generic => &
        polarization_init_generic, &
        polarization_init_generic_flv
   procedure, private :: polarization_init_generic
   procedure, private :: polarization_init_generic_flv
 <<Polarizations: procedures>>=
   subroutine polarization_init_generic (pol, spin_type, multiplicity, &
        anti, left_handed, right_handed)
     class(polarization_t), intent(out) :: pol
     integer, intent(in) :: spin_type
     integer, intent(in) :: multiplicity
     logical, intent(in) :: anti
     logical, intent(in) :: left_handed
     logical, intent(in) :: right_handed
     call pol%init (spin_type, multiplicity, &
          anti, left_handed, right_handed)
     select case (pol%chirality)
     case (0)
        if (pol%multiplicity == pol%bv%get_n_states ()) then
           call pol%bv%init (spin_type)
        else
           call pol%bv%init_max_weight (spin_type)
        end if
     end select
   end subroutine polarization_init_generic
 
   subroutine polarization_init_generic_flv (pol, flv)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     call pol%init_generic ( &
          spin_type = flv%get_spin_type (), &
          multiplicity = flv%get_multiplicity (), &
          anti = flv%is_antiparticle (), &
          left_handed = flv%is_left_handed (), &
          right_handed = flv%is_right_handed ())
   end subroutine polarization_init_generic_flv
 
 @ %def polarization_init_generic
 @ A finalizer is no longer necessary.
 
 \subsection{I/O}
 The default setting produces a tabular output of the polarization
 vector entries.  Optionally, we can create a state matrix and write
 its contents, emulating the obsolete original implementation.
 
 If [[all_states]] is true (default), we generate all helity
 combinations regardless of the matrix-element value.  Otherwise, skip
 helicities with zero entry, or absolute value less than [[tolerance]],
 if also given.
 <<Polarizations: polarization: TBP>>=
   procedure :: write => polarization_write
 <<Polarizations: procedures>>=
   subroutine polarization_write (pol, unit, state_matrix, all_states, tolerance)
     class(polarization_t), intent(in) :: pol
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: state_matrix, all_states
     real(default), intent(in), optional :: tolerance
     logical :: state_m
     type(state_matrix_t) :: state
     real(default), dimension(:), allocatable :: a
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     state_m = .false.;  if (present (state_matrix))  state_m = state_matrix
     if (pol%anti) then
        write (u, "(1x,A,I1,A,I1,A,L1,A)")  &
             "Polarization: [spin_type = ", pol%spin_type, &
             ", mult = ", pol%multiplicity, ", anti = ", pol%anti, "]"
     else
        write (u, "(1x,A,I1,A,I1,A)")  &
             "Polarization: [spin_type = ", pol%spin_type, &
             ", mult = ", pol%multiplicity, "]"
     end if
     if (state_m) then
        call pol%to_state (state, all_states, tolerance)
        call state%write (unit=unit)
        call state%final ()
     else if (pol%chirality == 1) then
        write (u, "(1x,A)")  "chirality = +"
     else if (pol%chirality == -1) then
        write (u, "(1x,A)")  "chirality = -"
     else if (pol%bv%is_polarized ()) then
        call pol%bv%to_array (a)
        do i = 1, size (a)
           write (u, "(1x,I2,':',1x,F10.7)")  i, a(i)
        end do
     else
        write (u, "(1x,A)")  "[unpolarized]"
     end if
   end subroutine polarization_write
 
 @ %def polarization_write
 @ Binary I/O.
 <<Polarizations: polarization: TBP>>=
   procedure :: write_raw => polarization_write_raw
   procedure :: read_raw => polarization_read_raw
 <<Polarizations: procedures>>=
   subroutine polarization_write_raw (pol, u)
     class(polarization_t), intent(in) :: pol
     integer, intent(in) :: u
     write (u) pol%spin_type
     write (u) pol%multiplicity
     write (u) pol%chirality
     write (u) pol%anti
     call pol%bv%write_raw (u)
   end subroutine polarization_write_raw
 
   subroutine polarization_read_raw (pol, u, iostat)
     class(polarization_t), intent(out) :: pol
     integer, intent(in) :: u
     integer, intent(out), optional :: iostat
     read (u, iostat=iostat) pol%spin_type
     read (u, iostat=iostat) pol%multiplicity
     read (u, iostat=iostat) pol%chirality
     read (u, iostat=iostat) pol%anti
     call pol%bv%read_raw (u, iostat)
   end subroutine polarization_read_raw
 
 @ %def polarization_read_raw
 @
 \subsection{Accessing contents}
 Return true if the particle is technically polarized.  The particle
 is either chiral, or its Bloch vector has been defined.  The
 function returns true even if the Bloch vector is zero or the particle
 is scalar.
 <<Polarizations: polarization: TBP>>=
   procedure :: is_polarized => polarization_is_polarized
 <<Polarizations: procedures>>=
   function polarization_is_polarized (pol) result (polarized)
     class(polarization_t), intent(in) :: pol
     logical :: polarized
     polarized = pol%chirality /= 0 .or. pol%bv%is_polarized ()
   end function polarization_is_polarized
 
 @ %def polarization_is_polarized
 @ Return true if the polarization is diagonal, i.e., all entries in
 the density matrix are diagonal.  For an unpolarized particle, we also
 return [[.true.]] since the density matrix is proportional to the unit
 matrix.
 <<Polarizations: polarization: TBP>>=
   procedure :: is_diagonal => polarization_is_diagonal
 <<Polarizations: procedures>>=
   function polarization_is_diagonal (pol) result (diagonal)
     class(polarization_t), intent(in) :: pol
     logical :: diagonal
     select case (pol%chirality)
     case (0)
        diagonal = pol%bv%is_diagonal ()
     case default
        diagonal = .true.
     end select
   end function polarization_is_diagonal
 
 @ %def polarization_is_diagonal
 @
 \subsection{Mapping between polarization and state matrix}
 Create the polarization object that corresponds to a state matrix.  The state
 matrix is not necessarily normalized.  The result will be either unpolarized,
 or a generalized Bloch vector that we compute in terms of the appropriate spin
 generator basis.  To this end, we first construct the complete density
 matrix, then set the Bloch vector with this input.
 
 For a naturally chiral particle (i.e., neutrino), we do not set the
 polarization vector, it is implied.
 
 Therefore, we cannot account for any sign flip and transform as-is.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_state_matrix => polarization_init_state_matrix
 <<Polarizations: procedures>>=
   subroutine polarization_init_state_matrix (pol, state)
     class(polarization_t), intent(out) :: pol
     type(state_matrix_t), intent(in), target :: state
     type(state_iterator_t) :: it
     type(flavor_t) :: flv
     type(helicity_t) :: hel
     integer :: d, h1, h2, i, j
     complex(default), dimension(:,:), allocatable :: r
     complex(default) :: me
     real(default) :: trace
     call it%init (state)
     flv = it%get_flavor (1)
     hel = it%get_helicity (1)
     if (hel%is_defined ()) then
        call pol%init_generic (flv)
        select case (pol%chirality)
        case (0)
           trace = 0
           d = pol%bv%get_n_states ()
           allocate (r (d, d), source = (0._default, 0._default))
           do while (it%is_valid ())
              hel = it%get_helicity (1)
              call hel%get_indices (h1, h2)
              i = pol%bv%hel_index (h1)
              j = pol%bv%hel_index (h2)
              me = it%get_matrix_element ()
              r(i,j) = me
              if (i == j)  trace = trace + real (me)
              call it%advance ()
           end do
           if (trace /= 0)  call pol%bv%set (r / trace)
        end select
     else
        call pol%init (flv)
     end if
   end subroutine polarization_init_state_matrix
 
 @ %def polarization_init_state_matrix
 @ Create the state matrix that corresponds to a given polarization.  We make
 use of the polarization iterator as defined below, which should iterate
 according to the canonical helicity ordering.
 <<Polarizations: polarization: TBP>>=
   procedure :: to_state => polarization_to_state_matrix
 <<Polarizations: procedures>>=
   subroutine polarization_to_state_matrix (pol, state, all_states, tolerance)
     class(polarization_t), intent(in), target :: pol
     type(state_matrix_t), intent(out) :: state
     logical, intent(in), optional :: all_states
     real(default), intent(in), optional :: tolerance
     type(polarization_iterator_t) :: it
     type(quantum_numbers_t), dimension(1) :: qn
     complex(default) :: value
     call it%init (pol, all_states, tolerance)
     call state%init (store_values = .true.)
     do while (it%is_valid ())
        value = it%get_value ()
        qn(1) = it%get_quantum_numbers ()
        call state%add_state (qn, value = value)
        call it%advance ()
     end do
     call state%freeze ()
   end subroutine polarization_to_state_matrix
 
 @ %def polarization_to_state_matrix
 @
 \subsection{Specific initializers}
 Unpolarized particle, no nontrivial entries in the density matrix.  This
 is the default initialization mode.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_unpolarized => polarization_init_unpolarized
 <<Polarizations: procedures>>=
   subroutine polarization_init_unpolarized (pol, flv)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     call pol%init (flv)
   end subroutine polarization_init_unpolarized
 
 @ %def polarization_init_unpolarized
 @ The following three modes are useful mainly for spin-1/2 particle
 and massless particles of any nonzero spin.  Only the highest-weight
 components are filled.
 
 Circular polarization: The density matrix of the two highest-weight
 states is
 \begin{equation*}
   \rho(f) =
   \frac{1-|f|}{2}\mathbf{1} +
   |f| \times
   \begin{cases}
     \begin{pmatrix} 1 & 0 \\ 0 & 0 \end{pmatrix}, & f > 0; \\[6pt]
     \begin{pmatrix} 0 & 0 \\ 0 & 1 \end{pmatrix}, & f < 0,
   \end{cases}
 \end{equation*}
 In the generalized Bloch representation, this is an entry for the $T^3$
 generator only, regardless of the spin representation.
 
 A chiral particle is not affected.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_circular => polarization_init_circular
 <<Polarizations: procedures>>=
   subroutine polarization_init_circular (pol, flv, f)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     real(default), intent(in) :: f
     call pol%init (flv)
     select case (pol%chirality)
     case (0)
        call pol%bv%init_vector (pol%spin_type, &
             [0._default, 0._default, f])
     end select
   end subroutine polarization_init_circular
 
 @ %def polarization_init_circular
 @ Transversal polarization is analogous to circular, but we get a
 density matrix
 \begin{equation*}
   \rho(f,\phi) =
   \frac{1-|f|}{2}\mathbf{1}
   + \frac{|f|}{2}  \begin{pmatrix} 1 & e^{-i\phi} \\ e^{i\phi} & 1
   \end{pmatrix}.
 \end{equation*}
 for the highest-weight subspace.  The lower weights are unaffected.
 The phase is $\phi=0$ for the $x$-axis, $\phi=90^\circ$ for the $y$
 axis as polarization vector.
 
 For an antiparticle, the phase switches sign, and for $f<0$, the
 off-diagonal elements switch sign.
 
 A chiral particle is not affected.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_transversal => polarization_init_transversal
 <<Polarizations: procedures>>=
   subroutine polarization_init_transversal (pol, flv, phi, f)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     real(default), intent(in) :: phi, f
     call pol%init (flv)
     select case (pol%chirality)
     case (0)
        if (pol%anti) then
           call pol%bv%init_vector (pol%spin_type, &
                [f * cos (phi), f * sin (phi), 0._default])
        else
           call pol%bv%init_vector (pol%spin_type, &
                [f * cos (phi),-f * sin (phi), 0._default])
        end if
     end select
   end subroutine polarization_init_transversal
 
 @ %def polarization_init_transversal
 @ For axis polarization, we again set only the entries with maximum weight,
 which for spin $1/2$ means
 \begin{equation*}
   \rho(f,\phi) =
   \frac{1}{2} \begin{pmatrix}
                  1 + \alpha_3 & \alpha_1 - i\alpha_2 \\
                  \alpha_1 + i\alpha_2 & 1 - \alpha_3
               \end{pmatrix}.
 \end{equation*}
 For an antiparticle, the imaginary part proportional to $\alpha_2$ switches
 sign (complex conjugate).  A chiral particle is not affected.
 
 In the generalized Bloch representation, this translates into coefficients for
 $T^{1,2,3}$, all others stay zero.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_axis => polarization_init_axis
 <<Polarizations: procedures>>=
   subroutine polarization_init_axis (pol, flv, alpha)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     real(default), dimension(3), intent(in) :: alpha
     call pol%init (flv)
     select case (pol%chirality)
     case (0)
        if (pol%anti) then
           call pol%bv%init_vector (pol%spin_type, &
                [alpha(1), alpha(2), alpha(3)])
        else
           call pol%bv%init_vector (pol%spin_type, &
                [alpha(1),-alpha(2), alpha(3)])
        end if
     end select
   end subroutine polarization_init_axis
 
 @ %def polarization_init_axis
 @ This version specifies the polarization axis in terms of $r$
 (polarization degree) and $\theta,\phi$ (polar and azimuthal angles).
 
 If one of the angles is a nonzero multiple of $\pi$, roundoff errors
 typically will result in tiny contributions to unwanted components.
 Therefore, include a catch for small numbers.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_angles => polarization_init_angles
 <<Polarizations: procedures>>=
   subroutine polarization_init_angles (pol, flv, r, theta, phi)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     real(default), intent(in) :: r, theta, phi
     real(default), dimension(3) :: alpha
     real(default), parameter :: eps = 10 * epsilon (1._default)
 
     alpha(1) = r * sin (theta) * cos (phi)
     alpha(2) = r * sin (theta) * sin (phi)
     alpha(3) = r * cos (theta)
     where (abs (alpha) < eps)  alpha = 0
     call pol%init_axis (flv, alpha)
   end subroutine polarization_init_angles
 
 @ %def polarization_init_angles
 @ Longitudinal polarization is defined only for massive bosons.  Only
 the zero component is filled.  Otherwise, unpolarized.
 
 In the generalized Bloch representation, the zero component corresponds to a
 linear combination of all diagonal (Cartan) generators.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_longitudinal => polarization_init_longitudinal
 <<Polarizations: procedures>>=
   subroutine polarization_init_longitudinal (pol, flv, f)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     real(default), intent(in) :: f
     real(default), dimension(:), allocatable :: rd
     integer :: s, d
     s = flv%get_spin_type ()
     select case (s)
     case (VECTOR, TENSOR)
        call pol%init_generic (flv)
        if (pol%bv%is_polarized ()) then
           d = pol%bv%get_n_states ()
           allocate (rd (d), source = 0._default)
           rd(pol%bv%hel_index (0)) = f
           call pol%bv%set (rd)
        end if
     case default
        call pol%init_unpolarized (flv)
     end select
   end subroutine polarization_init_longitudinal
 
 @ %def polarization_init_longitudinal
 @ This is diagonal polarization: we specify all components explicitly.
 [[rd]] is the array of diagonal elements of the density matrix.  We
 assume that the length of [[rd]] is equal to the particle
 multiplicity.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_diagonal => polarization_init_diagonal
 <<Polarizations: procedures>>=
   subroutine polarization_init_diagonal (pol, flv, rd)
     class(polarization_t), intent(out) :: pol
     type(flavor_t), intent(in) :: flv
     real(default), dimension(:), intent(in) :: rd
     real(default) :: trace
     call pol%init_generic (flv)
     if (pol%bv%is_polarized ()) then
        trace = sum (rd)
        if (trace /= 0)  call pol%bv%set (rd / trace)
     end if
   end subroutine polarization_init_diagonal
 
 @ %def polarization_init_diagonal
 @
 \subsection{Operations}
 Combine polarization states by computing the outer product of the
 state matrices.
 <<Polarizations: public>>=
   public :: combine_polarization_states
 <<Polarizations: procedures>>=
   subroutine combine_polarization_states (pol, state)
     type(polarization_t), dimension(:), intent(in), target :: pol
     type(state_matrix_t), intent(out) :: state
     type(state_matrix_t), dimension(size(pol)), target :: pol_state
     integer :: i
     do i = 1, size (pol)
        call pol(i)%to_state (pol_state(i))
     end do
     call outer_multiply (pol_state, state)
     do i = 1, size (pol)
        call pol_state(i)%final ()
     end do
   end subroutine combine_polarization_states
 
 @ %def combine_polarization_states
 @ Transform a polarization density matrix into a polarization vector.  This is
 possible without information loss only for spin-1/2 and for massless
 particles.  To get a unique answer in all cases, we consider only the
 components with highest weight.  Obviously, this loses the longitudinal
 component of a massive vector, for instance.  The norm of the returned axis is
 the polarization fraction for the highest-weight subspace.  For a scalar
 particle, we return a zero vector.  The same result applies if the
 highest-weight component vanishes.
 
 This is the inverse operation of [[polarization_init_axis]] above,
 where the polarization fraction is set to unity.
 
 For an antiparticle, the [[alpha(2)]] coefficient flips sign.
 <<Polarizations: polarization: TBP>>=
   procedure :: get_axis => polarization_get_axis
 <<Polarizations: procedures>>=
   function polarization_get_axis (pol) result (alpha)
     class(polarization_t), intent(in), target :: pol
     real(default), dimension(3) :: alpha
     select case (pol%chirality)
     case (0)
        call pol%bv%to_vector (alpha)
        if (.not. pol%anti)  alpha(2) = - alpha(2)
     case (-1)
        alpha = [0._default, 0._default, -1._default]
     case (1)
        alpha = [0._default, 0._default, 1._default]
     end select
   end function polarization_get_axis
 
 @ %def polarization_get_axis
 @ This function returns polarization degree and polar and azimuthal
 angles ($\theta,\phi$) of the polarization axis.  The same restrictions apply
 as above.
 
 Since we call the [[get_axis]] method, the phase flips sign for an
 antiparticle.
 <<Polarizations: polarization: TBP>>=
   procedure :: to_angles => polarization_to_angles
 <<Polarizations: procedures>>=
   subroutine polarization_to_angles (pol, r, theta, phi)
     class(polarization_t), intent(in) :: pol
     real(default), intent(out) :: r, theta, phi
     real(default), dimension(3) :: alpha
     real(default) :: norm, r12
     alpha = pol%get_axis ()
     norm = sum (alpha**2)
     r = sqrt (norm)
     if (norm > 0) then
        r12 = sqrt (alpha(1)**2 + alpha(2)**2)
        theta = atan2 (r12, alpha(3))
        if (any (alpha(1:2) /= 0)) then
           phi = atan2 (alpha(2), alpha(1))
        else
           phi = 0
        end if
     else
        theta = 0
        phi = 0
     end if
   end subroutine polarization_to_angles
 
 @ %def polarization_to_angles
 @
 \subsection{Polarization Iterator}
 The iterator acts like a state matrix iterator, i.e., it points to one
 helicity combination at a time and can return the corresponding helicity
 object and matrix-element value.
 
 Since the polarization is stored as a Bloch vector, we recover the
 whole density matrix explicitly upon initialization, store it inside
 the iterator object, and then just return its elements one at a time.
 
 For an unpolarized particle, the iterator returns a single state with
 undefined helicity.  The value is the value of any diagonal density
 matrix element, $1/n$ where $n$ is the multiplicity.
 <<Polarizations: public>>=
   public :: polarization_iterator_t
 <<Polarizations: types>>=
   type :: polarization_iterator_t
      private
      type(polarization_t), pointer :: pol => null ()
      logical :: polarized = .false.
      integer :: h1 = 0
      integer :: h2 = 0
      integer :: i = 0
      integer :: j = 0
      complex(default), dimension(:,:), allocatable :: r
      complex(default) :: value = 1._default
      real(default) :: tolerance = -1._default
      logical :: valid = .false.
    contains
    <<Polarizations: polarization iterator: TBP>>
   end type polarization_iterator_t
 
 @ %def polarization_iterator_t
 @ Output for debugging purposes only, therefore no format for real/complex.
 <<Polarizations: polarization iterator: TBP>>=
   procedure :: write => polarization_iterator_write
 <<Polarizations: procedures>>=
   subroutine polarization_iterator_write (it, unit)
     class(polarization_iterator_t), intent(in) :: it
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1X,A)")  "Polarization iterator:"
     write (u, "(3X,A,L1)")  "assigned = ", associated (it%pol)
     write (u, "(3X,A,L1)")  "valid    = ", it%valid
     if (it%valid) then
        write (u, "(3X,A,2(1X,I2))")  "i, j     = ", it%i, it%j
        write (u, "(3X,A,2(1X,I2))")  "h1, h2   = ", it%h1, it%h2
        write (u, "(3X,A)", advance="no")  "value    = "
        write (u, *)  it%value
        if (allocated (it%r)) then
           do i = 1, size (it%r, 2)
              write (u, *)  it%r(i,:)
           end do
        end if
     end if
   end subroutine polarization_iterator_write
 
 @ %def polarization_iterator_write
 @ Initialize, i.e., (virtually) point to the first helicity state
 supported by the polarization object.  If the density matrix is
 nontrivial, we calculate it here.
 
 Following the older state-matrix
 conventions, the iterator sequence starts at the lowest helicity
 value.  In the current internal representation, this corresponds to
 the highest index value.
 
 If the current matrix-element value is zero, advance the iterator.
 Advancing will stop at a nonzero value or if the iterator becomes
 invalid.
 
 If [[tolerance]] is given, any state matrix entry less or equal will
 be treated as zero, causing the iterator to skip an entry.  By
 default, the value is negative, so no entry is skipped.
 <<Polarizations: polarization iterator: TBP>>=
   procedure :: init => polarization_iterator_init
 <<Polarizations: procedures>>=
   subroutine polarization_iterator_init (it, pol, all_states, tolerance)
     class(polarization_iterator_t), intent(out) :: it
     type(polarization_t), intent(in), target :: pol
     logical, intent(in), optional :: all_states
     real(default), intent(in), optional :: tolerance
     integer :: d
     logical :: only_max_weight
     it%pol => pol
     if (present (all_states)) then
        if (.not. all_states) then
           if (present (tolerance)) then
              it%tolerance = tolerance
           else
              it%tolerance = 0
           end if
        end if
     end if
     select case (pol%chirality)
     case (0)
        d = pol%bv%get_n_states ()
        only_max_weight = pol%multiplicity < d
        it%polarized = pol%bv%is_polarized ()
        if (it%polarized) then
           it%i = d
           it%j = it%i
           it%h1 = pol%bv%hel_value (it%i)
           it%h2 = it%h1
           call pol%bv%to_matrix (it%r, only_max_weight)
           it%value = it%r(it%i, it%j)
        else
           it%value = 1._default / d
        end if
        it%valid = .true.
     case (1,-1)
        it%polarized = .true.
        select case (pol%spin_type)
        case (SPINOR)
           it%h1 = pol%chirality
        case (VECTORSPINOR)
           it%h1 = 2 * pol%chirality
        end select
        it%h2 = it%h1
        it%valid = .true.
     end select
     if (it%valid .and. abs (it%value) <= it%tolerance)  call it%advance ()
   end subroutine polarization_iterator_init
 
 @ %def polarization_iterator_init
 @ Advance to the next valid helicity state.  Repeat if the returned value is
 zero.
 
 For an unpolarized object, we iterate through the diagonal helicity
 states with a constant value.
 <<Polarizations: polarization iterator: TBP>>=
   procedure :: advance => polarization_iterator_advance
 <<Polarizations: procedures>>=
   recursive subroutine polarization_iterator_advance (it)
     class(polarization_iterator_t), intent(inout) :: it
     if (it%valid) then
        select case (it%pol%chirality)
        case (0)
           if (it%polarized) then
              if (it%j > 1) then
                 it%j = it%j - 1
                 it%h2 = it%pol%bv%hel_value (it%j)
                 it%value = it%r(it%i, it%j)
              else if (it%i > 1) then
                 it%j = it%pol%bv%get_n_states ()
                 it%h2 = it%pol%bv%hel_value (it%j)
                 it%i = it%i - 1
                 it%h1 = it%pol%bv%hel_value (it%i)
                 it%value = it%r(it%i, it%j)
              else
                 it%valid = .false.
              end if
           else
              it%valid = .false.
           end if
        case default
           it%valid = .false.
        end select
        if (it%valid .and. abs (it%value) <= it%tolerance)  call it%advance ()
     end if
   end subroutine polarization_iterator_advance
 
 @ %def polarization_iterator_advance
 @ This is true as long as the iterator points to a valid helicity state.
 <<Polarizations: polarization iterator: TBP>>=
   procedure :: is_valid => polarization_iterator_is_valid
 <<Polarizations: procedures>>=
   function polarization_iterator_is_valid (it) result (is_valid)
     logical :: is_valid
     class(polarization_iterator_t), intent(in) :: it
     is_valid = it%valid
   end function polarization_iterator_is_valid
 
 @ %def polarization_iterator_is_valid
 @ Return the matrix element value for the helicity that we are currently
 pointing at.
 <<Polarizations: polarization iterator: TBP>>=
   procedure :: get_value => polarization_iterator_get_value
 <<Polarizations: procedures>>=
   function polarization_iterator_get_value (it) result (value)
     complex(default) :: value
     class(polarization_iterator_t), intent(in) :: it
     if (it%valid) then
        value = it%value
     else
        value = 0
     end if
   end function polarization_iterator_get_value
 
 @ %def polarization_iterator_get_value
 @ Return a quantum number object for the helicity that we are currently
 pointing at.  This is a single quantum number object, not an array.
 
 Note that the [[init]] method of the helicity object has the order reversed.
 <<Polarizations: polarization iterator: TBP>>=
   procedure :: get_quantum_numbers => polarization_iterator_get_quantum_numbers
 <<Polarizations: procedures>>=
   function polarization_iterator_get_quantum_numbers (it) result (qn)
     class(polarization_iterator_t), intent(in) :: it
     type(helicity_t) :: hel
     type(quantum_numbers_t) :: qn
     if (it%polarized) then
        call hel%init (it%h2, it%h1)
     end if
     call qn%init (hel)
   end function polarization_iterator_get_quantum_numbers
 
 @ %def polarization_iterator_get_quantum_numbers
 @
 \subsection{Sparse Matrix}
 We introduce a simple implementation of a sparse matrix that can represent
 polarization (or similar concepts) for transfer to I/O within the
 program.  It consists of an integer array that represents the index
 values, and a complex array that represents the nonvanishing entries.  The
 number of nonvanishing entries must be known for initialization, but the
 entries are filled one at a time.
 
 Here is a base type without the special properties of a spin-density matrix.
 <<Polarizations: public>>=
   public :: smatrix_t
 <<Polarizations: types>>=
   type :: smatrix_t
      private
      integer :: dim = 0
      integer :: n_entry = 0
      integer, dimension(:,:), allocatable :: index
      complex(default), dimension(:), allocatable :: value
    contains
    <<Polarizations: smatrix: TBP>>
   end type smatrix_t
 
 @ %def smatrix_t
 @ Output.
 <<Polarizations: smatrix: TBP>>=
   procedure :: write => smatrix_write
 <<Polarizations: procedures>>=
   subroutine smatrix_write (object, unit, indent)
     class(smatrix_t), intent(in) :: object
     integer, intent(in), optional :: unit, indent
     integer :: u, i, ind
     u = given_output_unit (unit)
     ind = 0;  if (present (indent))  ind = indent
     if (allocated (object%value)) then
        if (size (object%value) > 0) then
           do i = 1, object%n_entry
              write (u, "(1x,A,'@(')", advance="no")  repeat ("  ", ind)
              write (u, "(SP,9999(I2.1,':',1x))", advance="no") &
                   object%index(:,i)
              write (u, "('('," // FMT_19 // ",','," // FMT_19 // &
                   ",'))')")  object%value(i)
           end do
        else
           write (u, "(1x,A)", advance="no")  repeat ("  ", ind)
           write (u, "(A)")  "[empty matrix]"
        end if
     else
        write (u, "(1x,A)", advance="no")  repeat ("  ", ind)
        write (u, "(A)")  "[undefined matrix]"
     end if
   end subroutine smatrix_write
 
 @ %def smatrix_write
 @ Initialization: allocate arrays to the correct size.  We specify both the
 dimension of the matrix (if different from two, this is rather a generic
 tensor) and the number of nonvanishing entries.
 <<Polarizations: smatrix: TBP>>=
   procedure :: init => smatrix_init
 <<Polarizations: procedures>>=
   subroutine smatrix_init (smatrix, dim, n_entry)
     class(smatrix_t), intent(out) :: smatrix
     integer, intent(in) :: dim
     integer, intent(in) :: n_entry
     smatrix%dim = dim
     smatrix%n_entry = n_entry
     allocate (smatrix%index (dim, n_entry))
     allocate (smatrix%value (n_entry))
   end subroutine smatrix_init
 
 @ %def smatrix_init
 @ Fill: one entry at a time.
 <<Polarizations: smatrix: TBP>>=
   procedure :: set_entry => smatrix_set_entry
 <<Polarizations: procedures>>=
   subroutine smatrix_set_entry (smatrix, i, index, value)
     class(smatrix_t), intent(inout) :: smatrix
     integer, intent(in) :: i
     integer, dimension(:), intent(in) :: index
     complex(default), intent(in) :: value
     smatrix%index(:,i) = index
     smatrix%value(i) = value
   end subroutine smatrix_set_entry
 
 @ %def smatrix_set_entry
 @
 <<Polarizations: smatrix: TBP>>=
   procedure :: exists => smatrix_exists
 <<Polarizations: procedures>>=
   elemental function smatrix_exists (smatrix) result (exist)
     logical :: exist
     class(smatrix_t), intent(in) :: smatrix
     exist = .not. all (smatrix%value == 0)
   end function smatrix_exists
 
 @ %def smatrix_exists
 @
 \subsection{Polarization Matrix}
 As an extension of the more generic [[smatrix]] type, we implement a proper
 spin-density matrix.  After the matrix has been filled, we can fix spin type
 and multiplicity for a particle, check the matrix for consistency, and
 normalize it if necessary.
 
 This implementation does not have an antiparticle flag, just
 like the state matrix object.  We therefore cannot account for sign
 flips when using this object.
 
 TODO: The [[pure]] flag is for informational purposes only, and it
 only represents a necessary condition if spin is greater than $1/2$.
 We may either check purity for all spins or drop this.
 <<Polarizations: public>>=
   public :: pmatrix_t
 <<Polarizations: types>>=
   type, extends (smatrix_t) :: pmatrix_t
      private
      integer :: spin_type = 0
      integer :: multiplicity = 0
      logical :: massive = .true.
      integer :: chirality = 0
      real(default) :: degree = 1
      logical :: pure = .false.
    contains
    <<Polarizations: pmatrix: TBP>>
   end type pmatrix_t
 
 @ %def pmatrix_t
 @ Output, including extra data.  (The [[indent]] argument is ignored.)
 <<Polarizations: pmatrix: TBP>>=
   procedure :: write => pmatrix_write
 <<Polarizations: procedures>>=
   subroutine pmatrix_write (object, unit, indent)
     class(pmatrix_t), intent(in) :: object
     integer, intent(in), optional :: unit, indent
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Polarization: spin density matrix"
     write (u, "(3x,A,I0)")  "spin type     = ", object%spin_type
     write (u, "(3x,A,I0)")  "multiplicity  = ", object%multiplicity
     write (u, "(3x,A,L1)")  "massive       = ", object%massive
     write (u, "(3x,A,I0)")  "chirality     = ", object%chirality
     write (u, "(3x,A,F10.7)")  "pol.degree    =", object%degree
     write (u, "(3x,A,L1)")  "pure state    = ", object%pure
     call object%smatrix_t%write (u, 1)
   end subroutine pmatrix_write
 
 @ %def pmatrix_write
 @ This assignment is trivial, but must be coded explicitly.
 <<Polarizations: pmatrix: TBP>>=
   generic :: assignment(=) => pmatrix_assign_from_smatrix
   procedure, private :: pmatrix_assign_from_smatrix
 <<Polarizations: procedures>>=
   subroutine pmatrix_assign_from_smatrix (pmatrix, smatrix)
     class(pmatrix_t), intent(out) :: pmatrix
     type(smatrix_t), intent(in) :: smatrix
     pmatrix%smatrix_t = smatrix
   end subroutine pmatrix_assign_from_smatrix
 
 @ %def pmatrix_assign_from_smatrix
 @ Declare spin, multiplicity, and polarization degree.  Check whether all
 entries fit, and whether this is a valid matrix.
 
 The required properties are:
 \begin{enumerate}
 \item all entries apply to the given spin and mass type
 \item the diagonal is real
 \item only the upper of corresponding off-diagonal elements is specified,
   i.e., the row index is less than the column index
 \item the trace is nonnegative and equal to the polarization degree (the
   remainder, proportional to the unit matrix, is understood to be present)
 \item the trace of the matrix square is positive and less or equal
   to the trace of the matrix itself, which is the polarization degree.
 \item If the trace of the matrix square and the trace of the matrix are unity,
   we may have a pure state.  (For spin up to $1/2$, this is actually
   sufficient.)
 \end{enumerate}
 <<Polarizations: pmatrix: TBP>>=
   procedure :: normalize => pmatrix_normalize
 <<Polarizations: procedures>>=
   subroutine pmatrix_normalize (pmatrix, flv, degree, tolerance)
     class(pmatrix_t), intent(inout) :: pmatrix
     type(flavor_t), intent(in) :: flv
     real(default), intent(in), optional :: degree
     real(default), intent(in), optional :: tolerance
     integer :: i, hmax
     logical :: fermion, ok
     real(default) :: trace, trace_sq
     real(default) :: tol
     tol = 0;  if (present (tolerance))  tol = tolerance
     pmatrix%spin_type = flv%get_spin_type ()
     pmatrix%massive = flv%get_mass () /= 0
     if (.not. pmatrix%massive) then
        if (flv%is_left_handed ()) then
           pmatrix%chirality = -1
        else if (flv%is_right_handed ()) then
           pmatrix%chirality = +1
        end if
     end if
     if (pmatrix%spin_type == SCALAR) then
        pmatrix%multiplicity = 1
     else if (pmatrix%massive) then
        pmatrix%multiplicity = pmatrix%spin_type
     else if (pmatrix%chirality == 0) then
        pmatrix%multiplicity = 2
     else
        pmatrix%multiplicity = 1
     end if
     if (present (degree)) then
        if (degree < 0 .or. degree > 1) &
             call msg_error ("polarization degree must be between 0 and 1")
        pmatrix%degree = degree
     end if
     if (size (pmatrix%index, 1) /= 2)  call error ("wrong array rank")
     fermion = mod (pmatrix%spin_type, 2) == 0
     hmax = pmatrix%spin_type / 2
     if (pmatrix%n_entry > 0) then
        if (fermion) then
           if (pmatrix%massive) then
              ok = all (pmatrix%index /= 0) &
                   .and. all (abs (pmatrix%index) <= hmax)
           else if (pmatrix%chirality == -1) then
              ok = all (pmatrix%index == -hmax)
           else if (pmatrix%chirality == +1) then
              ok = all (pmatrix%index == +hmax)
           else
              ok = all (abs (pmatrix%index) == hmax)
           end if
        else
           if (pmatrix%massive) then
              ok = all (abs (pmatrix%index) <= hmax)
           else
              ok = all (abs (pmatrix%index) == hmax)
           end if
        end if
        if (.not. ok)  call error ("illegal index value")
     else
        pmatrix%degree = 0
        pmatrix%pure = pmatrix%multiplicity == 1
        return
     end if
     trace = 0
     do i = 1, pmatrix%n_entry
        associate (index => pmatrix%index(:,i), value => pmatrix%value(i))
          if (index(1) == index(2)) then
             if (abs (aimag (value)) > tol)  call error ("diagonal must be real")
             value = real (value, kind=default)
             trace = trace + value
 
          else if (any (pmatrix%index(1,:) == index(2) &
               .and.    pmatrix%index(2,:) == index(1))) then
             call error ("redundant off-diagonal entry")
          else if (index(2) < index (1)) then
             index = index([2,1])
             value = conjg (value)
          end if
        end associate
     end do
     if (abs (trace) <= tol)  call error ("trace must not vanish")
     trace = real (trace, kind=default)
     pmatrix%value = pmatrix%value / trace * pmatrix%degree
     trace_sq = (1 - pmatrix%degree ** 2) / pmatrix%multiplicity
     do i = 1, pmatrix%n_entry
        associate (index => pmatrix%index(:,i), value => pmatrix%value(i))
          if (index(1) == index(2)) then
             trace_sq = trace_sq + abs (value) ** 2
          else
             trace_sq = trace_sq + 2 * abs (value) ** 2
          end if
        end associate
     end do
     if (pmatrix%multiplicity == 1) then
        pmatrix%pure = .true.
     else if (abs (trace_sq - 1) <= tol) then
        pmatrix%pure = .true.
     else if (trace_sq - 1 > tol .or. trace_sq < -tol) then
        print *, "Trace of matrix square = ", trace_sq
        call error ("not permissible as density matrix")
     end if
   contains
     subroutine error (msg)
       character(*), intent(in) :: msg
       call pmatrix%write ()
       call msg_fatal ("Spin density matrix: " // msg)
     end subroutine error
   end subroutine pmatrix_normalize
 
 @ %def pmatrix_normalize
 @
 A polarized matrix is defined as one with a positive polarization degree, even
 if the actual matrix is trivial.
 <<Polarizations: pmatrix: TBP>>=
   procedure :: is_polarized => pmatrix_is_polarized
 <<Polarizations: procedures>>=
   elemental function pmatrix_is_polarized (pmatrix) result (flag)
     class(pmatrix_t), intent(in) :: pmatrix
     logical :: flag
     flag = pmatrix%degree > 0
   end function pmatrix_is_polarized
 
 @ %def pmatrix_is_polarized
 @
 Check if there are only diagonal entries.
 <<Polarizations: pmatrix: TBP>>=
   procedure :: is_diagonal => pmatrix_is_diagonal
 <<Polarizations: procedures>>=
   elemental function pmatrix_is_diagonal (pmatrix) result (flag)
     class(pmatrix_t), intent(in) :: pmatrix
     logical :: flag
     flag = all (pmatrix%index(1,:) == pmatrix%index(2,:))
   end function pmatrix_is_diagonal
 
 @ %def pmatrix_is_diagonal
 @
 Check if there are only diagonal entries.
 <<Polarizations: pmatrix: TBP>>=
   procedure :: get_simple_pol => pmatrix_get_simple_pol
 <<Polarizations: procedures>>=
   elemental function pmatrix_get_simple_pol (pmatrix) result (pol)
     class(pmatrix_t), intent(in) :: pmatrix
     real(default) :: pol
     if (pmatrix%is_polarized ()) then
        select case (size (pmatrix%value))
        case (0)
           pol = 0
        case (1)
           pol = pmatrix%index (1,1) * pmatrix%degree
        case (2)
           pol = 42
        end select
     else
        pol = 0
     end if
   end function pmatrix_get_simple_pol
 
 @ %def pmatrix_get_simple_pol
 @
 \subsection{Data Transformation}
 Create a [[polarization_t]] object from the contents of a normalized
 [[pmatrix_t]] object.  We scan the entries as present in [[pmatrix]] and
 transform them into a density matrix, if necessary.  The density
 matrix then initializes the Bloch vector.  This is
 analogous to [[polarization_init_state_matrix]].
 
 There is a subtlety associated with massless particles.  Since the
 [[pmatrix]] doesn't contain the full density matrix but just the
 nontrivial part, we have to initialize the polarization object with
 the massless equipartion, which contains nonzero entries for the
 Cartan generators.  The [[set]] method therefore should not erase
 those initial contents.  This is a constraint for the implementation
 of [[set]], as applied to the Bloch vector.
 
 As mentioned above, [[pmatrix_t]] does not support an
 antiparticle flag.
 <<Polarizations: polarization: TBP>>=
   procedure :: init_pmatrix => polarization_init_pmatrix
 <<Polarizations: procedures>>=
   subroutine polarization_init_pmatrix (pol, pmatrix)
     class(polarization_t), intent(out) :: pol
     type(pmatrix_t), intent(in) :: pmatrix
     integer :: d, i, j, k, h1, h2
     complex(default), dimension(:,:), allocatable :: r
     call pol%init_generic ( &
          spin_type = pmatrix%spin_type, &
          multiplicity = pmatrix%multiplicity, &
          anti = .false., &                     !!! SUFFICIENT?
          left_handed = pmatrix%chirality < 0, &
          right_handed = pmatrix%chirality > 0)
     if (pol%bv%is_polarized ()) then
        d = pol%bv%get_n_states ()
        allocate (r (d, d), source = (0._default, 0._default))
        if (d == pmatrix%multiplicity) then
           do i = 1, d
              r(i,i) = (1 - pmatrix%degree) / d
           end do
        else if (d > pmatrix%multiplicity) then
           r(1,1) = (1 - pmatrix%degree) / 2
           r(d,d) = r(1,1)
        end if
        do k = 1, size (pmatrix%value)
           h1 = pmatrix%index(1,k)
           h2 = pmatrix%index(2,k)
           i = pol%bv%hel_index (h1)
           j = pol%bv%hel_index (h2)
           r(i,j) = r(i,j) + pmatrix%value(k)
           r(j,i) = conjg (r(i,j))
        end do
        call pol%bv%set (r)
     end if
   end subroutine polarization_init_pmatrix
 
 @ %def polarization_init_pmatrix
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[polarizations_ut.f90]]>>=
 <<File header>>
 
 module polarizations_ut
   use unit_tests
   use polarizations_uti
 
 <<Standard module head>>
 
 <<Polarizations: public test>>
 
 contains
 
 <<Polarizations: test driver>>
 
 end module polarizations_ut
 @ %def polarizations_ut
 @
 <<[[polarizations_uti.f90]]>>=
 <<File header>>
 
 module polarizations_uti
 
 <<Use kinds>>
   use flavors
   use model_data
 
   use polarizations
 
 <<Standard module head>>
 
 <<Polarizations: test declarations>>
 
 contains
 
 <<Polarizations: tests>>
 
 end module polarizations_uti
 @ %def polarizations_ut
 @ API: driver for the unit tests below.
 <<Polarizations: public test>>=
   public :: polarizations_test
 <<Polarizations: test driver>>=
   subroutine polarizations_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Polarizations: execute tests>>
   end subroutine polarizations_test
 
 @  %def polarizations_test
 @
 \subsubsection{Polarization type}
 Checking the setup for polarization.
 <<Polarizations: execute tests>>=
   call test (polarization_1, "polarization_1", &
        "check polarization setup", &
        u, results)
 <<Polarizations: test declarations>>=
   public :: polarization_1
 <<Polarizations: tests>>=
   subroutine polarization_1 (u)
     use os_interface
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(polarization_t) :: pol
     type(flavor_t) :: flv
     real(default), dimension(3) :: alpha
     real(default) :: r, theta, phi
     real(default), parameter :: tolerance = 1.E-14_default
 
     write (u, "(A)")  "* Test output: polarization_1"
     write (u, "(A)")  "*   Purpose: test polarization setup"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
     write (u, "(A)")
 
     call model%init_sm_test ()
 
     write (u, "(A)") "* Unpolarized fermion"
     write (u, "(A)")
 
     call flv%init (1, model)
     call pol%init_unpolarized (flv)
     call pol%write (u, state_matrix = .true.)
     write (u, "(A,L1)")  "   diagonal =", pol%is_diagonal ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized fermion"
     write (u, "(A)")
 
     call pol%init_circular (flv, 0._default)
     call pol%write (u, state_matrix = .true., all_states = .false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Transversally polarized fermion, phi=0"
     write (u, "(A)")
 
     call pol%init_transversal (flv, 0._default, 1._default)
     call pol%write (u, state_matrix = .true.)
     write (u, "(A,L1)")  "   diagonal =", pol%is_diagonal ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Transversally polarized fermion, phi=0.9, frac=0.8"
     write (u, "(A)")
 
     call pol%init_transversal (flv, 0.9_default, 0.8_default)
     call pol%write (u, state_matrix = .true.)
     write (u, "(A,L1)")  "   diagonal =", pol%is_diagonal ()
 
     write (u, "(A)")
     write (u, "(A)") "* All polarization directions of a fermion"
     write (u, "(A)")
 
     call pol%init_generic (flv)
     call pol%write (u, state_matrix = .true.)
 
 
     call flv%init (21, model)
 
     write (u, "(A)")
     write (u, "(A)")  "* Circularly polarized gluon, frac=0.3"
     write (u, "(A)")
 
     call pol%init_circular (flv, 0.3_default)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
 
 
     call flv%init (23, model)
 
     write (u, "(A)")
     write (u, "(A)") "* Circularly polarized massive vector, frac=-0.7"
     write (u, "(A)")
 
     call pol%init_circular (flv,  -0.7_default)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Circularly polarized massive vector"
     write (u, "(A)")
 
     call pol%init_circular (flv, 1._default)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Longitudinally polarized massive vector, frac=0.4"
     write (u, "(A)")
 
     call pol%init_longitudinal (flv, 0.4_default)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Longitudinally polarized massive vector"
     write (u, "(A)")
 
     call pol%init_longitudinal (flv, 1._default)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
 
     write (u, "(A)")
     write (u, "(A)")  "* Diagonally polarized massive vector"
     write (u, "(A)")
 
     call pol%init_diagonal &
          (flv, [2._default, 1._default, 0._default])
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
 
     write (u, "(A)")
     write (u, "(A)")  "* All polarization directions of a massive vector"
     write (u, "(A)")
 
     call pol%init_generic (flv)
     call pol%write (u, state_matrix = .true.)
     call flv%init (21, model)
 
     write (u, "(A)")
     write (u, "(A)")  "* Axis polarization (0.2, 0.4, 0.6)"
     write (u, "(A)")
 
     alpha = [0.2_default, 0.4_default, 0.6_default]
     call pol%init_axis (flv, alpha)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
 
     write (u, "(A)")
     write (u, "(1X,A)")  "Recovered axis:"
     alpha = pol%get_axis ()
     write (u, "(3(1X,F10.7))")  alpha
 
     write (u, "(A)")
     write (u, "(A)")  "* Angle polarization (0.5, 0.6, -1)"
     r = 0.5_default
     theta = 0.6_default
     phi = -1._default
     call pol%init_angles (flv, r, theta, phi)
     write (u, "(A)")
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
 
     write (u, "(A)")
     write (u, "(1X,A)")  "Recovered parameters (r, theta, phi):"
     call pol%to_angles (r, theta, phi)
     write (u, "(3(1x,F10.7))")  r, theta, phi
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: polarization_1"
 
   end subroutine polarization_1
 
 @ %def polarization_1
 @
 \subsubsection{Sparse-Matrix type}
 Use a sparse density matrix universally as the input for setting up
 polarization.
 <<Polarizations: execute tests>>=
   call test (polarization_2, "polarization_2", &
        "matrix polarization setup", &
        u, results)
 <<Polarizations: test declarations>>=
   public :: polarization_2
 <<Polarizations: tests>>=
   subroutine polarization_2 (u)
     use os_interface
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(polarization_t) :: pol
     real(default), dimension(3) :: alpha
     type(pmatrix_t) :: pmatrix
     real(default), parameter :: tolerance = 1e-8_default
 
     write (u, "(A)")  "* Test output: polarization_2"
     write (u, "(A)")  "*   Purpose: matrix polarization setup"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
     write (u, "(A)")
 
     call model%init_sm_test ()
 
     write (u, "(A)") "* Unpolarized fermion"
     write (u, "(A)")
 
     call flv%init (1, model)
     call pmatrix%init (2, 0)
     call pmatrix%normalize (flv, 0._default, tolerance)
     call pmatrix%write (u)
     write (u, *)
     write (u, "(1x,A,L1)")  "polarized = ", pmatrix%is_polarized ()
     write (u, "(1x,A,L1)")  "diagonal = ", pmatrix%is_diagonal ()
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Transversally polarized fermion, phi=0"
     write (u, "(A)")
 
     call pmatrix%init (2, 3)
     call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
     call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default))
     call pmatrix%set_entry (3, [-1,+1], (1._default, 0._default))
     call pmatrix%normalize (flv, 1._default, tolerance)
     call pmatrix%write (u)
     write (u, *)
     write (u, "(1x,A,L1)")  "polarized = ", pmatrix%is_polarized ()
     write (u, "(1x,A,L1)")  "diagonal = ", pmatrix%is_diagonal ()
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Transversally polarized fermion, phi=0.9, frac=0.8"
     write (u, "(A)")
 
     call pmatrix%init (2, 3)
     call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
     call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default))
     call pmatrix%set_entry (3, [-1,+1], exp ((0._default, -0.9_default)))
     call pmatrix%normalize (flv, 0.8_default, tolerance)
     call pmatrix%write (u)
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true.)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Left-handed massive fermion, frac=1"
     write (u, "(A)")
 
     call flv%init (11, model)
     call pmatrix%init (2, 1)
     call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
     call pmatrix%normalize (flv, 1._default, tolerance)
     call pmatrix%write (u)
     write (u, *)
     write (u, "(1x,A,L1)")  "polarized = ", pmatrix%is_polarized ()
     write (u, "(1x,A,L1)")  "diagonal = ", pmatrix%is_diagonal ()
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Left-handed massive fermion, frac=0.8"
     write (u, "(A)")
 
     call flv%init (11, model)
     call pmatrix%init (2, 1)
     call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
     call pmatrix%normalize (flv, 0.8_default, tolerance)
     call pmatrix%write (u)
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Left-handed massless fermion"
     write (u, "(A)")
 
     call flv%init (12, model)
     call pmatrix%init (2, 0)
     call pmatrix%normalize (flv, 1._default, tolerance)
     call pmatrix%write (u)
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true.)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Right-handed massless fermion, frac=0.5"
     write (u, "(A)")
 
     call flv%init (-12, model)
     call pmatrix%init (2, 1)
     call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
     call pmatrix%normalize (flv, 0.5_default, tolerance)
     call pmatrix%write (u)
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true.)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Circularly polarized gluon, frac=0.3"
     write (u, "(A)")
 
     call flv%init (21, model)
     call pmatrix%init (2, 1)
     call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
     call pmatrix%normalize (flv, 0.3_default, tolerance)
     call pmatrix%write (u)
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)") "* Circularly polarized massive vector, frac=0.7"
     write (u, "(A)")
 
     call flv%init (23, model)
     call pmatrix%init (2, 1)
     call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
     call pmatrix%normalize (flv, 0.7_default, tolerance)
     call pmatrix%write (u)
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Circularly polarized massive vector"
     write (u, "(A)")
 
     call flv%init (23, model)
     call pmatrix%init (2, 1)
     call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
     call pmatrix%normalize (flv, 1._default, tolerance)
     call pmatrix%write (u)
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Longitudinally polarized massive vector, frac=0.4"
     write (u, "(A)")
 
     call flv%init (23, model)
     call pmatrix%init (2, 1)
     call pmatrix%set_entry (1, [0,0], (1._default, 0._default))
     call pmatrix%normalize (flv, 0.4_default, tolerance)
     call pmatrix%write (u)
     write (u, *)
     write (u, "(1x,A,L1)")  "polarized = ", pmatrix%is_polarized ()
     write (u, "(1x,A,L1)")  "diagonal = ", pmatrix%is_diagonal ()
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Longitudinally polarized massive vector"
     write (u, "(A)")
 
     call flv%init (23, model)
     call pmatrix%init (2, 1)
     call pmatrix%set_entry (1, [0,0], (1._default, 0._default))
     call pmatrix%normalize (flv, 1._default, tolerance)
     call pmatrix%write (u)
     write (u, *)
     write (u, "(1x,A,L1)")  "polarized = ", pmatrix%is_polarized ()
     write (u, "(1x,A,L1)")  "diagonal = ", pmatrix%is_diagonal ()
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true., &
          all_states = .false., tolerance = tolerance)
     ! call pol%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Axis polarization (0.2, 0.4, 0.6)"
     write (u, "(A)")
 
     call flv%init (11, model)
     alpha = [0.2_default, 0.4_default, 0.6_default]
     alpha = alpha / sqrt (sum (alpha**2))
     call pmatrix%init (2, 3)
     call pmatrix%set_entry (1, [-1,-1], cmplx (1 - alpha(3), kind=default))
     call pmatrix%set_entry (2, [1,-1], &
          cmplx (alpha(1),-alpha(2), kind=default))
     call pmatrix%set_entry (3, [1,1], cmplx (1 + alpha(3), kind=default))
     call pmatrix%normalize (flv, 1._default, tolerance)
     call pmatrix%write (u)
     write (u, *)
 
     call pol%init_pmatrix (pmatrix)
     call pol%write (u, state_matrix = .true.)
     ! call pol%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: polarization_2"
 
   end subroutine polarization_2
 
 @ %def polarization_2
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Particles}
 This module defines the [[particle_t]] object type, and the methods
 and operations that deal with it.
 <<[[particles.f90]]>>=
 <<File header>>
 
 module particles
 
 <<Use kinds with double>>
 <<Use strings>>
 <<Use debug>>
   use io_units
   use format_utils, only: write_compressed_integer_array, write_separator
   use format_utils, only: pac_fmt
   use format_defs, only: FMT_16, FMT_19
   use numeric_utils
   use diagnostics
   use lorentz
   use model_data
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use state_matrices
   use interactions
   use subevents
   use polarizations
   use pdg_arrays, only: is_quark, is_gluon
 
 <<Standard module head>>
 
 <<Particles: public>>
 
 <<Particles: parameters>>
 
 <<Particles: types>>
 
 <<Particles: interfaces>>
 
 contains
 
 <<Particles: procedures>>
 
 end module particles
 @ %def particles
 @
 \subsection{The particle type}
 \subsubsection{Particle status codes}
 The overall status codes (incoming/outgoing etc.) are inherited from
 the module [[subevents]].
 
 Polarization status:
 <<Particles: parameters>>=
   integer, parameter, public :: PRT_UNPOLARIZED = 0
   integer, parameter, public :: PRT_DEFINITE_HELICITY = 1
   integer, parameter, public :: PRT_GENERIC_POLARIZATION = 2
 
 @ %def PRT_UNPOLARIZED PRT_DEFINITE_HELICITY PRT_GENERIC_POLARIZATION
 @
 \subsubsection{Definition}
 The quantum numbers are flavor (from which invariant particle
 properties can be derived), color, and polarization.  The particle may
 be unpolarized.  In this case, [[hel]] and [[pol]] are unspecified.
 If it has a definite helicity, the [[hel]] component is defined.  If
 it has a generic polarization, the [[pol]] component is defined.  For
 each particle we store the four-momentum and the invariant mass
 squared, i.e., the squared norm of the four-momentum.  There is also
 an optional list of parent and child particles, for bookkeeping in
 physical events. The [[vertex]] is an optional component that consists of
 a Lorentz 4-vector, denoting the position and time of the vertex
 (displaced vertex/time). [[lifetime]] is an optional component that
 accounts for the finite lifetime $\tau$ of a decaying particle. In
 case there is no magnetic field etc., the true decay vertex of a
 particle in the detector would be $\vec{v}^\prime = \vec{v} + \tau
 \times \vec{p}/p^0$, where $p^0$ and $\vec{p}$ are the energy and
 3-momentum of the particle.
 
 <<Particles: public>>=
   public :: particle_t
 <<Particles: types>>=
   type :: particle_t
      !private
      integer :: status = PRT_UNDEFINED
      integer :: polarization = PRT_UNPOLARIZED
      type(flavor_t) :: flv
      type(color_t) :: col
      type(helicity_t) :: hel
      type(polarization_t) :: pol
      type(vector4_t) :: p = vector4_null
      real(default) :: p2 = 0
      type(vector4_t), allocatable :: vertex
      real(default), allocatable :: lifetime
      integer, dimension(:), allocatable :: parent
      integer, dimension(:), allocatable :: child
    contains
   <<Particles: particle: TBP>>
   end type particle_t
 
 @ %def particle_t
 @ Copy a particle.  (Deep copy)  This excludes the parent-child
 relations.
 <<Particles: particle: TBP>>=
   generic :: init => init_particle
   procedure :: init_particle => particle_init_particle
 <<Particles: procedures>>=
   subroutine particle_init_particle (prt_out, prt_in)
     class(particle_t), intent(out) :: prt_out
     type(particle_t), intent(in) :: prt_in
     prt_out%status = prt_in%status
     prt_out%polarization = prt_in%polarization
     prt_out%flv = prt_in%flv
     prt_out%col = prt_in%col
     prt_out%hel = prt_in%hel
     prt_out%pol = prt_in%pol
     prt_out%p = prt_in%p
     prt_out%p2 = prt_in%p2
     if (allocated (prt_in%vertex))  &
        allocate (prt_out%vertex, source=prt_in%vertex)
     if (allocated (prt_in%lifetime))  &
          allocate (prt_out%lifetime, source=prt_in%lifetime)
   end subroutine particle_init_particle
 
 @ %def particle_init_particle
 @ Initialize a particle using external information.
 <<Particles: particle: TBP>>=
   generic :: init => init_external
   procedure :: init_external => particle_init_external
 <<Particles: procedures>>=
   subroutine particle_init_external &
          (particle, status, pdg, model, col, anti_col, mom)
     class(particle_t), intent(out) :: particle
     integer, intent(in) :: status, pdg, col, anti_col
     class(model_data_t), pointer, intent(in) :: model
     type(vector4_t), intent(in) :: mom
     type(flavor_t) :: flavor
     type(color_t) :: color
     call flavor%init (pdg, model)
     call particle%set_flavor (flavor)
     call color%init_col_acl (col, anti_col)
     call particle%set_color (color)
     call particle%set_status (status)
     call particle%set_momentum (mom)
   end subroutine particle_init_external
 
 @ %def particle_init_external
 @ Initialize a particle using a single-particle state matrix which
 determines flavor, color, and polarization.  The state matrix must
 have unique flavor and color.  The factorization mode determines
 whether the particle is unpolarized, has definite helicity, or generic
 polarization.  This mode is translated into the polarization status.
 <<Particles: particle: TBP>>=
   generic :: init => init_state
   procedure :: init_state => particle_init_state
 <<Particles: procedures>>=
   subroutine particle_init_state (prt, state, status, mode)
     class(particle_t), intent(out) :: prt
     type(state_matrix_t), intent(in), target :: state
     integer, intent(in) :: status, mode
     type(state_iterator_t) :: it
     prt%status = status
     call it%init (state)
     prt%flv = it%get_flavor (1)
     if (prt%flv%is_radiated ())  prt%status = PRT_BEAM_REMNANT
     prt%col = it%get_color (1)
     select case (mode)
     case (FM_SELECT_HELICITY)
        prt%hel = it%get_helicity (1)
        if (prt%hel%is_defined ()) then
           prt%polarization = PRT_DEFINITE_HELICITY
        end if
     case (FM_FACTOR_HELICITY)
        call prt%pol%init_state_matrix (state)
        prt%polarization = PRT_GENERIC_POLARIZATION
     end select
   end subroutine particle_init_state
 
 @ %def particle_init_state
 @ Finalizer.
 <<Particles: particle: TBP>>=
   procedure :: final => particle_final
 <<Particles: procedures>>=
   subroutine particle_final (prt)
     class(particle_t), intent(inout) :: prt
     if (allocated (prt%vertex))  deallocate (prt%vertex)
     if (allocated (prt%lifetime))  deallocate (prt%lifetime)
   end subroutine particle_final
 
 @ %def particle_final
 @
 \subsubsection{I/O}
 <<Particles: particle: TBP>>=
   procedure :: write => particle_write
 <<Particles: procedures>>=
   subroutine particle_write (prt, unit, testflag, compressed, polarization)
     class(particle_t), intent(in) :: prt
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag, compressed, polarization
     logical :: comp, pacified, pol
     integer :: u, h1, h2
     real(default) :: pp2
     character(len=7) :: fmt
     character(len=20) :: buffer
     comp = .false.; if (present (compressed))  comp = compressed
     pacified = .false.;  if (present (testflag))  pacified = testflag
     pol = .true.;  if (present (polarization))  pol = polarization
     call pac_fmt (fmt, FMT_19, FMT_16, testflag)
     u = given_output_unit (unit);  if (u < 0)  return
     pp2 = prt%p2
     if (pacified)  call pacify (pp2, tolerance = 1E-10_default)
     select case (prt%status)
     case (PRT_UNDEFINED);    write (u, "(1x, A)", advance="no")  "[-]"
     case (PRT_BEAM);         write (u, "(1x, A)", advance="no")  "[b]"
     case (PRT_INCOMING);     write (u, "(1x, A)", advance="no")  "[i]"
     case (PRT_OUTGOING);     write (u, "(1x, A)", advance="no")  "[o]"
     case (PRT_VIRTUAL);      write (u, "(1x, A)", advance="no")  "[v]"
     case (PRT_RESONANT);     write (u, "(1x, A)", advance="no")  "[r]"
     case (PRT_BEAM_REMNANT); write (u, "(1x, A)", advance="no")  "[x]"
     end select
     write (u, "(1x)", advance="no")
     if (comp) then
        write (u, "(A7,1X)", advance="no") char (prt%flv%get_name ())
        if (pol) then
           select case (prt%polarization)
           case (PRT_DEFINITE_HELICITY)
              ! Integer helicity, assumed diagonal
              call prt%hel%get_indices (h1, h2)
              write (u, "(I2,1X)", advance="no") h1
           case (PRT_GENERIC_POLARIZATION)
              ! No space for full density matrix here
              write (u, "(A2,1X)", advance="no") "*"
           case default
              ! Blank entry if helicity is undefined
              write (u, "(A2,1X)", advance="no") " "
           end select
        end if
        write (u, "(2(I4,1X))", advance="no") &
             prt%col%get_col (), prt%col%get_acl ()
        call write_compressed_integer_array (buffer, prt%parent)
        write (u, "(A,1X)", advance="no") buffer
        call write_compressed_integer_array (buffer, prt%child)
        write (u, "(A,1X)", advance="no") buffer
        call prt%p%write(u, testflag = testflag, compressed = comp)
        write (u, "(F12.3)") pp2
     else
        call prt%flv%write (unit)
        if (prt%col%is_nonzero ()) then
           call color_write (prt%col, unit)
        end if
        if (pol) then
           select case (prt%polarization)
           case (PRT_DEFINITE_HELICITY)
              call prt%hel%write (unit)
              write (u, *)
           case (PRT_GENERIC_POLARIZATION)
              write (u, *)
              call prt%pol%write (unit, state_matrix = .true.)
           case default
              write (u, *)
           end select
        else
           write (u, *)
        end if
        call prt%p%write (unit, testflag = testflag)
        write (u, "(1x,A,1x," // fmt // ")")  "T = ", pp2
        if (allocated (prt%parent)) then
           if (size (prt%parent) /= 0) then
              write (u, "(1x,A,40(1x,I0))")  "Parents: ", prt%parent
           end if
        end if
        if (allocated (prt%child)) then
           if (size (prt%child) /= 0) then
              write (u, "(1x,A,40(1x,I0))")  "Children:", prt%child
           end if
        end if
        if (allocated (prt%vertex)) then
           write (u, "(1x,A,1x," // fmt // ")")  "Vtx t = ", prt%vertex%p(0)
           write (u, "(1x,A,1x," // fmt // ")")  "Vtx x = ", prt%vertex%p(1)
           write (u, "(1x,A,1x," // fmt // ")")  "Vtx y = ", prt%vertex%p(2)
           write (u, "(1x,A,1x," // fmt // ")")  "Vtx z = ", prt%vertex%p(3)
        end if
        if (allocated (prt%lifetime)) then
           write (u, "(1x,A,1x," // fmt // ")")  "Lifetime = ", &
                prt%lifetime
        end if
     end if
   end subroutine particle_write
 
 @ %def particle_write
 @ Binary I/O:
 <<Particles: particle: TBP>>=
   procedure :: write_raw => particle_write_raw
   procedure :: read_raw => particle_read_raw
 <<Particles: procedures>>=
   subroutine particle_write_raw (prt, u)
     class(particle_t), intent(in) :: prt
     integer, intent(in) :: u
     write (u) prt%status, prt%polarization
     call prt%flv%write_raw (u)
     call prt%col%write_raw (u)
     select case (prt%polarization)
     case (PRT_DEFINITE_HELICITY)
        call prt%hel%write_raw (u)
     case (PRT_GENERIC_POLARIZATION)
        call prt%pol%write_raw (u)
     end select
     call vector4_write_raw (prt%p, u)
     write (u) prt%p2
     write (u) allocated (prt%parent)
     if (allocated (prt%parent)) then
        write (u) size (prt%parent)
        write (u) prt%parent
     end if
     write (u) allocated (prt%child)
     if (allocated (prt%child)) then
        write (u) size (prt%child)
        write (u) prt%child
     end if
     write (u) allocated (prt%vertex)
     if (allocated (prt%vertex)) then
        call vector4_write_raw (prt%vertex, u)
     end if
     write (u) allocated (prt%lifetime)
     if (allocated (prt%lifetime)) then
        write (u) prt%lifetime
     end if
   end subroutine particle_write_raw
 
   subroutine particle_read_raw (prt, u, iostat)
     class(particle_t), intent(out) :: prt
     integer, intent(in) :: u
     integer, intent(out) :: iostat
     logical :: allocated_parent, allocated_child
     logical :: allocated_vertex, allocated_lifetime
     integer :: size_parent, size_child
     read (u, iostat=iostat) prt%status, prt%polarization
     call prt%flv%read_raw (u, iostat=iostat)
     call prt%col%read_raw (u, iostat=iostat)
     select case (prt%polarization)
     case (PRT_DEFINITE_HELICITY)
        call prt%hel%read_raw (u, iostat=iostat)
     case (PRT_GENERIC_POLARIZATION)
        call prt%pol%read_raw (u, iostat=iostat)
     end select
     call vector4_read_raw (prt%p, u, iostat=iostat)
     read (u, iostat=iostat) prt%p2
     read (u, iostat=iostat) allocated_parent
     if (allocated_parent) then
        read (u, iostat=iostat) size_parent
        allocate (prt%parent (size_parent))
        read (u, iostat=iostat) prt%parent
     end if
     read (u, iostat=iostat) allocated_child
     if (allocated_child) then
        read (u, iostat=iostat) size_child
        allocate (prt%child (size_child))
        read (u, iostat=iostat) prt%child
     end if
     read (u, iostat=iostat) allocated_vertex
     if (allocated_vertex) then
        allocate (prt%vertex)
        read (u, iostat=iostat) prt%vertex%p
     end if
     read (u, iostat=iostat) allocated_lifetime
     if (allocated_lifetime) then
        allocate (prt%lifetime)
        read (u, iostat=iostat) prt%lifetime
     end if
   end subroutine particle_read_raw
 
 @ %def particle_write_raw particle_read_raw
 @
 \subsubsection{Setting contents}
 Reset the status code.  Where applicable, set $p^2$ assuming that the
 particle is on-shell.
 <<Particles: particle: TBP>>=
   procedure :: reset_status => particle_reset_status
 <<Particles: procedures>>=
   elemental subroutine particle_reset_status (prt, status)
     class(particle_t), intent(inout) :: prt
     integer, intent(in) :: status
     prt%status = status
     select case (status)
     case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING)
        prt%p2 = prt%flv%get_mass () ** 2
     end select
   end subroutine particle_reset_status
 
 @ %def particle_reset_status
 @ The color can be given explicitly.
 <<Particles: particle: TBP>>=
   procedure :: set_color => particle_set_color
 <<Particles: procedures>>=
   elemental subroutine particle_set_color (prt, col)
     class(particle_t), intent(inout) :: prt
     type(color_t), intent(in) :: col
     prt%col = col
   end subroutine particle_set_color
 
 @ %def particle_set_color
 @ The flavor can be given explicitly.
 <<Particles: particle: TBP>>=
   procedure :: set_flavor => particle_set_flavor
 <<Particles: procedures>>=
   subroutine particle_set_flavor (prt, flv)
     class(particle_t), intent(inout) :: prt
     type(flavor_t), intent(in) :: flv
     prt%flv = flv
   end subroutine particle_set_flavor
 
 @ %def particle_set_flavor
 @ As can the helicity.
 <<Particles: particle: TBP>>=
   procedure :: set_helicity => particle_set_helicity
 <<Particles: procedures>>=
   subroutine particle_set_helicity (prt, hel)
     class(particle_t), intent(inout) :: prt
     type(helicity_t), intent(in) :: hel
     prt%hel = hel
   end subroutine particle_set_helicity
 
 @ %def particle_set_helicity
 @ And the polarization.
 <<Particles: particle: TBP>>=
   procedure :: set_pol => particle_set_pol
 <<Particles: procedures>>=
   subroutine particle_set_pol (prt, pol)
     class(particle_t), intent(inout) :: prt
     type(polarization_t), intent(in) :: pol
     prt%pol = pol
   end subroutine particle_set_pol
 
 @ %def particle_set_pol
 @ Manually set the model for the particle flavor.  This is required, e.g., if
 the particle has been read from file.
 <<Particles: particle: TBP>>=
   procedure :: set_model => particle_set_model
 <<Particles: procedures>>=
   subroutine particle_set_model (prt, model)
     class(particle_t), intent(inout) :: prt
     class(model_data_t), intent(in), target :: model
     call prt%flv%set_model (model)
   end subroutine particle_set_model
 
 @ %def particle_set_model
 @ The momentum is set independent of the quantum numbers.
 <<Particles: particle: TBP>>=
   procedure :: set_momentum => particle_set_momentum
 <<Particles: procedures>>=
   elemental subroutine particle_set_momentum (prt, p, p2, on_shell)
     class(particle_t), intent(inout) :: prt
     type(vector4_t), intent(in) :: p
     real(default), intent(in), optional :: p2
     logical, intent(in), optional :: on_shell
     prt%p = p
     if (present (on_shell)) then
        if (on_shell) then
           if (prt%flv%is_associated ()) then
              prt%p2 = prt%flv%get_mass () ** 2
              return
           end if
        end if
     end if
     if (present (p2)) then
        prt%p2 = p2
     else
        prt%p2 = p ** 2
     end if
   end subroutine particle_set_momentum
 
 @ %def particle_set_momentum
 @ Set resonance information.  This should be done after momentum
 assignment, because we need to know wheter the particle is spacelike
 or timelike.  The resonance flag is defined only for virtual
 particles.
 <<Particle: particle: TBP>>=
   procedure :: set_resonance_flag => particle_set_resonance_flag
 <<Particles: procedures>>=
   elemental subroutine particle_set_resonance_flag (prt, resonant)
     class(particle_t), intent(inout) :: prt
     logical, intent(in) :: resonant
     select case (prt%status)
     case (PRT_VIRTUAL)
        if (resonant)  prt%status = PRT_RESONANT
     end select
   end subroutine particle_set_resonance_flag
 
 @ %def particle_set_resonance_flag
 @ Set children and parents information.
 <<Particles: particle: TBP>>=
   procedure :: set_children => particle_set_children
   procedure :: set_parents => particle_set_parents
 <<Particles: procedures>>=
   subroutine particle_set_children (prt, idx)
     class(particle_t), intent(inout) :: prt
     integer, dimension(:), intent(in) :: idx
     if (allocated (prt%child))  deallocate (prt%child)
     allocate (prt%child (count (idx /= 0)))
     prt%child = pack (idx, idx /= 0)
   end subroutine particle_set_children
 
   subroutine particle_set_parents (prt, idx)
     class(particle_t), intent(inout) :: prt
     integer, dimension(:), intent(in) :: idx
     if (allocated (prt%parent))  deallocate (prt%parent)
     allocate (prt%parent (count (idx /= 0)))
     prt%parent = pack (idx, idx /= 0)
   end subroutine particle_set_parents
 
 @ %def particle_set_children particle_set_parents
 @
 <<Particles: particle: TBP>>=
   procedure :: add_child => particle_add_child
 <<Particles: procedures>>=
   subroutine particle_add_child (prt, new_child)
     class(particle_t), intent(inout) :: prt
     integer, intent(in) :: new_child
     integer, dimension(:), allocatable :: idx
     integer :: n, i
     n = prt%get_n_children()
     if (n == 0) then
        call prt%set_children ([new_child])
     else
        do i = 1, n
           if (prt%child(i) == new_child) then
              return
           end if
        end do
        allocate (idx (1:n+1))
        idx(1:n) = prt%get_children ()
        idx(n+1) = new_child
        call prt%set_children (idx)
     end if
   end subroutine particle_add_child
 
 @ %def particle_add_child
 @
 <<Particles: particle: TBP>>=
   procedure :: add_children => particle_add_children
 <<Particles: procedures>>=
   subroutine particle_add_children (prt, new_child)
     class(particle_t), intent(inout) :: prt
     integer, dimension(:), intent(in) :: new_child
     integer, dimension(:), allocatable :: idx
     integer :: n
     n = prt%get_n_children()
     if (n == 0) then
        call prt%set_children (new_child)
     else
        allocate (idx (1:n+size(new_child)))
        idx(1:n) = prt%get_children ()
        idx(n+1:n+size(new_child)) = new_child
        call prt%set_children (idx)
     end if
   end subroutine particle_add_children
 
 @ %def particle_add_children
 @
 <<Particles: particle: TBP>>=
   procedure :: set_status => particle_set_status
 <<Particles: procedures>>=
   elemental subroutine particle_set_status (prt, status)
     class(particle_t), intent(inout) :: prt
     integer, intent(in) :: status
     prt%status = status
   end subroutine particle_set_status
 
 @ %def particle_set_status
 @
 <<Particles: particle: TBP>>=
   procedure :: set_polarization => particle_set_polarization
 <<Particles: procedures>>=
   subroutine particle_set_polarization (prt, polarization)
     class(particle_t), intent(inout) :: prt
     integer, intent(in) :: polarization
     prt%polarization = polarization
   end subroutine particle_set_polarization
 
 @ %def particle_set_polarization
 @
 <<Particles: particle: TBP>>=
   generic :: set_vertex => set_vertex_from_vector3, set_vertex_from_xyz, &
        set_vertex_from_vector4, set_vertex_from_xyzt
   procedure :: set_vertex_from_vector4 => particle_set_vertex_from_vector4
   procedure :: set_vertex_from_vector3 => particle_set_vertex_from_vector3
   procedure :: set_vertex_from_xyzt => particle_set_vertex_from_xyzt
   procedure :: set_vertex_from_xyz => particle_set_vertex_from_xyz
 <<Particles: procedures>>=
   subroutine particle_set_vertex_from_vector4 (prt, vertex)
     class(particle_t), intent(inout) :: prt
     type(vector4_t), intent(in) :: vertex
     if (allocated (prt%vertex)) deallocate (prt%vertex)
     allocate (prt%vertex, source=vertex)
   end subroutine particle_set_vertex_from_vector4
 
   subroutine particle_set_vertex_from_vector3 (prt, vertex)
     class(particle_t), intent(inout) :: prt
     type(vector3_t), intent(in) :: vertex
     type(vector4_t) :: vtx
     vtx = vector4_moving (0._default, vertex)
     if (allocated (prt%vertex)) deallocate (prt%vertex)
     allocate (prt%vertex, source=vtx)
   end subroutine particle_set_vertex_from_vector3
 
   subroutine particle_set_vertex_from_xyzt (prt, vx, vy, vz, t)
     class(particle_t), intent(inout) :: prt
     real(default), intent(in) :: vx, vy, vz, t
     type(vector4_t) :: vertex
     if (allocated (prt%vertex)) deallocate (prt%vertex)
     vertex = vector4_moving (t, vector3_moving ([vx, vy, vz]))
     allocate (prt%vertex, source=vertex)
   end subroutine particle_set_vertex_from_xyzt
 
   subroutine particle_set_vertex_from_xyz (prt, vx, vy, vz)
     class(particle_t), intent(inout) :: prt
     real(default), intent(in) :: vx, vy, vz
     type(vector4_t) :: vertex
     if (allocated (prt%vertex)) deallocate (prt%vertex)
     vertex = vector4_moving (0._default, vector3_moving ([vx, vy, vz]))
     allocate (prt%vertex, source=vertex)
   end subroutine particle_set_vertex_from_xyz
 
 @ %def particle_set_vertex_from_vector3
 @ %def particle_set_vertex_from_vector4
 @ %def particle_set_vertex_from_xyz
 @ %def particle_set_vertex_from_xyzt
 @ Set the lifetime of a particle.
 <<Particles: particle: TBP>>=
   procedure :: set_lifetime => particle_set_lifetime
 <<Particles: procedures>>=
   elemental subroutine particle_set_lifetime (prt, lifetime)
     class(particle_t), intent(inout) :: prt
     real(default), intent(in) :: lifetime
     if (allocated (prt%lifetime))  deallocate (prt%lifetime)
     allocate (prt%lifetime, source=lifetime)
   end subroutine particle_set_lifetime
 
 @ %def particle_set_lifetime
 @
 \subsubsection{Accessing contents}
 The status code.
 <<Particles: particle: TBP>>=
   procedure :: get_status => particle_get_status
 <<Particles: procedures>>=
   elemental function particle_get_status (prt) result (status)
     integer :: status
     class(particle_t), intent(in) :: prt
     status = prt%status
   end function particle_get_status
 
 @ %def particle_get_status
 @ Return true if the status is either [[INCOMING]],
 [[OUTGOING]] or [[RESONANT]]. [[BEAM]] is kept, if
 [[keep_beams]] is set true.
 <<Particles: particle: TBP>>=
   procedure :: is_real => particle_is_real
 <<Particles: procedures>>=
   elemental function particle_is_real (prt, keep_beams) result (flag)
     logical :: flag, kb
     class(particle_t), intent(in) :: prt
     logical, intent(in), optional :: keep_beams
     kb = .false.
     if (present (keep_beams)) kb = keep_beams
     select case (prt%status)
     case (PRT_INCOMING, PRT_OUTGOING, PRT_RESONANT)
        flag = .true.
     case (PRT_BEAM)
        flag = kb
     case default
        flag = .false.
     end select
   end function particle_is_real
 
 @ %def particle_is_real
 @
 <<Particles: particle: TBP>>=
   procedure :: is_colored => particle_is_colored
 <<Particles: procedures>>=
   elemental function particle_is_colored (particle) result (flag)
     logical :: flag
     class(particle_t), intent(in) :: particle
     flag = particle%col%is_nonzero ()
   end function particle_is_colored
 
 @ %def particle_is_colored
 @ $[90,100]$ hopefully catches all of them and not too many.
 <<Particles: particle: TBP>>=
   procedure :: is_hadronic_beam_remnant => particle_is_hadronic_beam_remnant
 <<Particles: procedures>>=
   elemental function particle_is_hadronic_beam_remnant (particle) result (flag)
     class(particle_t), intent(in) :: particle
     logical :: flag
     integer :: pdg
     pdg = particle%flv%get_pdg ()
     flag = particle%status == PRT_BEAM_REMNANT .and. &
          abs(pdg) >= 90 .and. abs(pdg) <= 100
   end function particle_is_hadronic_beam_remnant
 
 @ %def particle_is_hadronic_beam_remnant
 @
 <<Particles: particle: TBP>>=
   procedure :: is_beam_remnant => particle_is_beam_remnant
 <<Particles: procedures>>=
   elemental function particle_is_beam_remnant (particle) result (flag)
     class(particle_t), intent(in) :: particle
     logical :: flag
     flag = particle%status == PRT_BEAM_REMNANT
   end function particle_is_beam_remnant
 
 @ %def particle_is_beam_remnant
 @ Polarization status.
 <<Particles: particle: TBP>>=
   procedure :: get_polarization_status => particle_get_polarization_status
 <<Particles: procedures>>=
   elemental function particle_get_polarization_status (prt) result (status)
     integer :: status
     class(particle_t), intent(in) :: prt
     status = prt%polarization
   end function particle_get_polarization_status
 
 @ %def particle_get_polarization_status
 @ Return the PDG code from the flavor component directly.
 <<Particles: particle: TBP>>=
   procedure :: get_pdg => particle_get_pdg
 <<Particles: procedures>>=
   elemental function particle_get_pdg (prt) result (pdg)
     integer :: pdg
     class(particle_t), intent(in) :: prt
     pdg = prt%flv%get_pdg ()
   end function particle_get_pdg
 
 @ %def particle_get_pdg
 @ Return the color and anticolor quantum numbers.
 <<Particles: particle: TBP>>=
   procedure :: get_color => particle_get_color
 <<Particles: procedures>>=
   pure function particle_get_color (prt) result (col)
     integer, dimension(2) :: col
     class(particle_t), intent(in) :: prt
     col(1) = prt%col%get_col ()
     col(2) = prt%col%get_acl ()
   end function particle_get_color
 
 @ %def particle_get_color
 @ Return a copy of the polarization density matrix.
 <<Particles: particle: TBP>>=
   procedure :: get_polarization => particle_get_polarization
 <<Particles: procedures>>=
   function particle_get_polarization (prt) result (pol)
     class(particle_t), intent(in) :: prt
     type(polarization_t) :: pol
     pol = prt%pol
   end function particle_get_polarization
 
 @ %def particle_get_polarization
 @ Return the flavor, color and helicity.
 <<Particles: particle: TBP>>=
   procedure :: get_flv => particle_get_flv
   procedure :: get_col => particle_get_col
   procedure :: get_hel => particle_get_hel
 <<Particles: procedures>>=
   function particle_get_flv (prt) result (flv)
     class(particle_t), intent(in) :: prt
     type(flavor_t) :: flv
     flv = prt%flv
   end function particle_get_flv
 
   function particle_get_col (prt) result (col)
     class(particle_t), intent(in) :: prt
     type(color_t) :: col
     col = prt%col
   end function particle_get_col
 
   function particle_get_hel (prt) result (hel)
     class(particle_t), intent(in) :: prt
     type(helicity_t) :: hel
     hel = prt%hel
   end function particle_get_hel
 
 @ %def particle_get_flv particle_get_col particle_get_hel
 @ Return the helicity (if defined and diagonal).
 <<Particles: particle: TBP>>=
   procedure :: get_helicity => particle_get_helicity
 <<Particles: procedures>>=
   elemental function particle_get_helicity (prt) result (hel)
     integer :: hel
     integer, dimension(2) :: hel_arr
     class(particle_t), intent(in) :: prt
     hel = 0
     if (prt%hel%is_defined () .and. prt%hel%is_diagonal ()) then
        hel_arr = prt%hel%to_pair ()
        hel = hel_arr (1)
     end if
   end function particle_get_helicity
 
 @ %def particle_get_helicity
 @ Return the number of children/parents
 <<Particles: particle: TBP>>=
   procedure :: get_n_parents => particle_get_n_parents
   procedure :: get_n_children => particle_get_n_children
 <<Particles: procedures>>=
   elemental function particle_get_n_parents (prt) result (n)
     integer :: n
     class(particle_t), intent(in) :: prt
     if (allocated (prt%parent)) then
        n = size (prt%parent)
     else
        n = 0
     end if
   end function particle_get_n_parents
 
   elemental function particle_get_n_children (prt) result (n)
     integer :: n
     class(particle_t), intent(in) :: prt
     if (allocated (prt%child)) then
        n = size (prt%child)
     else
        n = 0
     end if
   end function particle_get_n_children
 
 @ %def particle_get_n_parents particle_get_n_children
 @ Return the array of parents/children.
 <<Particles: particle: TBP>>=
   procedure :: get_parents => particle_get_parents
   procedure :: get_children => particle_get_children
 <<Particles: procedures>>=
   function particle_get_parents (prt) result (parent)
     class(particle_t), intent(in) :: prt
     integer, dimension(:), allocatable :: parent
     if (allocated (prt%parent)) then
        allocate (parent (size (prt%parent)))
        parent = prt%parent
     else
        allocate (parent (0))
     end if
   end function particle_get_parents
 
   function particle_get_children (prt) result (child)
     class(particle_t), intent(in) :: prt
     integer, dimension(:), allocatable :: child
     if (allocated (prt%child)) then
        allocate (child (size (prt%child)))
        child = prt%child
     else
        allocate (child (0))
     end if
   end function particle_get_children
 
 @ %def particle_get_children
 @
 <<Particles: particle: TBP>>=
   procedure :: has_children => particle_has_children
 <<Particles: procedures>>=
   elemental function particle_has_children (prt) result (has_children)
     logical :: has_children
     class(particle_t), intent(in) :: prt
     has_children = .false.
     if (allocated (prt%child)) then
        has_children = size (prt%child) > 0
     end if
   end function particle_has_children
 
 @ %def particle_has_children
 @
 <<Particles: particle: TBP>>=
   procedure :: has_parents => particle_has_parents
 <<Particles: procedures>>=
   elemental function particle_has_parents (prt) result (has_parents)
     logical :: has_parents
     class(particle_t), intent(in) :: prt
     has_parents = .false.
     if (allocated (prt%parent)) then
        has_parents = size (prt%parent) > 0
     end if
   end function particle_has_parents
 
 @ %def particle_has_parents
 @ Return momentum and momentum squared.
 <<Particles: particle: TBP>>=
   procedure :: get_momentum => particle_get_momentum
   procedure :: get_p2 => particle_get_p2
 <<Particles: procedures>>=
   elemental function particle_get_momentum (prt) result (p)
     type(vector4_t) :: p
     class(particle_t), intent(in) :: prt
     p = prt%p
   end function particle_get_momentum
 
   elemental function particle_get_p2 (prt) result (p2)
     real(default) :: p2
     class(particle_t), intent(in) :: prt
     p2 = prt%p2
   end function particle_get_p2
 
 @ %def particle_get_momentum particle_get_p2
 @ Return the particle vertex, if allocated.
 <<Particles: particle: TBP>>=
   procedure :: get_vertex => particle_get_vertex
 <<Particles: procedures>>=
   elemental function particle_get_vertex (prt) result (vtx)
     type(vector4_t) :: vtx
     class(particle_t), intent(in) :: prt
     if (allocated (prt%vertex)) then
        vtx = prt%vertex
     else
        vtx = vector4_null
     end if
   end function particle_get_vertex
 
 @ %def particle_get_vertex
 @ Return the lifetime of a particle.
 <<Particles: particle: TBP>>=
   procedure :: get_lifetime => particle_get_lifetime
 <<Particles: procedures>>=
   elemental function particle_get_lifetime (prt) result (lifetime)
     real(default) :: lifetime
     class(particle_t), intent(in) :: prt
     if (allocated (prt%lifetime)) then
        lifetime = prt%lifetime
     else
        lifetime = 0
     end if
   end function particle_get_lifetime
 
 @ %def particle_get_lifetime
 @
 <<Particles: particle: TBP>>=
   procedure :: momentum_to_pythia6 => particle_momentum_to_pythia6
 <<Particles: procedures>>=
   pure function particle_momentum_to_pythia6 (prt) result (p)
     real(double), dimension(1:5) :: p
     class(particle_t), intent(in) :: prt
     p = prt%p%to_pythia6 (sqrt (prt%p2))
   end function particle_momentum_to_pythia6
 
 @ %def particle_momentum_to_pythia6
 @
 \subsection{Particle sets}
 A particle set is what is usually called an event: an array of
 particles.  The individual particle entries carry momentum, quantum
 numbers, polarization, and optionally connections.  There is (also
 optionally) a correlated state-density matrix that maintains spin
 correlations that are lost in the individual particle entries.
 <<Particles: public>>=
   public :: particle_set_t
 <<Particles: types>>=
   type :: particle_set_t
-     ! private !!! 
+     ! private !!!
      integer :: n_beam = 0
      integer :: n_in  = 0
      integer :: n_vir = 0
      integer :: n_out = 0
      integer :: n_tot = 0
      integer :: factorization_mode = FM_IGNORE_HELICITY
      type(particle_t), dimension(:), allocatable :: prt
      type(state_matrix_t) :: correlated_state
    contains
    <<Particles: particle set: TBP>>
   end type particle_set_t
 
 @ %def particle_set_t
 @ A particle set can be initialized from an interaction or from a
 HepMC event record.
 <<Particles: particle set: TBP>>=
   generic :: init => init_interaction
   procedure :: init_interaction => particle_set_init_interaction
 @ When a particle set is initialized from a given interaction, we have
 to determine the branch within the original state matrix that fixes
 the particle quantum numbers.  This is done with the appropriate
 probabilities, based on a random number [[x]].  The [[mode]]
 determines whether the individual particles become unpolarized, or
 take a definite (diagonal) helicity, or acquire single-particle
 polarization matrices.  The flag [[keep_correlations]] tells whether
 the spin-correlation matrix is to be calculated and stored in addition
 to the particles.  The flag [[keep_virtual]] tells whether virtual
 particles should be dropped.  Note that if virtual particles are
 dropped, the spin-correlation matrix makes no sense, and parent-child
 relations are not set.
 
 For a correct disentangling of color and flavor (in the presence of
 helicity), we consider two interactions.  [[int]] has no color
 information, and is used to select a flavor state.  Consequently, we
 trace over helicities here.  [[int_flows]] contains color-flow and
 potentially helicity information, but is useful only after the flavor
 combination has been chosen.  So this interaction is used to select
 helicity and color, but restricted to the selected flavor combination.
 
 [[int]] and [[int_flows]] may be identical if there is only a single
 (or no) color flow.  If there is just a single flavor combination,
 [[x(1)]] can be set to zero.
 
 The current algorithm of evaluator convolution requires that the beam
 particles are assumed outgoing (in the beam interaction) and become
 virtual in all derived interactions.  In the particle set they should
 be re-identified as incoming.  The optional integer [[n_incoming]]
 can be used to perform this correction.
 
 The flag [[is_valid]] is false if factorization of the state is not
 possible, in particular if the squared matrix element is zero.
 <<Particles: procedures>>=
   subroutine particle_set_init_interaction &
        (particle_set, is_valid, int, int_flows, mode, x, &
         keep_correlations, keep_virtual, n_incoming, qn_select)
     class(particle_set_t), intent(out) :: particle_set
     logical, intent(out) :: is_valid
     type(interaction_t), intent(in), target :: int, int_flows
     integer, intent(in) :: mode
     real(default), dimension(2), intent(in) :: x
     logical, intent(in) :: keep_correlations, keep_virtual
     integer, intent(in), optional :: n_incoming
     type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select
     type(state_matrix_t), dimension(:), allocatable, target :: flavor_state
     type(state_matrix_t), dimension(:), allocatable, target :: single_state
     integer :: n_in, n_vir, n_out, n_tot
     type(quantum_numbers_t), dimension(:,:), allocatable :: qn
     logical :: ok
     integer :: i, j
     if (present (n_incoming)) then
        n_in  = n_incoming
        n_vir = int%get_n_vir () - n_incoming
     else
        n_in  = int%get_n_in  ()
        n_vir = int%get_n_vir ()
     end if
     n_out = int%get_n_out ()
     n_tot = int%get_n_tot ()
     particle_set%n_in  = n_in
     particle_set%n_out = n_out
     if (keep_virtual) then
        particle_set%n_vir = n_vir
        particle_set%n_tot = n_tot
     else
        particle_set%n_vir = 0
        particle_set%n_tot = n_in + n_out
     end if
     particle_set%factorization_mode = mode
     allocate (qn (n_tot, 1))
     if (.not. present (qn_select)) then
        call int%factorize &
             (FM_IGNORE_HELICITY, x(1), is_valid, flavor_state)
        do i = 1, n_tot
           qn(i,:) = flavor_state(i)%get_quantum_number (1)
        end do
     else
        do i = 1, n_tot
           qn(i,:) = qn_select(i)
        end do
        is_valid = .true.
     end if
     if (keep_correlations .and. keep_virtual) then
        call particle_set%correlated_state%final ()
        call int_flows%factorize (mode, x(2), ok, &
             single_state, particle_set%correlated_state, qn(:,1))
     else
        call int_flows%factorize (mode, x(2), ok, &
             single_state, qn_in=qn(:,1))
     end if
     is_valid = is_valid .and. ok
     allocate (particle_set%prt (particle_set%n_tot))
     j = 1
     do i = 1, n_tot
        if (i <= n_in) then
           call particle_set%prt(j)%init (single_state(i), PRT_INCOMING, mode)
           call particle_set%prt(j)%set_momentum (int%get_momentum (i))
        else if (i <= n_in + n_vir) then
           if (.not. keep_virtual)  cycle
           call particle_set%prt(j)%init &
                (single_state(i), PRT_VIRTUAL, mode)
           call particle_set%prt(j)%set_momentum (int%get_momentum (i))
        else
           call particle_set%prt(j)%init (single_state(i), PRT_OUTGOING, mode)
           call particle_set%prt(j)%set_momentum &
                (int%get_momentum (i), on_shell = .true.)
        end if
        if (keep_virtual) then
           call particle_set%prt(j)%set_children &
                (interaction_get_children (int, i))
           call particle_set%prt(j)%set_parents &
                (interaction_get_parents (int, i))
        end if
        j = j + 1
     end do
     if (keep_virtual) then
        call particle_set_resonance_flag &
             (particle_set%prt, int%get_resonance_flags ())
     end if
     if (allocated (flavor_state)) then
        do i = 1, size(flavor_state)
           call flavor_state(i)%final ()
        end do
     end if
     do i = 1, size(single_state)
        call single_state(i)%final ()
     end do
   end subroutine particle_set_init_interaction
 
 @ %def particle_set_init_interaction
 @ Duplicate generic binding, to make sure that assignment works as it should.
 <<Particles: particle set: TBP>>=
   generic :: assignment(=) => init_particle_set
   generic :: init => init_particle_set
   procedure :: init_particle_set => particle_set_init_particle_set
 <<Particles: procedures>>=
   subroutine particle_set_init_particle_set (pset_out, pset_in)
     class(particle_set_t), intent(out) :: pset_out
     type(particle_set_t), intent(in) :: pset_in
     integer :: i
     pset_out%n_beam = pset_in%n_beam
     pset_out%n_in   = pset_in%n_in
     pset_out%n_vir  = pset_in%n_vir
     pset_out%n_out  = pset_in%n_out
     pset_out%n_tot  = pset_in%n_tot
     pset_out%factorization_mode = pset_in%factorization_mode
     if (allocated (pset_in%prt)) then
        allocate (pset_out%prt (size (pset_in%prt)))
        do i = 1, size (pset_in%prt)
           pset_out%prt(i) = pset_in%prt(i)
        end do
     end if
     pset_out%correlated_state = pset_in%correlated_state
   end subroutine particle_set_init_particle_set
 
 @ %def particle_set_init_particle_set
 @ Manually set the model for the stored particles.
 <<Particles: particle set: TBP>>=
   procedure :: set_model => particle_set_set_model
 <<Particles: procedures>>=
   subroutine particle_set_set_model (particle_set, model)
     class(particle_set_t), intent(inout) :: particle_set
     class(model_data_t), intent(in), target :: model
     integer :: i
     do i = 1, particle_set%n_tot
        call particle_set%prt(i)%set_model (model)
     end do
     call particle_set%correlated_state%set_model (model)
   end subroutine particle_set_set_model
 
 @ %def particle_set_set_model
 @ Pointer components are hidden inside the particle polarization, and
 in the correlated state matrix.
 <<Particles: particle set: TBP>>=
   procedure :: final => particle_set_final
 <<Particles: procedures>>=
   subroutine particle_set_final (particle_set)
     class(particle_set_t), intent(inout) :: particle_set
     integer :: i
     if (allocated (particle_set%prt)) then
        do i = 1, size(particle_set%prt)
           call particle_set%prt(i)%final ()
        end do
        deallocate (particle_set%prt)
     end if
     call particle_set%correlated_state%final ()
   end subroutine particle_set_final
 
 @ %def particle_set_final
 @
 \subsection{Manual build}
 Basic initialization.  Just allocate with a given number of beam, incoming,
 virtual, and outgoing particles.
 <<Particles: particle set: TBP>>=
   procedure :: basic_init => particle_set_basic_init
 <<Particles: procedures>>=
   subroutine particle_set_basic_init (particle_set, n_beam, n_in, n_vir, n_out)
     class(particle_set_t), intent(out) :: particle_set
     integer, intent(in) :: n_beam, n_in, n_vir, n_out
     particle_set%n_beam = n_beam
     particle_set%n_in = n_in
     particle_set%n_vir = n_vir
     particle_set%n_out = n_out
     particle_set%n_tot = n_beam + n_in + n_vir + n_out
     allocate (particle_set%prt (particle_set%n_tot))
   end subroutine particle_set_basic_init
 
 @ %def particle_set_basic_init
 @
 Build a particle set from scratch.  This is used for testing
 purposes.  The ordering of particles in the result is
 beam-incoming-remnant-virtual-outgoing.
 
 Parent-child relations:
 \begin{itemize}
 \item
   Beams are parents of incoming and beam remnants.  The assignment is
   alternating (first beam, second beam).
 \item
   Incoming are parents of virtual and outgoing, collectively.
 \end{itemize}
 More specific settings, such as resonance histories, cannot be set
 this way.
 
 Beam-remnant particles are counted as virtual, but have a different
 status code.
 
 We assume that the [[pdg]] array has the correct size.
 <<Particles: particle set: TBP>>=
   procedure :: init_direct => particle_set_init_direct
 <<Particles: procedures>>=
   subroutine particle_set_init_direct (particle_set, &
        n_beam, n_in, n_rem, n_vir, n_out, pdg, model)
     class(particle_set_t), intent(out) :: particle_set
     integer, intent(in) :: n_beam
     integer, intent(in) :: n_in
     integer, intent(in) :: n_rem
     integer, intent(in) :: n_vir
     integer, intent(in) :: n_out
     integer, dimension(:), intent(in) :: pdg
     class(model_data_t), intent(in), target :: model
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i, k, n
     call particle_set%basic_init (n_beam, n_in, n_rem+n_vir, n_out)
     n = 0
     call particle_set%prt(n+1:n+n_beam)%reset_status (PRT_BEAM)
     do i = n+1, n+n_beam
        call particle_set%prt(i)%set_children &
             ([(k, k=i+n_beam, n+n_beam+n_in+n_rem, 2)])
     end do
     n = n + n_beam
     call particle_set%prt(n+1:n+n_in)%reset_status (PRT_INCOMING)
     do i = n+1, n+n_in
        if (n_beam > 0) then
           call particle_set%prt(i)%set_parents &
                ([i-n_beam])
        end if
        call particle_set%prt(i)%set_children &
             ([(k, k=n+n_in+n_rem+1, n+n_in+n_rem+n_vir+n_out)])
     end do
     n = n + n_in
     call particle_set%prt(n+1:n+n_rem)%reset_status (PRT_BEAM_REMNANT)
     do i = n+1, n+n_rem
        if (n_beam > 0) then
           call particle_set%prt(i)%set_parents &
                ([i-n_in-n_beam])
        end if
     end do
     n = n + n_rem
     call particle_set%prt(n+1:n+n_vir)%reset_status (PRT_VIRTUAL)
     do i = n+1, n+n_vir
        call particle_set%prt(i)%set_parents &
             ([(k, k=n-n_rem-n_in+1, n-n_rem)])
     end do
     n = n + n_vir
     call particle_set%prt(n+1:n+n_out)%reset_status (PRT_OUTGOING)
     do i = n+1, n+n_out
        call particle_set%prt(i)%set_parents &
             ([(k, k=n-n_vir-n_rem-n_in+1, n-n_vir-n_rem)])
     end do
     allocate (flv (particle_set%n_tot))
     call flv%init (pdg, model)
     do k = n_beam+n_in+1, n_beam+n_in+n_rem
        call flv(k)%tag_radiated ()
     end do
     do i = 1, particle_set%n_tot
        call particle_set%prt(i)%set_flavor (flv(i))
     end do
   end subroutine particle_set_init_direct
 
 @ %def particle_set_init_direct
 @ Copy a particle set into a new, extended one.  Use the mapping array to
 determine the new positions of particles.  The new set contains [[n_new]]
 additional entries.  Count the new, undefined particles as
 virtual.
 <<Particles: particle set: TBP>>=
   procedure :: transfer => particle_set_transfer
 <<Particles: procedures>>=
   subroutine particle_set_transfer (pset, source, n_new, map)
     class(particle_set_t), intent(out) :: pset
     class(particle_set_t), intent(in) :: source
     integer, intent(in) :: n_new
     integer, dimension(:), intent(in) :: map
     integer :: i
     call pset%basic_init &
          (source%n_beam, source%n_in, source%n_vir + n_new, source%n_out)
     pset%factorization_mode = source%factorization_mode
     do i = 1, source%n_tot
        call pset%prt(map(i))%reset_status (source%prt(i)%get_status ())
        call pset%prt(map(i))%set_flavor (source%prt(i)%get_flv ())
        call pset%prt(map(i))%set_color (source%prt(i)%get_col ())
        call pset%prt(map(i))%set_parents (map (source%prt(i)%get_parents ()))
        call pset%prt(map(i))%set_children (map (source%prt(i)%get_children ()))
        call pset%prt(map(i))%set_polarization &
             (source%prt(i)%get_polarization_status ())
        select case (source%prt(i)%get_polarization_status ())
        case (PRT_DEFINITE_HELICITY)
           call pset%prt(map(i))%set_helicity (source%prt(i)%get_hel ())
        case (PRT_GENERIC_POLARIZATION)
           call pset%prt(map(i))%set_pol (source%prt(i)%get_polarization ())
        end select
     end do
   end subroutine particle_set_transfer
-  
+
 @ %def particle_set_transfer
 @ Insert a new particle as an intermediate into a previously empty position.
 
 Flavor and status are just set.  Color is not set (but see below).
 The complicated part is reassigning parent-child relations.  The
 inserted particle comes with an array [[child]] of its children which
 are supposed to be existing particles.
 
 We first scan all particles that come before the new insertion.
 Whenever a particle has children that coincide with the children of
 the new particle, those child entries are removed.  (a) If the new
 particle has no parent entry yet, those child entries are replaced by
 the index of the new particle and simultaneously, the particle is
 registered as a parent of the new particle.  (b) If the current particle
 already has a parent entry, those child entries are removed.
 
 When this is done, the new particle is registered as the (only) parent of its
 children.
 <<Particles: particle set: TBP>>=
   procedure :: insert => particle_set_insert
 <<Particles: procedures>>=
   subroutine particle_set_insert (pset, i, status, flv, child)
     class(particle_set_t), intent(inout) :: pset
     integer, intent(in) :: i
     integer, intent(in) :: status
     type(flavor_t), intent(in) :: flv
     integer, dimension(:), intent(in) :: child
     integer, dimension(:), allocatable :: p_child, parent
     integer :: j, k, c, n_parent
     logical :: no_match
     call pset%prt(i)%reset_status (status)
     call pset%prt(i)%set_flavor (flv)
     call pset%prt(i)%set_children (child)
     n_parent = pset%prt(i)%get_n_parents ()
     do j = 1, i - 1
        p_child = pset%prt(j)%get_children ()
        no_match = .true.
        do k = 1, size (p_child)
           if (any (p_child(k) == child)) then
              if (n_parent == 0 .and. no_match) then
                 if (.not. allocated (parent)) then
                    parent = [j]
                 else
                    parent = [parent, j]
                 end if
                 p_child(k) = i
              else
                 p_child(k) = 0
              end if
              no_match = .false.
           end if
        end do
        if (.not. no_match) then
           p_child = pack (p_child, p_child /= 0)
           call pset%prt(j)%set_children (p_child)
        end if
     end do
     if (n_parent == 0) then
        call pset%prt(i)%set_parents (parent)
     end if
     do j = 1, size (child)
        c = child(j)
        call pset%prt(c)%set_parents ([i])
     end do
   end subroutine particle_set_insert
-  
+
 @ %def particle_set_insert
 @ This should be done after completing all insertions: recover color
 assignments for the inserted particles, working backwards from
 children to parents.  A single call to the routine recovers the color
 and anticolor line indices for a single particle.
 <<Particles: particle set: TBP>>=
   procedure :: recover_color => particle_set_recover_color
 <<Particles: procedures>>=
   subroutine particle_set_recover_color (pset, i)
     class(particle_set_t), intent(inout) :: pset
     integer, intent(in) :: i
     type(color_t) :: col
     integer, dimension(:), allocatable :: child
     integer :: j
     child = pset%prt(i)%get_children ()
     if (size (child) > 0) then
        col = pset%prt(child(1))%get_col ()
        do j = 2, size (child)
           col = col .fuse. pset%prt(child(j))%get_col ()
        end do
        call pset%prt(i)%set_color (col)
     end if
   end subroutine particle_set_recover_color
 
 @ %def particle_set_recover_color
 @
 \subsection{Extract/modify contents}
 <<Particles: particle set: TBP>>=
   generic :: get_color => get_color_all
   generic :: get_color => get_color_indices
   procedure :: get_color_all => particle_set_get_color_all
   procedure :: get_color_indices => particle_set_get_color_indices
 <<Particles: procedures>>=
   function particle_set_get_color_all (particle_set) result (col)
     class(particle_set_t), intent(in) :: particle_set
     type(color_t), dimension(:), allocatable :: col
     allocate (col (size (particle_set%prt)))
     col = particle_set%prt%col
   end function particle_set_get_color_all
 
 @ %def particle_set_get_color_all
 @
 <<Particles: procedures>>=
   function particle_set_get_color_indices (particle_set, indices) result (col)
      type(color_t), dimension(:), allocatable :: col
      class(particle_set_t), intent(in) :: particle_set
      integer, intent(in), dimension(:), allocatable :: indices
      integer :: i
      allocate (col (size (indices)))
      do i = 1, size (indices)
         col(i) = particle_set%prt(indices(i))%col
      end do
   end function particle_set_get_color_indices
 
 @ %def particle_set_get_color_indices
 @ Set a single or all color components.  This is a wrapper around the
 corresponding [[particle_t]] method, with the same options.  We assume
 that the particle array is allocated.
 <<Particles: particle set: TBP>>=
   generic :: set_color => set_color_single
   generic :: set_color => set_color_indices
   generic :: set_color => set_color_all
   procedure :: set_color_single => particle_set_set_color_single
   procedure :: set_color_indices => particle_set_set_color_indices
   procedure :: set_color_all => particle_set_set_color_all
 <<Particles: procedures>>=
   subroutine particle_set_set_color_single (particle_set, i, col)
     class(particle_set_t), intent(inout) :: particle_set
     integer, intent(in) :: i
     type(color_t), intent(in) :: col
     call particle_set%prt(i)%set_color (col)
   end subroutine particle_set_set_color_single
 
   subroutine particle_set_set_color_indices (particle_set, indices, col)
     class(particle_set_t), intent(inout) :: particle_set
     integer, dimension(:), intent(in) :: indices
     type(color_t), dimension(:), intent(in) :: col
     integer :: i
     do i = 1, size (indices)
        call particle_set%prt(indices(i))%set_color (col(i))
     end do
   end subroutine particle_set_set_color_indices
 
   subroutine particle_set_set_color_all (particle_set, col)
     class(particle_set_t), intent(inout) :: particle_set
     type(color_t), dimension(:), intent(in) :: col
     call particle_set%prt%set_color (col)
   end subroutine particle_set_set_color_all
 
 @ %def particle_set_set_color
 @ Assigning particles manually may result in color mismatches.  This is
 checked here for all particles in the set.  The color object is
 compared against the color type that belongs to the flavor object.
 The return value is an allocatable array which consists of the particles
 with invalid color assignments.  If the array size is zero, all is fine.
 <<Particles: particle set: TBP>>=
   procedure :: find_prt_invalid_color => particle_set_find_prt_invalid_color
 <<Particles: procedures>>=
   subroutine particle_set_find_prt_invalid_color (particle_set, index, prt)
     class(particle_set_t), intent(in) :: particle_set
     integer, dimension(:), allocatable, intent(out) :: index
     type(particle_t), dimension(:), allocatable, intent(out), optional :: prt
     type(flavor_t) :: flv
     type(color_t) :: col
     logical, dimension(:), allocatable :: mask
     integer :: i, n, n_invalid
     n = size (particle_set%prt)
     allocate (mask (n))
     do i = 1, n
        associate (prt => particle_set%prt(i))
          flv = prt%get_flv ()
          col = prt%get_col ()
          mask(i) = flv%get_color_type () /= col%get_type ()
        end associate
     end do
     index = pack ([(i, i = 1, n)], mask)
     if (present (prt))  prt = pack (particle_set%prt, mask)
   end subroutine particle_set_find_prt_invalid_color
-  
+
 @ %def particle_set_find_prt_invalid_color
-@ 
+@
 <<Particles: particle set: TBP>>=
   generic :: get_momenta => get_momenta_all
   generic :: get_momenta => get_momenta_indices
   procedure :: get_momenta_all => particle_set_get_momenta_all
   procedure :: get_momenta_indices => particle_set_get_momenta_indices
 <<Particles: procedures>>=
   function particle_set_get_momenta_all (particle_set) result (p)
     class(particle_set_t), intent(in) :: particle_set
     type(vector4_t), dimension(:), allocatable :: p
     allocate (p (size (particle_set%prt)))
     p = particle_set%prt%p
   end function particle_set_get_momenta_all
 
 @ %def particle_set_get_momenta_all
 @
 <<Particles: procedures>>=
   function particle_set_get_momenta_indices (particle_set, indices) result (p)
      type(vector4_t), dimension(:), allocatable :: p
      class(particle_set_t), intent(in) :: particle_set
      integer, intent(in), dimension(:), allocatable :: indices
      integer :: i
      allocate (p (size (indices)))
      do i = 1, size (indices)
         p(i) = particle_set%prt(indices(i))%p
      end do
   end function particle_set_get_momenta_indices
 
 @ %def particle_set_get_momenta_indices
 @ Replace a single or all momenta.  This is a wrapper around the
 corresponding [[particle_t]] method, with the same options.  We assume
 that the particle array is allocated.
 <<Particles: particle set: TBP>>=
   generic :: set_momentum => set_momentum_single
   generic :: set_momentum => set_momentum_indices
   generic :: set_momentum => set_momentum_all
   procedure :: set_momentum_single => particle_set_set_momentum_single
   procedure :: set_momentum_indices => particle_set_set_momentum_indices
   procedure :: set_momentum_all => particle_set_set_momentum_all
 <<Particles: procedures>>=
   subroutine particle_set_set_momentum_single &
        (particle_set, i, p, p2, on_shell)
     class(particle_set_t), intent(inout) :: particle_set
     integer, intent(in) :: i
     type(vector4_t), intent(in) :: p
     real(default), intent(in), optional :: p2
     logical, intent(in), optional :: on_shell
     call particle_set%prt(i)%set_momentum (p, p2, on_shell)
   end subroutine particle_set_set_momentum_single
 
   subroutine particle_set_set_momentum_indices &
        (particle_set, indices, p, p2, on_shell)
     class(particle_set_t), intent(inout) :: particle_set
     integer, dimension(:), intent(in) :: indices
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), dimension(:), intent(in), optional :: p2
     logical, intent(in), optional :: on_shell
     integer :: i
     if (present (p2)) then
        do i = 1, size (indices)
           call particle_set%prt(indices(i))%set_momentum (p(i), p2(i), on_shell)
        end do
     else
        do i = 1, size (indices)
           call particle_set%prt(indices(i))%set_momentum &
                (p(i), on_shell=on_shell)
        end do
     end if
   end subroutine particle_set_set_momentum_indices
 
   subroutine particle_set_set_momentum_all (particle_set, p, p2, on_shell)
     class(particle_set_t), intent(inout) :: particle_set
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), dimension(:), intent(in), optional :: p2
     logical, intent(in), optional :: on_shell
     call particle_set%prt%set_momentum (p, p2, on_shell)
   end subroutine particle_set_set_momentum_all
 
 @ %def particle_set_set_momentum
 @ Recover a momentum by recombining from children, assuming that this
 is possible.  The reconstructed momentum is not projected on-shell.
 <<Particles: particle set: TBP>>=
   procedure :: recover_momentum => particle_set_recover_momentum
 <<Particles: procedures>>=
   subroutine particle_set_recover_momentum (particle_set, i)
     class(particle_set_t), intent(inout) :: particle_set
     integer, intent(in) :: i
     type(vector4_t), dimension(:), allocatable :: p
     integer, dimension(:), allocatable :: index
     index = particle_set%prt(i)%get_children ()
     p = particle_set%get_momenta (index)
     call particle_set%set_momentum (i, sum (p))
   end subroutine particle_set_recover_momentum
-  
+
 @ %def particle_set_recover_momentum
 @
 <<Particles: particle set: TBP>>=
   procedure :: replace_incoming_momenta => particle_set_replace_incoming_momenta
 <<Particles: procedures>>=
   subroutine particle_set_replace_incoming_momenta (particle_set, p)
     class(particle_set_t), intent(inout) :: particle_set
     type(vector4_t), intent(in), dimension(:) :: p
     integer :: i, j
     i = 1
     do j = 1, particle_set%get_n_tot ()
        if (particle_set%prt(j)%get_status () == PRT_INCOMING) then
           particle_set%prt(j)%p = p(i)
           i = i + 1
           if (i > particle_set%n_in) exit
        end if
     end do
   end subroutine particle_set_replace_incoming_momenta
 
 @ %def particle_set_replace_incoming_momenta
 @
 <<Particles: particle set: TBP>>=
   procedure :: replace_outgoing_momenta => particle_set_replace_outgoing_momenta
 <<Particles: procedures>>=
   subroutine particle_set_replace_outgoing_momenta (particle_set, p)
     class(particle_set_t), intent(inout) :: particle_set
     type(vector4_t), intent(in), dimension(:) :: p
     integer :: i, j
     i = particle_set%n_in + 1
     do j = 1, particle_set%n_tot
        if (particle_set%prt(j)%get_status () == PRT_OUTGOING) then
           particle_set%prt(j)%p = p(i)
           i = i + 1
        end if
     end do
   end subroutine particle_set_replace_outgoing_momenta
 
 @ %def particle_set_replace_outgoing_momenta
-@ 
+@
 <<Particles: particle set: TBP>>=
   procedure :: get_outgoing_momenta => particle_set_get_outgoing_momenta
 <<Particles: procedures>>=
   function particle_set_get_outgoing_momenta (particle_set) result (p)
     class(particle_set_t), intent(in) :: particle_set
     type(vector4_t), dimension(:), allocatable :: p
     integer :: i, k
     allocate (p (count (particle_set%prt%get_status () == PRT_OUTGOING)))
     k = 0
     do i = 1, size (particle_set%prt)
        if (particle_set%prt(i)%get_status () == PRT_OUTGOING) then
           k = k + 1
           p(k) = particle_set%prt(i)%get_momentum ()
        end if
     end do
   end function particle_set_get_outgoing_momenta
 
 @ %def particle_set_get_outgoing_momenta
 @
 <<Particles: particle set: TBP>>=
   procedure :: parent_add_child => particle_set_parent_add_child
 <<Particles: procedures>>=
   subroutine particle_set_parent_add_child (particle_set, parent, child)
     class(particle_set_t), intent(inout) :: particle_set
     integer, intent(in) :: parent, child
     call particle_set%prt(child)%set_parents ([parent])
     call particle_set%prt(parent)%add_child (child)
   end subroutine particle_set_parent_add_child
 
 @ %def particle_set_parent_add_child
 @ Given the [[particle_set]] before radiation, the new momenta
 [[p_radiated]], the [[emitter]] and the [[flv_radiated]] as well as the
 [[model]] and a random number [[r_color]] for chosing a color, we update
 the [[particle_set]].
 <<Particles: particle set: TBP>>=
   procedure :: build_radiation => particle_set_build_radiation
 <<Particles: procedures>>=
   subroutine particle_set_build_radiation (particle_set, p_radiated, &
      emitter, flv_radiated, model, r_color)
      class(particle_set_t), intent(inout) :: particle_set
      type(vector4_t), intent(in), dimension(:) :: p_radiated
      integer, intent(in) :: emitter
      integer, intent(in), dimension(:) :: flv_radiated
      class(model_data_t), intent(in), target :: model
      real(default), intent(in) :: r_color
      type(particle_set_t) :: new_particle_set
      type(particle_t) :: new_particle
      integer :: i
      integer :: pdg_index_emitter, pdg_index_radiation
      integer, dimension(:), allocatable :: parents, children
      type(flavor_t) :: new_flv
      logical, dimension(:), allocatable :: status_mask
      integer, dimension(:), allocatable :: &
           i_in1, i_beam1, i_remnant1, i_virt1, i_out1
      integer, dimension(:), allocatable :: &
           i_in2, i_beam2, i_remnant2, i_virt2, i_out2
      integer :: n_in1, n_beam1, n_remnant1, n_virt1, n_out1
      integer :: n_in2, n_beam2, n_remnant2, n_virt2, n_out2
      integer :: n, n_tot
      integer :: i_emitter
 
      n = particle_set%get_n_tot ()
      allocate (status_mask (n))
      do i = 1, n
         status_mask(i) = particle_set%prt(i)%get_status () == PRT_INCOMING
      end do
      n_in1 = count (status_mask)
      allocate (i_in1 (n_in1))
      i_in1 = particle_set%get_indices (status_mask)
      do i = 1, n
         status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM
      end do
      n_beam1 = count (status_mask)
      allocate (i_beam1 (n_beam1))
      i_beam1 = particle_set%get_indices (status_mask)
      do i = 1, n
         status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM_REMNANT
      end do
      n_remnant1 = count (status_mask)
      allocate (i_remnant1 (n_remnant1))
      i_remnant1 = particle_set%get_indices (status_mask)
      do i = 1, n
         status_mask(i) = particle_set%prt(i)%get_status () == PRT_VIRTUAL
      end do
      n_virt1 = count (status_mask)
      allocate (i_virt1 (n_virt1))
      i_virt1 = particle_set%get_indices (status_mask)
      do i = 1, n
         status_mask(i) = particle_set%prt(i)%get_status () == PRT_OUTGOING
      end do
      n_out1 = count (status_mask)
      allocate (i_out1 (n_out1))
      i_out1 = particle_set%get_indices (status_mask)
 
      n_in2 = n_in1; n_beam2 = n_beam1; n_remnant2 = n_remnant1
      n_virt2 = n_virt1 + n_out1
      n_out2 = n_out1 + 1
      n_tot = n_in2 + n_beam2 + n_remnant2 + n_virt2 + n_out2
 
      allocate (i_in2 (n_in2), i_beam2 (n_beam2), i_remnant2 (n_remnant2))
      i_in2 = i_in1; i_beam2 = i_beam1; i_remnant2 = i_remnant1
 
      allocate (i_virt2 (n_virt2))
      i_virt2(1 : n_virt1) = i_virt1
      i_virt2(n_virt1 + 1 : n_virt2) = i_out1
 
      allocate (i_out2 (n_out2))
      i_out2(1 : n_out1) = i_out1(1 : n_out1) + n_out1
      i_out2(n_out2) = n_tot
 
      new_particle_set%n_beam = n_beam2
      new_particle_set%n_in = n_in2
      new_particle_set%n_vir = n_virt2
      new_particle_set%n_out = n_out2
      new_particle_set%n_tot = n_tot
      new_particle_set%correlated_state = particle_set%correlated_state
      allocate (new_particle_set%prt (n_tot))
      if (size (i_beam1) > 0) new_particle_set%prt(i_beam2) = particle_set%prt(i_beam1)
      if (size (i_remnant1) > 0) new_particle_set%prt(i_remnant2) = particle_set%prt(i_remnant1)
      do i = 1, n_virt1
         new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_virt1(i))
      end do
 
      do i = n_virt1 + 1, n_virt2
         new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_out1(i - n_virt1))
         call new_particle_set%prt(i_virt2(i))%reset_status (PRT_VIRTUAL)
      end do
 
      do i = 1, n_in2
         new_particle_set%prt(i_in2(i)) = particle_set%prt(i_in1(i))
         new_particle_set%prt(i_in2(i))%p = p_radiated (i)
      end do
 
      do i = 1, n_out2 - 1
         new_particle_set%prt(i_out2(i)) = particle_set%prt(i_out1(i))
         new_particle_set%prt(i_out2(i))%p = p_radiated(i + n_in2)
         call new_particle_set%prt(i_out2(i))%reset_status (PRT_OUTGOING)
      end do
 
      call new_particle%reset_status (PRT_OUTGOING)
      call new_particle%set_momentum (p_radiated (n_in2 + n_out2))
 
      !!! Helicity and polarization handling is missing at this point
      !!! Also, no helicities or polarizations yet
      pdg_index_emitter = flv_radiated (emitter)
      pdg_index_radiation = flv_radiated (n_in2 + n_out2)
      call new_flv%init (pdg_index_radiation, model)
      i_emitter = emitter + n_virt2 + n_remnant2 + n_beam2
 
      call reassign_colors (new_particle, new_particle_set%prt(i_emitter), &
         pdg_index_radiation, pdg_index_emitter, r_color)
 
      call new_particle%set_flavor (new_flv)
      new_particle_set%prt(n_tot) = new_particle
 
      allocate (children (n_out2))
      children = i_out2
      do i = n_in2 + n_beam2 + n_remnant2 + n_virt1 + 1, n_in2 + n_beam2 + n_remnant2 + n_virt2
         call new_particle_set%prt(i)%set_children (children)
      end do
 
      !!! Set proper parents for outgoing particles
      allocate (parents (n_out1))
      parents = i_out1
      do i = n_in2 + n_beam2 + n_remnant2 + n_virt2 + 1, n_tot
         call new_particle_set%prt(i)%set_parents (parents)
      end do
      call particle_set%init (new_particle_set)
   contains
 
     <<build radiation: set color offset>>
     subroutine reassign_colors (prt_radiated, prt_emitter, i_rad, i_em, r_col)
       type(particle_t), intent(inout) :: prt_radiated, prt_emitter
       integer, intent(in) :: i_rad, i_em
       real(default), intent(in) :: r_col
       type(color_t) :: col_rad, col_em
       if (is_quark (i_em) .and. is_gluon (i_rad)) then
          call reassign_colors_qg (prt_emitter, col_rad, col_em)
       else if (is_gluon (i_em) .and. is_gluon (i_rad)) then
          call reassign_colors_gg (prt_emitter, r_col, col_rad, col_em)
       else if (is_gluon (i_em) .and. is_quark (i_rad)) then
          call reassign_colors_qq (prt_emitter, i_em, col_rad, col_em)
       else
          call msg_fatal ("Invalid splitting")
       end if
       call prt_emitter%set_color (col_em)
       call prt_radiated%set_color (col_rad)
     end subroutine reassign_colors
 
     subroutine reassign_colors_qg (prt_emitter, col_rad, col_em)
       type(particle_t), intent(in) :: prt_emitter
       type(color_t), intent(out) :: col_rad, col_em
       integer, dimension(2) :: color_rad, color_em
       integer :: i1, i2
       integer :: new_color_index
       logical :: is_anti_quark
 
       color_em = prt_emitter%get_color ()
       i1 = 1; i2 = 2
       is_anti_quark = color_em(2) /= 0
       if (is_anti_quark) then
          i1 = 2; i2 = 1
       end if
       new_color_index = color_em(i1)+1
       color_rad(i1) = color_em(i1)
       color_rad(i2) = new_color_index
       color_em(i1) = new_color_index
       call col_em%init_col_acl (color_em(1), color_em(2))
       call col_rad%init_col_acl (color_rad(1), color_rad(2))
     end subroutine reassign_colors_qg
 
     subroutine reassign_colors_gg (prt_emitter, random, col_rad, col_em)
       !!! NOT TESTED YET
       type(particle_t), intent(in) :: prt_emitter
       real(default), intent(in) :: random
       type(color_t), intent(out) :: col_rad, col_em
       integer, dimension(2) :: color_rad, color_em
       integer :: i1, i2
       integer :: new_color_index
 
       color_em = prt_emitter%get_color ()
       new_color_index = maxval (abs (color_em))
       i1 = 1; i2 = 2
       if (random < 0.5) then
          i1 = 2; i2 = 1
       end if
       color_rad(i1) = new_color_index
       color_rad(i2) = color_em(i2)
       color_em(i2) = new_color_index
       call col_em%init_col_acl (color_em(1), color_em(2))
       call col_rad%init_col_acl (color_rad(1), color_rad(2))
     end subroutine reassign_colors_gg
 
     subroutine reassign_colors_qq (prt_emitter, pdg_emitter, col_rad, col_em)
       !!! NOT TESTED YET
       type(particle_t), intent(in) :: prt_emitter
       integer, intent(in) :: pdg_emitter
       type(color_t), intent(out) :: col_rad, col_em
       integer, dimension(2) :: color_rad, color_em
       integer :: i1, i2
       logical :: is_anti_quark
 
       color_em = prt_emitter%get_color ()
       i1 = 1; i2 = 2
       is_anti_quark = pdg_emitter < 0
       if (is_anti_quark) then
          i1 = 2; i1 = 1
       end if
       color_em(i2) = 0
       color_rad(i1) = 0
       color_rad(i2) = color_em(i1)
       call col_em%init_col_acl (color_em(1), color_em(2))
       call col_rad%init_col_acl (color_rad(1), color_rad(2))
     end subroutine reassign_colors_qq
   end subroutine particle_set_build_radiation
 
 @ %def particle_set_build_radiation
 @ Increments the color indices of all particles by their maximal value to distinguish them
 from the record-keeping Born particles in the LHE-output if the virtual entries are kept.
 <<build radiation: set color offset>>=
   subroutine set_color_offset (particle_set)
     type(particle_set_t), intent(inout) :: particle_set
     integer, dimension(2) :: color
     integer :: i, i_color_max
     type(color_t) :: new_color
 
     i_color_max = 0
     do i = 1, size (particle_set%prt)
        associate (prt => particle_set%prt(i))
           if (prt%get_status () <= PRT_INCOMING) cycle
           color = prt%get_color ()
           i_color_max = maxval([i_color_max, color(1), color(2)])
        end associate
     end do
 
 
     do i = 1, size (particle_set%prt)
        associate (prt => particle_set%prt(i))
           if (prt%get_status () /= PRT_OUTGOING) cycle
           color = prt%get_color ()
           where (color /= 0) color = color + i_color_max
           call new_color%init_col_acl (color(1), color(2))
           call prt%set_color (new_color)
        end associate
     end do
   end subroutine set_color_offset
 
 @ %def set_color_offset
 @ Output (default format)
 <<Particles: particle set: TBP>>=
   procedure :: write => particle_set_write
 <<Particles: procedures>>=
   subroutine particle_set_write &
     (particle_set, unit, testflag, summary, compressed)
     class(particle_set_t), intent(in) :: particle_set
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag, summary, compressed
     logical :: summ, comp, pol
     type(vector4_t) :: sum_vec
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     summ = .false.; if (present (summary)) summ = summary
     comp = .false.; if (present (compressed)) comp = compressed
     pol = particle_set%factorization_mode /= FM_IGNORE_HELICITY
     write (u, "(1x,A)") "Particle set:"
     call write_separator (u)
     if (comp) then
        if (pol) then
           write (u, &
                "((A4,1X),(A6,1X),(A7,1X),(A3),2(A4,1X),2(A20,1X),5(A12,1X))") &
                "Nr", "Status", "Flavor", "Hel", "Col", "ACol", &
                "Parents", "Children", &
                "P(0)", "P(1)", "P(2)", "P(3)", "P^2"
        else
           write (u, &
                "((A4,1X),(A6,1X),(A7,1X),2(A4,1X),2(A20,1X),5(A12,1X))") &
                "Nr", "Status", "Flavor", "Col", "ACol", &
                "Parents", "Children", &
                "P(0)", "P(1)", "P(2)", "P(3)", "P^2"
        end if
     end if
     if (particle_set%n_tot /= 0) then
        do i = 1, particle_set%n_tot
           if (comp) then
              write (u, "(I4,1X,2X)", advance="no") i
           else
              write (u, "(1x,A,1x,I0)", advance="no") "Particle", i
           end if
           call particle_set%prt(i)%write (u, testflag = testflag, &
                compressed = comp, polarization = pol)
        end do
        if (particle_set%correlated_state%is_defined ()) then
           call write_separator (u)
           write (u, *) "Correlated state density matrix:"
           call particle_set%correlated_state%write (u)
        end if
        if (summ) then
           call write_separator (u)
           write (u, "(A)", advance="no") &
                "Sum of incoming momenta: p(0:3) =     "
           sum_vec = sum (particle_set%prt%p, &
                mask=particle_set%prt%get_status () == PRT_INCOMING)
           call pacify (sum_vec, tolerance = 1E-3_default)
           call sum_vec%write (u, compressed=.true.)
           write (u, *)
           write (u, "(A)", advance="no") &
                "Sum of beam remnant momenta: p(0:3) = "
           sum_vec = sum (particle_set%prt%p, &
                mask=particle_set%prt%get_status () == PRT_BEAM_REMNANT)
           call pacify (sum_vec, tolerance = 1E-3_default)
           call sum_vec%write (u, compressed=.true.)
           write (u, *)
           write (u, "(A)", advance="no") &
                "Sum of outgoing momenta: p(0:3) =     "
           sum_vec = sum (particle_set%prt%p, &
                mask=particle_set%prt%get_status () == PRT_OUTGOING)
           call pacify (sum_vec, tolerance = 1E-3_default)
           call sum_vec%write (u, compressed=.true.)
           write (u, "(A)") ""
        end if
     else
        write (u, "(3x,A)") "[empty]"
     end if
   end subroutine particle_set_write
 
 @ %def particle_set_write
 @
 \subsection{I/O formats}
 Here, we define input/output of particle sets in various formats.
 This is the right place since particle sets contain most of the event
 information.
 
 All write/read routines take as first argument the object, as second
 argument the I/O unit which in this case is a mandatory argument.
 Then follow further event data.
 
 \subsubsection{Internal binary format}
 This format is supposed to contain the complete information, so
 the particle data set can be fully reconstructed.  The exception is
 the model part of the particle flavors; this is unassigned for the
 flavor values read from file.
 <<Particles: particle set: TBP>>=
   procedure :: write_raw => particle_set_write_raw
   procedure :: read_raw => particle_set_read_raw
 <<Particles: procedures>>=
   subroutine particle_set_write_raw (particle_set, u)
     class(particle_set_t), intent(in) :: particle_set
     integer, intent(in) :: u
     integer :: i
     write (u) &
          particle_set%n_beam, particle_set%n_in, &
          particle_set%n_vir, particle_set%n_out
     write (u) particle_set%factorization_mode
     write (u) particle_set%n_tot
     do i = 1, particle_set%n_tot
        call particle_set%prt(i)%write_raw (u)
     end do
     call particle_set%correlated_state%write_raw (u)
   end subroutine particle_set_write_raw
 
   subroutine particle_set_read_raw (particle_set, u, iostat)
     class(particle_set_t), intent(out) :: particle_set
     integer, intent(in) :: u
     integer, intent(out) :: iostat
     integer :: i
     read (u, iostat=iostat) &
          particle_set%n_beam, particle_set%n_in, &
          particle_set%n_vir, particle_set%n_out
     read (u, iostat=iostat) particle_set%factorization_mode
     read (u, iostat=iostat) particle_set%n_tot
     allocate (particle_set%prt (particle_set%n_tot))
     do i = 1, size (particle_set%prt)
        call particle_set%prt(i)%read_raw (u, iostat=iostat)
     end do
     call particle_set%correlated_state%read_raw (u, iostat=iostat)
   end subroutine particle_set_read_raw
 
 @ %def particle_set_write_raw particle_set_read_raw
 @
 \subsubsection{Get contents}
 Find parents/children of a particular particle recursively; the
 search terminates if a parent/child has status [[BEAM]], [[INCOMING]],
 [[OUTGOING]] or [[RESONANT]].
 <<Particles: particle set: TBP>>=
   procedure :: get_real_parents => particle_set_get_real_parents
   procedure :: get_real_children => particle_set_get_real_children
 <<Particles: procedures>>=
   function particle_set_get_real_parents (pset, i, keep_beams) result (parent)
     integer, dimension(:), allocatable :: parent
     class(particle_set_t), intent(in) :: pset
     integer, intent(in) :: i
     logical, intent(in), optional :: keep_beams
     logical, dimension(:), allocatable :: is_real
     logical, dimension(:), allocatable :: is_parent, is_real_parent
     logical :: kb
     integer :: j, k
     kb = .false.
     if (present (keep_beams)) kb = keep_beams
     allocate (is_real (pset%n_tot))
     is_real = pset%prt%is_real (kb)
     allocate (is_parent (pset%n_tot), is_real_parent (pset%n_tot))
     is_real_parent = .false.
     is_parent = .false.
     is_parent(pset%prt(i)%get_parents()) = .true.
     do while (any (is_parent))
        where (is_real .and. is_parent)
           is_real_parent = .true.
           is_parent = .false.
        end where
        mark_next_parent: do j = size (is_parent), 1, -1
           if (is_parent(j)) then
              is_parent(pset%prt(j)%get_parents()) = .true.
              is_parent(j) = .false.
              exit mark_next_parent
           end if
        end do mark_next_parent
     end do
     allocate (parent (count (is_real_parent)))
     j = 0
     do k = 1, size (is_parent)
        if (is_real_parent(k)) then
           j = j + 1
           parent(j) = k
        end if
     end do
   end function particle_set_get_real_parents
 
   function particle_set_get_real_children (pset, i, keep_beams) result (child)
     integer, dimension(:), allocatable :: child
     class(particle_set_t), intent(in) :: pset
     integer, intent(in) :: i
     logical, dimension(:), allocatable :: is_real
     logical, dimension(:), allocatable :: is_child, is_real_child
     logical, intent(in), optional :: keep_beams
     integer :: j, k
     logical :: kb
     kb = .false.
     if (present (keep_beams)) kb = keep_beams
     allocate (is_real (pset%n_tot))
     is_real = pset%prt%is_real (kb)
     is_real = pset%prt%is_real (kb)
     allocate (is_child (pset%n_tot), is_real_child (pset%n_tot))
     is_real_child = .false.
     is_child = .false.
     is_child(pset%prt(i)%get_children()) = .true.
     do while (any (is_child))
        where (is_real .and. is_child)
           is_real_child = .true.
           is_child = .false.
        end where
        mark_next_child: do j = 1, size (is_child)
           if (is_child(j)) then
              is_child(pset%prt(j)%get_children()) = .true.
              is_child(j) = .false.
              exit mark_next_child
           end if
        end do mark_next_child
     end do
     allocate (child (count (is_real_child)))
     j = 0
     do k = 1, size (is_child)
        if (is_real_child(k)) then
           j = j + 1
           child(j) = k
        end if
     end do
   end function particle_set_get_real_children
 
 @ %def particle_set_get_real_parents
 @ %def particle_set_get_real_children
 @ Get the [[n_tot]], [[n_in]], and [[n_out]] values out of the
 particle set.
 <<Particles: particle set: TBP>>=
   procedure :: get_n_beam => particle_set_get_n_beam
   procedure :: get_n_in => particle_set_get_n_in
   procedure :: get_n_vir => particle_set_get_n_vir
   procedure :: get_n_out => particle_set_get_n_out
   procedure :: get_n_tot => particle_set_get_n_tot
   procedure :: get_n_remnants => particle_set_get_n_remnants
 <<Particles: procedures>>=
   function particle_set_get_n_beam (pset) result (n_beam)
      class(particle_set_t), intent(in) :: pset
      integer :: n_beam
      n_beam = pset%n_beam
   end function particle_set_get_n_beam
 
   function particle_set_get_n_in (pset) result (n_in)
      class(particle_set_t), intent(in) :: pset
      integer :: n_in
      n_in = pset%n_in
   end function particle_set_get_n_in
 
   function particle_set_get_n_vir (pset) result (n_vir)
      class(particle_set_t), intent(in) :: pset
      integer :: n_vir
      n_vir = pset%n_vir
    end function particle_set_get_n_vir
 
   function particle_set_get_n_out (pset) result (n_out)
      class(particle_set_t), intent(in) :: pset
      integer :: n_out
      n_out = pset%n_out
   end function particle_set_get_n_out
 
   function particle_set_get_n_tot (pset) result (n_tot)
      class(particle_set_t), intent(in) :: pset
      integer :: n_tot
      n_tot = pset%n_tot
   end function particle_set_get_n_tot
 
   function particle_set_get_n_remnants (pset) result (n_remn)
     class(particle_set_t), intent(in) :: pset
     integer :: n_remn
     if (allocated (pset%prt)) then
        n_remn = count (pset%prt%get_status () == PRT_BEAM_REMNANT)
     else
        n_remn = 0
     end if
   end function particle_set_get_n_remnants
 
 @ %def particle_set_get_n_beam
 @ %def particle_set_get_n_in
 @ %def particle_set_get_n_vir
 @ %def particle_set_get_n_out
 @ %def particle_set_get_n_tot
 @ %def particle_set_get_n_remnants
 @ Return a pointer to the particle corresponding to the number
 <<Particles: particle set: TBP>>=
   procedure :: get_particle => particle_set_get_particle
 <<Particles: procedures>>=
   function particle_set_get_particle (pset, index) result (particle)
     class(particle_set_t), intent(in) :: pset
     integer, intent(in) :: index
     type(particle_t) :: particle
     particle = pset%prt(index)
   end function particle_set_get_particle
 
 @ %def particle_set_get_particle
 @
 <<Particles: particle set: TBP>>=
   procedure :: get_indices => particle_set_get_indices
 <<Particles: procedures>>=
   pure function particle_set_get_indices (pset, mask) result (finals)
     integer, dimension(:), allocatable :: finals
     class(particle_set_t), intent(in) :: pset
     logical, dimension(:), intent(in) :: mask
     integer, dimension(size(mask)) :: indices
     integer :: i
     allocate (finals (count (mask)))
     indices = [(i, i=1, pset%n_tot)]
     finals = pack (indices, mask)
   end function particle_set_get_indices
 
 @ %def particle_set_get_indices
 @
 <<Particles: particle set: TBP>>=
   procedure :: get_in_and_out_momenta => particle_set_get_in_and_out_momenta
 <<Particles: procedures>>=
   function particle_set_get_in_and_out_momenta (pset) result (phs_point)
     type(phs_point_t) :: phs_point
     class(particle_set_t), intent(in) :: pset
     logical, dimension(:), allocatable :: mask
     integer, dimension(:), allocatable :: indices
     type(vector4_t), dimension(:), allocatable :: p
     allocate (mask (pset%get_n_tot ()))
     allocate (p (size (pset%prt)))
     mask = pset%prt%status == PRT_INCOMING .or. &
            pset%prt%status == PRT_OUTGOING
     allocate (indices (count (mask)))
     indices = pset%get_indices (mask)
     phs_point = pset%get_momenta (indices)
   end function particle_set_get_in_and_out_momenta
 
 @ %def particle_set_get_in_and_out_momenta
 @
 \subsubsection{Tools}
 Build a new particles array without hadronic remnants but with
 [[n_extra]] additional spots.  We also update the mother-daughter
 relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]].
 <<Particles: particle set: TBP>>=
   procedure :: without_hadronic_remnants => &
        particle_set_without_hadronic_remnants
 <<Particles: procedures>>=
   subroutine particle_set_without_hadronic_remnants &
          (particle_set, particles, n_particles, n_extra)
     class(particle_set_t), intent(inout) :: particle_set
     type(particle_t), dimension(:), allocatable, intent(out) :: particles
     integer, intent(out) :: n_particles
     integer, intent(in) :: n_extra
     logical, dimension(:), allocatable :: no_hadronic_remnants, &
          no_hadronic_children
     integer, dimension(:), allocatable :: children, new_children
     integer :: i, j, k, first_remnant
     first_remnant = particle_set%n_tot
     do i = 1, particle_set%n_tot
        if (particle_set%prt(i)%is_hadronic_beam_remnant ()) then
           first_remnant = i
           exit
        end if
     end do
     n_particles = count (.not. particle_set%prt%is_hadronic_beam_remnant ())
     allocate (no_hadronic_remnants (particle_set%n_tot))
     no_hadronic_remnants = .not. particle_set%prt%is_hadronic_beam_remnant ()
     allocate (particles (n_particles + n_extra))
     k = 1
     do i = 1, particle_set%n_tot
        if (no_hadronic_remnants(i)) then
           particles(k) = particle_set%prt(i)
           k = k + 1
        end if
     end do
     if (n_particles /= particle_set%n_tot) then
        do i = 1, n_particles
           select case (particles(i)%get_status ())
           case (PRT_BEAM)
              if (allocated (children))  deallocate (children)
              allocate (children (particles(i)%get_n_children ()))
              children = particles(i)%get_children ()
              if (allocated (no_hadronic_children)) &
                   deallocate (no_hadronic_children)
              allocate (no_hadronic_children (particles(i)%get_n_children ()))
              no_hadronic_children = .not. &
                   particle_set%prt(children)%is_hadronic_beam_remnant ()
              if (allocated (new_children))  deallocate (new_children)
              allocate (new_children (count (no_hadronic_children)))
              new_children = pack (children, no_hadronic_children)
              call particles(i)%set_children (new_children)
           case (PRT_INCOMING, PRT_RESONANT)
              <<update children after remnant>>
           case (PRT_OUTGOING, PRT_BEAM_REMNANT)
           case default
           end select
        end do
     end if
   end subroutine particle_set_without_hadronic_remnants
 
 @ %def particle_set_without_hadronic_remnants
 <<update children after remnant>>=
 if (allocated (children))  deallocate (children)
 allocate (children (particles(i)%get_n_children ()))
 children = particles(i)%get_children ()
 do j = 1, size (children)
    if (children(j) > first_remnant) then
       children(j) = children (j) - &
            (particle_set%n_tot - n_particles)
    end if
 end do
 call particles(i)%set_children (children)
 @
 Build a new particles array without remnants but with
 [[n_extra]] additional spots.  We also update the mother-daughter
 relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]].
 <<Particles: particle set: TBP>>=
   procedure :: without_remnants => particle_set_without_remnants
 <<Particles: procedures>>=
   subroutine particle_set_without_remnants &
          (particle_set, particles, n_particles, n_extra)
     class(particle_set_t), intent(inout) :: particle_set
     type(particle_t), dimension(:), allocatable, intent(out) :: particles
     integer, intent(in) :: n_extra
     integer, intent(out) :: n_particles
     logical, dimension(:), allocatable :: no_remnants, no_children
     integer, dimension(:), allocatable :: children, new_children
     integer :: i,j, k, first_remnant
     first_remnant = particle_set%n_tot
     do i = 1, particle_set%n_tot
        if (particle_set%prt(i)%is_beam_remnant ()) then
           first_remnant = i
           exit
        end if
     end do
     allocate (no_remnants (particle_set%n_tot))
     no_remnants = .not. (particle_set%prt%is_beam_remnant ())
     n_particles = count (no_remnants)
     allocate (particles (n_particles + n_extra))
     k = 1
     do i = 1, particle_set%n_tot
        if (no_remnants(i)) then
           particles(k) = particle_set%prt(i)
           k = k + 1
        end if
     end do
     if (n_particles /= particle_set%n_tot) then
        do i = 1, n_particles
           select case (particles(i)%get_status ())
           case (PRT_BEAM)
              if (allocated (children))  deallocate (children)
              allocate (children (particles(i)%get_n_children ()))
              children = particles(i)%get_children ()
              if (allocated (no_children))  deallocate (no_children)
              allocate (no_children (particles(i)%get_n_children ()))
              no_children = .not. (particle_set%prt(children)%is_beam_remnant ())
              if (allocated (new_children))  deallocate (new_children)
              allocate (new_children (count (no_children)))
              new_children = pack (children, no_children)
              call particles(i)%set_children (new_children)
           case (PRT_INCOMING, PRT_RESONANT)
              <<update children after remnant>>
           case (PRT_OUTGOING, PRT_BEAM_REMNANT)
           case default
           end select
        end do
     end if
   end subroutine particle_set_without_remnants
 
 @ %def particle_set_without_remnants
 @
 <<Particles: particle set: TBP>>=
   procedure :: find_particle => particle_set_find_particle
 <<Particles: procedures>>=
   pure function particle_set_find_particle (particle_set, pdg, &
        momentum, abs_smallness, rel_smallness) result (idx)
     integer :: idx
     class(particle_set_t), intent(in) :: particle_set
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: momentum
     real(default), intent(in), optional :: abs_smallness, rel_smallness
     integer :: i
     logical, dimension(0:3) :: equals
     idx = 0
     do i = 1, size (particle_set%prt)
        if (particle_set%prt(i)%flv%get_pdg () == pdg) then
           equals = nearly_equal (particle_set%prt(i)%p%p, momentum%p, &
                abs_smallness, rel_smallness)
           if (all (equals)) then
              idx = i
              return
           end if
        end if
     end do
   end function particle_set_find_particle
 
 @ %def particle_set_find_particle
 <<Particles: particle set: TBP>>=
   procedure :: reverse_find_particle => particle_set_reverse_find_particle
 <<Particles: procedures>>=
   pure function particle_set_reverse_find_particle &
          (particle_set, pdg, momentum, abs_smallness, rel_smallness) result (idx)
     integer :: idx
     class(particle_set_t), intent(in) :: particle_set
     integer, intent(in) :: pdg
     type(vector4_t), intent(in) :: momentum
     real(default), intent(in), optional :: abs_smallness, rel_smallness
     integer :: i
     idx = 0
     do i = size (particle_set%prt), 1, -1
        if (particle_set%prt(i)%flv%get_pdg () == pdg) then
           if (all (nearly_equal (particle_set%prt(i)%p%p, momentum%p, &
                abs_smallness, rel_smallness))) then
              idx = i
              return
           end if
        end if
     end do
   end function particle_set_reverse_find_particle
 
 @ %def particle_set_reverse_find_particle
 @ This connects broken links of the form
 $\text{something} \to i \to \text{none or} j$ and
 $\text{none} \to j \to \text{something or none}$ where the particles $i$ and $j$
 are \emph{identical}.  It also works if $i \to j$, directly, and thus
 removes duplicates.  We are removing $j$ and connect the possible
 daughters to $i$.
 <<Particles: particle set: TBP>>=
   procedure :: remove_duplicates => particle_set_remove_duplicates
 <<Particles: procedures>>=
   subroutine particle_set_remove_duplicates (particle_set, smallness)
     class(particle_set_t), intent(inout) :: particle_set
     real(default), intent(in) :: smallness
     integer :: n_removals
     integer, dimension(particle_set%n_tot) :: to_remove
     type(particle_t), dimension(:), allocatable :: particles
     type(vector4_t) :: p_i
     integer, dimension(:), allocatable :: map
     to_remove = 0
     call find_duplicates ()
     n_removals = count (to_remove > 0)
     if (n_removals > 0) then
        call strip_duplicates (particles)
        call particle_set%replace (particles)
     end if
 
   contains
 
   <<Particles: remove duplicates: procedures>>
 
   end subroutine particle_set_remove_duplicates
 
 @ %def particle_set_remove_duplicates
 @ This does not catch all cases. Missing are splittings of the type
 $i \to \text{something and} j$.
 <<Particles: remove duplicates: procedures>>=
   subroutine find_duplicates ()
     integer :: pdg_i, child_i, i, j
     OUTER: do i = 1, particle_set%n_tot
        if (particle_set%prt(i)%status == PRT_OUTGOING .or. &
             particle_set%prt(i)%status == PRT_VIRTUAL .or. &
             particle_set%prt(i)%status == PRT_RESONANT) then
           if (allocated (particle_set%prt(i)%child)) then
              if (size (particle_set%prt(i)%child) > 1) cycle OUTER
              if (size (particle_set%prt(i)%child) == 1) then
                 child_i = particle_set%prt(i)%child(1)
              else
                 child_i = 0
              end if
           else
              child_i = 0
           end if
           pdg_i = particle_set%prt(i)%flv%get_pdg ()
           p_i = particle_set%prt(i)%p
           do j = i + 1, particle_set%n_tot
              if (pdg_i == particle_set%prt(j)%flv%get_pdg ()) then
                 if (all (nearly_equal (particle_set%prt(j)%p%p, p_i%p, &
                      abs_smallness = smallness, &
                      rel_smallness = 1E4_default * smallness))) then
                    if (child_i == 0 .or. j == child_i) then
                       to_remove(j) = i
                       if (debug_on) call msg_debug2 (D_PARTICLES, &
                            "Particles: Will remove duplicate of i", i)
                       if (debug_on) call msg_debug2 (D_PARTICLES, &
                            "Particles: j", j)
                    end if
                    cycle OUTER
                 end if
              end if
           end do
        end if
     end do OUTER
   end subroutine find_duplicates
 
 @
 <<Particles: remove duplicates: procedures>>=
   recursive function get_alive_index (try) result (alive)
     integer :: alive
     integer :: try
     if (map(try) > 0) then
        alive = map(try)
     else
        alive = get_alive_index (to_remove(try))
     end if
   end function get_alive_index
 
 @
 <<Particles: remove duplicates: procedures>>=
   subroutine strip_duplicates (particles)
     type(particle_t), dimension(:), allocatable, intent(out) :: particles
     integer :: kept, removed, i, j
     integer, dimension(:), allocatable :: old_children
     logical, dimension(:), allocatable :: parent_set
     if (debug_on) call msg_debug (D_PARTICLES, "Particles: Removing duplicates")
     if (debug_on) call msg_debug (D_PARTICLES, "Particles: n_removals", n_removals)
     if (debug2_active (D_PARTICLES)) then
        call msg_debug2 (D_PARTICLES, "Particles: Given set before removing:")
        call particle_set%write (summary=.true., compressed=.true.)
     end if
     allocate (particles (particle_set%n_tot - n_removals))
     allocate (map (particle_set%n_tot))
     allocate (parent_set (particle_set%n_tot))
     parent_set = .false.
     map = 0
     j = 0
     do i = 1, particle_set%n_tot
        if (to_remove(i) == 0) then
           j = j + 1
           map(i) = j
           call particles(j)%init (particle_set%prt(i))
        end if
     end do
     do i = 1, particle_set%n_tot
        if (map(i) /= 0) then
           if (.not. parent_set(map(i))) then
              call particles(map(i))%set_parents &
                   (map (particle_set%prt(i)%get_parents ()))
           end if
           call particles(map(i))%set_children &
                (map (particle_set%prt(i)%get_children ()))
        else
           removed = i
           kept = to_remove(i)
           if (particle_set%prt(removed)%has_children ()) then
              old_children = particle_set%prt(removed)%get_children ()
              do j = 1, size (old_children)
                 if (map(old_children(j)) > 0) then
                    call particles(map(old_children(j)))%set_parents &
                         ([get_alive_index (kept)])
                    parent_set(map(old_children(j))) = .true.
                    call particles(get_alive_index (kept))%add_child &
                         (map(old_children(j)))
                 end if
              end do
              particles(get_alive_index (kept))%status = PRT_RESONANT
           else
              particles(get_alive_index (kept))%status = PRT_OUTGOING
           end if
        end if
     end do
   end subroutine strip_duplicates
 
 @ Given a subevent, reset status codes.  If the new status is beam,
 incoming, or outgoing, we also make sure that the stored $p^2$ value
 is equal to the on-shell mass squared.
 <<Particles: particle set: TBP>>=
   procedure :: reset_status => particle_set_reset_status
 <<Particles: procedures>>=
   subroutine particle_set_reset_status (particle_set, index, status)
     class(particle_set_t), intent(inout) :: particle_set
     integer, dimension(:), intent(in) :: index
     integer, intent(in) :: status
     integer :: i
     if (allocated (particle_set%prt)) then
        do i = 1, size (index)
           call particle_set%prt(index(i))%reset_status (status)
        end do
     end if
     particle_set%n_beam  = &
          count (particle_set%prt%get_status () == PRT_BEAM)
     particle_set%n_in  = &
          count (particle_set%prt%get_status () == PRT_INCOMING)
     particle_set%n_out = &
          count (particle_set%prt%get_status () == PRT_OUTGOING)
     particle_set%n_vir = particle_set%n_tot &
          - particle_set%n_beam - particle_set%n_in - particle_set%n_out
   end subroutine particle_set_reset_status
 
 @ %def particle_set_reset_status
 @ Reduce a particle set to the essential entries.  The entries kept
 are those with status [[INCOMING]], [[OUTGOING]] or
 [[RESONANT]]. [[BEAM]] is kept if [[keep_beams]] is true. Other
 entries are skipped. The correlated state matrix, if any, is also
 ignored.
 <<Particles: particle set: TBP>>=
   procedure :: reduce => particle_set_reduce
 <<Particles: procedures>>=
   subroutine particle_set_reduce (pset_in, pset_out, keep_beams)
     class(particle_set_t), intent(in) :: pset_in
     type(particle_set_t), intent(out) :: pset_out
     logical, intent(in), optional :: keep_beams
     integer, dimension(:), allocatable :: status, map
     integer :: i, j
     logical :: kb
     kb = .false.;  if (present (keep_beams))  kb = keep_beams
     allocate (status (pset_in%n_tot))
     pset_out%factorization_mode = pset_in%factorization_mode
     status = pset_in%prt%get_status ()
     if (kb)  pset_out%n_beam  = count (status == PRT_BEAM)
     pset_out%n_in  = count (status == PRT_INCOMING)
     pset_out%n_vir = count (status == PRT_RESONANT)
     pset_out%n_out = count (status == PRT_OUTGOING)
     pset_out%n_tot = &
          pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out
     allocate (pset_out%prt (pset_out%n_tot))
     allocate (map (pset_in%n_tot))
     map = 0
     j = 0
     if (kb) call copy_particles (PRT_BEAM)
     call copy_particles (PRT_INCOMING)
     call copy_particles (PRT_RESONANT)
     call copy_particles (PRT_OUTGOING)
     do i = 1, pset_in%n_tot
        if (map(i) == 0)  cycle
        call pset_out%prt(map(i))%set_parents &
             (pset_in%get_real_parents (i, kb))
        call pset_out%prt(map(i))%set_parents &
             (map (pset_out%prt(map(i))%parent))
        call pset_out%prt(map(i))%set_children &
             (pset_in%get_real_children (i, kb))
        call pset_out%prt(map(i))%set_children &
             (map (pset_out%prt(map(i))%child))
     end do
   contains
     subroutine copy_particles (stat)
       integer, intent(in) :: stat
       integer :: i
       do i = 1, pset_in%n_tot
          if (status(i) == stat) then
             j = j + 1
             map(i) = j
             call particle_init_particle (pset_out%prt(j), pset_in%prt(i))
          end if
       end do
     end subroutine copy_particles
   end subroutine particle_set_reduce
 
 @ %def particles_set_reduce
 @ Remove the beam particles and beam remnants from the particle set if the
 keep beams flag is false. If keep beams is not given, the beam particles
 and the beam remnants are removed.
 The correlated state matrix, if any, is also ignored.
 <<Particles: particle set: TBP>>=
   procedure :: filter_particles => particle_set_filter_particles
 <<Particles: procedures>>=
   subroutine particle_set_filter_particles &
        (pset_in, pset_out, keep_beams, real_parents, keep_virtuals)
     class(particle_set_t), intent(in) :: pset_in
     type(particle_set_t), intent(out) :: pset_out
     logical, intent(in), optional :: keep_beams, real_parents, keep_virtuals
     integer, dimension(:), allocatable :: status, map
     logical, dimension(:), allocatable :: filter
     integer :: i, j
     logical :: kb, rp, kv
     kb = .false.;  if (present (keep_beams))  kb = keep_beams
     rp = .false.; if (present (real_parents)) rp = real_parents
     kv = .true.; if (present (keep_virtuals)) kv = keep_virtuals
     if (debug_on) call msg_debug (D_PARTICLES, "filter_particles")
     if (debug2_active (D_PARTICLES)) then
        print *, 'keep_beams =    ', kb
        print *, 'real_parents =    ', rp
        print *, 'keep_virtuals =    ', kv
        print *, '>>> pset_in : '
        call pset_in%write(compressed=.true.)
     end if
     call count_and_allocate()
     map = 0
     j = 0
     filter = .false.
     if (.not. kb) filter = status == PRT_BEAM .or. status == PRT_BEAM_REMNANT
     if (.not. kv) filter = filter .or. status == PRT_VIRTUAL
     call copy_particles ()
     do i = 1, pset_in%n_tot
        if (map(i) == 0)  cycle
        if (rp) then
           call pset_out%prt(map(i))%set_parents &
                (map (pset_in%get_real_parents (i, kb)))
           call pset_out%prt(map(i))%set_children &
                (map (pset_in%get_real_children (i, kb)))
        else
           call pset_out%prt(map(i))%set_parents &
                (map (pset_in%prt(i)%get_parents ()))
           call pset_out%prt(map(i))%set_children &
                (map (pset_in%prt(i)%get_children ()))
        end if
     end do
     if (debug2_active (D_PARTICLES)) then
        print *, '>>> pset_out : '
        call pset_out%write(compressed=.true.)
     end if
   contains
     <<filter particles: procedures>>
   end subroutine particle_set_filter_particles
 
 @ %def particles_set_filter_particles
 <<filter particles: procedures>>=
     subroutine copy_particles ()
       integer :: i
       do i = 1, pset_in%n_tot
          if (.not. filter(i)) then
             j = j + 1
             map(i) = j
             call particle_init_particle (pset_out%prt(j), pset_in%prt(i))
          end if
       end do
     end subroutine copy_particles
 
 <<filter particles: procedures>>=
   subroutine count_and_allocate
     allocate (status (pset_in%n_tot))
     status = particle_get_status (pset_in%prt)
     if (kb)  pset_out%n_beam  = count (status == PRT_BEAM)
     pset_out%n_in  = count (status == PRT_INCOMING)
     if (kb .and. kv) then
        pset_out%n_vir = count (status == PRT_VIRTUAL) + &
             count (status == PRT_RESONANT) + &
             count (status == PRT_BEAM_REMNANT)
     else if (kb .and. .not. kv) then
        pset_out%n_vir = count (status == PRT_RESONANT) + &
             count (status == PRT_BEAM_REMNANT)
     else if (.not. kb .and. kv) then
        pset_out%n_vir = count (status == PRT_VIRTUAL) + &
             count (status == PRT_RESONANT)
     else
        pset_out%n_vir = count (status == PRT_RESONANT)
     end if
     pset_out%n_out = count (status == PRT_OUTGOING)
     pset_out%n_tot = &
          pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out
     allocate (pset_out%prt (pset_out%n_tot))
     allocate (map (pset_in%n_tot))
     allocate (filter (pset_in%n_tot))
   end subroutine count_and_allocate
 
 @ Transform a particle set into HEPEVT-compatible form.  In this form, for each
 particle, the parents and the children are contiguous in the particle array.
 Usually, this requires to clone some particles.
 
 We do not know in advance how many particles the canonical form will have.
 To be on the safe side, allocate four times the original size.
 <<Particles: particle set: TBP>>=
   procedure :: to_hepevt_form => particle_set_to_hepevt_form
 <<Particles: procedures>>=
   subroutine particle_set_to_hepevt_form (pset_in, pset_out)
     class(particle_set_t), intent(in) :: pset_in
     type(particle_set_t), intent(out) :: pset_out
     type :: particle_entry_t
        integer :: src = 0
        integer :: status = 0
        integer :: orig = 0
        integer :: copy = 0
     end type particle_entry_t
     type(particle_entry_t), dimension(:), allocatable :: prt
     integer, dimension(:), allocatable :: map1, map2
     integer, dimension(:), allocatable :: parent, child
     integer :: n_tot, n_parents, n_children, i, j, c, n
 
     n_tot = pset_in%n_tot
     allocate (prt (4 * n_tot))
     allocate (map1(4 * n_tot))
     allocate (map2(4 * n_tot))
     map1 = 0
     map2 = 0
     allocate (child (n_tot))
     allocate (parent (n_tot))
     n = 0
     do i = 1, n_tot
        if (pset_in%prt(i)%get_n_parents () == 0) then
           call append (i)
        end if
     end do
     do i = 1, n_tot
        n_children = pset_in%prt(i)%get_n_children ()
        if (n_children > 0) then
           child(1:n_children) = pset_in%prt(i)%get_children ()
           c = child(1)
           if (map1(c) == 0) then
              n_parents = pset_in%prt(c)%get_n_parents ()
              if (n_parents > 1) then
                 parent(1:n_parents) = pset_in%prt(c)%get_parents ()
                 if (i == parent(1) .and. &
                     any( [(map1(i)+j-1, j=1,n_parents)] /= &
                            map1(parent(1:n_parents)))) then
                    do j = 1, n_parents
                       call append (parent(j))
                    end do
                 end if
              else if (map1(i) == 0) then
                 call append (i)
              end if
              do j = 1, n_children
                 call append (child(j))
              end do
           end if
        else if (map1(i) == 0) then
           call append (i)
        end if
     end do
     do i = n, 1, -1
        if (prt(i)%status /= PRT_OUTGOING) then
           do j = 1, i-1
              if (prt(j)%status == PRT_OUTGOING) then
                 call append(prt(j)%src)
              end if
           end do
           exit
        end if
     end do
     pset_out%n_beam = count (prt(1:n)%status == PRT_BEAM)
     pset_out%n_in   = count (prt(1:n)%status == PRT_INCOMING)
     pset_out%n_vir  = count (prt(1:n)%status == PRT_RESONANT)
     pset_out%n_out  = count (prt(1:n)%status == PRT_OUTGOING)
     pset_out%n_tot = n
     allocate (pset_out%prt (n))
     do i = 1, n
        call particle_init_particle (pset_out%prt(i), pset_in%prt(prt(i)%src))
        call pset_out%prt(i)%reset_status (prt(i)%status)
        if (prt(i)%orig == 0) then
           call pset_out%prt(i)%set_parents &
                (map2 (pset_in%prt(prt(i)%src)%get_parents ()))
        else
           call pset_out%prt(i)%set_parents ([ prt(i)%orig ])
        end if
        if (prt(i)%copy == 0) then
           call pset_out%prt(i)%set_children &
                (map1 (pset_in%prt(prt(i)%src)%get_children ()))
        else
           call pset_out%prt(i)%set_children ([ prt(i)%copy ])
        end if
     end do
   contains
     subroutine append (i)
       integer, intent(in) :: i
       n = n + 1
       if (n > size (prt)) &
            call msg_bug ("Particle set transform to HEPEVT: insufficient space")
       prt(n)%src = i
       prt(n)%status = pset_in%prt(i)%get_status ()
       if (map1(i) == 0) then
          map1(i) = n
       else
          prt(map2(i))%status = PRT_VIRTUAL
          prt(map2(i))%copy = n
          prt(n)%orig = map2(i)
       end if
       map2(i) = n
     end subroutine append
   end subroutine particle_set_to_hepevt_form
 
 @ %def particle_set_to_hepevt_form
 @ This procedure aims at reconstructing the momenta of an interaction,
 given a particle set.  The main task is to find the original hard process, by
-following the event history. 
+following the event history.
 
 In-state: take those particles which are flagged as [[PRT_INCOMING]]
 
 Out-state: try to be smart by checking the immediate children of the incoming
 particles.  If the [[state_flv]] table is present, check any [[PRT_RESONANT]]
 particles that we get this way, whether they are potential out-particles by
 their PDG codes.  If not, replace them by their children, recursively.
 (Resonances may have been inserted by the corresponding event transform.)
 
 [WK 21-02-16] Revised the algorithm for the case [[recover_beams]] = false,
 i.e., the particle set contains beams and radiation.  This does not mean that
 the particle set contains the complete radiation history.  To make up for
 missing information, we follow the history in the interaction one step
 backwards and do a bit of guesswork to match this to the possibly incomplete
 history in the particle set.  [The current implementation allows only for one
   stage of radiation; this could be improved by iterating the procedure!]
 
 [WK 21-03-21] Amended the [[find_hard_process_in_pset]] algorithm as follows:
 Occasionally, PYTHIA adds a stepchild to the decay of a resonance that WHIZARD
 has inserted, a shower object that also has other particles in the event as
 parents.  Such objects must not enter the hard-process record.  Therefore,
 resonance child particle objects are ignored if they have more than one
 parent.
 <<Particles: particle set: TBP>>=
   procedure :: fill_interaction => particle_set_fill_interaction
 <<Particles: procedures>>=
   subroutine particle_set_fill_interaction &
        (pset, int, n_in, recover_beams, check_match, state_flv, success)
     class(particle_set_t), intent(in) :: pset
     type(interaction_t), intent(inout) :: int
     integer, intent(in) :: n_in
     logical, intent(in), optional :: recover_beams, check_match
     type(state_flv_content_t), intent(in), optional :: state_flv
     logical, intent(out), optional :: success
     integer, dimension(:), allocatable :: map, pdg
     integer, dimension(:), allocatable :: i_in, i_out, p_in, p_out
     logical, dimension(:), allocatable :: i_set
     integer :: n_out, i, p
     logical :: r_beams, check
     r_beams = .false.;  if (present (recover_beams))  r_beams = recover_beams
     check = .true.;  if (present (check_match))  check = check_match
     if (check) then
        call find_hard_process_in_int  (i_in, i_out)
        call find_hard_process_in_pset (p_in, p_out, state_flv, success)
        if (present (success)) then
           if (size (i_in) /= n_in)  success = .false.
           if (size (p_in) /= n_in)  success = .false.
           if (size (p_out) /= n_out)  success = .false.
           if (.not. success)  return
        else
           if (size (i_in) /= n_in)  call err_int_n_in
           if (size (p_in) /= n_in)  call err_pset_n_in
           if (size (p_out) /= n_out)  call err_pset_n_out
        end if
        call extract_hard_process_from_pset (pdg)
        call determine_map_for_hard_process (map, state_flv, success)
        if (present (success)) then
           if (.not. success)  return
        end if
        call map_handle_duplicates (map)
        if (.not. r_beams) then
           call determine_map_for_beams (map)
           call map_handle_duplicates (map)
           call determine_map_for_radiation (map, i_in, p_in)
           call map_handle_duplicates (map)
        end if
     else
        allocate (map (int%get_n_tot ()))
        map = [(i, i = 1, size (map))]
        r_beams = .false.
     end if
     allocate (i_set (int%get_n_tot ()), source = .false.)
     do p = 1, size (map)
        if (map(p) /= 0) then
           if (.not. i_set(map(p))) then
              call int%set_momentum (pset%prt(p)%get_momentum (), map(p))
              i_set(map(p)) = .true.
           end if
        end if
     end do
     if (r_beams) then
        do i = 1, n_in
           call reconstruct_beam_and_radiation (i, i_set)
        end do
     else
        do i = int%get_n_tot (), 1, -1
           if (.not. i_set(i))  call reconstruct_missing (i, i_set)
        end do
     end if
     if (any (.not. i_set)) then
        if (present (success)) then
           success = .false.
        else
           call err_map
        end if
     end if
   contains
     subroutine find_hard_process_in_int (i_in, i_out)
       integer, dimension(:), allocatable, intent(out) :: i_in, i_out
       integer :: n_in_i
       integer :: i
       i = int%get_n_tot ()
       n_in_i = interaction_get_n_parents (int, i)
       if (n_in_i /= n_in)  call err_int_n_in
       allocate (i_in (n_in))
       i_in = interaction_get_parents (int, i)
       i = i_in(1)
       n_out = interaction_get_n_children (int, i)
       allocate (i_out (n_out))
       i_out = interaction_get_children (int, i)
     end subroutine find_hard_process_in_int
     subroutine find_hard_process_in_pset (p_in, p_out, state_flv, success)
       integer, dimension(:), allocatable, intent(out) :: p_in, p_out
       type(state_flv_content_t), intent(in), optional :: state_flv
       logical, intent(out), optional :: success
       integer, dimension(:), allocatable :: p_status, p_idx, p_child
       integer :: n_out_p, n_child, n_shift
       integer :: i, k, c
       allocate (p_status (pset%n_tot), p_idx (pset%n_tot), p_child (pset%n_tot))
       p_status = pset%prt%get_status ()
       p_idx = [(i, i = 1, pset%n_tot)]
       allocate (p_in (n_in))
       p_in = pack (p_idx, p_status == PRT_INCOMING)
       if (size (p_in) == 0)  call err_pset_hard
       i = p_in(1)
       allocate (p_out (n_out))
       n_out_p = particle_get_n_children (pset%prt(i))
       p_out(1:n_out_p) = particle_get_children (pset%prt(i))
       do k = 1, size (p_out)
          i = p_out(k)
          if (present (state_flv)) then
             do while (pset%prt(i)%get_status () == PRT_RESONANT)
                if (state_flv%contains (pset%prt(i)%get_pdg ()))  exit
                n_child = particle_get_n_children (pset%prt(i))
                p_child(1:n_child) = particle_get_children (pset%prt(i))
                n_shift = -1
                do c = 1, n_child
                   if (particle_get_n_parents (pset%prt(p_child(c))) == 1) then
                      n_shift = n_shift + 1
                   else
                      p_child(c) = 0
                   end if
                end do
-	       if (n_shift < 0) then
+               if (n_shift < 0) then
                   if (present (success)) then
                      success = .false.
                      return
                   else
                      call err_mismatch
                   end if
                end if
                p_out(k+1+n_shift:n_out_p+n_shift) = p_out(k+1:n_out_p)
                n_out_p = n_out_p + n_shift
                do c = 1, n_child
                   if (p_child(c) /= 0) then
                      p_out(k+c-1) = p_child(c)
                   end if
                end do
                i = p_out(k)
             end do
          end if
       end do
       if (present (success))  success = .true.
     end subroutine find_hard_process_in_pset
     subroutine extract_hard_process_from_pset (pdg)
       integer, dimension(:), allocatable, intent(out) :: pdg
       integer, dimension(:), allocatable :: pdg_p
       logical, dimension(:), allocatable :: mask_p
       integer :: i
       allocate (pdg_p (pset%n_tot))
       pdg_p = pset%prt%get_pdg ()
       allocate (mask_p (pset%n_tot), source = .false.)
       mask_p (p_in) = .true.
       mask_p (p_out) = .true.
       allocate (pdg (n_in + n_out))
       pdg = pack (pdg_p, mask_p)
     end subroutine extract_hard_process_from_pset
     subroutine determine_map_for_hard_process (map, state_flv, success)
       integer, dimension(:), allocatable, intent(out) :: map
       type(state_flv_content_t), intent(in), optional :: state_flv
       logical, intent(out), optional :: success
       integer, dimension(:), allocatable :: pdg_i, map_i
       integer :: n_tot
       logical, dimension(:), allocatable :: mask_i, mask_p
       logical :: match
       n_tot = int%get_n_tot ()
       if (present (state_flv)) then
          allocate (mask_i (n_tot), source = .false.)
          mask_i (i_in) = .true.
          mask_i (i_out) = .true.
          allocate (pdg_i (n_tot), map_i (n_tot))
          pdg_i = unpack (pdg, mask_i, 0)
          call state_flv%match (pdg_i, match, map_i)
          if (present (success)) then
             success = match
-	 end if
+         end if
          if (.not. match) then
-	    if (present (success)) then
-	       return
-	    else
+            if (present (success)) then
+               return
+            else
                call err_mismatch
             end if
-	 end if
+         end if
          allocate (mask_p (pset%n_tot), source = .false.)
          mask_p (p_in) = .true.
          mask_p (p_out) = .true.
          allocate (map (size (mask_p)), &
               source = unpack (pack (map_i, mask_i), mask_p, 0))
       else
          allocate (map (n_tot), source = 0)
          map(p_in) = i_in
          map(p_out) = i_out
       end if
     end subroutine determine_map_for_hard_process
     subroutine map_handle_duplicates (map)
       integer, dimension(:), intent(inout) :: map
       integer, dimension(1) :: p_parent, p_child
       integer :: p
       do p = 1, pset%n_tot
          if (map(p) == 0) then
             if (pset%prt(p)%get_n_parents () == 1) then
                p_parent = pset%prt(p)%get_parents ()
                if (map(p_parent(1)) /= 0) then
                   if (pset%prt(p_parent(1))%get_n_children () == 1) then
                      map(p) = map(p_parent(1))
                   end if
                end if
             end if
          end if
       end do
       do p = pset%n_tot, 1, -1
          if (map(p) == 0) then
             if (pset%prt(p)%get_n_children () == 1) then
                p_child = pset%prt(p)%get_children ()
                if (map(p_child(1)) /= 0) then
                   if (pset%prt(p_child(1))%get_n_parents () == 1) then
                      map(p) = map(p_child(1))
                   end if
                end if
             end if
          end if
       end do
     end subroutine map_handle_duplicates
     subroutine determine_map_for_beams (map)
       integer, dimension(:), intent(inout) :: map
       select case (n_in)
       case (1);  map(1) = 1
       case (2);  map(1:2) = [1,2]
       end select
     end subroutine determine_map_for_beams
     subroutine determine_map_for_radiation (map, i_in, p_in)
       integer, dimension(:), intent(inout) :: map
       integer, dimension(:), intent(in) :: i_in
       integer, dimension(:), intent(in) :: p_in
       integer, dimension(:), allocatable :: i_cur, p_cur
       integer, dimension(:), allocatable :: i_par, p_par, i_rad, p_rad
       integer :: i, p
       integer :: b, r
       i_cur = i_in
       p_cur = p_in
       do b = 1, n_in
          i = i_cur(b)
          p = p_cur(b)
          i_par = interaction_get_parents (int, i)
          p_par = pset%prt(p)%get_parents ()
          if (size (i_par) == 0 .or. size (p_par) == 0)  cycle
          if (size (p_par) == 1) then
             if (pset%prt(p_par(1))%get_n_children () == 1) then
                p_par = pset%prt(p_par(1))%get_parents ()  ! copy of entry
             end if
          end if
          i_rad = interaction_get_children (int, i_par(1))
          p_rad = pset%prt(p_par(1))%get_children ()
          do r = 1, size (i_rad)
             if (any (map == i_rad(r)))  i_rad(r) = 0
          end do
          i_rad = pack (i_rad, i_rad /= 0)
          do r = 1, size (p_rad)
             if (map(p_rad(r)) /= 0)  p_rad(r) = 0
          end do
          p_rad = pack (p_rad, p_rad /= 0)
          do r = 1, min (size (i_rad), size (p_rad))
             map(p_rad(r)) = i_rad(r)
          end do
       end do
       do b = 1, min (size (p_par), size (i_par))
          if (map(p_par(b)) == 0 .and. all (map /= i_par(b))) then
             map(p_par(b)) = i_par(b)
          end if
       end do
     end subroutine determine_map_for_radiation
     subroutine reconstruct_beam_and_radiation (k, i_set)
       integer, intent(in) :: k
       logical, dimension(:), intent(inout) :: i_set
       integer :: k_src, k_pre, k_in, k_rad
       type(interaction_t), pointer :: int_src
       integer, dimension(2) :: i_child
       logical, dimension(2) :: is_final
       integer :: i
       call int%find_source (k, int_src, k_src)
       k_pre = 0
       k_in = k
       do while (.not. i_set (k_in))
          if (k_pre == 0) then
             call int%set_momentum (int_src%get_momentum (k_src), k_in)
          else
             call int%set_momentum (int%get_momentum (k_pre), k_in)
          end if
          i_set(k_in) = .true.
          if (n_in == 2) then
             k_pre = k_in
             i_child = interaction_get_children (int, k_pre)
             do i = 1, 2
                is_final(i) = interaction_get_n_children (int, i_child(i)) == 0
             end do
             if (all (.not. is_final)) then
                k_in = i_child(k);  k_rad = 0
             else if (is_final(2)) then
                k_in = i_child(1);  k_rad = i_child(2)
             else if (is_final(1)) then
                k_in = i_child(2);  k_rad = i_child(1)
             else
                call err_beams
             end if
             if (k_rad /= 0) then
                if (i_set (k_in)) then
                   call int%set_momentum &
                        (int%get_momentum (k) - int%get_momentum (k_in), k_rad)
                   i_set(k_rad) = .true.
                else
                   call err_beams_norad
                end if
             end if
          end if
       end do
     end subroutine reconstruct_beam_and_radiation
     subroutine reconstruct_missing (i, i_set)
       integer, intent(in) :: i
       logical, dimension(:), intent(inout) :: i_set
       integer, dimension(:), allocatable :: i_child, i_parent, i_sibling
       integer :: s
       i_child = interaction_get_children (int, i)
       i_parent = interaction_get_parents (int, i)
       if (size (i_child) > 0 .and. all (i_set(i_child))) then
          call int%set_momentum (sum (int%get_momenta (i_child)), i)
       else if (size (i_parent) > 0 .and. all (i_set(i_parent))) then
          i_sibling = interaction_get_children (int, i_parent(1))
          call int%set_momentum (sum (int%get_momenta (i_parent)), i)
          do s = 1, size (i_sibling)
             if (i_sibling(s) == i)  cycle
             if (i_set(i_sibling(s))) then
                call int%set_momentum (int%get_momentum (i) &
                     - int%get_momentum (i_sibling(s)), i)
             else
                call err_beams_norad
             end if
          end do
       else
          call err_beams_norad
       end if
       i_set(i) = .true.
     end subroutine reconstruct_missing
     subroutine err_pset_hard
       call msg_fatal ("Reading particle set: no particles marked as incoming")
     end subroutine err_pset_hard
     subroutine err_int_n_in
       integer :: n
       if (allocated (i_in)) then
          n = size (i_in)
       else
          n = 0
       end if
       write (msg_buffer, "(A,I0,A,I0)") &
            "Filling hard process from particle set: expect ", n_in, &
            " incoming particle(s), found ", n
       call msg_bug
     end subroutine err_int_n_in
     subroutine err_pset_n_in
       write (msg_buffer, "(A,I0,A,I0)") &
            "Reading hard-process particle set: should contain ", n_in, &
            " incoming particle(s), found ", size (p_in)
       call msg_fatal
     end subroutine err_pset_n_in
     subroutine err_pset_n_out
       write (msg_buffer, "(A,I0,A,I0)") &
            "Reading hard-process particle set: should contain ", n_out, &
            " outgoing particle(s), found ", size (p_out)
       call msg_fatal
     end subroutine err_pset_n_out
     subroutine err_mismatch
       call pset%write ()
       call state_flv%write ()
       call msg_fatal ("Reading particle set: Flavor combination " &
            // "does not match requested process")
     end subroutine err_mismatch
     subroutine err_map
       call pset%write ()
       call int%basic_write ()
       call msg_fatal ("Reading hard-process particle set: " &
            // "Incomplete mapping from particle set to interaction")
     end subroutine err_map
     subroutine err_beams
       call pset%write ()
       call int%basic_write ()
       call msg_fatal ("Reading particle set: Beam structure " &
            // "does not match requested process")
     end subroutine err_beams
     subroutine err_beams_norad
       call pset%write ()
       call int%basic_write ()
       call msg_fatal ("Reading particle set: Beam structure " &
            // "cannot be reconstructed for this configuration")
     end subroutine err_beams_norad
     subroutine err_radiation
       call int%basic_write ()
       call msg_bug ("Reading particle set: Interaction " &
            // "contains inconsistent radiation pattern.")
     end subroutine err_radiation
   end subroutine particle_set_fill_interaction
 
 @ %def particle_set_fill_interaction
 @
 This procedure reconstructs an array of vertex indices from the
 parent-child information in the particle entries, according to the
 HepMC scheme.  For each particle, we determine which vertex it comes
 from and which vertex it goes to.  We return the two arrays and the
 maximum vertex index.
 
 For each particle in the list, we first check its parents.  If for any
 parent the vertex where it goes to is already known, this vertex index
 is assigned as the current 'from' vertex.  Otherwise, a new index is
 created, assigned as the current 'from' vertex, and as the 'to' vertex
 for all parents.
 
 Then, the analogous procedure is done for the children.
 
 Furthermore, we assign to each vertex the vertex position from the
 parent(s). We check that these vertex positions coincide, and if not
 return a null vector.
 <<Particles: particle set: TBP>>=
   procedure :: assign_vertices => particle_set_assign_vertices
 <<Particles: procedures>>=
   subroutine particle_set_assign_vertices &
        (particle_set, v_from, v_to, n_vertices)
     class(particle_set_t), intent(in) :: particle_set
     integer, dimension(:), intent(out) :: v_from, v_to
     integer, intent(out) :: n_vertices
     integer, dimension(:), allocatable :: parent, child
     integer :: n_parents, n_children, vf, vt
     integer :: i, j, v
     v_from = 0
     v_to = 0
     vf = 0
     vt = 0
     do i = 1, particle_set%n_tot
        n_parents = particle_set%prt(i)%get_n_parents ()
        if (n_parents /= 0) then
           allocate (parent (n_parents))
           parent = particle_set%prt(i)%get_parents ()
           SCAN_PARENTS: do j = 1, size (parent)
              v = v_to(parent(j))
              if (v /= 0) then
                 v_from(i) = v;  exit SCAN_PARENTS
              end if
           end do SCAN_PARENTS
           if (v_from(i) == 0) then
              vf = vf + 1;  v_from(i) = vf
              v_to(parent) = vf
           end if
           deallocate (parent)
        end if
        n_children = particle_set%prt(i)%get_n_children ()
        if (n_children /= 0) then
           allocate (child (n_children))
           child = particle_set%prt(i)%get_children ()
           SCAN_CHILDREN: do j = 1, size (child)
              v = v_from(child(j))
              if (v /= 0) then
                 v_to(i) = v;  exit SCAN_CHILDREN
              end if
           end do SCAN_CHILDREN
           if (v_to(i) == 0) then
              vt = vt + 1;  v_to(i) = vt
              v_from(child) = vt
           end if
           deallocate (child)
        end if
     end do
     n_vertices = max (vf, vt)
   end subroutine particle_set_assign_vertices
 
 @ %def particle_set_assign_vertices
 @
 \subsection{Expression interface}
 This converts a [[particle_set]] object as defined here to a more
 concise [[subevt]] object that can be used as the event root of an
 expression.  In particular, the latter lacks virtual particles, spin
 correlations and parent-child relations.
 
 We keep beam particles, incoming partons, and outgoing partons.
 Furthermore, we keep radiated particles (a.k.a.\ beam remnants) if
 they have no children in the current particle set, and mark them as
 outgoing particles.
 
 If [[colorize]] is set and true, mark all particles in the subevent as
 colorized, and set color/anticolor flow indices where they are defined.
 Colorless particles do not get indices but are still marked as colorized, for
 consistency.
 <<Particles: particle set: TBP>>=
   procedure :: to_subevt => particle_set_to_subevt
 <<Particles: procedures>>=
   subroutine particle_set_to_subevt (particle_set, subevt, colorize)
     class(particle_set_t), intent(in) :: particle_set
     type(subevt_t), intent(out) :: subevt
     logical, intent(in), optional :: colorize
     integer :: n_tot, n_beam, n_in, n_out, n_rad
     integer :: i, k, n_active
     integer, dimension(2) :: hel
     logical :: keep
     n_tot  = particle_set_get_n_tot      (particle_set)
     n_beam = particle_set_get_n_beam     (particle_set)
     n_in   = particle_set_get_n_in       (particle_set)
     n_out  = particle_set_get_n_out      (particle_set)
     n_rad  = particle_set_get_n_remnants (particle_set)
     call subevt_init (subevt, n_beam + n_rad + n_in + n_out)
     k = 0
     do i = 1, n_tot
        associate (prt => particle_set%prt(i))
          keep = .false.
          select case (particle_get_status (prt))
          case (PRT_BEAM)
             k = k + 1
             call subevt_set_beam (subevt, k, &
                  particle_get_pdg (prt), &
                  particle_get_momentum (prt), &
                  particle_get_p2 (prt))
             keep = .true.
          case (PRT_INCOMING)
             k = k + 1
             call subevt_set_incoming (subevt, k, &
                  particle_get_pdg (prt), &
                  particle_get_momentum (prt), &
                  particle_get_p2 (prt))
             keep = .true.
          case (PRT_OUTGOING)
             k = k + 1
             call subevt_set_outgoing (subevt, k, &
                  particle_get_pdg (prt), &
                  particle_get_momentum (prt), &
                  particle_get_p2 (prt))
             keep = .true.
          case (PRT_BEAM_REMNANT)
             if (particle_get_n_children (prt) == 0) then
                k = k + 1
                call subevt_set_outgoing (subevt, k, &
                     particle_get_pdg (prt), &
                     particle_get_momentum (prt), &
                     particle_get_p2 (prt))
                keep = .true.
             end if
          end select
          if (keep) then
             if (prt%polarization == PRT_DEFINITE_HELICITY) then
                if (prt%hel%is_diagonal ()) then
                   hel = prt%hel%to_pair ()
                   call subevt_polarize (subevt, k, hel(1))
                end if
             end if
          end if
          if (present (colorize)) then
             if (colorize) then
                call subevt_colorize &
                     (subevt, i, prt%col%get_col (), prt%col%get_acl ())
             end if
          end if
        end associate
        n_active = k
     end do
     call subevt_reset (subevt, n_active)
   end subroutine particle_set_to_subevt
 
 @ %def particle_set_to_subevt
 @
 This replaces the [[particle\_set\%prt array]] with a given array of particles
 <<Particles: particle set: TBP>>=
   procedure :: replace => particle_set_replace
 <<Particles: procedures>>=
   subroutine particle_set_replace (particle_set, newprt)
     class(particle_set_t), intent(inout) :: particle_set
     type(particle_t), intent(in), dimension(:), allocatable :: newprt
     if (allocated (particle_set%prt))  deallocate (particle_set%prt)
     allocate (particle_set%prt(size (newprt)))
     particle_set%prt = newprt
     particle_set%n_tot = size (newprt)
     particle_set%n_beam = count (particle_get_status (newprt) == PRT_BEAM)
     particle_set%n_in = count (particle_get_status (newprt) == PRT_INCOMING)
     particle_set%n_out = count (particle_get_status (newprt) == PRT_OUTGOING)
     particle_set%n_vir = particle_set%n_tot &
          - particle_set%n_beam - particle_set%n_in - particle_set%n_out
   end subroutine particle_set_replace
 
 @ %def particle_set_replace
 @ This routines orders the outgoing particles into clusters of
 colorless particles and such of particles ordered corresponding to the
 indices of the color lines. All outgoing particles in the ordered set
 appear as child of the corresponding outgoing particle in the
 unordered set, including colored beam remnants. We always start
 continue via the anti-color line, such that color flows within each
 Lund string system is always continued from the anticolor of one
 particle to the identical color index of another particle.
 <<Particles: particle set: TBP>>=
   procedure :: order_color_lines => particle_set_order_color_lines
 <<Particles: procedures>>=
   subroutine particle_set_order_color_lines (pset_out, pset_in)
     class(particle_set_t), intent(inout) :: pset_out
     type(particle_set_t), intent(in) :: pset_in
     integer :: i, n, n_col_rem
     n_col_rem = 0
     do i = 1, pset_in%n_tot
        if (pset_in%prt(i)%get_status () == PRT_BEAM_REMNANT .and. &
             any (pset_in%prt(i)%get_color () /= 0)) then
           n_col_rem = n_col_rem + 1
        end if
     end do
     pset_out%n_beam = pset_in%n_beam
     pset_out%n_in   = pset_in%n_in
     pset_out%n_vir  = pset_in%n_vir + pset_in%n_out + n_col_rem
     pset_out%n_out  = pset_in%n_out
     pset_out%n_tot  = pset_in%n_tot + pset_in%n_out + n_col_rem
     pset_out%correlated_state = pset_in%correlated_state
     pset_out%factorization_mode = pset_in%factorization_mode
     allocate (pset_out%prt (pset_out%n_tot))
     do i = 1, pset_in%n_tot
        call pset_out%prt(i)%init (pset_in%prt(i))
        call pset_out%prt(i)%set_children (pset_in%prt(i)%child)
        call pset_out%prt(i)%set_parents (pset_in%prt(i)%parent)
     end do
     n = pset_in%n_tot
     do i = 1, pset_in%n_tot
        if (pset_out%prt(i)%get_status () == PRT_OUTGOING .and. &
            all (pset_out%prt(i)%get_color () == 0) .and. &
            .not. pset_out%prt(i)%has_children ()) then
           n = n + 1
           call pset_out%prt(n)%init (pset_out%prt(i))
           call pset_out%prt(i)%reset_status (PRT_VIRTUAL)
           call pset_out%prt(i)%add_child (n)
           call pset_out%prt(i)%set_parents ([i])
        end if
     end do
     if (n_col_rem > 0) then
        do i = 1, n_col_rem
        end do
     end if
   end subroutine particle_set_order_color_lines
 
 @ %def particle_set_order_color_lines
 @
 Eliminate numerical noise
 <<Particles: public>>=
   public :: pacify
 <<Particles: interfaces>>=
   interface pacify
      module procedure pacify_particle
      module procedure pacify_particle_set
   end interface pacify
 
 <<Particles: procedures>>=
   subroutine pacify_particle (prt)
     class(particle_t), intent(inout) :: prt
     real(default) :: e
     e = epsilon (1._default) * energy (prt%p)
     call pacify (prt%p, 10 * e)
     call pacify (prt%p2, 1e4 * e)
   end subroutine pacify_particle
 
   subroutine pacify_particle_set (pset)
     class(particle_set_t), intent(inout) :: pset
     integer :: i
     do i = 1, pset%n_tot
        call pacify (pset%prt(i))
     end do
   end subroutine pacify_particle_set
 
 @ %def pacify
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[particles_ut.f90]]>>=
 <<File header>>
 
 module particles_ut
   use unit_tests
   use particles_uti
 
 <<Standard module head>>
 
 <<Particles: public test>>
 
 contains
 
 <<Particles: test driver>>
 
 end module particles_ut
 @ %def particles_ut
 @
 <<[[particles_uti.f90]]>>=
 <<File header>>
 
 module particles_uti
 
 <<Use kinds>>
   use io_units
   use numeric_utils
   use constants, only: one, tiny_07
   use lorentz
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use state_matrices
   use interactions
   use evaluators
   use model_data
   use subevents
 
   use particles
 
 <<Standard module head>>
 
 <<Particles: test declarations>>
 
 contains
 
 <<Particles: tests>>
 
 <<Particles: test auxiliary>>
 
 end module particles_uti
 @ %def particles_ut
 @ API: driver for the unit tests below.
 <<Particles: public test>>=
   public :: particles_test
 <<Particles: test driver>>=
   subroutine particles_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Particles: execute tests>>
   end subroutine particles_test
 
 @ %def particles_test
 @
 Check the basic setup of the [[particle_set_t]] type:
 Set up a chain of production and decay and factorize the result into
 particles.  The process is $d\bar d \to Z \to q\bar q$.
 <<Particles: execute tests>>=
   call test (particles_1, "particles_1", &
        "check particle_set routines", &
        u, results)
 <<Particles: test declarations>>=
   public :: particles_1
 <<Particles: tests>>=
   subroutine particles_1 (u)
     use os_interface
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(3) :: flv
     type(color_t), dimension(3) :: col
     type(helicity_t), dimension(3) :: hel
     type(quantum_numbers_t), dimension(3) :: qn
     type(vector4_t), dimension(3) :: p
     type(interaction_t), target :: int1, int2
     type(quantum_numbers_mask_t) :: qn_mask_conn
     type(evaluator_t), target :: eval
     type(interaction_t) :: int
     type(particle_set_t) :: particle_set1, particle_set2
     type(particle_set_t) :: particle_set3, particle_set4
     type(subevt_t) :: subevt
     logical :: ok
     integer :: unit, iostat
 
     write (u, "(A)")  "* Test output: Particles"
     write (u, "(A)")  "*   Purpose: test particle_set routines"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Initializing production process"
 
     call int1%basic_init (2, 0, 1, set_relations=.true.)
     call flv%init ([1, -1, 23], model)
     call col%init_col_acl ([0, 0, 0], [0, 0, 0])
     call hel(3)%init (1, 1)
     call qn%init (flv, col, hel)
     call int1%add_state (qn, value=(0.25_default, 0._default))
     call hel(3)%init (1,-1)
     call qn%init (flv, col, hel)
     call int1%add_state (qn, value=(0._default, 0.25_default))
     call hel(3)%init (-1, 1)
     call qn%init (flv, col, hel)
     call int1%add_state (qn, value=(0._default,-0.25_default))
     call hel(3)%init (-1,-1)
     call qn%init (flv, col, hel)
     call int1%add_state (qn, value=(0.25_default, 0._default))
     call hel(3)%init (0, 0)
     call qn%init (flv, col, hel)
     call int1%add_state (qn, value=(0.5_default, 0._default))
     call int1%freeze ()
     p(1) = vector4_moving (45._default, 45._default, 3)
     p(2) = vector4_moving (45._default,-45._default, 3)
     p(3) = p(1) + p(2)
     call int1%set_momenta (p)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup decay process"
 
     call int2%basic_init (1, 0, 2, set_relations=.true.)
     call flv%init ([23, 1, -1], model)
     call col%init_col_acl ([0, 501, 0], [0, 0, 501])
     call hel%init ([1, 1, 1], [1, 1, 1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(1._default, 0._default))
     call hel%init ([1, 1, 1], [-1,-1,-1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(0._default, 0.1_default))
     call hel%init ([-1,-1,-1], [1, 1, 1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(0._default,-0.1_default))
     call hel%init ([-1,-1,-1], [-1,-1,-1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(1._default, 0._default))
     call hel%init ([0, 1,-1], [0, 1,-1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(4._default, 0._default))
     call hel%init ([0,-1, 1], [0, 1,-1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(2._default, 0._default))
     call hel%init ([0, 1,-1], [0,-1, 1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(2._default, 0._default))
     call hel%init ([0,-1, 1], [0,-1, 1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(4._default, 0._default))
     call flv%init ([23, 2, -2], model)
     call hel%init ([0, 1,-1], [0, 1,-1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(0.5_default, 0._default))
     call hel%init ([0,-1, 1], [0,-1, 1])
     call qn%init (flv, col, hel)
     call int2%add_state (qn, value=(0.5_default, 0._default))
     call int2%freeze ()
     p(2) = vector4_moving (45._default, 45._default, 2)
     p(3) = vector4_moving (45._default,-45._default, 2)
     call int2%set_momenta (p)
     call int2%set_source_link (1, int1, 3)
     call int1%basic_write (u)
     call int2%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Concatenate production and decay"
 
     call eval%init_product (int1, int2, qn_mask_conn, &
          connections_are_resonant=.true.)
     call eval%receive_momenta ()
     call eval%evaluate ()
     call eval%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Factorize as subevent (complete, polarized)"
     write (u, "(A)")
 
     int = eval%interaction_t
     call particle_set1%init &
          (ok, int, int, FM_FACTOR_HELICITY, &
           [0.2_default, 0.2_default], .false., .true.)
     call particle_set1%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Factorize as subevent (in/out only, selected helicity)"
     write (u, "(A)")
 
     int = eval%interaction_t
     call particle_set2%init &
          (ok, int, int, FM_SELECT_HELICITY, &
           [0.9_default, 0.9_default], .false., .false.)
     call particle_set2%write (u)
     call particle_set2%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Factorize as subevent (complete, selected helicity)"
     write (u, "(A)")
 
     int = eval%interaction_t
     call particle_set2%init &
          (ok, int, int, FM_SELECT_HELICITY, &
           [0.7_default, 0.7_default], .false., .true.)
     call particle_set2%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  &
          "* Factorize (complete, polarized, correlated); write and read again"
     write (u, "(A)")
 
     int = eval%interaction_t
     call particle_set3%init &
          (ok, int, int, FM_FACTOR_HELICITY, &
           [0.7_default, 0.7_default], .true., .true.)
     call particle_set3%write (u)
 
     unit = free_unit ()
     open (unit, action="readwrite", form="unformatted", status="scratch")
     call particle_set3%write_raw (unit)
     rewind (unit)
     call particle_set4%read_raw (unit, iostat=iostat)
     call particle_set4%set_model (model)
     close (unit)
 
     write (u, "(A)")
     write (u, "(A)")  "* Result from reading"
     write (u, "(A)")
 
     call particle_set4%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Transform to a subevt object"
     write (u, "(A)")
 
     call particle_set4%to_subevt (subevt)
     call subevt_write (subevt, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call particle_set1%final ()
     call particle_set2%final ()
     call particle_set3%final ()
     call particle_set4%final ()
     call eval%final ()
     call int1%final ()
     call int2%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particles_1"
 
   end subroutine particles_1
 
 @ %def particles_1
 @
 Reconstruct a hard interaction from a particle set.
 <<Particles: execute tests>>=
   call test (particles_2, "particles_2", &
        "reconstruct hard interaction", &
        u, results)
 <<Particles: test declarations>>=
   public :: particles_2
 <<Particles: tests>>=
   subroutine particles_2 (u)
 
     integer, intent(in) :: u
     type(interaction_t) :: int
     type(state_flv_content_t) :: state_flv
     type(particle_set_t) :: pset
     type(flavor_t), dimension(:), allocatable :: flv
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer :: i, j
 
     write (u, "(A)")  "* Test output: Particles"
     write (u, "(A)")  "*   Purpose: reconstruct simple interaction"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up a 2 -> 3 interaction"
     write (u, "(A)")  "    + incoming partons marked as virtual"
     write (u, "(A)")  "    + no quantum numbers"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call int%basic_init (0, 2, 3)
     do i = 1, 2
        do j = 3, 5
           call int%relate (i, j)
        end do
     end do
 
     allocate (qn (5))
     call int%add_state (qn)
     call int%freeze ()
 
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually set up a flavor-content record"
     write (u, "(A)")
 
     call state_flv%init (1, &
          mask = [.false., .false., .true., .true., .true.])
     call state_flv%set_entry (1, &
          pdg = [11, 12, 3, 4, 5], &
          map = [1, 2, 3, 4, 5])
 
     call state_flv%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually create a matching particle set"
     write (u, "(A)")
 
     pset%n_beam = 0
     pset%n_in   = 2
     pset%n_vir  = 0
     pset%n_out  = 3
     pset%n_tot  = 5
     allocate (pset%prt (pset%n_tot))
     do i = 1, 2
        call pset%prt(i)%reset_status (PRT_INCOMING)
        call pset%prt(i)%set_children ([3,4,5])
     end do
     do i = 3, 5
        call pset%prt(i)%reset_status (PRT_OUTGOING)
        call pset%prt(i)%set_parents ([1,2])
     end do
     call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
     call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
     call pset%prt(3)%set_momentum (vector4_at_rest (5._default))
     call pset%prt(4)%set_momentum (vector4_at_rest (4._default))
     call pset%prt(5)%set_momentum (vector4_at_rest (3._default))
 
     allocate (flv (5))
     call flv%init ([11,12,5,4,3])
     do i = 1, 5
        call pset%prt(i)%set_flavor (flv(i))
     end do
 
     call pset%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "*   Fill interaction from particle set"
     write (u, "(A)")
 
     call pset%fill_interaction (int, 2, state_flv=state_flv)
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call int%final ()
     call pset%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particles_2"
 
   end subroutine particles_2
 
 @ %def particles_2
 @
 Reconstruct an interaction with beam structure, e.g., a hadronic
 interaction, from a particle set.
 <<Particles: execute tests>>=
   call test (particles_3, "particles_3", &
        "reconstruct interaction with beam structure", &
        u, results)
 <<Particles: test declarations>>=
   public :: particles_3
 <<Particles: tests>>=
   subroutine particles_3 (u)
 
     integer, intent(in) :: u
     type(interaction_t) :: int
     type(state_flv_content_t) :: state_flv
     type(particle_set_t) :: pset
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer :: i, j
 
     write (u, "(A)")  "* Test output: Particles"
     write (u, "(A)")  "*   Purpose: reconstruct simple interaction"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up a 2 -> 2 -> 3 interaction with radiation"
     write (u, "(A)")  "    + no quantum numbers"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call int%basic_init (0, 6, 3)
     call int%relate (1, 3)
     call int%relate (1, 4)
     call int%relate (2, 5)
     call int%relate (2, 6)
     do i = 4, 6, 2
        do j = 7, 9
           call int%relate (i, j)
        end do
     end do
 
     allocate (qn (9))
     call int%add_state (qn)
     call int%freeze ()
 
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually set up a flavor-content record"
     write (u, "(A)")
 
     call state_flv%init (1, &
          mask = [.false., .false., .false., .false., .false., .false., &
          .true., .true., .true.])
     call state_flv%set_entry (1, &
          pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
          map = [1, 2, 3, 4, 5, 6, 7, 8, 9])
 
     call state_flv%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually create a matching particle set"
     write (u, "(A)")
 
     call create_test_particle_set_1 (pset)
 
     call pset%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "*   Fill interaction from particle set"
     write (u, "(A)")
 
     call pset%fill_interaction (int, 2, state_flv=state_flv)
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call int%final ()
     call pset%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particles_3"
 
   end subroutine particles_3
 
 @ %def particles_3
 @
 <<Particles: test auxiliary>>=
   subroutine create_test_particle_set_1 (pset)
     type(particle_set_t), intent(out) :: pset
     type(flavor_t), dimension(:), allocatable :: flv
     integer :: i
     pset%n_beam = 2
     pset%n_in   = 2
     pset%n_vir  = 2
     pset%n_out  = 3
     pset%n_tot  = 9
 
     allocate (pset%prt (pset%n_tot))
     call pset%prt(1)%reset_status (PRT_BEAM)
     call pset%prt(2)%reset_status (PRT_BEAM)
     call pset%prt(3)%reset_status (PRT_INCOMING)
     call pset%prt(4)%reset_status (PRT_INCOMING)
     call pset%prt(5)%reset_status (PRT_BEAM_REMNANT)
     call pset%prt(6)%reset_status (PRT_BEAM_REMNANT)
     call pset%prt(7)%reset_status (PRT_OUTGOING)
     call pset%prt(8)%reset_status (PRT_OUTGOING)
     call pset%prt(9)%reset_status (PRT_OUTGOING)
 
     call pset%prt(1)%set_children ([3,5])
     call pset%prt(2)%set_children ([4,6])
     call pset%prt(3)%set_children ([7,8,9])
     call pset%prt(4)%set_children ([7,8,9])
 
     call pset%prt(3)%set_parents ([1])
     call pset%prt(4)%set_parents ([2])
     call pset%prt(5)%set_parents ([1])
     call pset%prt(6)%set_parents ([2])
     call pset%prt(7)%set_parents ([3,4])
     call pset%prt(8)%set_parents ([3,4])
     call pset%prt(9)%set_parents ([3,4])
 
     call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
     call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
     call pset%prt(3)%set_momentum (vector4_at_rest (4._default))
     call pset%prt(4)%set_momentum (vector4_at_rest (6._default))
     call pset%prt(5)%set_momentum (vector4_at_rest (3._default))
     call pset%prt(6)%set_momentum (vector4_at_rest (5._default))
     call pset%prt(7)%set_momentum (vector4_at_rest (7._default))
     call pset%prt(8)%set_momentum (vector4_at_rest (8._default))
     call pset%prt(9)%set_momentum (vector4_at_rest (9._default))
 
     allocate (flv (9))
     call flv%init ([2011, 2012, 11, 12, 91, 92, 3, 4, 5])
     do i = 1, 9
        call pset%prt(i)%set_flavor (flv(i))
     end do
   end subroutine create_test_particle_set_1
 
 @ %def create_test_particle_set_1
 
 @
 Reconstruct an interaction with beam structure, e.g., a hadronic
 interaction, from a particle set that is missing the beam information.
 <<Particles: execute tests>>=
   call test (particles_4, "particles_4", &
        "reconstruct interaction with missing beams", &
        u, results)
 <<Particles: test declarations>>=
   public :: particles_4
 <<Particles: tests>>=
   subroutine particles_4 (u)
 
     integer, intent(in) :: u
     type(interaction_t) :: int
     type(interaction_t), target :: int_beams
     type(state_flv_content_t) :: state_flv
     type(particle_set_t) :: pset
     type(flavor_t), dimension(:), allocatable :: flv
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer :: i, j
 
     write (u, "(A)")  "* Test output: Particles"
     write (u, "(A)")  "*   Purpose: reconstruct beams"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     write (u, "(A)")  "* Set up an interaction that contains beams only"
     write (u, "(A)")
 
     call int_beams%basic_init (0, 0, 2)
     call int_beams%set_momentum (vector4_at_rest (1._default), 1)
     call int_beams%set_momentum (vector4_at_rest (2._default), 2)
     allocate (qn (2))
     call int_beams%add_state (qn)
     call int_beams%freeze ()
 
     call int_beams%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up a 2 -> 2 -> 3 interaction with radiation"
     write (u, "(A)")  "    + no quantum numbers"
     write (u, "(A)")
 
     call int%basic_init (0, 6, 3)
     call int%relate (1, 3)
     call int%relate (1, 4)
     call int%relate (2, 5)
     call int%relate (2, 6)
     do i = 4, 6, 2
        do j = 7, 9
           call int%relate (i, j)
        end do
     end do
     do i = 1, 2
        call int%set_source_link (i, int_beams, i)
     end do
 
     deallocate (qn)
     allocate (qn (9))
     call int%add_state (qn)
     call int%freeze ()
 
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually set up a flavor-content record"
     write (u, "(A)")
 
     call state_flv%init (1, &
          mask = [.false., .false., .false., .false., .false., .false., &
          .true., .true., .true.])
     call state_flv%set_entry (1, &
          pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
          map = [1, 2, 3, 4, 5, 6, 7, 8, 9])
 
     call state_flv%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually create a matching particle set"
     write (u, "(A)")
 
     pset%n_beam = 0
     pset%n_in   = 2
     pset%n_vir  = 0
     pset%n_out  = 3
     pset%n_tot  = 5
 
     allocate (pset%prt (pset%n_tot))
     call pset%prt(1)%reset_status (PRT_INCOMING)
     call pset%prt(2)%reset_status (PRT_INCOMING)
     call pset%prt(3)%reset_status (PRT_OUTGOING)
     call pset%prt(4)%reset_status (PRT_OUTGOING)
     call pset%prt(5)%reset_status (PRT_OUTGOING)
 
     call pset%prt(1)%set_children ([3,4,5])
     call pset%prt(2)%set_children ([3,4,5])
 
     call pset%prt(3)%set_parents ([1,2])
     call pset%prt(4)%set_parents ([1,2])
     call pset%prt(5)%set_parents ([1,2])
 
     call pset%prt(1)%set_momentum (vector4_at_rest (6._default))
     call pset%prt(2)%set_momentum (vector4_at_rest (6._default))
     call pset%prt(3)%set_momentum (vector4_at_rest (3._default))
     call pset%prt(4)%set_momentum (vector4_at_rest (4._default))
     call pset%prt(5)%set_momentum (vector4_at_rest (5._default))
 
     allocate (flv (5))
     call flv%init ([11, 12, 3, 4, 5])
     do i = 1, 5
        call pset%prt(i)%set_flavor (flv(i))
     end do
 
     call pset%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "*   Fill interaction from particle set"
     write (u, "(A)")
 
     call pset%fill_interaction (int, 2, state_flv=state_flv, &
          recover_beams = .true.)
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call int%final ()
     call pset%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particles_4"
 
   end subroutine particles_4
 
 @ %def particles_4
 @
 Reconstruct an interaction with beam structure and cloned particles
 (radiated particles repeated in the event record, to maintain some
 canonical ordering).
 <<Particles: execute tests>>=
   call test (particles_5, "particles_5", &
        "reconstruct interaction with beams and duplicate entries", &
        u, results)
 <<Particles: test declarations>>=
   public :: particles_5
 <<Particles: tests>>=
   subroutine particles_5 (u)
 
     integer, intent(in) :: u
     type(interaction_t) :: int
     type(state_flv_content_t) :: state_flv
     type(particle_set_t) :: pset
     type(flavor_t), dimension(:), allocatable :: flv
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer :: i, j
 
     write (u, "(A)")  "* Test output: Particles"
     write (u, "(A)")  "*   Purpose: reconstruct event with duplicate entries"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up a 2 -> 2 -> 3 interaction with radiation"
     write (u, "(A)")  "    + no quantum numbers"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call int%basic_init (0, 6, 3)
     call int%relate (1, 3)
     call int%relate (1, 4)
     call int%relate (2, 5)
     call int%relate (2, 6)
     do i = 4, 6, 2
        do j = 7, 9
           call int%relate (i, j)
        end do
     end do
 
     allocate (qn (9))
     call int%add_state (qn)
     call int%freeze ()
 
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually set up a flavor-content record"
     write (u, "(A)")
 
     call state_flv%init (1, &
          mask = [.false., .false., .false., .false., .false., .false., &
          .true., .true., .true.])
     call state_flv%set_entry (1, &
          pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
          map = [1, 2, 3, 4, 5, 6, 7, 8, 9])
 
     call state_flv%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually create a matching particle set"
     write (u, "(A)")
 
     pset%n_beam = 2
     pset%n_in   = 2
     pset%n_vir  = 4
     pset%n_out  = 5
     pset%n_tot  = 13
 
     allocate (pset%prt (pset%n_tot))
     call pset%prt(1)%reset_status (PRT_BEAM)
     call pset%prt(2)%reset_status (PRT_BEAM)
     call pset%prt(3)%reset_status (PRT_VIRTUAL)
     call pset%prt(4)%reset_status (PRT_VIRTUAL)
     call pset%prt(5)%reset_status (PRT_VIRTUAL)
     call pset%prt(6)%reset_status (PRT_VIRTUAL)
     call pset%prt(7)%reset_status (PRT_INCOMING)
     call pset%prt(8)%reset_status (PRT_INCOMING)
     call pset%prt( 9)%reset_status (PRT_OUTGOING)
     call pset%prt(10)%reset_status (PRT_OUTGOING)
     call pset%prt(11)%reset_status (PRT_OUTGOING)
     call pset%prt(12)%reset_status (PRT_OUTGOING)
     call pset%prt(13)%reset_status (PRT_OUTGOING)
 
     call pset%prt(1)%set_children ([3,4])
     call pset%prt(2)%set_children ([5,6])
     call pset%prt(3)%set_children ([ 7])
     call pset%prt(4)%set_children ([ 9])
     call pset%prt(5)%set_children ([ 8])
     call pset%prt(6)%set_children ([10])
     call pset%prt(7)%set_children ([11,12,13])
     call pset%prt(8)%set_children ([11,12,13])
 
     call pset%prt(3)%set_parents ([1])
     call pset%prt(4)%set_parents ([1])
     call pset%prt(5)%set_parents ([2])
     call pset%prt(6)%set_parents ([2])
     call pset%prt( 7)%set_parents ([3])
     call pset%prt( 8)%set_parents ([5])
     call pset%prt( 9)%set_parents ([4])
     call pset%prt(10)%set_parents ([6])
     call pset%prt(11)%set_parents ([7,8])
     call pset%prt(12)%set_parents ([7,8])
     call pset%prt(13)%set_parents ([7,8])
 
     call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
     call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
     call pset%prt(3)%set_momentum (vector4_at_rest (4._default))
     call pset%prt(4)%set_momentum (vector4_at_rest (3._default))
     call pset%prt(5)%set_momentum (vector4_at_rest (6._default))
     call pset%prt(6)%set_momentum (vector4_at_rest (5._default))
     call pset%prt(7)%set_momentum (vector4_at_rest (4._default))
     call pset%prt(8)%set_momentum (vector4_at_rest (6._default))
     call pset%prt( 9)%set_momentum (vector4_at_rest (3._default))
     call pset%prt(10)%set_momentum (vector4_at_rest (5._default))
     call pset%prt(11)%set_momentum (vector4_at_rest (7._default))
     call pset%prt(12)%set_momentum (vector4_at_rest (8._default))
     call pset%prt(13)%set_momentum (vector4_at_rest (9._default))
 
     allocate (flv (13))
     call flv%init ([2011, 2012, 11, 91, 12, 92, 11, 12, 91, 92, 3, 4, 5])
     do i = 1, 13
        call pset%prt(i)%set_flavor (flv(i))
     end do
 
     call pset%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "*   Fill interaction from particle set"
     write (u, "(A)")
 
     call pset%fill_interaction (int, 2, state_flv=state_flv)
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call int%final ()
     call pset%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particles_5"
 
   end subroutine particles_5
 
 @ %def particles_5
 @
 Reconstruct an interaction with pair spectrum, e.g., beamstrahlung from a
 particle set.
 <<Particles: execute tests>>=
   call test (particles_6, "particles_6", &
        "reconstruct interaction with pair spectrum", &
        u, results)
 <<Particles: test declarations>>=
   public :: particles_6
 <<Particles: tests>>=
   subroutine particles_6 (u)
 
     integer, intent(in) :: u
     type(interaction_t) :: int
     type(state_flv_content_t) :: state_flv
     type(particle_set_t) :: pset
     type(flavor_t), dimension(:), allocatable :: flv
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer :: i, j
 
     write (u, "(A)")  "* Test output: Particles"
     write (u, "(A)")  "*   Purpose: reconstruct interaction with pair spectrum"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up a 2 -> 2 -> 3 interaction with radiation"
     write (u, "(A)")  "    + no quantum numbers"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call int%basic_init (0, 6, 3)
     do i = 1, 2
        do j = 3, 6
           call int%relate (i, j)
        end do
     end do
     do i = 5, 6
        do j = 7, 9
           call int%relate (i, j)
        end do
     end do
 
     allocate (qn (9))
     call int%add_state (qn)
     call int%freeze ()
 
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually set up a flavor-content record"
     write (u, "(A)")
 
     call state_flv%init (1, &
          mask = [.false., .false., .false., .false., .false., .false., &
          .true., .true., .true.])
     call state_flv%set_entry (1, &
          pdg = [1011, 1012, 21, 22, 11, 12, 3, 4, 5], &
          map = [1, 2, 3, 4, 5, 6, 7, 8, 9])
 
     call state_flv%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually create a matching particle set"
     write (u, "(A)")
 
     pset%n_beam = 2
     pset%n_in   = 2
     pset%n_vir  = 2
     pset%n_out  = 3
     pset%n_tot  = 9
 
     allocate (pset%prt (pset%n_tot))
     call pset%prt(1)%reset_status (PRT_BEAM)
     call pset%prt(2)%reset_status (PRT_BEAM)
     call pset%prt(3)%reset_status (PRT_INCOMING)
     call pset%prt(4)%reset_status (PRT_INCOMING)
     call pset%prt(5)%reset_status (PRT_OUTGOING)
     call pset%prt(6)%reset_status (PRT_OUTGOING)
     call pset%prt(7)%reset_status (PRT_OUTGOING)
     call pset%prt(8)%reset_status (PRT_OUTGOING)
     call pset%prt(9)%reset_status (PRT_OUTGOING)
 
     call pset%prt(1)%set_children ([3,4,5,6])
     call pset%prt(2)%set_children ([3,4,5,6])
     call pset%prt(3)%set_children ([7,8,9])
     call pset%prt(4)%set_children ([7,8,9])
 
     call pset%prt(3)%set_parents ([1,2])
     call pset%prt(4)%set_parents ([1,2])
     call pset%prt(5)%set_parents ([1,2])
     call pset%prt(6)%set_parents ([1,2])
     call pset%prt(7)%set_parents ([3,4])
     call pset%prt(8)%set_parents ([3,4])
     call pset%prt(9)%set_parents ([3,4])
 
     call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
     call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
     call pset%prt(3)%set_momentum (vector4_at_rest (5._default))
     call pset%prt(4)%set_momentum (vector4_at_rest (6._default))
     call pset%prt(5)%set_momentum (vector4_at_rest (3._default))
     call pset%prt(6)%set_momentum (vector4_at_rest (4._default))
     call pset%prt(7)%set_momentum (vector4_at_rest (7._default))
     call pset%prt(8)%set_momentum (vector4_at_rest (8._default))
     call pset%prt(9)%set_momentum (vector4_at_rest (9._default))
 
     allocate (flv (9))
     call flv%init ([1011, 1012, 11, 12, 21, 22, 3, 4, 5])
     do i = 1, 9
        call pset%prt(i)%set_flavor (flv(i))
     end do
 
     call pset%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "*   Fill interaction from particle set"
     write (u, "(A)")
 
     call pset%fill_interaction (int, 2, state_flv=state_flv)
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call int%final ()
     call pset%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particles_6"
 
   end subroutine particles_6
 
 @ %def particles_6
 @
 Reconstruct a hard decay interaction from a shuffled particle set.
 <<Particles: execute tests>>=
   call test (particles_7, "particles_7", &
        "reconstruct decay interaction with reordering", &
        u, results)
 <<Particles: test declarations>>=
   public :: particles_7
 <<Particles: tests>>=
   subroutine particles_7 (u)
 
     integer, intent(in) :: u
     type(interaction_t) :: int
     type(state_flv_content_t) :: state_flv
     type(particle_set_t) :: pset
     type(flavor_t), dimension(:), allocatable :: flv
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer :: i, j
 
     write (u, "(A)")  "* Test output: Particles"
     write (u, "(A)")  "*   Purpose: reconstruct decay interaction with reordering"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up a 1 -> 3 interaction"
     write (u, "(A)")  "    + no quantum numbers"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call int%basic_init (0, 1, 3)
     do j = 2, 4
        call int%relate (1, j)
     end do
 
     allocate (qn (4))
     call int%add_state (qn)
     call int%freeze ()
 
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually set up a flavor-content record"
     write (u, "(A)")  "*   assumed interaction: 6 12 5 -11"
     write (u, "(A)")
 
     call state_flv%init (1, &
          mask = [.false., .true., .true., .true.])
     call state_flv%set_entry (1, &
          pdg = [6, 5, -11, 12], &
          map = [1, 4, 2, 3])
 
     call state_flv%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Manually create a matching particle set"
     write (u, "(A)")
 
     pset%n_beam = 0
     pset%n_in   = 1
     pset%n_vir  = 0
     pset%n_out  = 3
     pset%n_tot  = 4
     allocate (pset%prt (pset%n_tot))
     do i = 1, 1
        call pset%prt(i)%reset_status (PRT_INCOMING)
        call pset%prt(i)%set_children ([2,3,4])
     end do
     do i = 2, 4
        call pset%prt(i)%reset_status (PRT_OUTGOING)
        call pset%prt(i)%set_parents ([1])
     end do
     call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
     call pset%prt(2)%set_momentum (vector4_at_rest (3._default))
     call pset%prt(3)%set_momentum (vector4_at_rest (2._default))
     call pset%prt(4)%set_momentum (vector4_at_rest (4._default))
 
     allocate (flv (4))
     call flv%init ([6,5,12,-11])
     do i = 1, 4
        call pset%prt(i)%set_flavor (flv(i))
     end do
 
     call pset%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "*   Fill interaction from particle set"
     write (u, "(A)")
 
     call pset%fill_interaction (int, 1, state_flv=state_flv)
     call int%basic_write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call int%final ()
     call pset%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particles_7"
 
   end subroutine particles_7
 
 @ %def particles_7
 @
 <<Particles: execute tests>>=
   call test (particles_8, "particles_8", &
             "Test functions on particle sets", u, results)
 <<Particles: test declarations>>=
   public :: particles_8
 <<Particles: tests>>=
   subroutine particles_8 (u)
     integer, intent(in) :: u
     type(particle_set_t) :: particle_set
     type(particle_t), dimension(:), allocatable :: particles
     integer, allocatable, dimension(:) :: children, parents
     integer :: n_particles, i
     write (u, "(A)")  "* Test output: particles_8"
     write (u, "(A)")  "*   Purpose: Test functions on particle sets"
     write (u, "(A)")
 
     call create_test_particle_set_1 (particle_set)
     call particle_set%write (u)
     call assert_equal (u, particle_set%n_tot, 9)
     call assert_equal (u, particle_set%n_beam, 2)
     allocate (children (particle_set%prt(3)%get_n_children ()))
     children = particle_set%prt(3)%get_children()
     call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3)
     call assert_equal (u, size (particle_set%prt(1)%get_children ()), 2)
     call assert_equal (u, size (particle_set%prt(2)%get_children ()), 2)
 
     call particle_set%without_hadronic_remnants &
          (particles, n_particles, 3)
     call particle_set%replace (particles)
     write (u, "(A)")
     call particle_set%write (u)
 
     call assert_equal (u, n_particles, 7)
     call assert_equal (u, size(particles), 10)
     call assert_equal (u, particle_set%n_tot, 10)
     call assert_equal (u, particle_set%n_beam, 2)
     do i = 3, 4
        if (allocated (children))  deallocate (children)
        allocate (children (particle_set%prt(i)%get_n_children ()))
        children = particle_set%prt(i)%get_children()
        call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3)
        call assert_equal (u, particle_set%prt(children(2))%get_pdg (), 4)
        call assert_equal (u, particle_set%prt(children(3))%get_pdg (), 5)
     end do
     do i = 5, 7
        if (allocated (parents))  deallocate (parents)
        allocate (parents (particle_set%prt(i)%get_n_parents ()))
        parents = particle_set%prt(i)%get_parents()
        call assert_equal (u, particle_set%prt(parents(1))%get_pdg (), 11)
        call assert_equal (u, particle_set%prt(parents(2))%get_pdg (), 12)
     end do
     call assert_equal (u, size (particle_set%prt(1)%get_children ()), &
          1, "get children of 1")
     call assert_equal (u, size (particle_set%prt(2)%get_children ()), &
          1, "get children of 2")
 
     call assert_equal (u, particle_set%find_particle &
          (particle_set%prt(1)%get_pdg (), particle_set%prt(1)%p), &
          1, "find 1st particle")
     call assert_equal (u, particle_set%find_particle &
          (particle_set%prt(2)%get_pdg (), particle_set%prt(2)%p * &
           (one + tiny_07), rel_smallness=1.0E-6_default), &
          2, "find 2nd particle fuzzy")
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: particles_8"
   end subroutine particles_8
 
 @ %def particles_8
 @
 Order color lines into Lund string systems, without colored beam
 remnants first.
 <<Particles: execute tests>>=
   call test (particles_9, "particles_9", &
        "order into Lund strings, uncolored beam remnants", &
        u, results)
 <<Particles: test declarations>>=
   public :: particles_9
 <<Particles: tests>>=
   subroutine particles_9 (u)
     integer, intent(in) :: u
     write (u, "(A)")  "* Test output: particles_9"
     write (u, "(A)")  "*   Purpose: Order into Lund strings, "
     write (u, "(A)")  "*              uncolored beam remnants"
     write (u, "(A)")
   end subroutine particles_9
 
 @  %def particles_9
-
-
-
Index: trunk/share/tests/ext_tests_nlo/ref-output/nlo_ppjj_real_partition.ref
===================================================================
--- trunk/share/tests/ext_tests_nlo/ref-output/nlo_ppjj_real_partition.ref	(revision 0)
+++ trunk/share/tests/ext_tests_nlo/ref-output/nlo_ppjj_real_partition.ref	(revision 8733)
@@ -0,0 +1,190 @@
+?openmp_logging = false
+?vis_history = false
+?integration_timer = false
+openmp_num_threads = 1
+?debug_decay = false
+?debug_process = false
+?debug_verbose = false
+?write_raw = false
+| Switching to model 'SM', scheme 'GF_MW_MZ'
+$blha_ew_scheme = "alpha_qed"
+SM.mZ =>  9.118800000000E+01
+SM.mW =>  8.041900200000E+01
+SM.mH =>  1.250000000000E+02
+SM.GF =>  1.166390000000E-05
+SM.wZ =>  0.000000000000E+00
+SM.wtop =>  0.000000000000E+00
+SM.wW =>  0.000000000000E+00
+SM.wH =>  0.000000000000E+00
+SM.ms =>  0.000000000000E+00
+SM.mc =>  0.000000000000E+00
+SM.mb =>  0.000000000000E+00
+SM.mtop =>  1.732000000000E+02
+SM.me =>  0.000000000000E+00
+SM.mmu =>  0.000000000000E+00
+SM.mtau =>  1.777000000000E+00
+SM.alphas =>  1.180000000000E-01
+?alphas_is_fixed = false
+?alphas_from_mz = true
+?alphas_from_lambda_qcd = false
+alphas_nf = 5
+alphas_order = 2
+[user variable] jet = PDG(2, -2, 1, -1, 3, -3, 4, -4, 5, -5, 21)
+$exclude_gauge_splittings = "t"
+$method = "openloops"
+seed = 8131
+sqrts =  1.000000000000E+03
+jet_algorithm = 2
+jet_r =  5.000000000000E-01
+$integration_method = "vamp2"
+$rng_method = "rng_stream"
+| End of included 'nlo_settings.sin'
+?pacify = true
+[user variable] pr = PDG(2, -2, 1, -1, 3, -3, 21)
+[user variable] jet = PDG(2, -2, 1, -1, 3, -3, 21)
+$exclude_gauge_splittings = "c:b:t"
+?alphas_from_mz = false
+?alphas_from_lhapdf = true
+alphas_nf = 5
+alphas_order = 2
+alpha_power = 0
+alphas_power = 2
+$lhapdf_file = "MSTW2008nlo68cl"
+sqrts =  1.30000E+04
+$rng_method = "rng_stream"
+$integration_method = "vamp2"
+?nlo_use_real_partition = true
+real_partition_scale =  1.00000E+01
+$restrictions = "!W+:W-"
+| Process library 'nlo_ppjj_real_partition_lib': recorded process 'ppjj_wp'
+| Integrate: current process library needs compilation
+| Process library 'nlo_ppjj_real_partition_lib': compiling ...
+| Process library 'nlo_ppjj_real_partition_lib': writing makefile
+| Process library 'nlo_ppjj_real_partition_lib': removing old files
+| Process library 'nlo_ppjj_real_partition_lib': writing driver
+| Process library 'nlo_ppjj_real_partition_lib': creating source code
+| Process library 'nlo_ppjj_real_partition_lib': compiling sources
+| Process library 'nlo_ppjj_real_partition_lib': linking
+| Process library 'nlo_ppjj_real_partition_lib': loading
+| Process library 'nlo_ppjj_real_partition_lib': ... success.
+| Integrate: compilation done
+| QCD alpha: using a running strong coupling
+| RNG: Initializing RNG Stream random-number generator
+| RNG: Setting seed for random-number generator to 8131
+| Initializing integration for process ppjj_wp:
+| Beam structure: p, p => lhapdf
+| Beam data (collision):
+|   p  (mass = 0.0000000E+00 GeV)
+|   p  (mass = 0.0000000E+00 GeV)
+|   sqrts = 1.300000000000E+04 GeV
+| Phase space: generating configuration ...
+Warning:  Intermediate decay of zero-width particle Z may be possible.
+Warning:  Intermediate decay of zero-width particle W+ may be possible.
+Warning:  Intermediate decay of zero-width particle W- may be possible.
+| Phase space: ... success.
+| Phase space: writing configuration file 'ppjj_wp.i1.phs'
+| Phase space: generating configuration ...
+| Phase space: ... success.
+| Phase space: writing configuration file 'ppjj_wp.i3.phs'
+| Phase space: generating configuration ...
+| Phase space: ... success.
+| Phase space: writing configuration file 'ppjj_wp.i6.phs'
+| One-Loop-Provider: Using OpenLoops
+| Loading library: [...]
+| One-Loop-Provider: Using OpenLoops
+| Loading library: [...]
+| One-Loop-Provider: Using OpenLoops
+| Loading library: [...]
+| One-Loop-Provider: Using OpenLoops
+| Loading library: [...]
+| ------------------------------------------------------------------------
+| Process [scattering]: 'ppjj_wp'
+|   Library name  = 'nlo_ppjj_real_partition_lib'
+|   Process index = 1
+|   Process components:
+|     1: 'ppjj_wp_i1':   u:ubar:d:dbar:s:sbar:gl, u:ubar:d:dbar:s:sbar:gl => u:ubar:d:dbar:s:sbar:gl, u:ubar:d:dbar:s:sbar:gl [inactive]
+|     2: 'ppjj_wp_i2':   dbar:d:ubar:u:sbar:s:gl, dbar:d:ubar:u:sbar:s:gl => d:dbar:u:ubar:s:sbar:gl, d:dbar:u:ubar:s:sbar:gl, d:dbar:u:ubar:s:sbar:gl [openloops], [real]
+|     3: 'ppjj_wp_i3':   u:ubar:d:dbar:s:sbar:gl, u:ubar:d:dbar:s:sbar:gl => u:ubar:d:dbar:s:sbar:gl, u:ubar:d:dbar:s:sbar:gl [inactive], [virtual]
+|     4: 'ppjj_wp_i4':   u:ubar:d:dbar:s:sbar:gl, u:ubar:d:dbar:s:sbar:gl => u:ubar:d:dbar:s:sbar:gl, u:ubar:d:dbar:s:sbar:gl [inactive], [subtraction]
+|     5: 'ppjj_wp_i5':   u:ubar:d:dbar:s:sbar:gl, u:ubar:d:dbar:s:sbar:gl => u:ubar:d:dbar:s:sbar:gl, u:ubar:d:dbar:s:sbar:gl [inactive], [dglap]
+|     6: 'ppjj_wp_i6':   dbar:d:ubar:u:sbar:s:gl, dbar:d:ubar:u:sbar:s:gl => d:dbar:u:ubar:s:sbar:gl, d:dbar:u:ubar:s:sbar:gl, d:dbar:u:ubar:s:sbar:gl [openloops], [real]
+| ------------------------------------------------------------------------
+| Phase space: 5 channels, 2 dimensions
+| Phase space: found 5 channels, collected in 2 groves.
+| Phase space: Using 18 equivalences between channels.
+| Phase space: wood
+| Phase space: 5 channels, 5 dimensions
+| Phase space: found 5 channels, collected in 2 groves.
+| Phase space: Using 18 equivalences between channels.
+| Phase space: wood
+| Phase space: 5 channels, 2 dimensions
+| Phase space: found 5 channels, collected in 2 groves.
+| Phase space: Using 18 equivalences between channels.
+| Phase space: wood
+| Phase space: 5 channels, 3 dimensions
+| Phase space: found 5 channels, collected in 2 groves.
+| Phase space: Using 18 equivalences between channels.
+| Phase space: wood
+| Phase space: 57 channels, 5 dimensions
+| Phase space: found 57 channels, collected in 8 groves.
+| Phase space: Using 170 equivalences between channels.
+| Phase space: wood
+| Beam structure: lhapdf, none => none, lhapdf
+| Beam structure: 1 channels, 2 dimensions
+| Applying user-defined cuts.
+| Using user-defined general scale.
+| Starting integration for process 'ppjj_wp' part 'real'
+| Integrate: iterations = 2:1000:"gw", 2:1000
+| Integrator: 2 chains, 5 channels, 7 dimensions
+| Integrator: Using VAMP2 channel equivalences
+| Integrator: Write grid header and grids to 'ppjj_wp.m2.vg2'
+| Integrator: Grid checkpoint after each iteration
+| Integrator: 1000 initial calls, 20 max. bins, stratified = T
+| Integrator: VAMP2
+|=============================================================================|
+| It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
+|=============================================================================|
+| VAMP2: Initialize new grids and write to file 'ppjj_wp.m2.vg2'.
+| VAMP2: set chain: use chained weights.
+   1        932    -3.010E+09   1.68E+09   55.73   17.01     0.6
+   2        980    -5.270E+09   1.61E+09   30.63    9.59     1.3
+|-----------------------------------------------------------------------------|
+   2       1912    -4.183E+09   1.16E+09   27.81   12.16     1.3    0.94   2
+|-----------------------------------------------------------------------------|
+   3        980    -6.109E+09   7.80E+08   12.77    4.00     2.5
+   4        980    -5.506E+09   5.68E+08   10.32    3.23     3.9
+|-----------------------------------------------------------------------------|
+   4       1960    -5.715E+09   4.59E+08    8.04    3.56     3.9    0.39   2
+|=============================================================================|
+| Starting integration for process 'ppjj_wp' part 'real'
+| Integrate: iterations = 2:1000:"gw", 2:1000
+| Integrator: 8 chains, 57 channels, 7 dimensions
+| Integrator: Using VAMP2 channel equivalences
+| Integrator: Write grid header and grids to 'ppjj_wp.m5.vg2'
+| Integrator: Grid checkpoint after each iteration
+| Integrator: 1000 initial calls, 20 max. bins, stratified = T
+| Integrator: VAMP2
+|=============================================================================|
+| It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
+|=============================================================================|
+| VAMP2: Initialize new grids and write to file 'ppjj_wp.m5.vg2'.
+| VAMP2: set chain: use chained weights.
+   1       1006     9.749E+09   6.29E+09   64.55   20.47     5.7
+   2       1000     4.877E+09   1.16E+09   23.82    7.53     6.0
+|-----------------------------------------------------------------------------|
+   2       2006     5.037E+09   1.14E+09   22.68   10.16     6.0    0.58   2
+|-----------------------------------------------------------------------------|
+   3       1000     6.069E+09   1.71E+09   28.15    8.90     5.6
+   4       1000     4.310E+09   9.16E+08   21.26    6.72     6.3
+|-----------------------------------------------------------------------------|
+   4       2000     4.703E+09   8.07E+08   17.17    7.68     6.3    0.82   2
+|=============================================================================|
+| Integrate: sum of all components
+|=============================================================================|
+| It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
+|=============================================================================|
+   1          0    -1.012E+09   9.29E+08   91.78    0.00    -1.3
+|=============================================================================|
+| There were no errors and    3 warning(s).
+| WHIZARD run finished.
+|=============================================================================|
Index: trunk/share/tests/ext_tests_nlo/nlo_ppjj_real_partition.sin
===================================================================
--- trunk/share/tests/ext_tests_nlo/nlo_ppjj_real_partition.sin	(revision 0)
+++ trunk/share/tests/ext_tests_nlo/nlo_ppjj_real_partition.sin	(revision 8733)
@@ -0,0 +1,63 @@
+include("nlo_settings.sin")
+
+?pacify = true
+
+alias pr = u:U:d:D:s:S:gl
+alias jet = u:U:d:D:s:S:gl
+$exclude_gauge_splittings = "c:b:t"
+
+?alphas_from_mz = false
+?alphas_from_lhapdf = true
+alphas_nf = 5
+alphas_order = 2
+
+alpha_power = 0
+alphas_power = 2
+
+beams = p, p => lhapdf
+$lhapdf_file = "MSTW2008nlo68cl"
+
+sqrts = 13 TeV
+
+# Settings for MPI
+$rng_method = "rng_stream"
+$integration_method = "vamp2"
+
+cuts = let subevt @clustered_jets = cluster [jet] in
+       let subevt @pt_selected = select if Pt > 80 GeV [@clustered_jets] in
+       let subevt @eta_selected = select if abs(Eta) < 4 [@pt_selected] in
+       let subevt @hardest_jets = select if Pt > 100 GeV [@eta_selected] in
+       count [@eta_selected] >= 2 and count [@hardest_jets] >= 1
+
+scale = let int njet = count [jet] in
+        if njet == 2 then
+          ( eval Pt [extract index 1 [jet]]
+          + eval Pt [extract index 2 [jet]]) / 2
+        elsif njet == 3 then
+          ( eval Pt [extract index 1 [jet]]
+          + eval Pt [extract index 2 [jet]]
+          + eval Pt [extract index 3 [jet]]) / 2
+        else
+          sqrts
+        endif
+
+
+
+!process ppjj_np = pr, pr => jet, jet { nlo_calculation = real $restrictions="!W+:W-" }
+
+?nlo_use_real_partition = true
+real_partition_scale = 10 GeV
+
+process ppjj_wp = pr, pr => jet, jet { nlo_calculation = real $restrictions="!W+:W-" }
+
+!mult_call_real = 2
+
+!integrate (ppjj_np) { iterations = 10:2000000:"gw",5:2000000 }
+!integrate (ppjj_wp) { iterations = 10:2000000:"gw",5:2000000 }
+
+!expect (integral(ppjj_np) == integral(ppjj_wp))
+!{
+!  tolerance = sqrt (error(ppjj_np)**2 + error(ppjj_wp)**2)
+!}
+
+integrate (ppjj_wp) { iterations = 2:1000:"gw",2:1000 }
Index: trunk/share/tests/Makefile.am
===================================================================
--- trunk/share/tests/Makefile.am	(revision 8732)
+++ trunk/share/tests/Makefile.am	(revision 8733)
@@ -1,1581 +1,1583 @@
 ## Makefile.am -- Makefile for WHIZARD tests
 ##
 ## Process this file with automake to produce Makefile.in
 ##
 ########################################################################
 #
 # Copyright (C) 1999-2021 by
 #     Wolfgang Kilian <kilian@physik.uni-siegen.de>
 #     Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
 #     Juergen Reuter <juergen.reuter@desy.de>
 #     with contributions from
 #     cf. main AUTHORS file
 #
 # WHIZARD is free software; you can redistribute it and/or modify it
 # under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 2, or (at your option)
 # any later version.
 #
 # WHIZARD is distributed in the hope that it will be useful, but
 # WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.
 #
 # You should have received a copy of the GNU General Public License
 # along with this program; if not, write to the Free Software
 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #
 ########################################################################
 
 EXTRA_DIST = \
     $(TESTSUITE_MACROS) $(TESTSUITES_M4) $(TESTSUITES_SIN) \
     $(TESTSUITE_TOOLS) \
     $(REF_OUTPUT_FILES) \
     cascades2_1.fds \
     cascades2_2.fds \
     cascades2_lexer_1.fds \
     ext_tests_nmssm/nmssm.slha \
     functional_tests/structure_2_inc.sin functional_tests/testproc_3.phs \
     functional_tests/susyhit.in \
     functional_tests/ufo_5_test.slha
 
 TESTSUITE_MACROS = testsuite.m4
 TESTSUITE_TOOLS = \
     check-debug-output.py \
     check-debug-output-hadro.py \
     check-hepmc-weights.py \
     compare-histograms.py \
     compare-integrals.py \
     compare-integrals-multi.py \
     compare-methods.py
 
 REF_OUTPUT_FILES = \
     extra_integration_results.dat \
     $(REF_OUTPUT_FILES_BASE) $(REF_OUTPUT_FILES_DOUBLE) \
     $(REF_OUTPUT_FILES_PREC) $(REF_OUTPUT_FILES_EXT) \
     $(REF_OUTPUT_FILES_QUAD)
 
 REF_OUTPUT_FILES_BASE = \
     unit_tests/ref-output/analysis_1.ref \
     unit_tests/ref-output/api_1.ref \
     unit_tests/ref-output/api_2.ref \
     unit_tests/ref-output/api_3.ref \
     unit_tests/ref-output/api_4.ref \
     unit_tests/ref-output/api_5.ref \
     unit_tests/ref-output/api_6.ref \
     unit_tests/ref-output/api_7.ref \
     unit_tests/ref-output/api_8.ref \
     unit_tests/ref-output/api_c_1.ref \
     unit_tests/ref-output/api_c_2.ref \
     unit_tests/ref-output/api_c_3.ref \
     unit_tests/ref-output/api_c_4.ref \
     unit_tests/ref-output/api_c_5.ref \
     unit_tests/ref-output/api_cc_1.ref \
     unit_tests/ref-output/api_cc_2.ref \
     unit_tests/ref-output/api_cc_3.ref \
     unit_tests/ref-output/api_cc_4.ref \
     unit_tests/ref-output/api_cc_5.ref \
     unit_tests/ref-output/api_hepmc2_1.ref \
     unit_tests/ref-output/api_hepmc2_cc_1.ref \
     unit_tests/ref-output/api_hepmc3_1.ref \
     unit_tests/ref-output/api_hepmc3_cc_1.ref \
     unit_tests/ref-output/api_lcio_1.ref \
     unit_tests/ref-output/api_lcio_cc_1.ref \
     unit_tests/ref-output/array_list_1.ref \
     unit_tests/ref-output/auto_components_1.ref \
     unit_tests/ref-output/auto_components_2.ref \
     unit_tests/ref-output/auto_components_3.ref \
     unit_tests/ref-output/beam_1.ref \
     unit_tests/ref-output/beam_2.ref \
     unit_tests/ref-output/beam_3.ref \
     unit_tests/ref-output/beam_structures_1.ref \
     unit_tests/ref-output/beam_structures_2.ref \
     unit_tests/ref-output/beam_structures_3.ref \
     unit_tests/ref-output/beam_structures_4.ref \
     unit_tests/ref-output/beam_structures_5.ref \
     unit_tests/ref-output/beam_structures_6.ref \
     unit_tests/ref-output/binary_tree_1.ref \
     unit_tests/ref-output/blha_1.ref \
     unit_tests/ref-output/blha_2.ref \
     unit_tests/ref-output/blha_3.ref \
     unit_tests/ref-output/bloch_vectors_1.ref \
     unit_tests/ref-output/bloch_vectors_2.ref \
     unit_tests/ref-output/bloch_vectors_3.ref \
     unit_tests/ref-output/bloch_vectors_4.ref \
     unit_tests/ref-output/bloch_vectors_5.ref \
     unit_tests/ref-output/bloch_vectors_6.ref \
     unit_tests/ref-output/bloch_vectors_7.ref \
     unit_tests/ref-output/cascades2_1.ref \
     unit_tests/ref-output/cascades2_2.ref \
     unit_tests/ref-output/cascades2_lexer_1.ref \
     unit_tests/ref-output/cascades_1.ref \
     unit_tests/ref-output/cascades_2.ref \
     unit_tests/ref-output/color_1.ref \
     unit_tests/ref-output/color_2.ref \
     unit_tests/ref-output/commands_1.ref \
     unit_tests/ref-output/commands_2.ref \
     unit_tests/ref-output/commands_3.ref \
     unit_tests/ref-output/commands_4.ref \
     unit_tests/ref-output/commands_5.ref \
     unit_tests/ref-output/commands_6.ref \
     unit_tests/ref-output/commands_7.ref \
     unit_tests/ref-output/commands_8.ref \
     unit_tests/ref-output/commands_9.ref \
     unit_tests/ref-output/commands_10.ref \
     unit_tests/ref-output/commands_11.ref \
     unit_tests/ref-output/commands_12.ref \
     unit_tests/ref-output/commands_13.ref \
     unit_tests/ref-output/commands_14.ref \
     unit_tests/ref-output/commands_15.ref \
     unit_tests/ref-output/commands_16.ref \
     unit_tests/ref-output/commands_17.ref \
     unit_tests/ref-output/commands_18.ref \
     unit_tests/ref-output/commands_19.ref \
     unit_tests/ref-output/commands_20.ref \
     unit_tests/ref-output/commands_21.ref \
     unit_tests/ref-output/commands_22.ref \
     unit_tests/ref-output/commands_23.ref \
     unit_tests/ref-output/commands_24.ref \
     unit_tests/ref-output/commands_25.ref \
     unit_tests/ref-output/commands_26.ref \
     unit_tests/ref-output/commands_27.ref \
     unit_tests/ref-output/commands_28.ref \
     unit_tests/ref-output/commands_29.ref \
     unit_tests/ref-output/commands_30.ref \
     unit_tests/ref-output/commands_31.ref \
     unit_tests/ref-output/commands_32.ref \
     unit_tests/ref-output/commands_33.ref \
     unit_tests/ref-output/commands_34.ref \
     unit_tests/ref-output/compilations_1.ref \
     unit_tests/ref-output/compilations_2.ref \
     unit_tests/ref-output/compilations_3.ref \
     unit_tests/ref-output/compilations_static_1.ref \
     unit_tests/ref-output/compilations_static_2.ref \
     unit_tests/ref-output/cputime_1.ref \
     unit_tests/ref-output/cputime_2.ref \
     unit_tests/ref-output/decays_1.ref \
     unit_tests/ref-output/decays_2.ref \
     unit_tests/ref-output/decays_3.ref \
     unit_tests/ref-output/decays_4.ref \
     unit_tests/ref-output/decays_5.ref \
     unit_tests/ref-output/decays_6.ref \
     unit_tests/ref-output/dispatch_1.ref \
     unit_tests/ref-output/dispatch_2.ref \
     unit_tests/ref-output/dispatch_7.ref \
     unit_tests/ref-output/dispatch_8.ref \
     unit_tests/ref-output/dispatch_10.ref \
     unit_tests/ref-output/dispatch_11.ref \
     unit_tests/ref-output/dispatch_mci_1.ref \
     unit_tests/ref-output/dispatch_phs_1.ref \
     unit_tests/ref-output/dispatch_phs_2.ref \
     unit_tests/ref-output/dispatch_rng_1.ref \
     unit_tests/ref-output/dispatch_transforms_1.ref \
     unit_tests/ref-output/dispatch_transforms_2.ref \
     unit_tests/ref-output/eio_ascii_1.ref \
     unit_tests/ref-output/eio_ascii_2.ref \
     unit_tests/ref-output/eio_ascii_3.ref \
     unit_tests/ref-output/eio_ascii_4.ref \
     unit_tests/ref-output/eio_ascii_5.ref \
     unit_tests/ref-output/eio_ascii_6.ref \
     unit_tests/ref-output/eio_ascii_7.ref \
     unit_tests/ref-output/eio_ascii_8.ref \
     unit_tests/ref-output/eio_ascii_9.ref \
     unit_tests/ref-output/eio_ascii_10.ref \
     unit_tests/ref-output/eio_ascii_11.ref \
     unit_tests/ref-output/eio_base_1.ref \
     unit_tests/ref-output/eio_checkpoints_1.ref \
     unit_tests/ref-output/eio_data_1.ref \
     unit_tests/ref-output/eio_data_2.ref \
     unit_tests/ref-output/eio_direct_1.ref \
     unit_tests/ref-output/eio_dump_1.ref \
     unit_tests/ref-output/eio_hepmc2_1.ref \
     unit_tests/ref-output/eio_hepmc2_2.ref \
     unit_tests/ref-output/eio_hepmc2_3.ref \
     unit_tests/ref-output/eio_hepmc3_1.ref \
     unit_tests/ref-output/eio_hepmc3_2.ref \
     unit_tests/ref-output/eio_hepmc3_3.ref \
     unit_tests/ref-output/eio_lcio_1.ref \
     unit_tests/ref-output/eio_lcio_2.ref \
     unit_tests/ref-output/eio_lhef_1.ref \
     unit_tests/ref-output/eio_lhef_2.ref \
     unit_tests/ref-output/eio_lhef_3.ref \
     unit_tests/ref-output/eio_lhef_4.ref \
     unit_tests/ref-output/eio_lhef_5.ref \
     unit_tests/ref-output/eio_lhef_6.ref \
     unit_tests/ref-output/eio_raw_1.ref \
     unit_tests/ref-output/eio_raw_2.ref \
     unit_tests/ref-output/eio_stdhep_1.ref \
     unit_tests/ref-output/eio_stdhep_2.ref \
     unit_tests/ref-output/eio_stdhep_3.ref \
     unit_tests/ref-output/eio_stdhep_4.ref \
     unit_tests/ref-output/eio_weights_1.ref \
     unit_tests/ref-output/eio_weights_2.ref \
     unit_tests/ref-output/eio_weights_3.ref \
     unit_tests/ref-output/epa_handler_1.ref \
     unit_tests/ref-output/epa_handler_2.ref \
     unit_tests/ref-output/epa_handler_3.ref \
     unit_tests/ref-output/evaluator_1.ref \
     unit_tests/ref-output/evaluator_2.ref \
     unit_tests/ref-output/evaluator_3.ref \
     unit_tests/ref-output/evaluator_4.ref \
     unit_tests/ref-output/event_streams_1.ref \
     unit_tests/ref-output/event_streams_2.ref \
     unit_tests/ref-output/event_streams_3.ref \
     unit_tests/ref-output/event_streams_4.ref \
     unit_tests/ref-output/event_transforms_1.ref \
     unit_tests/ref-output/events_1.ref \
     unit_tests/ref-output/events_2.ref \
     unit_tests/ref-output/events_3.ref \
     unit_tests/ref-output/events_4.ref \
     unit_tests/ref-output/events_5.ref \
     unit_tests/ref-output/events_6.ref \
     unit_tests/ref-output/events_7.ref \
     unit_tests/ref-output/expressions_1.ref \
     unit_tests/ref-output/expressions_2.ref \
     unit_tests/ref-output/expressions_3.ref \
     unit_tests/ref-output/expressions_4.ref \
     unit_tests/ref-output/fks_regions_1.ref \
     unit_tests/ref-output/fks_regions_2.ref \
     unit_tests/ref-output/fks_regions_3.ref \
     unit_tests/ref-output/fks_regions_4.ref \
     unit_tests/ref-output/fks_regions_5.ref \
     unit_tests/ref-output/fks_regions_6.ref \
     unit_tests/ref-output/fks_regions_7.ref \
     unit_tests/ref-output/fks_regions_8.ref \
     unit_tests/ref-output/format_1.ref \
     unit_tests/ref-output/grids_1.ref \
     unit_tests/ref-output/grids_2.ref \
     unit_tests/ref-output/grids_3.ref \
     unit_tests/ref-output/grids_4.ref \
     unit_tests/ref-output/grids_5.ref \
     unit_tests/ref-output/hep_events_1.ref \
     unit_tests/ref-output/hepmc2_interface_1.ref \
     unit_tests/ref-output/hepmc3_interface_1.ref \
     unit_tests/ref-output/integration_results_1.ref \
     unit_tests/ref-output/integration_results_2.ref \
     unit_tests/ref-output/integration_results_3.ref \
     unit_tests/ref-output/integration_results_4.ref \
     unit_tests/ref-output/integration_results_5.ref \
     unit_tests/ref-output/integrations_1.ref \
     unit_tests/ref-output/integrations_2.ref \
     unit_tests/ref-output/integrations_3.ref \
     unit_tests/ref-output/integrations_4.ref \
     unit_tests/ref-output/integrations_5.ref \
     unit_tests/ref-output/integrations_6.ref \
     unit_tests/ref-output/integrations_7.ref \
     unit_tests/ref-output/integrations_8.ref \
     unit_tests/ref-output/integrations_9.ref \
     unit_tests/ref-output/integrations_history_1.ref \
     unit_tests/ref-output/interaction_1.ref \
     unit_tests/ref-output/isr_handler_1.ref \
     unit_tests/ref-output/isr_handler_2.ref \
     unit_tests/ref-output/isr_handler_3.ref \
     unit_tests/ref-output/iterations_1.ref \
     unit_tests/ref-output/iterations_2.ref \
     unit_tests/ref-output/iterator_1.ref \
     unit_tests/ref-output/jets_1.ref \
     unit_tests/ref-output/lcio_interface_1.ref \
     unit_tests/ref-output/lexer_1.ref \
     unit_tests/ref-output/mci_base_1.ref \
     unit_tests/ref-output/mci_base_2.ref \
     unit_tests/ref-output/mci_base_3.ref \
     unit_tests/ref-output/mci_base_4.ref \
     unit_tests/ref-output/mci_base_5.ref \
     unit_tests/ref-output/mci_base_6.ref \
     unit_tests/ref-output/mci_base_7.ref \
     unit_tests/ref-output/mci_base_8.ref \
     unit_tests/ref-output/mci_midpoint_1.ref \
     unit_tests/ref-output/mci_midpoint_2.ref \
     unit_tests/ref-output/mci_midpoint_3.ref \
     unit_tests/ref-output/mci_midpoint_4.ref \
     unit_tests/ref-output/mci_midpoint_5.ref \
     unit_tests/ref-output/mci_midpoint_6.ref \
     unit_tests/ref-output/mci_midpoint_7.ref \
     unit_tests/ref-output/mci_none_1.ref \
     unit_tests/ref-output/mci_vamp2_1.ref \
     unit_tests/ref-output/mci_vamp2_2.ref \
     unit_tests/ref-output/mci_vamp2_3.ref \
     unit_tests/ref-output/mci_vamp_1.ref \
     unit_tests/ref-output/mci_vamp_2.ref \
     unit_tests/ref-output/mci_vamp_3.ref \
     unit_tests/ref-output/mci_vamp_4.ref \
     unit_tests/ref-output/mci_vamp_5.ref \
     unit_tests/ref-output/mci_vamp_6.ref \
     unit_tests/ref-output/mci_vamp_7.ref \
     unit_tests/ref-output/mci_vamp_8.ref \
     unit_tests/ref-output/mci_vamp_9.ref \
     unit_tests/ref-output/mci_vamp_10.ref \
     unit_tests/ref-output/mci_vamp_11.ref \
     unit_tests/ref-output/mci_vamp_12.ref \
     unit_tests/ref-output/mci_vamp_13.ref \
     unit_tests/ref-output/mci_vamp_14.ref \
     unit_tests/ref-output/mci_vamp_15.ref \
     unit_tests/ref-output/mci_vamp_16.ref \
     unit_tests/ref-output/md5_1.ref \
     unit_tests/ref-output/models_1.ref \
     unit_tests/ref-output/models_2.ref \
     unit_tests/ref-output/models_3.ref \
     unit_tests/ref-output/models_4.ref \
     unit_tests/ref-output/models_5.ref \
     unit_tests/ref-output/models_6.ref \
     unit_tests/ref-output/models_7.ref \
     unit_tests/ref-output/models_8.ref \
     unit_tests/ref-output/models_9.ref \
     unit_tests/ref-output/models_10.ref \
     unit_tests/ref-output/os_interface_1.ref \
     unit_tests/ref-output/parse_1.ref \
     unit_tests/ref-output/particle_specifiers_1.ref \
     unit_tests/ref-output/particle_specifiers_2.ref \
     unit_tests/ref-output/particles_1.ref \
     unit_tests/ref-output/particles_2.ref \
     unit_tests/ref-output/particles_3.ref \
     unit_tests/ref-output/particles_4.ref \
     unit_tests/ref-output/particles_5.ref \
     unit_tests/ref-output/particles_6.ref \
     unit_tests/ref-output/particles_7.ref \
     unit_tests/ref-output/particles_8.ref \
     unit_tests/ref-output/particles_9.ref \
     unit_tests/ref-output/parton_states_1.ref \
     unit_tests/ref-output/pdg_arrays_1.ref \
     unit_tests/ref-output/pdg_arrays_2.ref \
     unit_tests/ref-output/pdg_arrays_3.ref \
     unit_tests/ref-output/pdg_arrays_4.ref \
     unit_tests/ref-output/pdg_arrays_5.ref \
     unit_tests/ref-output/phs_base_1.ref \
     unit_tests/ref-output/phs_base_2.ref \
     unit_tests/ref-output/phs_base_3.ref \
     unit_tests/ref-output/phs_base_4.ref \
     unit_tests/ref-output/phs_base_5.ref \
     unit_tests/ref-output/phs_fks_generator_1.ref \
     unit_tests/ref-output/phs_fks_generator_2.ref \
     unit_tests/ref-output/phs_fks_generator_3.ref \
     unit_tests/ref-output/phs_fks_generator_4.ref \
     unit_tests/ref-output/phs_fks_generator_5.ref \
     unit_tests/ref-output/phs_fks_generator_6.ref \
     unit_tests/ref-output/phs_fks_generator_7.ref \
     unit_tests/ref-output/phs_forest_1.ref \
     unit_tests/ref-output/phs_forest_2.ref \
     unit_tests/ref-output/phs_none_1.ref \
     unit_tests/ref-output/phs_rambo_1.ref \
     unit_tests/ref-output/phs_rambo_2.ref \
     unit_tests/ref-output/phs_rambo_3.ref \
     unit_tests/ref-output/phs_rambo_4.ref \
     unit_tests/ref-output/phs_single_1.ref \
     unit_tests/ref-output/phs_single_2.ref \
     unit_tests/ref-output/phs_single_3.ref \
     unit_tests/ref-output/phs_single_4.ref \
     unit_tests/ref-output/phs_tree_1.ref \
     unit_tests/ref-output/phs_tree_2.ref \
     unit_tests/ref-output/phs_wood_1.ref \
     unit_tests/ref-output/phs_wood_2.ref \
     unit_tests/ref-output/phs_wood_3.ref \
     unit_tests/ref-output/phs_wood_4.ref \
     unit_tests/ref-output/phs_wood_5.ref \
     unit_tests/ref-output/phs_wood_6.ref \
     unit_tests/ref-output/phs_wood_vis_1.ref \
     unit_tests/ref-output/polarization_1.ref \
     unit_tests/ref-output/polarization_2.ref \
     unit_tests/ref-output/prc_omega_1.ref \
     unit_tests/ref-output/prc_omega_2.ref \
     unit_tests/ref-output/prc_omega_3.ref \
     unit_tests/ref-output/prc_omega_4.ref \
     unit_tests/ref-output/prc_omega_5.ref \
     unit_tests/ref-output/prc_omega_6.ref \
     unit_tests/ref-output/prc_omega_diags_1.ref \
     unit_tests/ref-output/prc_recola_1.ref \
     unit_tests/ref-output/prc_recola_2.ref \
     unit_tests/ref-output/prc_template_me_1.ref \
     unit_tests/ref-output/prc_template_me_2.ref \
     unit_tests/ref-output/prc_test_1.ref \
     unit_tests/ref-output/prc_test_2.ref \
     unit_tests/ref-output/prc_test_3.ref \
     unit_tests/ref-output/prc_test_4.ref \
     unit_tests/ref-output/prclib_interfaces_1.ref \
     unit_tests/ref-output/prclib_interfaces_2.ref \
     unit_tests/ref-output/prclib_interfaces_3.ref \
     unit_tests/ref-output/prclib_interfaces_4.ref \
     unit_tests/ref-output/prclib_interfaces_5.ref \
     unit_tests/ref-output/prclib_interfaces_6.ref \
     unit_tests/ref-output/prclib_interfaces_7.ref \
     unit_tests/ref-output/prclib_stacks_1.ref \
     unit_tests/ref-output/prclib_stacks_2.ref \
     unit_tests/ref-output/process_configurations_1.ref \
     unit_tests/ref-output/process_configurations_2.ref \
     unit_tests/ref-output/process_libraries_1.ref \
     unit_tests/ref-output/process_libraries_2.ref \
     unit_tests/ref-output/process_libraries_3.ref \
     unit_tests/ref-output/process_libraries_4.ref \
     unit_tests/ref-output/process_libraries_5.ref \
     unit_tests/ref-output/process_libraries_6.ref \
     unit_tests/ref-output/process_libraries_7.ref \
     unit_tests/ref-output/process_libraries_8.ref \
     unit_tests/ref-output/process_stacks_1.ref \
     unit_tests/ref-output/process_stacks_2.ref \
     unit_tests/ref-output/process_stacks_3.ref \
     unit_tests/ref-output/process_stacks_4.ref \
     unit_tests/ref-output/processes_1.ref \
     unit_tests/ref-output/processes_2.ref \
     unit_tests/ref-output/processes_3.ref \
     unit_tests/ref-output/processes_4.ref \
     unit_tests/ref-output/processes_5.ref \
     unit_tests/ref-output/processes_6.ref \
     unit_tests/ref-output/processes_7.ref \
     unit_tests/ref-output/processes_8.ref \
     unit_tests/ref-output/processes_9.ref \
     unit_tests/ref-output/processes_10.ref \
     unit_tests/ref-output/processes_11.ref \
     unit_tests/ref-output/processes_12.ref \
     unit_tests/ref-output/processes_13.ref \
     unit_tests/ref-output/processes_14.ref \
     unit_tests/ref-output/processes_15.ref \
     unit_tests/ref-output/processes_16.ref \
     unit_tests/ref-output/processes_17.ref \
     unit_tests/ref-output/processes_18.ref \
     unit_tests/ref-output/processes_19.ref \
     unit_tests/ref-output/radiation_generator_1.ref \
     unit_tests/ref-output/radiation_generator_2.ref \
     unit_tests/ref-output/radiation_generator_3.ref \
     unit_tests/ref-output/radiation_generator_4.ref \
     unit_tests/ref-output/real_subtraction_1.ref \
     unit_tests/ref-output/recoil_kinematics_1.ref \
     unit_tests/ref-output/recoil_kinematics_2.ref \
     unit_tests/ref-output/recoil_kinematics_3.ref \
     unit_tests/ref-output/recoil_kinematics_4.ref \
     unit_tests/ref-output/recoil_kinematics_5.ref \
     unit_tests/ref-output/recoil_kinematics_6.ref \
     unit_tests/ref-output/resonance_insertion_1.ref \
     unit_tests/ref-output/resonance_insertion_2.ref \
     unit_tests/ref-output/resonance_insertion_3.ref \
     unit_tests/ref-output/resonance_insertion_4.ref \
     unit_tests/ref-output/resonance_insertion_5.ref \
     unit_tests/ref-output/resonance_insertion_6.ref \
     unit_tests/ref-output/resonances_1.ref \
     unit_tests/ref-output/resonances_2.ref \
     unit_tests/ref-output/resonances_3.ref \
     unit_tests/ref-output/resonances_4.ref \
     unit_tests/ref-output/resonances_5.ref \
     unit_tests/ref-output/resonances_6.ref \
     unit_tests/ref-output/resonances_7.ref \
     unit_tests/ref-output/restricted_subprocesses_1.ref \
     unit_tests/ref-output/restricted_subprocesses_2.ref \
     unit_tests/ref-output/restricted_subprocesses_3.ref \
     unit_tests/ref-output/restricted_subprocesses_4.ref \
     unit_tests/ref-output/restricted_subprocesses_5.ref \
     unit_tests/ref-output/restricted_subprocesses_6.ref \
     unit_tests/ref-output/rng_base_1.ref \
     unit_tests/ref-output/rng_base_2.ref \
     unit_tests/ref-output/rng_stream_1.ref \
     unit_tests/ref-output/rng_stream_2.ref \
     unit_tests/ref-output/rng_stream_3.ref \
     unit_tests/ref-output/rng_tao_1.ref \
     unit_tests/ref-output/rng_tao_2.ref \
     unit_tests/ref-output/rt_data_1.ref \
     unit_tests/ref-output/rt_data_2.ref \
     unit_tests/ref-output/rt_data_3.ref \
     unit_tests/ref-output/rt_data_4.ref \
     unit_tests/ref-output/rt_data_5.ref \
     unit_tests/ref-output/rt_data_6.ref \
     unit_tests/ref-output/rt_data_7.ref \
     unit_tests/ref-output/rt_data_8.ref \
     unit_tests/ref-output/rt_data_9.ref \
     unit_tests/ref-output/rt_data_10.ref \
     unit_tests/ref-output/rt_data_11.ref \
     unit_tests/ref-output/selectors_1.ref \
     unit_tests/ref-output/selectors_2.ref \
     unit_tests/ref-output/sf_aux_1.ref \
     unit_tests/ref-output/sf_aux_2.ref \
     unit_tests/ref-output/sf_aux_3.ref \
     unit_tests/ref-output/sf_aux_4.ref \
     unit_tests/ref-output/sf_base_1.ref \
     unit_tests/ref-output/sf_base_2.ref \
     unit_tests/ref-output/sf_base_3.ref \
     unit_tests/ref-output/sf_base_4.ref \
     unit_tests/ref-output/sf_base_5.ref \
     unit_tests/ref-output/sf_base_6.ref \
     unit_tests/ref-output/sf_base_7.ref \
     unit_tests/ref-output/sf_base_8.ref \
     unit_tests/ref-output/sf_base_9.ref \
     unit_tests/ref-output/sf_base_10.ref \
     unit_tests/ref-output/sf_base_11.ref \
     unit_tests/ref-output/sf_base_12.ref \
     unit_tests/ref-output/sf_base_13.ref \
     unit_tests/ref-output/sf_base_14.ref \
     unit_tests/ref-output/sf_beam_events_1.ref \
     unit_tests/ref-output/sf_beam_events_2.ref \
     unit_tests/ref-output/sf_beam_events_3.ref \
     unit_tests/ref-output/sf_circe1_1.ref \
     unit_tests/ref-output/sf_circe1_2.ref \
     unit_tests/ref-output/sf_circe1_3.ref \
     unit_tests/ref-output/sf_circe2_1.ref \
     unit_tests/ref-output/sf_circe2_2.ref \
     unit_tests/ref-output/sf_circe2_3.ref \
     unit_tests/ref-output/sf_epa_1.ref \
     unit_tests/ref-output/sf_epa_2.ref \
     unit_tests/ref-output/sf_epa_3.ref \
     unit_tests/ref-output/sf_epa_4.ref \
     unit_tests/ref-output/sf_epa_5.ref \
     unit_tests/ref-output/sf_escan_1.ref \
     unit_tests/ref-output/sf_escan_2.ref \
     unit_tests/ref-output/sf_ewa_1.ref \
     unit_tests/ref-output/sf_ewa_2.ref \
     unit_tests/ref-output/sf_ewa_3.ref \
     unit_tests/ref-output/sf_ewa_4.ref \
     unit_tests/ref-output/sf_ewa_5.ref \
     unit_tests/ref-output/sf_gaussian_1.ref \
     unit_tests/ref-output/sf_gaussian_2.ref \
     unit_tests/ref-output/sf_isr_1.ref \
     unit_tests/ref-output/sf_isr_2.ref \
     unit_tests/ref-output/sf_isr_3.ref \
     unit_tests/ref-output/sf_isr_4.ref \
     unit_tests/ref-output/sf_isr_5.ref \
     unit_tests/ref-output/sf_lhapdf5_1.ref \
     unit_tests/ref-output/sf_lhapdf5_2.ref \
     unit_tests/ref-output/sf_lhapdf5_3.ref \
     unit_tests/ref-output/sf_lhapdf6_1.ref \
     unit_tests/ref-output/sf_lhapdf6_2.ref \
     unit_tests/ref-output/sf_lhapdf6_3.ref \
     unit_tests/ref-output/sf_mappings_1.ref \
     unit_tests/ref-output/sf_mappings_2.ref \
     unit_tests/ref-output/sf_mappings_3.ref \
     unit_tests/ref-output/sf_mappings_4.ref \
     unit_tests/ref-output/sf_mappings_5.ref \
     unit_tests/ref-output/sf_mappings_6.ref \
     unit_tests/ref-output/sf_mappings_7.ref \
     unit_tests/ref-output/sf_mappings_8.ref \
     unit_tests/ref-output/sf_mappings_9.ref \
     unit_tests/ref-output/sf_mappings_10.ref \
     unit_tests/ref-output/sf_mappings_11.ref \
     unit_tests/ref-output/sf_mappings_12.ref \
     unit_tests/ref-output/sf_mappings_13.ref \
     unit_tests/ref-output/sf_mappings_14.ref \
     unit_tests/ref-output/sf_mappings_15.ref \
     unit_tests/ref-output/sf_mappings_16.ref \
     unit_tests/ref-output/sf_pdf_builtin_1.ref \
     unit_tests/ref-output/sf_pdf_builtin_2.ref \
     unit_tests/ref-output/sf_pdf_builtin_3.ref \
     unit_tests/ref-output/shower_1.ref \
     unit_tests/ref-output/shower_2.ref \
     unit_tests/ref-output/shower_base_1.ref \
     unit_tests/ref-output/simulations_1.ref \
     unit_tests/ref-output/simulations_2.ref \
     unit_tests/ref-output/simulations_3.ref \
     unit_tests/ref-output/simulations_4.ref \
     unit_tests/ref-output/simulations_5.ref \
     unit_tests/ref-output/simulations_6.ref \
     unit_tests/ref-output/simulations_7.ref \
     unit_tests/ref-output/simulations_8.ref \
     unit_tests/ref-output/simulations_9.ref \
     unit_tests/ref-output/simulations_10.ref \
     unit_tests/ref-output/simulations_11.ref \
     unit_tests/ref-output/simulations_12.ref \
     unit_tests/ref-output/simulations_13.ref \
     unit_tests/ref-output/simulations_14.ref \
     unit_tests/ref-output/simulations_15.ref \
     unit_tests/ref-output/slha_1.ref \
     unit_tests/ref-output/slha_2.ref \
     unit_tests/ref-output/sm_physics_1.ref \
     unit_tests/ref-output/sm_physics_2.ref \
     unit_tests/ref-output/sm_qcd_1.ref \
     unit_tests/ref-output/solver_1.ref \
     unit_tests/ref-output/sorting_1.ref \
     unit_tests/ref-output/state_matrix_1.ref \
     unit_tests/ref-output/state_matrix_2.ref \
     unit_tests/ref-output/state_matrix_3.ref \
     unit_tests/ref-output/state_matrix_4.ref \
     unit_tests/ref-output/state_matrix_5.ref \
     unit_tests/ref-output/state_matrix_6.ref \
     unit_tests/ref-output/state_matrix_7.ref \
     unit_tests/ref-output/su_algebra_1.ref \
     unit_tests/ref-output/su_algebra_2.ref \
     unit_tests/ref-output/su_algebra_3.ref \
     unit_tests/ref-output/su_algebra_4.ref \
     unit_tests/ref-output/subevt_expr_1.ref \
     unit_tests/ref-output/subevt_expr_2.ref \
     unit_tests/ref-output/ttv_formfactors_1.ref \
     unit_tests/ref-output/ttv_formfactors_2.ref \
     unit_tests/ref-output/vamp2_1.ref \
     unit_tests/ref-output/vamp2_2.ref \
     unit_tests/ref-output/vamp2_3.ref \
     unit_tests/ref-output/vamp2_4.ref \
     unit_tests/ref-output/vamp2_5.ref \
     unit_tests/ref-output/vegas_1.ref \
     unit_tests/ref-output/vegas_2.ref \
     unit_tests/ref-output/vegas_3.ref \
     unit_tests/ref-output/vegas_4.ref \
     unit_tests/ref-output/vegas_5.ref \
     unit_tests/ref-output/vegas_6.ref \
     unit_tests/ref-output/vegas_7.ref \
     unit_tests/ref-output/whizard_lha_1.ref \
     unit_tests/ref-output/xml_1.ref \
     unit_tests/ref-output/xml_2.ref \
     unit_tests/ref-output/xml_3.ref \
     unit_tests/ref-output/xml_4.ref \
     functional_tests/ref-output/alphas.ref \
     functional_tests/ref-output/analyze_1.ref \
     functional_tests/ref-output/analyze_2.ref \
     functional_tests/ref-output/analyze_3.ref \
     functional_tests/ref-output/analyze_4.ref \
     functional_tests/ref-output/analyze_5.ref \
     functional_tests/ref-output/analyze_6.ref \
     functional_tests/ref-output/beam_events_1.ref \
     functional_tests/ref-output/beam_events_4.ref \
     functional_tests/ref-output/beam_setup_1.ref \
     functional_tests/ref-output/beam_setup_2.ref \
     functional_tests/ref-output/beam_setup_3.ref \
     functional_tests/ref-output/beam_setup_4.ref \
     functional_tests/ref-output/bjet_cluster.ref \
     functional_tests/ref-output/br_redef_1.ref \
     functional_tests/ref-output/cascades2_phs_1.ref \
     functional_tests/ref-output/cascades2_phs_2.ref \
     functional_tests/ref-output/circe1_1.ref \
     functional_tests/ref-output/circe1_2.ref \
     functional_tests/ref-output/circe1_3.ref \
     functional_tests/ref-output/circe1_6.ref \
     functional_tests/ref-output/circe1_10.ref \
     functional_tests/ref-output/circe1_errors_1.ref \
     functional_tests/ref-output/circe2_1.ref \
     functional_tests/ref-output/circe2_2.ref \
     functional_tests/ref-output/circe2_3.ref \
     functional_tests/ref-output/cmdline_1.ref \
     functional_tests/ref-output/colors.ref \
     functional_tests/ref-output/colors_hgg.ref \
     functional_tests/ref-output/cuts.ref \
     functional_tests/ref-output/decay_err_1.ref \
     functional_tests/ref-output/decay_err_2.ref \
     functional_tests/ref-output/decay_err_3.ref \
     functional_tests/ref-output/energy_scan_1.ref \
     functional_tests/ref-output/ep_3.ref \
     functional_tests/ref-output/epa_1.ref \
     functional_tests/ref-output/epa_2.ref \
     functional_tests/ref-output/epa_3.ref \
     functional_tests/ref-output/epa_4.ref \
     functional_tests/ref-output/event_dump_1.ref \
     functional_tests/ref-output/event_dump_2.ref \
     functional_tests/ref-output/event_eff_1.ref \
     functional_tests/ref-output/event_eff_2.ref \
     functional_tests/ref-output/event_failed_1.ref \
     functional_tests/ref-output/event_weights_1.ref \
     functional_tests/ref-output/event_weights_2.ref \
     functional_tests/ref-output/ewa_4.ref \
     functional_tests/ref-output/extpar.ref \
     functional_tests/ref-output/fatal.ref \
     functional_tests/ref-output/fatal_beam_decay.ref \
     functional_tests/ref-output/fks_res_2.ref \
     functional_tests/ref-output/flvsum_1.ref \
     functional_tests/ref-output/gaussian_1.ref \
     functional_tests/ref-output/gaussian_2.ref \
     functional_tests/ref-output/hadronize_1.ref \
     functional_tests/ref-output/hepmc_1.ref \
     functional_tests/ref-output/hepmc_2.ref \
     functional_tests/ref-output/hepmc_3.ref \
     functional_tests/ref-output/hepmc_4.ref \
     functional_tests/ref-output/hepmc_5.ref \
     functional_tests/ref-output/hepmc_6.ref \
     functional_tests/ref-output/hepmc_7.ref \
     functional_tests/ref-output/hepmc_9.ref \
     functional_tests/ref-output/hepmc_10.ref \
     functional_tests/ref-output/isr_1.ref \
     functional_tests/ref-output/isr_epa_1.ref \
     functional_tests/ref-output/jets_xsec.ref \
     functional_tests/ref-output/job_id_1.ref \
     functional_tests/ref-output/job_id_2.ref \
     functional_tests/ref-output/job_id_3.ref \
     functional_tests/ref-output/job_id_4.ref \
     functional_tests/ref-output/lcio_1.ref \
     functional_tests/ref-output/lcio_3.ref \
     functional_tests/ref-output/lcio_4.ref \
     functional_tests/ref-output/lcio_5.ref \
     functional_tests/ref-output/lcio_6.ref \
     functional_tests/ref-output/lcio_8.ref \
     functional_tests/ref-output/lcio_9.ref \
     functional_tests/ref-output/lcio_10.ref \
     functional_tests/ref-output/lcio_11.ref \
     functional_tests/ref-output/lhef_1.ref \
     functional_tests/ref-output/lhef_2.ref \
     functional_tests/ref-output/lhef_3.ref \
     functional_tests/ref-output/lhef_4.ref \
     functional_tests/ref-output/lhef_5.ref \
     functional_tests/ref-output/lhef_6.ref \
     functional_tests/ref-output/lhef_9.ref \
     functional_tests/ref-output/lhef_10.ref \
     functional_tests/ref-output/lhef_11.ref \
     functional_tests/ref-output/libraries_1.ref \
     functional_tests/ref-output/libraries_2.ref \
     functional_tests/ref-output/libraries_4.ref \
     functional_tests/ref-output/method_ovm_1.ref \
     functional_tests/ref-output/mlm_matching_fsr.ref \
     functional_tests/ref-output/mlm_pythia6_isr.ref \
     functional_tests/ref-output/model_change_1.ref \
     functional_tests/ref-output/model_change_2.ref \
     functional_tests/ref-output/model_change_3.ref \
     functional_tests/ref-output/model_scheme_1.ref \
     functional_tests/ref-output/model_test.ref \
     functional_tests/ref-output/mssmtest_1.ref \
     functional_tests/ref-output/mssmtest_2.ref \
     functional_tests/ref-output/mssmtest_3.ref \
     functional_tests/ref-output/multi_comp_4.ref \
     functional_tests/ref-output/nlo_1.ref \
     functional_tests/ref-output/nlo_2.ref \
     functional_tests/ref-output/nlo_6.ref \
     functional_tests/ref-output/nlo_decay_1.ref \
     functional_tests/ref-output/observables_1.ref \
     functional_tests/ref-output/openloops_1.ref \
     functional_tests/ref-output/openloops_2.ref \
     functional_tests/ref-output/openloops_4.ref \
     functional_tests/ref-output/openloops_5.ref \
     functional_tests/ref-output/openloops_6.ref \
     functional_tests/ref-output/openloops_7.ref \
     functional_tests/ref-output/openloops_8.ref \
     functional_tests/ref-output/openloops_9.ref \
     functional_tests/ref-output/openloops_10.ref \
     functional_tests/ref-output/openloops_11.ref \
     functional_tests/ref-output/pack_1.ref \
     functional_tests/ref-output/parton_shower_1.ref \
     functional_tests/ref-output/photon_isolation_1.ref \
     functional_tests/ref-output/photon_isolation_2.ref \
     functional_tests/ref-output/polarized_1.ref \
     functional_tests/ref-output/process_log.ref \
     functional_tests/ref-output/pythia6_1.ref \
     functional_tests/ref-output/pythia6_2.ref \
     functional_tests/ref-output/qcdtest_4.ref \
     functional_tests/ref-output/qcdtest_5.ref \
     functional_tests/ref-output/qcdtest_6.ref \
     functional_tests/ref-output/qedtest_1.ref \
     functional_tests/ref-output/qedtest_2.ref \
     functional_tests/ref-output/qedtest_5.ref \
     functional_tests/ref-output/qedtest_6.ref \
     functional_tests/ref-output/qedtest_7.ref \
     functional_tests/ref-output/qedtest_8.ref \
     functional_tests/ref-output/qedtest_9.ref \
     functional_tests/ref-output/qedtest_10.ref \
     functional_tests/ref-output/rambo_vamp_1.ref \
     functional_tests/ref-output/rambo_vamp_2.ref \
     functional_tests/ref-output/real_partition_1.ref \
     functional_tests/ref-output/rebuild_2.ref \
     functional_tests/ref-output/rebuild_3.ref \
     functional_tests/ref-output/rebuild_4.ref \
     functional_tests/ref-output/recola_1.ref \
     functional_tests/ref-output/recola_2.ref \
     functional_tests/ref-output/recola_3.ref \
     functional_tests/ref-output/recola_4.ref \
     functional_tests/ref-output/recola_5.ref \
     functional_tests/ref-output/recola_6.ref \
     functional_tests/ref-output/recola_7.ref \
     functional_tests/ref-output/recola_8.ref \
     functional_tests/ref-output/recola_9.ref \
     functional_tests/ref-output/resonances_5.ref \
     functional_tests/ref-output/resonances_6.ref \
     functional_tests/ref-output/resonances_7.ref \
     functional_tests/ref-output/resonances_8.ref \
     functional_tests/ref-output/resonances_9.ref \
     functional_tests/ref-output/resonances_12.ref \
     functional_tests/ref-output/restrictions.ref \
     functional_tests/ref-output/reweight_1.ref \
     functional_tests/ref-output/reweight_2.ref \
     functional_tests/ref-output/reweight_3.ref \
     functional_tests/ref-output/reweight_4.ref \
     functional_tests/ref-output/reweight_5.ref \
     functional_tests/ref-output/reweight_6.ref \
     functional_tests/ref-output/reweight_7.ref \
     functional_tests/ref-output/reweight_8.ref \
     functional_tests/ref-output/reweight_9.ref \
     functional_tests/ref-output/reweight_10.ref \
     functional_tests/ref-output/select_1.ref \
     functional_tests/ref-output/select_2.ref \
     functional_tests/ref-output/show_1.ref \
     functional_tests/ref-output/show_2.ref \
     functional_tests/ref-output/show_3.ref \
     functional_tests/ref-output/show_4.ref \
     functional_tests/ref-output/show_5.ref \
     functional_tests/ref-output/shower_err_1.ref \
     functional_tests/ref-output/sm_cms_1.ref \
     functional_tests/ref-output/smtest_1.ref \
     functional_tests/ref-output/smtest_3.ref \
     functional_tests/ref-output/smtest_4.ref \
     functional_tests/ref-output/smtest_5.ref \
     functional_tests/ref-output/smtest_6.ref \
     functional_tests/ref-output/smtest_7.ref \
     functional_tests/ref-output/smtest_9.ref \
     functional_tests/ref-output/smtest_10.ref \
     functional_tests/ref-output/smtest_11.ref \
     functional_tests/ref-output/smtest_12.ref \
     functional_tests/ref-output/smtest_13.ref \
     functional_tests/ref-output/smtest_14.ref \
     functional_tests/ref-output/smtest_15.ref \
     functional_tests/ref-output/smtest_16.ref \
     functional_tests/ref-output/spincor_1.ref \
     functional_tests/ref-output/static_1.ref \
     functional_tests/ref-output/static_2.ref \
     functional_tests/ref-output/stdhep_1.ref \
     functional_tests/ref-output/stdhep_2.ref \
     functional_tests/ref-output/stdhep_3.ref \
     functional_tests/ref-output/stdhep_4.ref \
     functional_tests/ref-output/stdhep_5.ref \
     functional_tests/ref-output/stdhep_6.ref \
     functional_tests/ref-output/structure_1.ref \
     functional_tests/ref-output/structure_2.ref \
     functional_tests/ref-output/structure_3.ref \
     functional_tests/ref-output/structure_4.ref \
     functional_tests/ref-output/structure_5.ref \
     functional_tests/ref-output/structure_6.ref \
     functional_tests/ref-output/structure_7.ref \
     functional_tests/ref-output/structure_8.ref \
     functional_tests/ref-output/susyhit.ref \
     functional_tests/ref-output/template_me_1.ref \
     functional_tests/ref-output/template_me_2.ref \
     functional_tests/ref-output/testproc_1.ref \
     functional_tests/ref-output/testproc_2.ref \
     functional_tests/ref-output/testproc_3.ref \
     functional_tests/ref-output/testproc_4.ref \
     functional_tests/ref-output/testproc_5.ref \
     functional_tests/ref-output/testproc_6.ref \
     functional_tests/ref-output/testproc_7.ref \
     functional_tests/ref-output/testproc_8.ref \
     functional_tests/ref-output/testproc_9.ref \
     functional_tests/ref-output/testproc_10.ref \
     functional_tests/ref-output/testproc_11.ref \
     functional_tests/ref-output/ufo_1.ref \
     functional_tests/ref-output/ufo_2.ref \
     functional_tests/ref-output/ufo_3.ref \
     functional_tests/ref-output/ufo_4.ref \
     functional_tests/ref-output/ufo_5.ref \
     functional_tests/ref-output/ufo_6.ref \
     functional_tests/ref-output/user_prc_threshold_1.ref \
     functional_tests/ref-output/user_prc_threshold_2.ref \
     functional_tests/ref-output/vamp2_1.ref \
     functional_tests/ref-output/vamp2_2.ref \
     functional_tests/ref-output/vamp2_3.ref \
     functional_tests/ref-output/vars.ref \
     ext_tests_nlo/ref-output/nlo_ee4j.ref \
     ext_tests_nlo/ref-output/nlo_ee4t.ref \
     ext_tests_nlo/ref-output/nlo_ee5j.ref \
     ext_tests_nlo/ref-output/nlo_eejj.ref \
     ext_tests_nlo/ref-output/nlo_eejjj.ref \
     ext_tests_nlo/ref-output/nlo_eett.ref \
     ext_tests_nlo/ref-output/nlo_eetth.ref \
     ext_tests_nlo/ref-output/nlo_eetthh.ref \
     ext_tests_nlo/ref-output/nlo_eetthj.ref \
     ext_tests_nlo/ref-output/nlo_eetthz.ref \
     ext_tests_nlo/ref-output/nlo_eettwjj.ref \
     ext_tests_nlo/ref-output/nlo_eettww.ref \
     ext_tests_nlo/ref-output/nlo_eettz.ref \
     ext_tests_nlo/ref-output/nlo_eettzj.ref \
     ext_tests_nlo/ref-output/nlo_eettzjj.ref \
     ext_tests_nlo/ref-output/nlo_eettzz.ref \
+    ext_tests_nlo/ref-output/nlo_ppjj_real_partition.ref \
     ext_tests_nlo/ref-output/nlo_pptttt.ref \
     ext_tests_nlo/ref-output/nlo_ppw.ref \
     ext_tests_nlo/ref-output/nlo_ppz.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_sim_1.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_sim_2.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_sim_3.ref \
     ext_tests_nlo/ref-output/nlo_ppzj_sim_4.ref \
     ext_tests_nlo/ref-output/nlo_ppzw.ref \
     ext_tests_nlo/ref-output/nlo_ppzz.ref
 
 # Reference files that depend on the numerical precision
 REF_OUTPUT_FILES_DOUBLE = \
     functional_tests/ref-output-double/beam_events_2.ref \
     functional_tests/ref-output-double/beam_events_3.ref \
     functional_tests/ref-output-double/beam_setup_5.ref \
     functional_tests/ref-output-double/circe1_4.ref \
     functional_tests/ref-output-double/circe1_5.ref \
     functional_tests/ref-output-double/circe1_7.ref \
     functional_tests/ref-output-double/circe1_8.ref \
     functional_tests/ref-output-double/circe1_9.ref \
     functional_tests/ref-output-double/circe1_photons_1.ref \
     functional_tests/ref-output-double/circe1_photons_2.ref \
     functional_tests/ref-output-double/circe1_photons_3.ref \
     functional_tests/ref-output-double/circe1_photons_4.ref \
     functional_tests/ref-output-double/circe1_photons_5.ref \
     functional_tests/ref-output-double/colors_2.ref \
     functional_tests/ref-output-double/defaultcuts.ref \
     functional_tests/ref-output-double/ep_1.ref \
     functional_tests/ref-output-double/ep_2.ref \
     functional_tests/ref-output-double/ewa_1.ref \
     functional_tests/ref-output-double/ewa_2.ref \
     functional_tests/ref-output-double/ewa_3.ref \
     functional_tests/ref-output-double/fks_res_1.ref \
     functional_tests/ref-output-double/fks_res_3.ref \
     functional_tests/ref-output-double/helicity.ref \
     functional_tests/ref-output-double/hepmc_8.ref \
     functional_tests/ref-output-double/ilc.ref \
     functional_tests/ref-output-double/isr_2.ref \
     functional_tests/ref-output-double/isr_3.ref \
     functional_tests/ref-output-double/isr_4.ref \
     functional_tests/ref-output-double/isr_5.ref \
     functional_tests/ref-output-double/isr_6.ref \
     functional_tests/ref-output-double/lcio_2.ref \
     functional_tests/ref-output-double/lcio_7.ref \
     functional_tests/ref-output-double/lcio_12.ref \
     functional_tests/ref-output-double/lhapdf5.ref \
     functional_tests/ref-output-double/lhapdf6.ref \
     functional_tests/ref-output-double/lhef_7.ref \
     functional_tests/ref-output-double/mlm_matching_isr.ref \
     functional_tests/ref-output-double/multi_comp_1.ref \
     functional_tests/ref-output-double/multi_comp_2.ref \
     functional_tests/ref-output-double/multi_comp_3.ref \
     functional_tests/ref-output-double/testproc_12.ref \
     functional_tests/ref-output-double/nlo_3.ref \
     functional_tests/ref-output-double/nlo_4.ref \
     functional_tests/ref-output-double/nlo_5.ref \
     functional_tests/ref-output-double/nlo_7.ref \
     functional_tests/ref-output-double/nlo_8.ref \
     functional_tests/ref-output-double/nlo_9.ref \
     functional_tests/ref-output-double/nlo_10.ref \
     functional_tests/ref-output-double/observables_2.ref \
     functional_tests/ref-output-double/openloops_3.ref \
     functional_tests/ref-output-double/openloops_12.ref \
     functional_tests/ref-output-double/openloops_13.ref \
     functional_tests/ref-output-double/openloops_14.ref \
     functional_tests/ref-output-double/parton_shower_2.ref \
     functional_tests/ref-output-double/pdf_builtin.ref \
     functional_tests/ref-output-double/powheg_1.ref \
     functional_tests/ref-output-double/pythia6_3.ref \
     functional_tests/ref-output-double/pythia6_4.ref \
     functional_tests/ref-output-double/qcdtest_1.ref \
     functional_tests/ref-output-double/qcdtest_2.ref \
     functional_tests/ref-output-double/qcdtest_3.ref \
     functional_tests/ref-output-double/qedtest_3.ref \
     functional_tests/ref-output-double/qedtest_4.ref \
     functional_tests/ref-output-double/resonances_1.ref \
     functional_tests/ref-output-double/resonances_2.ref \
     functional_tests/ref-output-double/resonances_3.ref \
     functional_tests/ref-output-double/resonances_4.ref \
     functional_tests/ref-output-double/resonances_10.ref \
     functional_tests/ref-output-double/resonances_11.ref \
     functional_tests/ref-output-double/resonances_13.ref \
     functional_tests/ref-output-double/resonances_14.ref \
     functional_tests/ref-output-double/resonances_15.ref \
     functional_tests/ref-output-double/smtest_2.ref \
     functional_tests/ref-output-double/smtest_8.ref \
     functional_tests/ref-output-double/tauola_1.ref \
     functional_tests/ref-output-double/tauola_2.ref \
     functional_tests/ref-output-double/tauola_3.ref
 
 REF_OUTPUT_FILES_PREC = \
     functional_tests/ref-output-prec/beam_setup_5.ref \
     functional_tests/ref-output-prec/circe1_9.ref \
     functional_tests/ref-output-prec/circe1_photons_1.ref \
     functional_tests/ref-output-prec/circe1_photons_2.ref \
     functional_tests/ref-output-prec/circe1_photons_3.ref \
     functional_tests/ref-output-prec/circe1_photons_4.ref \
     functional_tests/ref-output-prec/circe1_photons_5.ref \
     functional_tests/ref-output-prec/colors_2.ref \
     functional_tests/ref-output-prec/defaultcuts.ref \
     functional_tests/ref-output-prec/ep_1.ref \
     functional_tests/ref-output-prec/ep_2.ref \
     functional_tests/ref-output-prec/ewa_1.ref \
     functional_tests/ref-output-prec/fks_res_1.ref \
     functional_tests/ref-output-prec/fks_res_3.ref \
     functional_tests/ref-output-prec/helicity.ref \
     functional_tests/ref-output-prec/ilc.ref \
     functional_tests/ref-output-prec/lhapdf5.ref \
     functional_tests/ref-output-prec/lhapdf6.ref \
     functional_tests/ref-output-prec/lhef_7.ref \
     functional_tests/ref-output-prec/multi_comp_1.ref \
     functional_tests/ref-output-prec/multi_comp_2.ref \
     functional_tests/ref-output-prec/multi_comp_3.ref \
     functional_tests/ref-output-prec/testproc_12.ref \
     functional_tests/ref-output-prec/nlo_3.ref \
     functional_tests/ref-output-prec/nlo_4.ref \
     functional_tests/ref-output-prec/parton_shower_2.ref \
     functional_tests/ref-output-prec/pdf_builtin.ref \
     functional_tests/ref-output-prec/qcdtest_1.ref \
     functional_tests/ref-output-prec/qcdtest_2.ref \
     functional_tests/ref-output-prec/qcdtest_3.ref \
     functional_tests/ref-output-prec/qedtest_3.ref \
     functional_tests/ref-output-prec/qedtest_4.ref \
     functional_tests/ref-output-prec/smtest_2.ref \
     functional_tests/ref-output-prec/smtest_8.ref
 
 REF_OUTPUT_FILES_EXT = \
     functional_tests/ref-output-ext/beam_events_2.ref \
     functional_tests/ref-output-ext/beam_events_3.ref \
     functional_tests/ref-output-ext/circe1_4.ref \
     functional_tests/ref-output-ext/circe1_5.ref \
     functional_tests/ref-output-ext/circe1_7.ref \
     functional_tests/ref-output-ext/circe1_8.ref \
     functional_tests/ref-output-ext/ewa_2.ref \
     functional_tests/ref-output-ext/ewa_3.ref \
     functional_tests/ref-output-ext/hepmc_8.ref \
     functional_tests/ref-output-ext/isr_2.ref \
     functional_tests/ref-output-ext/isr_3.ref \
     functional_tests/ref-output-ext/isr_4.ref \
     functional_tests/ref-output-ext/isr_5.ref \
     functional_tests/ref-output-ext/isr_6.ref \
     functional_tests/ref-output-ext/lcio_2.ref \
     functional_tests/ref-output-ext/lcio_7.ref \
     functional_tests/ref-output-ext/lcio_12.ref \
     functional_tests/ref-output-ext/mlm_matching_isr.ref \
     functional_tests/ref-output-ext/nlo_5.ref \
     functional_tests/ref-output-ext/nlo_7.ref \
     functional_tests/ref-output-ext/nlo_8.ref \
     functional_tests/ref-output-ext/nlo_9.ref \
     functional_tests/ref-output-ext/nlo_10.ref \
     functional_tests/ref-output-ext/observables_2.ref \
     functional_tests/ref-output-ext/openloops_3.ref \
     functional_tests/ref-output-ext/openloops_12.ref \
     functional_tests/ref-output-ext/openloops_13.ref \
     functional_tests/ref-output-ext/openloops_14.ref \
     functional_tests/ref-output-ext/powheg_1.ref \
     functional_tests/ref-output-ext/pythia6_3.ref \
     functional_tests/ref-output-ext/pythia6_4.ref \
     functional_tests/ref-output-ext/resonances_1.ref \
     functional_tests/ref-output-ext/resonances_2.ref \
     functional_tests/ref-output-ext/resonances_3.ref \
     functional_tests/ref-output-ext/resonances_4.ref \
     functional_tests/ref-output-ext/resonances_10.ref \
     functional_tests/ref-output-ext/resonances_11.ref \
     functional_tests/ref-output-ext/resonances_13.ref \
     functional_tests/ref-output-ext/resonances_14.ref \
     functional_tests/ref-output-ext/resonances_15.ref \
     functional_tests/ref-output-ext/tauola_1.ref \
     functional_tests/ref-output-ext/tauola_2.ref \
     functional_tests/ref-output-ext/tauola_3.ref
 
 REF_OUTPUT_FILES_QUAD = \
     functional_tests/ref-output-quad/beam_events_2.ref \
     functional_tests/ref-output-quad/beam_events_3.ref \
     functional_tests/ref-output-quad/circe1_4.ref \
     functional_tests/ref-output-quad/circe1_5.ref \
     functional_tests/ref-output-quad/circe1_7.ref \
     functional_tests/ref-output-quad/circe1_8.ref \
     functional_tests/ref-output-quad/ewa_2.ref \
     functional_tests/ref-output-quad/ewa_3.ref \
     functional_tests/ref-output-quad/hepmc_8.ref \
     functional_tests/ref-output-quad/isr_2.ref \
     functional_tests/ref-output-quad/isr_3.ref \
     functional_tests/ref-output-quad/isr_4.ref \
     functional_tests/ref-output-quad/isr_5.ref \
     functional_tests/ref-output-quad/isr_6.ref \
     functional_tests/ref-output-quad/lcio_2.ref \
     functional_tests/ref-output-quad/lcio_7.ref \
     functional_tests/ref-output-quad/lcio_12.ref \
     functional_tests/ref-output-quad/mlm_matching_isr.ref \
     functional_tests/ref-output-quad/nlo_5.ref \
     functional_tests/ref-output-quad/nlo_7.ref \
     functional_tests/ref-output-quad/nlo_8.ref \
     functional_tests/ref-output-quad/nlo_9.ref \
     functional_tests/ref-output-quad/nlo_10.ref \
     functional_tests/ref-output-quad/observables_2.ref \
     functional_tests/ref-output-quad/openloops_3.ref \
     functional_tests/ref-output-quad/openloops_12.ref \
     functional_tests/ref-output-quad/openloops_13.ref \
     functional_tests/ref-output-quad/openloops_14.ref \
     functional_tests/ref-output-quad/powheg_1.ref \
     functional_tests/ref-output-quad/pythia6_3.ref \
     functional_tests/ref-output-quad/pythia6_4.ref \
     functional_tests/ref-output-quad/resonances_1.ref \
     functional_tests/ref-output-quad/resonances_2.ref \
     functional_tests/ref-output-quad/resonances_3.ref \
     functional_tests/ref-output-quad/resonances_4.ref \
     functional_tests/ref-output-quad/resonances_10.ref \
     functional_tests/ref-output-quad/resonances_11.ref \
     functional_tests/ref-output-quad/resonances_13.ref \
     functional_tests/ref-output-quad/resonances_14.ref \
     functional_tests/ref-output-quad/resonances_15.ref \
     functional_tests/ref-output-quad/tauola_1.ref \
     functional_tests/ref-output-quad/tauola_2.ref \
     functional_tests/ref-output-quad/tauola_3.ref
 
 TESTSUITES_M4 = \
     $(MISC_TESTS_M4) \
     $(EXT_MSSM_M4) \
     $(EXT_NMSSM_M4)
 
 TESTSUITES_SIN = \
     $(MISC_TESTS_SIN) \
     $(EXT_ILC_SIN) \
     $(EXT_MSSM_SIN) \
     $(EXT_NMSSM_SIN) \
     $(EXT_SHOWER_SIN) \
     $(EXT_NLO_SIN) \
     $(EXT_NLO_ADD_SIN)
 
 
 MISC_TESTS_M4 =
 
 MISC_TESTS_SIN = \
     functional_tests/alphas.sin \
     functional_tests/analyze_1.sin \
     functional_tests/analyze_2.sin \
     functional_tests/analyze_3.sin \
     functional_tests/analyze_4.sin \
     functional_tests/analyze_5.sin \
     functional_tests/analyze_6.sin \
     functional_tests/beam_events_1.sin \
     functional_tests/beam_events_2.sin \
     functional_tests/beam_events_3.sin \
     functional_tests/beam_events_4.sin \
     functional_tests/beam_setup_1.sin \
     functional_tests/beam_setup_2.sin \
     functional_tests/beam_setup_3.sin \
     functional_tests/beam_setup_4.sin \
     functional_tests/beam_setup_5.sin \
     functional_tests/bjet_cluster.sin \
     functional_tests/br_redef_1.sin \
     functional_tests/cascades2_phs_1.sin \
     functional_tests/cascades2_phs_2.sin \
     functional_tests/circe1_1.sin \
     functional_tests/circe1_2.sin \
     functional_tests/circe1_3.sin \
     functional_tests/circe1_4.sin \
     functional_tests/circe1_5.sin \
     functional_tests/circe1_6.sin \
     functional_tests/circe1_7.sin \
     functional_tests/circe1_8.sin \
     functional_tests/circe1_9.sin \
     functional_tests/circe1_10.sin \
     functional_tests/circe1_errors_1.sin \
     functional_tests/circe1_photons_1.sin \
     functional_tests/circe1_photons_2.sin \
     functional_tests/circe1_photons_3.sin \
     functional_tests/circe1_photons_4.sin \
     functional_tests/circe1_photons_5.sin \
     functional_tests/circe2_1.sin \
     functional_tests/circe2_2.sin \
     functional_tests/circe2_3.sin \
     functional_tests/cmdline_1.sin \
     functional_tests/cmdline_1_a.sin \
     functional_tests/cmdline_1_b.sin \
     functional_tests/colors.sin \
     functional_tests/colors_2.sin \
     functional_tests/colors_hgg.sin \
     functional_tests/cuts.sin \
     functional_tests/decay_err_1.sin \
     functional_tests/decay_err_2.sin \
     functional_tests/decay_err_3.sin \
     functional_tests/defaultcuts.sin \
     functional_tests/empty.sin \
     functional_tests/energy_scan_1.sin \
     functional_tests/ep_1.sin \
     functional_tests/ep_2.sin \
     functional_tests/ep_3.sin \
     functional_tests/epa_1.sin \
     functional_tests/epa_2.sin \
     functional_tests/epa_3.sin \
     functional_tests/epa_4.sin \
     functional_tests/event_dump_1.sin \
     functional_tests/event_dump_2.sin \
     functional_tests/event_eff_1.sin \
     functional_tests/event_eff_2.sin \
     functional_tests/event_failed_1.sin \
     functional_tests/event_weights_1.sin \
     functional_tests/event_weights_2.sin \
     functional_tests/ewa_1.sin \
     functional_tests/ewa_2.sin \
     functional_tests/ewa_3.sin \
     functional_tests/ewa_4.sin \
     functional_tests/extpar.sin \
     functional_tests/fatal.sin \
     functional_tests/fatal_beam_decay.sin \
     functional_tests/fks_res_1.sin \
     functional_tests/fks_res_2.sin \
     functional_tests/fks_res_3.sin \
     functional_tests/flvsum_1.sin \
     functional_tests/gaussian_1.sin \
     functional_tests/gaussian_2.sin \
     functional_tests/hadronize_1.sin \
     functional_tests/helicity.sin \
     functional_tests/hepmc_1.sin \
     functional_tests/hepmc_2.sin \
     functional_tests/hepmc_3.sin \
     functional_tests/hepmc_4.sin \
     functional_tests/hepmc_5.sin \
     functional_tests/hepmc_6.sin \
     functional_tests/hepmc_7.sin \
     functional_tests/hepmc_8.sin \
     functional_tests/hepmc_9.sin \
     functional_tests/hepmc_10.sin \
     functional_tests/ilc.sin \
     functional_tests/isr_1.sin \
     functional_tests/isr_2.sin \
     functional_tests/isr_3.sin \
     functional_tests/isr_4.sin \
     functional_tests/isr_5.sin \
     functional_tests/isr_6.sin \
     functional_tests/isr_epa_1.sin \
     functional_tests/jets_xsec.sin \
     functional_tests/job_id_1.sin \
     functional_tests/job_id_2.sin \
     functional_tests/job_id_3.sin \
     functional_tests/job_id_4.sin \
     functional_tests/lcio_1.sin \
     functional_tests/lcio_2.sin \
     functional_tests/lcio_3.sin \
     functional_tests/lcio_4.sin \
     functional_tests/lcio_5.sin \
     functional_tests/lcio_6.sin \
     functional_tests/lcio_7.sin \
     functional_tests/lcio_8.sin \
     functional_tests/lcio_9.sin \
     functional_tests/lcio_10.sin \
     functional_tests/lcio_11.sin \
     functional_tests/lcio_12.sin \
     functional_tests/lhapdf5.sin \
     functional_tests/lhapdf6.sin \
     functional_tests/lhef_1.sin \
     functional_tests/lhef_2.sin \
     functional_tests/lhef_3.sin \
     functional_tests/lhef_4.sin \
     functional_tests/lhef_5.sin \
     functional_tests/lhef_6.sin \
     functional_tests/lhef_7.sin \
     functional_tests/lhef_8.sin \
     functional_tests/lhef_9.sin \
     functional_tests/lhef_10.sin \
     functional_tests/lhef_11.sin \
     functional_tests/libraries_1.sin \
     functional_tests/libraries_2.sin \
     functional_tests/libraries_3.sin \
     functional_tests/libraries_4.sin \
     functional_tests/method_ovm_1.sin \
     functional_tests/mlm_matching_fsr.sin \
     functional_tests/mlm_matching_isr.sin \
     functional_tests/mlm_pythia6_isr.sin \
     functional_tests/model_change_1.sin \
     functional_tests/model_change_2.sin \
     functional_tests/model_change_3.sin \
     functional_tests/model_scheme_1.sin \
     functional_tests/model_test.sin \
     functional_tests/mssmtest_1.sin \
     functional_tests/mssmtest_2.sin \
     functional_tests/mssmtest_3.sin \
     functional_tests/multi_comp_1.sin \
     functional_tests/multi_comp_2.sin \
     functional_tests/multi_comp_3.sin \
     functional_tests/multi_comp_4.sin \
     functional_tests/nlo_1.sin \
     functional_tests/nlo_2.sin \
     functional_tests/nlo_3.sin \
     functional_tests/nlo_4.sin \
     functional_tests/nlo_5.sin \
     functional_tests/nlo_6.sin \
     functional_tests/nlo_7.sin \
     functional_tests/nlo_8.sin \
     functional_tests/nlo_9.sin \
     functional_tests/nlo_10.sin \
     functional_tests/nlo_decay_1.sin \
     functional_tests/observables_1.sin \
     functional_tests/observables_2.sin \
     functional_tests/openloops_1.sin \
     functional_tests/openloops_2.sin \
     functional_tests/openloops_3.sin \
     functional_tests/openloops_4.sin \
     functional_tests/openloops_5.sin \
     functional_tests/openloops_6.sin \
     functional_tests/openloops_7.sin \
     functional_tests/openloops_8.sin \
     functional_tests/openloops_9.sin \
     functional_tests/openloops_10.sin \
     functional_tests/openloops_11.sin \
     functional_tests/openloops_12.sin \
     functional_tests/openloops_13.sin \
     functional_tests/openloops_14.sin \
     functional_tests/pack_1.sin \
     functional_tests/parton_shower_1.sin \
     functional_tests/parton_shower_2.sin \
     functional_tests/pdf_builtin.sin \
     functional_tests/photon_isolation_1.sin \
     functional_tests/photon_isolation_2.sin \
     functional_tests/polarized_1.sin \
     functional_tests/powheg_1.sin \
     functional_tests/process_log.sin \
     functional_tests/pythia6_1.sin \
     functional_tests/pythia6_2.sin \
     functional_tests/pythia6_3.sin \
     functional_tests/pythia6_4.sin \
     functional_tests/pythia8_1.sin \
     functional_tests/pythia8_2.sin \
     functional_tests/qcdtest_1.sin \
     functional_tests/qcdtest_2.sin \
     functional_tests/qcdtest_3.sin \
     functional_tests/qcdtest_4.sin \
     functional_tests/qcdtest_5.sin \
     functional_tests/qcdtest_6.sin \
     functional_tests/qedtest_1.sin \
     functional_tests/qedtest_2.sin \
     functional_tests/qedtest_3.sin \
     functional_tests/qedtest_4.sin \
     functional_tests/qedtest_5.sin \
     functional_tests/qedtest_6.sin \
     functional_tests/qedtest_7.sin \
     functional_tests/qedtest_8.sin \
     functional_tests/qedtest_9.sin \
     functional_tests/qedtest_10.sin \
     functional_tests/rambo_vamp_1.sin \
     functional_tests/rambo_vamp_2.sin \
     functional_tests/real_partition_1.sin \
     functional_tests/rebuild_1.sin \
     functional_tests/rebuild_2.sin \
     functional_tests/rebuild_3.sin \
     functional_tests/rebuild_4.sin \
     functional_tests/rebuild_5.sin \
     functional_tests/recola_1.sin \
     functional_tests/recola_2.sin \
     functional_tests/recola_3.sin \
     functional_tests/recola_4.sin \
     functional_tests/recola_5.sin \
     functional_tests/recola_6.sin \
     functional_tests/recola_7.sin \
     functional_tests/recola_8.sin \
     functional_tests/recola_9.sin \
     functional_tests/resonances_1.sin \
     functional_tests/resonances_2.sin \
     functional_tests/resonances_3.sin \
     functional_tests/resonances_4.sin \
     functional_tests/resonances_5.sin \
     functional_tests/resonances_6.sin \
     functional_tests/resonances_7.sin \
     functional_tests/resonances_8.sin \
     functional_tests/resonances_9.sin \
     functional_tests/resonances_10.sin \
     functional_tests/resonances_11.sin \
     functional_tests/resonances_12.sin \
     functional_tests/resonances_13.sin \
     functional_tests/resonances_14.sin \
     functional_tests/resonances_15.sin \
     functional_tests/restrictions.sin \
     functional_tests/reweight_1.sin \
     functional_tests/reweight_2.sin \
     functional_tests/reweight_3.sin \
     functional_tests/reweight_4.sin \
     functional_tests/reweight_5.sin \
     functional_tests/reweight_6.sin \
     functional_tests/reweight_7.sin \
     functional_tests/reweight_8.sin \
     functional_tests/reweight_9.sin \
     functional_tests/reweight_10.sin \
     functional_tests/select_1.sin \
     functional_tests/select_2.sin \
     functional_tests/show_1.sin \
     functional_tests/show_2.sin \
     functional_tests/show_3.sin \
     functional_tests/show_4.sin \
     functional_tests/show_5.sin \
     functional_tests/shower_err_1.sin \
     functional_tests/sm_cms_1.sin \
     functional_tests/smtest_1.sin \
     functional_tests/smtest_2.sin \
     functional_tests/smtest_3.sin \
     functional_tests/smtest_4.sin \
     functional_tests/smtest_5.sin \
     functional_tests/smtest_6.sin \
     functional_tests/smtest_7.sin \
     functional_tests/smtest_8.sin \
     functional_tests/smtest_9.sin \
     functional_tests/smtest_10.sin \
     functional_tests/smtest_11.sin \
     functional_tests/smtest_12.sin \
     functional_tests/smtest_13.sin \
     functional_tests/smtest_14.sin \
     functional_tests/smtest_15.sin \
     functional_tests/smtest_16.sin \
     functional_tests/spincor_1.sin \
     functional_tests/static_1.exe.sin \
     functional_tests/static_1.sin \
     functional_tests/static_2.exe.sin \
     functional_tests/static_2.sin \
     functional_tests/stdhep_1.sin \
     functional_tests/stdhep_2.sin \
     functional_tests/stdhep_3.sin \
     functional_tests/stdhep_4.sin \
     functional_tests/stdhep_5.sin \
     functional_tests/stdhep_6.sin \
     functional_tests/structure_1.sin \
     functional_tests/structure_2.sin \
     functional_tests/structure_3.sin \
     functional_tests/structure_4.sin \
     functional_tests/structure_5.sin \
     functional_tests/structure_6.sin \
     functional_tests/structure_7.sin \
     functional_tests/structure_8.sin \
     functional_tests/susyhit.sin \
     functional_tests/tauola_1.sin \
     functional_tests/tauola_2.sin \
     functional_tests/tauola_3.sin \
     functional_tests/template_me_1.sin \
     functional_tests/template_me_2.sin \
     functional_tests/testproc_1.sin \
     functional_tests/testproc_2.sin \
     functional_tests/testproc_3.sin \
     functional_tests/testproc_4.sin \
     functional_tests/testproc_5.sin \
     functional_tests/testproc_6.sin \
     functional_tests/testproc_7.sin \
     functional_tests/testproc_8.sin \
     functional_tests/testproc_9.sin \
     functional_tests/testproc_10.sin \
     functional_tests/testproc_11.sin \
     functional_tests/testproc_12.sin \
     functional_tests/ufo_1.sin \
     functional_tests/ufo_2.sin \
     functional_tests/ufo_3.sin \
     functional_tests/ufo_4.sin \
     functional_tests/ufo_5.sin \
     functional_tests/ufo_6.sin \
     functional_tests/user_prc_threshold_1.sin \
     functional_tests/user_prc_threshold_2.sin \
     functional_tests/vamp2_1.sin \
     functional_tests/vamp2_2.sin \
     functional_tests/vamp2_3.sin \
     functional_tests/vars.sin
 
 EXT_MSSM_M4 = \
     ext_tests_mssm/mssm_ext-aa.m4 \
     ext_tests_mssm/mssm_ext-bb.m4 \
     ext_tests_mssm/mssm_ext-bt.m4 \
     ext_tests_mssm/mssm_ext-dd.m4 \
     ext_tests_mssm/mssm_ext-dd2.m4 \
     ext_tests_mssm/mssm_ext-ddckm.m4 \
     ext_tests_mssm/mssm_ext-dg.m4 \
     ext_tests_mssm/mssm_ext-ee.m4 \
     ext_tests_mssm/mssm_ext-ee2.m4 \
     ext_tests_mssm/mssm_ext-en.m4 \
     ext_tests_mssm/mssm_ext-ga.m4 \
     ext_tests_mssm/mssm_ext-gg.m4 \
     ext_tests_mssm/mssm_ext-gw.m4 \
     ext_tests_mssm/mssm_ext-gz.m4 \
     ext_tests_mssm/mssm_ext-tn.m4 \
     ext_tests_mssm/mssm_ext-tt.m4 \
     ext_tests_mssm/mssm_ext-ug.m4 \
     ext_tests_mssm/mssm_ext-uu.m4 \
     ext_tests_mssm/mssm_ext-uu2.m4 \
     ext_tests_mssm/mssm_ext-uuckm.m4 \
     ext_tests_mssm/mssm_ext-wa.m4 \
     ext_tests_mssm/mssm_ext-ww.m4 \
     ext_tests_mssm/mssm_ext-wz.m4 \
     ext_tests_mssm/mssm_ext-za.m4 \
     ext_tests_mssm/mssm_ext-zz.m4
 
 EXT_NMSSM_M4 = \
     ext_tests_nmssm/nmssm_ext-aa.m4  \
     ext_tests_nmssm/nmssm_ext-bb1.m4 \
     ext_tests_nmssm/nmssm_ext-bb2.m4 \
     ext_tests_nmssm/nmssm_ext-bt.m4  \
     ext_tests_nmssm/nmssm_ext-dd1.m4 \
     ext_tests_nmssm/nmssm_ext-dd2.m4 \
     ext_tests_nmssm/nmssm_ext-ee1.m4 \
     ext_tests_nmssm/nmssm_ext-ee2.m4 \
     ext_tests_nmssm/nmssm_ext-en.m4  \
     ext_tests_nmssm/nmssm_ext-ga.m4  \
     ext_tests_nmssm/nmssm_ext-gg.m4  \
     ext_tests_nmssm/nmssm_ext-gw.m4  \
     ext_tests_nmssm/nmssm_ext-gz.m4  \
     ext_tests_nmssm/nmssm_ext-qg.m4  \
     ext_tests_nmssm/nmssm_ext-tn.m4  \
     ext_tests_nmssm/nmssm_ext-tt1.m4 \
     ext_tests_nmssm/nmssm_ext-tt2.m4 \
     ext_tests_nmssm/nmssm_ext-uu1.m4 \
     ext_tests_nmssm/nmssm_ext-uu2.m4 \
     ext_tests_nmssm/nmssm_ext-wa.m4  \
     ext_tests_nmssm/nmssm_ext-ww1.m4 \
     ext_tests_nmssm/nmssm_ext-ww2.m4 \
     ext_tests_nmssm/nmssm_ext-wz.m4  \
     ext_tests_nmssm/nmssm_ext-za.m4  \
     ext_tests_nmssm/nmssm_ext-zz1.m4 \
     ext_tests_nmssm/nmssm_ext-zz2.m4
 
 EXT_MSSM_SIN = $(EXT_MSSM_M4:.m4=.sin)
 EXT_NMSSM_SIN = $(EXT_NMSSM_M4:.m4=.sin)
 
 EXT_ILC_SIN = \
     ext_tests_ilc/ilc_settings.sin \
     ext_tests_ilc/ilc_top_pair_360.sin \
     ext_tests_ilc/ilc_top_pair_500.sin \
     ext_tests_ilc/ilc_vbf_higgs_360.sin \
     ext_tests_ilc/ilc_vbf_higgs_500.sin \
     ext_tests_ilc/ilc_vbf_no_higgs_360.sin \
     ext_tests_ilc/ilc_vbf_no_higgs_500.sin \
     ext_tests_ilc/ilc_higgs_strahlung_360.sin \
     ext_tests_ilc/ilc_higgs_strahlung_500.sin \
     ext_tests_ilc/ilc_higgs_strahlung_background_360.sin \
     ext_tests_ilc/ilc_higgs_strahlung_background_500.sin \
     ext_tests_ilc/ilc_higgs_coupling_360.sin \
     ext_tests_ilc/ilc_higgs_coupling_500.sin \
     ext_tests_ilc/ilc_higgs_coupling_background_360.sin \
     ext_tests_ilc/ilc_higgs_coupling_background_500.sin
 
 EXT_SHOWER_SIN = \
     ext_tests_shower/shower_1_norad.sin \
     ext_tests_shower/shower_2_aall.sin \
     ext_tests_shower/shower_3_bb.sin \
     ext_tests_shower/shower_3_jj.sin \
     ext_tests_shower/shower_3_qqqq.sin \
     ext_tests_shower/shower_3_tt.sin \
     ext_tests_shower/shower_3_z_nu.sin \
     ext_tests_shower/shower_3_z_tau.sin \
     ext_tests_shower/shower_4_ee.sin \
     ext_tests_shower/shower_5.sin \
     ext_tests_shower/shower_6.sin
 
 EXT_NLO_SIN = \
     ext_tests_nlo/nlo_ee4b.sin \
     ext_tests_nlo/nlo_ee4j.sin \
     ext_tests_nlo/nlo_ee4t.sin \
     ext_tests_nlo/nlo_ee4tj.sin \
     ext_tests_nlo/nlo_ee5j.sin \
     ext_tests_nlo/nlo_eebb.sin \
     ext_tests_nlo/nlo_eebbj.sin \
     ext_tests_nlo/nlo_eebbjj.sin \
     ext_tests_nlo/nlo_eejj.sin \
     ext_tests_nlo/nlo_eejjj.sin \
     ext_tests_nlo/nlo_eett.sin \
     ext_tests_nlo/nlo_eetta.sin \
     ext_tests_nlo/nlo_eettaa.sin \
     ext_tests_nlo/nlo_eettah.sin \
     ext_tests_nlo/nlo_eettaj.sin \
     ext_tests_nlo/nlo_eettajj.sin \
     ext_tests_nlo/nlo_eettaz.sin \
     ext_tests_nlo/nlo_eettbb.sin \
     ext_tests_nlo/nlo_eetth.sin \
     ext_tests_nlo/nlo_eetthh.sin \
     ext_tests_nlo/nlo_eetthj.sin \
     ext_tests_nlo/nlo_eetthjj.sin \
     ext_tests_nlo/nlo_eetthz.sin \
     ext_tests_nlo/nlo_eettj.sin \
     ext_tests_nlo/nlo_eettjj.sin \
     ext_tests_nlo/nlo_eettjjj.sin \
     ext_tests_nlo/nlo_eettwjj.sin \
     ext_tests_nlo/nlo_eettww.sin \
     ext_tests_nlo/nlo_eettz.sin \
     ext_tests_nlo/nlo_eettzj.sin \
     ext_tests_nlo/nlo_eettzjj.sin \
     ext_tests_nlo/nlo_eettzz.sin \
+    ext_tests_nlo/nlo_ppjj_real_partition.sin \
     ext_tests_nlo/nlo_pptttt.sin \
     ext_tests_nlo/nlo_ppw.sin \
     ext_tests_nlo/nlo_ppz.sin \
     ext_tests_nlo/nlo_ppzj_sim_1.sin \
     ext_tests_nlo/nlo_ppzj_sim_2.sin \
     ext_tests_nlo/nlo_ppzj_sim_3.sin \
     ext_tests_nlo/nlo_ppzj_sim_4.sin \
     ext_tests_nlo/nlo_ppzw.sin \
     ext_tests_nlo/nlo_ppzz.sin \
     ext_tests_nlo/nlo_settings.sin
 
 EXT_NLO_ADD_SIN = \
     ext_tests_nlo_add/nlo_decay_tbw.sin \
     ext_tests_nlo_add/nlo_fks_delta_i_ppee.sin \
     ext_tests_nlo_add/nlo_fks_delta_o_eejj.sin \
     ext_tests_nlo_add/nlo_jets.sin \
     ext_tests_nlo_add/nlo_methods_gosam.sin \
     ext_tests_nlo_add/nlo_qq_powheg.sin \
     ext_tests_nlo_add/nlo_threshold_factorized.sin \
     ext_tests_nlo_add/nlo_threshold.sin \
     ext_tests_nlo_add/nlo_tt_powheg_sudakov.sin \
     ext_tests_nlo_add/nlo_tt_powheg.sin \
     ext_tests_nlo_add/nlo_tt.sin \
     ext_tests_nlo_add/nlo_uu_powheg.sin \
     ext_tests_nlo_add/nlo_uu.sin
 
 all-local: $(TESTSUITES_SIN)
 
 if M4_AVAILABLE
 SUFFIXES = .m4 .sin
 .m4.sin:
 	case "$@" in \
 	*/*) \
 		mkdir -p `sed 's,/.[^/]*$$,,g' <<< "$@"` ;; \
 	esac
 	$(M4) $(srcdir)/$(TESTSUITE_MACROS) $< > $@
 endif M4_AVAILABLE
Index: trunk/tests/ext_tests_nlo/Makefile.am
===================================================================
--- trunk/tests/ext_tests_nlo/Makefile.am	(revision 8732)
+++ trunk/tests/ext_tests_nlo/Makefile.am	(revision 8733)
@@ -1,299 +1,301 @@
 ## Makefile.am -- Makefile for executable WHIZARD test scripts
 ##
 ## Process this file with automake to produce Makefile.in
 ##
 ########################################################################
 #
 # Copyright (C) 1999-2021 by
 #     Wolfgang Kilian <kilian@physik.uni-siegen.de>
 #     Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
 #     Juergen Reuter <juergen.reuter@desy.de>
 #     with contributions from
 #     cf. main AUTHORS file
 #
 # WHIZARD is free software; you can redistribute it and/or modify it
 # under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 2, or (at your option)
 # any later version.
 #
 # WHIZARD is distributed in the hope that it will be useful, but
 # WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 # GNU General Public License for more details.
 #
 # You should have received a copy of the GNU General Public License
 # along with this program; if not, write to the Free Software
 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 #
 ########################################################################
 
 WHIZARD_DRIVER = run_whizard.sh
 
 TESTS_EXTENDED = \
 	nlo_ee4b.run \
 	nlo_ee4j.run \
 	nlo_ee4t.run \
 	nlo_ee4tj.run \
 	nlo_ee5j.run \
 	nlo_eebb.run \
 	nlo_eebbj.run \
 	nlo_eebbjj.run \
 	nlo_eejj.run \
 	nlo_eejjj.run \
 	nlo_eett.run \
 	nlo_eetta.run \
 	nlo_eettaa.run \
 	nlo_eettah.run \
 	nlo_eettaj.run \
 	nlo_eettajj.run \
 	nlo_eettaz.run \
 	nlo_eettbb.run \
 	nlo_eetth.run \
 	nlo_eetthh.run \
 	nlo_eetthj.run \
 	nlo_eetthjj.run \
 	nlo_eetthz.run \
 	nlo_eettj.run \
 	nlo_eettjj.run \
 	nlo_eettjjj.run \
 	nlo_eettwjj.run \
 	nlo_eettww.run \
 	nlo_eettz.run \
 	nlo_eettzj.run \
 	nlo_eettzjj.run \
 	nlo_eettzz.run \
+	nlo_ppjj_real_partition.run \
 	nlo_ppz.run \
 	nlo_ppzj_sim_1.run \
 	nlo_ppzj_sim_2.run \
 	nlo_ppzj_sim_3.run \
 	nlo_ppzj_sim_4.run \
 	nlo_ppw.run \
 	nlo_ppzz.run \
 	nlo_ppzw.run \
 	nlo_pptttt.run
 
 XFAIL_TESTS_EXTENDED =
 
 TESTS_REQ_GAMELAN =
 
 TEST_DRIVERS_RUN = \
     $(TESTS_EXTENDED)
 
 TEST_DRIVERS_SH = $(TEST_DRIVERS_RUN:.run=.sh)
 
 ########################################################################
 
 TESTS = $(TESTS_EXTENDED)
 XFAIL_TESTS = $(XFAIL_TESTS_EXTENDED)
 
 EXTRA_DIST = $(TEST_DRIVERS_SH)
 
 ########################################################################
 
 VPATH = $(srcdir)
 
 SUFFIXES = .sh .run
 
 .sh.run:
 	@rm -f $@
 	@if test -f $(top_builddir)/share/tests/ext_tests_nlo/$*.sin; then \
 	  $(SED) 's|@script@|$(top_builddir)/share/tests/ext_tests_nlo/$*|g' $< > $@; \
 	elif test -f $(top_srcdir)/share/tests/ext_tests_nlo/$*.sin; then \
 	  $(SED) 's|@script@|$(top_srcdir)/share/tests/ext_tests_nlo/$*|g' $< > $@; \
 	fi
 	@chmod +x $@
 
 nlo_eejj.run: nlo_settings.sin
 nlo_eejjj.run: nlo_settings.sin
 nlo_ee4j.run: nlo_settings.sin
 nlo_ee5j.run: nlo_settings.sin
 nlo_eebb.run: nlo_settings.sin
 nlo_eebbj.run: nlo_settings.sin
 nlo_eebbjj.run: nlo_settings.sin
 nlo_ee4b.run: nlo_settings.sin
 nlo_eett.run: nlo_settings.sin
 nlo_eettj.run: nlo_settings.sin
 nlo_eettjj.run: nlo_settings.sin
 nlo_eettjjj.run: nlo_settings.sin
 nlo_eettbb.run: nlo_settings.sin
 nlo_eetta.run: nlo_settings.sin
 nlo_eettaa.run: nlo_settings.sin
 nlo_eettaj.run: nlo_settings.sin
 nlo_eettajj.run: nlo_settings.sin
 nlo_eettah.run: nlo_settings.sin
 nlo_eettaz.run: nlo_settings.sin
 nlo_eettz.run: nlo_settings.sin
 nlo_eettzj.run: nlo_settings.sin
 nlo_eettzjj.run: nlo_settings.sin
 nlo_eettzz.run: nlo_settings.sin
 nlo_eettwjj.run: nlo_settings.sin
 nlo_eettww.run: nlo_settings.sin
 nlo_eetth.run: nlo_settings.sin
 nlo_eetthj.run: nlo_settings.sin
 nlo_eetthjj.run: nlo_settings.sin
 nlo_eetthh.run: nlo_settings.sin
 nlo_eetthz.run: nlo_settings.sin
 nlo_ee4t.run: nlo_settings.sin
 nlo_ee4tj.run: nlo_settings.sin
+nlo_ppjj_real_partition.run: nlo_settings.sin
 nlo_ppz.run: nlo_settings.sin
 nlo_ppw.run: nlo_settings.sin
 nlo_ppzz.run: nlo_settings.sin
 nlo_ppzw.run: nlo_settings.sin
 nlo_pptttt.run: nlo_settings.sin
 nlo_ppzj_sim_1.run: nlo_settings.sin
 nlo_ppzj_sim_2.run: nlo_settings.sin
 nlo_ppzj_sim_3.run: nlo_settings.sin
 nlo_ppzj_sim_4.run: nlo_settings.sin
 nlo_settings.sin: $(top_builddir)/share/tests/ext_tests_nlo/nlo_settings.sin
 	cp $< $@
 
 if MPOST_AVAILABLE
 $(TESTS_REQ_GAMELAN): gamelan.sty
 $(UNIT_TESTS_REQ_GAMELAN): gamelan.sty
 gamelan.sty: $(top_builddir)/src/gamelan/gamelan.sty
 	cp $< $@
 
 $(top_builddir)/src/gamelan/gamelan.sty:
 	$(MAKE) -C $(top_builddir)/src/gamelan gamelan.sty
 endif
 
 BUILT_SOURCES = \
     TESTFLAG  \
     HEPMC2_FLAG \
     HEPMC3_FLAG \
     LCIO_FLAG \
     FASTJET_FLAG \
     LHAPDF5_FLAG \
     LHAPDF6_FLAG \
     GAMELAN_FLAG \
     EVENT_ANALYSIS_FLAG \
     OCAML_FLAG \
     PYTHON_FLAG \
     PYTHIA6_FLAG \
     OPENLOOPS_FLAG \
     GOSAM_FLAG \
     STATIC_FLAG \
     ref-output
 
 # If this file is found in the working directory, WHIZARD
 # will use the paths for the uninstalled version (source/build tree),
 # otherwise it uses the installed version
 TESTFLAG:
 	touch $@
 
 FASTJET_FLAG:
 if FASTJET_AVAILABLE
 	touch $@
 endif
 
 HEPMC2_FLAG:
 if HEPMC2_AVAILABLE
 	touch $@
 endif
 
 HEPMC3_FLAG:
 if HEPMC3_AVAILABLE
 	touch $@
 endif
 
 LCIO_FLAG:
 if LCIO_AVAILABLE
 	touch $@
 endif
 
 LHAPDF5_FLAG:
 if LHAPDF5_AVAILABLE
 	touch $@
 endif
 
 LHAPDF6_FLAG:
 if LHAPDF6_AVAILABLE
 	touch $@
 endif
 
 GAMELAN_FLAG:
 if MPOST_AVAILABLE
 	touch $@
 endif
 
 OCAML_FLAG:
 if OCAML_AVAILABLE
 	touch $@
 endif
 
 PYTHON_FLAG:
 if PYTHON_AVAILABLE
 	touch $@
 endif
 
 PYTHIA6_FLAG:
 if PYTHIA6_AVAILABLE
 	touch $@
 endif
 
 OPENLOOPS_FLAG:
 if OPENLOOPS_AVAILABLE
 	touch $@
 endif
 
 GOSAM_FLAG:
 if GOSAM_AVAILABLE
 	touch $@
 endif
 
 EVENT_ANALYSIS_FLAG:
 if EVENT_ANALYSIS_AVAILABLE
 	touch $@
 endif
 
 STATIC_FLAG:
 if STATIC_AVAILABLE
 	touch $@
 endif
 
 # The reference output files are in the source directory.  Copy them here.
 ref-output: $(top_srcdir)/share/tests/ext_tests_nlo/ref-output
 	mkdir -p ref-output
 	for f in $</*.ref; do cp $$f $@; done
 
 ## installcheck runs the test scripts with the TESTFLAG removed.
 installcheck-local: notestflag check-am
 notestflag:
 	rm -f TESTFLAG
 .PHONY: notestflag
 
 ## Remove generated files
 clean-local:
 	rm -f gamelan.sty
 	rm -f TESTFLAG
 	rm -f *_FLAG
 	rm -f static_1.exe
 	rm -f *.run *.log slha_test.out
 	rm -f core* stdhep_rd
 	rm -f *.f90 *.c *.$(FCMOD) *.o *.la *.f90.in
 	rm -f *.makefile
 	rm -rf ref-output
 	rm -f *.sin *.hbc
 	rm -f *.phs *.vg *.vg2 *.vgb *.evt *.evx *.lhe *.hepmc *.dat *.debug
 	rm -f *.tmp *.hepevt *.hepevt.verb *.lha *.lha.verb *.slcio
 	rm -f prc_omega_diags_1_p_i1_diags.out prc_omega_diags_1_p_i1_diags.toc
 	rm -f *.hep *.up.hep *.[1-9] *.[1-9][0-9] *.[1-9][0-9][0-9]
 	rm -f *.tex *.mp *.mpx *.t[1-9] *.t[1-9][0-9] *.t[1-9][0-9][0-9]
 	rm -f *.ltp *.aux *.dvi *.ps *.pdf so_test.*
 	rm -f *.tbl sps1ap_decays.slha bar structure_6[a-b].out
 	rm -f slhaspectrum.in suspect2.out suspect2_lha.out
 	rm -f susyhit.in susyhit_slha.out suspect2_lha.in
 	rm -f *.olc *.olp *.olp_parameters
 	rm -rf stability_log
 	rm -rf *olp_modules
 	rm -rf Generated_Loops
 	rm -rf include lib golem.in
 	rm -f *fks_regions.out
 if FC_SUBMODULES
 	rm -f *.smod
 endif
 
 ## Remove backup files
 maintainer-clean-local: maintainer-clean-fc
 	-rm -f *~
 .PHONY: maintainer-clean-local
Index: trunk/tests/ext_tests_nlo/nlo_ppjj_real_partition.sh
===================================================================
--- trunk/tests/ext_tests_nlo/nlo_ppjj_real_partition.sh	(revision 0)
+++ trunk/tests/ext_tests_nlo/nlo_ppjj_real_partition.sh	(revision 8733)
@@ -0,0 +1,36 @@
+#!/bin/sh
+echo "Running script $0"
+name=`basename @script@`
+if test -f ref-output/$name.ref; then
+  if test -f OCAML_FLAG -a -f OPENLOOPS_FLAG -a -f FASTJET_FLAG -a -f LHAPDF6_FLAG; then
+    ./run_whizard.sh @script@ --no-logging
+    mv $name.log $name.log.tmp
+    cat $name.log.tmp | sed -e 's/Loading library:.*/Loading library: [...]/' > $name.log
+    rm $name.log.tmp
+    diff ref-output/$name.ref $name.log
+    diffrc=$?
+    grep --quiet "The desired process has not been found" $name.run.log
+    greprc=$?
+    if test $diffrc -gt 0 -a $greprc -eq 0; then
+      echo "|=============================================================================|"
+      echo "OpenLoops process library missing"
+      exit 99
+    fi
+    grep --quiet "'MSTW2008nlo68cl' not found" $name.run.log
+    greprc=$?
+    if test $diffrc -gt 0 -a $greprc -eq 0; then
+      echo "|=============================================================================|"
+      echo "LHAPDF: Data file 'MSTW2008nlo68cl' missing"
+      exit 99
+    fi
+    exit $diffrc
+  else
+    echo "|=============================================================================|"
+    echo "No O'Mega/OpenLoops matrix elements / FastJet / LHAPDF6 available"
+    exit 77
+  fi
+else
+  echo "|=============================================================================|"
+  echo "$name.ref not found"
+  exit 77
+fi
Index: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog	(revision 8732)
+++ trunk/ChangeLog	(revision 8733)
@@ -1,2240 +1,2245 @@
 ChangeLog -- Summary of changes to the WHIZARD package
 
 Use svn log to see detailed changes.
 
 	Version 3.0.1+
 
+2021-08-06
+        Generalize optional partitioning of the NLO real phase space
+
+##################################################################
+
 2021-07-08
 	RELEASE: version 3.0.1
 
 2021-07-06
 	MPI parallelization now comes with two incarnations:
 	- standard MPI parallelization ("simple", default)
 	- MPI with load balancer ("load")
 
 2021-07-05
 	Bug fix for C++17 default compilers w/ HepMC3/ROOT interface
 
 2021-07-02
 	Improvement for POWHEG matching:
 	- implement massless recoil case
 	- enable reading in existing POWHEG grids
 	- support kinematic cuts at generator level
 
 2021-07-01
 	Distinguish different cases of photons in NLO EW corrections
 
 2021-06-21
 	Option to keep negative PDF entries or set them zero
 
 2021-05-31
 	Full LCIO MC production files can be properly recasted
 
 2021-05-24
         Use defaults for UFO models without propagators.py
 
 2021-05-21
 	Bug fix: prevent invalid code for UFO models containing hyphens
 
 2021-05-20
 	UFO files with scientific notation float constants allowed
 	UFO files: max. n-arity of vertices bound by process multiplicity
 
 ##################################################################
 
 2021-04-27
 	RELEASE: version 3.0.0
 
 2021-04-20
 	Minimal required OCaml version is now 4.05.0.
 	Bug fix for tau polarization from stau decays
 
 2021-04-19
 	NLO EW splitting functions and collinear remnants completed
 	Photon recombination implemented
 
 2021-04-14
 	Bug fix for vertices/status codes with HepMC2/3 event format
 
 2021-04-08
 	Correct Lorentz statistics for UFO model with Majorana fermions
 
 2021-04-06
 	Bug fix for rare script failure in system_dependencies.f90.in
 	Kappa factor for quartic Higgs coupling in SM_ac(_CKM) model
 
 2021-04-04
 	Support for UFO extensions in SMEFTSim 3.0
 
 2021-02-25
 	Enable VAMP and VAMP2 channel equivalences for NLO integrations
 
 2021-02-04
 	Bug fix if user does not set a prefix at configuration
 
 2020-12-10
 	Generalize NLO calculations to non-CMS lab frames
 
 2020-12-08
 	Bug fix in expanded p-wave form factor for top threshold
 
 2020-12-06
 	Patch for macOS Big Sur shared library handling due to libtool;
 	   the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5
 
 2020-12-04
 	O'Mega only inserts non-vanishing couplings from UFO models
 
 2020-11-21
 	Bug fix for fractional hypercharges in UFO models
 
 2020-11-11
 	Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh)
 
 2020-11-09
 	Correct flavor assignment for NLO fixed-order events
 
 2020-11-05
 	Bug fix for ISR handler not working with unstable particles
 
 2020-10-08
 	Bug fix in LHAPDF interface for photon PDFs
 
 2020-10-07
 	Bug fix for structure function setup with asymmetric beams
 
 2020-10-02
 	Python/Cython layer for WHIZARD API
 
 2020-09-30
 	Allow mismatches of Python and name attributes in UFO models
 
 2020-09-26
 	Support for negative PDG particles from certain UFO models
 
 2020-09-24
 	Allow for QNUMBERS blocks in BSM SLHA files
 
 2020-09-22
 	Full support for compilation with clang(++) on Darwin/macOS
 	More documentation in the manual
 	Minor clean-ups
 
 2020-09-16
 	Bug fix enables reading LCIO events with LCIO v2.15+
 
 ##################################################################
 
 2020-09-16
 	RELEASE: version 2.8.5
 
 2020-09-11
 	Bug fix for H->tau tau transverse polarization with PYTHIA6
 	   (thanks to Junping Tian / Akiya Miyamoto)
 
 2020-09-09
 	Fix a long standing bug (since 2.0) in the calculation of color
 	factors when particles of different color were combined in a
 	particle class.  NB: O'Mega never produced a wrong number,
 	it only declared all processes as invalid.
 
 2020-09-08
 	Enable Openloops matrix element equivalences for optimization
 
 2020-09-02
 	Compatibility fix for PYTHIA v8.301+ interface
 
 2020-09-01
 	Support exclusive jet clustering in ee for Fastjet interface
 
 ##################################################################
 
 2020-08-30
 	RELEASE: version 3.0.0_beta
 
 2020-08-27
 	Major revision of NLO distributions and events for
 	   processes with structure functions:
 	- Use parton momenta/flavors (instead of beams) for events
 	- Bug fix for Lorentz boosts and Lorentz frames of momenta
 	- Bug fix: apply cuts to virtual NLO component in correct frame
 	- Correctly assign ISR radiation momenta in data structures
 	- Refactoring on quantum numbers for NLO event data structures
 	- Functional tests for hadron collider NLO distributions
 	- many minor bug fixes regarding NLO hadron collider physics
 
 2020-08-11
 	Bug fix for linking problem with OpenMPI
 
 2020-08-07
 	New WHIZARD API: WHIZARD can be externally linked as a
 	  library, added examples for Fortran, C, C++ programs
 
 ##################################################################
 
 2020-07-08
 	RELEASE: version 2.8.4
 
 2020-07-07
 	Bug fix: steering of UFO Majorana models from WHIZARD
 
 ##################################################################
 
 2020-07-06
 	Combined integration also for hadron collider processes at NLO
 
 2020-07-05
 	Bug fix: correctly steer e+e- FastJet clustering algorithms
 	Major revision of NLO differential distributions and events:
 	- Correctly assign quantum numbers to NLO fixed-order events
 	- Correctly assign weights to NLO fixed-order events for
 	     combined simulation
 	- Cut all NLO fixed-order subevents in event groups individually
 	- Only allow "sigma" normalization for NLO fixed-order events
 	- Use correct PDF setup for NLO counter events
 	- Several technical fixes and updates of the NLO testsuite
 
 ##################################################################
 
 2020-07-03
 	RELEASE: version 2.8.3
 
 2020-07-02
 	Feature-complete UFO implementation for Majorana fermions
 
 2020-06-22
 	Running width scheme supported for O'Mega matrix elements
 
 2020-06-20
 	Adding H-s-s coupling to SM_Higgs(_CKM) models
 
 2020-06-17
 	Completion of ILC 2->6 fermion extended test suite
 
 2020-06-15
 	Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays
 
 2020-06-09
 	Bug fix: correctly update calls for additional VAMP/2 iterations
 	Bug fix: correct assignment for tau spins from PYTHIA6 interface
 
 2020-06-04
 	Bug fix: cascades2 tree merge with empty subtree(s)
 
 2020-05-31
 	Switch $epa_mode for different EPA implementations
 
 2020-05-26
 	Bug fix: spin information transferred for resonance histories
 
 2020-04-13
 	HepMC: correct weighted events for non-xsec event normalizations
 
 2020-04-04
 	Improved HepMC3 interface: HepMC3 Root/RootTree interface
 
 2020-03-24
 	ISR: Fix on-shell kinematics for events with ?isr_handler=true
 	   (set ?isr_handler_keep_mass=false for old behavior)
 
 2020-03-11
 	Beam masses are correctly passed to hard matrix element for CIRCE2
 	EPA with polarized beams: double-counting corrected
 
 ##################################################################
 
 2020-03-03
 	RELEASE: version 3.0.0_alpha
 
 2020-02-25
 	Bug fix: Scale and alphas can be retrieved from internal event format to
 	   external formats
 
 2020-02-17
 	Bug fix: ?keep_failed_events now forces output of actual event data
 	Bug fix: particle-set reconstruction (rescanning events w/o radiation)
 
 2020-01-28
 	Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max)
 
 2020-01-23
 	Bug fix for real components of NLO QCD 2->1 processes
 
 2020-01-22
         Bug fix: correct random number sequencing during parallel MPI event
 	   generation with rng_stream
 
 2020-01-21
 	Consistent distribution of events during parallel MPI event generation
 
 2020-01-20
 	Bug fix for configure setup for automake v1.16+
 
 2020-01-18
 	General SLHA parameter files for UFO models supported
 
 2020-01-08
 	Bug fix: correctly register RECOLA processes with flavor sums
 
 2019-12-19
 	Support for UFO customized propagators
 	O'Mega unit tests for fermion-number violating interactions
 
 2019-12-10
 	For distribution building: check for graphviz/dot
 	   version 2.40 or newer
 
 2019-11-21
 	Bug fix: alternate setups now work correctly
 	Infrastructure for accessing alpha_QED event-by-event
 	Guard against tiny numbers that break ASCII event output
 	Enable inverse hyperbolic functions as SINDARIN observables
 	Remove old compiler bug workarounds
 
 2019-11-20
 	Allow quoted -e argument, implemented -f option
 
 2019-11-19
 	Bug fix: resonance histories now work also with UFO models
 	Fix in numerical precision of ASCII VAMP2 grids
 
 2019-11-06
 	Add squared matrix elements to the LCIO event header
 
 2019-11-05
 	Do not include RNG state in MD5 sum for CIRCE1/2
 
 2019-11-04
 	Full CIRCE2 ILC 250 and 500 GeV beam spectra added
 	Minor update on LCIO event header information
 
 2019-10-30
 	NLO QCD for final states completed
 	When using Openloops, v2.1.1+ mandatory
 
 2019-10-25
 	Binary grid files for VAMP2 integrator
 
 ##################################################################
 
 2019-10-24
 	RELEASE: version 2.8.2
 
 2019-10-20
 	Bug fix for HepMC linker flags
 
 2019-10-19
 	Support for spin-2 particles from UFO files
 
 2019-09-27
 	LCIO event format allows rescan and alternate weights
 
 2019-09-24
 	Compatibility fix for OCaml v4.08.0+
 
 ##################################################################
 
 2019-09-21
 	RELEASE: version 2.8.1
 
 2019-09-19
 	Carriage return characters in UFO models can be parsed
 	Mathematica symbols in UFO models possible
 	Unused/undefined parameters in UFO models handled
 
 2019-09-13
 	New extended NLO test suite for ee and pp processes
 
 2019-09-09
 	Photon isolation (separation of perturbative and fragmentation
 	   part a la Frixione)
 
 2019-09-05
 	Major progress on NLO QCD for hadron collisions:
 	- correctly assign flavor structures for alpha regions
 	- fix crossing of particles for initial state splittings
 	- correct assignment for PDF factors for real subtractions
 	- fix kinematics for collinear splittings
 	- bug fix for integrated virtual subtraction terms
 
 2019-09-03
 	b and c jet selection in cuts and analysis
 
 2019-08-27
 	Support for Intel MPI
 
 2019-08-20
 	Complete (preliminary) HepMC3 support (incl.
 	   backwards HepMC2 write/read mode)
 
 2019-08-08
 	Bug fix: handle carriage returns in UFO files (non-Unix OS)
 
 ##################################################################
 
 2019-08-07
 	RELEASE: version 2.8.0
 
 2019-07-31
 	Complete WHIZARD UFO interface:
 	- general Lorentz structures
 	- matrix element support for general color factors
 	- missing features: Majorana fermions and SLHA
 
 2019-07-20
 	Make WHIZARD compatible with OCaml 4.08.0+
 
 2019-07-19
 	Fix version testing for LHAPDF 6.2.3 and newer
 	Minimal required OCaml version is now 4.02.3.
 
 2019-04-18
 	Correctly generate ordered FKS tuples for alpha regions
 	   from all possible underlying Born processes
 
 2019-04-08
 	Extended O'Mega/Recola matrix element test suite
 
 2019-03-29
 	Correct identical particle symmetry factors for FKS subtraction
 
 2019-03-28
 	Correct assertion of spin-correlated matrix
 	   elements for hadron collisions
 
 2019-03-27
 	Bug fix for cut-off parameter delta_i for
 	   collinear plus/minus regions
 
 ##################################################################
 
 2019-03-27
 	RELEASE: version 2.7.1
 
 2019-02-19
 	Further infrastructure for HepMC3 interface (v3.01.00)
 
 2019-02-07
 	Explicit configure option for using debugging options
 	Bug fix for performance by removing unnecessary debug operations
 
 2019-01-29
 	Bug fix for DGLAP remnants with cut-off parameter delta_i
 
 2019-01-24
 	Radiative decay neu2 -> neu1 A added to MSSM_Hgg model
 
 ##################################################################
 
 2019-01-21
 	RELEASE: version 2.7.0
 
 2018-12-18
 	Support RECOLA for integrated und unintegrated subtractions
 
 2018-12-11
 	FCNC top-up sector in model SM_top_anom
 
 2018-12-05
 	Use libtirpc instead of SunRPC on Arch Linux etc.
 
 2018-11-30
 	Display rescaling factor for weighted event samples with cuts
 
 2018-11-29
 	Reintroduce check against different masses in flavor sums
 	Bug fix for wrong couplings in the Littlest Higgs model(s)
 
 2018-11-22
 	Bug fix for rescanning events with beam structure
 
 2018-11-09
 	Major refactoring of internal process data
 
 2018-11-02
 	PYTHIA8 interface
 
 2018-10-29
         Flat phase space parametrization with RAMBO (on diet) implemented
 
 2018-10-17
 	Revise extended test suite
 
 2018-09-27
 	Process container for RECOLA processes
 
 2018-09-15
 	Fixes by M. Berggren for PYTHIA6 interface
 
 2018-09-14
 	First fixes after HepForge modernization
 
 ##################################################################
 
 2018-08-23
 	RELEASE: version 2.6.4
 
 2018-08-09
 	Infrastructure to check colored subevents
 
 2018-07-10
 	Infrastructure for running WHIZARD in batch mode
 
 2018-07-04
 	MPI available from distribution tarball
 
 2018-06-03
 	Support Intel Fortran Compiler under MAC OS X
 
 2018-05-07
 	FKS slicing parameter delta_i (initial state) implementend
 
 2018-05-03
 	Refactor structure function assignment for NLO
 
 2018-05-02
 	FKS slicing parameter xi_cut, delta_0 implemented
 
 2018-04-20
 	Workspace subdirectory for process integration (grid/phs files)
 	Packing/unpacking of files at job end/start
 	Exporting integration results from scan loops
 
 2018-04-13
 	Extended QCD NLO test suite
 
 2018-04-09
 	Bug fix for Higgs Singlet Extension model
 
 2018-04-06
 	Workspace subdirectory for process generation and compilation
 	--job-id option for creating job-specific names
 
 2018-03-20
 	Bug fix for color flow matching in hadron collisions
 	   with identical initial state quarks
 
 2018-03-08
 	Structure functions quantum numbers correctly assigned for NLO
 
 2018-02-24
 	Configure setup includes 'pgfortran' and 'flang'
 
 2018-02-21
 	Include spin-correlated matrix elements in interactions
 
 2018-02-15
 	Separate module for QED ISR structure functions
 
 ##################################################################
 
 2018-02-10
 	RELEASE: version 2.6.3
 
 2018-02-08
 	Improvements in memory management for PS generation
 
 2018-01-31
 	Partial refactoring: quantum number assigment NLO
 	Initial-state QCD splittings for hadron collisions
 
 2018-01-25
 	Bug fix for weighted events with VAMP2
 
 2018-01-17
 	Generalized interface for Recola versions 1.3+  and 2.1+
 
 2018-01-15
 	Channel equivalences also for VAMP2 integrator
 
 2018-01-12
 	Fix for OCaml compiler 4.06 (and newer)
 
 2017-12-19
 	RECOLA matrix elements with flavor sums can be integrated
 
 2017-12-18
 	Bug fix for segmentation fault in empty resonance histories
 
 2017-12-16
 	Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers
 	  from transferral between PYTHIA and WHIZARD event records
 
 2017-12-15
 	Event index for multiple processes in event file correct
 
 ##################################################################
 
 2017-12-13
 	RELEASE: version 2.6.2
 
 2017-12-07
 	User can set offset in event numbers
 
 2017-11-29
 	Possibility to have more than one RECOLA process in one file
 
 2017-11-23
 	Transversal/mixed (and unitarized) dim-8 operators
 
 2017-11-16
 	epa_q_max replaces epa_e_max (trivial factor 2)
 
 2017-11-15
 	O'Mega matrix element compilation silent now
 
 2017-11-14
 	Complete expanded P-wave form factor for top threshold
 
 2017-11-10
 	Incoming particles can be accessed in SINDARIN
 
 2017-11-08
 	Improved handling of resonance insertion, additional parameters
 
 2017-11-04
 	Added Higgs-electron coupling (SM_Higgs)
 
 ##################################################################
 
 2017-11-03
 	RELEASE: version 2.6.1
 
 2017-10-20
 	More than 5 NLO components possible at same time
 
 2017-10-19
 	Gaussian cutoff for shower resonance matching
 
 2017-10-12
 	Alternative (more efficient) method to generate
 	   phase space file
 
 2017-10-11
 	Bug fix for shower resonance histories for processes
 	   with multiple components
 
 2017-09-25
 	Bug fix for process libraries in shower resonance histories
 
 2017-09-21
 	Correctly generate pT distribution for EPA remnants
 
 2017-09-20
 	Set branching ratios for unstable particles also by hand
 
 2017-09-14
 	Correctly generate pT distribution for ISR photons
 
 ##################################################################
 
 2017-09-08
 	RELEASE: version 2.6.0
 
 2017-09-05
 	Bug fix for initial state NLO QCD flavor structures
 	Real and virtual NLO QCD hadron collider processes
 	   work with internal interactions
 
 2017-09-04
 	Fully validated MPI integration and event generation
 
 2017-09-01
 	Resonance histories for shower: full support
 	Bug fix in O'Mega model constraints
 	O'Mega allows to output a parsable form of the DAG
 
 2017-08-24
 	Resonance histories in events for transferral
 	   to parton shower (e.g. in ee -> jjjj)
 
 2017-08-01
 	Alpha version of HepMC v3 interface
 	   (not yet really functional)
 
 2017-07-31
 	Beta version for RECOLA OLP support
 
 2017-07-06
 	Radiation generator fix for LHC processes
 
 2017-06-30
 	Fix bug for NLO with structure
 	   functions and/or polarization
 
 2017-06-23
 	Collinear limit for QED corrections works
 
 2017-06-17
 	POWHEG grids generated already during integration
 
 2017-06-12
 	Soft limit for QED corrections works
 
 2017-05-16
 	Beta version of full MPI parallelization (VAMP2)
 	Check consistency of POWHEG grid files
 	Logfile config-summary.log for configure summary
 
 2017-05-12
 	Allow polarization in top threshold
 
 2017-05-09
 	Minimal demand automake 1.12.2
 	Silent rules for make procedures
 
 2017-05-07
 	Major fix for POWHEG damping
 	Correctly initialize FKS ISR phasespace
 
 ##################################################################
 
 2017-05-06
 	RELEASE: version 2.5.0
 
 2017-05-05
 	Full UFO support (SM-like models)
 	Fixed-beam ISR FKS phase space
 
 2017-04-26
 	QED splittings in radiation generator
 
 2017-04-10
 	Retire deprecated O'Mega vertex cache files
 
 ##################################################################
 
 2017-03-24
 	RELEASE: version 2.4.1
 
 2017-03-16
 	Distinguish resonance charge in phase space channels
 	Keep track of resonance histories in phase space
 	Complex mass scheme default for OpenLoops amplitudes
 
 2017-03-13
 	Fix helicities for polarized OpenLoops calculations
 
 2017-03-09
 	Possibility to advance RNG state in rng_stream
 
 2017-03-04
 	General setup for partitioning real emission
 	   phase space
 
 2017-03-06
 	Bug fix on rescan command for converting event files
 
 2017-02-27
 	Alternative multi-channel VEGAS implementation
 	   VAMP2: serial backbone for MPI setup
 	Smoothstep top threshold matching
 
 2017-02-25
 	Single-beam structure function with
 	   s-channel mapping supported
 	Safeguard against invalid process libraries
 
 2017-02-16
 	Radiation generator for photon emission
 
 2017-02-10
 	Fixes for NLO QCD processes (color correlations)
 
 2017-01-16
 	LCIO variable takes precedence over LCIO_DIR
 
 2017-01-13
 	Alternative random number generator
 	   rng_stream (cf. L'Ecuyer et al.)
 
 2017-01-01
 	Fix for multi-flavor BLHA tree
 	   matrix elements
 
 2016-12-31
 	Grid path option for VAMP grids
 
 2016-12-28
 	Alpha version of Recola OLP support
 
 2016-12-27
 	Dalitz plots for FKS phase space
 
 2016-12-14
 	NLO multi-flavor events possible
 
 2016-12-09
 	LCIO event header information added
 
 2016-12-02
 	Alpha version of RECOLA interface
 	Bug fix for generator status in LCIO
 
 ##################################################################
 
 2016-11-28
 	RELEASE: version 2.4.0
 
 2016-11-24
 	Bug fix for OpenLoops interface: EW scheme
 	   is set by WHIZARD
 	Bug fixes for top threshold implementation
 
 2016-11-11
 	Refactoring of dispatching
 
 2016-10-18
 	Bug fix for LCIO output
 
 2016-10-10
 	First implementation for collinear soft terms
 
 2016-10-06
 	First full WHIZARD models from UFO files
 
 2016-10-05
 	WHIZARD does not support legacy gcc 4.7.4 any longer
 
 2016-09-30
 	Major refactoring of process core and NLO components
 
 2016-09-23
 	WHIZARD homogeneous entity: discarding subconfigures
 	  for CIRCE1/2, O'Mega, VAMP subpackages; these are
 	  reconstructable by script projectors
 
 2016-09-06
 	Introduce main configure summary
 
 2016-08-26
 	Fix memory leak in event generation
 
 ##################################################################
 
 2016-08-25
 	RELEASE: version 2.3.1
 
 2016-08-19
 	Bug fix for EW-scheme dependence of gluino propagators
 
 2016-08-01
 	Beta version of complex mass scheme support
 
 2016-07-26
 	Fix bug in POWHEG damping for the matching
 
 ##################################################################
 
 2016-07-21
 	RELEASE: version 2.3.0
 
 2016-07-20
 	UFO file support (alpha version) in O'Mega
 
 2016-07-13
 	New (more) stable of WHIZARD GUI
 	Support for EW schemes for OpenLoops
 	Factorized NLO top decays for threshold model
 
 2016-06-15
 	Passing factorization scale to PYTHIA6
 	Adding charge and neutral observables
 
 2016-06-14
 	Correcting angular distribution/tweaked kinematics in
 	   non-collinear structure functions splittings
 
 2016-05-10
 	Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6
 	   (backwards validation of LC CDR/TDR samples)
 
 2016-04-27
 	Within OpenLoops virtuals: support for Collier library
 
 2016-04-25
 	O'Mega vertex tables only loaded at first usage
 
 2016-04-21
 	New CJ15 PDF parameterizations added
 
 2016-04-21
 	Support for hadron collisions at NLO QCD
 
 2016-04-05
 	Support for different (parameter) schemes in model files
 
 2016-03-31
 	Correct transferral of lifetime/vertex from PYTHIA/TAUOLA
 	  into the event record
 
 2016-03-21
 	New internal implementation of polarization
 	  via Bloch vectors, remove pointer constructions
 
 2016-03-13
 	Extension of cascade syntax for processes:
 	  exclude propagators/vertices etc. possible
 
 2016-02-24
 	Full support for OpenLoops QCD NLO matrix
 	  elements, inclusion in test suite
 
 2016-02-12
 	Substantial progress on QCD NLO support
 
 2016-02-02
 	Automated resonance mapping for FKS subtraction
 
 2015-12-17
 	New BSM model WZW for diphoton resonances
 
 ##################################################################
 
 2015-11-22
 	RELEASE: version 2.2.8
 
 2015-11-21
 	Bug fix for fixed-order NLO events
 
 2015-11-20
 	Anomalous FCNC top-charm vertices
 
 2015-11-19
 	StdHEP output via HEPEVT/HEPEV4 supported
 
 2015-11-18
 	Full set of electroweak dim-6 operators included
 
 2015-10-22
 	Polarized one-loop amplitudes supported
 
 2015-10-21
 	Fixes for event formats for showered events
 
 2015-10-14
 	Callback mechanism for event output
 
 2015-09-22
 	Bypass matrix elements in pure event sample rescans
 	StdHep frozen final version v5.06.01 included internally
 
 2015-09-21
 	configure option --with-precision to
 	  demand 64bit, 80bit, or 128bit Fortran
 	  and bind C precision types
 
 2015-09-07
 	More extensive tests of NLO
 	   infrastructure and POWHEG matching
 
 2015-09-01
 	NLO decay infrastructure
 	User-defined squared matrix elements
 	Inclusive FastJet algorithm plugin
 	Numerical improvement for small boosts
 
 ##################################################################
 
 2015-08-11
 	RELEASE: version 2.2.7
 
 2015-08-10
 	Infrastructure for damped POWHEG
 	Massive emitters in POWHEG
 	Born matrix elements via BLHA
 	GoSam filters via SINDARIN
 	Minor running coupling bug fixes
 	Fixed-order NLO events
 
 2015-08-06
 	CT14 PDFs included (LO, NLO, NNLL)
 
 2015-07-07
 	Revalidation of ILC WHIZARD-PYTHIA event chain
 	Extended test suite for showered events
 	Alpha version of massive FSR for POWHEG
 
 2015-06-09
 	Fix memory leak in interaction for long cascades
 	Catch mismatch between beam definition and CIRCE2 spectrum
 
 2015-06-08
 	Automated POWHEG matching: beta version
 	Infrastructure for GKS matching
 	Alpha version of fixed-order NLO events
 	CIRCE2 polarization averaged spectra with
 	   explicitly polarized beams
 
 2015-05-12
 	Abstract matching type: OO structure for matching/merging
 
 2015-05-07
 	Bug fix in event record WHIZARD-PYTHIA6 transferral
 	Gaussian beam spectra for lepton colliders
 
 ##################################################################
 
 2015-05-02
 	RELEASE: version 2.2.6
 
 2015-05-01
 	Models for (unitarized) tensor resonances in VBS
 
 2015-04-28
 	Bug fix in channel weights for event generation.
 
 2015-04-18
 	Improved event record transfer WHIZARD/PYTHIA6
 
 2015-03-19
 	POWHEG matching: alpha version
 
 ##################################################################
 
 2015-02-27
 	RELEASE: version 2.2.5
 
 2015-02-26
 	Abstract types for quantum numbers
 
 2015-02-25
 	Read-in of StdHEP events, self-tests
 
 2015-02-22
 	Bug fix for mother-daughter relations in
 	   showered/hadronized events
 
 2015-02-20
 	Projection on polarization in intermediate states
 
 2015-02-13
 	Correct treatment of beam remnants in
 	   event formats (also LC remnants)
 
 ##################################################################
 
 2015-02-06
 	RELEASE: version 2.2.4
 
 2015-02-06
 	Bug fix in event output
 
 2015-02-05
 	LCIO event format supported
 
 2015-01-30
 	Including state matrices in WHIZARD's internal IO
 	Versioning for WHIZARD's internal IO
 	Libtool update from 2.4.3 to 2.4.5
 	LCIO event output (beta version)
 
 2015-01-27
 	Progress on NLO integration
 	Fixing a bug for multiple processes in a single
 	   event file when using beam event files
 
 2015-01-19
 	Bug fix for spin correlations evaluated in the rest
 	   frame of the mother particle
 
 2015-01-17
 	Regression fix for statically linked processes
 	   from SARAH and FeynRules
 
 2015-01-10
 	NLO: massive FKS emitters supported (experimental)
 
 2015-01-06
 	MMHT2014 PDF sets included
 
 2015-01-05
 	Handling mass degeneracies in auto_decays
 
 2014-12-19
 	Fixing bug in rescan of event files
 
 ##################################################################
 
 2014-11-30
 	RELEASE: version 2.2.3
 
 2014-11-29
 	Beta version of LO continuum/NLL-threshold
 	matched top threshold model for e+e- physics
 
 2014-11-28
 	More internal refactoring: disentanglement of module
 	   dependencies
 
 2014-11-21
 	OVM: O'Mega Virtual Machine, bytecode instructions
 	   instead of compiled Fortran code
 
 2014-11-01
 	Higgs Singlet extension model included
 
 2014-10-18
 	Internal restructuring of code; half-way
 	  WHIZARD main code file disassembled
 
 2014-07-09
 	Alpha version of NLO infrastructure
 
 ##################################################################
 
 2014-07-06
 	RELEASE: version 2.2.2
 
 2014-07-05
 	CIRCE2: correlated LC beam spectra and
 	  GuineaPig Interface to LC machine parameters
 
 2014-07-01
 	Reading LHEF for decayed/factorized/showered/
 	   hadronized events
 
 2014-06-25
 	Configure support for GoSAM/Ninja/Form/QGraf
 
 2014-06-22
 	LHAPDF6 interface
 
 2014-06-18
 	Module for automatic generation of
 	  radiation and loop infrastructure code
 
 2014-06-11
 	Improved internal directory structure
 
 ##################################################################
 
 2014-06-03
 	RELEASE: version 2.2.1
 
 2014-05-30
 	Extensions of internal PDG arrays
 
 2014-05-26
 	FastJet interface
 
 2014-05-24
 	CJ12 PDFs included
 
 2014-05-20
 	Regression fix for external models (via SARAH
 	    or FeynRules)
 
 ##################################################################
 
 2014-05-18
 	RELEASE: version 2.2.0
 
 2014-04-11
 	Multiple components: inclusive process definitions,
 	   syntax: process A + B + ...
 
 2014-03-13
 	Improved PS mappings for e+e- ISR
 	ILC TDR and CLIC spectra included in CIRCE1
 
 2014-02-23
 	New models: AltH w\ Higgs for exclusion purposes,
 	  SM_rx for Dim 6-/Dim-8 operators, SSC for
 	  general strong interactions (w/ Higgs), and
 	  NoH_rx (w\ Higgs)
 
 2014-02-14
 	Improved s-channel mapping, new on-shell
 	  production mapping (e.g. Drell-Yan)
 
 2014-02-03
 	PRE-RELEASE: version 2.2.0_beta
 
 2014-01-26
 	O'Mega: Feynman diagram generation possible (again)
 
 2013-12-16
 	HOPPET interface for b parton matching
 
 2013-11-15
 	PRE-RELEASE: version 2.2.0_alpha-4
 
 2013-10-27
 	LHEF standards 1.0/2.0/3.0 implemented
 
 2013-10-15
 	PRE-RELEASE: version 2.2.0_alpha-3
 
 2013-10-02
 	PRE-RELEASE: version 2.2.0_alpha-2
 
 2013-09-25
 	PRE-RELEASE: version 2.2.0_alpha-1
 
 2013-09-12
 	PRE-RELEASE: version 2.2.0_alpha
 
 2013-09-03
 	General 2HDM implemented
 
 2013-08-18
 	Rescanning/recalculating events
 
 2013-06-07
 	Reconstruction of complete event
 	  from 4-momenta possible
 
 2013-05-06
 	Process library stacks
 
 2013-05-02
 	Process stacks
 
 2013-04-29
 	Single-particle phase space module
 
 2013-04-26
 	Abstract interface for random
 	  number generator
 
 2013-04-24
 	More object-orientation on modules
 	Midpoint-rule integrator
 
 2013-04-05
 	Object-oriented integration and
 	  event generation
 
 2013-03-12
 	Processes recasted object-oriented:
 	  MEs, scales, structure functions
 	First infrastructure for general Lorentz
 	  structures
 
 2013-01-17
 	Object-orientated reworking of library and
 	   process core, more variable internal structure,
 	   unit tests
 
 2012-12-14
 	Update Pythia version to 6.4.27
 
 2012-12-04
 	Fix the phase in HAZ vertices
 
 2012-11-21
 	First O'Mega unit tests, some infrastructure
 
 2012-11-13
 	Bug fix in anom. HVV Lorentz structures
 
 ##################################################################
 
 2012-09-18
 	RELEASE: version 2.1.1
 
 2012-09-11
 	Model MSSM_Hgg with Hgg and HAA vertices
 
 2012-09-10
 	First version of implementation of multiple
 	   interactions in WHIZARD
 
 2012-09-05
 	Infrastructure for internal CKKW matching
 
 2012-09-02
 	C, C++, Python API
 
 2012-07-19
 	Fixing particle numbering in HepMC format
 
 ##################################################################
 
 2012-06-15
 	RELEASE: version 2.1.0
 
 2012-06-14
 	Analytical and kT-ordered shower officially
 	  released
 	PYTHIA interface officially released
 
 2012-05-09
 	Intrisince PDFs can be used for showering
 
 2012-05-04
 	Anomalous Higgs couplings a la hep-ph/9902321
 
 ##################################################################
 
 2012-03-19
 	RELEASE: version 2.0.7
 
 2012-03-15
 	Run IDs are available now
 	More event variables in analysis
 	Modified raw event format (compatibility mode exists)
 
 2012-03-12
 	Bug fix in decay-integration order
 	MLM matching steered completely internally now
 
 2012-03-09
 	Special phase space mapping for narrow resonances
 	  decaying to 4-particle final states with far off-shell
 	  intermediate states
 	Running alphas from PDF collaborations with
 	  builtin PDFs
 
 2012-02-16
 	Bug fix in cascades decay infrastructure
 
 2012-02-04
 	WHIZARD documentation compatible with TeXLive 2011
 
 2012-02-01
 	Bug fix in FeynRules interface with --prefix flag
 
 2012-01-29
 	Bug fix with name clash of O'Mega variable names
 
 2012-01-27
 	Update internal PYTHIA to version 6.4.26
 	Bug fix in LHEF output
 
 2012-01-21
 	Catching stricter automake 1.11.2 rules
 
 2011-12-23
 	Bug fix in decay cascade setup
 
 2011-12-20
 	Bug fix in helicity selection rules
 
 2011-12-16
 	Accuracy goal reimplemented
 
 2011-12-14
 	WHIZARD compatible with TeXLive 2011
 
 2011-12-09
 	Option --user-target added
 
 ##################################################################
 
 2011-12-07
 	RELEASE: version 2.0.6
 
 2011-12-07
 	Bug fixes in SM_top_anom
 	Added missing entries to HepMC format
 
 2011-12-06
 	Allow to pass options to O'Mega
 	Bug fix for HEPEVT block for showered/hadronized events
 
 2011-12-01
 	Reenabled user plug-in for external code for
 	   cuts, structure functions, routines etc.
 
 2011-11-29
 	Changed model SM_Higgs for Higgs phenomenology
 
 2011-11-25
 	Supporting a Y, (B-L) Z' model
 
 2011-11-23
 	Make WHIZARD compatible for MAC OS X Lion/XCode 4
 
 2011-09-25
 	WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742
 
 2011-08-16
 	Model SM_QCD: QCD with one EW insertion
 
 2011-07-19
 	Explicit output channel for dvips avoids printing
 
 2011-07-10
 	Test suite for WHIZARD unit tests
 
 2011-07-01
 	Commands for matrix element tests
 	More OpenMP parallelization of kinematics
 	Added unit tests
 
 2011-06-23
 	Conversion of CIRCE2 from F77 to F90, major
 	  clean-up
 
 2011-06-14
 	Conversion of CIRCE1 from F77 to F90
 
 2011-06-10
 	OpenMP parallelization of channel kinematics
 		(by Matthias Trudewind)
 
 2011-05-31
 	RELEASE: version 1.97
 
 2011-05-24
 	Minor bug fixes: update grids and elsif statement.
 
 ##################################################################
 
 2011-05-10
 	RELEASE: version 2.0.5
 
 2011-05-09
 	Fixed bug in final state flavor sums
 	Minor improvements on phase-space setup
 
 2011-05-05
 	Minor bug fixes
 
 2011-04-15
 	WHIZARD as a precompiled 64-bit binary available
 
 2011-04-06
 	Wall clock instead of cpu time for time estimates
 
 2011-04-05
 	Major improvement on the phase space setup
 
 2011-04-02
 	OpenMP parallelization for helicity loop in O'Mega
 	   matrix elements
 
 2011-03-31
 	Tools for relocating WHIZARD and use in batch
 	environments
 
 2011-03-29
 	Completely static builds possible, profiling options
 
 2011-03-28
 	Visualization of integration history
 
 2011-03-27
 	Fixed broken K-matrix implementation
 
 2011-03-23
 	Including the GAMELAN manual in the distribution
 
 2011-01-26
 	WHIZARD analysis can handle hadronized event files
 
 2011-01-17
 	MSTW2008 and CT10 PDF sets included
 
 2010-12-23
 	Inclusion of NMSSM with Hgg couplings
 
 2010-12-21
 	Advanced options for integration passes
 
 2010-11-16
 	WHIZARD supports CTEQ6 and possibly other PDFs
 	directly; data files included in the distribution
 
 ##################################################################
 
 2010-10-26
 	RELEASE: version 2.0.4
 
 2010-10-06
 	Bug fix in MSSM implementation
 
 2010-10-01
 	Update to libtool 2.4
 
 2010-09-29
 	Support for anomalous top couplings (form factors etc.)
 	Bug fix for running gauge Yukawa SUSY couplings
 
 2010-09-28
 	RELEASE: version 1.96
 
 2010-09-21
 	Beam remnants and pT spectra for lepton collider re-enabled
 	Restructuring subevt class
 
 2010-09-16
 	Shower and matching are disabled by default
 	PYTHIA as a conditional on these two options
 
 2010-09-14
 	Possibility to read in beam spectra re-enabled (e.g. Guinea
 	   Pig)
 
 2010-09-13
 	Energy scan as (pseudo-) structure functions re-implemented
 
 2010-09-10
 	CIRCE2 included again in WHIZARD 2 and validated
 
 2010-09-02
 	Re-implementation of asymmetric beam energies and collision
 	  angles, e-p collisions work, inclusion of a HERA DIS test
 	  case
 
 ##################################################################
 
 2010-10-18
 	RELEASE: version 2.0.3
 
 2010-08-08
 	Bug in CP-violating anomalous triple TGCs fixed
 
 2010-08-06
 	Solving backwards compatibility problem with O'Caml 3.12.0
 
 2010-07-12
 	Conserved quantum numbers speed up O'Mega code generation
 
 2010-07-07
 	Attaching full ISR/FSR parton shower and MPI/ISR
 	   module
 	Added SM model containing Hgg, HAA, HAZ vertices
 
 2010-07-02
 	Matching output available as LHEF and STDHEP
 
 2010-06-30
 	Various bug fixes, missing files, typos
 
 2010-06-26
 	CIRCE1 completely re-enabled
 	Chaining structure functions supported
 
 2010-06-25
 	Partial support for conserved quantum numbers in
 	   O'Mega
 
 2010-06-21
 	Major upgrade of the graphics package: error bars,
 	   smarter SINDARIN steering, documentation, and all that...
 
 2010-06-17
 	MLM matching with PYTHIA shower included
 
 2010-06-16
 	Added full CIRCE1 and CIRCE2 versions including
 	full documentation and miscellanea to the trunk
 
 2010-06-12
 	User file management supported, improved variable
 	and command structure
 
 2010-05-24
 	Improved handling of variables in local command lists
 
 2010-05-20
 	PYTHIA interface re-enabled
 
 2010-05-19
 	ASCII file formats for interfacing ROOT and gnuplot in
 	   data analysis
 
 ##################################################################
 
 2010-05-18
 	RELEASE: version 2.0.2
 
 2010-05-14
 	Reimplementation of visualization of phase space
 	   channels
 	Minor bug fixes
 
 2010-05-12
 	Improved phase space - elimination of redundancies
 
 2010-05-08
 	Interface for polarization completed: polarized beams etc.
 
 2010-05-06
 	Full quantum numbers appear in process log
 	Integration results are usable as user variables
 	Communication with external programs
 
 2010-05-05
 	Split module commands into commands, integration,
 	   simulation modules
 
 2010-05-04
 	FSR+ISR for the first time connected to the WHIZARD 2 core
 
 ##################################################################
 
 2010-04-25
 	RELEASE: version 2.0.1
 
 2010-04-23
 	Automatic compile and integrate if simulate is called
 	Minor bug fixes in O'Mega
 
 2010-04-21
 	Checkpointing for event generation
 	Flush statements to use WHIZARD inside a pipe
 
 2010-04-20
 	Reimplementation of signal handling in WGIZARD 2.0
 
 2010-04-19
 	VAMP is now a separately configurable and installable unit of
 	   WHIZARD, included VAMP self-checks
 	Support again compilation in quadruple precision
 
 2010-04-06
 	Allow for logarithmic plots in GAMELAN, reimplement the
 	   possibility to set the number of bins
 
 2010-04-15
 	Improvement on time estimates for event generation
 
 ##################################################################
 
 2010-04-12
 	RELEASE: version 2.0.0
 
 2010-04-09
 	Per default, the code for the amplitudes is subdivided to allow
 	  faster compiler optimization
 	More advanced and unified and straightforward command language
 	  syntax
 	Final bug fixes
 
 2010-04-07
 	Improvement on SINDARIN syntax; printf, sprintf function
 	  thorugh a C interface
 
 2010-04-05
 	Colorizing DAGs instead of model vertices: speed boost
 	  in colored code generation
 
 2010-03-31
 	Generalized options for normalization of weighted and
 	  unweighted events
 	Grid and weight histories added again to log files
 	Weights can be used in analyses
 
 2010-03-28
 	Cascade decays completely implemented including color and
 	   spin correlations
 
 2010-03-07
 	Added new WHIZARD header with logo
 
 2010-03-05
 	Removed conflict in O'Mega amplitudes between flavour sums
 	   and cascades
 	StdHEP interface re-implemented
 
 2010-03-03
 	RELEASE: version 2.0.0rc3
 	Several bug fixes for preventing abuse in input files
 	OpenMP support for amplitudes
 	Reimplementation of WHIZARD 1 HEPEVT ASCII event formats
 	FeynRules interface successfully passed MSSM test
 
 2010-02-26
 	Eliminating ghost gluons from multi-gluon amplitudes
 
 2010-02-25
 	RELEASE: version 1.95
 	HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2
 
 2010-02-23
 	Running alpha_s implemented in the FeynRules interface
 
 2010-02-19
 	MSSM (semi-) automatized self-tests finalized
 
 2010-02-17
 	RELEASE: version 1.94
 
 2010-02-16
 	Closed memory corruption in WHIZARD 1
 	Fixed problems of old MadGraph and CompHep drivers
 	   with modern compilers
 	Uncolored vertex selection rules for colored amplitudes in
 	   O'Mega
 
 2010-02-15
 	Infrastructure for color correlation computation in O'Mega
 	   finished
 	Forbidden processes are warned about, but treated as non-fatal
 
 2010-02-14
 	Color correlation computation in O'Mega finalized
 
 2010-02-10
 	Improving phase space mappings for identical particles in
 	initial and final states
 	Introduction of more extended multi-line error message
 
 2010-02-08
 	First O'Caml code for computation of color correlations in
 	O'Mega
 
 2010-02-07
 	First MLM matching with e+ e- -> jets
 
 ##################################################################
 
 2010-02-06
 	RELEASE: version 2.0.0rc2
 
 2010-02-05
 	Reconsidered the Makefile structure and more extended tests
 	Catch a crash between WHIZARD and O'Mega for forbidden processes
 	Tensor products of arbitrary color structures in jet definitions
 
 2010-02-04
 	Color correlation computation in O'Mega finalized
 
 ##################################################################
 
 2010-02-03
 	RELEASE: version 2.0.0rc1
 
 ##################################################################
 
 2010-01-31
 	Reimplemented numerical helicity selection rules
 	Phase space functionality of version 1 restored and improved
 
 2009-12-05
 	NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam)
 
 2009-12-04
 	RELEASE: version 2.0.0alpha
 
 ##################################################################
 
 2009-04-16
 	RELEASE: version 1.93
 
 2009-04-15
 	Clean-up of Makefiles and configure scripts
 	Reconfiguration of BSM model implementation
 	extended supersymmetric models
 
 2008-12-23
 	New model NMSSM	(Felix Braam)
 	SLHA2 added
 	Bug in LHAPDF interface fixed
 
 2008-08-16
 	Bug fixed in K matrix implementation
 	Gravitino option in the MSSM added
 
 2008-03-20
 	Improved color and flavor sums
 
 ##################################################################
 
 2008-03-12
 	RELEASE: version 1.92
 	LHEF (Les Houches Event File) format added
 	Fortran 2003 command-line interface (if supported by the compiler)
 	Automated interface to colored models
 	More bug fixes and workarounds for compiler compatibility
 
 ##################################################################
 
 2008-03-06
 	RELEASE: version 1.91
 	New model K-matrix (resonances and anom. couplings in WW scattering)
 	EWA spectrum
 	Energy-scan pseudo spectrum
 	Preliminary parton shower module (only from final-state quarks)
 	Cleanup and improvements of configure process
 	Improvements for O'Mega parameter files
 	Quadruple precision works again
 	More plotting options: lines, symbols, errors
 	Documentation with PDF bookmarks enabled
 	Various bug fixes
 
 2007-11-29
 	New model UED
 
 ##################################################################
 
 2007-11-23
 	RELEASE: version 1.90
 	O'Mega now part of the WHIZARD tree
 	Madgraph/CompHEP disabled by default (but still usable)
 	Support for LHAPDF (preliminary)
 	Added new models: SMZprime, SM_km, Template
 	Improved compiler recognition and compatibility
 	Minor bug fixes
 
 ##################################################################
 
 2006-06-15
 	RELEASE: version 1.51
 	Support for anomaly-type Higgs couplings (to gluon and photon/Z)
 	Support for spin 3/2 and spin 2
 	New models: Little Higgs (4 versions), toy models for extra dimensions
           and gravitinos
 	Fixes to the whizard.nw source documentation to run through LaTeX
 	Intel 9.0 bug workaround (deallocation of some arrays)
 
 2006-05-15
 	O'Mega RELEASE: version 0.11
 	merged JRR's O'Mega extensions
 
 ##################################################################
 
 2006-02-07
 	RELEASE: version 1.50
         To avoid confusion: Mention outdated manual example in BUGS file
         O'Mega becomes part of the WHIZARD generator
 
 2006-02-02   [bug fix update]
 	Bug fix: spurious error when writing event files for weighted events
 	Bug fix: 'r' option for omega produced garbage for some particle names
 	Workaround for ifort90 bug (crash when compiling whizard_event)
 	Workaround for ifort90 bug (crash when compiling hepevt_common)
 
 2006-01-27
 	Added process definition files for MSSM 2->2 processes
 	Included beam recoil for EPA (T.Barklow)
 	Updated STDHEP byte counts (for STDHEP 5.04.02)
 	Fixed STDHEP compatibility (avoid linking of incomplete .so libs)
 	Fixed issue with comphep requiring Xlibs on Opteron
 	Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface)
 	Fixed color-flow code: was broken for omega with option 'c' and 'w'
 	Workaround hacks for g95 compatibility
 
 2005-11-07
 	O'Mega RELEASE: version 0.10
 	O'Mega, merged JRR's and WK's color hack for WHiZard
         O'Mega, EXPERIMENTAL: cache fusion tables (required for colors
 	  a la JRR/WK)
         O'Mega, make JRR's MSSM official
 
 ##################################################################
 
 2005-10-25
 	RELEASE: version 1.43
 	Minor fixes in MSSM couplings (Higgs/3rd gen squarks).
 	  This should be final, since the MSSM results agree now completely
           with Madgraph and Sherpa
 	User-defined lower and upper limits for split event file count
 	Allow for counters (events, bytes) exceeding $2^{31}$
 	Revised checksum treatment and implementation (now MD5)
         Bug fix: missing process energy scale in raw event file
 
 ##################################################################
 
 2005-09-30
 	RELEASE: version 1.42
 	Graphical display of integration history ('make history')
 	Allow for switching off signals even if supported (configure option)
 
 2005-09-29
 	Revised phase space generation code, in particular for flavor sums
 	Negative cut and histogram codes use initial beams instead of
 	  initial parton momenta.  This allows for computing, e.g., E_miss
 	Support constant-width and zero-width options for O'Mega
 	Width options now denoted by w:X (X=f,c,z).  f option obsolescent
 	Bug fix: colorized code: flipped indices could screw up result
 	Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem)
 	Bug fix: dvips on systems where dvips defaults to lpr
 	Bug fix: integer overflow if too many events are requested
 
 2005-07-29
 	Allow for 2 -> 1 processes (if structure functions are on)
 
 2005-07-26
 	Fixed and expanded the 'test' matrix element:
 	  Unit matrix element with option 'u' / default: normalized phase space
 
 ##################################################################
 
 2005-07-15
 	RELEASE: version 1.41
 	Bug fix: no result for particle decay processes with width=0
 	Bug fix: line breaks in O'Mega files with color decomposition
 
 2005-06-02
 	New self-tests (make test-QED / test-QCD / test-SM)
 	  check lists of 2->2 processes
 	Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex)
 
 2005-05-25
 	Revised Makefile structure
 	Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA)
 
 2005-05-19
 	Support for color in O'Mega (using color flow decomposition)
 	New model QCD
 	Parameter file changes that correspond to replaced SM module in O'Mega
 	Bug fixes in MSSM (O'Mega) parameter file
 
 2005-05-18
 	New event file formats, useful for LHC applications:
           ATHENA and Les Houches Accord (external fragmentation)
         Naive (i.e., leading 1/N) color factor now implemented both for
           incoming and outgoing partons
 
 2005-01-26
 	include missing HELAS files for bundle
 	pgf90 compatibility issues [note: still internal error in pgf90]
 
 ##################################################################
 
 2004-12-13
 	RELEASE: version 1.40
 	compatibility fix: preprocessor marks in helas code now commented out
 	minor bug fix: format string in madgraph source
 
 2004-12-03
 	support for arbitray beam energies and directions
 	allow for pT kick in structure functions
 	bug fix: rounding error could result in zero cross section
 	  (compiler-dependent)
 
 2004-10-07
 	simulate decay processes
 	list fraction (of total width/cross section) instead of efficiency
           in process summary
 	new cut/analysis parameters AA, AAD, CTA: absolute polar angle
 
 2004-10-04
 	Replaced Madgraph I by Madgraph II.  Main improvement: model no
           longer hardcoded
 	introduced parameter reset_seed_each_process (useful for debugging)
         bug fix: color initialization for some processes was undefined
 
 2004-09-21
 	don't compile unix_args module if it is not required
 
 ##################################################################
 
 2004-09-20
 	RELEASE: version 1.30
 	g95 compatibility issues resolved
 	some (irrelevant) memory leaks closed
 	removed obsolete warning in circe1
 	manual update (essentially) finished
 
 2004-08-03
 	O'Mega RELEASE: version 0.9
 	O'Mega, src/trie.mli, src/trie.ml: make interface compatible with
           the O'Caml 3.08 library (remains compatible with older
           versions).  Implementation of unused functions still
           incomplete.
 
 2004-07-26
 	minor fixes and improvements in make process
 
 2004-06-29
 	workarounds for new Intel compiler bugs ...
 	no rebuild of madgraph/comphep executables after 'make clean'
 	bug fix in phase space routine:
           wrong energy for massive initial particles
         bug fix in (new) model interface: name checks for antiparticles
         pre-run checks for comphep improved
         ww-strong model file extended
         Model files particle name fixes, chep SM vertices included
 
 2004-06-22
 	O'Mega RELEASE: version 0.8
 	O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings
 
 2004-05-05
 	Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO)
 	NAG compiler: set number of continuation lines to 200 as default
 	Extended format for cross section summary; appears now in whizard.out
 	Fixed 'bundle' feature
 
 2004-04-28
 	Fixed compatibility with revised O'Mega SM_ac model
 	Fixed problem with x=0 or x=1 when calling PDFLIB (ThO)
 	Fixed bug in comphep module: Vtb was overlooked
 
 ##################################################################
 
 2004-04-15
 	RELEASE: version 1.28
         Fixed bug: Color factor was missing for O'Mega processes with
           four quarks and more
         Manual partially updated
 
 2004-04-08
 	Support for grid files in binary format
 	New default value show_histories=F (reduce output file size)
 	Revised phase space switches: removed annihilation_lines,
 	  removed s_channel_resonance, changed meaning of
 	  extra_off_shell_lines, added show_deleted_channels
 	Bug fixed which lead to omission of some phase space channels
 	Color flow guessed only if requested by guess_color_flow
 
 2004-03-10
 	New model interface: Only one model name specified in whizard.prc
         All model-dependent files reside in conf/models (modellib removed)
 
 2004-03-03
 	Support for input/output in SUSY Les Houches Accord format
 	Split event files if requested
 	Support for overall time limit
 	Support for CIRCE and CIRCE2 generator mode
 	Support for reading beam events from file
 
 2004-02-05
 	Fixed compiler problems with Intel Fortran 7.1 and 8.0
 	Support for catching signals
 
 ##################################################################
 
 2003-08-06
 	RELEASE: version 1.27
 	User-defined PDF libraries as an alternative to the standard PDFLIB
 
 2003-07-23
 	Revised phase space module: improved mappings for massless particles,
 	  equivalences of phase space channels are exploited
 	Improved mapping for PDF (hadron colliders)
 	Madgraph module: increased max number of color flows from 250 to 1000
 
 ##################################################################
 
 2003-06-23
 	RELEASE: version 1.26
 	CIRCE2 support
 	Fixed problem with 'TC' integer kind [Intel compiler complained]
 
 2003-05-28
 	Support for drawing histograms of grids
 	Bug fixes for MSSM definitions
 
 ##################################################################
 
 2003-05-22
 	RELEASE: version 1.25
 	Experimental MSSM support with ISAJET interface
 	Improved capabilities of generating/analyzing weighted events
 	Optional drawing phase space diagrams using FeynMF
 
 ##################################################################
 
 2003-01-31
 	RELEASE: version 1.24
 	A few more fixes and workarounds (Intel and Lahey compiler)
 
 2003-01-15
 	Fixes and workarounds needed for WHIZARD to run with Intel compiler
 	Command-line option interface for the Lahey compiler
 
 	Bug fix: problem with reading whizard.phs
 
 ##################################################################
 
 2002-12-10
 	RELEASE: version 1.23
 
 	Command-line options (on some systems)
 
 	Allow for initial particles in the event record, ordered:
           [beams, initials] - [remnants] - outgoing partons
 
 	Support for PYTHIA 6.2: Les Houches external process interface
 	String pythia_parameters can be up to 1000 characters long
 	Select color flow states in (internal) analysis
 	Bug fix in color flow content of raw event files
 
 	Support for transversal polarization of fermion beams
 	Cut codes: PHI now for absolute azimuthal angle, DPHI for distance
 	'Test' matrix elements optionally respect polarization
 
 	User-defined code can be inserted for spectra, structure functions
           and fragmentation
 
 	Time limits can be specified for adaptation and simulation
 	User-defined file names and file directory
         Initial weights in input file no longer supported
 
         Bug fix in MadGraph (wave function counter could overflow)
 
 	Bug fix: Gamelan (graphical analysis) was not built if noweb absent
 
 ##################################################################
 
 2002-03-16
 	RELEASE: version 1.22
 	Allow for beam remnants in the event record
 
 2002-03-01
         Handling of aliases in whizard.prc fixed (aliases are whole tokens)
 
 2002-02-28
 	Optimized phase space handling routines
 	  (total execution time reduced by 20-60%, depending on process)
 
 ##################################################################
 
 2002-02-26
 	RELEASE: version 1.21
 	Fixed ISR formula (ISR was underestimated in previous versions).
           New version includes ISR in leading-log approximation up to
           third order.  Parameter ISR_sqrts renamed to ISR_scale.
 
 ##################################################################
 
 2002-02-19
 	RELEASE: version 1.20
 	New process-generating method 'test' (dummy matrix element)
 	Compatibility with autoconf 2.50 and current O'Mega version
 
 2002-02-05
 	Prevent integration channels from being dropped (optionally)
 	New internal mapping for structure functions improves performance
 	Old whizard.phx file deleted after recompiling (could cause trouble)
 
 2002-01-24
 	Support for user-defined cuts and matrix element reweighting
 	STDHEP output now written by write_events_format=20 (was 3)
 
 2002-01-16
 	Improved structure function handling; small changes in user interface:
           new parameter structured_beams in &process_input
           parameter fixed_energy in &beam_input removed
 	Support for multiple initial states
 	Eta-phi (cone) cut possible (hadron collider applications)
 	Fixed bug: Whizard library was not always recompiled when necessary
 	Fixed bug: Default cuts were insufficient in some cases
 	Fixed bug: Unusable phase space mappings generated in some cases
 
 2001-12-06
 	Reorganized document source
 
 2001-12-05
 	Preliminary CIRCE2 support (no functionality yet)
 
 2001-11-27
 	Intel compiler support (does not yet work because of compiler bugs)
 	New cut and analysis mode cos-theta* and related
 	Fixed circular jetset_interface dependency warning
 	Some broadcast routines removed (parallel support disabled anyway)
 	Minor shifts in cleanup targets (Makefiles)
         Modified library search, check for pdflib8*
 
 2001-08-06
 	Fixed bug: I/O unit number could be undefined when reading phase space
 	Fixed bug: Unitialized variable could cause segfault when
                    event generation was disabled
 	Fixed bug: Undefined subroutine in CIRCE replacement module
 	Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements
 		   (CompHEP model sm-GF #5, O'Mega model SM_ac)
 	Fixed portability issue: Makefile did rely on PWD environment variable
 	Fixed portability issue: PYTHIA library search ambiguity resolved
 
 2001-08-01
 	Default whizard.prc and whizard.in depend on activated modules
 	Fixed bug: TEX=latex was not properly enabled when making plots
 
 2001-07-20
 	Fixed output settings in PERL script calls
 	Cache enabled in various configure checks
 
 2001-07-13
 	Support for multiple processes in a single WHIZARD run.  The
           integrations are kept separate, but the generated events are mixed
 	The whizard.evx format has changed (incompatible), including now
 	  the color flow information for PYTHIA fragmentation
 	Output files are now process-specific, except for the event file
 	Phase space file whizard.phs (if present) is used only as input,
 	  program-generated phase space is now in whizard.phx
 
 2001-07-10
 	Bug fix: Undefined parameters in parameters_SM_ac.f90 removed
 
 2001-07-04
 	Bug fix: Compiler options for the case OMEGA is disabled
 	Small inconsistencies in whizard.out format fixed
 
 2001-07-01
 	Workaround for missing PDFLIB dummy routines in PYTHIA library
 
 ##################################################################
 
 2001-06-30
 	RELEASE: version 1.13
 	Default path /cern/pro/lib in configure script
 
 2001-06-20
 	New fragmentation option: Interface for PYTHIA with full color flow
           information, beam remnants etc.
 
 2001-06-18
 	Severe bug fixed in madgraph interface: 3-gluon coupling was missing
 	Enabled color flow information in madgraph
 
 2001-06-11
 	VAMP interface module rewritten
 	Revised output format: Multiple VAMP iterations count as one WHIZARD
           iteration in integration passes 1 and 3
 	Improved message and error handling
 	Bug fix in VAMP: handle exceptional cases in rebinning_weights
 
 2001-05-31
 	new parameters for grid adaptation: accuracy_goal and efficiency_goal
 
 ##################################################################
 
 2001-05-29
 	RELEASE: version 1.12
 	bug fixes (compilation problems): deleted/modified unused functions
 
 2001-05-16
 	diagram selection improved and documented
 
 2001-05-06
         allow for disabling packages during configuration
 
 2001-05-03
 	slight changes in whizard.out format; manual extended
 
 ##################################################################
 
 2001-04-20
 	RELEASE: version 1.11
 	fixed some configuration and compilation problems (PDFLIB etc.)
 
 2001-04-18
 	linked PDFLIB: support for quark/gluon structure functions
 
 2001-04-05
 	parameter interface written by PERL script
 	SM_ac model file: fixed error in continuation line
 
 2001-03-13
 	O'Mega, O'Caml 3.01: incompatible changes
 	O'Mega, src/trie.mli: add covariance annotation to T.t
 	  This breaks O'Caml 3.00, but is required for O'Caml 3.01.
 	O'Mega, many instances: replace `sig include Module.T end' by
 	  `Module.T', since the bug is fixed in O'Caml 3.01
 
 2001-02-28
 	O'Mega, src/model.mli:
             new field Model.vertices required for model functors, will
 	    retire Model.fuse2, Model.fuse3, Model.fusen soon.
 
 ##################################################################
 
 2001-03-27
 	RELEASE: version 1.10
 	reorganized the modules as libraries
 	linked PYTHIA: support for parton fragmentation
 
 2000-12-14
 	fixed some configuration problems (if noweb etc. are absent)
 
 ##################################################################
 
 2000-12-01
 	RELEASE of first public version: version 1.00beta