Index: trunk/src/qft/qft.nw
===================================================================
--- trunk/src/qft/qft.nw	(revision 8357)
+++ trunk/src/qft/qft.nw	(revision 8358)
@@ -1,15475 +1,15475 @@
 %% -*- 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 (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)
     class(flavor_t), intent(inout) :: flv
     flv%hard_process = .true.
   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
 <<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
     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
   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
   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)
     class(quantum_numbers_t), intent(inout) :: qn
     call qn%f%tag_hard_process ()
   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 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
 @ 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
     logical :: match_flv
     match_flv = .false.; if (present (match_only_flavor)) match_flv = .true.
     do while (it%is_valid ())
        if (match_flv) then
           if (all (qn .fmatch. it%get_quantum_numbers ())) 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
 @ 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
     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
 @
 <<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
 @
 \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 a ordered list of quantum numbers (without any subtraction index) map
+@ Given an ordered list of quantum numbers (without any subtraction index) map
 these list to a state matrix, such that each list index corresponds to 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]].
 <<Interactions: qn index map: TBP>>=
   generic :: init => qn_index_map_init
   procedure, private :: qn_index_map_init
 <<Interactions: procedures>>=
   subroutine qn_index_map_init (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
 
 @ %def qn_index_map_init
 @ Construct a trivial mapping.
 <<Interactions: qn index map: TBP>>=
   generic :: init => qn_index_map_init_trivial
   procedure, private :: qn_index_map_init_trivial
 <<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
 
 @ %def qn_index_map_init_trivial
 @ 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
 @ For the rescaling of the structure functions in the real subtraction
 and DGLAP components we need a mapping 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>>=
   procedure :: init_sf => qn_index_map_init_sf
 <<Interactions: procedures>>=
   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_sf
 @ 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 msg_bug ("[qn_index_map_get_index] 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.
    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
 @ 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
 @ 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 als 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
 \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
 <<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))
        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
 aparticle 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.)  Finally, the
 [[connections_are_resonant]] argument tells whether the connecting
 particles should be marked as resonant in the final event record.
 This is useful for 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
       n_matrix_elements = size (me_index)
       allocate (pa (n_matrix_elements))
       allocate (n_entries (n_matrix_elements))
       n_entries = 1
       call pairing_array_init &
            (pa, n_entries, has_i2=.false., has_factor=.false.)
       do i = 1, n_matrix_elements
          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/phase_space/phase_space.nw
===================================================================
--- trunk/src/phase_space/phase_space.nw	(revision 8357)
+++ trunk/src/phase_space/phase_space.nw	(revision 8358)
@@ -1,27610 +1,27606 @@
 % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: phase space
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Phase Space}
 \includemodulegraph{phase_space}
 
 The abstract representation of a type that parameterizes phase space,
 with methods for construction and evaluation.
 \begin{description}
 \item[phs\_base]
   Abstract phase-space representation.
 \end{description}
 
 A simple implementation:
 \begin{description}
 \item[phs\_1none]
   This implements a non-functional dummy module for the phase space.
   A process which uses this module cannot be integrated.  The purpose
   of this module is to provide a placeholder for processes which do
   not require phase-space evaluation.  They may still allow for evaluating
   matrix elements.
 \item[phs\_single]
   Parameterize the phase space of a single particle, i.e., the solid
   angle.  This is useful only for very restricted problems, but it
   avoids the complexity of a generic approach in those trivial cases.
 \end{description}
 
 The standard implementation is called \emph{wood} phase space.  It
 consists of several auxiliary modules and the actual implementation
 module.
 \begin{description}
 \item[mappings]
   Generate invariant masses and decay angles from given
   random numbers (or the inverse operation).  Each mapping pertains to a
   particular node in a phase-space tree.  Different mappings account for
   uniform distributions, resonances, zero-mass behavior, and so on.
 \item[phs\_trees]
   Phase space parameterizations for scattering
   processes are defined recursively as if there was an initial particle
   decaying.  This module sets up a representation in terms of abstract
   trees, where each node gets a unique binary number.  Each tree is
   stored as an array of branches, where integers indicate the
   connections.  This emulates pointers in a transparent way.  Real
   pointers would also be possible, but seem to be less efficient for
   this particular case.
 \item[phs\_forests]
   The type defined by this module collects the
   decay trees corresponding to a given process and the applicable
   mappings.  To set this up, a file is read which is either written by
   the user or by the \textbf{cascades} module functions.  The module
   also contains the routines that evaluate phase space, i.e., generate
   momenta from random numbers and back.
 \item[cascades]
   This module is a pseudo Feynman diagram generator with the
   particular purpose of finding the phase space parameterizations best
   suited for a given process.  It uses a model file to set up the
   possible vertices, generates all possible diagrams, identifies
   resonances and singularities, and simplifies the list by merging
   equivalent diagrams and dropping irrelevant ones.  This process can be
   controlled at several points by user-defined parameters.  Note that it
   depends on the particular values of particle masses, so it cannot be
   done before reading the input file.
 \item[phs\_wood]
   Make the functionality available in form of an implementation of the
   abstract phase-space type.
 \item[phs\_fks]
   Phase-space parameterization with modifications for the FKS scheme.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Abstract phase-space module}
 
 In this module we define an abstract base type (and a trivial test
 implementation) for multi-channel phase-space parameterizations.
 <<[[phs_base.f90]]>>=
 <<File header>>
 
 module phs_base
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants, only: TWOPI, TWOPI4
   use string_utils, only: split_string
   use format_defs, only: FMT_19
   use numeric_utils
   use diagnostics
   use md5
   use physics_defs
   use lorentz
   use model_data
   use flavors
   use process_constants
 
 <<Standard module head>>
 
 <<PHS base: public>>
 
 <<PHS base: types>>
 
 <<PHS base: interfaces>>
 
 contains
 
 <<PHS base: procedures>>
 
 end module phs_base
 @ %def phs_base
 @
 \subsection{Phase-space channels}
 The kinematics configuration may generate multiple parameterizations of phase
 space.  Some of those have specific properties, such as a resonance in the s
 channel.
 
 \subsubsection{Channel properties}
 This is the abstract type for the channel properties.  We need them as
 a data transfer container, so everything is public and transparent.
 <<PHS base: public>>=
   public :: channel_prop_t
 <<PHS base: types>>=
   type, abstract :: channel_prop_t
    contains
      procedure (channel_prop_to_string), deferred :: to_string
      generic :: operator (==) => is_equal
      procedure (channel_eq), deferred :: is_equal
   end type channel_prop_t
 
 @ %def channel_prop_t
 <<PHS base: interfaces>>=
   abstract interface
      function channel_prop_to_string (object) result (string)
        import
        class(channel_prop_t), intent(in) :: object
        type(string_t) :: string
      end function channel_prop_to_string
   end interface
 
 @ %def channel_prop_to_string
 <<PHS base: interfaces>>=
   abstract interface
      function channel_eq (prop1, prop2) result (flag)
        import
        class(channel_prop_t), intent(in) :: prop1, prop2
        logical :: flag
      end function channel_eq
   end interface
 
 @ %def channel_prop_to_string
 @
 Here is a resonance as a channel property.  Mass and width are stored
 here in physical units.
 <<PHS base: public>>=
   public :: resonance_t
 <<PHS base: types>>=
   type, extends (channel_prop_t) :: resonance_t
      real(default) :: mass = 0
      real(default) :: width = 0
    contains
      procedure :: to_string => resonance_to_string
      procedure :: is_equal => resonance_is_equal
   end type resonance_t
 
 @ %def resonance_t
 @ Print mass and width.
 <<PHS base: procedures>>=
   function resonance_to_string (object) result (string)
     class(resonance_t), intent(in) :: object
     type(string_t) :: string
     character(32) :: buffer
     string = "resonant: m ="
     write (buffer, "(" // FMT_19 // ")")  object%mass
     string = string // trim (buffer) // " GeV, w ="
     write (buffer, "(" // FMT_19 // ")")  object%width
     string = string // trim (buffer) // " GeV"
   end function resonance_to_string
 
 @ %def resonance_to_string
 @ Equality.
 <<PHS base: procedures>>=
   function resonance_is_equal (prop1, prop2) result (flag)
     class(resonance_t), intent(in) :: prop1
     class(channel_prop_t), intent(in) :: prop2
     logical :: flag
     select type (prop2)
     type is (resonance_t)
        flag = prop1%mass == prop2%mass .and. prop1%width == prop2%width
     class default
        flag = .false.
     end select
   end function resonance_is_equal
 
 @ %def resonance_is_equal
 @
 This is the limiting case of a resonance, namely an on-shell particle.
 We just store the mass in physical units.
 <<PHS base: public>>=
   public :: on_shell_t
 <<PHS base: types>>=
   type, extends (channel_prop_t) :: on_shell_t
      real(default) :: mass = 0
    contains
      procedure :: to_string => on_shell_to_string
      procedure :: is_equal => on_shell_is_equal
   end type on_shell_t
 
 @ %def on_shell_t
 @ Print mass and width.
 <<PHS base: procedures>>=
   function on_shell_to_string (object) result (string)
     class(on_shell_t), intent(in) :: object
     type(string_t) :: string
     character(32) :: buffer
     string = "on shell: m ="
     write (buffer, "(" // FMT_19 // ")")  object%mass
     string = string // trim (buffer) // " GeV"
   end function on_shell_to_string
 
 @ %def on_shell_to_string
 @ Equality.
 <<PHS base: procedures>>=
   function on_shell_is_equal (prop1, prop2) result (flag)
     class(on_shell_t), intent(in) :: prop1
     class(channel_prop_t), intent(in) :: prop2
     logical :: flag
     select type (prop2)
     type is (on_shell_t)
        flag = prop1%mass == prop2%mass
     class default
        flag = .false.
     end select
   end function on_shell_is_equal
 
 @ %def on_shell_is_equal
 @
 \subsubsection{Channel equivalences}
 This type describes an equivalence.  The current channel is equivalent
 to channel [[c]].  The equivalence involves a permutation [[perm]] of
 integration dimensions and, within each integration dimension, a
 mapping [[mode]].
 <<PHS base: types>>=
   type :: phs_equivalence_t
      integer :: c = 0
      integer, dimension(:), allocatable :: perm
      integer, dimension(:), allocatable :: mode
    contains
    <<PHS base: phs equivalence: TBP>>
   end type phs_equivalence_t
 
 @ %def phs_equivalence_t
 @
 The mapping modes are
 <<PHS base: types>>=
   integer, parameter, public :: &
        EQ_IDENTITY = 0, EQ_INVERT = 1, EQ_SYMMETRIC = 2, EQ_INVARIANT = 3
 
 @ %def EQ_IDENTITY EQ_INVERT EQ_SYMMETRIC
 @ In particular, if a channel is equivalent to itself in the
 [[EQ_SYMMETRIC]] mode, the integrand can be assumed to be symmetric
 w.r.t.\ a reflection $x\to 1 - x$ of the correponding integration variable.
 
 These are the associated tags, for output:
 <<PHS base: types>>=
   character, dimension(0:3), parameter :: TAG = ["+", "-", ":", "x"]
 
 @ %def TAG
 @ Write an equivalence.
 <<PHS base: phs equivalence: TBP>>=
   procedure :: write => phs_equivalence_write
 <<PHS base: procedures>>=
   subroutine phs_equivalence_write (object, unit)
     class(phs_equivalence_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, j
     u = given_output_unit (unit)
     write (u, "(5x,'=',1x,I0,1x)", advance = "no")  object%c
     if (allocated (object%perm)) then
        write (u, "(A)", advance = "no")  "("
        do j = 1, size (object%perm)
           if (j > 1)  write (u, "(1x)", advance = "no")
           write (u, "(I0,A1)", advance = "no") &
                object%perm(j), TAG(object%mode(j))
        end do
        write (u, "(A)")  ")"
     else
        write (u, "(A)")
     end if
   end subroutine phs_equivalence_write
 
 @ %def phs_equivalence_write
 @ Initialize an equivalence.  This allocates the [[perm]] and [[mode]]
 arrays with equal size.
 <<PHS base: phs equivalence: TBP>>=
   procedure :: init => phs_equivalence_init
 <<PHS base: procedures>>=
   subroutine phs_equivalence_init (eq, n_dim)
     class(phs_equivalence_t), intent(out) :: eq
     integer, intent(in) :: n_dim
     allocate (eq%perm (n_dim), source = 0)
     allocate (eq%mode (n_dim), source = EQ_IDENTITY)
   end subroutine phs_equivalence_init
 
 @ %def phs_equivalence_init
 @
 \subsubsection{Channel objects}
 The channel entry holds (optionally) specific properties.
 
 [[sf_channel]] is the structure-function channel that corresponds to this
 phase-space channel.  The structure-function channel may be set up with a
 specific mapping that depends on the phase-space channel properties.  (The
 default setting is to leave the properties empty.)
 <<PHS base: public>>=
   public :: phs_channel_t
 <<PHS base: types>>=
   type :: phs_channel_t
      class(channel_prop_t), allocatable :: prop
      integer :: sf_channel = 1
      type(phs_equivalence_t), dimension(:), allocatable :: eq
    contains
    <<PHS base: phs channel: TBP>>
   end type phs_channel_t
 
 @ %def phs_channel_t
 @ Output.
 <<PHS base: phs channel: TBP>>=
   procedure :: write => phs_channel_write
 <<PHS base: procedures>>=
   subroutine phs_channel_write (object, unit)
     class(phs_channel_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, j
     u = given_output_unit (unit)
     write (u, "(1x,I0)", advance="no") object%sf_channel
     if (allocated (object%prop)) then
        write (u, "(1x,A)")  char (object%prop%to_string ())
     else
        write (u, *)
     end if
     if (allocated (object%eq)) then
        do j = 1, size (object%eq)
           call object%eq(j)%write (u)
        end do
     end if
   end subroutine phs_channel_write
 
 @ %def phs_channel_write
 @ Identify the channel with an s-channel resonance.
 <<PHS base: phs channel: TBP>>=
   procedure :: set_resonant => channel_set_resonant
 <<PHS base: procedures>>=
   subroutine channel_set_resonant (channel, mass, width)
     class(phs_channel_t), intent(inout) :: channel
     real(default), intent(in) :: mass, width
     allocate (resonance_t :: channel%prop)
     select type (prop => channel%prop)
     type is (resonance_t)
        prop%mass = mass
        prop%width = width
     end select
   end subroutine channel_set_resonant
 
 @ %def channel_set_resonant
 @ Identify the channel with an on-shell particle.
 <<PHS base: phs channel: TBP>>=
   procedure :: set_on_shell => channel_set_on_shell
 <<PHS base: procedures>>=
   subroutine channel_set_on_shell (channel, mass)
     class(phs_channel_t), intent(inout) :: channel
     real(default), intent(in) :: mass
     allocate (on_shell_t :: channel%prop)
     select type (prop => channel%prop)
     type is (on_shell_t)
        prop%mass = mass
     end select
   end subroutine channel_set_on_shell
 
 @ %def channel_set_on_shell
 @
 \subsection{Property collection}
 We can set up a list of all distinct channel properties for a given
 set of channels.
 <<PHS base: public>>=
   public :: phs_channel_collection_t
 <<PHS base: types>>=
   type :: prop_entry_t
      integer :: i = 0
      class(channel_prop_t), allocatable :: prop
      type(prop_entry_t), pointer :: next => null ()
   end type prop_entry_t
 
   type :: phs_channel_collection_t
      integer :: n = 0
      type(prop_entry_t), pointer :: first => null ()
    contains
    <<PHS base: phs channel collection: TBP>>
   end type phs_channel_collection_t
 
 @ %def prop_entry_t
 @ %def phs_channel_collection_t
 @ Finalizer for the list.
 <<PHS base: phs channel collection: TBP>>=
   procedure :: final => phs_channel_collection_final
 <<PHS base: procedures>>=
   subroutine phs_channel_collection_final (object)
     class(phs_channel_collection_t), intent(inout) :: object
     type(prop_entry_t), pointer :: entry
     do while (associated (object%first))
        entry => object%first
        object%first => entry%next
        deallocate (entry)
     end do
   end subroutine phs_channel_collection_final
 
 @ %def phs_channel_collection_final
 @ Output.
 <<PHS base: phs channel collection: TBP>>=
   procedure :: write => phs_channel_collection_write
 <<PHS base: procedures>>=
   subroutine phs_channel_collection_write (object, unit)
     class(phs_channel_collection_t), intent(in) :: object
     integer, intent(in), optional :: unit
     type(prop_entry_t), pointer :: entry
     integer :: u
     u = given_output_unit (unit)
     entry => object%first
     do while (associated (entry))
        if (allocated (entry%prop)) then
           write (u, "(1x,I0,1x,A)")  entry%i, char (entry%prop%to_string ())
        else
           write (u, "(1x,I0)")  entry%i
        end if
        entry => entry%next
     end do
   end subroutine phs_channel_collection_write
 
 @ %def phs_channel_collection_write
 @ Push a new property to the stack if it is not yet included.
 Simultaneously, set the [[sf_channel]] entry in the phase-space
 channel object to the index of the matching entry, or the new entry if
 there was no match.
 <<PHS base: phs channel collection: TBP>>=
   procedure :: push => phs_channel_collection_push
 <<PHS base: procedures>>=
   subroutine phs_channel_collection_push (coll, channel)
     class(phs_channel_collection_t), intent(inout) :: coll
     type(phs_channel_t), intent(inout) :: channel
     type(prop_entry_t), pointer :: entry, new
     if (associated (coll%first)) then
        entry => coll%first
        do
           if (allocated (entry%prop)) then
              if (allocated (channel%prop)) then
                 if (entry%prop == channel%prop) then
                    channel%sf_channel = entry%i
                    return
                 end if
              end if
           else if (.not. allocated (channel%prop)) then
              channel%sf_channel = entry%i
              return
           end if
           if (associated (entry%next)) then
              entry => entry%next
           else
              exit
           end if
        end do
        allocate (new)
        entry%next => new
     else
        allocate (new)
        coll%first => new
     end if
     coll%n = coll%n + 1
     new%i = coll%n
     channel%sf_channel = new%i
     if (allocated (channel%prop)) then
        allocate (new%prop, source = channel%prop)
     end if
   end subroutine phs_channel_collection_push
 
 @ %def phs_channel_collection_push
 @ Return the number of collected distinct channels.
 <<PHS base: phs channel collection: TBP>>=
   procedure :: get_n => phs_channel_collection_get_n
 <<PHS base: procedures>>=
   function phs_channel_collection_get_n (coll) result (n)
     class(phs_channel_collection_t), intent(in) :: coll
     integer :: n
     n = coll%n
   end function phs_channel_collection_get_n
 
 @ %def phs_channel_collection_get_n
 @ Return a specific channel (property object).
 <<PHS base: phs channel collection: TBP>>=
   procedure :: get_entry => phs_channel_collection_get_entry
 <<PHS base: procedures>>=
   subroutine phs_channel_collection_get_entry (coll, i, prop)
     class(phs_channel_collection_t), intent(in) :: coll
     integer, intent(in) :: i
     class(channel_prop_t), intent(out), allocatable :: prop
     type(prop_entry_t), pointer :: entry
     integer :: k
     if (i > 0 .and. i <= coll%n) then
        entry => coll%first
        do k = 2, i
           entry => entry%next
        end do
        if (allocated (entry%prop)) then
           if (allocated (prop))  deallocate (prop)
           allocate (prop, source = entry%prop)
        end if
     else
        call msg_bug ("PHS channel collection: get entry: illegal index")
     end if
   end subroutine phs_channel_collection_get_entry
 
 @ %def phs_channel_collection_get_entry
 @
 \subsection{Kinematics configuration}
 Here, we store the universal information that is specifically relevant
 for phase-space generation.  It is a subset of the process data,
 supplemented by basic information on phase-space parameterization
 channels.
 
 A concrete implementation will contain more data, that describe the
 phase space in detail.
 
 MD5 sums: the phase space setup depends on the process, it depends on
 the model parameters (the masses, that is), and on the configuration
 parameters.  (It does not depend on the QCD setup.)
 <<PHS base: public>>=
   public :: phs_config_t
 <<PHS base: types>>=
   type, abstract :: phs_config_t
      ! private
      type(string_t) :: id
      integer :: n_in = 0
      integer :: n_out = 0
      integer :: n_tot = 0
      integer :: n_state = 0
      integer :: n_par = 0
      integer :: n_channel = 0
      real(default) :: sqrts = 0
      logical :: sqrts_fixed = .true.
      logical :: cm_frame = .true.
      logical :: azimuthal_dependence = .false.
      integer, dimension(:), allocatable :: dim_flat
      logical :: provides_equivalences = .false.
      logical :: provides_chains = .false.
      logical :: vis_channels = .false.
      integer, dimension(:), allocatable :: chain
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(:,:), allocatable :: flv
      type(phs_channel_t), dimension(:), allocatable :: channel
      character(32) :: md5sum_process = ""
      character(32) :: md5sum_model_par = ""
      character(32) :: md5sum_phs_config = ""
      integer :: nlo_type
    contains
    <<PHS base: phs config: TBP>>
   end type phs_config_t
 
 @ %def phs_config_t
 @ Finalizer, deferred.
 <<PHS base: phs config: TBP>>=
   procedure (phs_config_final), deferred :: final
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_config_final (object)
        import
        class(phs_config_t), intent(inout) :: object
      end subroutine phs_config_final
   end interface
 
 @ %def phs_config_final
 @ Output.  We provide an implementation for the output of the base-type
 contents and an interface for the actual write method.
 <<PHS base: phs config: TBP>>=
   procedure (phs_config_write), deferred :: write
   procedure :: base_write => phs_config_write
 <<PHS base: procedures>>=
   subroutine phs_config_write (object, unit, include_id)
     class(phs_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: include_id
     integer :: u, i, j
     integer :: n_tot_flv
     logical :: use_id
     n_tot_flv = object%n_tot
     u = given_output_unit (unit)
     use_id = .true.; if (present (include_id)) use_id = include_id
     if (use_id) write (u, "(3x,A,A,A)") "ID        = '", char (object%id), "'"
     write (u, "(3x,A,I0)")  "n_in      = ", object%n_in
     write (u, "(3x,A,I0)")  "n_out     = ", object%n_out
     write (u, "(3x,A,I0)")  "n_tot     = ", object%n_tot
     write (u, "(3x,A,I0)")  "n_state   = ", object%n_state
     write (u, "(3x,A,I0)")  "n_par     = ", object%n_par
     write (u, "(3x,A,I0)")  "n_channel = ", object%n_channel
     write (u, "(3x,A," // FMT_19 // ")")  "sqrts     = ", object%sqrts
     write (u, "(3x,A,L1)")  "s_fixed   = ", object%sqrts_fixed
     write (u, "(3x,A,L1)")  "cm_frame  = ", object%cm_frame
     write (u, "(3x,A,L1)")  "azim.dep. = ", object%azimuthal_dependence
     if (allocated (object%dim_flat)) then
        write (u, "(3x,A,I0)")  "flat dim. = ", object%dim_flat
     end if
     write (u, "(1x,A)")  "Flavor combinations:"
     do i = 1, object%n_state
        write (u, "(3x,I0,':')", advance="no")  i
 !       do j = 1, object%n_tot
        do j = 1, n_tot_flv
           write (u, "(1x,A)", advance="no")  char (object%flv(j,i)%get_name ())
        end do
        write (u, "(A)")
     end do
     if (allocated (object%channel)) then
        write (u, "(1x,A)")  "Phase-space / structure-function channels:"
        do i = 1, object%n_channel
           write (u, "(3x,I0,':')", advance="no") i
           call object%channel(i)%write (u)
        end do
     end if
     if (object%md5sum_process /= "") then
        write (u, "(3x,A,A,A)") "MD5 sum (process)    = '", &
             object%md5sum_process, "'"
     end if
     if (object%md5sum_model_par /= "") then
        write (u, "(3x,A,A,A)") "MD5 sum (model par)  = '", &
             object%md5sum_model_par, "'"
     end if
     if (object%md5sum_phs_config /= "") then
        write (u, "(3x,A,A,A)") "MD5 sum (phs config) = '", &
             object%md5sum_phs_config, "'"
     end if
   end subroutine phs_config_write
 
 @ %def phs_config_write
 @ Similarly, a basic initializer and an interface.  The model pointer is taken
 as an argument; we may verify that this has the expected model name.
 
 The intent is [[inout]].  We want to be able to set parameters in advance.
 <<PHS base: phs config: TBP>>=
   procedure :: init => phs_config_init
 <<PHS base: procedures>>=
   subroutine phs_config_init (phs_config, data, model)
     class(phs_config_t), intent(inout) :: phs_config
     type(process_constants_t), intent(in) :: data
     class(model_data_t), intent(in), target :: model
     integer :: i, j
     phs_config%id = data%id
     phs_config%n_in  = data%n_in
     phs_config%n_out = data%n_out
     phs_config%n_tot = data%n_in + data%n_out
     phs_config%n_state = data%n_flv
     if (data%model_name == model%get_name ()) then
        phs_config%model => model
     else
        call msg_bug ("phs_config_init: model name mismatch")
     end if
     allocate (phs_config%flv (phs_config%n_tot, phs_config%n_state))
     do i = 1, phs_config%n_state
        do j = 1, phs_config%n_tot
           call phs_config%flv(j,i)%init (data%flv_state(j,i), &
                phs_config%model)
        end do
     end do
     phs_config%md5sum_process = data%md5sum
   end subroutine phs_config_init
 
 @ %def phs_config_init
 @
 WK 2018-04-05: This procedure appears to be redundant?
 <<XXX PHS base: phs config: TBP>>=
   procedure :: set_component_index => phs_config_set_component_index
 <<XXX PHS base: procedures>>=
   subroutine phs_config_set_component_index (phs_config, index)
     class(phs_config_t), intent(inout) :: phs_config
     integer, intent(in) :: index
     type(string_t), dimension(:), allocatable :: id
     type(string_t) :: suffix
     integer :: i, n
     suffix = var_str ('i') // int2string (index)
     call split_string (phs_config%id, var_str ('_'), id)
     phs_config%id = var_str ('')
     n = size (id) - 1
     do i = 1, n
        phs_config%id = phs_config%id // id(i) // var_str ('_')
     end do
     phs_config%id = phs_config%id // suffix
   end subroutine phs_config_set_component_index
 
 @ %def phs_config_set_component_index
 @ This procedure should complete the phase-space configuration.  We
 need the [[sqrts]] value as overall scale, which is known only after
 the beams have been defined.  The procedure should determine the number of
 channels, their properties (if any), and allocate and fill the [[channel]]
 array accordingly.
 <<PHS base: phs config: TBP>>=
   procedure (phs_config_configure), deferred :: configure
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_config_configure (phs_config, sqrts, &
           sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, &
           nlo_type, subdir)
        import
        class(phs_config_t), intent(inout) :: phs_config
        real(default), intent(in) :: sqrts
        logical, intent(in), optional :: sqrts_fixed
        logical, intent(in), optional :: cm_frame
        logical, intent(in), optional :: azimuthal_dependence
        logical, intent(in), optional :: rebuild
        logical, intent(in), optional :: ignore_mismatch
        integer, intent(in), optional :: nlo_type
        type(string_t), intent(in), optional :: subdir
      end subroutine phs_config_configure
   end interface
 
 @ %def phs_config_configure
 @ Manually assign structure-function channel indices to the phase-space
 channel objects.  (Used by a test routine.)
 <<PHS base: phs config: TBP>>=
   procedure :: set_sf_channel => phs_config_set_sf_channel
 <<PHS base: procedures>>=
   subroutine phs_config_set_sf_channel (phs_config, sf_channel)
     class(phs_config_t), intent(inout) :: phs_config
     integer, dimension(:), intent(in) :: sf_channel
     phs_config%channel%sf_channel = sf_channel
   end subroutine phs_config_set_sf_channel
 
 @ %def phs_config_set_sf_channel
 @ Collect new channels not yet in the collection from this phase-space
 configuration object.  At the same time, assign structure-function channels.
 <<PHS base: phs config: TBP>>=
   procedure :: collect_channels => phs_config_collect_channels
 <<PHS base: procedures>>=
   subroutine phs_config_collect_channels (phs_config, coll)
     class(phs_config_t), intent(inout) :: phs_config
     type(phs_channel_collection_t), intent(inout) :: coll
     integer :: c
     do c = 1, phs_config%n_channel
        call coll%push (phs_config%channel(c))
     end do
   end subroutine phs_config_collect_channels
 
 @ %def phs_config_collect_channels
 @ Compute the MD5 sum.  We abuse the [[write]] method.  In
 type implementations, [[write]] should only display information that is
 relevant for the MD5 sum.  The data include the process MD5 sum which is taken
 from the process constants, and the MD5 sum of the model parameters.  This may
 change, so it is computed here.
 <<PHS base: phs config: TBP>>=
   procedure :: compute_md5sum => phs_config_compute_md5sum
 <<PHS base: procedures>>=
   subroutine phs_config_compute_md5sum (phs_config, include_id)
     class(phs_config_t), intent(inout) :: phs_config
     logical, intent(in), optional :: include_id
     integer :: u
     phs_config%md5sum_model_par = phs_config%model%get_parameters_md5sum ()
     phs_config%md5sum_phs_config = ""
     u = free_unit ()
     open (u, status = "scratch", action = "readwrite")
     call phs_config%write (u, include_id)
     rewind (u)
     phs_config%md5sum_phs_config = md5sum (u)
     close (u)
   end subroutine phs_config_compute_md5sum
 
 @ %def phs_config_compute_md5sum
 @ Print an informative message after phase-space configuration.
 <<PHS base: phs config: TBP>>=
   procedure (phs_startup_message), deferred :: startup_message
   procedure :: base_startup_message => phs_startup_message
 <<PHS base: procedures>>=
   subroutine phs_startup_message (phs_config, unit)
     class(phs_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     write (msg_buffer, "(A,3(1x,I0,1x,A))") &
          "Phase space:", &
          phs_config%n_channel, "channels,", &
          phs_config%n_par, "dimensions"
     call msg_message (unit = unit)
   end subroutine phs_startup_message
 
 @ %def phs_startup_message
 @ This procedure should be implemented such that the phase-space
 configuration object allocates a phase-space instance of matching type.
 <<PHS base: phs config: TBP>>=
   procedure (phs_config_allocate_instance), nopass, deferred :: &
        allocate_instance
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_config_allocate_instance (phs)
        import
        class(phs_t), intent(inout), pointer :: phs
      end subroutine phs_config_allocate_instance
   end interface
 
 @ %def phs_config_allocate_instance
 @
 \subsection{Extract data}
 Return the number of MC input parameters.
 <<PHS base: phs config: TBP>>=
   procedure :: get_n_par => phs_config_get_n_par
 <<PHS base: procedures>>=
   function phs_config_get_n_par (phs_config) result (n)
     class(phs_config_t), intent(in) :: phs_config
     integer :: n
     n = phs_config%n_par
   end function phs_config_get_n_par
 
 @ %def phs_config_get_n_par
 @ Return dimensions (parameter indices) for which the phase-space
 dimension is flat, so integration and event generation can be simplified.
 <<PHS base: phs config: TBP>>=
   procedure :: get_flat_dimensions => phs_config_get_flat_dimensions
 <<PHS base: procedures>>=
   function phs_config_get_flat_dimensions (phs_config) result (dim_flat)
     class(phs_config_t), intent(in) :: phs_config
     integer, dimension(:), allocatable :: dim_flat
     if (allocated (phs_config%dim_flat)) then
        allocate (dim_flat (size (phs_config%dim_flat)))
        dim_flat = phs_config%dim_flat
     else
        allocate (dim_flat (0))
     end if
   end function phs_config_get_flat_dimensions
 
 @ %def phs_config_get_flat_dimensions
 @ Return the number of phase-space channels.
 <<PHS base: phs config: TBP>>=
   procedure :: get_n_channel => phs_config_get_n_channel
 <<PHS base: procedures>>=
   function phs_config_get_n_channel (phs_config) result (n)
     class(phs_config_t), intent(in) :: phs_config
     integer :: n
     n = phs_config%n_channel
   end function phs_config_get_n_channel
 
 @ %def phs_config_get_n_channel
 @ Return the structure-function channel that corresponds to the
 phase-space channel [[c]].  If the channel array is not allocated (which
 happens if there is no structure function), return zero.
 <<PHS base: phs config: TBP>>=
   procedure :: get_sf_channel => phs_config_get_sf_channel
 <<PHS base: procedures>>=
   function phs_config_get_sf_channel (phs_config, c) result (c_sf)
     class(phs_config_t), intent(in) :: phs_config
     integer, intent(in) :: c
     integer :: c_sf
     if (allocated (phs_config%channel)) then
        c_sf = phs_config%channel(c)%sf_channel
     else
        c_sf = 0
     end if
   end function phs_config_get_sf_channel
 
 @ %def phs_config_get_sf_channel
 @ Return the mass(es) of the incoming particle(s).  We take the first flavor
 combination in the array, assuming that masses must be degenerate among
 flavors.
 <<PHS base: phs config: TBP>>=
   procedure :: get_masses_in => phs_config_get_masses_in
 <<PHS base: procedures>>=
   subroutine phs_config_get_masses_in (phs_config, m)
     class(phs_config_t), intent(in) :: phs_config
     real(default), dimension(:), intent(out) :: m
     integer :: i
     do i = 1, phs_config%n_in
        m(i) = phs_config%flv(i,1)%get_mass ()
     end do
   end subroutine phs_config_get_masses_in
 
 @ %def phs_config_get_masses_in
 @ Return the MD5 sum of the configuration.
 <<PHS base: phs config: TBP>>=
   procedure :: get_md5sum => phs_config_get_md5sum
 <<PHS base: procedures>>=
   function phs_config_get_md5sum (phs_config) result (md5sum)
     class(phs_config_t), intent(in) :: phs_config
     character(32) :: md5sum
     md5sum = phs_config%md5sum_phs_config
   end function phs_config_get_md5sum
 
 @ %def phs_config_get_md5sum
 @
 \subsection{Phase-space point instance}
 The [[phs_t]] object holds the workspace for phase-space generation.
 In the base object, we have the MC input parameters [[r]] and the
 Jacobian factor [[f]], for each channel, and the incoming and outgoing
 momenta.
 
 Note: The [[active_channel]] array is not used yet, all elements are
 initialized with [[.true.]].  It should be touched by the integrator if it
 decides to drop irrelevant channels.
 <<PHS base: public>>=
   public :: phs_t
 <<PHS base: types>>=
   type, abstract :: phs_t
      class(phs_config_t), pointer :: config => null ()
      logical :: r_defined = .false.
      integer :: selected_channel = 0
      logical, dimension(:), allocatable :: active_channel
      real(default), dimension(:,:), allocatable :: r
      real(default), dimension(:), allocatable :: f
      real(default), dimension(:), allocatable :: m_in
      real(default), dimension(:), allocatable :: m_out
      real(default) :: flux = 0
      real(default) :: volume = 0
      type(lorentz_transformation_t) :: lt_cm_to_lab
      logical :: p_defined = .false.
      real(default) :: sqrts_hat = 0
      type(vector4_t), dimension(:), allocatable :: p
      logical :: q_defined = .false.
      type(vector4_t), dimension(:), allocatable :: q
    contains
    <<PHS base: phs: TBP>>
   end type phs_t
 
 @ %def phs_t
 @ Output.  Since phase space may get complicated, we include a
 [[verbose]] option for the abstract [[write]] procedure.
 <<PHS base: phs: TBP>>=
   procedure (phs_write), deferred :: write
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_write (object, unit, verbose)
        import
        class(phs_t), intent(in) :: object
        integer, intent(in), optional :: unit
        logical, intent(in), optional :: verbose
      end subroutine phs_write
   end interface
 
 @ %def phs_write
 @ This procedure can be called to print the contents of the base type.
 <<PHS base: phs: TBP>>=
   procedure :: base_write => phs_base_write
 <<PHS base: procedures>>=
   subroutine phs_base_write (object, unit)
     class(phs_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, c, i
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "Partonic phase space: parameters"
     if (object%r_defined) then
        write (u, *)
     else
        write (u, "(1x,A)")  "[undefined]"
     end if
     write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_in    =", object%m_in
     write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_out   =", object%m_out
     write (u, "(3x,A," // FMT_19 // ")")  "Flux   = ", object%flux
     write (u, "(3x,A," // FMT_19 // ")")  "Volume = ", object%volume
     if (allocated (object%f)) then
        do c = 1, size (object%r, 2)
           write (u, "(1x,A,I0,A)", advance="no")  "Channel #", c, ":"
           if (c == object%selected_channel) then
              write (u, "(1x,A)")  "[selected]"
           else
              write (u, *)
           end if
           write (u, "(3x,A)", advance="no")  "r ="
           do i = 1, size (object%r, 1)
              write (u, "(1x,F9.7)", advance="no")  object%r(i,c)
           end do
           write (u, *)
           write (u, "(3x,A,1x,ES13.7)")  "f =", object%f(c)
        end do
     end if
     write (u, "(1x,A)")  "Partonic phase space: momenta"
     if (object%p_defined) then
        write (u, "(3x,A," // FMT_19 // ")")  "sqrts  = ", object%sqrts_hat
     end if
     write (u, "(1x,A)", advance="no")  "Incoming:"
     if (object%p_defined) then
        write (u, *)
     else
        write (u, "(1x,A)")  "[undefined]"
     end if
     if (allocated (object%p)) then
        do i = 1, size (object%p)
           call vector4_write (object%p(i), u)
        end do
     end if
     write (u, "(1x,A)", advance="no")  "Outgoing:"
     if (object%q_defined) then
        write (u, *)
     else
        write (u, "(1x,A)")  "[undefined]"
     end if
     if (allocated (object%q)) then
        do i = 1, size (object%q)
           call vector4_write (object%q(i), u)
        end do
     end if
     if (object%p_defined .and. .not. object%config%cm_frame) then
        write (u, "(1x,A)")  "Transformation c.m -> lab frame"
        call lorentz_transformation_write (object%lt_cm_to_lab, u)
     end if
   end subroutine phs_base_write
 
 @ %def phs_base_write
 @ Finalizer.  The base type does not need it, but extensions may.
 <<PHS base: phs: TBP>>=
   procedure (phs_final), deferred :: final
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_final (object)
        import
        class(phs_t), intent(inout) :: object
      end subroutine phs_final
   end interface
 
 @ %def phs_final
 @ Initializer.  Everything should be contained in the [[process_data]]
 configuration object, so we can require a universal interface.
 <<PHS base: phs: TBP>>=
   procedure (phs_init), deferred :: init
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_init (phs, phs_config)
        import
        class(phs_t), intent(out) :: phs
        class(phs_config_t), intent(in), target :: phs_config
      end subroutine phs_init
   end interface
 
 @ %def phs_init
 @ The base version will just allocate the arrays.  It should be called
 at the beginning of the implementation of [[phs_init]].
 <<PHS base: phs: TBP>>=
   procedure :: base_init => phs_base_init
 <<PHS base: procedures>>=
   subroutine phs_base_init (phs, phs_config)
     class(phs_t), intent(out) :: phs
     class(phs_config_t), intent(in), target :: phs_config
     real(default), dimension(phs_config%n_in) :: m_in
     real(default), dimension(phs_config%n_out) :: m_out
     phs%config => phs_config
     allocate (phs%active_channel (phs%config%n_channel))
     phs%active_channel = .true.
     allocate (phs%r (phs%config%n_par, phs%config%n_channel));  phs%r = 0
     allocate (phs%f (phs%config%n_channel));                    phs%f = 0
     allocate (phs%p (phs%config%n_in))
     !!! !!! !!! Workaround for gfortran 5.0 ICE
     m_in  = phs_config%flv(:phs_config%n_in, 1)%get_mass ()
     m_out = phs_config%flv(phs_config%n_in+1:, 1)%get_mass ()
     allocate (phs%m_in  (phs%config%n_in), source = m_in)
     !!! allocate (phs%m_in  (phs%config%n_in), &
     !!!      source = phs_config%flv(:phs_config%n_in, 1)%get_mass ())
     allocate (phs%q (phs%config%n_out))
     allocate (phs%m_out (phs%config%n_out), source = m_out)
     !!! allocate (phs%m_out (phs%config%n_out), &
     !!!      source = phs_config%flv(phs_config%n_in+1:, 1)%get_mass ())
     call phs%compute_flux ()
   end subroutine phs_base_init
 
 @ %def phs_base_init
 @ Manually select a channel.
 <<PHS base: phs: TBP>>=
   procedure :: select_channel => phs_base_select_channel
 <<PHS base: procedures>>=
   subroutine phs_base_select_channel (phs, channel)
     class(phs_t), intent(inout) :: phs
     integer, intent(in), optional :: channel
     if (present (channel)) then
        phs%selected_channel = channel
     else
        phs%selected_channel = 0
     end if
   end subroutine phs_base_select_channel
 
 @ %def phs_base_select_channel
 @ Set incoming momenta.  Assume that array shapes match.  If
 requested, compute the Lorentz transformation from the c.m.\ to the
 lab frame and apply that transformation to the incoming momenta.
 
 In the c.m.\ frame, the sum of three-momenta is zero.  In a scattering
 process, the $z$ axis is the direction of the first beam, the second
 beam is along the negative $z$ axis.  The transformation from the
 c.m.\ to the lab frame is a rotation from the $z$ axis to the boost
 axis followed by a boost, such that the c.m.\ momenta are transformed
 into the lab-frame momenta.  In a decay process, we just boost along
 the flight direction, without rotation.
 <<PHS base: phs: TBP>>=
   procedure :: set_incoming_momenta => phs_set_incoming_momenta
 <<PHS base: procedures>>=
   subroutine phs_set_incoming_momenta (phs, p)
     class(phs_t), intent(inout) :: phs
     type(vector4_t), dimension(:), intent(in) :: p
     type(vector4_t) :: p0, p1
     type(lorentz_transformation_t) :: lt0
     integer :: i
     phs%p = p
     if (phs%config%cm_frame) then
        phs%sqrts_hat = phs%config%sqrts
        phs%p = p
        phs%lt_cm_to_lab = identity
     else
        p0 = sum (p)
        if (phs%config%sqrts_fixed) then
           phs%sqrts_hat = phs%config%sqrts
        else
           phs%sqrts_hat = p0 ** 1
        end if
        lt0 = boost (p0, phs%sqrts_hat)
        select case (phs%config%n_in)
        case (1)
           phs%lt_cm_to_lab = lt0
        case (2)
           p1 = inverse (lt0) * p(1)
           phs%lt_cm_to_lab = lt0 * rotation_to_2nd (3, space_part (p1))
        end select
        phs%p = inverse (phs%lt_cm_to_lab) * p
     end if
     phs%p_defined = .true.
   end subroutine phs_set_incoming_momenta
 
 @ %def phs_set_incoming_momenta
 @ Set outgoing momenta.  Assume that array shapes match.  The incoming
 momenta must be known, so can apply the Lorentz transformation from
 c.m.\ to lab (inverse) to the momenta.
 <<PHS base: phs: TBP>>=
   procedure :: set_outgoing_momenta => phs_set_outgoing_momenta
 <<PHS base: procedures>>=
   subroutine phs_set_outgoing_momenta (phs, q)
     class(phs_t), intent(inout) :: phs
     type(vector4_t), dimension(:), intent(in) :: q
     integer :: i
     if (phs%p_defined) then
        if (phs%config%cm_frame) then
           phs%q = q
        else
           phs%q = inverse (phs%lt_cm_to_lab) * q
        end if
        phs%q_defined = .true.
     end if
   end subroutine phs_set_outgoing_momenta
 
 @ %def phs_set_outgoing_momenta
 @ Return outgoing momenta.  Apply the c.m.\ to lab transformation if
 necessary.
 <<PHS base: phs: TBP>>=
   procedure :: get_outgoing_momenta => phs_get_outgoing_momenta
 <<PHS base: procedures>>=
   subroutine phs_get_outgoing_momenta (phs, q)
     class(phs_t), intent(in) :: phs
     type(vector4_t), dimension(:), intent(out) :: q
     if (phs%p_defined .and. phs%q_defined) then
        if (phs%config%cm_frame) then
           q = phs%q
        else
           q = phs%lt_cm_to_lab * phs%q
        end if
     else
        q = vector4_null
     end if
   end subroutine phs_get_outgoing_momenta
 
 @ %def phs_get_outgoing_momenta
 @
 <<PHS base: phs: TBP>>=
   procedure :: is_cm_frame => phs_is_cm_frame
 <<PHS base: procedures>>=
   function phs_is_cm_frame (phs) result (cm_frame)
     logical :: cm_frame
     class(phs_t), intent(in) :: phs
     cm_frame = phs%config%cm_frame
   end function phs_is_cm_frame
 
 @ %def phs_is_cm_frame
 @
 <<PHS base: phs: TBP>>=
   procedure :: get_n_tot => phs_get_n_tot
 <<PHS base: procedures>>=
   elemental function phs_get_n_tot (phs) result (n_tot)
     integer :: n_tot
     class(phs_t), intent(in) :: phs
     n_tot = phs%config%n_tot
   end function phs_get_n_tot
 
 @ %def phs_get_n_tot
 @
 <<PHS base: phs: TBP>>=
   procedure :: set_lorentz_transformation => phs_set_lorentz_transformation
 <<PHS base: procedures>>=
   subroutine phs_set_lorentz_transformation (phs, lt)
     class(phs_t), intent(inout) :: phs
     type(lorentz_transformation_t), intent(in) :: lt
     phs%lt_cm_to_lab = lt
   end subroutine phs_set_lorentz_transformation
 
 @ %def phs_set_lorentz_transformation
 @
 <<PHS base: phs: TBP>>=
   procedure :: get_lorentz_transformation => phs_get_lorentz_transformation
 <<PHS base: procedures>>=
   function phs_get_lorentz_transformation (phs) result (lt)
     type(lorentz_transformation_t) :: lt
     class(phs_t), intent(in) :: phs
     lt = phs%lt_cm_to_lab
   end function phs_get_lorentz_transformation
 
 @ %def phs_get_lorentz_transformation
 @ Return the input parameter array for a channel.
 <<PHS base: phs: TBP>>=
   procedure :: get_mcpar => phs_get_mcpar
 <<PHS base: procedures>>=
   subroutine phs_get_mcpar (phs, c, r)
     class(phs_t), intent(in) :: phs
     integer, intent(in) :: c
     real(default), dimension(:), intent(out) :: r
     if (phs%r_defined) then
        r = phs%r(:,c)
     else
        r = 0
     end if
   end subroutine phs_get_mcpar
 
 @ %def phs_get_mcpar
 @ Return the Jacobian factor for a channel.
 <<PHS base: phs: TBP>>=
   procedure :: get_f => phs_get_f
 <<PHS base: procedures>>=
   function phs_get_f (phs, c) result (f)
     class(phs_t), intent(in) :: phs
     integer, intent(in) :: c
     real(default) :: f
     if (phs%r_defined) then
        f = phs%f(c)
     else
        f = 0
     end if
   end function phs_get_f
 
 @ %def phs_get_f
 @ Return the overall factor, which is the product of the flux factor for the
 incoming partons and the phase-space volume for the outgoing partons.
 <<PHS base: phs: TBP>>=
   procedure :: get_overall_factor => phs_get_overall_factor
 <<PHS base: procedures>>=
   function phs_get_overall_factor (phs) result (f)
     class(phs_t), intent(in) :: phs
     real(default) :: f
     f = phs%flux * phs%volume
   end function phs_get_overall_factor
 
 @ %def phs_get_overall_factor
 @ Compute flux factor.  We do this during initialization (when the
 incoming momenta [[p]] are undefined), unless [[sqrts]] is variable.  We do
 this again once for each phase-space point, but then we skip the calculation
 if [[sqrts]] is fixed.
 
 There are three different flux factors.
 \begin{enumerate}
 \item
   For a decaying massive particle, the factor is
   \begin{equation}
     f = (2\pi)^4 / (2M)
   \end{equation}
 \item
   For a $2\to n$ scattering process with $n>1$, the factor is
   \begin{equation}
     f = (2\pi)^4 / (2\sqrt{\lambda})
   \end{equation}
   where for massless incoming particles, $\sqrt{\lambda} = s$.
 \item For a $2\to 1$ on-shell production process, the factor includes
   an extra $1/(2\pi)^3$ factor and a $1/m^2$ factor from the
   phase-space delta function $\delta (x_1x_2 - m^2/s)$, which
   originate from the one-particle phase space that we integrate out.
   \begin{equation}
     f = 2\pi / (2s m^2)
   \end{equation}
   The delta function is handled by the structure-function
   parameterization.
 \end{enumerate}
 <<PHS base: phs: TBP>>=
   procedure :: compute_flux => phs_compute_flux
 <<PHS base: procedures>>=
   subroutine phs_compute_flux (phs)
     class(phs_t), intent(inout) :: phs
     real(default) :: s_hat, lda
     select case (phs%config%n_in)
     case (1)
        if (.not. phs%p_defined) then
           phs%flux = twopi4 / (2 * phs%m_in(1))
        end if
     case (2)
        if (phs%p_defined) then
           if (phs%config%sqrts_fixed) then
              return
           else
              s_hat = sum (phs%p) ** 2
           end if
        else
           if (phs%config%sqrts_fixed) then
              s_hat = phs%config%sqrts ** 2
           else
              return
           end if
        end if
        select case (phs%config%n_out)
        case (2:)
           lda = lambda (s_hat, phs%m_in(1) ** 2, phs%m_in(2) ** 2)
           if (lda > 0) then
              phs%flux = conv * twopi4 / (2 * sqrt (lda))
           else
              phs%flux = 0
           end if
        case (1)
           phs%flux = conv * twopi &
                / (2 * phs%config%sqrts ** 2 * phs%m_out(1) ** 2)
        case default
           phs%flux = 0
        end select
     end select
   end subroutine phs_compute_flux
 
 @ %def phs_compute_flux
 @ Evaluate the phase-space point for a particular channel and compute momenta,
 Jacobian, and phase-space volume. This is, of course, deferred to
 the implementation.
 <<PHS base: phs: TBP>>=
   procedure (phs_evaluate_selected_channel), deferred :: &
        evaluate_selected_channel
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_evaluate_selected_channel (phs, c_in, r_in)
        import
        class(phs_t), intent(inout) :: phs
        integer, intent(in) :: c_in
        real(default), dimension(:), intent(in) :: r_in
      end subroutine phs_evaluate_selected_channel
   end interface
 
 @ %def phs_evaluate_selected_channel
 @ Compute the inverse mappings to completely fill the [[r]] and [[f]] arrays,
 for the non-selected channels.
 <<PHS base: phs: TBP>>=
   procedure (phs_evaluate_other_channels), deferred :: &
        evaluate_other_channels
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_evaluate_other_channels (phs, c_in)
        import
        class(phs_t), intent(inout) :: phs
        integer, intent(in) :: c_in
      end subroutine phs_evaluate_other_channels
   end interface
 
 @ %def phs_evaluate_other_channels
 @ Inverse evaluation.  If all momenta are known, we compute the
 inverse mappings to fill the [[r]] and [[f]] arrays.
 <<PHS base: phs: TBP>>=
   procedure (phs_inverse), deferred :: inverse
 <<PHS base: interfaces>>=
   abstract interface
      subroutine phs_inverse (phs)
        import
        class(phs_t), intent(inout) :: phs
      end subroutine phs_inverse
   end interface
 
 @ %def phs_inverse
 @
 <<PHS base: phs: TBP>>=
   procedure :: get_sqrts => phs_get_sqrts
 <<PHS base: procedures>>=
   function phs_get_sqrts (phs) result (sqrts)
     real(default) :: sqrts
     class(phs_t), intent(in) :: phs
     sqrts = phs%config%sqrts
   end function phs_get_sqrts
 
 @ %def phs_get_sqrts
 @
 \subsubsection{Uniform angular distribution}
 These procedures implement the uniform angular distribution, generated
 from two parameters $x_1$ and $x_2$:
 \begin{equation}
   \cos\theta = 1 - 2x_1, \qquad \phi = 2\pi x_2
 \end{equation}
 We generate a rotation (Lorentz transformation) which rotates the
 positive $z$ axis into this point on the unit sphere.  This rotation
 is applied to the [[p]] momenta, which are assumed to be
 back-to-back, on-shell, and with the correct mass.
 
 We do not compute a Jacobian (constant).  The uniform distribution is
 assumed to be normalized.
 <<PHS base: public>>=
   public :: compute_kinematics_solid_angle
 <<PHS base: procedures>>=
   subroutine compute_kinematics_solid_angle (p, q, x)
     type(vector4_t), dimension(2), intent(in) :: p
     type(vector4_t), dimension(2), intent(out) :: q
     real(default), dimension(2), intent(in) :: x
     real(default) :: ct, st, phi
     type(lorentz_transformation_t) :: rot
     integer :: i
     ct = 1 - 2*x(1)
     st = sqrt (1 - ct**2)
     phi = twopi * x(2)
     rot = rotation (phi, 3) * rotation (ct, st, 2)
     do i = 1, 2
        q(i) = rot * p(i)
     end do
   end subroutine compute_kinematics_solid_angle
 
 @ %def compute_kinematics_solid_angle
 @ This is the inverse transformation.  We assume that the outgoing
 momenta are rotated versions of the incoming momenta, back-to-back.
 Thus, we determine the angles from $q(1)$ alone.  [[p]] is unused.
 <<PHS base: public>>=
   public :: inverse_kinematics_solid_angle
 <<PHS base: procedures>>=
   subroutine inverse_kinematics_solid_angle (p, q, x)
     type(vector4_t), dimension(:), intent(in) :: p
     type(vector4_t), dimension(2), intent(in) :: q
     real(default), dimension(2), intent(out) :: x
     real(default) :: ct, phi
     ct = polar_angle_ct (q(1))
     phi = azimuthal_angle (q(1))
     x(1) = (1 - ct) / 2
     x(2) = phi / twopi
   end subroutine inverse_kinematics_solid_angle
 
 @ %def inverse_kinematics_solid_angle
 @
 \subsection{Auxiliary stuff}
 The [[pacify]] subroutine, which is provided by the Lorentz module,
 has the purpose of setting numbers to zero which are (by comparing
 with a [[tolerance]] parameter) considered equivalent with zero.  This
 is useful for numerical checks.
 <<PHS base: public>>=
   public :: pacify
 <<PHS base: interfaces>>=
   interface pacify
      module procedure pacify_phs
   end interface pacify
 
 <<PHS base: procedures>>=
   subroutine pacify_phs (phs)
     class(phs_t), intent(inout) :: phs
     if (phs%p_defined) then
        call pacify (phs%p, 30 * epsilon (1._default) * phs%config%sqrts)
        call pacify (phs%lt_cm_to_lab, 30 * epsilon (1._default))
     end if
     if (phs%q_defined) then
        call pacify (phs%q, 30 * epsilon (1._default) * phs%config%sqrts)
     end if
   end subroutine pacify_phs
 
 @ %def pacify
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[phs_base_ut.f90]]>>=
 <<File header>>
 
 module phs_base_ut
   use unit_tests
   use phs_base_uti
 
 <<Standard module head>>
 
 <<PHS base: public test>>
 
 <<PHS base: public test auxiliary>>
 
 contains
 
 <<PHS base: test driver>>
 
 end module phs_base_ut
 @ %def phs_base_ut
 @
 <<[[phs_base_uti.f90]]>>=
 <<File header>>
 
 module phs_base_uti
 
 <<Use kinds>>
 <<Use strings>>
   use diagnostics
   use io_units
   use format_defs, only: FMT_19
   use physics_defs, only: BORN
   use lorentz
   use flavors
   use model_data
   use process_constants
 
   use phs_base
 
 <<Standard module head>>
 
 <<PHS base: public test auxiliary>>
 
 <<PHS base: test declarations>>
 
 <<PHS base: test types>>
 
 contains
 
 <<PHS base: tests>>
 
 <<PHS base: test auxiliary>>
 
 end module phs_base_uti
 @ %def phs_base_ut
 @ API: driver for the unit tests below.
 <<PHS base: public test>>=
   public :: phs_base_test
 <<PHS base: test driver>>=
   subroutine phs_base_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS base: execute tests>>
   end subroutine phs_base_test
 
 @ %def phs_base_test
 @
 \subsubsection{Test process data}
 We provide a procedure that initializes a test case for the process
 constants.  This set of process data contains just the minimal
 contents that we need for the phase space.  The rest is left
 uninitialized.
 <<PHS base: public test auxiliary>>=
   public :: init_test_process_data
 <<PHS base: test auxiliary>>=
   subroutine init_test_process_data (id, data)
     type(process_constants_t), intent(out) :: data
     type(string_t), intent(in), optional :: id
     if (present (id)) then
        data%id = id
     else
        data%id = "testproc"
     end if
     data%model_name = "Test"
     data%n_in = 2
     data%n_out = 2
     data%n_flv = 1
     allocate (data%flv_state (data%n_in + data%n_out, data%n_flv))
     data%flv_state = 25
   end subroutine init_test_process_data
 
 @ %def init_test_process_data
 @ This is the variant for a decay process.
 <<PHS base: public test auxiliary>>=
   public :: init_test_decay_data
 <<PHS base: test auxiliary>>=
   subroutine init_test_decay_data (id, data)
     type(process_constants_t), intent(out) :: data
     type(string_t), intent(in), optional :: id
     if (present (id)) then
        data%id = id
     else
        data%id = "testproc"
     end if
     data%model_name = "Test"
     data%n_in = 1
     data%n_out = 2
     data%n_flv = 1
     allocate (data%flv_state (data%n_in + data%n_out, data%n_flv))
     data%flv_state(:,1) = [25, 6, -6]
   end subroutine init_test_decay_data
 
 @ %def init_test_decay_data
 @
 \subsubsection{Test kinematics configuration}
 This is a trivial implementation of the [[phs_config_t]] configuration object.
 <<PHS base: public test auxiliary>>=
   public :: phs_test_config_t
 <<PHS base: test types>>=
   type, extends (phs_config_t) :: phs_test_config_t
      logical :: create_equivalences = .false.
    contains
      procedure :: final => phs_test_config_final
      procedure :: write => phs_test_config_write
      procedure :: configure => phs_test_config_configure
      procedure :: startup_message => phs_test_config_startup_message
      procedure, nopass :: allocate_instance => phs_test_config_allocate_instance
   end type phs_test_config_t
 
 @ %def phs_test_config_t
 @ The finalizer is empty.
 <<PHS base: test auxiliary>>=
   subroutine phs_test_config_final (object)
     class(phs_test_config_t), intent(inout) :: object
   end subroutine phs_test_config_final
 
 @ %def phs_test_config_final
 @ The [[cm_frame]] parameter is not tested here; we defer this to the
 [[phs_single]] implementation.
 <<PHS base: test auxiliary>>=
   subroutine phs_test_config_write (object, unit, include_id)
     class(phs_test_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: include_id
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Partonic phase-space configuration:"
     call object%base_write (unit)
   end subroutine phs_test_config_write
 
   subroutine phs_test_config_configure (phs_config, sqrts, &
        sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, &
        ignore_mismatch, nlo_type, subdir)
     class(phs_test_config_t), intent(inout) :: phs_config
     real(default), intent(in) :: sqrts
     logical, intent(in), optional :: sqrts_fixed
     logical, intent(in), optional :: cm_frame
     logical, intent(in), optional :: azimuthal_dependence
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     integer, intent(in), optional :: nlo_type
     type(string_t), intent(in), optional :: subdir
     phs_config%n_channel = 2
     phs_config%n_par = 2
     phs_config%sqrts = sqrts
     if (.not. present (nlo_type)) &
       phs_config%nlo_type = BORN
     if (present (sqrts_fixed)) then
        phs_config%sqrts_fixed = sqrts_fixed
     end if
     if (present (cm_frame)) then
        phs_config%cm_frame = cm_frame
     end if
     if (present (azimuthal_dependence)) then
        phs_config%azimuthal_dependence = azimuthal_dependence
     end if
     if (allocated (phs_config%channel))  deallocate (phs_config%channel)
     allocate (phs_config%channel (phs_config%n_channel))
     if (phs_config%create_equivalences) then
        call setup_test_equivalences (phs_config)
        call setup_test_channel_props (phs_config)
     end if
     call phs_config%compute_md5sum ()
   end subroutine phs_test_config_configure
 
 @ %def phs_test_config_write
 @ %def phs_test_config_configure
 @ If requested, we make up an arbitrary set of equivalences.
 <<PHS base: test auxiliary>>=
   subroutine setup_test_equivalences (phs_config)
     class(phs_test_config_t), intent(inout) :: phs_config
     integer :: i
     associate (channel => phs_config%channel(1))
       allocate (channel%eq (2))
       do i = 1, size (channel%eq)
          call channel%eq(i)%init (phs_config%n_par)
       end do
       associate (eq => channel%eq(1))
         eq%c = 1;  eq%perm = [1, 2];  eq%mode = [EQ_IDENTITY, EQ_SYMMETRIC]
       end associate
       associate (eq => channel%eq(2))
         eq%c = 2;  eq%perm = [2, 1];  eq%mode = [EQ_INVARIANT, EQ_IDENTITY]
       end associate
     end associate
   end subroutine setup_test_equivalences
 
 @ %def setup_test_equivalences
 @ Ditto, for channel properties.
 <<PHS base: test auxiliary>>=
   subroutine setup_test_channel_props (phs_config)
     class(phs_test_config_t), intent(inout) :: phs_config
     associate (channel => phs_config%channel(2))
       call channel%set_resonant (140._default, 3.1415_default)
     end associate
   end subroutine setup_test_channel_props
 
 @ %def setup_test_channel_props
 @ Startup message
 <<PHS base: test auxiliary>>=
   subroutine phs_test_config_startup_message (phs_config, unit)
     class(phs_test_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     call phs_config%base_startup_message (unit)
     write (msg_buffer, "(A)") "Phase space: Test"
     call msg_message (unit = unit)
   end subroutine phs_test_config_startup_message
 
 @ %def phs_test_config_startup_message
 @ The instance type that matches [[phs_test_config_t]] is [[phs_test_t]].
 <<PHS base: test auxiliary>>=
   subroutine phs_test_config_allocate_instance (phs)
     class(phs_t), intent(inout), pointer :: phs
     allocate (phs_test_t :: phs)
   end subroutine phs_test_config_allocate_instance
 
 @ %def phs_test_config_allocate_instance
 @
 \subsubsection{Test kinematics implementation}
 This implementation of kinematics generates a simple two-particle
 configuration from the incoming momenta.  The incoming momenta must be
 in the c.m.\ system, all masses equal.
 
 There are two channels: one generates $\cos\theta$ and $\phi$
 uniformly, in the other channel we map the $r_1$ parameter which
 belongs to $\cos\theta$.
 
 We should store the mass parameter that we need.
 <<PHS base: public test auxiliary>>=
   public :: phs_test_t
 <<PHS base: test types>>=
   type, extends (phs_t) :: phs_test_t
      real(default) :: m = 0
      real(default), dimension(:), allocatable :: x
    contains
    <<PHS base: phs test: TBP>>
   end type phs_test_t
 
 @ %def phs_test_t
 @ Output.  The specific data are displayed only if [[verbose]] is set.
 <<PHS base: phs test: TBP>>=
   procedure :: write => phs_test_write
 <<PHS base: test auxiliary>>=
   subroutine phs_test_write (object, unit, verbose)
     class(phs_test_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     logical :: verb
     u = given_output_unit (unit)
     verb = .false.;  if (present (verbose))  verb = verbose
     if (verb) then
        write (u, "(1x,A)")  "Partonic phase space: data"
        write (u, "(3x,A," // FMT_19 // ")")  "m = ", object%m
     end if
     call object%base_write (u)
   end subroutine phs_test_write
 
 @ %def phs_test_write
 @ The finalizer is empty.
 <<PHS base: phs test: TBP>>=
   procedure :: final => phs_test_final
 <<PHS base: test auxiliary>>=
   subroutine phs_test_final (object)
     class(phs_test_t), intent(inout) :: object
   end subroutine phs_test_final
 
 @ %def phs_test_final
 @ Initialization: set the mass value.
 <<PHS base: phs test: TBP>>=
   procedure :: init => phs_test_init
 <<PHS base: test auxiliary>>=
   subroutine phs_test_init (phs, phs_config)
     class(phs_test_t), intent(out) :: phs
     class(phs_config_t), intent(in), target :: phs_config
     call phs%base_init (phs_config)
     phs%m = phs%config%flv(1,1)%get_mass ()
     allocate (phs%x (phs_config%n_par), source = 0._default)
   end subroutine phs_test_init
 
 @ %def phs_test_init
 @ Evaluation.  In channel 1, we uniformly generate $\cos\theta$ and
 $\phi$, with Jacobian normalized to one.  In channel 2, we prepend a
 mapping $r_1 \to r_1^(1/3)$ with Jacobian $f=3r_1^2$.
 
 The component [[x]] is allocated in the first subroutine, used and deallocated
 in the second one.
 <<PHS base: phs test: TBP>>=
   procedure :: evaluate_selected_channel => phs_test_evaluate_selected_channel
   procedure :: evaluate_other_channels => phs_test_evaluate_other_channels
 <<PHS base: test auxiliary>>=
   subroutine phs_test_evaluate_selected_channel (phs, c_in, r_in)
     class(phs_test_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     real(default), intent(in), dimension(:) :: r_in
     if (phs%p_defined) then
        call phs%select_channel (c_in)
        phs%r(:,c_in) = r_in
        select case (c_in)
        case (1)
           phs%x = r_in
        case (2)
           phs%x(1) = r_in(1) ** (1 / 3._default)
           phs%x(2) = r_in(2)
        end select
        call compute_kinematics_solid_angle (phs%p, phs%q, phs%x)
        phs%volume = 1
        phs%q_defined = .true.
     end if
   end subroutine phs_test_evaluate_selected_channel
 
   subroutine phs_test_evaluate_other_channels (phs, c_in)
     class(phs_test_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     integer :: c, n_channel
     if (phs%p_defined) then
        n_channel = phs%config%n_channel
        do c = 1, n_channel
           if (c /= c_in) then
              call inverse_kinematics_solid_angle (phs%p, phs%q, phs%x)
              select case (c)
              case (1)
                 phs%r(:,c) = phs%x
              case (2)
                 phs%r(1,c) = phs%x(1) ** 3
                 phs%r(2,c) = phs%x(2)
              end select
           end if
        end do
        phs%f(1) = 1
        if (phs%r(1,2) /= 0) then
           phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default))
        else
           phs%f(2) = 0
        end if
        phs%r_defined = .true.
     end if
   end subroutine phs_test_evaluate_other_channels
 
 @ %def phs_test_evaluate_selected_channels
 @ %def phs_test_evaluate_other_channels
 @ Inverse evaluation.
 <<PHS base: phs test: TBP>>=
   procedure :: inverse => phs_test_inverse
 <<PHS base: test auxiliary>>=
   subroutine phs_test_inverse (phs)
     class(phs_test_t), intent(inout) :: phs
     integer :: c, n_channel
     real(default), dimension(:), allocatable :: x
     if (phs%p_defined .and. phs%q_defined) then
        call phs%select_channel ()
        n_channel = phs%config%n_channel
        allocate (x (phs%config%n_par))
        do c = 1, n_channel
           call inverse_kinematics_solid_angle (phs%p, phs%q, x)
           select case (c)
           case (1)
              phs%r(:,c) = x
           case (2)
              phs%r(1,c) = x(1) ** 3
              phs%r(2,c) = x(2)
           end select
        end do
        phs%f(1) = 1
        if (phs%r(1,2) /= 0) then
           phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default))
        else
           phs%f(2) = 0
        end if
        phs%volume = 1
        phs%r_defined = .true.
     end if
   end subroutine phs_test_inverse
 
 @ %def phs_test_inverse
 @
 \subsubsection{Phase-space configuration data}
 Construct and display a test phase-space configuration object.
 <<PHS base: execute tests>>=
   call test (phs_base_1, "phs_base_1", &
        "phase-space configuration", &
        u, results)
 <<PHS base: test declarations>>=
   public :: phs_base_1
 <<PHS base: tests>>=
   subroutine phs_base_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable :: phs_data
 
     write (u, "(A)")  "* Test output: phs_base_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test phase-space configuration data"
     write (u, "(A)")
 
     call model%init_test ()
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_base_1"), process_data)
 
     allocate (phs_test_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     call phs_data%write (u)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_base_1"
 
   end subroutine phs_base_1
 
 @ %def phs_base_1
 @
 \subsubsection{Phase space evaluation}
 Compute kinematics for given parameters, also invert the calculation.
 <<PHS base: execute tests>>=
   call test (phs_base_2, "phs_base_2", &
        "phase-space evaluation", &
        u, results)
 <<PHS base: test declarations>>=
   public :: phs_base_2
 <<PHS base: tests>>=
   subroutine phs_base_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(process_constants_t) :: process_data
     real(default) :: sqrts, E
     class(phs_config_t), allocatable, target :: phs_data
     class(phs_t), pointer :: phs => null ()
     type(vector4_t), dimension(2) :: p, q
 
     write (u, "(A)")  "* Test output: phs_base_2"
     write (u, "(A)")  "*   Purpose: test simple two-channel phase space"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_base_2"), process_data)
 
     allocate (phs_test_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     select type (phs)
     type is (phs_test_t)
        call phs%init (phs_data)
     end select
 
     call phs%write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming momenta"
     write (u, "(A)")
 
     E = sqrts / 2
     p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point in channel 1 &
          &for x = 0.5, 0.125"
     write (u, "(A)")
 
     call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
     call phs%evaluate_other_channels (1)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point in channel 2 &
          &for x = 0.125, 0.125"
     write (u, "(A)")
 
     call phs%evaluate_selected_channel (2, [0.125_default, 0.125_default])
     call phs%evaluate_other_channels (2)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     deallocate (phs)
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     sqrts = 1000._default
     select type (phs_data)
     type is (phs_test_config_t)
        call phs_data%configure (sqrts)
     end select
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_base_2"
 
   end subroutine phs_base_2
 
 @ %def phs_base_2
 @
 \subsubsection{Phase-space equivalences}
 Construct a test phase-space configuration which contains channel
 equivalences.
 <<PHS base: execute tests>>=
   call test (phs_base_3, "phs_base_3", &
        "channel equivalences", &
        u, results)
 <<PHS base: test declarations>>=
   public :: phs_base_3
 <<PHS base: tests>>=
   subroutine phs_base_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable :: phs_data
 
     write (u, "(A)")  "* Test output: phs_base_3"
     write (u, "(A)")  "*   Purpose: construct phase-space configuration data &
          &with equivalences"
     write (u, "(A)")
 
     call model%init_test ()
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_base_3"), process_data)
 
     allocate (phs_test_config_t :: phs_data)
     call phs_data%init (process_data, model)
     select type (phs_data)
     type is (phs_test_config_t)
        phs_data%create_equivalences = .true.
     end select
 
     call phs_data%configure (1000._default)
     call phs_data%write (u)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_base_3"
 
   end subroutine phs_base_3
 
 @ %def phs_base_3
 @
 \subsubsection{MD5 sum checks}
 Construct a test phase-space configuration, compute and compare MD5 sums.
 <<PHS base: execute tests>>=
   call test (phs_base_4, "phs_base_4", &
        "MD5 sum", &
        u, results)
 <<PHS base: test declarations>>=
   public :: phs_base_4
 <<PHS base: tests>>=
   subroutine phs_base_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable :: phs_data
 
     write (u, "(A)")  "* Test output: phs_base_4"
     write (u, "(A)")  "*   Purpose: compute and compare MD5 sums"
     write (u, "(A)")
 
     call model%init_test ()
 
     write (u, "(A)")  "* Model parameters"
     write (u, "(A)")
 
     call model%write (unit = u, &
          show_parameters = .true., &
          show_particles = .false., show_vertices = .false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_base_4"), process_data)
     process_data%md5sum = "test_process_data_m6sum_12345678"
 
     allocate (phs_test_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     call phs_data%compute_md5sum ()
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Modify model parameter"
     write (u, "(A)")
 
     call model%set_par (var_str ("ms"), 100._default)
     call model%write (show_parameters = .true., &
          show_particles = .false., show_vertices = .false.)
 
     write (u, "(A)")
     write (u, "(A)")  "* PHS configuration"
     write (u, "(A)")
 
     call phs_data%compute_md5sum ()
     call phs_data%write (u)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_base_4"
 
   end subroutine phs_base_4
 
 @ %def phs_base_4
 @
 \subsubsection{Phase-space channel collection}
 Set up an array of various phase-space channels and collect them in a list.
 <<PHS base: execute tests>>=
   call test (phs_base_5, "phs_base_5", &
        "channel collection", &
        u, results)
 <<PHS base: test declarations>>=
   public :: phs_base_5
 <<PHS base: tests>>=
   subroutine phs_base_5 (u)
     integer, intent(in) :: u
     type(phs_channel_t), dimension(:), allocatable :: channel
     type(phs_channel_collection_t) :: coll
     integer :: i, n
 
     write (u, "(A)")  "* Test output: phs_base_5"
     write (u, "(A)")  "*   Purpose: collect channel properties"
     write (u, "(A)")
 
     write (u, "(A)")  "* Set up an array of channels"
     write (u, "(A)")
 
     n = 6
 
     allocate (channel (n))
     call channel(2)%set_resonant (75._default, 3._default)
     call channel(4)%set_resonant (130._default, 1._default)
     call channel(5)%set_resonant (75._default, 3._default)
     call channel(6)%set_on_shell (33._default)
 
     do i = 1, n
        write (u, "(1x,I0)", advance="no")  i
        call channel(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Collect distinct properties"
     write (u, "(A)")
 
     do i = 1, n
        call coll%push (channel(i))
     end do
 
     write (u, "(1x,A,I0)")  "n = ", coll%get_n ()
     write (u, "(A)")
 
     call coll%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Channel array with collection index assigned"
     write (u, "(A)")
 
     do i = 1, n
        write (u, "(1x,I0)", advance="no")  i
        call channel(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call coll%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_base_5"
 
   end subroutine phs_base_5
 
 @ %def phs_base_5
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \clearpage
 \section{Dummy phase space}
 
 This module implements a dummy phase space module for cases where the
 program structure demands the existence of a phase-space module, but
 no phase space integration is performed.
 
 <<[[phs_none.f90]]>>=
 <<File header>>
 
 module phs_none
 
 <<Use kinds>>
 <<Use strings>>
   use io_units, only: given_output_unit
   use diagnostics, only: msg_message, msg_fatal
   use phs_base, only: phs_config_t, phs_t
 
 <<Standard module head>>
 
 <<PHS none: public>>
 
 <<PHS none: types>>
 
 contains
 
 <<PHS none: procedures>>
 
 end module phs_none
 @ %def phs_none
 @
 \subsection{Configuration}
 Nothing to configure, but we provide the type and methods.
 <<PHS none: public>>=
   public :: phs_none_config_t
 <<PHS none: types>>=
   type, extends (phs_config_t) :: phs_none_config_t
   contains
   <<PHS none: phs none config: TBP>>
   end type phs_none_config_t
 
 @ %def phs_none_config_t
 @ The finalizer is empty.
 <<PHS none: phs none config: TBP>>=
   procedure :: final => phs_none_config_final
 <<PHS none: procedures>>=
   subroutine phs_none_config_final (object)
     class(phs_none_config_t), intent(inout) :: object
   end subroutine phs_none_config_final
 
 @ %def phs_none_final
 @ Output.  No contents, just an informative line.
 <<PHS none: phs none config: TBP>>=
   procedure :: write => phs_none_config_write
 <<PHS none: procedures>>=
   subroutine phs_none_config_write (object, unit, include_id)
     class(phs_none_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: include_id
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Partonic phase-space configuration: non-functional dummy"
   end subroutine phs_none_config_write
 
 @ %def phs_none_config_write
 @ Configuration: we have to implement this method, but it obviously does nothing.
 <<PHS none: phs none config: TBP>>=
   procedure :: configure => phs_none_config_configure
 <<PHS none: procedures>>=
   subroutine phs_none_config_configure (phs_config, sqrts, &
        sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, &
        nlo_type, subdir)
     class(phs_none_config_t), intent(inout) :: phs_config
     real(default), intent(in) :: sqrts
     logical, intent(in), optional :: sqrts_fixed
     logical, intent(in), optional :: cm_frame
     logical, intent(in), optional :: azimuthal_dependence
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     integer, intent(in), optional :: nlo_type
     type(string_t), intent(in), optional :: subdir
   end subroutine phs_none_config_configure
 
 @ %def phs_none_config_configure
 @ Startup message, after configuration is complete.
 <<PHS none: phs none config: TBP>>=
   procedure :: startup_message => phs_none_config_startup_message
 <<PHS none: procedures>>=
   subroutine phs_none_config_startup_message (phs_config, unit)
     class(phs_none_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     call msg_message ("Phase space: none")
   end subroutine phs_none_config_startup_message
 
 @ %def phs_none_config_startup_message
 @ Allocate an instance: the actual phase-space object.
 <<PHS none: phs none config: TBP>>=
   procedure, nopass :: allocate_instance => phs_none_config_allocate_instance
 <<PHS none: procedures>>=
   subroutine phs_none_config_allocate_instance (phs)
     class(phs_t), intent(inout), pointer :: phs
     allocate (phs_none_t :: phs)
   end subroutine phs_none_config_allocate_instance
 
 @ %def phs_none_config_allocate_instance
 @
 \subsection{Kinematics implementation}
 This is considered as empty, but we have to implement the minimal set of methods.
 <<PHS none: public>>=
   public :: phs_none_t
 <<PHS none: types>>=
   type, extends (phs_t) :: phs_none_t
    contains
    <<PHS none: phs none: TBP>>
   end type phs_none_t
 
 @ %def phs_none_t
 @ Output.
 <<PHS none: phs none: TBP>>=
   procedure :: write => phs_none_write
 <<PHS none: procedures>>=
   subroutine phs_none_write (object, unit, verbose)
     class(phs_none_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     write (u, "(A)")  "Partonic phase space: none"
   end subroutine phs_none_write
 
 @ %def phs_none_write
 @ The finalizer is empty.
 <<PHS none: phs none: TBP>>=
   procedure :: final => phs_none_final
 <<PHS none: procedures>>=
   subroutine phs_none_final (object)
     class(phs_none_t), intent(inout) :: object
   end subroutine phs_none_final
 
 @ %def phs_none_final
 @ Initialization, trivial.
 <<PHS none: phs none: TBP>>=
   procedure :: init => phs_none_init
 <<PHS none: procedures>>=
   subroutine phs_none_init (phs, phs_config)
     class(phs_none_t), intent(out) :: phs
     class(phs_config_t), intent(in), target :: phs_config
     call phs%base_init (phs_config)
   end subroutine phs_none_init
 
 @ %def phs_none_init
 @ Evaluation.  This must not be called at all.
 <<PHS none: phs none: TBP>>=
   procedure :: evaluate_selected_channel => phs_none_evaluate_selected_channel
   procedure :: evaluate_other_channels => phs_none_evaluate_other_channels
 <<PHS none: procedures>>=
   subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in)
     class(phs_none_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     real(default), intent(in), dimension(:) :: r_in
     call msg_fatal ("Phase space: attempt to evaluate with the 'phs_none' method")
   end subroutine phs_none_evaluate_selected_channel
 
   subroutine phs_none_evaluate_other_channels (phs, c_in)
     class(phs_none_t), intent(inout) :: phs
     integer, intent(in) :: c_in
   end subroutine phs_none_evaluate_other_channels
 
 @ %def phs_none_evaluate_selected_channel
 @ %def phs_none_evaluate_other_channels
 @ Inverse evaluation, likewise.
 <<PHS none: phs none: TBP>>=
   procedure :: inverse => phs_none_inverse
 <<PHS none: procedures>>=
   subroutine phs_none_inverse (phs)
     class(phs_none_t), intent(inout) :: phs
     call msg_fatal ("Phase space: attempt to evaluate inverse with the 'phs_none' method")
   end subroutine phs_none_inverse
 
 @ %def phs_none_inverse
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[phs_none_ut.f90]]>>=
 <<File header>>
 
 module phs_none_ut
   use unit_tests
   use phs_none_uti
 
 <<Standard module head>>
 
 <<PHS none: public test>>
 
 contains
 
 <<PHS none: test driver>>
 
 end module phs_none_ut
 @ %def phs_none_ut
 @
 <<[[phs_none_uti.f90]]>>=
 <<File header>>
 
 module phs_none_uti
 
 <<Use kinds>>
 <<Use strings>>
   use flavors
   use lorentz
   use model_data
   use process_constants
   use phs_base
 
   use phs_none
 
   use phs_base_ut, only: init_test_process_data, init_test_decay_data
 
 <<Standard module head>>
 
 <<PHS none: test declarations>>
 
 contains
 
 <<PHS none: tests>>
 
 end module phs_none_uti
 @ %def phs_none_ut
 @ API: driver for the unit tests below.
 <<PHS none: public test>>=
   public :: phs_none_test
 <<PHS none: test driver>>=
   subroutine phs_none_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS none: execute tests>>
   end subroutine phs_none_test
 
 @ %def phs_none_test
 @
 \subsubsection{Phase-space configuration data}
 Construct and display a test phase-space configuration object.  Also
 check the [[azimuthal_dependence]] flag.
 <<PHS none: execute tests>>=
   call test (phs_none_1, "phs_none_1", &
        "phase-space configuration dummy", &
        u, results)
 <<PHS none: test declarations>>=
   public :: phs_none_1
 <<PHS none: tests>>=
   subroutine phs_none_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable :: phs_data
     real(default) :: sqrts
 
     write (u, "(A)")  "* Test output: phs_none_1"
     write (u, "(A)")  "*   Purpose: display &
          &phase-space configuration data"
     write (u, "(A)")
 
     allocate (phs_none_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts, azimuthal_dependence=.false.)
 
     call phs_data%write (u)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_none_1"
 
   end subroutine phs_none_1
 
 @ %def phs_none_1
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \clearpage
 \section{Single-particle phase space}
 
 This module implements the phase space for a single particle, i.e., the solid
 angle, in a straightforward parameterization with a single channel.  The
 phase-space implementation may be used either for $1\to 2$ decays or for $2\to
 2$ scattering processes, so the number of incoming particles is the only free
 parameter in the configuration.  In the latter case, we should restrict its
 use to non-resonant s-channel processes, because there is no mapping of the
 scattering angle.
 
 (We might extend this later to account for generic $2\to 2$ situations, e.g.,
 account for a Coulomb singularity or detect an s-channel resonance structure
 that requires matching structure-function mappings.)
 
 This is derived from the [[phs_test]] implementation in the
 [[phs_base]] module above, even more simplified, but intended for
 actual use.
 <<[[phs_single.f90]]>>=
 <<File header>>
 
 module phs_single
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants
   use numeric_utils
   use diagnostics
   use os_interface
   use lorentz
   use physics_defs
   use model_data
   use flavors
   use process_constants
   use phs_base
 
 <<Standard module head>>
 
 <<PHS single: public>>
 
 <<PHS single: types>>
 
 contains
 
 <<PHS single: procedures>>
 
 end module phs_single
 @ %def phs_single
 @
 \subsection{Configuration}
 <<PHS single: public>>=
   public :: phs_single_config_t
 <<PHS single: types>>=
   type, extends (phs_config_t) :: phs_single_config_t
   contains
   <<PHS single: phs single config: TBP>>
   end type phs_single_config_t
 
 @ %def phs_single_config_t
 @ The finalizer is empty.
 <<PHS single: phs single config: TBP>>=
   procedure :: final => phs_single_config_final
 <<PHS single: procedures>>=
   subroutine phs_single_config_final (object)
     class(phs_single_config_t), intent(inout) :: object
   end subroutine phs_single_config_final
 
 @ %def phs_single_final
 @ Output.
 <<PHS single: phs single config: TBP>>=
   procedure :: write => phs_single_config_write
 <<PHS single: procedures>>=
   subroutine phs_single_config_write (object, unit, include_id)
     class(phs_single_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: include_id
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Partonic phase-space configuration (single-particle):"
     call object%base_write (unit)
   end subroutine phs_single_config_write
 
 @ %def phs_single_config_write
 @ Configuration: there is only one channel and two parameters.  The
 second parameter is the azimuthal angle, which may be a flat dimension.
 <<PHS single: phs single config: TBP>>=
   procedure :: configure => phs_single_config_configure
 <<PHS single: procedures>>=
   subroutine phs_single_config_configure (phs_config, sqrts, &
        sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, &
        nlo_type, subdir)
     class(phs_single_config_t), intent(inout) :: phs_config
     real(default), intent(in) :: sqrts
     logical, intent(in), optional :: sqrts_fixed
     logical, intent(in), optional :: cm_frame
     logical, intent(in), optional :: azimuthal_dependence
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     integer, intent(in), optional :: nlo_type
     type(string_t), intent(in), optional :: subdir
     if (.not. present (nlo_type)) &
       phs_config%nlo_type = BORN
     if (phs_config%n_out == 2) then
        phs_config%n_channel = 1
        phs_config%n_par = 2
        phs_config%sqrts = sqrts
        if (present (sqrts_fixed))  phs_config%sqrts_fixed = sqrts_fixed
        if (present (cm_frame))  phs_config%cm_frame = cm_frame
        if (present (azimuthal_dependence)) then
           phs_config%azimuthal_dependence = azimuthal_dependence
           if (.not. azimuthal_dependence) then
              allocate (phs_config%dim_flat (1))
              phs_config%dim_flat(1) = 2
           end if
        end if
        if (allocated (phs_config%channel))  deallocate (phs_config%channel)
        allocate (phs_config%channel (1))
        call phs_config%compute_md5sum ()
     else
        call msg_fatal ("Single-particle phase space requires n_out = 2")
     end if
   end subroutine phs_single_config_configure
 
 @ %def phs_single_config_configure
 @ Startup message, after configuration is complete.
 <<PHS single: phs single config: TBP>>=
   procedure :: startup_message => phs_single_config_startup_message
 <<PHS single: procedures>>=
   subroutine phs_single_config_startup_message (phs_config, unit)
     class(phs_single_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     call phs_config%base_startup_message (unit)
     write (msg_buffer, "(A,2(1x,I0,1x,A))") &
          "Phase space: single-particle"
     call msg_message (unit = unit)
   end subroutine phs_single_config_startup_message
 
 @ %def phs_single_config_startup_message
 @ Allocate an instance: the actual phase-space object.
 <<PHS single: phs single config: TBP>>=
   procedure, nopass :: allocate_instance => phs_single_config_allocate_instance
 <<PHS single: procedures>>=
   subroutine phs_single_config_allocate_instance (phs)
     class(phs_t), intent(inout), pointer :: phs
     allocate (phs_single_t :: phs)
   end subroutine phs_single_config_allocate_instance
 
 @ %def phs_single_config_allocate_instance
 @
 \subsection{Kinematics implementation}
 We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle.
 
 Note: The incoming momenta must be in the c.m. system.
 <<PHS single: public>>=
   public :: phs_single_t
 <<PHS single: types>>=
   type, extends (phs_t) :: phs_single_t
    contains
    <<PHS single: phs single: TBP>>
   end type phs_single_t
 
 @ %def phs_single_t
 @ Output.  The [[verbose]] setting is irrelevant, we just display the contents
 of the base object.
 <<PHS single: phs single: TBP>>=
   procedure :: write => phs_single_write
 <<PHS single: procedures>>=
   subroutine phs_single_write (object, unit, verbose)
     class(phs_single_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (u)
   end subroutine phs_single_write
 
 @ %def phs_single_write
 @ The finalizer is empty.
 <<PHS single: phs single: TBP>>=
   procedure :: final => phs_single_final
 <<PHS single: procedures>>=
   subroutine phs_single_final (object)
     class(phs_single_t), intent(inout) :: object
   end subroutine phs_single_final
 
 @ %def phs_single_final
 @ Initialization.  We allocate arrays ([[base_init]]) and adjust the
 phase-space volume.  The massless two-particle phase space volume is
 \begin{equation}
   \Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5}
 \end{equation}
 For a decay with nonvanishing masses ($m_3$, $m_4$), there is a correction
 factor
 \begin{equation}
   \Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s}
   \lambda^{1/2}(\hat s, m_3^2, m_4^2).
 \end{equation}
 For a scattering process with nonvanishing masses, the correction
 factor is
 \begin{equation}
   \Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s ^ 2}
   \lambda^{1/2}(\hat s, m_1^2, m_2^2)\,
   \lambda^{1/2}(\hat s, m_3^2, m_4^2).
 \end{equation}
 If the energy is fixed, this is constant.  Otherwise, we have to account for
 varying $\hat s$.
 <<PHS single: phs single: TBP>>=
   procedure :: init => phs_single_init
 <<PHS single: procedures>>=
   subroutine phs_single_init (phs, phs_config)
     class(phs_single_t), intent(out) :: phs
     class(phs_config_t), intent(in), target :: phs_config
     call phs%base_init (phs_config)
     phs%volume = 1 / (4 * twopi5)
     call phs%compute_factor ()
   end subroutine phs_single_init
 
 @ %def phs_single_init
 @ Compute the correction factor for nonzero masses.  We do this during
 initialization (when the incoming momenta [[p]] are undefined), unless
 [[sqrts]] is variable.  We do this again once for each phase-space point, but
 then we skip the calculation if [[sqrts]] is fixed.
 <<PHS single: phs single: TBP>>=
   procedure :: compute_factor => phs_single_compute_factor
 <<PHS single: procedures>>=
   subroutine phs_single_compute_factor (phs)
     class(phs_single_t), intent(inout) :: phs
     real(default) :: s_hat
     select case (phs%config%n_in)
     case (1)
        if (.not. phs%p_defined) then
           if (sum (phs%m_out) < phs%m_in(1)) then
              s_hat = phs%m_in(1) ** 2
              phs%f(1) = 1 / s_hat &
                   * sqrt (lambda (s_hat, phs%m_out(1)**2, phs%m_out(2)**2))
           else
              print *, "m_in  = ", phs%m_in
              print *, "m_out = ", phs%m_out
              call msg_fatal ("Decay is kinematically forbidden")
           end if
        end if
     case (2)
        if (phs%config%sqrts_fixed) then
           if (phs%p_defined)  return
           s_hat = phs%config%sqrts ** 2
        else
           if (.not. phs%p_defined)  return
           s_hat = sum (phs%p) ** 2
        end if
        if (sum (phs%m_in)**2 < s_hat .and. sum (phs%m_out)**2 < s_hat) then
           phs%f(1) = 1 / s_hat * &
                ( lambda (s_hat, phs%m_in (1)**2, phs%m_in (2)**2)   &
                * lambda (s_hat, phs%m_out(1)**2, phs%m_out(2)**2) ) &
                ** 0.25_default
        else
           phs%f(1) = 0
        end if
     end select
   end subroutine phs_single_compute_factor
 
 @ %def phs_single_compute_factor
 @ Evaluation.  We uniformly generate $\cos\theta$ and
 $\phi$, with Jacobian normalized to one.
 
 There is only a single channel, so the second subroutine does nothing.
 
 Note: the current implementation works for elastic scattering only.
 <<PHS single: phs single: TBP>>=
   procedure :: evaluate_selected_channel => phs_single_evaluate_selected_channel
   procedure :: evaluate_other_channels => phs_single_evaluate_other_channels
 <<PHS single: procedures>>=
   subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in)
     class(phs_single_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     real(default), intent(in), dimension(:) :: r_in
     if (phs%p_defined) then
        call phs%select_channel (c_in)
        phs%r(:,c_in) = r_in
        select case (phs%config%n_in)
        case (2)
           if (all (phs%m_in == phs%m_out)) then
              call compute_kinematics_solid_angle (phs%p, phs%q, r_in)
           else
              call msg_bug ("PHS single: inelastic scattering not implemented")
           end if
        case (1)
           call compute_kinematics_solid_angle (phs%decay_p (), phs%q, r_in)
        end select
        call phs%compute_factor ()
        phs%q_defined = .true.
        phs%r_defined = .true.
     end if
   end subroutine phs_single_evaluate_selected_channel
 
   subroutine phs_single_evaluate_other_channels (phs, c_in)
     class(phs_single_t), intent(inout) :: phs
     integer, intent(in) :: c_in
   end subroutine phs_single_evaluate_other_channels
 
 @ %def phs_single_evaluate_selected_channel
 @ %def phs_single_evaluate_other_channels
 @ Auxiliary: split a decaying particle at rest into the decay products,
 aligned along the $z$ axis.
 <<PHS single: phs single: TBP>>=
   procedure :: decay_p => phs_single_decay_p
 <<PHS single: procedures>>=
   function phs_single_decay_p (phs) result (p)
     class(phs_single_t), intent(in) :: phs
     type(vector4_t), dimension(2) :: p
     real(default) :: k
     real(default), dimension(2) :: E
     k = sqrt (lambda (phs%m_in(1) ** 2, phs%m_out(1) ** 2, phs%m_out(2) ** 2)) &
          / (2 * phs%m_in(1))
     E = sqrt (phs%m_out ** 2 + k ** 2)
     p(1) = vector4_moving (E(1), k, 3)
     p(2) = vector4_moving (E(2),-k, 3)
   end function phs_single_decay_p
 
 @ %def phs_single_decay_p
 @ Inverse evaluation.
 <<PHS single: phs single: TBP>>=
   procedure :: inverse => phs_single_inverse
 <<PHS single: procedures>>=
   subroutine phs_single_inverse (phs)
     class(phs_single_t), intent(inout) :: phs
     real(default), dimension(:), allocatable :: x
     if (phs%p_defined .and. phs%q_defined) then
        call phs%select_channel ()
        allocate (x (phs%config%n_par))
        call inverse_kinematics_solid_angle (phs%p, phs%q, x)
        phs%r(:,1) = x
        call phs%compute_factor ()
        phs%r_defined = .true.
     end if
   end subroutine phs_single_inverse
 
 @ %def phs_single_inverse
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[phs_single_ut.f90]]>>=
 <<File header>>
 
 module phs_single_ut
   use unit_tests
   use phs_single_uti
 
 <<Standard module head>>
 
 <<PHS single: public test>>
 
 contains
 
 <<PHS single: test driver>>
 
 end module phs_single_ut
 @ %def phs_single_ut
 @
 <<[[phs_single_uti.f90]]>>=
 <<File header>>
 
 module phs_single_uti
 
 <<Use kinds>>
 <<Use strings>>
   use flavors
   use lorentz
   use model_data
   use process_constants
   use phs_base
 
   use phs_single
 
   use phs_base_ut, only: init_test_process_data, init_test_decay_data
 
 <<Standard module head>>
 
 <<PHS single: test declarations>>
 
 contains
 
 <<PHS single: tests>>
 
 end module phs_single_uti
 @ %def phs_single_ut
 @ API: driver for the unit tests below.
 <<PHS single: public test>>=
   public :: phs_single_test
 <<PHS single: test driver>>=
   subroutine phs_single_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS single: execute tests>>
   end subroutine phs_single_test
 
 @ %def phs_single_test
 @
 \subsubsection{Phase-space configuration data}
 Construct and display a test phase-space configuration object.  Also
 check the [[azimuthal_dependence]] flag.
 <<PHS single: execute tests>>=
   call test (phs_single_1, "phs_single_1", &
        "phase-space configuration", &
        u, results)
 <<PHS single: test declarations>>=
   public :: phs_single_1
 <<PHS single: tests>>=
   subroutine phs_single_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable :: phs_data
     real(default) :: sqrts
 
     write (u, "(A)")  "* Test output: phs_single_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &phase-space configuration data"
     write (u, "(A)")
 
     call model%init_test ()
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_single_1"), process_data)
 
     allocate (phs_single_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts, azimuthal_dependence=.false.)
 
     call phs_data%write (u)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_single_1"
 
   end subroutine phs_single_1
 
 @ %def phs_single_1
 @
 \subsubsection{Phase space evaluation}
 Compute kinematics for given parameters, also invert the calculation.
 <<PHS single: execute tests>>=
   call test (phs_single_2, "phs_single_2", &
        "phase-space evaluation", &
        u, results)
 <<PHS single: test declarations>>=
   public :: phs_single_2
 <<PHS single: tests>>=
   subroutine phs_single_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(process_constants_t) :: process_data
     real(default) :: sqrts, E
     class(phs_config_t), allocatable, target :: phs_data
     class(phs_t), pointer :: phs => null ()
     type(vector4_t), dimension(2) :: p, q
 
     write (u, "(A)")  "* Test output: phs_single_2"
     write (u, "(A)")  "*   Purpose: test simple two-channel phase space"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_single_2"), process_data)
 
     allocate (phs_single_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming momenta"
     write (u, "(A)")
 
     E = sqrts / 2
     p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point &
          &for x = 0.5, 0.125"
     write (u, "(A)")
 
     call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
     call phs%evaluate_other_channels (1)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     deallocate (phs)
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_single_2"
 
   end subroutine phs_single_2
 
 @ %def phs_single_2
 @
 \subsubsection{Phase space for non-c.m. system}
 Compute kinematics for given parameters, also invert the calculation.
 Since this will involve cancellations, we call [[pacify]] to eliminate
 numerical noise.
 <<PHS single: execute tests>>=
   call test (phs_single_3, "phs_single_3", &
        "phase-space evaluation in lab frame", &
        u, results)
 <<PHS single: test declarations>>=
   public :: phs_single_3
 <<PHS single: tests>>=
   subroutine phs_single_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(process_constants_t) :: process_data
     real(default) :: sqrts, E
     class(phs_config_t), allocatable, target :: phs_data
     class(phs_t), pointer :: phs => null ()
     type(vector4_t), dimension(2) :: p, q
     type(lorentz_transformation_t) :: lt
 
     write (u, "(A)")  "* Test output: phs_single_3"
     write (u, "(A)")  "*   Purpose: test simple two-channel phase space"
     write (u, "(A)")  "*            without c.m. kinematics assumption"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_single_3"), process_data)
 
     allocate (phs_single_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts, cm_frame=.false., sqrts_fixed=.false.)
 
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming momenta in lab system"
     write (u, "(A)")
 
     lt = boost (0.1_default, 1) * boost (0.3_default, 3)
 
     E = sqrts / 2
     p(1) = lt * vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     p(2) = lt * vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
 
     call vector4_write (p(1), u)
     call vector4_write (p(2), u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point &
          &for x = 0.5, 0.125"
     write (u, "(A)")
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
 
     call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
     call phs%evaluate_other_channels (1)
     call pacify (phs)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract outgoing momenta in lab system"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     call vector4_write (q(1), u)
     call vector4_write (q(2), u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     deallocate (phs)
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call pacify (phs)
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_single_3"
 
   end subroutine phs_single_3
 
 @ %def phs_single_3
 @
 \subsubsection{Decay Phase space evaluation}
 Compute kinematics for given parameters, also invert the calculation.  This
 time, implement a decay process.
 <<PHS single: execute tests>>=
   call test (phs_single_4, "phs_single_4", &
        "decay phase-space evaluation", &
        u, results)
 <<PHS single: test declarations>>=
   public :: phs_single_4
 <<PHS single: tests>>=
   subroutine phs_single_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable, target :: phs_data
     class(phs_t), pointer :: phs => null ()
     type(vector4_t), dimension(1) :: p
     type(vector4_t), dimension(2) :: q
 
     write (u, "(A)")  "* Test output: phs_single_4"
     write (u, "(A)")  "*   Purpose: test simple two-channel phase space"
     write (u, "(A)")
 
     call model%init_test ()
 
     call model%set_par (var_str ("ff"), 0.4_default)
     call model%set_par (var_str ("mf"), &
          model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
     call flv%init (25, model)
 
     write (u, "(A)")  "* Initialize a decay and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_decay_data (var_str ("phs_single_4"), process_data)
 
     allocate (phs_single_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     call phs_data%configure (flv%get_mass ())
 
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming momenta"
     write (u, "(A)")
 
     p(1) = vector4_at_rest (flv%get_mass ())
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point &
          &for x = 0.5, 0.125"
     write (u, "(A)")
 
     call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
     call phs%evaluate_other_channels (1)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     deallocate (phs)
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs_data%configure (flv%get_mass ())
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_single_4"
 
   end subroutine phs_single_4
 
 @ %def phs_single_4
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Flat RAMBO phase space}
 
 This module implements the flat \texttt{RAMBO} phase space for massless and massive particles using the minimal d.o.f $3n - 4$ in a straightforward parameterization with a single channel.
 We generate $n$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_{n} = 0$.
 We let each mass system decay $1 \rightarrow 2$ in a four-momentum conserving way.
 The four-momenta of the two particles are generated back-to-back where we map the d.o.f. to energy, azimuthal and polar angle.
 The particle momenta are then boosted to CMS by an appriopriate boost using the kinematics of the parent mass system.
 
 <<[[phs_rambo.f90]]>>=
 <<File header>>
 
 module phs_rambo
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants
   use numeric_utils
   use format_defs, only: FMT_19
   use permutations, only: factorial
   use diagnostics
   use os_interface
   use lorentz
   use physics_defs
   use model_data
   use flavors
   use process_constants
   use phs_base
 
 <<Standard module head>>
 
 <<PHS rambo: parameters>>
 
 <<PHS rambo: types>>
 
 <<PHS rambo: public>>
 
 contains
 
 <<PHS rambo: procedures>>
 
 end module phs_rambo
 @ %def phs_rambo
 @
 \subsection{Configuration}
 <<PHS rambo: public>>=
   public :: phs_rambo_config_t
 <<PHS rambo: types>>=
   type, extends (phs_config_t) :: phs_rambo_config_t
   contains
   <<PHS rambo: phs rambo config: TBP>>
   end type phs_rambo_config_t
 
 @ %def phs_rambo_config_t
 @ The finalizer is empty.
 <<PHS rambo: phs rambo config: TBP>>=
   procedure :: final => phs_rambo_config_final
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_config_final (object)
     class(phs_rambo_config_t), intent(inout) :: object
   end subroutine phs_rambo_config_final
 
 @ %def phs_rambo_final
 @ Output.
 <<PHS rambo: phs rambo config: TBP>>=
   procedure :: write => phs_rambo_config_write
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_config_write (object, unit, include_id)
     class(phs_rambo_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: include_id
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Partonic, flat phase-space configuration (RAMBO):"
     call object%base_write (unit)
   end subroutine phs_rambo_config_write
 
 @ %def phs_rambo_config_write
 @ Configuration: there is only one channel and $3n - 4$ parameters.
 <<PHS rambo: phs rambo config: TBP>>=
   procedure :: configure => phs_rambo_config_configure
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_config_configure (phs_config, sqrts, &
        sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, &
        nlo_type, subdir)
     class(phs_rambo_config_t), intent(inout) :: phs_config
     real(default), intent(in) :: sqrts
     logical, intent(in), optional :: sqrts_fixed
     logical, intent(in), optional :: cm_frame
     logical, intent(in), optional :: azimuthal_dependence
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     integer, intent(in), optional :: nlo_type
     type(string_t), intent(in), optional :: subdir
     if (.not. present (nlo_type)) &
       phs_config%nlo_type = BORN
     if (phs_config%n_out < 2) then
        call msg_fatal ("RAMBO phase space requires n_out >= 2")
     end if
     phs_config%n_channel = 1
     phs_config%n_par = 3 * phs_config%n_out - 4
     phs_config%sqrts = sqrts
     if (present (sqrts_fixed))  phs_config%sqrts_fixed = sqrts_fixed
     if (present (cm_frame))  phs_config%cm_frame = cm_frame
     if (allocated (phs_config%channel))  deallocate (phs_config%channel)
     allocate (phs_config%channel (1))
     call phs_config%compute_md5sum ()
   end subroutine phs_rambo_config_configure
 
 @ %def phs_rambo_config_configure
 @ Startup message, after configuration is complete.
 <<PHS rambo: phs rambo config: TBP>>=
   procedure :: startup_message => phs_rambo_config_startup_message
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_config_startup_message (phs_config, unit)
     class(phs_rambo_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     call phs_config%base_startup_message (unit)
     write (msg_buffer, "(A,2(1x,I0,1x,A))") &
          "Phase space: flat (RAMBO)"
     call msg_message (unit = unit)
   end subroutine phs_rambo_config_startup_message
 
 @ %def phs_rambo_config_startup_message
 @ Allocate an instance: the actual phase-space object.
 <<PHS rambo: phs rambo config: TBP>>=
   procedure, nopass :: allocate_instance => phs_rambo_config_allocate_instance
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_config_allocate_instance (phs)
     class(phs_t), intent(inout), pointer :: phs
     allocate (phs_rambo_t :: phs)
   end subroutine phs_rambo_config_allocate_instance
 
 @ %def phs_rambo_config_allocate_instance
 @
 \subsection{Kinematics implementation}
 
 We generate $n - 2$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_n = 0$...
 
 Note: The incoming momenta must be in the c.m. system.
 <<PHS rambo: public>>=
   public :: phs_rambo_t
 <<PHS rambo: types>>=
   type, extends (phs_t) :: phs_rambo_t
      real(default), dimension(:), allocatable :: k
      real(default), dimension(:), allocatable :: m
    contains
    <<PHS rambo: phs rambo: TBP>>
   end type phs_rambo_t
 
 @ %def phs_rambo_t
 @ Output.
 <<PHS rambo: phs rambo: TBP>>=
 procedure :: write => phs_rambo_write
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_write (object, unit, verbose)
     class(phs_rambo_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (u)
     write (u, "(1X,A)") "Intermediate masses (massless):"
     write (u, "(3X,999(" // FMT_19 // "))") object%k
     write (u, "(1X,A)") "Intermediate masses (massive):"
     write (u, "(3X,999(" // FMT_19 // "))") object%m
   end subroutine phs_rambo_write
 
 @ %def phs_rambo_write
 @ The finalizer is empty.
 <<PHS rambo: phs rambo: TBP>>=
   procedure :: final => phs_rambo_final
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_final (object)
     class(phs_rambo_t), intent(inout) :: object
   end subroutine phs_rambo_final
 
 @ %def phs_rambo_final
 @ Initialization.  We allocate arrays ([[base_init]]) and adjust the
 phase-space volume.
 The energy dependent factor of $s^{n - 2}$ is applied later.
 <<PHS rambo: phs rambo: TBP>>=
   procedure :: init => phs_rambo_init
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_init (phs, phs_config)
     class(phs_rambo_t), intent(out) :: phs
     class(phs_config_t), intent(in), target :: phs_config
     call phs%base_init (phs_config)
     associate (n => phs%config%n_out)
       select case (n)
       case (1)
          if (sum (phs%m_out) > phs%m_in (1)) then
             print *, "m_in = ", phs%m_in
             print *, "m_out = ", phs%m_out
             call msg_fatal ("[phs_rambo_init] Decay is kinematically forbidden.")
          end if
       end select
       allocate (phs%k(n), source = 0._default)
       allocate (phs%m(n), source = 0._default)
       phs%volume = 1. / (twopi)**(3 * n) &
            * (pi / 2.)**(n - 1) / (factorial(n - 1) * factorial(n - 2))
     end associate
   end subroutine phs_rambo_init
 
 @ %def phs_rambo_init
 @ Evaluation. There is only one channel for RAMBO, so the second subroutine does nothing.
 
 Note: the current implementation works for elastic scattering only.
 <<PHS rambo: phs rambo: TBP>>=
   procedure :: evaluate_selected_channel => phs_rambo_evaluate_selected_channel
   procedure :: evaluate_other_channels => phs_rambo_evaluate_other_channels
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in)
     class(phs_rambo_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     real(default), intent(in), dimension(:) :: r_in
     type(vector4_t), dimension(2) :: p_rest, p_boosted
     type(vector4_t) :: q
     real(default), dimension(2) :: r_angle
     integer :: i
     if (.not. phs%p_defined) return
     call phs%select_channel (c_in)
     phs%r(:,c_in) = r_in
     associate (n => phs%config%n_out, m => phs%m)
       call phs%generate_intermediates (r_in(:n - 2))
       q = sum (phs%p)
       do i = 2, n
          r_angle(1) = r_in(n - 5 + 2 * i)
          r_angle(2) = r_in(n - 4 + 2 * i)
          call phs%decay_intermediate (i, r_angle, p_rest)
          p_boosted = boost(q, m(i - 1)) * p_rest
          q = p_boosted(1)
          phs%q(i - 1)  = p_boosted(2)
       end do
       phs%q(n) = q
     end associate
     phs%q_defined = .true.
     phs%r_defined = .true.
   end subroutine phs_rambo_evaluate_selected_channel
 
   subroutine phs_rambo_evaluate_other_channels (phs, c_in)
     class(phs_rambo_t), intent(inout) :: phs
     integer, intent(in) :: c_in
   end subroutine phs_rambo_evaluate_other_channels
 
 @ %def phs_rambo_evaluate_selected_channel
 @ %def phs_rambo_evaluate_other_channels
 @ Decay intermediate mass system $M_{i - 1}$ into a on-shell particle with mass
 $m_{i - 1}$ and subsequent intermediate mass system with fixed $M_i$.
 <<PHS rambo: phs rambo: TBP>>=
   procedure, private :: decay_intermediate => phs_rambo_decay_intermediate
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p)
     class(phs_rambo_t), intent(in) :: phs
     integer, intent(in) :: i
     real(default), dimension(2), intent(in) :: r_angle
     type(vector4_t), dimension(2), intent(out) :: p
     real(default) :: k_abs, cos_theta, phi
     type(vector3_t):: k
     real(default), dimension(2) :: E
     cos_theta = 2. * r_angle(1) - 1.
     phi = twopi * r_angle(2)
     if (phi > pi) phi = phi - twopi
     k_abs = sqrt (lambda (phs%m(i - 1)**2, phs%m(i)**2, phs%m_out(i - 1)**2)) &
          / (2. * phs%m(i - 1))
     k = k_abs * [cos(phi) * sqrt(1. - cos_theta**2), &
          sin(phi) * sqrt(1. - cos_theta**2), cos_theta]
     E(1) = sqrt (phs%m(i)**2 + k_abs**2)
     E(2) = sqrt (phs%m_out(i - 1)**2 + k_abs**2)
     p(1) = vector4_moving (E(1), -k)
     p(2) = vector4_moving (E(2), k)
   end subroutine phs_rambo_decay_intermediate
 
 @ %def phs_rambo_decay_intermediate
 @ Generate intermediate masses.
 <<PHS rambo: parameters>>=
   integer, parameter :: BISECT_MAX_ITERATIONS = 1000
   real(default), parameter :: BISECT_MIN_PRECISION = tiny_10
 <<PHS rambo: phs rambo: TBP>>=
   procedure, private :: generate_intermediates => phs_rambo_generate_intermediates
   procedure, private :: invert_intermediates => phs_rambo_invert_intermediates
 <<PHS rambo: procedures>>=
  subroutine phs_rambo_generate_intermediates (phs, r)
     class(phs_rambo_t), intent(inout) :: phs
     real(default), dimension(:), intent(in) :: r
     integer :: i, j
     associate (n => phs%config%n_out, k => phs%k, m => phs%m)
       m(1) = invariant_mass (sum (phs%p))
       m(n) = phs%m_out (n)
       call calculate_k (r)
       do i = 2, n - 1
          m(i) = k(i) + sum (phs%m_out (i:n))
       end do
       ! Massless volume times reweighting for massive volume
       phs%f(1) = k(1)**(2 * n - 4) &
            * 8. * rho(m(n - 1), phs%m_out(n), phs%m_out(n - 1))
       do i = 2, n - 1
          phs%f(1) = phs%f(1) * &
               rho(m(i - 1), m(i), phs%m_out(i - 1)) / &
               rho(k(i - 1), k(i), 0._default) * &
               M(i) / K(i)
       end do
     end associate
   contains
     subroutine calculate_k (r)
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), allocatable :: u
       integer :: i
       associate (n => phs%config%n_out, k => phs%k, m => phs%m)
         k = 0
         k(1) = m(1) - sum(phs%m_out(1:n))
         allocate (u(2:n - 1), source=0._default)
         call solve_for_u (r, u)
         do i = 2, n - 1
            k(i) = sqrt (u(i) * k(i - 1)**2)
         end do
       end associate
     end subroutine calculate_k
 
     subroutine solve_for_u (r, u)
       real(default), dimension(phs%config%n_out - 2), intent(in) :: r
       real(default), dimension(2:phs%config%n_out - 1), intent(out) :: u
       integer :: i, j
       real(default) :: f, f_mid, xl, xr, xmid
       associate (n => phs%config%n_out)
         do i = 2, n - 1
            xl = 0
            xr = 1
            if (r(i - 1) == 1 .or. r(i - 1) == 0) then
               u(i) = r(i - 1)
            else
               do j = 1, BISECT_MAX_ITERATIONS
                  xmid = (xl + xr) / 2.
                  f = f_rambo (xl, n - i) - r(i - 1)
                  f_mid = f_rambo (xmid, n - i) - r(i - 1)
                  if (f * f_mid > 0) then
                     xl = xmid
                  else
                     xr = xmid
                  end if
                  if (abs(xl - xr) < BISECT_MIN_PRECISION) exit
               end do
               u(i) = xmid
            end if
         end do
       end associate
     end subroutine solve_for_u
 
     real(default) function f_rambo(u, n)
       real(default), intent(in) :: u
       integer, intent(in) :: n
       f_rambo = (n + 1) * u**n - n * u**(n + 1)
     end function f_rambo
 
     real(default) function rho (M1, M2, m)
       real(default), intent(in) :: M1, M2, m
       real(default) :: MP, MM
       rho = sqrt ((M1**2 - (M2 + m)**2) * (M1**2 - (M2 - m)**2))
       ! MP = (M1 - (M2 + m)) * (M1 + (M2 + m))
       ! MM = (M1 - (M2 - m)) * (M1 + (M2 - m))
       ! rho = sqrt (MP) * sqrt (MM)
       rho = rho / (8._default * M1**2)
     end function rho
 
   end subroutine phs_rambo_generate_intermediates
 
   subroutine phs_rambo_invert_intermediates (phs)
     class(phs_rambo_t), intent(inout) :: phs
     real(default) :: u
     integer :: i
     associate (n => phs%config%n_out, k => phs%k, m => phs%m)
       k = m
       do i = 1, n - 1
          k(i) = k(i) - sum (phs%m_out(i:n))
       end do
       do i = 2, n - 1
          u = (k(i) / k(i - 1))**2
          phs%r(i - 1, 1) = (n + 1 - i) * u**(n - i) &
               - (n - i) * u**(n + 1 - i)
       end do
     end associate
   end subroutine phs_rambo_invert_intermediates
 @ %def phs_rambo_generate_intermediates
 @ Inverse evaluation.
 <<PHS rambo: phs rambo: TBP>>=
   procedure :: inverse => phs_rambo_inverse
 <<PHS rambo: procedures>>=
   subroutine phs_rambo_inverse (phs)
     class(phs_rambo_t), intent(inout) :: phs
     type(vector4_t), dimension(:), allocatable :: q
     type(vector4_t) :: p
     type(lorentz_transformation_t) :: L
     real(default) :: phi, cos_theta
     integer :: i
     if (.not. (phs%p_defined .and. phs%q_defined)) return
     call phs%select_channel ()
     associate (n => phs%config%n_out, m => phs%m)
       allocate(q(n))
       m(1) = invariant_mass (sum (phs%p))
       q(1) = vector4_at_rest (m(1))
       q(n) = phs%q(n)
       do i = 2, n - 1
          q(i) = q(i) + sum (phs%q(i:n))
          m(i) = invariant_mass (q(i))
       end do
       call phs%invert_intermediates ()
       do i = 2, n
          L = inverse (boost (q(i - 1), m(i - 1)))
          p = L * phs%q(i - 1)
          phi = azimuthal_angle (p); cos_theta = polar_angle_ct (p)
          phs%r(n - 5 + 2 * i, 1) = (cos_theta + 1.) / 2.
          phs%r(n - 4 + 2 * i, 1) = phi / twopi
       end do
     end associate
        phs%r_defined = .true.
   end subroutine phs_rambo_inverse
 
 @ %def phs_rambo_inverse
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[phs_rambo_ut.f90]]>>=
 <<File header>>
 
 module phs_rambo_ut
   use unit_tests
   use phs_rambo_uti
 
 <<Standard module head>>
 
 <<PHS rambo: public test>>
 
 contains
 
 <<PHS rambo: test driver>>
 
 end module phs_rambo_ut
 @ %def phs_rambo_ut
 @
 <<[[phs_rambo_uti.f90]]>>=
 <<File header>>
 
 module phs_rambo_uti
 
 <<Use kinds>>
 <<Use strings>>
   use flavors
   use lorentz
   use model_data
   use process_constants
   use phs_base
 
   use phs_rambo
 
   use phs_base_ut, only: init_test_process_data, init_test_decay_data
 
 <<Standard module head>>
 
 <<PHS rambo: test declarations>>
 
 contains
 
 <<PHS rambo: tests>>
 
 end module phs_rambo_uti
 @ %def phs_rambo_ut
 @ API: driver for the unit tests below.
 <<PHS rambo: public test>>=
   public :: phs_rambo_test
 <<PHS rambo: test driver>>=
   subroutine phs_rambo_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS rambo: execute tests>>
   end subroutine phs_rambo_test
 
 @ %def phs_rambo_test
 @
 \subsubsection{Phase-space configuration data}
 Construct and display a test phase-space configuration object.  Also
 check the [[azimuthal_dependence]] flag.
 <<PHS rambo: execute tests>>=
   call test (phs_rambo_1, "phs_rambo_1", &
        "phase-space configuration", &
        u, results)
 <<PHS rambo: test declarations>>=
   public :: phs_rambo_1
 <<PHS rambo: tests>>=
   subroutine phs_rambo_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable :: phs_data
     real(default) :: sqrts
 
     write (u, "(A)")  "* Test output: phs_rambo_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &phase-space configuration data"
     write (u, "(A)")
 
     call model%init_test ()
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_rambo_1"), process_data)
 
     allocate (phs_rambo_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs_data%write (u)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_rambo_1"
 
   end subroutine phs_rambo_1
 
 @ %def phs_rambo_1
 @
 \subsubsection{Phase space evaluation}
 Compute kinematics for given parameters, also invert the calculation.
 <<PHS rambo: execute tests>>=
   call test (phs_rambo_2, "phs_rambo_2", &
        "phase-space evaluation", &
        u, results)
 <<PHS rambo: test declarations>>=
   public :: phs_rambo_2
 <<PHS rambo: tests>>=
   subroutine phs_rambo_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(process_constants_t) :: process_data
     real(default) :: sqrts, E
     class(phs_config_t), allocatable, target :: phs_data
     class(phs_t), pointer :: phs => null ()
     type(vector4_t), dimension(2) :: p, q
 
     write (u, "(A)")  "* Test output: phs_rambo_2"
     write (u, "(A)")  "*   Purpose: test simple two-channel phase space"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_rambo_2"), process_data)
 
     allocate (phs_rambo_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming momenta"
     write (u, "(A)")
 
     E = sqrts / 2
     p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point &
          &for x = 0.5, 0.125"
     write (u, "(A)")
 
     call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
     call phs%evaluate_other_channels (1)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     deallocate (phs)
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_rambo_2"
 
   end subroutine phs_rambo_2
 
 @ %def phs_rambo_2
 @
 \subsubsection{Phase space for non-c.m. system}
 Compute kinematics for given parameters, also invert the calculation.
 Since this will involve cancellations, we call [[pacify]] to eliminate
 numerical noise.
 <<PHS rambo: execute tests>>=
   call test (phs_rambo_3, "phs_rambo_3", &
        "phase-space evaluation in lab frame", &
        u, results)
 <<PHS rambo: test declarations>>=
   public :: phs_rambo_3
 <<PHS rambo: tests>>=
   subroutine phs_rambo_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(process_constants_t) :: process_data
     real(default) :: sqrts, E
     class(phs_config_t), allocatable, target :: phs_data
     class(phs_t), pointer :: phs => null ()
     type(vector4_t), dimension(2) :: p, q
     type(lorentz_transformation_t) :: lt
 
     write (u, "(A)")  "* Test output: phs_rambo_3"
     write (u, "(A)")  "*   Purpose: phase-space evaluation in lab frame"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_rambo_3"), process_data)
 
     allocate (phs_rambo_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts, cm_frame=.false., sqrts_fixed=.false.)
 
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming momenta in lab system"
     write (u, "(A)")
 
     lt = boost (0.1_default, 1) * boost (0.3_default, 3)
 
     E = sqrts / 2
     p(1) = lt * vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     p(2) = lt * vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
 
     call vector4_write (p(1), u)
     call vector4_write (p(2), u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point &
          &for x = 0.5, 0.125"
     write (u, "(A)")
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
 
     call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
     call phs%evaluate_other_channels (1)
     call pacify (phs)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract outgoing momenta in lab system"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     call vector4_write (q(1), u)
     call vector4_write (q(2), u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     deallocate (phs)
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call pacify (phs)
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_rambo_3"
 
   end subroutine phs_rambo_3
 
 @ %def phs_rambo_3
 @
 \subsubsection{Decay Phase space evaluation}
 Compute kinematics for given parameters, also invert the calculation.  This
 time, implement a decay process.
 <<PHS rambo: execute tests>>=
   call test (phs_rambo_4, "phs_rambo_4", &
        "decay phase-space evaluation", &
        u, results)
 <<PHS rambo: test declarations>>=
   public :: phs_rambo_4
 <<PHS rambo: tests>>=
   subroutine phs_rambo_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable, target :: phs_data
     class(phs_t), pointer :: phs => null ()
     type(vector4_t), dimension(1) :: p
     type(vector4_t), dimension(2) :: q
 
     write (u, "(A)")  "* Test output: phs_rambo_4"
     write (u, "(A)")  "*   Purpose: test simple two-channel phase space"
     write (u, "(A)")
 
     call model%init_test ()
 
     call model%set_par (var_str ("ff"), 0.4_default)
     call model%set_par (var_str ("mf"), &
          model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
     call flv%init (25, model)
 
     write (u, "(A)")  "* Initialize a decay and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_decay_data (var_str ("phs_rambo_4"), process_data)
 
     allocate (phs_rambo_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     call phs_data%configure (flv%get_mass ())
 
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming momenta"
     write (u, "(A)")
 
     p(1) = vector4_at_rest (flv%get_mass ())
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point &
          &for x = 0.5, 0.125"
     write (u, "(A)")
 
     call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
     call phs%evaluate_other_channels (1)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     deallocate (phs)
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs_data%configure (flv%get_mass ())
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_rambo_4"
 
   end subroutine phs_rambo_4
 
 @ %def phs_rambo_4
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Resonance Handler}
 For various purposes (e.g., shower histories), we should extract the set of
 resonances and resonant channels from a phase-space tree set.  A few methods
 do kinematics calculations specifically for those resonance data.
 <<[[resonances.f90]]>>=
 <<File header>>
 
 module resonances
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use string_utils, only: str
   use format_utils, only: write_indent
   use io_units
   use diagnostics
   use lorentz
   use constants, only: one
   use model_data, only: model_data_t
   use flavors, only: flavor_t
 
 <<Standard module head>>
 
 <<Resonances: public>>
 
 <<Resonances: parameters>>
 
 <<Resonances: types>>
 
 contains
 
 <<Resonances: procedures>>
 
 end module resonances
 @ %def resonances
 @
 \subsection{Decay products (contributors)}
 This stores the indices of the particles that contribute to a resonance, i.e.,
 the decay products.
 <<Resonances: public>>=
   public :: resonance_contributors_t
 <<Resonances: types>>=
   type :: resonance_contributors_t
      integer, dimension(:), allocatable :: c
    contains
    <<Resonances: resonance contributors: TBP>>
   end type resonance_contributors_t
 
 @ %def resonance_contributors_t
 @ Equality (comparison)
 <<Resonances: resonance contributors: TBP>>=
   procedure, private :: resonance_contributors_equal
   generic :: operator(==) => resonance_contributors_equal
 <<Resonances: procedures>>=
   elemental function resonance_contributors_equal (c1, c2) result (equal)
     logical :: equal
     class(resonance_contributors_t), intent(in) :: c1, c2
     equal = allocated (c1%c) .and. allocated (c2%c)
     if (equal) equal = size (c1%c) == size (c2%c)
     if (equal) equal = all (c1%c == c2%c)
   end function resonance_contributors_equal
 
 @ %def resonance_contributors_equal
 @ Assignment
 <<Resonances: resonance contributors: TBP>>=
   procedure, private :: resonance_contributors_assign
   generic :: assignment(=) => resonance_contributors_assign
 <<Resonances: procedures>>=
   pure subroutine resonance_contributors_assign (contributors_out, contributors_in)
     class(resonance_contributors_t), intent(inout) :: contributors_out
     class(resonance_contributors_t), intent(in) :: contributors_in
     if (allocated (contributors_out%c))  deallocate (contributors_out%c)
     if (allocated (contributors_in%c)) then
        allocate (contributors_out%c (size (contributors_in%c)))
        contributors_out%c = contributors_in%c
     end if
   end subroutine resonance_contributors_assign
 
 @ %def resonance_contributors_assign
 @
 \subsection{Resonance info object}
 This data structure augments the set of resonance contributors by a flavor
 object, such that we can perform calculations that take into
 account the particle properties, including mass and width.
 
 Avoiding nameclash with similar but different [[resonance_t]] of
 [[phs_base]]:
 <<Resonances: public>>=
   public :: resonance_info_t
 <<Resonances: types>>=
   type :: resonance_info_t
      type(flavor_t) :: flavor
      type(resonance_contributors_t) :: contributors
   contains
    <<Resonances: resonance info: TBP>>
   end type resonance_info_t
 
 @ %def resonance_info_t
 @
 <<Resonances: resonance info: TBP>>=
   procedure :: copy => resonance_info_copy
 <<Resonances: procedures>>=
   subroutine resonance_info_copy (resonance_in, resonance_out)
     class(resonance_info_t), intent(in) :: resonance_in
     type(resonance_info_t), intent(out) :: resonance_out
     resonance_out%flavor = resonance_in%flavor
     if (allocated (resonance_in%contributors%c)) then
        associate (c => resonance_in%contributors%c)
           allocate (resonance_out%contributors%c (size (c)))
           resonance_out%contributors%c = c
        end associate
     end if
   end subroutine resonance_info_copy
 
 @ %def resonance_info_copy
 @
 <<Resonances: resonance info: TBP>>=
   procedure :: write => resonance_info_write
 <<Resonances: procedures>>=
   subroutine resonance_info_write (resonance, unit, verbose)
     class(resonance_info_t), intent(in) :: resonance
     integer, optional, intent(in) :: unit
     logical, optional, intent(in) :: verbose
     integer :: u, i
     logical :: verb
     u = given_output_unit (unit);  if (u < 0)  return
     verb = .true.;  if (present (verbose))  verb = verbose
     if (verb) then
        write (u, '(A)', advance='no') "Resonance contributors: "
     else
        write (u, '(1x)', advance="no")
     end if
     if (allocated (resonance%contributors%c)) then
        do i = 1, size(resonance%contributors%c)
           write (u, '(I0,1X)', advance='no') resonance%contributors%c(i)
        end do
     else if (verb) then
        write (u, "(A)", advance="no")  "[not allocated]"
     end if
     if (resonance%flavor%is_defined ()) call resonance%flavor%write (u)
     write (u, '(A)')
   end subroutine resonance_info_write
 
 @ %def resonance_info_write
 @ Create a resonance-info object.  The particle info may be available
 in term of a flavor object or as a PDG code; in the latter case we
 have to require a model data object that provides mass and width information.
 <<Resonances: resonance info: TBP>>=
   procedure, private :: resonance_info_init_pdg
   procedure, private :: resonance_info_init_flv
   generic :: init => resonance_info_init_pdg, resonance_info_init_flv
 <<Resonances: procedures>>=
   subroutine resonance_info_init_pdg (resonance, mom_id, pdg, model, n_out)
     class(resonance_info_t), intent(out) :: resonance
     integer, intent(in) :: mom_id
     integer, intent(in) :: pdg, n_out
     class(model_data_t), intent(in), target :: model
     type(flavor_t) :: flv
     if (debug_on) call msg_debug (D_PHASESPACE, "resonance_info_init_pdg")
     call flv%init (pdg, model)
     call resonance%init (mom_id, flv, n_out)
   end subroutine resonance_info_init_pdg
 
   subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out)
     class(resonance_info_t), intent(out) :: resonance
     integer, intent(in) :: mom_id
     type(flavor_t), intent(in) :: flv
     integer, intent(in) :: n_out
     integer :: i
     logical, dimension(n_out) :: contrib
     integer, dimension(n_out) :: tmp
     if (debug_on) call msg_debug (D_PHASESPACE, "resonance_info_init_flv")
     resonance%flavor = flv
     do i = 1, n_out
        tmp(i) = i
     end do
     contrib = btest (mom_id, tmp - 1)
     allocate (resonance%contributors%c (count (contrib)))
     resonance%contributors%c = pack (tmp, contrib)
   end subroutine resonance_info_init_flv
 
 @ %def resonance_info_init
 @
 <<Resonances: resonance info: TBP>>=
   procedure, private :: resonance_info_equal
   generic :: operator(==) => resonance_info_equal
 <<Resonances: procedures>>=
   elemental function resonance_info_equal (r1, r2) result (equal)
     logical :: equal
     class(resonance_info_t), intent(in) :: r1, r2
     equal = r1%flavor == r2%flavor .and. r1%contributors == r2%contributors
   end function resonance_info_equal
 
 @ %def resonance_info_equal
 @ With each resonance region we associate a Breit-Wigner function
 \begin{equation*}
   P = \frac{M_{res}^4}{(s - M_{res}^2)^2 + \Gamma_{res}^2 M_{res}^2},
 \end{equation*}
 where $s$ denotes the invariant mass of the outgoing momenta originating
 from this resonance. Note that the $M_{res}^4$ in the nominator makes
 the mapping a dimensionless quantity.
 <<Resonances: resonance info: TBP>>=
   procedure :: mapping => resonance_info_mapping
 <<Resonances: procedures>>=
   function resonance_info_mapping (resonance, s) result (bw)
     real(default) :: bw
     class(resonance_info_t), intent(in) :: resonance
     real(default), intent(in) :: s
     real(default) :: m, gamma
     if (resonance%flavor%is_defined ()) then
        m = resonance%flavor%get_mass ()
        gamma = resonance%flavor%get_width ()
        bw = m**4 / ((s - m**2)**2 + gamma**2 * m**2)
     else
        bw = one
     end if
   end function resonance_info_mapping
 
 @ %def resonance_info_mapping
 @ Used for building a resonance tree below.
 <<Resonances: resonance info: TBP>>=
   procedure, private :: get_n_contributors => resonance_info_get_n_contributors
   procedure, private :: contains => resonance_info_contains
 <<Resonances: procedures>>=
   elemental function resonance_info_get_n_contributors (resonance) result (n)
     class(resonance_info_t), intent(in) :: resonance
     integer :: n
     if (allocated (resonance%contributors%c)) then
        n = size (resonance%contributors%c)
     else
        n = 0
     end if
   end function resonance_info_get_n_contributors
 
   elemental function resonance_info_contains (resonance, c) result (flag)
     class(resonance_info_t), intent(in) :: resonance
     integer, intent(in) :: c
     logical :: flag
     if (allocated (resonance%contributors%c)) then
        flag = any (resonance%contributors%c == c)
     else
        flag = .false.
     end if
   end function resonance_info_contains
 
 @ %def resonance_info_get_n_contributors
 @ %def resonance_info_contains
 @
 \subsection{Resonance history object}
 This data structure stores a set of resonances, i.e., the resonances that
 appear in a particular Feynman graph or, in the context of phase space, phase
 space diagram.
 <<Resonances: public>>=
   public :: resonance_history_t
 <<Resonances: types>>=
   type :: resonance_history_t
      type(resonance_info_t), dimension(:), allocatable :: resonances
      integer :: n_resonances = 0
   contains
    <<Resonances: resonance history: TBP>>
   end type resonance_history_t
 
 @ %def resonance_history_t
 @ Clear the resonance history.  Assuming that there are no
 pointer-allocated parts, a straightforward [[intent(out)]] will do.
 <<Resonances: resonance history: TBP>>=
   procedure :: clear => resonance_history_clear
 <<Resonances: procedures>>=
   subroutine resonance_history_clear (res_hist)
     class(resonance_history_t), intent(out) :: res_hist
   end subroutine resonance_history_clear
 
 @ %def resonance_history_clear
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: copy => resonance_history_copy
 <<Resonances: procedures>>=
   subroutine resonance_history_copy (res_hist_in, res_hist_out)
     class(resonance_history_t), intent(in) :: res_hist_in
     type(resonance_history_t), intent(out) :: res_hist_out
     integer :: i
     res_hist_out%n_resonances = res_hist_in%n_resonances
     allocate (res_hist_out%resonances (size (res_hist_in%resonances)))
     do i = 1, size (res_hist_in%resonances)
        call res_hist_in%resonances(i)%copy (res_hist_out%resonances(i))
     end do
   end subroutine resonance_history_copy
 
 @ %def resonance_history_copy
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: write => resonance_history_write
 <<Resonances: procedures>>=
   subroutine resonance_history_write (res_hist, unit, verbose, indent)
     class(resonance_history_t), intent(in) :: res_hist
     integer, optional, intent(in) :: unit
     logical, optional, intent(in) :: verbose
     integer, optional, intent(in) :: indent
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     call write_indent (u, indent)
     write(u, '(A,I0,A)') "Resonance history with ", &
          res_hist%n_resonances, " resonances:"
     do i = 1, res_hist%n_resonances
        call write_indent (u, indent)
        write (u, "(2x)", advance="no")
        call res_hist%resonances(i)%write (u, verbose)
     end do
   end subroutine resonance_history_write
 
 @ %def resonance_history_write
 @ Assignment.  Indirectly calls type-bound assignment for the contributors.
 
 Strictly speaking, this is redundant.  But NAGfor 6.208 intrinsic assignment
 crashes under certain conditions.
 <<Resonances: resonance history: TBP>>=
   procedure, private :: resonance_history_assign
   generic :: assignment(=) => resonance_history_assign
 <<Resonances: procedures>>=
   subroutine resonance_history_assign (res_hist_out, res_hist_in)
     class(resonance_history_t), intent(out) :: res_hist_out
     class(resonance_history_t), intent(in) :: res_hist_in
     if (allocated (res_hist_in%resonances)) then
        res_hist_out%resonances = res_hist_in%resonances
        res_hist_out%n_resonances = res_hist_in%n_resonances
     end if
   end subroutine resonance_history_assign
 
 @ %def resonance_history_assign
 @ Equality.  If this turns out to slow down the program, we should
 change the implementation or use hash codes.
 <<Resonances: resonance history: TBP>>=
   procedure, private :: resonance_history_equal
   generic :: operator(==) => resonance_history_equal
 <<Resonances: procedures>>=
   elemental function resonance_history_equal (rh1, rh2) result (equal)
     logical :: equal
     class(resonance_history_t), intent(in) :: rh1, rh2
     integer :: i
     equal = .false.
     if (rh1%n_resonances == rh2%n_resonances) then
        do i = 1, rh1%n_resonances
           if (.not. rh1%resonances(i) == rh2%resonances(i)) then
              return
           end if
        end do
        equal = .true.
     end if
   end function resonance_history_equal
 
 @ %def resonance_history_equal
 @ Check if a resonance history is a strict superset of another one.  This is
 true if the first one is nonempty and the second one is empty.
 Otherwise, we check if each entry of the second argument appears in
 the first one.
 <<Resonances: resonance history: TBP>>=
   procedure, private :: resonance_history_contains
   generic :: operator(.contains.) => resonance_history_contains
 @
 <<Resonances: procedures>>=
   elemental function resonance_history_contains (rh1, rh2) result (flag)
     logical :: flag
     class(resonance_history_t), intent(in) :: rh1, rh2
     integer :: i
     if (rh1%n_resonances > rh2%n_resonances) then
        flag = .true.
        do i = 1, rh2%n_resonances
           flag = flag .and. any (rh1%resonances == rh2%resonances(i))
        end do
     else
        flag = .false.
     end if
   end function resonance_history_contains
 
 @ %def resonance_history_contains
 @ Number of entries for dynamically extending the resonance-info array.
 <<Resonances: parameters>>=
   integer, parameter :: n_max_resonances = 10
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: add_resonance => resonance_history_add_resonance
 <<Resonances: procedures>>=
   subroutine resonance_history_add_resonance (res_hist, resonance)
     class(resonance_history_t), intent(inout) :: res_hist
     type(resonance_info_t), intent(in) :: resonance
     type(resonance_info_t), dimension(:), allocatable :: tmp
     integer :: n, i
     if (debug_on) call msg_debug (D_PHASESPACE, "resonance_history_add_resonance")
     if (.not. allocated (res_hist%resonances)) then
        n = 0
        allocate (res_hist%resonances (1))
     else
        n = res_hist%n_resonances
        allocate (tmp (n))
        do i = 1, n
           call res_hist%resonances(i)%copy (tmp(i))
        end do
        deallocate (res_hist%resonances)
        allocate (res_hist%resonances (n+1))
        do i = 1, n
           call tmp(i)%copy (res_hist%resonances(i))
        end do
        deallocate (tmp)
     end if
     call resonance%copy (res_hist%resonances(n+1))
     res_hist%n_resonances = n + 1
     if (debug_on) call msg_debug &
          (D_PHASESPACE, "res_hist%n_resonances", res_hist%n_resonances)
   end subroutine resonance_history_add_resonance
 
 @ %def resonance_history_add_resonance
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: remove_resonance => resonance_history_remove_resonance
 <<Resonances: procedures>>=
   subroutine resonance_history_remove_resonance (res_hist, i_res)
     class(resonance_history_t), intent(inout) :: res_hist
     integer, intent(in) :: i_res
     type(resonance_info_t), dimension(:), allocatable :: tmp_1, tmp_2
     integer :: i, j, n
     n = res_hist%n_resonances
     res_hist%n_resonances = n - 1
     if (res_hist%n_resonances == 0) then
        deallocate (res_hist%resonances)
     else
        if (i_res > 1) allocate (tmp_1(1:i_res-1))
        if (i_res < n) allocate (tmp_2(i_res+1:n))
        if (allocated (tmp_1)) then
           do i = 1, i_res - 1
              call res_hist%resonances(i)%copy (tmp_1(i))
           end do
        end if
        if (allocated (tmp_2)) then
           do i = i_res + 1, n
              call res_hist%resonances(i)%copy (tmp_2(i))
           end do
        end if
        deallocate (res_hist%resonances)
        allocate (res_hist%resonances (res_hist%n_resonances))
        j = 1
        if (allocated (tmp_1)) then
           do i = 1, i_res - 1
              call tmp_1(i)%copy (res_hist%resonances(j))
              j = j + 1
           end do
           deallocate (tmp_1)
        end if
        if (allocated (tmp_2)) then
           do i = i_res + 1, n
              call tmp_2(i)%copy (res_hist%resonances(j))
              j = j + 1
           end do
           deallocate (tmp_2)
        end if
     end if
   end subroutine resonance_history_remove_resonance
 
 @ %def resonance_history_remove_resonance
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: add_offset => resonance_history_add_offset
 <<Resonances: procedures>>=
   subroutine resonance_history_add_offset (res_hist, n)
     class(resonance_history_t), intent(inout) :: res_hist
     integer, intent(in) :: n
     integer :: i_res
     do i_res = 1, res_hist%n_resonances
        associate (contributors => res_hist%resonances(i_res)%contributors%c)
           contributors = contributors + n
        end associate
     end do
   end subroutine resonance_history_add_offset
 
 @ %def resonance_history_add_offset
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: contains_leg => resonance_history_contains_leg
 <<Resonances: procedures>>=
   function resonance_history_contains_leg (res_hist, i_leg) result (val)
     logical :: val
     class(resonance_history_t), intent(in) :: res_hist
     integer, intent(in) :: i_leg
     integer :: i_res
     val = .false.
     do i_res = 1, res_hist%n_resonances
        if (any (res_hist%resonances(i_res)%contributors%c == i_leg)) then
           val = .true.
           exit
        end if
     end do
   end function resonance_history_contains_leg
 
 @ %def resonance_history_contains_leg
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: mapping => resonance_history_mapping
 <<Resonances: procedures>>=
   function resonance_history_mapping (res_hist, p, i_gluon) result (p_map)
     real(default) :: p_map
     class(resonance_history_t), intent(in) :: res_hist
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in), optional :: i_gluon
     integer :: i_res
     real(default) :: s
     p_map = one
     do i_res = 1, res_hist%n_resonances
        associate (res => res_hist%resonances(i_res))
           s = compute_resonance_mass (p, res%contributors%c, i_gluon)**2
           p_map = p_map * res%mapping (s)
        end associate
     end do
   end function resonance_history_mapping
 
 @ %def resonance_history_mapping
 @ This predicate is true if all resonances in the history have exactly
 [[n]] contributors.  For instance, if $n=2$, all resonances have a
 two-particle decay.
 <<Resonances: resonance history: TBP>>=
   procedure :: only_has_n_contributors => resonance_history_only_has_n_contributors
 <<Resonances: procedures>>=
   function resonance_history_only_has_n_contributors (res_hist, n) result (value)
     logical :: value
     class(resonance_history_t), intent(in) :: res_hist
     integer, intent(in) :: n
     integer :: i_res
     value = .true.
     do i_res = 1, res_hist%n_resonances
        associate (res => res_hist%resonances(i_res))
           value = value .and. size (res%contributors%c) == n
        end associate
     end do
   end function resonance_history_only_has_n_contributors
 
 @ %def resonance_history_only_has_n_contributors
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: has_flavor => resonance_history_has_flavor
 <<Resonances: procedures>>=
   function resonance_history_has_flavor (res_hist, flv) result (has_flv)
     logical :: has_flv
     class(resonance_history_t), intent(in) :: res_hist
     type(flavor_t), intent(in) :: flv
     integer :: i
     has_flv = .false.
     do i = 1, res_hist%n_resonances
        has_flv = has_flv .or. res_hist%resonances(i)%flavor == flv
     end do
   end function resonance_history_has_flavor
 
 @ %def resonance_history_has_flavor
 @
 \subsection{Kinematics}
 Evaluate the distance from a resonance.  The distance is given by
 $|p^2-m^2|/(m\Gamma)$.  For $\Gamma\ll m$, this is the relative
 distance from the resonance peak in units of the half-width.
 <<Resonances: resonance info: TBP>>=
   procedure :: evaluate_distance => resonance_info_evaluate_distance
 <<Resonances: procedures>>=
   subroutine resonance_info_evaluate_distance (res_info, p, dist)
     class(resonance_info_t), intent(in) :: res_info
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(out) :: dist
     real(default) :: m, w
     type(vector4_t) :: q
     m = res_info%flavor%get_mass ()
     w = res_info%flavor%get_width ()
     q = sum (p(res_info%contributors%c))
     dist = abs (q**2 - m**2) / (m * w)
   end subroutine resonance_info_evaluate_distance
 
 @ %def resonance_info_evaluate_distance
 @
 Evaluate the array of distances from a resonance history.  We assume that the
 array has been allocated with correct size, namely the number of resonances in
 this history.
 <<Resonances: resonance history: TBP>>=
   procedure :: evaluate_distances => resonance_history_evaluate_distances
 <<Resonances: procedures>>=
   subroutine resonance_history_evaluate_distances (res_hist, p, dist)
     class(resonance_history_t), intent(in) :: res_hist
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), dimension(:), intent(out) :: dist
     integer :: i
     do i = 1, res_hist%n_resonances
        call res_hist%resonances(i)%evaluate_distance (p, dist(i))
     end do
   end subroutine resonance_history_evaluate_distances
 
 @ %def resonance_history_evaluate_distances
 @ Use the distance to determine a Gaussian turnoff factor for a
 resonance.  The factor is given by a Gaussian function
 $e^{-d^2/\sigma^2}$, where $\sigma$ is the [[gw]] parameter multiplied
 by the resonance width, and $d$ is the distance (see above).  So, for
 $d=\sigma$, the factor is $0.37$, and for $d=2\sigma$ we get $0.018$.
 
 If the [[gw]] factor is less or equal to zero, return $1$.
 <<Resonances: resonance info: TBP>>=
   procedure :: evaluate_gaussian => resonance_info_evaluate_gaussian
 <<Resonances: procedures>>=
   function resonance_info_evaluate_gaussian (res_info, p, gw) result (factor)
     class(resonance_info_t), intent(in) :: res_info
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(in) :: gw
     real(default) :: factor
     real(default) :: dist, w
     if (gw > 0) then
        w = res_info%flavor%get_width ()
        call res_info%evaluate_distance (p, dist)
        factor = exp (- (dist / (gw * w)) **2)
     else
        factor = 1
     end if
   end function resonance_info_evaluate_gaussian
 
 @ %def resonance_info_evaluate_gaussian
 @ The Gaussian factor of the history is the product of all factors.
 <<Resonances: resonance history: TBP>>=
   procedure :: evaluate_gaussian => resonance_history_evaluate_gaussian
 <<Resonances: procedures>>=
   function resonance_history_evaluate_gaussian (res_hist, p, gw) result (factor)
     class(resonance_history_t), intent(in) :: res_hist
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(in) :: gw
     real(default), dimension(:), allocatable :: dist
     real(default) :: factor
     integer :: i
     factor = 1
     do i = 1, res_hist%n_resonances
        factor = factor * res_hist%resonances(i)%evaluate_gaussian (p, gw)
     end do
   end function resonance_history_evaluate_gaussian
 
 @ %def resonance_history_evaluate_gaussian
 @
 Use the distances to determine whether the resonance history can qualify as
 on-shell.  The criterion is whether the distance is greater than the number of
 width values as given by [[on_shell_limit]].
 <<Resonances: resonance info: TBP>>=
   procedure :: is_on_shell => resonance_info_is_on_shell
 <<Resonances: procedures>>=
   function resonance_info_is_on_shell (res_info, p, on_shell_limit) &
        result (flag)
     class(resonance_info_t), intent(in) :: res_info
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(in) :: on_shell_limit
     logical :: flag
     real(default) :: dist
     call res_info%evaluate_distance (p, dist)
     flag = dist < on_shell_limit
   end function resonance_info_is_on_shell
 
 @ %def resonance_info_is_on_shell
 @
 <<Resonances: resonance history: TBP>>=
   procedure :: is_on_shell => resonance_history_is_on_shell
 <<Resonances: procedures>>=
   function resonance_history_is_on_shell (res_hist, p, on_shell_limit) &
        result (flag)
     class(resonance_history_t), intent(in) :: res_hist
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(in) :: on_shell_limit
     logical :: flag
     integer :: i
     flag = .true.
     do i = 1, res_hist%n_resonances
        flag = flag .and. res_hist%resonances(i)%is_on_shell (p, on_shell_limit)
     end do
   end function resonance_history_is_on_shell
 
 @ %def resonance_history_is_on_shell
 @
 \subsection{OMega restriction strings}
 One application of the resonance module is creating restriction
 strings that can be fed into process definitions with the OMega
 generator.  Since OMega counts the incoming particles first, we have
 to supply [[n_in]] as an offset.
 <<Resonances: resonance info: TBP>>=
   procedure :: as_omega_string => resonance_info_as_omega_string
 <<Resonances: resonance history: TBP>>=
   procedure :: as_omega_string => resonance_history_as_omega_string
 <<Resonances: procedures>>=
   function resonance_info_as_omega_string (res_info, n_in) result (string)
     class(resonance_info_t), intent(in) :: res_info
     integer, intent(in) :: n_in
     type(string_t) :: string
     integer :: i
     string = ""
     if (allocated (res_info%contributors%c)) then
        do i = 1, size (res_info%contributors%c)
           if (i > 1)  string = string // "+"
           string = string // str (res_info%contributors%c(i) + n_in)
        end do
        string = string // "~" // res_info%flavor%get_name ()
     end if
   end function resonance_info_as_omega_string
 
   function resonance_history_as_omega_string (res_hist, n_in) result (string)
     class(resonance_history_t), intent(in) :: res_hist
     integer, intent(in) :: n_in
     type(string_t) :: string
     integer :: i
     string = ""
     do i = 1, res_hist%n_resonances
        if (i > 1)  string = string // " && "
        string = string // res_hist%resonances(i)%as_omega_string (n_in)
     end do
   end function resonance_history_as_omega_string
 
 @ %def resonance_info_as_omega_string
 @ %def resonance_history_as_omega_string
 @
 \subsection{Resonance history as tree}
 If we want to organize the resonances and their decay products, it can be
 useful to have them explicitly as a tree structure.  We implement this in the
 traditional event-record form with the resonances sorted by decreasing number
 of contributors, and their decay products added as an extra array.
 <<Resonances: public>>=
   public :: resonance_tree_t
 <<Resonances: types>>=
   type :: resonance_branch_t
      integer :: i = 0
      type(flavor_t) :: flv
      integer, dimension(:), allocatable :: r_child
      integer, dimension(:), allocatable :: o_child
   end type resonance_branch_t
 
   type :: resonance_tree_t
      private
      integer :: n = 0
      type(resonance_branch_t), dimension(:), allocatable :: branch
    contains
    <<Resonances: resonance tree: TBP>>
   end type resonance_tree_t
 
 
 @ %def resonance_branch_t resonance_tree_t
 @
 <<Resonances: resonance tree: TBP>>=
   procedure :: write => resonance_tree_write
 <<Resonances: procedures>>=
   subroutine resonance_tree_write (tree, unit, indent)
     class(resonance_tree_t), intent(in) :: tree
     integer, intent(in), optional :: unit, indent
     integer :: u, b, c
     u = given_output_unit (unit)
     call write_indent (u, indent)
     write (u, "(A)", advance="no")  "Resonance tree:"
     if (tree%n > 0) then
        write (u, *)
        do b = 1, tree%n
           call write_indent (u, indent)
           write (u, "(2x,'r',I0,':',1x)", advance="no")  b
           associate (branch => tree%branch(b))
             call branch%flv%write (u)
             write (u, "(1x,'=>')", advance="no")
             if (allocated (branch%r_child)) then
                do c = 1, size (branch%r_child)
                   write (u, "(1x,'r',I0)", advance="no")  branch%r_child(c)
                end do
             end if
             if (allocated (branch%o_child)) then
                do c = 1, size (branch%o_child)
                   write (u, "(1x,I0)", advance="no")  branch%o_child(c)
                end do
             end if
             write (u, *)
           end associate
        end do
     else
        write (u, "(1x,A)")  "[empty]"
     end if
   end subroutine resonance_tree_write
 
 @ %def resonance_tree_write
 @ Contents.
 <<Resonances: resonance tree: TBP>>=
   procedure :: get_n_resonances => resonance_tree_get_n_resonances
   procedure :: get_flv => resonance_tree_get_flv
 <<Resonances: procedures>>=
   function resonance_tree_get_n_resonances (tree) result (n)
     class(resonance_tree_t), intent(in) :: tree
     integer :: n
     n = tree%n
   end function resonance_tree_get_n_resonances
 
   function resonance_tree_get_flv (tree, i) result (flv)
     class(resonance_tree_t), intent(in) :: tree
     integer, intent(in) :: i
     type(flavor_t) :: flv
     flv = tree%branch(i)%flv
   end function resonance_tree_get_flv
 
 @ %def resonance_tree_get_n_resonances
 @ %def resonance_tree_get_flv
 @ Return the shifted indices of the resonance children for branch [[i]].  For
 a child which is itself a resonance, add [[offset_r]] to the index value.  For
 the others, add [[offset_o]].  Combine both in a single array.
 <<Resonances: resonance tree: TBP>>=
   procedure :: get_children => resonance_tree_get_children
 <<Resonances: procedures>>=
   function resonance_tree_get_children (tree, i, offset_r, offset_o) &
        result (child)
     class(resonance_tree_t), intent(in) :: tree
     integer, intent(in) :: i, offset_r, offset_o
     integer, dimension(:), allocatable :: child
     integer :: nr, no
     associate (branch => tree%branch(i))
       nr = size (branch%r_child)
       no = size (branch%o_child)
       allocate (child (nr + no))
       child(1:nr) = branch%r_child + offset_r
       child(nr+1:nr+no) = branch%o_child + offset_o
     end associate
   end function resonance_tree_get_children
 
 @ %def resonance_tree_get_children
 @ Transform a resonance history into a resonance tree.
 Algorithm:
 \begin{enumerate}
 \item
   Determine a mapping of the resonance array, such that in the new array the
   resonances are ordered by decreasing number of contributors.
 \item
   Copy the flavor entries to the mapped array.
 \item
   Scan all resonances and, for each one, find a resonance that is its parent.
   Since the resonances are ordered, later matches overwrite earlier ones.  The
   last match is the correct one.  Then scan again and, for each resonance,
   collect the resonances that have it as parent.  This is the set of child
   resonances.
 \item
   Analogously, scan all outgoing particles that appear in any of the
   contributors list.  Determine their immediate parent as above, and set the
   child outgoing parents for the resonances, as above.
 \end{enumerate}
 <<Resonances: resonance history: TBP>>=
   procedure :: to_tree => resonance_history_to_tree
 <<Resonances: procedures>>=
   subroutine resonance_history_to_tree (res_hist, tree)
     class(resonance_history_t), intent(in) :: res_hist
     type(resonance_tree_t), intent(out) :: tree
     integer :: nr
     integer, dimension(:), allocatable :: r_branch, r_source
 
     nr = res_hist%n_resonances
     tree%n = nr
     allocate (tree%branch (tree%n), r_branch (tree%n), r_source (tree%n))
     if (tree%n > 0) then
        call find_branch_ordering ()
        call set_flavors ()
        call set_child_resonances ()
        call set_child_outgoing ()
     end if
 
   contains
 
     subroutine find_branch_ordering ()
       integer, dimension(:), allocatable :: nc_array
       integer :: r, ir, nc
       allocate (nc_array (tree%n))
       nc_array(:) = res_hist%resonances%get_n_contributors ()
       ir = 0
       do nc = maxval (nc_array), minval (nc_array), -1
          do r = 1, nr
             if (nc_array(r) == nc) then
                ir = ir + 1
                r_branch(r) = ir
                r_source(ir) = r
             end if
          end do
       end do
     end subroutine find_branch_ordering
 
     subroutine set_flavors ()
       integer :: r
       do r = 1, nr
          tree%branch(r_branch(r))%flv = res_hist%resonances(r)%flavor
       end do
     end subroutine set_flavors
 
     subroutine set_child_resonances ()
       integer, dimension(:), allocatable :: r_child, r_parent
       integer :: r, ir, pr
       allocate (r_parent (nr), source = 0)
       SCAN_RES: do r = 1, nr
          associate (this_res => res_hist%resonances(r))
            SCAN_PARENT: do ir = 1, nr
               pr = r_source(ir)
               if (pr == r)  cycle SCAN_PARENT
               if (all (res_hist%resonances(pr)%contains &
                    (this_res%contributors%c))) then
                  r_parent (r) = pr
               end if
            end do SCAN_PARENT
          end associate
       end do SCAN_RES
       allocate (r_child (nr), source = [(r, r = 1, nr)])
       do r = 1, nr
          ir = r_branch(r)
          tree%branch(ir)%r_child = r_branch (pack (r_child, r_parent == r))
       end do
     end subroutine set_child_resonances
 
     subroutine set_child_outgoing ()
       integer, dimension(:), allocatable :: o_child, o_parent
       integer :: o_max, r, o, ir
       o_max = 0
       do r = 1, nr
          associate (this_res => res_hist%resonances(r))
            o_max = max (o_max, maxval (this_res%contributors%c))
          end associate
       end do
       allocate (o_parent (o_max), source=0)
       SCAN_OUT: do o = 1, o_max
          SCAN_PARENT: do ir = 1, nr
             r = r_source(ir)
             associate (this_res => res_hist%resonances(r))
               if (this_res%contains (o))  o_parent(o) = r
             end associate
          end do SCAN_PARENT
       end do SCAN_OUT
       allocate (o_child (o_max), source = [(o, o = 1, o_max)])
       do r = 1, nr
          ir = r_branch(r)
          tree%branch(ir)%o_child = pack (o_child, o_parent == r)
       end do
     end subroutine set_child_outgoing
 
   end subroutine resonance_history_to_tree
 
 @ %def resonance_history_to_tree
 @
 \subsection{Resonance history set}
 This is an array of resonance histories.  The elements are supposed to
 be unique.  That is, entering a new element is successful only if the
 element does not already exist.
 
 The current implementation uses a straightforward linear search for
 comparison.  If this should become an issue, we may change the
 implementation to a hash table.  To keep this freedom, the set should
 be an opaque object.  In fact, we expect to use it as a transient data
 structure.  Once the set is complete, we transform it into a
 contiguous array.
 <<Resonances: public>>=
   public :: resonance_history_set_t
 <<Resonances: types>>=
   type :: index_array_t
      integer, dimension(:), allocatable :: i
   end type index_array_t
 
   type :: resonance_history_set_t
      private
      logical :: complete = .false.
      integer :: n_filter = 0
      type(resonance_history_t), dimension(:), allocatable :: history
      type(index_array_t), dimension(:), allocatable :: contains_this
      type(resonance_tree_t), dimension(:), allocatable :: tree
      integer :: last = 0
    contains
    <<Resonances: resonance history set: TBP>>
   end type resonance_history_set_t
 
 @ %def resonance_history_set_t
 @ Display.
 
 The tree-format version of the histories is displayed only upon request.
 <<Resonances: resonance history set: TBP>>=
   procedure :: write => resonance_history_set_write
 <<Resonances: procedures>>=
   subroutine resonance_history_set_write (res_set, unit, indent, show_trees)
     class(resonance_history_set_t), intent(in) :: res_set
     integer, intent(in), optional :: unit
     integer, intent(in), optional :: indent
     logical, intent(in), optional :: show_trees
     logical :: s_trees
     integer :: u, i, j, ind
     u = given_output_unit (unit)
     s_trees = .false.;  if (present (show_trees))  s_trees = show_trees
     ind = 0;  if (present (indent))  ind = indent
     call write_indent (u, indent)
     write (u, "(A)", advance="no")  "Resonance history set:"
     if (res_set%complete) then
        write (u, *)
     else
        write (u, "(1x,A)")  "[incomplete]"
     end if
     do i = 1, res_set%last
        write (u, "(1x,I0,1x)", advance="no")  i
        call res_set%history(i)%write (u, verbose=.false., indent=indent)
        if (allocated (res_set%contains_this)) then
           call write_indent (u, indent)
           write (u, "(3x,A)", advance="no")  "contained in ("
           do j = 1, size (res_set%contains_this(i)%i)
              if (j>1)  write (u, "(',')", advance="no")
              write (u, "(I0)", advance="no")  res_set%contains_this(i)%i(j)
           end do
           write (u, "(A)")  ")"
        end if
        if (s_trees .and. allocated (res_set%tree)) then
           call res_set%tree(i)%write (u, ind + 1)
        end if
     end do
   end subroutine resonance_history_set_write
 
 @ %def resonance_history_set_write
 @ Initialization.  The default initial size is 16 elements, to be doubled in
 size repeatedly as needed.
 <<Resonances: parameters>>=
   integer, parameter :: resonance_history_set_initial_size = 16
 @ %def resonance_history_set_initial_size = 16
 <<Resonances: resonance history set: TBP>>=
   procedure :: init => resonance_history_set_init
 <<Resonances: procedures>>=
   subroutine resonance_history_set_init (res_set, n_filter, initial_size)
     class(resonance_history_set_t), intent(out) :: res_set
     integer, intent(in), optional :: n_filter
     integer, intent(in), optional :: initial_size
     if (present (n_filter))  res_set%n_filter = n_filter
     if (present (initial_size)) then
        allocate (res_set%history (initial_size))
     else
        allocate (res_set%history (resonance_history_set_initial_size))
     end if
   end subroutine resonance_history_set_init
 
 @ %def resonance_history_set_init
 @ Enter an entry: append to the array if it does not yet exist, expand
 as needed.  If a [[n_filter]] value has been provided, enter the
 resonance only if it fulfils the requirement.
 
 An empty resonance history is entered only if the [[trivial]] flag is set.
 <<Resonances: resonance history set: TBP>>=
   procedure :: enter => resonance_history_set_enter
 <<Resonances: procedures>>=
   subroutine resonance_history_set_enter (res_set, res_history, trivial)
     class(resonance_history_set_t), intent(inout) :: res_set
     type(resonance_history_t), intent(in) :: res_history
     logical, intent(in), optional :: trivial
     integer :: i, new
     if (res_history%n_resonances == 0) then
        if (present (trivial)) then
           if (.not. trivial) return
        else
           return
        end if
     end if
     if (res_set%n_filter > 0) then
        if (.not. res_history%only_has_n_contributors (res_set%n_filter))  return
     end if
     do i = 1, res_set%last
        if (res_set%history(i) == res_history)  return
     end do
     new = res_set%last + 1
     if (new > size (res_set%history))  call res_set%expand ()
     res_set%history(new) = res_history
     res_set%last = new
   end subroutine resonance_history_set_enter
 
 @ %def resonance_history_set_enter
 @ Freeze the resonance history set: determine the array that determines
 in which other resonance histories a particular history is contained.
 
 This can only be done once, and once this is done, no further histories can be
 entered.
 <<Resonances: resonance history set: TBP>>=
   procedure :: freeze => resonance_history_set_freeze
 <<Resonances: procedures>>=
   subroutine resonance_history_set_freeze (res_set)
     class(resonance_history_set_t), intent(inout) :: res_set
     integer :: i, n, c
     logical, dimension(:), allocatable :: contains_this
     integer, dimension(:), allocatable :: index_array
     n = res_set%last
     allocate (contains_this (n))
     allocate (index_array (n), source = [(i, i=1, n)])
     allocate (res_set%contains_this (n))
     do i = 1, n
        contains_this = resonance_history_contains &
             (res_set%history(1:n), res_set%history(i))
        c = count (contains_this)
        allocate (res_set%contains_this(i)%i (c))
        res_set%contains_this(i)%i = pack (index_array, contains_this)
     end do
     allocate (res_set%tree (n))
     do i = 1, n
        call res_set%history(i)%to_tree (res_set%tree(i))
     end do
     res_set%complete = .true.
   end subroutine resonance_history_set_freeze
 
 @ %def resonance_history_set_freeze
 @ Determine the histories (in form of their indices in the array) that can be
 considered on-shell, given a set of momenta and a maximum distance.  The
 distance from the resonance is measured in multiples of the resonance width.
 
 Note that the momentum array must only contain the outgoing particles.
 
 If a particular history is on-shell, but there is another history which
 contains this and also is on-shell, only the latter is retained.
 <<Resonances: resonance history set: TBP>>=
   procedure :: determine_on_shell_histories &
        => resonance_history_set_determine_on_shell_histories
 <<Resonances: procedures>>=
   subroutine resonance_history_set_determine_on_shell_histories &
        (res_set, p, on_shell_limit, index_array)
     class(resonance_history_set_t), intent(in) :: res_set
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(in) :: on_shell_limit
     integer, dimension(:), allocatable, intent(out) :: index_array
     integer :: n, i
     integer, dimension(:), allocatable :: i_array
     if (res_set%complete) then
        n = res_set%last
        allocate (i_array (n), source=0)
        do i = 1, n
           if (res_set%history(i)%is_on_shell (p, on_shell_limit))  i_array(i) = i
        end do
        do i = 1, n
           if (any (i_array(res_set%contains_this(i)%i) /= 0)) then
              i_array(i) = 0
           end if
        end do
        allocate (index_array (count (i_array /= 0)))
        index_array(:) = pack (i_array, i_array /= 0)
     end if
   end subroutine resonance_history_set_determine_on_shell_histories
 
 @ %def resonance_history_set_determine_on_shell_histories
 @ For the selected history, compute the Gaussian turnoff factor.
 The turnoff parameter is [[gw]].
 <<Resonances: resonance history set: TBP>>=
   procedure :: evaluate_gaussian => resonance_history_set_evaluate_gaussian
 <<Resonances: procedures>>=
   function resonance_history_set_evaluate_gaussian (res_set, p, gw, i) &
        result (factor)
     class(resonance_history_set_t), intent(in) :: res_set
     type(vector4_t), dimension(:), intent(in) :: p
     real(default), intent(in) :: gw
     integer, intent(in) :: i
     real(default) :: factor
     factor = res_set%history(i)%evaluate_gaussian (p, gw)
   end function resonance_history_set_evaluate_gaussian
 
 @ %def resonance_history_set_evaluate_gaussian
 @ Return the number of histories.  This is zero if there are none, or
 if [[freeze]] has not been called yet.
 <<Resonances: resonance history set: TBP>>=
   procedure :: get_n_history => resonance_history_set_get_n_history
 <<Resonances: procedures>>=
   function resonance_history_set_get_n_history (res_set) result (n)
     class(resonance_history_set_t), intent(in) :: res_set
     integer :: n
     if (res_set%complete) then
        n = res_set%last
     else
        n = 0
     end if
   end function resonance_history_set_get_n_history
 
 @ %def resonance_history_set_get_n_history
 @ Return a single history.
 <<Resonances: resonance history set: TBP>>=
   procedure :: get_history => resonance_history_set_get_history
 <<Resonances: procedures>>=
   function resonance_history_set_get_history (res_set, i) result (res_history)
     class(resonance_history_set_t), intent(in) :: res_set
     integer, intent(in) :: i
     type(resonance_history_t) :: res_history
     if (res_set%complete .and. i <= res_set%last) then
        res_history = res_set%history(i)
     end if
   end function resonance_history_set_get_history
 
 @ %def resonance_history_set_get_history
 @ Conversion to a plain array, sized correctly.
 <<Resonances: resonance history set: TBP>>=
   procedure :: to_array => resonance_history_set_to_array
 <<Resonances: procedures>>=
   subroutine resonance_history_set_to_array (res_set, res_history)
     class(resonance_history_set_t), intent(in) :: res_set
     type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_history
     if (res_set%complete) then
        allocate (res_history (res_set%last))
        res_history(:) = res_set%history(1:res_set%last)
     end if
   end subroutine resonance_history_set_to_array
 
 @ %def resonance_history_set_to_array
 @ Return a selected history in tree form.
 <<Resonances: resonance history set: TBP>>=
   procedure :: get_tree => resonance_history_set_get_tree
 <<Resonances: procedures>>=
   subroutine resonance_history_set_get_tree (res_set, i, res_tree)
     class(resonance_history_set_t), intent(in) :: res_set
     integer, intent(in) :: i
     type(resonance_tree_t), intent(out) :: res_tree
     if (res_set%complete) then
        res_tree = res_set%tree(i)
     end if
   end subroutine resonance_history_set_get_tree
 
 @ %def resonance_history_set_to_array
 @ Expand: double the size of the array.  We do not need this in the API.
 <<Resonances: resonance history set: TBP>>=
   procedure, private :: expand => resonance_history_set_expand
 <<Resonances: procedures>>=
   subroutine resonance_history_set_expand (res_set)
     class(resonance_history_set_t), intent(inout) :: res_set
     type(resonance_history_t), dimension(:), allocatable :: history_new
     integer :: s
     s = size (res_set%history)
     allocate (history_new (2 * s))
     history_new(1:s) = res_set%history(1:s)
     call move_alloc (history_new, res_set%history)
   end subroutine resonance_history_set_expand
 
 @ %def resonance_history_set_expand
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[resonances_ut.f90]]>>=
 <<File header>>
 
 module resonances_ut
   use unit_tests
   use resonances_uti
 
 <<Standard module head>>
 
 <<Resonances: public test>>
 
 contains
 
 <<Resonances: test driver>>
 
 end module resonances_ut
 @ %def resonances_ut
 @
 <<[[resonances_uti.f90]]>>=
 <<File header>>
 
 module resonances_uti
 
 <<Use kinds>>
 <<Use strings>>
   use format_defs, only: FMF_12
   use lorentz, only: vector4_t, vector4_at_rest
   use model_data, only: model_data_t
   use flavors, only: flavor_t
 
   use resonances, only: resonance_history_t
 
   use resonances
 
 <<Standard module head>>
 
 <<Resonances: test declarations>>
 
 contains
 
 <<Resonances: tests>>
 
 end module resonances_uti
 @ %def resonances_ut
 @ API: driver for the unit tests below.
 <<Resonances: public test>>=
   public :: resonances_test
 <<Resonances: test driver>>=
   subroutine resonances_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Resonances: execute tests>>
   end subroutine resonances_test
 
 @  %def resonances_test
 @ Basic operations on a resonance history object.
 <<Resonances: execute tests>>=
   call test (resonances_1, "resonances_1", &
        "check resonance history setup", &
        u, results)
 <<Resonances: test declarations>>=
   public :: resonances_1
 <<Resonances: tests>>=
   subroutine resonances_1 (u)
     integer, intent(in) :: u
     type(resonance_info_t) :: res_info
     type(resonance_history_t) :: res_history
     type(model_data_t), target :: model
 
     write (u, "(A)")  "* Test output: resonances_1"
     write (u, "(A)")  "*   Purpose: test resonance history setup"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Empty resonance history"
     write (u, "(A)")
 
     call res_history%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Add resonance"
     write (u, "(A)")
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Add another resonance"
     write (u, "(A)")
 
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Remove resonance"
     write (u, "(A)")
 
     call res_history%remove_resonance (1)
     call res_history%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: resonances_1"
 
   end subroutine resonances_1
 
 @ %def resonances_1
 @ Basic operations on a resonance history object.
 <<Resonances: execute tests>>=
   call test (resonances_2, "resonances_2", &
        "check O'Mega restriction strings", &
        u, results)
 <<Resonances: test declarations>>=
   public :: resonances_2
 <<Resonances: tests>>=
   subroutine resonances_2 (u)
     integer, intent(in) :: u
     type(resonance_info_t) :: res_info
     type(resonance_history_t) :: res_history
     type(model_data_t), target :: model
     type(string_t) :: restrictions
 
     write (u, "(A)")  "* Test output: resonances_2"
     write (u, "(A)")  "*   Purpose: test OMega restrictions strings &
          &for resonance history"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Empty resonance history"
     write (u, "(A)")
 
     restrictions = res_history%as_omega_string (2)
     write (u, "(A,A,A)")  "restrictions = '", char (restrictions), "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Add resonance"
     write (u, "(A)")
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     restrictions = res_history%as_omega_string (2)
     write (u, "(A,A,A)")  "restrictions = '", char (restrictions), "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Add another resonance"
     write (u, "(A)")
 
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     restrictions = res_history%as_omega_string (2)
     write (u, "(A,A,A)")  "restrictions = '", char (restrictions), "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: resonances_2"
 
   end subroutine resonances_2
 
 @ %def resonances_2
 @ Basic operations on a resonance history set.
 <<Resonances: execute tests>>=
   call test (resonances_3, "resonances_3", &
        "check resonance history set", &
        u, results)
 <<Resonances: test declarations>>=
   public :: resonances_3
 <<Resonances: tests>>=
   subroutine resonances_3 (u)
     integer, intent(in) :: u
     type(resonance_info_t) :: res_info
     type(resonance_history_t) :: res_history
     type(resonance_history_t), dimension(:), allocatable :: res_histories
     type(resonance_history_set_t) :: res_set
     type(model_data_t), target :: model
     integer :: i
 
     write (u, "(A)")  "* Test output: resonances_3"
     write (u, "(A)")  "*   Purpose: test resonance history set"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize resonance history set"
     write (u, "(A)")
 
     call res_set%init (initial_size = 2)
 
     write (u, "(A)")  "* Add resonance histories, one at a time"
     write (u, "(A)")
 
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     write (u, *)
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     write (u, *)
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     write (u, *)
 
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     write (u, *)
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     write (u, *)
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_info%init (7, 25, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_set%freeze ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Result"
     write (u, "(A)")
 
     call res_set%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Queries"
     write (u, "(A)")
 
     write (u, "(A,1x,I0)")  "n_history =", res_set%get_n_history ()
 
     write (u, "(A)")
     write (u, "(A)")  "History #2:"
 
     res_history = res_set%get_history (2)
     call res_history%write (u, indent=1)
     call res_history%clear ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Result in array form"
 
     call res_set%to_array (res_histories)
     do i = 1, size (res_histories)
        write (u, *)
        call res_histories(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-initialize resonance history set with filter n=2"
     write (u, "(A)")
 
     call res_set%init (n_filter = 2)
 
     write (u, "(A)")  "* Add resonance histories, one at a time"
     write (u, "(A)")
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     write (u, *)
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     write (u, *)
 
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     write (u, *)
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_set%freeze ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Result"
     write (u, "(A)")
 
     call res_set%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: resonances_3"
 
   end subroutine resonances_3
 
 @ %def resonances_3
 @ Probe momenta for resonance histories
 <<Resonances: execute tests>>=
   call test (resonances_4, "resonances_4", &
        "resonance history: distance evaluation", &
        u, results)
 <<Resonances: test declarations>>=
   public :: resonances_4
 <<Resonances: tests>>=
   subroutine resonances_4 (u)
     integer, intent(in) :: u
     type(resonance_info_t) :: res_info
     type(resonance_history_t) :: res_history
     type(model_data_t), target :: model
     type(flavor_t) :: fw, fz
     real(default) :: mw, mz, ww, wz
     type(vector4_t), dimension(3) :: p
     real(default), dimension(2) :: dist
     real(default) :: gw, factor
     integer :: i
 
     write (u, "(A)")  "* Test output: resonances_4"
     write (u, "(A)")  "*   Purpose: test resonance history evaluation"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* W and Z parameters"
     write (u, "(A)")
 
     call fw%init (24, model)
     call fz%init (23, model)
     mw = fw%get_mass ()
     ww = fw%get_width ()
     mz = fz%get_mass ()
     wz = fz%get_width ()
 
     write (u, "(A,1x," // FMF_12 // ")")  "mW  =", mw
     write (u, "(A,1x," // FMF_12 // ")")  "wW  =", ww
     write (u, "(A,1x," // FMF_12 // ")")  "mZ  =", mz
     write (u, "(A,1x," // FMF_12 // ")")  "wZ  =", wz
 
     write (u, "(A)")
     write (u, "(A)")  "* Gaussian width parameter"
     write (u, "(A)")
 
     gw = 2
     write (u, "(A,1x," // FMF_12 // ")")  "gw  =", gw
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup resonance histories"
     write (u, "(A)")
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
 
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
 
     call res_history%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup zero momenta"
     write (u, "(A)")
 
     do i = 1, 3
        call p(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate distances from resonances"
     write (u, "(A)")
 
     call res_history%evaluate_distances (p, dist)
     write (u, "(A,1x," // FMF_12 // ")")  "distance (W) =", dist(1)
     write (u, "(A,1x," // FMF_12 // ")")  "m/w (W)      =", mw / ww
     write (u, "(A,1x," // FMF_12 // ")")  "distance (Z) =", dist(2)
     write (u, "(A,1x," // FMF_12 // ")")  "m/w (Z)      =", mz / wz
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate Gaussian turnoff factor"
     write (u, "(A)")
 
     factor = res_history%evaluate_gaussian (p, gw)
     write (u, "(A,1x," // FMF_12 // ")")  "gaussian fac =", factor
 
     write (u, "(A)")
     write (u, "(A)")  "* Set momenta on W peak"
     write (u, "(A)")
 
     p(1) = vector4_at_rest (mw/2)
     p(2) = vector4_at_rest (mw/2)
     do i = 1, 3
        call p(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate distances from resonances"
     write (u, "(A)")
 
     call res_history%evaluate_distances (p, dist)
     write (u, "(A,1x," // FMF_12 // ")")  "distance (W) =", dist(1)
     write (u, "(A,1x," // FMF_12 // ")")  "distance (Z) =", dist(2)
     write (u, "(A,1x," // FMF_12 // ")")  "expected     =", &
          abs (mz**2 - mw**2) / (mz*wz)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate Gaussian turnoff factor"
     write (u, "(A)")
 
     factor = res_history%evaluate_gaussian (p, gw)
     write (u, "(A,1x," // FMF_12 // ")")  "gaussian fac =", factor
     write (u, "(A,1x," // FMF_12 // ")")  "expected     =", &
          exp (- (abs (mz**2 - mw**2) / (mz*wz))**2 / (gw * wz)**2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set momenta on both peaks"
     write (u, "(A)")
 
     p(3) = vector4_at_rest (mz - mw)
     do i = 1, 3
        call p(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate distances from resonances"
     write (u, "(A)")
 
     call res_history%evaluate_distances (p, dist)
     write (u, "(A,1x," // FMF_12 // ")")  "distance (W) =", dist(1)
     write (u, "(A,1x," // FMF_12 // ")")  "distance (Z) =", dist(2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate Gaussian turnoff factor"
     write (u, "(A)")
 
     factor = res_history%evaluate_gaussian (p, gw)
     write (u, "(A,1x," // FMF_12 // ")")  "gaussian fac =", factor
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: resonances_4"
 
   end subroutine resonances_4
 
 @ %def resonances_4
 @ Probe on-shell test for resonance histories
 <<Resonances: execute tests>>=
   call test (resonances_5, "resonances_5", &
        "resonance history: on-shell test", &
        u, results)
 <<Resonances: test declarations>>=
   public :: resonances_5
 <<Resonances: tests>>=
   subroutine resonances_5 (u)
     integer, intent(in) :: u
     type(resonance_info_t) :: res_info
     type(resonance_history_t) :: res_history
     type(resonance_history_set_t) :: res_set
     type(model_data_t), target :: model
     type(flavor_t) :: fw, fz
     real(default) :: mw, mz, ww, wz
     real(default) :: on_shell_limit
     integer, dimension(:), allocatable :: on_shell
     type(vector4_t), dimension(4) :: p
 
     write (u, "(A)")  "* Test output: resonances_5"
     write (u, "(A)")  "*   Purpose: resonance history on-shell test"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* W and Z parameters"
     write (u, "(A)")
 
     call fw%init (24, model)
     call fz%init (23, model)
     mw = fw%get_mass ()
     ww = fw%get_width ()
     mz = fz%get_mass ()
     wz = fz%get_width ()
 
     write (u, "(A,1x," // FMF_12 // ")")  "mW  =", mw
     write (u, "(A,1x," // FMF_12 // ")")  "wW  =", ww
     write (u, "(A,1x," // FMF_12 // ")")  "mZ  =", mz
     write (u, "(A,1x," // FMF_12 // ")")  "wZ  =", wz
 
     write (u, "(A)")
     write (u, "(A)")  "* On-shell parameter: distance as multiple of width"
     write (u, "(A)")
 
     on_shell_limit = 3
     write (u, "(A,1x," // FMF_12 // ")")  "on-shell limit =", on_shell_limit
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup resonance history set"
     write (u, "(A)")
 
     call res_set%init ()
 
     call res_info%init (3, -24, model, 6)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_info%init (12, 24, model, 6)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_info%init (15, 23, model, 6)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_info%init (3, -24, model, 6)
     call res_history%add_resonance (res_info)
     call res_info%init (15, 23, model, 6)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_info%init (12, 24, model, 6)
     call res_history%add_resonance (res_info)
     call res_info%init (15, 23, model, 6)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_set%freeze ()
     call res_set%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup zero momenta"
     write (u, "(A)")
 
     call write_momenta (p)
 
     call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
     call write_on_shell_histories (on_shell)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup momenta near W- resonance (2 widths off)"
     write (u, "(A)")
 
     p(1) = vector4_at_rest (82.5_default)
     call write_momenta (p)
 
     call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
     call write_on_shell_histories (on_shell)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup momenta near W- resonance (4 widths off)"
     write (u, "(A)")
 
     p(1) = vector4_at_rest (84.5_default)
     call write_momenta (p)
 
     call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
     call write_on_shell_histories (on_shell)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup momenta near Z resonance"
     write (u, "(A)")
 
     p(1) = vector4_at_rest (45._default)
     p(3) = vector4_at_rest (45._default)
     call write_momenta (p)
 
     call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
     call write_on_shell_histories (on_shell)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup momenta near W- and W+ resonances"
     write (u, "(A)")
 
     p(1) = vector4_at_rest (40._default)
     p(2) = vector4_at_rest (40._default)
     p(3) = vector4_at_rest (40._default)
     p(4) = vector4_at_rest (40._default)
     call write_momenta (p)
 
     call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
     call write_on_shell_histories (on_shell)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup momenta near W- and Z resonances, &
          &shadowing single resonances"
     write (u, "(A)")
 
     p(1) = vector4_at_rest (40._default)
     p(2) = vector4_at_rest (40._default)
     p(3) = vector4_at_rest (10._default)
     p(4) = vector4_at_rest ( 0._default)
     call write_momenta (p)
 
     call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
     call write_on_shell_histories (on_shell)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: resonances_5"
 
   contains
 
     subroutine write_momenta (p)
       type(vector4_t), dimension(:), intent(in) :: p
       integer :: i
       do i = 1, size (p)
          call p(i)%write (u)
       end do
     end subroutine write_momenta
 
     subroutine write_on_shell_histories (on_shell)
       integer, dimension(:), intent(in) :: on_shell
       integer :: i
       write (u, *)
       write (u, "(A)", advance="no")  "on-shell = ("
       do i = 1, size (on_shell)
          if (i > 1)  write (u, "(',')", advance="no")
          write (u, "(I0)", advance="no")  on_shell(i)
       end do
       write (u, "(')')")
     end subroutine write_on_shell_histories
 
   end subroutine resonances_5
 
 @ %def resonances_5
 @ Organize the resonance history as a tree structure.
 <<Resonances: execute tests>>=
   call test (resonances_6, "resonances_6", &
        "check resonance history setup", &
        u, results)
 <<Resonances: test declarations>>=
   public :: resonances_6
 <<Resonances: tests>>=
   subroutine resonances_6 (u)
     integer, intent(in) :: u
     type(resonance_info_t) :: res_info
     type(resonance_history_t) :: res_history
     type(resonance_tree_t) :: res_tree
     type(model_data_t), target :: model
 
     write (u, "(A)")  "* Test output: resonances_6"
     write (u, "(A)")  "*   Purpose: retrieve resonance histories as trees"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Empty resonance history"
     write (u, "(A)")
 
     call res_history%write (u)
 
     write (u, "(A)")
     call res_history%to_tree (res_tree)
     call res_tree%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Single resonance"
     write (u, "(A)")
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
 
     write (u, "(A)")
     call res_history%to_tree (res_tree)
     call res_tree%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Nested resonances"
     write (u, "(A)")
 
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%write (u)
 
     write (u, "(A)")
     call res_history%to_tree (res_tree)
     call res_tree%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Disjunct resonances"
     write (u, "(A)")
 
     call res_history%clear ()
 
     call res_info%init (5, 24, model, 7)
     call res_history%add_resonance (res_info)
 
     call res_info%init (7, 6, model, 7)
     call res_history%add_resonance (res_info)
 
     call res_info%init (80, -24, model, 7)
     call res_history%add_resonance (res_info)
 
     call res_info%init (112, -6, model, 7)
     call res_history%add_resonance (res_info)
 
     call res_history%write (u)
 
     write (u, "(A)")
     call res_history%to_tree (res_tree)
     call res_tree%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: resonances_6"
 
   end subroutine resonances_6
 
 @ %def resonances_6
 @ Basic operations on a resonance history set.
 <<Resonances: execute tests>>=
   call test (resonances_7, "resonances_7", &
        "display tree format of history set elements", &
        u, results)
 <<Resonances: test declarations>>=
   public :: resonances_7
 <<Resonances: tests>>=
   subroutine resonances_7 (u)
     integer, intent(in) :: u
     type(resonance_info_t) :: res_info
     type(resonance_history_t) :: res_history
     type(resonance_tree_t) :: res_tree
     type(resonance_history_set_t) :: res_set
     type(model_data_t), target :: model
     type(flavor_t) :: flv
 
     write (u, "(A)")  "* Test output: resonances_7"
     write (u, "(A)")  "*   Purpose: test tree format"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize, fill and freeze resonance history set"
     write (u, "(A)")
 
     call res_set%init (initial_size = 2)
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_history%clear ()
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_info%init (7, 23, model, 5)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_info%init (3, -24, model, 5)
     call res_history%add_resonance (res_info)
     call res_info%init (7, 25, model, 5)
     call res_history%add_resonance (res_info)
     call res_set%enter (res_history)
     call res_history%clear ()
 
     call res_set%freeze ()
 
     call res_set%write (u, show_trees = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract tree #1"
     write (u, "(A)")
 
     call res_set%get_tree (1, res_tree)
     call res_tree%write (u)
 
     write (u, *)
     write (u, "(1x,A,1x,I0)")  "n_resonances =", res_tree%get_n_resonances ()
 
     write (u, *)
     write (u, "(1x,A,1x)", advance="no")  "flv(r1) ="
     flv = res_tree%get_flv (1)
     call flv%write (u)
     write (u, *)
     write (u, "(1x,A,1x)", advance="no")  "flv(r2) ="
     flv = res_tree%get_flv (2)
     call flv%write (u)
     write (u, *)
 
     write (u, *)
     write (u, "(1x,A)")  "[offset = 2, 4]"
     write (u, "(1x,A,9(1x,I0))")  "children(r1) =", &
          res_tree%get_children(1, 2, 4)
     write (u, "(1x,A,9(1x,I0))")  "children(r2) =", &
          res_tree%get_children(2, 2, 4)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: resonances_7"
 
   end subroutine resonances_7
 
 @ %def resonances_7
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \clearpage
 \section{Mappings}
 
 Mappings are objects that encode the transformation of the interval
 $(0,1)$ to a physical variable $m^2$ or $\cos\theta$ (and back), as it
 is used in the phase space parameterization.  The mapping objects
 contain fixed parameters, the associated methods implement the mapping
 and inverse mapping operations, including the computation of the
 Jacobian (phase space factor).
 <<[[mappings.f90]]>>=
 <<File header>>
 
 module mappings
 
 <<Use kinds>>
   use kinds, only: TC
 <<Use strings>>
   use io_units
   use constants, only: pi
   use format_defs, only: FMT_19
   use diagnostics
   use md5
   use model_data
   use flavors
 
 <<Standard module head>>
 
 <<Mappings: public>>
 
 <<Mappings: parameters>>
 
 <<Mappings: types>>
 
 <<Mappings: interfaces>>
 
 contains
 
 <<Mappings: procedures>>
 
 end module mappings
 @ %def mappings
 @
 \subsection{Default parameters}
 This type holds the default parameters, needed for setting the scale
 in cases where no mass parameter is available.  The contents are public.
 <<Mappings: public>>=
   public :: mapping_defaults_t
 <<Mappings: types>>=
   type :: mapping_defaults_t
      real(default) :: energy_scale = 10
      real(default) :: invariant_mass_scale = 10
      real(default) :: momentum_transfer_scale = 10
      logical :: step_mapping = .true.
      logical :: step_mapping_exp = .true.
      logical :: enable_s_mapping = .false.
    contains
    <<Mappings: mapping defaults: TBP>>
   end type mapping_defaults_t
 
 @ %def mapping_defaults_t
 @ Output.
 <<Mappings: mapping defaults: TBP>>=
   procedure :: write => mapping_defaults_write
 <<Mappings: procedures>>=
   subroutine mapping_defaults_write (object, unit)
     class(mapping_defaults_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A," // FMT_19 // ")") "energy scale  = ", &
          object%energy_scale
     write (u, "(3x,A," // FMT_19 // ")") "mass scale    = ", &
          object%invariant_mass_scale
     write (u, "(3x,A," // FMT_19 // ")") "q scale       = ", &
          object%momentum_transfer_scale
     write (u, "(3x,A,L1)") "step mapping     = ", &
          object%step_mapping
     write (u, "(3x,A,L1)") "step exp. mode   = ", &
          object%step_mapping_exp
     write (u, "(3x,A,L1)") "allow s mapping  = ", &
          object%enable_s_mapping
   end subroutine mapping_defaults_write
 
 @ %def mapping_defaults_write
 @
 <<Mappings: public>>=
   public :: mapping_defaults_md5sum
 <<Mappings: procedures>>=
   function mapping_defaults_md5sum (mapping_defaults) result (md5sum_map)
     character(32) :: md5sum_map
     type(mapping_defaults_t), intent(in) :: mapping_defaults
     integer :: u
     u = free_unit ()
     open (u, status = "scratch")
     write (u, *)  mapping_defaults%energy_scale
     write (u, *)  mapping_defaults%invariant_mass_scale
     write (u, *)  mapping_defaults%momentum_transfer_scale
     write (u, *)  mapping_defaults%step_mapping
     write (u, *)  mapping_defaults%step_mapping_exp
     write (u, *)  mapping_defaults%enable_s_mapping
     rewind (u)
     md5sum_map = md5sum (u)
     close (u)
   end function mapping_defaults_md5sum
 
 @ %def mapping_defaults_md5sum
 @
 \subsection{The Mapping type}
 Each mapping has a type (e.g., s-channel, infrared), a binary code
 (redundant, but useful for debugging), and a reference particle.  The
 flavor code of this particle is stored for bookkeeping reasons, what
 matters are the mass and width of this particle.  Furthermore,
 depending on the type, various mapping parameters can be set and used.
 
 The parameters [[a1]] to [[a3]] (for $m^2$ mappings) and [[b1]] to
 [[b3]] (for $\cos\theta$ mappings) are values that are stored once to
 speed up the calculation, if [[variable_limits]] is false.  The exact
 meaning of these parameters depends on the mapping type.  The limits
 are fixed if there is a fixed c.m. energy.
 <<Mappings: public>>=
   public :: mapping_t
 <<Mappings: types>>=
   type :: mapping_t
      private
      integer :: type = NO_MAPPING
      integer(TC) :: bincode
      type(flavor_t) :: flv
      real(default) :: mass = 0
      real(default) :: width = 0
      logical :: a_unknown = .true.
      real(default) :: a1 = 0
      real(default) :: a2 = 0
      real(default) :: a3 = 0
      logical :: b_unknown = .true.
      real(default) :: b1 = 0
      real(default) :: b2 = 0
      real(default) :: b3 = 0
      logical :: variable_limits = .true.
    contains
    <<Mappings: mapping: TBP>>
   end type mapping_t
 
 @ %def mapping_t
 @ The valid mapping types.  The extra type [[STEP_MAPPING]] is used
 only internally.
 <<Mappings: parameters>>=
 <<Mapping modes>>
 @
 \subsection{Screen output}
 Do not write empty mappings.
 <<Mappings: public>>=
   public :: mapping_write
 <<Mappings: procedures>>=
   subroutine mapping_write (map, unit, verbose)
     type(mapping_t), intent(in) :: map
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     character(len=9) :: str
     u = given_output_unit (unit);  if (u < 0)  return
     select case(map%type)
     case(S_CHANNEL); str = "s_channel"
     case(COLLINEAR); str = "collinear"
     case(INFRARED);  str = "infrared "
     case(RADIATION); str = "radiation"
     case(T_CHANNEL); str = "t_channel"
     case(U_CHANNEL); str = "u_channel"
     case(STEP_MAPPING_E);  str = "step_exp"
     case(STEP_MAPPING_H);  str = "step_hyp"
     case(ON_SHELL);  str = "on_shell"
     case default;    str = "????????"
     end select
     if (map%type /= NO_MAPPING) then
        write (u, '(1x,A,I4,A)') &
             "Branch #", map%bincode, ":  " // &
             "Mapping (" // str // ") for particle " // &
             '"' // char (map%flv%get_name ()) // '"'
        if (present (verbose)) then
           if (verbose) then
              select case (map%type)
              case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H)
                 write (u, "(1x,A,3(" // FMT_19 // "))")  &
                      "  m/w    = ", map%mass, map%width
              case default
                 write (u, "(1x,A,3(" // FMT_19 // "))")  &
                      "  m      = ", map%mass
              end select
              select case (map%type)
              case (S_CHANNEL, T_CHANNEL, U_CHANNEL, &
                   STEP_MAPPING_E, STEP_MAPPING_H, &
                   COLLINEAR, INFRARED, RADIATION)
                 write (u, "(1x,A,3(" // FMT_19 // "))")  &
                      "  a1/2/3 = ", map%a1, map%a2, map%a3
              end select
              select case (map%type)
              case (T_CHANNEL, U_CHANNEL, COLLINEAR)
                 write (u, "(1x,A,3(" // FMT_19 // "))")  &
                      "  b1/2/3 = ", map%b1, map%b2, map%b3
              end select
           end if
        end if
     end if
   end subroutine mapping_write
 
 @ %def mapping_write
 @
 \subsection{Define a mapping}
 The initialization routine sets the mapping type and the particle
 (binary code and flavor code) for which the mapping applies (e.g., a
 $Z$ resonance in branch \#3).
 <<Mappings: public>>=
   public :: mapping_init
 <<Mappings: procedures>>=
   subroutine mapping_init (mapping, bincode, type, f, model)
     type(mapping_t), intent(inout) :: mapping
     integer(TC), intent(in) :: bincode
     type(string_t), intent(in) :: type
     integer, intent(in), optional :: f
     class(model_data_t), intent(in), optional, target :: model
     mapping%bincode = bincode
     select case (char (type))
     case ("s_channel");  mapping%type = S_CHANNEL
     case ("collinear");  mapping%type = COLLINEAR
     case ("infrared");   mapping%type = INFRARED
     case ("radiation");  mapping%type = RADIATION
     case ("t_channel");  mapping%type = T_CHANNEL
     case ("u_channel");  mapping%type = U_CHANNEL
     case ("step_exp");  mapping%type = STEP_MAPPING_E
     case ("step_hyp");  mapping%type = STEP_MAPPING_H
     case ("on_shell");  mapping%type = ON_SHELL
     case default
        call msg_bug ("Mappings: encountered undefined mapping key '" &
             // char (type) // "'")
     end select
     if (present (f) .and. present (model))  call mapping%flv%init (f, model)
   end subroutine mapping_init
 
 @ %def mapping_init
 @ This sets the actual mass and width, using a parameter set.  Since
 the auxiliary parameters will only be determined when the mapping is
 first called, they are marked as unknown.
 <<Mappings: public>>=
   public :: mapping_set_parameters
 <<Mappings: procedures>>=
   subroutine mapping_set_parameters (map, mapping_defaults, variable_limits)
     type(mapping_t), intent(inout) :: map
     type(mapping_defaults_t), intent(in) :: mapping_defaults
     logical, intent(in) :: variable_limits
     if (map%type /= NO_MAPPING) then
        map%mass  = map%flv%get_mass ()
        map%width = map%flv%get_width ()
        map%variable_limits = variable_limits
        map%a_unknown = .true.
        map%b_unknown = .true.
        select case (map%type)
        case (S_CHANNEL)
           if (map%mass <= 0) then
              call mapping_write (map)
              call msg_fatal &
                   & (" S-channel resonance must have positive mass")
           else if (map%width <= 0) then
              call mapping_write (map)
              call msg_fatal &
                   & (" S-channel resonance must have positive width")
           end if
        case (RADIATION)
           map%width = max (map%width, mapping_defaults%energy_scale)
        case (INFRARED, COLLINEAR)
           map%mass = max (map%mass, mapping_defaults%invariant_mass_scale)
        case (T_CHANNEL, U_CHANNEL)
           map%mass = max (map%mass, mapping_defaults%momentum_transfer_scale)
        end select
     end if
   end subroutine mapping_set_parameters
 
 @ %def mapping_set_code mapping_set_parameters
 @ For a step mapping the mass and width are set directly, instead of
 being determined from the flavor parameter (which is meaningless
 here).  They correspond to the effective upper bound of phase space
 due to a resonance, as opposed to the absolute upper bound.
 <<Mappings: public>>=
   public :: mapping_set_step_mapping_parameters
 <<Mappings: procedures>>=
   subroutine mapping_set_step_mapping_parameters (map, &
        mass, width, variable_limits)
     type(mapping_t), intent(inout) :: map
     real(default), intent(in) :: mass, width
     logical, intent(in) :: variable_limits
     select case (map%type)
     case (STEP_MAPPING_E, STEP_MAPPING_H)
        map%variable_limits = variable_limits
        map%a_unknown = .true.
        map%b_unknown = .true.
        map%mass = mass
        map%width = width
     end select
   end subroutine mapping_set_step_mapping_parameters
 
 @ %def mapping_set_step_mapping_parameters
 @
 \subsection{Retrieve contents}
 Return true if there is any / an s-channel mapping.
 <<Mappings: public>>=
   public :: mapping_is_set
   public :: mapping_is_s_channel
   public :: mapping_is_on_shell
 <<Mappings: mapping: TBP>>=
   procedure :: is_set => mapping_is_set
   procedure :: is_s_channel => mapping_is_s_channel
   procedure :: is_on_shell => mapping_is_on_shell
 <<Mappings: procedures>>=
   function mapping_is_set (mapping) result (flag)
     class(mapping_t), intent(in) :: mapping
     logical :: flag
     flag = mapping%type /= NO_MAPPING
   end function mapping_is_set
 
   function mapping_is_s_channel (mapping) result (flag)
     class(mapping_t), intent(in) :: mapping
     logical :: flag
     flag = mapping%type == S_CHANNEL
   end function mapping_is_s_channel
 
   function mapping_is_on_shell (mapping) result (flag)
     class(mapping_t), intent(in) :: mapping
     logical :: flag
     flag = mapping%type == ON_SHELL
   end function mapping_is_on_shell
 
 @ %def mapping_is_set
 @ %def mapping_is_s_channel
 @ %def mapping_is_on_shell
 @ Return the binary code for the mapped particle.
 <<Mappings: mapping: TBP>>=
   procedure :: get_bincode => mapping_get_bincode
 <<Mappings: procedures>>=
   function mapping_get_bincode (mapping) result (bincode)
     class(mapping_t), intent(in) :: mapping
     integer(TC) :: bincode
     bincode = mapping%bincode
   end function mapping_get_bincode
 
 @ %def mapping_get_bincode
 @ Return the flavor object for the mapped particle.
 <<Mappings: mapping: TBP>>=
   procedure :: get_flv => mapping_get_flv
 <<Mappings: procedures>>=
   function mapping_get_flv (mapping) result (flv)
     class(mapping_t), intent(in) :: mapping
     type(flavor_t) :: flv
     flv = mapping%flv
   end function mapping_get_flv
 
 @ %def mapping_get_flv
 @ Return stored mass and width, respectively.
 <<Mappings: public>>=
   public :: mapping_get_mass
   public :: mapping_get_width
 <<Mappings: procedures>>=
   function mapping_get_mass (mapping) result (mass)
     real(default) :: mass
     type(mapping_t), intent(in) :: mapping
     mass = mapping%mass
   end function mapping_get_mass
 
   function mapping_get_width (mapping) result (width)
     real(default) :: width
     type(mapping_t), intent(in) :: mapping
     width = mapping%width
   end function mapping_get_width
 
 @ %def mapping_get_mass
 @ %def mapping_get_width
 @
 \subsection{Compare mappings}
 Equality for single mappings and arrays
 <<Mappings: public>>=
   public :: operator(==)
 <<Mappings: interfaces>>=
   interface operator(==)
      module procedure mapping_equal
   end interface
 <<Mappings: procedures>>=
   function mapping_equal (m1, m2) result (equal)
     type(mapping_t), intent(in) :: m1, m2
     logical :: equal
     if (m1%type == m2%type) then
        select case (m1%type)
        case (NO_MAPPING)
           equal = .true.
        case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H)
           equal = (m1%mass == m2%mass) .and. (m1%width == m2%width)
        case default
           equal = (m1%mass == m2%mass)
        end select
     else
        equal = .false.
     end if
   end function mapping_equal
 
 @ %def mapping_equal
 @
 \subsection{Mappings of the invariant mass}
 Inserting an $x$ value between 0 and 1, we want to compute the
 corresponding invariant mass $m^2(x)$ and the jacobian, aka phase
 space factor $f(x)$.  We also need the reverse operation.
 
 In general, the phase space factor $f$ is defined by
 \begin{equation}
   \frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2)
   = \int_0^1 dx\,\frac{1}{s}\,\frac{dm^2}{dx}\,g(m^2(x))
   = \int_0^1 dx\,f(x)\,g(x),
 \end{equation}
 where thus
 \begin{equation}
   f(x) = \frac{1}{s}\,\frac{dm^2}{dx}.
 \end{equation}
 With this mapping, a function of the form
 \begin{equation}
   g(m^2) = c\frac{dx(m^2)}{dm^2}
 \end{equation}
 is mapped to a constant:
 \begin{equation}
   \frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2)
   = \int_0^1 dx\,f(x)\,g(m^2(x)) = \int_0^1 dx\,\frac{c}{s}.
 \end{equation}
 
 Here is the mapping routine.  Input are the available energy
 squared [[s]], the limits for $m^2$, and the $x$ value.  Output are
 the $m^2$ value and the phase space factor $f$.
 <<Mappings: public>>=
   public :: mapping_compute_msq_from_x
 <<Mappings: procedures>>=
   subroutine mapping_compute_msq_from_x (map, s, msq_min, msq_max, msq, f, x)
     type(mapping_t), intent(inout) :: map
     real(default), intent(in) :: s, msq_min, msq_max
     real(default), intent(out) :: msq, f
     real(default), intent(in) :: x
     real(default) :: z, msq0, msq1, tmp
     integer :: type
     type = map%type
     if (s == 0) &
          call msg_fatal (" Applying msq mapping for zero energy")
   <<Modify mapping type if necessary>>
     select case(type)
     case (NO_MAPPING)
      <<Constants for trivial msq mapping>>
      <<Apply trivial msq mapping>>
     case (S_CHANNEL)
      <<Constants for s-channel resonance mapping>>
      <<Apply s-channel resonance mapping>>
     case (COLLINEAR, INFRARED, RADIATION)
      <<Constants for s-channel pole mapping>>
      <<Apply s-channel pole mapping>>
     case (T_CHANNEL, U_CHANNEL)
      <<Constants for t-channel pole mapping>>
      <<Apply t-channel pole mapping>>
     case (STEP_MAPPING_E)
      <<Constants for exponential step mapping>>
      <<Apply exponential step mapping>>
     case (STEP_MAPPING_H)
      <<Constants for hyperbolic step mapping>>
      <<Apply hyperbolic step mapping>>
     case default
        call msg_fatal ( " Attempt to apply undefined msq mapping")
     end select
   end subroutine mapping_compute_msq_from_x
 
 @ %def mapping_compute_msq_from_x
 @ The inverse mapping
 <<Mappings: public>>=
   public :: mapping_compute_x_from_msq
 <<Mappings: procedures>>=
   subroutine mapping_compute_x_from_msq (map, s, msq_min, msq_max, msq, f, x)
     type(mapping_t), intent(inout) :: map
     real(default), intent(in) :: s, msq_min, msq_max
     real(default), intent(in) :: msq
     real(default), intent(out) :: f, x
     real(default) :: msq0, msq1, tmp, z
     integer :: type
     type = map%type
     if (s == 0) &
          call msg_fatal (" Applying inverse msq mapping for zero energy")
   <<Modify mapping type if necessary>>
     select case (type)
     case (NO_MAPPING)
      <<Constants for trivial msq mapping>>
      <<Apply inverse trivial msq mapping>>
     case (S_CHANNEL)
      <<Constants for s-channel resonance mapping>>
      <<Apply inverse s-channel resonance mapping>>
     case (COLLINEAR, INFRARED, RADIATION)
      <<Constants for s-channel pole mapping>>
      <<Apply inverse s-channel pole mapping>>
     case (T_CHANNEL, U_CHANNEL)
      <<Constants for t-channel pole mapping>>
      <<Apply inverse t-channel pole mapping>>
     case (STEP_MAPPING_E)
      <<Constants for exponential step mapping>>
      <<Apply inverse exponential step mapping>>
     case (STEP_MAPPING_H)
      <<Constants for hyperbolic step mapping>>
      <<Apply inverse hyperbolic step mapping>>
     case default
        call msg_fatal ( " Attempt to apply undefined msq mapping")
     end select
   end subroutine mapping_compute_x_from_msq
 
 @ %def mapping_compute_x_from_msq
 @
 \subsubsection{Trivial mapping}
 We simply map the boundaries of the interval $(m_{\textrm{min}},
 m_{\textrm{max}})$ to $(0,1)$:
 \begin{equation}
   m^2 = (1-x) m_{\textrm{min}}^2 + x m_{\textrm{max}}^2;
 \end{equation}
 the inverse is
 \begin{equation}
   x = \frac{m^2 - m_{\textrm{min}}^2}{m_{\textrm{max}}^2- m_{\textrm{min}}^2}.
 \end{equation}
 Hence
 \begin{equation}
   f(x) = \frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{s},
 \end{equation}
 and we have, as required,
 \begin{equation}
   f(x)\,\frac{dx}{dm^2} = \frac{1}{s}.
 \end{equation}
 
 We store the constant parameters the first time the mapping is called
 -- or, if limits vary, recompute them each time.
 <<Constants for trivial msq mapping>>=
   if (map%variable_limits .or. map%a_unknown) then
      map%a1 = 0
      map%a2 = msq_max - msq_min
      map%a3 = map%a2 / s
      map%a_unknown = .false.
   end if
 <<Apply trivial msq mapping>>=
   msq = (1-x) * msq_min + x * msq_max
   f = map%a3
 <<Apply inverse trivial msq mapping>>=
   if (map%a2 /= 0) then
      x = (msq - msq_min) / map%a2
   else
      x = 0
   end if
   f = map%a3
 @ Resonance or step mapping does not make much sense if the resonance mass is
 outside the kinematical bounds.  If this is the case, revert to
 [[NO_MAPPING]].  This is possible even if the kinematical bounds vary
 from event to event.
 <<Modify mapping type if necessary>>=
   select case (type)
   case (S_CHANNEL, STEP_MAPPING_E, STEP_MAPPING_H)
      msq0 = map%mass**2
      if (msq0 < msq_min .or. msq0 > msq_max)  type = NO_MAPPING
   end select
 @
 \subsubsection{Breit-Wigner mapping}
 A Breit-Wigner resonance with mass $M$ and width $\Gamma$ is flattened
 by the following mapping:
 
 This mapping does not make much sense if the resonance mass is too low.
 If this is the case, revert to [[NO_MAPPING]].  There is a tricky
 point with this if the mass is too high: [[msq_max]] is not a
 constant if structure functions are around.  However, switching the
 type depending on the overall energy does not change the integral, it
 is just another branching point.
 \begin{equation}
   m^2 = M(M+t\Gamma),
 \end{equation}
 where
 \begin{equation}
   t = \tan\left[(1-x)\arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}
                 + x  \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}\right].
 \end{equation}
 The inverse:
 \begin{equation}
   x = \frac{  \arctan\frac{m^2 - M^2}{M\Gamma}
             - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}}
            {  \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}
             - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}}
 \end{equation}
 The phase-space factor of this transformation is
 \begin{equation}
   f(x) = \frac{M\Gamma}{s}\left(
            \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}
          - \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}\right)
          (1 + t^2).
 \end{equation}
 This maps any function proportional to
 \begin{equation}
   g(m^2) = \frac{M\Gamma}{(m^2-M^2)^2 + M^2\Gamma^2}
 \end{equation}
 to a constant times $1/s$.
 <<Constants for s-channel resonance mapping>>=
   if (map%variable_limits .or. map%a_unknown) then
      msq0 = map%mass ** 2
      map%a1 = atan ((msq_min - msq0) / (map%mass * map%width))
      map%a2 = atan ((msq_max - msq0) / (map%mass * map%width))
      map%a3 = (map%a2 - map%a1) * (map%mass * map%width) / s
      map%a_unknown = .false.
   end if
 <<Apply s-channel resonance mapping>>=
   z = (1-x) * map%a1 + x * map%a2
   if (-pi/2 < z .and. z < pi/2) then
      tmp = tan (z)
      msq = map%mass * (map%mass + map%width * tmp)
      f = map%a3 * (1 + tmp**2)
   else
      msq = 0
      f = 0
   end if
 <<Apply inverse s-channel resonance mapping>>=
   tmp = (msq - msq0) / (map%mass * map%width)
   x = (atan (tmp) - map%a1) / (map%a2 - map%a1)
   f = map%a3 * (1 + tmp**2)
 @
 \subsubsection{Mapping for massless splittings}
 This mapping accounts for approximately scale-invariant behavior where
 $\ln M^2$ is evenly distributed.
 \begin{equation}
   m^2 = m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right)
 \end{equation}
 where
 \begin{equation}
   L = \ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{M^2} + 1\right).
 \end{equation}
 The inverse:
 \begin{equation}
   x = \frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right)
 \end{equation}
 The constant $M$ is a characteristic scale.  Above this scale
 ($m^2-m_{\textrm{min}}^2 \gg M^2$), this mapping behaves like
 $x\propto\ln m^2$, while below the scale it reverts to a linear
 mapping.
 
 The phase-space factor is
 \begin{equation}
   f(x) = \frac{M^2}{s}\,\exp(xL)\,L.
 \end{equation}
 A function proportional to
 \begin{equation}
   g(m^2) = \frac{1}{(m^2-m_{\textrm{min}}^2) + M^2}
 \end{equation}
 is mapped to a constant, i.e., a simple pole near $m_{\textrm{min}}$
 with a regulator mass $M$.
 
 This type of mapping is useful for massless collinear and infrared
 singularities, where the scale is stored as the mass parameter.  In
 the radiation case (IR radiation off massive particle), the heavy
 particle width is the characteristic scale.
 <<Constants for s-channel pole mapping>>=
   if (map%variable_limits .or. map%a_unknown) then
      if (type == RADIATION) then
         msq0 = map%width**2
      else
         msq0 = map%mass**2
      end if
      map%a1 = msq0
      map%a2 = log ((msq_max - msq_min) / msq0 + 1)
      map%a3 = map%a2 / s
      map%a_unknown = .false.
   end if
 <<Apply s-channel pole mapping>>=
   msq1 = map%a1 * exp (x * map%a2)
   msq = msq1 - map%a1 + msq_min
   f = map%a3 * msq1
 <<Apply inverse s-channel pole mapping>>=
   msq1 = msq - msq_min + map%a1
   x = log (msq1 / map%a1) / map%a2
   f = map%a3 * msq1
 @
 \subsubsection{Mapping for t-channel poles}
 This is also approximately scale-invariant, and we use the same type
 of mapping as before.  However, we map $1/x$ singularities at both
 ends of the interval; again, the mapping becomes linear when the
 distance is less than $M^2$:
 \begin{equation}
   m^2 =
   \begin{cases}
     m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right)
     &
     \text{for $0 < x < \frac12$}
     \\
     m_{\textrm{max}}^2 - M^2\left(\exp((1-x)L)-1\right)
     &
     \text{for $\frac12 \leq x < 1$}
   \end{cases}
 \end{equation}
 where
 \begin{equation}
   L = 2\ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{2M^2}
                 + 1\right).
 \end{equation}
 The inverse:
 \begin{equation}
   x =
   \begin{cases}
     \frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right)
     &
     \text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
     \\
     1 - \frac1L\ln\left(\frac{m_{\textrm{max}}-m^2}{M^2} + 1\right)
     &
     \text{for $m^2 \geq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
   \end{cases}
 \end{equation}
 The phase-space factor is
 \begin{equation}
   f(x) =
   \begin{cases}
     \frac{M^2}{s}\,\exp(xL)\,L.
     &
     \text{for $0 < x < \frac12$}
     \\
     \frac{M^2}{s}\,\exp((1-x)L)\,L.
     &
     \text{for $\frac12 \leq x < 1$}
   \end{cases}
 \end{equation}
 A (continuous) function proportional to
 \begin{equation}
   g(m^2) =
   \begin{cases}
     1/(m^2-m_{\textrm{min}}^2) + M^2)
     &
     \text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
     \\
     1/((m_{\textrm{max}}^2 - m^2) + M^2)
     &
     \text{for $m^2 \leq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
   \end{cases}
 \end{equation}
 is mapped to a constant by this mapping, i.e., poles near both ends of
 the interval.
 <<Constants for t-channel pole mapping>>=
   if (map%variable_limits .or. map%a_unknown) then
      msq0 = map%mass**2
      map%a1 = msq0
      map%a2 = 2 * log ((msq_max - msq_min)/(2*msq0) + 1)
      map%a3 = map%a2 / s
      map%a_unknown = .false.
   end if
 <<Apply t-channel pole mapping>>=
   if (x < .5_default) then
      msq1 = map%a1 * exp (x * map%a2)
      msq = msq1 - map%a1 + msq_min
   else
      msq1 = map%a1 * exp ((1-x) * map%a2)
      msq = -(msq1 - map%a1) + msq_max
   end if
   f = map%a3 * msq1
 <<Apply inverse t-channel pole mapping>>=
   if (msq < (msq_max + msq_min)/2) then
      msq1 = msq - msq_min + map%a1
      x = log (msq1/map%a1) / map%a2
   else
      msq1 = msq_max - msq + map%a1
      x = 1 - log (msq1/map%a1) / map%a2
   end if
   f = map%a3 * msq1
 @
 \subsection{Step mapping}
 Step mapping is useful when the allowed range for a squared-mass
 variable is large, but only a fraction at the lower end is populated
 because the particle in question is an (off-shell) decay product of a
 narrow resonance.  I.e., if the resonance was forced to be on-shell,
 the upper end of the range would be the resonance mass, minus the
 effective (real or resonance) mass of the particle(s) in the sibling
 branch of the decay.
 
 The edge of this phase space section has a width which is determined
 by the width of the parent, plus the width of the sibling branch.  (The
 widths might be added in quadrature, but this precision is probably
 not important.)
 
 \subsubsection{Fermi function}
 
 A possible mapping is derived from the Fermi function which has
 precisely this behavior.  The Fermi function is given by
 \begin{equation}
   f(x) = \frac{1}{1 + \exp\frac{x-\mu}{\gamma}}
 \end{equation}
 where $x$ is taken as the invariant mass squared, $\mu$ is the
 invariant mass squared of the edge, and $\gamma$ is the effective
 width which is given by the widths of the parent and the sibling
 branch.  (Widths might be added in quadrature, but we do not require
 this level of precision.)
 \begin{align}
   x &= \frac{m^2 - m_{\text{min}}^2}{\Delta m^2}
 \\
   \mu &=
   \frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2}
           {\Delta m^2}
 \\
   \gamma &= \frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2}
 \end{align}
 with
 \begin{equation}
   \Delta m^2 = m_{\text{max}}^2 - m_{\text{min}}^2
 \end{equation}
 $m^2$ is thus given by
 \begin{equation}
   m^2(x) = xm_{\text{max}}^2 + (1-x)m_{\text{min}}^2
 \end{equation}
 For the mapping, we compute the integral $g(x)$ of the Fermi function,
 normalized such that $g(0)=0$ and $g(1)=1$.  We introduce the abbreviations
 \begin{align}
   \alpha &= 1 - \gamma\ln\frac{1 + \beta e^{1/\gamma}}{1 + \beta}
 \\
   \beta  &= e^{- \mu/\gamma}
 \end{align}
 and obtain
 \begin{equation}
   g(x) = \frac{1}{\alpha}
          \left(x - \gamma\ln\frac{1 + \beta e^{x/\gamma}}
                                  {1 + \beta}\right)
 \end{equation}
 The actual mapping is the inverse function $h(y) = g^{-1}(y)$,
 \begin{equation}
   h(y) = -\gamma\ln\left(e^{-\alpha y/\gamma}(1 + \beta) - \beta\right)
 \end{equation}
 The Jacobian is
 \begin{equation}
   \frac{dh}{dy} = \alpha\left(1 - e^{\alpha y/\gamma}
                                   \frac{\beta}{1 + \beta}\right)^{-1}
 \end{equation}
 which is equal to $1/(dg/dx)$, namely
 \begin{equation}
   \frac{dg}{dx} = \frac{1}{\alpha}\,\frac{1}{1 + \beta e^{x/\gamma}}
 \end{equation}
 The final result is
 \begin{align}
   \int_{m_{\text{min}}^2}^{m_{\text{max}}^2} dm^2\,F(m^2)
   &= \Delta m^2\int_0^1\,dx\,F(m^2(x))
 \\
   &= \Delta m^2\int_0^1\,dy\,F(m^2(h(y)))\,\frac{dh}{dy}
 \end{align}
 Here is the implementation.  We fill [[a1]], [[a2]], [[a3]] with
 $\alpha,\beta,\gamma$, respectively.
 <<Constants for exponential step mapping>>=
   if (map%variable_limits .or. map%a_unknown) then
      map%a3 = max (2 * map%mass * map%width / (msq_max - msq_min), 0.01_default)
      map%a2 = exp (- (map%mass**2 - msq_min) / (msq_max - msq_min) &
                      / map%a3)
      map%a1 = 1 - map%a3 * log ((1 + map%a2 * exp (1 / map%a3)) / (1 + map%a2))
   end if
 <<Apply exponential step mapping>>=
   tmp = exp (- x * map%a1 / map%a3) * (1 + map%a2)
   z = - map%a3 * log (tmp - map%a2)
   msq  = z * msq_max + (1 - z) * msq_min
   f = map%a1 / (1 - map%a2 / tmp) * (msq_max - msq_min) / s
 <<Apply inverse exponential step mapping>>=
   z = (msq - msq_min) / (msq_max - msq_min)
   tmp = 1 + map%a2 * exp (z / map%a3)
   x = (z - map%a3 * log (tmp / (1 + map%a2))) &
       / map%a1
   f = map%a1 * tmp * (msq_max - msq_min) / s
 @
 \subsubsection{Hyperbolic mapping}
 
 The Fermi function has the drawback that it decreases exponentially.
 It might be preferable to take a function with a power-law decrease,
 such that the high-mass region is not completely depopulated.
 
 Here, we start with the actual mapping which we take as
 \begin{equation}
   h(y) = \frac{b}{a-y} - \frac{b}{a} + \mu y
 \end{equation}
 with the abbreviation
 \begin{equation}
   a = \frac12\left(1 + \sqrt{1 + \frac{4b}{1-\mu}}\right)
 \end{equation}
 This is a hyperbola in the $xy$ plane.  The derivative is
 \begin{equation}
   \frac{dh}{dy} = \frac{b}{(a-y)^2} + \mu
 \end{equation}
 The constants correspond to
 \begin{align}
   \mu &=
   \frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2}
           {\Delta m^2}
 \\
   b &= \frac{1}{\mu}\left(\frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2}\right)^2
 \end{align}
 The inverse function is the solution of a quadratic equation,
 \begin{equation}
   g(x) = \frac{1}{2}
          \left[\left(a + \frac{x}{\mu} + \frac{b}{a\mu}\right)
                - \sqrt{\left(a-\frac{x}{\mu}\right)^2
                        + 2\frac{b}{a\mu}\left(a + \frac{x}{\mu}\right)
                        + \left(\frac{b}{a\mu}\right)^2}\right]
 \end{equation}
 The constants $a_{1,2,3}$ are identified with $a,b,\mu$.
 <<Constants for hyperbolic step mapping>>=
   if (map%variable_limits .or. map%a_unknown) then
      map%a3 = (map%mass**2 - msq_min) / (msq_max - msq_min)
      map%a2 = max ((2 * map%mass * map%width / (msq_max - msq_min))**2 &
                    / map%a3, 1e-6_default)
      map%a1 = (1 + sqrt (1 + 4 * map%a2 / (1 - map%a3))) / 2
   end if
 <<Apply hyperbolic step mapping>>=
   z = map%a2 / (map%a1 - x) - map%a2 / map%a1 + map%a3 * x
   msq = z * msq_max + (1 - z) * msq_min
   f = (map%a2 / (map%a1 - x)**2 + map%a3) * (msq_max - msq_min) / s
 <<Apply inverse hyperbolic step mapping>>=
   z = (msq - msq_min) / (msq_max - msq_min)
   tmp = map%a2 / (map%a1 * map%a3)
   x = ((map%a1 + z / map%a3 + tmp) &
        - sqrt ((map%a1 - z / map%a3)**2 + 2 * tmp * (map%a1 + z / map%a3) &
                + tmp**2)) / 2
   f = (map%a2 / (map%a1 - x)**2 + map%a3) * (msq_max - msq_min) / s
 @
 \subsection{Mappings of the polar angle}
 The other type of singularity, a simple pole just outside the
 integration region, can occur in the integration over $\cos\theta$.
 This applies to exchange of massless (or light) particles.
 
 Double poles (Coulomb scattering) are also possible, but only in
 certain cases.  These are also handled by the single-pole mapping.
 
 The mapping is analogous to the previous $m^2$ pole mapping, but with
 a different normalization and notation of variables:
 \begin{equation}
   \frac12\int_{-1}^1 d\cos\theta\,g(\theta)
   = \int_0^1 dx\,\frac{d\cos\theta}{dx}\,g(\theta(x))
   = \int_0^1 dx\,f(x)\,g(x),
 \end{equation}
 where thus
 \begin{equation}
   f(x) = \frac12\,\frac{d\cos\theta}{dx}.
 \end{equation}
 With this mapping, a function of the form
 \begin{equation}
   g(\theta) = c\frac{dx(\cos\theta)}{d\cos\theta}
 \end{equation}
 is mapped to a constant:
 \begin{equation}
   \int_{-1}^1 d\cos\theta\,g(\theta)
   = \int_0^1 dx\,f(x)\,g(\theta(x)) = \int_0^1 dx\,c.
 \end{equation}
 <<Mappings: public>>=
   public :: mapping_compute_ct_from_x
 <<Mappings: procedures>>=
   subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x)
     type(mapping_t), intent(inout) :: map
     real(default), intent(in) :: s
     real(default), intent(out) :: ct, st, f
     real(default), intent(in) :: x
     real(default) :: tmp, ct1
     select case (map%type)
     case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, &
          STEP_MAPPING_E, STEP_MAPPING_H)
      <<Apply trivial ct mapping>>
     case (T_CHANNEL, U_CHANNEL, COLLINEAR)
      <<Constants for ct pole mapping>>
      <<Apply ct pole mapping>>
     case default
        call msg_fatal (" Attempt to apply undefined ct mapping")
     end select
   end subroutine mapping_compute_ct_from_x
 
 @ %def mapping_compute_ct_from_x
 <<Mappings: public>>=
   public :: mapping_compute_x_from_ct
 <<Mappings: procedures>>=
   subroutine mapping_compute_x_from_ct (map, s, ct, f, x)
     type(mapping_t), intent(inout) :: map
     real(default), intent(in) :: s
     real(default), intent(in) :: ct
     real(default), intent(out) :: f, x
     real(default) :: ct1
     select case (map%type)
     case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, &
          STEP_MAPPING_E, STEP_MAPPING_H)
      <<Apply inverse trivial ct mapping>>
     case (T_CHANNEL, U_CHANNEL, COLLINEAR)
      <<Constants for ct pole mapping>>
      <<Apply inverse ct pole mapping>>
     case default
        call msg_fatal (" Attempt to apply undefined inverse ct mapping")
     end select
   end subroutine mapping_compute_x_from_ct
 
 @ %def mapping_compute_x_from_ct
 @
 \subsubsection{Trivial mapping}
 This is just the mapping of the interval $(-1,1)$ to $(0,1)$:
 \begin{equation}
   \cos\theta = -1 + 2x
 \end{equation}
 and
 \begin{equation}
   f(x) = 1
 \end{equation}
 with the inverse
 \begin{equation}
   x = \frac{1+\cos\theta}{2}
 \end{equation}
 <<Apply trivial ct mapping>>=
   tmp = 2 * (1-x)
   ct = 1 - tmp
   st = sqrt (tmp * (2-tmp))
   f = 1
 <<Apply inverse trivial ct mapping>>=
   x = (ct + 1) / 2
   f = 1
 @
 \subsubsection{Pole mapping}
 As above for $m^2$, we simultaneously map poles at both ends of the
 $\cos\theta$ interval.  The formulae are completely analogous:
 \begin{equation}
   \cos\theta =
   \begin{cases}
     \frac{M^2}{s}\left[\exp(xL)-1\right] - 1
     &
     \text{for $x<\frac12$}
     \\
     -\frac{M^2}{s}\left[\exp((1-x)L)-1\right] + 1
     &
     \text{for $x\geq\frac12$}
   \end{cases}
 \end{equation}
 where
 \begin{equation}
   L = 2\ln\frac{M^2+s}{M^2}.
 \end{equation}
 Inverse:
 \begin{equation}
   x =
   \begin{cases}
     \frac{1}{2L}\ln\frac{1 + \cos\theta + M^2/s}{M^2/s}
     &
     \text{for $\cos\theta < 0$}
     \\
     1 - \frac{1}{2L}\ln\frac{1 - \cos\theta + M^2/s}{M^2/s}
     &
     \text{for $\cos\theta \geq 0$}
   \end{cases}
 \end{equation}
 The phase-space factor:
 \begin{equation}
   f(x) =
   \begin{cases}
     \frac{M^2}{s}\exp(xL)\,L
     &
     \text{for $x<\frac12$}
     \\
     \frac{M^2}{s}\exp((1-x)L)\,L
     &
     \text{for $x\geq\frac12$}
   \end{cases}
 \end{equation}
 <<Constants for ct pole mapping>>=
   if (map%variable_limits .or. map%b_unknown) then
      map%b1 = map%mass**2 / s
      map%b2 = log ((map%b1 + 1) / map%b1)
      map%b3 = 0
      map%b_unknown = .false.
   end if
 <<Apply ct pole mapping>>=
   if (x < .5_default) then
      ct1 = map%b1 * exp (2 * x * map%b2)
      ct = ct1 - map%b1 - 1
   else
      ct1 = map%b1 * exp (2 * (1-x) * map%b2)
      ct = -(ct1 - map%b1) + 1
   end if
   if (ct >= -1 .and. ct <= 1) then
      st = sqrt (1 - ct**2)
      f = ct1 * map%b2
   else
      ct = 1;  st = 0;  f = 0
   end if
 <<Apply inverse ct pole mapping>>=
   if (ct < 0) then
      ct1 = ct + map%b1 + 1
      x = log (ct1 / map%b1) / (2 * map%b2)
   else
      ct1 = -ct + map%b1 + 1
      x = 1 - log (ct1 / map%b1) / (2 * map%b2)
   end if
   f = ct1 * map%b2
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \clearpage
 \section{Phase-space trees}
 The phase space evaluation is organized in terms of trees, where each
 branch corresponds to three integrations: $m^2$, $\cos\theta$, and
 $\phi$.  The complete tree thus makes up a specific parameterization
 of the multidimensional phase-space integral.  For the multi-channel
 integration, the phase-space tree is a single channel.
 
 The trees imply mappings of formal Feynman tree graphs into arrays of
 integer numbers: Each branch, corresponding to a particular line in
 the graph, is assigned an integer code $c$ (with kind value [[TC]] =
 tree code).
 
 In this integer, each bit determines whether a particular external
 momentum flows through the line.  The external branches therefore have
 codes $1,2,4,8,\ldots$.  An internal branch has those bits ORed
 corresponding to the momenta flowing through it.  For example, a
 branch with momentum $p_1+p_4$ has code $2^0+2^3=1+8=9$.
 
 There is a two-fold ambiguity: Momentum conservation implies that the
 branch with code
 \begin{equation}
   c_0 = \sum_{i=1}^{n(\rm{ext})} 2^{i-1}
 \end{equation}
 i.e. the branch with momentum $p_1+p_2+\ldots p_n$ has momentum zero,
 which is equivalent to tree code $0$ by definition.  Correspondingly,
 \begin{equation}
   c \quad\textrm{and}\quad c_0 - c = c\;\textrm{XOR}\;c_0
 \end{equation}
 are equivalent.  E.g., if there are five externals with codes
 $c=1,2,4,8,16$, then $c=9$ and $\bar c=31-9=22$ are equivalent.
 
 This ambiguity may be used to assign a direction to the line: If all
 momenta are understood as outgoing, $c=9$ in the example above means
 $p_1+p_4$, but $c=22$ means $p_2+p_3+p_5 = -(p_1+p_4)$.
 
 Here we make use of the ambiguity in a slightly different way.  First,
 the initial particles are singled out as those externals with the
 highest bits, the IN-bits.  (Here: $8$ and $16$ for a $2\to 3$
 scattering process, $16$ only for a $1\to 4$ decay.)  Then we invert
 those codes where all IN-bits are set.  For a decay process this maps
 each tree of an equivalence class onto a unique representative (that one
 with the smallest integer codes).  For a scattering process we proceed
 further:
 
 The ambiguity remains in all branches where only one IN-bit is set,
 including the initial particles.  If there are only externals with
 this property, we have an $s$-channel graph which we leave as it is.
 In all other cases, an internal with only one IN-bit is a $t$-channel
 line, which for phase space integration should be associated with one
 of the initial momenta as a reference axis.  We take that one whose
 bit is set in the current tree code.  (E.g., for branch $c=9$ we use
 the initial particle $c=8$ as reference axis, whereas for the same
 branch we would take $c=16$ if it had been assigned $\bar c=31-9=22$
 as tree code.) Thus, different ways of coding the same $t$-channel
 graph imply different phase space parameterizations.
 
 $s$-channel graphs have a unique parameterization.  The same sets of
 parameterizations are used for $t$-channel graphs, except for the
 reference frames of their angular parts.  We map each
 $t$-channel graph onto an $s$-channel graph as follows:
 
 Working in ascending order, for each $t$-channel line (whose code has
 exactly one IN-bit set) the attached initial line is flipped upstream,
 while the outgoing line is flipped downstream.  (This works only if
 $t$-channel graphs are always parameterized beginning at their outer
 vertices, which we require as a restriction.)  After all possible
 flips have been applied, we have an $s$-channel graph.  We only have
 to remember the initial particle a vertex was originally attached to.
 <<[[phs_trees.f90]]>>=
 <<File header>>
 
 module phs_trees
 
 <<Use kinds>>
   use kinds, only: TC
 <<Use strings>>
   use io_units
   use constants, only: twopi, twopi2, twopi5
   use format_defs, only: FMT_19
   use numeric_utils, only: vanishes
   use diagnostics
   use lorentz
   use permutations, only: permutation_t, permutation_size
   use permutations, only: permutation_init, permutation_find
   use permutations, only: tc_decay_level, tc_permute
   use model_data
   use flavors
   use resonances, only: resonance_history_t, resonance_info_t
   use mappings
 
 <<Standard module head>>
 
 <<PHS trees: public>>
 
 <<PHS trees: types>>
 
 contains
 
 <<PHS trees: procedures>>
 
 end module phs_trees
 @ %def phs_trees
 @
 \subsection{Particles}
 We define a particle type which contains only four-momentum and
 invariant mass squared, and a flag that tells whether the momentum is
 filled or not.
 <<PHS trees: public>>=
   public :: phs_prt_t
 <<PHS trees: types>>=
   type :: phs_prt_t
      private
      logical :: defined = .false.
      type(vector4_t) :: p
      real(default) :: p2
   end type phs_prt_t
 
 @ %def phs_prt_t
 @ Set contents:
 <<PHS trees: public>>=
   public :: phs_prt_set_defined
   public :: phs_prt_set_undefined
   public :: phs_prt_set_momentum
   public :: phs_prt_set_msq
 <<PHS trees: procedures>>=
   elemental subroutine phs_prt_set_defined (prt)
     type(phs_prt_t), intent(inout) :: prt
     prt%defined = .true.
   end subroutine phs_prt_set_defined
 
   elemental subroutine phs_prt_set_undefined (prt)
     type(phs_prt_t), intent(inout) :: prt
     prt%defined = .false.
   end subroutine phs_prt_set_undefined
 
   elemental subroutine phs_prt_set_momentum (prt, p)
     type(phs_prt_t), intent(inout) :: prt
     type(vector4_t), intent(in) :: p
     prt%p = p
   end subroutine phs_prt_set_momentum
 
   elemental subroutine phs_prt_set_msq (prt, p2)
     type(phs_prt_t), intent(inout) :: prt
     real(default), intent(in) :: p2
     prt%p2 = p2
   end subroutine phs_prt_set_msq
 
 @ %def phs_prt_set_defined phs_prt_set_momentum phs_prt_set_msq
 @ Access methods:
 <<PHS trees: public>>=
   public :: phs_prt_is_defined
   public :: phs_prt_get_momentum
   public :: phs_prt_get_msq
 <<PHS trees: procedures>>=
   elemental function phs_prt_is_defined (prt) result (defined)
     logical :: defined
     type(phs_prt_t), intent(in) :: prt
     defined = prt%defined
   end function phs_prt_is_defined
 
   elemental function phs_prt_get_momentum (prt) result (p)
     type(vector4_t) :: p
     type(phs_prt_t), intent(in) :: prt
     p = prt%p
   end function phs_prt_get_momentum
 
   elemental function phs_prt_get_msq (prt) result (p2)
     real(default) :: p2
     type(phs_prt_t), intent(in) :: prt
     p2 = prt%p2
   end function phs_prt_get_msq
 
 @ %def phs_prt_is_defined phs_prt_get_momentum phs_prt_get_msq
 @ Addition of momenta (invariant mass square is computed).
 <<PHS trees: public>>=
   public :: phs_prt_combine
 <<PHS trees: procedures>>=
   elemental subroutine phs_prt_combine (prt, prt1, prt2)
     type(phs_prt_t), intent(inout) :: prt
     type(phs_prt_t), intent(in) :: prt1, prt2
     prt%defined = .true.
     prt%p = prt1%p + prt2%p
     prt%p2 = prt%p ** 2
     call phs_prt_check (prt)
   end subroutine phs_prt_combine
 
 @ %def phs_prt_combine
 @ Output
 <<PHS trees: public>>=
   public :: phs_prt_write
 <<PHS trees: procedures>>=
   subroutine phs_prt_write (prt, unit)
     type(phs_prt_t), intent(in) :: prt
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     if (prt%defined) then
        call vector4_write (prt%p, u)
        write (u, "(1x,A,1x," // FMT_19 // ")") "T = ", prt%p2
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine phs_prt_write
 
 @ %def phs_prt_write
 <<PHS trees: public>>=
   public :: phs_prt_check
 <<PHS trees: procedures>>=
   elemental subroutine phs_prt_check (prt)
     type(phs_prt_t), intent(inout) :: prt
     if (prt%p2 < 0._default) then
        prt%p2 = 0._default
     end if
   end subroutine phs_prt_check
 
 @ %def phs_prt_check
 @
 \subsection{The phase-space tree type}
 \subsubsection{Definition}
 In the concrete implementation, each branch $c$ may have two
 \emph{daughters} $c_1$ and $c_2$ such that $c_1+c_2=c$, a
 \emph{sibling} $c_s$ and a \emph{mother} $c_m$ such that $c+c_s =
 c_m$, and a \emph{friend} which is kept during flips, such that it can
 indicate a fixed reference frame.  Absent entries are set $c=0$.
 
 First, declare the branch type.  There is some need to have this
 public. Give initializations for all components, so no [[init]]
 routine is necessary.  The branch has some information about the
 associated coordinates and about connections.
 <<PHS trees: types>>=
   type :: phs_branch_t
      private
      logical :: set = .false.
      logical :: inverted_decay = .false.
      logical :: inverted_axis = .false.
      integer(TC) :: mother = 0
      integer(TC) :: sibling = 0
      integer(TC) :: friend = 0
      integer(TC) :: origin = 0
      integer(TC), dimension(2) :: daughter = 0
      integer :: firstborn = 0
      logical :: has_children = .false.
      logical :: has_friend = .false.
      logical :: is_real = .false.
   end type phs_branch_t
 
 @ %def phs_branch_t
 @ The tree type: No initialization, this is done by
 [[phs_tree_init]].  In addition to the branch array which
 
 The branches are collected in an array which holds all possible
 branches, of which only a few are set.  After flips have been applied,
 the branch $c_M=\sum_{i=1}^{n({\rm fin})}2^{i-1}$ must be there,
 indicating the mother of all decay products.  In addition, we should
 check for consistency at the beginning.
 
 [[n_branches]] is the number of those actually set.  [[n_externals]]
 defines the number of significant bit, and [[mask]] is a code where all
 bits are set.  Analogous: [[n_in]] and [[mask_in]] for the incoming
 particles.
 
 The [[mapping]] array contains the mappings associated to the branches
 (corresponding indices).  The array [[mass_sum]] contains the sum of
 the real masses of the external final-state particles associated to
 the branch.  During phase-space evaluation, this determines the
 boundaries.
 <<PHS trees: public>>=
   public :: phs_tree_t
 <<PHS trees: types>>=
   type :: phs_tree_t
      private
      integer :: n_branches, n_externals, n_in, n_msq, n_angles
      integer(TC) :: n_branches_tot, n_branches_out
      integer(TC) :: mask, mask_in, mask_out
      type(phs_branch_t), dimension(:), allocatable :: branch
      type(mapping_t), dimension(:), allocatable :: mapping
      real(default), dimension(:), allocatable :: mass_sum
      real(default), dimension(:), allocatable :: effective_mass
      real(default), dimension(:), allocatable :: effective_width
      logical :: real_phsp = .false.
      integer, dimension(:), allocatable :: momentum_link
    contains
    <<PHS trees: phs tree: TBP>>
   end type phs_tree_t
 
 @ %def phs_tree_t
 @ The maximum number of external particles that can be represented is
 related to the bit size of the integer that stores binary codes.  With
 the default integer of 32 bit on common machines, this is more than
 enough space.  If [[TC]] is actually the default integer kind, there
 is no need to keep it separate, but doing so marks this as a
 special type of integer.  So, just state that the maximum number is 32:
 <<Limits: public parameters>>=
   integer, parameter, public :: MAX_EXTERNAL = 32
 @ %def MAX_EXTERNAL
 @
 \subsubsection{Constructor and destructor}
 Allocate memory for a phase-space tree with given number of externals and
 incoming.  The number of allocated branches can easily become large,
 but appears manageable for realistic cases, e.g., for [[n_in=2]] and
 [[n_out=8]] we get $2^{10}-1=1023$.
 <<PHS trees: public>>=
   public :: phs_tree_init
   public :: phs_tree_final
 @ Here we set the masks for incoming and for all externals.
 <<PHS trees: phs tree: TBP>>=
   procedure :: init => phs_tree_init
   procedure :: final => phs_tree_final
 <<PHS trees: procedures>>=
   elemental subroutine phs_tree_init (tree, n_in, n_out, n_masses, n_angles)
     class(phs_tree_t), intent(inout) :: tree
     integer, intent(in) :: n_in, n_out, n_masses, n_angles
     integer(TC) :: i
     tree%n_externals = n_in + n_out
     tree%n_branches_tot = 2**(n_in+n_out) - 1
     tree%n_branches_out = 2**n_out - 1
     tree%mask = 0
     do i = 0, n_in + n_out - 1
        tree%mask = ibset (tree%mask, i)
     end do
     tree%n_in = n_in
     tree%mask_in = 0
     do i = n_out, n_in + n_out - 1
        tree%mask_in = ibset (tree%mask_in, i)
     end do
     tree%mask_out = ieor (tree%mask, tree%mask_in)
     tree%n_msq = n_masses
     tree%n_angles = n_angles
     allocate (tree%branch (tree%n_branches_tot))
     tree%n_branches  = 0
     allocate (tree%mapping (tree%n_branches_out))
     allocate (tree%mass_sum (tree%n_branches_out))
     allocate (tree%effective_mass (tree%n_branches_out))
     allocate (tree%effective_width (tree%n_branches_out))
   end subroutine phs_tree_init
 
   elemental subroutine phs_tree_final (tree)
     class(phs_tree_t), intent(inout) :: tree
     deallocate (tree%branch)
     deallocate (tree%mapping)
     deallocate (tree%mass_sum)
     deallocate (tree%effective_mass)
     deallocate (tree%effective_width)
   end subroutine phs_tree_final
 
 @ %def phs_tree_init phs_tree_final
 @
 \subsubsection{Screen output}
 Write only the branches that are set:
 <<PHS trees: public>>=
   public :: phs_tree_write
 <<PHS trees: phs tree: TBP>>=
   procedure :: write => phs_tree_write
 <<PHS trees: procedures>>=
   subroutine phs_tree_write (tree, unit)
     class(phs_tree_t), intent(in) :: tree
     integer, intent(in), optional :: unit
     integer :: u
     integer(TC) :: k
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, '(3X,A,1x,I0,5X,A,I3)') &
          'External:', tree%n_externals, 'Mask:', tree%mask
     write (u, '(3X,A,1x,I0,5X,A,I3)') &
          'Incoming:', tree%n_in, 'Mask:', tree%mask_in
     write (u, '(3X,A,1x,I0,5X,A,I3)') &
          'Branches:', tree%n_branches
     do k = size (tree%branch), 1, -1
        if (tree%branch(k)%set) &
             call phs_branch_write (tree%branch(k), unit=unit, kval=k)
     end do
     do k = 1, size (tree%mapping)
        call mapping_write (tree%mapping (k), unit, verbose=.true.)
     end do
     write (u, "(3x,A)") "Arrays: mass_sum, effective_mass, effective_width"
     do k = 1, size (tree%mass_sum)
        if (tree%branch(k)%set) then
           write (u, "(5x,I0,3(2x," // FMT_19 // "))") k, tree%mass_sum(k), &
                tree%effective_mass(k), tree%effective_width(k)
        end if
     end do
   end subroutine phs_tree_write
 
   subroutine phs_branch_write (b, unit, kval)
     type(phs_branch_t), intent(in) :: b
     integer, intent(in), optional :: unit
     integer(TC), intent(in), optional :: kval
     integer :: u
     integer(TC) :: k
     character(len=6) :: tmp
     character(len=1) :: firstborn(2), sign_decay, sign_axis
     integer :: i
     u = given_output_unit (unit);  if (u < 0)  return
     k = 0;  if (present (kval))  k = kval
     if (b%origin /= 0) then
        write(tmp, '(A,I4,A)') '(', b%origin, ')'
     else
        tmp = ' '
     end if
     do i=1, 2
        if (b%firstborn == i) then
           firstborn(i) = "*"
        else
           firstborn(i) = " "
        end if
     end do
     if (b%inverted_decay) then
        sign_decay = "-"
     else
        sign_decay = "+"
     end if
     if (b%inverted_axis) then
        sign_axis = "-"
     else
        sign_axis = "+"
     end if
     if (b%has_children) then
        if (b%has_friend) then
           write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A,1x,I0)') &
                &   '*', k, tmp, &
                &   'Daughters: ', &
                &   b%daughter(1), firstborn(1), &
                &   b%daughter(2), firstborn(2), sign_decay, &
                &   'Friend:    ', b%friend
        else
           write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A)') &
                &   '*', k, tmp, &
                &   'Daughters: ', &
                &   b%daughter(1), firstborn(1), &
                &   b%daughter(2), firstborn(2), sign_decay, &
                &   '(axis '//sign_axis//')'
        end if
     else
        write(u,'(5X,I0)') k
     end if
   end subroutine phs_branch_write
 
 @ %def phs_tree_write phs_branch_write
 @
 \subsection{PHS tree setup}
 \subsubsection{Transformation into an array of branch codes and back}
 Assume that the tree/array has been created before with the
 appropriate length and is empty.
 <<PHS trees: public>>=
   public :: phs_tree_from_array
 <<PHS trees: phs tree: TBP>>=
   procedure :: from_array => phs_tree_from_array
 <<PHS trees: procedures>>=
   subroutine phs_tree_from_array (tree, a)
     class(phs_tree_t), intent(inout) :: tree
     integer(TC), dimension(:), intent(in) :: a
     integer :: i
     integer(TC) :: k
   <<Set branches from array [[a]]>>
   <<Set external branches if necessary>>
   <<Check number of branches>>
   <<Determine the connections>>
   contains
   <<Subroutine: set relatives>>
   end subroutine phs_tree_from_array
 
 @ %def phs_tree_from_array
 @ First, set all branches specified by the user.  If all IN-bits
 are set, we invert the branch code.
 <<Set branches from array [[a]]>>=
   do i=1, size(a)
      k = a(i)
      if (iand(k, tree%mask_in) == tree%mask_in)  k = ieor(tree%mask, k)
      tree%branch(k)%set = .true.
      tree%n_branches = tree%n_branches+1
   end do
 @ The external branches are understood, so set them now if not yet
 done.  In all cases ensure that the representative with one bit set is
 used, except for decays where the in-particle is represented by all
 OUT-bits set instead.
 <<Set external branches if necessary>>=
   do i=0, tree%n_externals-1
      k = ibset(0,i)
      if (iand(k, tree%mask_in) == tree%mask_in)  k = ieor(tree%mask, k)
      if (tree%branch(ieor(tree%mask, k))%set) then
         tree%branch(ieor(tree%mask, k))%set = .false.
         tree%branch(k)%set = .true.
      else if (.not.tree%branch(k)%set) then
         tree%branch(k)%set = .true.
         tree%n_branches = tree%n_branches+1
      end if
   end do
 @ Now the number of branches set can be checked.  Here we assume that
 the tree is binary.  For three externals there are three branches in
 total, and for each additional external branch we get another internal
 one.
 <<Check number of branches>>=
   if (tree%n_branches /= tree%n_externals*2-3) then
      call phs_tree_write (tree)
      call msg_bug &
           & (" Wrong number of branches set in phase space tree")
   end if
 @ For all branches that are set, except for the externals, we try to
 find the daughter branches:
 <<Determine the connections>>=
   do k=1, size (tree%branch)
      if (tree%branch(k)%set .and. tc_decay_level (k) /= 1) then
         call branch_set_relatives(k)
      end if
   end do
 @ To this end, we scan all codes less than the current code, whether
 we can find two branches which are set and which together give the
 current code.  After that, the tree may still not be connected, but at
 least we know if a branch does not have daughters: This indicates some
 inconsistency.
 
 The algorithm ensures that, at this stage, the first daughter has a
 smaller code value than the second one.
 <<Subroutine: set relatives>>=
   subroutine branch_set_relatives (k)
     integer(TC), intent(in) :: k
     integer(TC) :: m,n
     do m=1, k-1
        if(iand(k,m)==m) then
           n = ieor(k,m)
           if ( tree%branch(m)%set .and. tree%branch(n)%set ) then
              tree%branch(k)%daughter(1) = m;  tree%branch(k)%daughter(2) = n
              tree%branch(m)%mother      = k;  tree%branch(n)%mother      = k
              tree%branch(m)%sibling     = n;  tree%branch(n)%sibling     = m
              tree%branch(k)%has_children = .true.
              return
           end if
        end if
     end do
     call phs_tree_write (tree)
     call msg_bug &
          & (" Missing daughter branch(es) in phase space tree")
   end subroutine branch_set_relatives
 
 @ The inverse: this is trivial, fortunately.
 @
 \subsubsection{Flip $t$-channel into $s$-channel}
 Flipping the tree is done upwards, beginning from the decay products.
 First we select a $t$-channel branch [[k]]: one which is set, which
 does have an IN-bit, and which is not an external particle.
 
 Next, we determine the adjacent in-particle (called the 'friend' [[f]]
 here, since it will provide the reference axis for the angular
 integration).  In addition, we look for the 'mother' and 'sibling' of
 this particle.  If the latter field is empty, we select the (unique)
 other out-particle which has no mother, calling the internal
 subroutine [[find_orphan]].
 
 The flip is done as follows: We assume that the first daughter [[d]]
 is an $s$-channel line, which is true if the daughters are sorted.
 This will stay the first daughter.  The second one is a $t$-channel
 line; it is exchanged with the 'sibling' [[s]].  The new line which
 replaces the branch [[k]] is just the sum of [[s]] and [[d]].  In
 addition, we have to rearrange the relatives of [[s]] and [[d]], as
 well of [[f]].
 
 Finally, we flip 'sibling' and 'friend' and set the new $s$-channel
 branch [[n]] which replaces the $t$-channel branch [[k]].  After this
 is complete, we are ready to execute another flip.
 
 [Although the friend is not needed for the final flip, since it would
 be an initial particle anyway, we need to know whether we have $t$- or
 $u$-channel.]
 <<PHS trees: public>>=
   public :: phs_tree_flip_t_to_s_channel
 <<PHS trees: procedures>>=
   subroutine phs_tree_flip_t_to_s_channel (tree)
     type(phs_tree_t), intent(inout) :: tree
     integer(TC) :: k, f, m, n, d, s
     if (tree%n_in == 2) then
        FLIP: do k=3, tree%mask-1
           if (.not. tree%branch(k)%set) cycle FLIP
           f = iand(k,tree%mask_in)
           if (f==0 .or. f==k) cycle FLIP
           m = tree%branch(k)%mother
           s = tree%branch(k)%sibling
           if (s==0) call find_orphan(s)
           d = tree%branch(k)%daughter(1)
           n = ior(d,s)
           tree%branch(k)%set = .false.
           tree%branch(n)%set = .true.
           tree%branch(n)%origin = k
           tree%branch(n)%daughter(1) = d; tree%branch(d)%mother  = n
           tree%branch(n)%daughter(2) = s; tree%branch(s)%mother  = n
           tree%branch(n)%has_children = .true.
           tree%branch(d)%sibling = s;  tree%branch(s)%sibling = d
           tree%branch(n)%sibling = f;  tree%branch(f)%sibling = n
           tree%branch(n)%mother      = m
           tree%branch(f)%mother      = m
           if (m/=0) then
              tree%branch(m)%daughter(1) = n
              tree%branch(m)%daughter(2) = f
           end if
           tree%branch(n)%friend = f
           tree%branch(n)%has_friend = .true.
           tree%branch(n)%firstborn = 2
        end do FLIP
     end if
   contains
     subroutine find_orphan(s)
       integer(TC) :: s
       do s=1, tree%mask_out
          if (tree%branch(s)%set .and. tree%branch(s)%mother==0) return
       end do
       call phs_tree_write (tree)
       call msg_bug (" Can't flip phase space tree to channel")
     end subroutine find_orphan
   end subroutine phs_tree_flip_t_to_s_channel
 
 @ %def phs_tree_flip_t_to_s_channel
 @ After the tree has been flipped, one may need to determine what has
 become of a particular $t$-channel branch.  This function gives the
 bincode of the flipped tree.  If the original bincode does not contain
 IN-bits, we leave it as it is.
 <<PHS trees: procedures>>=
   function tc_flipped (tree, kt) result (ks)
     type(phs_tree_t), intent(in) :: tree
     integer(TC), intent(in) :: kt
     integer(TC) :: ks
     if (iand (kt, tree%mask_in) == 0) then
        ks = kt
     else
        ks = tree%branch(iand (kt, tree%mask_out))%mother
     end if
   end function tc_flipped
 
 @ %def tc_flipped
 @ Scan a tree and make sure that the first daughter has always a
 smaller code than the second one.  Furthermore, delete any [[friend]]
 entry in the root branch -- this branching has the incoming particle
 direction as axis anyway.  Keep track of reordering by updating
 [[inverted_axis]], [[inverted_decay]] and [[firstborn]].
 <<PHS trees: public>>=
   public :: phs_tree_canonicalize
 <<PHS trees: procedures>>=
   subroutine phs_tree_canonicalize (tree)
     type(phs_tree_t), intent(inout) :: tree
     integer :: n_out
     integer(TC) :: k_out
     call branch_canonicalize (tree%branch(tree%mask_out))
     n_out = tree%n_externals - tree%n_in
     k_out = tree%mask_out
     if (tree%branch(k_out)%has_friend &
          & .and. tree%branch(k_out)%friend == ibset (0, n_out)) then
        tree%branch(k_out)%inverted_axis = .not.tree%branch(k_out)%inverted_axis
     end if
     tree%branch(k_out)%has_friend = .false.
     tree%branch(k_out)%friend = 0
   contains
     recursive subroutine branch_canonicalize (b)
       type(phs_branch_t), intent(inout) :: b
       integer(TC) :: d1, d2
       if (b%has_children) then
          d1 = b%daughter(1)
          d2 = b%daughter(2)
          if (d1 > d2) then
             b%daughter(1) = d2
             b%daughter(2) = d1
             b%inverted_decay = .not.b%inverted_decay
             if (b%firstborn /= 0)  b%firstborn = 3 - b%firstborn
          end if
          call branch_canonicalize (tree%branch(b%daughter(1)))
          call branch_canonicalize (tree%branch(b%daughter(2)))
       end if
     end subroutine branch_canonicalize
   end subroutine phs_tree_canonicalize
 
 @ %def phs_tree_canonicalize
 @
 \subsubsection{Mappings}
 Initialize a mapping for the current tree.  This is done while reading
 from file, so the mapping parameters are read, but applied to the
 flipped tree.  Thus, the size of the array of mappings is given by the
 number of outgoing particles only.
 <<PHS trees: public>>=
   public :: phs_tree_init_mapping
 <<PHS trees: phs tree: TBP>>=
   procedure :: init_mapping => phs_tree_init_mapping
 <<PHS trees: procedures>>=
   subroutine phs_tree_init_mapping (tree, k, type, pdg, model)
     class(phs_tree_t), intent(inout) :: tree
     integer(TC), intent(in) :: k
     type(string_t), intent(in) :: type
     integer, intent(in) :: pdg
     class(model_data_t), intent(in), target :: model
     integer(TC) :: kk
     kk = tc_flipped (tree, k)
     call mapping_init (tree%mapping(kk), kk, type, pdg, model)
   end subroutine phs_tree_init_mapping
 
 @ %def phs_tree_init_mapping
 @ Set the physical parameters for the mapping, using a specific
 parameter set.  Also set the mass sum array.
 <<PHS trees: public>>=
   public :: phs_tree_set_mapping_parameters
 <<PHS trees: phs tree: TBP>>=
   procedure :: set_mapping_parameters => phs_tree_set_mapping_parameters
 <<PHS trees: procedures>>=
   subroutine phs_tree_set_mapping_parameters &
        (tree, mapping_defaults, variable_limits)
     class(phs_tree_t), intent(inout) :: tree
     type(mapping_defaults_t), intent(in) :: mapping_defaults
     logical, intent(in) :: variable_limits
     integer(TC) :: k
     do k = 1, tree%n_branches_out
        call mapping_set_parameters &
             (tree%mapping(k), mapping_defaults, variable_limits)
     end do
   end subroutine phs_tree_set_mapping_parameters
 
 @ %def phs_tree_set_mapping_parameters
 @ Return the mapping for the sum of all outgoing particles.  This
 should either be no mapping or a global s-channel mapping.
 <<PHS trees: public>>=
   public :: phs_tree_assign_s_mapping
 <<PHS trees: procedures>>=
   subroutine phs_tree_assign_s_mapping (tree, mapping)
     type(phs_tree_t), intent(in) :: tree
     type(mapping_t), intent(out) :: mapping
     mapping = tree%mapping(tree%mask_out)
   end subroutine phs_tree_assign_s_mapping
 
 @ %def phs_tree_assign_s_mapping
 @
 \subsubsection{Kinematics}
 Fill the mass sum array, starting from the external particles and
 working down to the tree root.  For each bincode [[k]] we scan the
 bits in [[k]]; if only one is set, we take the physical mass of the
 corresponding external particle; if more then one is set, we sum up
 the two masses (which we know have already been set).
 <<PHS trees: public>>=
   public :: phs_tree_set_mass_sum
 <<PHS trees: phs tree: TBP>>=
   procedure :: set_mass_sum => phs_tree_set_mass_sum
 <<PHS trees: procedures>>=
   subroutine phs_tree_set_mass_sum (tree, flv)
     class(phs_tree_t), intent(inout) :: tree
     type(flavor_t), dimension(:), intent(in) :: flv
     integer(TC) :: k
     integer :: i
     tree%mass_sum = 0
     do k = 1, tree%n_branches_out
        do i = 0, size (flv) - 1
           if (btest(k,i)) then
              if (ibclr(k,i) == 0) then
                 tree%mass_sum(k) = flv(i+1)%get_mass ()
              else
                 tree%mass_sum(k) = &
                      tree%mass_sum(ibclr(k,i)) + tree%mass_sum(ibset(0,i))
              end if
              exit
           end if
        end do
     end do
   end subroutine phs_tree_set_mass_sum
 
 @ %def phs_tree_set_mass_sum
 @ Set the effective masses and widths.  For each non-resonant branch
 in a tree, the effective mass is equal to the sum of the effective
 masses of the children (and analogous for the width).  External
 particles have their real mass and width zero.  For resonant branches,
 we insert mass and width from the corresponding mapping.
 
 This routine has [[phs_tree_set_mass_sum]] and
 [[phs_tree_set_mapping_parameters]] as prerequisites.
 <<PHS trees: public>>=
   public :: phs_tree_set_effective_masses
 <<PHS trees: phs tree: TBP>>=
   procedure :: set_effective_masses => phs_tree_set_effective_masses
 <<PHS trees: procedures>>=
   subroutine phs_tree_set_effective_masses (tree)
     class(phs_tree_t), intent(inout) :: tree
     tree%effective_mass = 0
     tree%effective_width = 0
     call set_masses_x (tree%mask_out)
   contains
     recursive subroutine set_masses_x (k)
       integer(TC), intent(in) :: k
       integer(TC) :: k1, k2
       if (tree%branch(k)%has_children) then
          k1 = tree%branch(k)%daughter(1)
          k2 = tree%branch(k)%daughter(2)
          call set_masses_x (k1)
          call set_masses_x (k2)
          if (mapping_is_s_channel (tree%mapping(k))) then
             tree%effective_mass(k) = mapping_get_mass (tree%mapping(k))
             tree%effective_width(k) = mapping_get_width (tree%mapping(k))
          else
             tree%effective_mass(k) = &
                  tree%effective_mass(k1) + tree%effective_mass(k2)
             tree%effective_width(k) = &
                  tree%effective_width(k1) + tree%effective_width(k2)
          end if
       else
          tree%effective_mass(k) = tree%mass_sum(k)
       end if
     end subroutine set_masses_x
   end subroutine phs_tree_set_effective_masses
 
 @ %def phs_tree_set_effective_masses
 @ Define step mappings, recursively, for the decay products of all
 intermediate resonances.  Step mappings account for the fact that a
 branch may originate from a resonance, which almost replaces the
 upper limit on the possible invariant mass.  The step
 mapping implements a smooth cutoff that interpolates between the
 resonance and the real kinematic limit.  The mapping width determines
 the sharpness of the cutoff.
 
 Step mappings are inserted only for branches that are not mapped
 otherwise.
 
 At each branch, we record the mass that is effectively available for
 phase space, by taking the previous limit and subtracting the
 effective mass of the sibling branch.  Widths are added, not subtracted.
 
 If we encounter a resonance decay, we discard the previous limit and
 replace it by the mass and width of the resonance, also subtracting
 the sibling branch.
 
 Initially, the limit is zero, so it becomes negative at any branch.  Only
 if there is a resonance, the limit becomes positive.  Whenever the
 limit is positive, and the current branch decays, we activate a step
 mapping for the current branch.
 
 As a result, step mappings are implemented for all internal lines that
 originate from an intermediate resonance decay.
 
 The flag [[variable_limits]] applies to the ultimate limit from the
 available energy, not to the intermediate resonances whose masses are
 always fixed.
 
 This routine requires [[phs_tree_set_effective_masses]]
 <<PHS trees: public>>=
   public :: phs_tree_set_step_mappings
 <<PHS trees: procedures>>=
   subroutine phs_tree_set_step_mappings (tree, exp_type, variable_limits)
     type(phs_tree_t), intent(inout) :: tree
     logical, intent(in) :: exp_type
     logical, intent(in) :: variable_limits
     type(string_t) :: map_str
     integer(TC) :: k
     if (exp_type) then
        map_str = "step_exp"
     else
        map_str = "step_hyp"
     end if
     k = tree%mask_out
     call set_step_mappings_x (k, 0._default, 0._default)
   contains
     recursive subroutine set_step_mappings_x (k, m_limit, w_limit)
       integer(TC), intent(in) :: k
       real(default), intent(in) :: m_limit, w_limit
       integer(TC), dimension(2) :: kk
       real(default), dimension(2) :: m, w
       if (tree%branch(k)%has_children) then
          if (m_limit > 0) then
             if (.not. mapping_is_set (tree%mapping(k))) then
                call mapping_init (tree%mapping(k), k, map_str)
                call mapping_set_step_mapping_parameters (tree%mapping(k), &
                     m_limit, w_limit, &
                     variable_limits)
             end if
          end if
          kk = tree%branch(k)%daughter
          m = tree%effective_mass(kk)
          w = tree%effective_width(kk)
          if (mapping_is_s_channel (tree%mapping(k))) then
             call set_step_mappings_x (kk(1), &
                  mapping_get_mass (tree%mapping(k)) - m(2), &
                  mapping_get_width (tree%mapping(k)) + w(2))
             call set_step_mappings_x (kk(2), &
                  mapping_get_mass (tree%mapping(k)) - m(1), &
                  mapping_get_width (tree%mapping(k)) + w(1))
          else if (m_limit > 0) then
             call set_step_mappings_x (kk(1), &
                  m_limit - m(2), &
                  w_limit + w(2))
             call set_step_mappings_x (kk(2), &
                  m_limit - m(1), &
                  w_limit + w(1))
          else
             call set_step_mappings_x (kk(1), &
                  - m(2), &
                  + w(2))
             call set_step_mappings_x (kk(2), &
                  - m(1), &
                  + w(1))
          end if
       end if
     end subroutine set_step_mappings_x
   end subroutine phs_tree_set_step_mappings
 
 @ %def phs_tree_set_step_mappings
 @
 \subsubsection{Resonance structure}
 We identify the resonances within a tree as the set of s-channel
 mappings.  The [[resonance_history_t]] type serves as the result
 container.
 <<PHS trees: phs tree: TBP>>=
   procedure :: extract_resonance_history => phs_tree_extract_resonance_history
 <<PHS trees: procedures>>=
   subroutine phs_tree_extract_resonance_history (tree, res_history)
     class(phs_tree_t), intent(in) :: tree
     type(resonance_history_t), intent(out) :: res_history
     type(resonance_info_t) :: res_info
     integer :: i
     if (allocated (tree%mapping)) then
        do i = 1, size (tree%mapping)
           associate (mapping => tree%mapping(i))
              if (mapping%is_s_channel ()) then
                 call res_info%init (mapping%get_bincode (), mapping%get_flv (), &
                      n_out = tree%n_externals - tree%n_in)
                 call res_history%add_resonance (res_info)
              end if
           end associate
        end do
     end if
   end subroutine phs_tree_extract_resonance_history
 
 @ %def phs_tree_extract_resonance_history
 @
 \subsubsection{Structural comparison}
 This function allows to check whether one tree is the permutation of
 another one.  The permutation is applied to the second tree in the
 argument list.  We do not make up a temporary permuted tree, but
 compare the two trees directly.  The branches are scanned recursively,
 where for each daughter we check the friend and the mapping as well.
 Once a discrepancy is found, the recursion is exited immediately.
 <<PHS trees: public>>=
   public :: phs_tree_equivalent
 <<PHS trees: procedures>>=
   function phs_tree_equivalent (t1, t2, perm) result (is_equal)
     type(phs_tree_t), intent(in) :: t1, t2
     type(permutation_t), intent(in) :: perm
     logical :: equal, is_equal
     integer(TC) :: k1, k2, mask_in
     k1 = t1%mask_out
     k2 = t2%mask_out
     mask_in = t1%mask_in
     equal = .true.
     call check (t1%branch(k1), t2%branch(k2), k1, k2)
     is_equal = equal
   contains
     recursive subroutine check (b1, b2, k1, k2)
       type(phs_branch_t), intent(in) :: b1, b2
       integer(TC), intent(in) :: k1, k2
       integer(TC), dimension(2) :: d1, d2, pd2
       integer :: i
       if (.not.b1%has_friend .and. .not.b2%has_friend) then
          equal = .true.
       else if (b1%has_friend .and. b2%has_friend) then
          equal = (b1%friend == tc_permute (b2%friend, perm, mask_in))
       end if
       if (equal) then
          if (b1%has_children .and. b2%has_children) then
             d1 = b1%daughter
             d2 = b2%daughter
             do i=1, 2
                pd2(i) = tc_permute (d2(i), perm, mask_in)
             end do
             if (d1(1)==pd2(1) .and. d1(2)==pd2(2)) then
                equal = (b1%firstborn == b2%firstborn)
                if (equal) call check &
                     &     (t1%branch(d1(1)), t2%branch(d2(1)), d1(1), d2(1))
                if (equal) call check &
                     &     (t1%branch(d1(2)), t2%branch(d2(2)), d1(2), d2(2))
             else if (d1(1)==pd2(2) .and. d1(2)==pd2(1)) then
                equal = ( (b1%firstborn == 0 .and. b2%firstborn == 0) &
                     &   .or. (b1%firstborn == 3 - b2%firstborn) )
                if (equal) call check &
                     &     (t1%branch(d1(1)), t2%branch(d2(2)), d1(1), d2(2))
                if (equal) call check &
                     &     (t1%branch(d1(2)), t2%branch(d2(1)), d1(2), d2(1))
             else
                equal = .false.
             end if
          end if
       end if
       if (equal) then
          equal = (t1%mapping(k1) == t2%mapping(k2))
       end if
     end subroutine check
   end function phs_tree_equivalent
 
 @ %def phs_tree_equivalent
 @ Scan two decay trees and determine the correspondence of mass
 variables, i.e., the permutation that transfers the ordered list of
 mass variables belonging to the second tree into the first one.  Mass
 variables are assigned beginning from branches and ending at the root.
 <<PHS trees: public>>=
   public :: phs_tree_find_msq_permutation
 <<PHS trees: procedures>>=
   subroutine phs_tree_find_msq_permutation (tree1, tree2, perm2, msq_perm)
     type(phs_tree_t), intent(in) :: tree1, tree2
     type(permutation_t), intent(in) :: perm2
     type(permutation_t), intent(out) :: msq_perm
     type(permutation_t) :: perm1
     integer(TC) :: mask_in, root
     integer(TC), dimension(:), allocatable :: index1, index2
     integer :: i
     allocate (index1 (tree1%n_msq), index2 (tree2%n_msq))
     call permutation_init (perm1, permutation_size (perm2))
     mask_in = tree1%mask_in
     root = tree1%mask_out
     i = 0
     call tree_scan (tree1, root, perm1, index1)
     i = 0
     call tree_scan (tree2, root, perm2, index2)
     call permutation_find (msq_perm, index1, index2)
   contains
     recursive subroutine tree_scan (tree, k, perm, index)
       type(phs_tree_t), intent(in) :: tree
       integer(TC), intent(in) :: k
       type(permutation_t), intent(in) :: perm
       integer, dimension(:), intent(inout) :: index
       if (tree%branch(k)%has_children) then
          call tree_scan (tree, tree%branch(k)%daughter(1), perm, index)
          call tree_scan (tree, tree%branch(k)%daughter(2), perm, index)
          i = i + 1
          if (i <= size (index))  index(i) = tc_permute (k, perm, mask_in)
       end if
     end subroutine tree_scan
   end subroutine phs_tree_find_msq_permutation
 
 @ %def phs_tree_find_msq_permutation
 <<PHS trees: public>>=
   public :: phs_tree_find_angle_permutation
 <<PHS trees: procedures>>=
   subroutine phs_tree_find_angle_permutation &
        (tree1, tree2, perm2, angle_perm, sig2)
     type(phs_tree_t), intent(in) :: tree1, tree2
     type(permutation_t), intent(in) :: perm2
     type(permutation_t), intent(out) :: angle_perm
     logical, dimension(:), allocatable, intent(out) :: sig2
     type(permutation_t) :: perm1
     integer(TC) :: mask_in, root
     integer(TC), dimension(:), allocatable :: index1, index2
     logical, dimension(:), allocatable :: sig1
     integer :: i
     allocate (index1 (tree1%n_angles), index2 (tree2%n_angles))
     allocate (sig1 (tree1%n_angles), sig2 (tree2%n_angles))
     call permutation_init (perm1, permutation_size (perm2))
     mask_in = tree1%mask_in
     root = tree1%mask_out
     i = 0
     call tree_scan (tree1, root, perm1, index1, sig1)
     i = 0
     call tree_scan (tree2, root, perm2, index2, sig2)
     call permutation_find (angle_perm, index1, index2)
   contains
     recursive subroutine tree_scan (tree, k, perm, index, sig)
       type(phs_tree_t), intent(in) :: tree
       integer(TC), intent(in) :: k
       type(permutation_t), intent(in) :: perm
       integer, dimension(:), intent(inout) :: index
       logical, dimension(:), intent(inout) :: sig
       integer(TC) :: k1, k2, kp
       logical :: s
       if (tree%branch(k)%has_children) then
          k1 = tree%branch(k)%daughter(1)
          k2 = tree%branch(k)%daughter(2)
          s = (tc_permute(k1, perm, mask_in) < tc_permute(k2, perm, mask_in))
          kp = tc_permute (k, perm, mask_in)
          i = i + 1
          index(i) = kp
          sig(i) = s
          i = i + 1
          index(i) = - kp
          sig(i) = s
          call tree_scan (tree, k1, perm, index, sig)
          call tree_scan (tree, k2, perm, index, sig)
       end if
     end subroutine tree_scan
   end subroutine phs_tree_find_angle_permutation
 
 @ %def phs_tree_find_angle_permutation
 @
 \subsection{Phase-space evaluation}
 \subsubsection{Phase-space volume}
 We compute the phase-space volume recursively, following the same path
 as for computing other kinematical variables.  However, the volume
 depends just on $\sqrt{\hat s}$, not on the momentum configuration.
 
 Note: counting branches, we may replace this by a simple formula.
 <<PHS trees: public>>=
   public :: phs_tree_compute_volume
 <<PHS trees: procedures>>=
   subroutine phs_tree_compute_volume (tree, sqrts, volume)
     type(phs_tree_t), intent(in) :: tree
     real(default), intent(in) :: sqrts
     real(default), intent(out) :: volume
     integer(TC) :: k
     k  = tree%mask_out
     if (tree%branch(k)%has_children) then
        call compute_volume_x (tree%branch(k), k, volume, .true.)
     else
        volume = 1
     end if
   contains
     recursive subroutine compute_volume_x (b, k, volume, initial)
       type(phs_branch_t), intent(in) :: b
       integer(TC), intent(in) :: k
       real(default), intent(out) :: volume
       logical, intent(in) :: initial
       integer(TC) :: k1, k2
       real(default) :: v1, v2
       k1 = b%daughter(1);  k2 = b%daughter(2)
       if (tree%branch(k1)%has_children) then
          call compute_volume_x (tree%branch(k1), k1, v1, .false.)
       else
          v1 = 1
       end if
       if (tree%branch(k2)%has_children) then
          call compute_volume_x (tree%branch(k2), k2, v2, .false.)
       else
          v2 = 1
       end if
       if (initial) then
          volume = v1 * v2 / (4 * twopi5)
       else
          volume = v1 * v2 * sqrts**2 / (4 * twopi2)
       end if
     end subroutine compute_volume_x
   end subroutine phs_tree_compute_volume
 
 @ %def phs_tree_compute_volume
 @
 \subsubsection{Determine momenta}
 This is done in two steps: First the masses are determined.  This step
 may fail, in which case [[ok]] is set to false.  If successful, we
 generate angles and the actual momenta.  The array [[decay_p]] serves
 for transferring the individual three-momenta of the daughter
 particles in their mother rest frame from the mass generation to the
 momentum generation step.
 <<PHS trees: public>>=
   public :: phs_tree_compute_momenta_from_x
 <<PHS trees: procedures>>=
   subroutine phs_tree_compute_momenta_from_x &
        (tree, prt, factor, volume, sqrts, x, ok)
     type(phs_tree_t), intent(inout) :: tree
     type(phs_prt_t), dimension(:), intent(inout) :: prt
     real(default), intent(out) :: factor, volume
     real(default), intent(in) :: sqrts
     real(default), dimension(:), intent(in) :: x
     logical, intent(out) :: ok
     real(default), dimension(tree%mask_out) :: decay_p
     integer :: n1, n2
     integer :: n_out
     if (tree%real_phsp) then
       n_out = tree%n_externals - tree%n_in - 1
       n1 = max (n_out-2, 0)
       n2 = n1 + max (2*n_out, 0)
     else
       n1 = tree%n_msq
       n2 = n1 + tree%n_angles
     end if
     call phs_tree_set_msq &
          (tree, prt, factor, volume, decay_p, sqrts, x(1:n1), ok)
     if (ok) call phs_tree_set_angles &
          (tree, prt, factor, decay_p, sqrts, x(n1+1:n2))
   end subroutine phs_tree_compute_momenta_from_x
 
 @ %def phs_tree_compute_momenta_from_x
 @ Mass generation is done recursively.  The [[ok]] flag causes the
 filled tree to be discarded if set to [[.false.]].  This happens if a
 three-momentum turns out to be imaginary, indicating impossible
 kinematics.  The index [[ix]] tells us how far we have used up the
 input array [[x]].
 <<PHS trees: procedures>>=
   subroutine phs_tree_set_msq &
        (tree, prt, factor, volume, decay_p, sqrts, x, ok)
     type(phs_tree_t), intent(inout) :: tree
     type(phs_prt_t), dimension(:), intent(inout) :: prt
     real(default), intent(out) :: factor, volume
     real(default), dimension(:), intent(out) :: decay_p
     real(default), intent(in) :: sqrts
     real(default), dimension(:), intent(in) :: x
     logical, intent(out) :: ok
     integer :: ix
     integer(TC) :: k
     real(default) :: m_tot
     ok =.true.
     ix = 1
     k  = tree%mask_out
     m_tot = tree%mass_sum(k)
     decay_p(k) = 0.
     if (m_tot < sqrts .or. k == 1) then
        if (tree%branch(k)%has_children) then
           call set_msq_x (tree%branch(k), k, factor, volume, .true.)
        else
           factor = 1
           volume = 1
        end if
     else
        ok = .false.
     end if
   contains
     recursive subroutine set_msq_x (b, k, factor, volume, initial)
       type(phs_branch_t), intent(in) :: b
       integer(TC), intent(in) :: k
       real(default), intent(out) :: factor, volume
       logical, intent(in) :: initial
       real(default) :: msq, m, m_min, m_max, m1, m2, msq1, msq2, lda, rlda
       integer(TC) :: k1, k2
       real(default) :: f1, f2, v1, v2
       k1 = b%daughter(1);  k2 = b%daughter(2)
       if (tree%branch(k1)%has_children) then
          call set_msq_x (tree%branch(k1), k1, f1, v1, .false.)
          if (.not.ok) return
       else
          f1 = 1;  v1 = 1
       end if
       if (tree%branch(k2)%has_children) then
          call set_msq_x (tree%branch(k2), k2, f2, v2, .false.)
          if (.not.ok) return
       else
          f2 = 1;  v2 = 1
       end if
       m_min = tree%mass_sum(k)
       if (initial) then
          msq = sqrts**2
          m = sqrts
          m_max = sqrts
          factor = f1 * f2
          volume = v1 * v2 / (4 * twopi5)
       else
          m_max = sqrts - m_tot + m_min
          call mapping_compute_msq_from_x &
               (tree%mapping(k), sqrts**2, m_min**2, m_max**2, msq, factor, &
                x(ix)); ix = ix + 1
          if (msq >= 0) then
             m = sqrt (msq)
             factor = f1 * f2 * factor
             volume = v1 * v2 * sqrts**2 / (4 * twopi2)
             call phs_prt_set_msq (prt(k), msq)
             call phs_prt_set_defined (prt(k))
          else
             ok = .false.
          end if
       end if
       if (ok) then
          msq1 = phs_prt_get_msq (prt(k1));  m1 = sqrt (msq1)
          msq2 = phs_prt_get_msq (prt(k2));  m2 = sqrt (msq2)
          lda = lambda (msq, msq1, msq2)
          if (lda > 0 .and. m > m1 + m2 .and. m <= m_max) then
             rlda = sqrt (lda)
             decay_p(k1) = rlda / (2*m)
             decay_p(k2) = - decay_p(k1)
             factor = rlda / msq * factor
          else
             ok = .false.
          end if
       end if
     end subroutine set_msq_x
 
   end subroutine phs_tree_set_msq
 
 @ %def phs_tree_set_msq
 @
 The heart of phase space generation: Now we have the invariant masses,
 let us generate angles.  At each branch, we take a Lorentz
 transformation and augment it by a boost to the current particle
 rest frame, and by rotations $\phi$ and $\theta$ around the $z$ and
 $y$ axis, respectively.  This transformation is passed down to the
 daughter particles, if present.
 <<PHS trees: procedures>>=
   subroutine phs_tree_set_angles (tree, prt, factor, decay_p, sqrts, x)
     type(phs_tree_t), intent(inout) :: tree
     type(phs_prt_t), dimension(:), intent(inout) :: prt
     real(default), intent(inout) :: factor
     real(default), dimension(:), intent(in) :: decay_p
     real(default), intent(in) :: sqrts
     real(default), dimension(:), intent(in) :: x
     integer :: ix
     integer(TC) :: k
     ix = 1
     k  = tree%mask_out
     call set_angles_x (tree%branch(k), k)
   contains
     recursive subroutine set_angles_x (b, k, L0)
       type(phs_branch_t), intent(in) :: b
       integer(TC), intent(in) :: k
       type(lorentz_transformation_t), intent(in), optional :: L0
       real(default) :: m, msq, ct, st, phi, f, E, p, bg
       type(lorentz_transformation_t) :: L, LL
       integer(TC) :: k1, k2
       type(vector3_t) :: axis
       p = decay_p(k)
       msq = phs_prt_get_msq (prt(k));  m = sqrt (msq)
       E = sqrt (msq + p**2)
       if (present (L0)) then
          call phs_prt_set_momentum (prt(k), L0 * vector4_moving (E,p,3))
       else
          call phs_prt_set_momentum (prt(k), vector4_moving (E,p,3))
       end if
       call phs_prt_set_defined (prt(k))
       if (b%has_children) then
          k1 = b%daughter(1)
          k2 = b%daughter(2)
          if (m > 0) then
             bg = p / m
          else
             bg = 0
          end if
          phi = x(ix) * twopi;  ix = ix + 1
          call mapping_compute_ct_from_x &
               (tree%mapping(k), sqrts**2, ct, st, f, x(ix));  ix = ix + 1
          factor = factor * f
          if (.not. b%has_friend) then
             L = LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), bg)
             !!! The function above is equivalent to:
             ! L = boost (bg,3) * rotation (phi,3) * rotation (ct,st,2)
          else
             LL = boost (-bg,3);  if (present (L0))  LL = LL * inverse(L0)
             axis = space_part ( &
                  LL * phs_prt_get_momentum (prt(tree%branch(k)%friend)) )
             L = boost(bg,3) * rotation_to_2nd (vector3_canonical(3), axis) &
                  * LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), 0._default)
          end if
          if (present (L0))  L = L0 * L
          call set_angles_x (tree%branch(k1), k1, L)
          call set_angles_x (tree%branch(k2), k2, L)
       end if
     end subroutine set_angles_x
 
   end subroutine phs_tree_set_angles
 
 @ %def phs_tree_set_angles
 @
 \subsubsection{Recover random numbers}
 For the other channels we want to compute the random numbers that
 would have generated the momenta that we already know.
 <<PHS trees: public>>=
   public :: phs_tree_compute_x_from_momenta
 <<PHS trees: procedures>>=
   subroutine phs_tree_compute_x_from_momenta (tree, prt, factor, sqrts, x)
     type(phs_tree_t), intent(inout) :: tree
     type(phs_prt_t), dimension(:), intent(in) :: prt
     real(default), intent(out) :: factor
     real(default), intent(in) :: sqrts
     real(default), dimension(:), intent(inout) :: x
     real(default), dimension(tree%mask_out) :: decay_p
     integer :: n1, n2
     n1 = tree%n_msq
     n2 = n1 + tree%n_angles
     call phs_tree_get_msq &
          (tree, prt, factor, decay_p, sqrts, x(1:n1))
     call phs_tree_get_angles &
          (tree, prt, factor, decay_p, sqrts, x(n1+1:n2))
   end subroutine phs_tree_compute_x_from_momenta
 
 @ %def phs_tree_compute_x_from_momenta
 @ The inverse operation follows exactly the same steps.  The tree is
 [[inout]] because it contains mappings whose parameters can be reset
 when the mapping is applied.
 <<PHS trees: procedures>>=
   subroutine phs_tree_get_msq (tree, prt, factor, decay_p, sqrts, x)
     type(phs_tree_t), intent(inout) :: tree
     type(phs_prt_t), dimension(:), intent(in) :: prt
     real(default), intent(out) :: factor
     real(default), dimension(:), intent(out) :: decay_p
     real(default), intent(in) :: sqrts
     real(default), dimension(:), intent(inout) :: x
     integer :: ix
     integer(TC) :: k
     real(default) :: m_tot
     ix = 1
     k  = tree%mask_out
     m_tot = tree%mass_sum(k)
     decay_p(k) = 0.
     if (tree%branch(k)%has_children) then
        call get_msq_x (tree%branch(k), k, factor, .true.)
     else
        factor = 1
     end if
   contains
     recursive subroutine get_msq_x (b, k, factor, initial)
       type(phs_branch_t), intent(in) :: b
       integer(TC), intent(in) :: k
       real(default), intent(out) :: factor
       logical, intent(in) :: initial
       real(default) :: msq, m, m_min, m_max, msq1, msq2, lda, rlda
       integer(TC) :: k1, k2
       real(default) :: f1, f2
       k1 = b%daughter(1);  k2 = b%daughter(2)
       if (tree%branch(k1)%has_children) then
          call get_msq_x (tree%branch(k1), k1, f1, .false.)
       else
          f1 = 1
       end if
       if (tree%branch(k2)%has_children) then
          call get_msq_x (tree%branch(k2), k2, f2, .false.)
       else
          f2 = 1
       end if
       m_min = tree%mass_sum(k)
       m_max = sqrts - m_tot + m_min
       msq = phs_prt_get_msq (prt(k));  m = sqrt (msq)
       if (initial) then
          factor = f1 * f2
       else
          call mapping_compute_x_from_msq &
               (tree%mapping(k), sqrts**2, m_min**2, m_max**2, msq, factor, &
                x(ix));  ix = ix + 1
          factor = f1 * f2 * factor
       end if
       msq1 = phs_prt_get_msq (prt(k1))
       msq2 = phs_prt_get_msq (prt(k2))
       lda = lambda (msq, msq1, msq2)
       if (lda > 0) then
          rlda = sqrt (lda)
          decay_p(k1) = rlda / (2 * m)
          decay_p(k2) = - decay_p(k1)
          factor = rlda / msq * factor
       else
          decay_p(k1) = 0
          decay_p(k2) = 0
          factor = 0
       end if
     end subroutine get_msq_x
 
   end subroutine phs_tree_get_msq
 
 @ %def phs_tree_get_msq
 @ This subroutine is the most time-critical part of the whole
 program.  Therefore, we do not exactly parallel the angle generation
 routine above but make sure that things get evaluated only if they are
 really needed, at the expense of readability.  Particularly important
 is to have as few multiplications of Lorentz transformations as
 possible.
 <<PHS trees: procedures>>=
   subroutine phs_tree_get_angles (tree, prt, factor, decay_p, sqrts, x)
     type(phs_tree_t), intent(inout) :: tree
     type(phs_prt_t), dimension(:), intent(in) :: prt
     real(default), intent(inout) :: factor
     real(default), dimension(:), intent(in) :: decay_p
     real(default), intent(in) :: sqrts
     real(default), dimension(:), intent(out) :: x
     integer :: ix
     integer(TC) :: k
     ix = 1
     k  = tree%mask_out
     if (tree%branch(k)%has_children) then
        call get_angles_x (tree%branch(k), k)
     end if
   contains
     recursive subroutine get_angles_x (b, k, ct0, st0, phi0, L0)
       type(phs_branch_t), intent(in) :: b
       integer(TC), intent(in) :: k
       real(default), intent(in), optional :: ct0, st0, phi0
       type(lorentz_transformation_t), intent(in), optional :: L0
       real(default) :: cp0, sp0, m, msq, ct, st, phi, bg, f
       type(lorentz_transformation_t) :: L, LL
       type(vector4_t) :: p1, pf
       type(vector3_t) :: n, axis
       integer(TC) :: k1, k2, kf
       logical :: has_friend, need_L
       k1 = b%daughter(1)
       k2 = b%daughter(2)
       kf = b%friend
       has_friend = b%has_friend
       if (present(L0)) then
          p1 = L0 * phs_prt_get_momentum (prt(k1))
          if (has_friend)  pf = L0 * phs_prt_get_momentum (prt(kf))
       else
          p1 = phs_prt_get_momentum (prt(k1))
          if (has_friend)  pf = phs_prt_get_momentum (prt(kf))
       end if
       if (present(phi0)) then
          cp0 = cos (phi0)
          sp0 = sin (phi0)
       end if
       msq = phs_prt_get_msq (prt(k));  m = sqrt (msq)
       if (m > 0) then
          bg = decay_p(k) / m
       else
          bg = 0
       end if
       if (has_friend) then
          if (present (phi0)) then
             axis = axis_from_p_r3_r2_b3 (pf, cp0, -sp0, ct0, -st0, -bg)
             LL = rotation_to_2nd (axis, vector3_canonical (3)) &
                  * LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg)
          else
             axis = axis_from_p_b3 (pf, -bg)
             LL = rotation_to_2nd (axis, vector3_canonical(3))
             if (.not. vanishes (bg))  LL = LL * boost(-bg, 3)
          end if
          n = space_part (LL * p1)
       else if (present (phi0)) then
          n = axis_from_p_r3_r2_b3 (p1, cp0, -sp0, ct0, -st0, -bg)
       else
          n = axis_from_p_b3 (p1, -bg)
       end if
       phi = azimuthal_angle (n)
       x(ix) = phi / twopi;  ix = ix + 1
       ct = polar_angle_ct (n)
       st = sqrt (1 - ct**2)
       call mapping_compute_x_from_ct (tree%mapping(k), sqrts**2, ct, f, &
            x(ix));  ix = ix + 1
       factor = factor * f
       if (tree%branch(k1)%has_children .or. tree%branch(k2)%has_children) then
          need_L = .true.
          if (has_friend) then
             if (present (L0)) then
                L = LL * L0
             else
                L = LL
             end if
          else if (present (L0)) then
             L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) * L0
          else if (present (phi0)) then
             L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg)
          else if (bg /= 0) then
             L = boost(-bg, 3)
          else
             need_L = .false.
          end if
          if (need_L) then
             if (tree%branch(k1)%has_children) &
                  call get_angles_x (tree%branch(k1), k1, ct, st, phi, L)
             if (tree%branch(k2)%has_children) &
                  call get_angles_x (tree%branch(k2), k2, ct, st, phi, L)
          else
             if (tree%branch(k1)%has_children) &
                  call get_angles_x (tree%branch(k1), k1, ct, st, phi)
             if (tree%branch(k2)%has_children) &
                  call get_angles_x (tree%branch(k2), k2, ct, st, phi)
          end if
       end if
     end subroutine get_angles_x
   end subroutine phs_tree_get_angles
 
 @ %def phs_tree_get_angles
 @
 \subsubsection{Auxiliary stuff}
 This calculates all momenta that are not yet known by summing up
 daughter particle momenta.  The external particles must be known.
 Only composite particles not yet known are calculated.
 <<PHS trees: public>>=
   public :: phs_tree_combine_particles
 <<PHS trees: procedures>>=
   subroutine phs_tree_combine_particles (tree, prt)
     type(phs_tree_t), intent(in) :: tree
     type(phs_prt_t), dimension(:), intent(inout) :: prt
     call combine_particles_x (tree%mask_out)
   contains
     recursive subroutine combine_particles_x (k)
       integer(TC), intent(in) :: k
       integer :: k1, k2
       if (tree%branch(k)%has_children) then
          k1 = tree%branch(k)%daughter(1);  k2 = tree%branch(k)%daughter(2)
          call combine_particles_x (k1)
          call combine_particles_x (k2)
          if (.not. prt(k)%defined) then
             call phs_prt_combine (prt(k), prt(k1), prt(k2))
          end if
       end if
     end subroutine combine_particles_x
   end subroutine phs_tree_combine_particles
 
 @ %def phs_tree_combine_particles
 @ The previous routine is to be evaluated at runtime.  Instead of
 scanning trees, we can as well set up a multiplication table.  This is
 generated here.  Note that the table is [[intent(out)]].
 <<PHS trees: public>>=
   public :: phs_tree_setup_prt_combinations
 <<PHS trees: procedures>>=
   subroutine phs_tree_setup_prt_combinations (tree, comb)
     type(phs_tree_t), intent(in) :: tree
     integer, dimension(:,:), intent(out) :: comb
     comb = 0
     call setup_prt_combinations_x (tree%mask_out)
   contains
     recursive subroutine setup_prt_combinations_x (k)
       integer(TC), intent(in) :: k
       integer, dimension(2) :: kk
       if (tree%branch(k)%has_children) then
          kk = tree%branch(k)%daughter
          call setup_prt_combinations_x (kk(1))
          call setup_prt_combinations_x (kk(2))
          comb(:,k) = kk
       end if
     end subroutine setup_prt_combinations_x
   end subroutine phs_tree_setup_prt_combinations
 
 @ %def phs_tree_setup_prt_combinations
 @
 <<PHS trees: public>>=
   public :: phs_tree_reshuffle_mappings
 <<PHS trees: procedures>>=
   subroutine phs_tree_reshuffle_mappings (tree)
    type(phs_tree_t), intent(inout) :: tree
    integer(TC) :: k0, k_old, k_new, k2
    integer :: i
    type(mapping_t) :: mapping_tmp
    real(default) :: mass_tmp
    do i = 1, size (tree%momentum_link)
      if (i /= tree%momentum_link (i)) then
        k_old = 2**(i-tree%n_in-1)
        k_new = 2**(tree%momentum_link(i)-tree%n_in-1)
        k0 = tree%branch(k_old)%mother
        k2 = k_new + tree%branch(k_old)%sibling
        mapping_tmp = tree%mapping(k0)
        mass_tmp = tree%mass_sum(k0)
        tree%mapping(k0) = tree%mapping(k2)
        tree%mapping(k2) = mapping_tmp
        tree%mass_sum(k0) = tree%mass_sum(k2)
        tree%mass_sum(k2) = mass_tmp
      end if
    end do
   end subroutine phs_tree_reshuffle_mappings
 
 @ %def phs_tree_reshuffle_mappings
 @
 <<PHS trees: public>>=
   public :: phs_tree_set_momentum_links
 <<PHS trees: procedures>>=
   subroutine phs_tree_set_momentum_links (tree, list)
     type(phs_tree_t), intent(inout) :: tree
     integer, dimension(:), allocatable :: list
     tree%momentum_link = list
   end subroutine phs_tree_set_momentum_links
 
 @ %def phs_tree_set_momentum_links
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[phs_trees_ut.f90]]>>=
 <<File header>>
 
 module phs_trees_ut
   use unit_tests
   use phs_trees_uti
 
 <<Standard module head>>
 
 <<PHS trees: public test>>
 
 contains
 
 <<PHS trees: test driver>>
 
 end module phs_trees_ut
 @ %def phs_trees_ut
 @
 <<[[phs_trees_uti.f90]]>>=
 <<File header>>
 
 module phs_trees_uti
 
 !!!<<Use kinds>>
   use kinds, only: TC
 <<Use strings>>
   use flavors, only: flavor_t
   use model_data, only: model_data_t
 
   use resonances, only: resonance_history_t
   use mappings, only: mapping_defaults_t
 
   use phs_trees
 
 <<Standard module head>>
 
 <<PHS trees: test declarations>>
 
 contains
 
 <<PHS trees: tests>>
 
 end module phs_trees_uti
 @ %def phs_trees_ut
 @ API: driver for the unit tests below.
 <<PHS trees: public test>>=
   public :: phs_trees_test
 <<PHS trees: test driver>>=
   subroutine phs_trees_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS trees: execute tests>>
   end subroutine phs_trees_test
 
 @  %def phs_trees_test
 @
 Create a simple $2\to 3$ PHS tree and display it.
 <<PHS trees: execute tests>>=
   call test (phs_tree_1, "phs_tree_1", &
        "check phs tree setup", &
        u, results)
 <<PHS trees: test declarations>>=
   public :: phs_tree_1
 <<PHS trees: tests>>=
   subroutine phs_tree_1 (u)
     integer, intent(in) :: u
     type(phs_tree_t) :: tree
     type(model_data_t), target :: model
     type(flavor_t), dimension(5) :: flv
     integer :: i
 
     write (u, "(A)")  "* Test output: phs_tree_1"
     write (u, "(A)")  "*   Purpose: test PHS tree routines"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up flavors"
     write (u, "(A)")
 
     call flv%init ([1, -2, 24, 5, -5], model)
     do i = 1, 5
        write (u, "(1x)", advance="no")
        call flv(i)%write (u)
     end do
     write (u, *)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create tree"
     write (u, "(A)")
 
     call tree%init (2, 3, 0, 0)
     call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16])
     call tree%set_mass_sum (flv)
     call tree%set_effective_masses ()
 
     call tree%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call tree%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_tree_1"
 
   end subroutine phs_tree_1
 
 @ %def phs_tree_1
 @ The analogous tree with resonance (s-channel) mappings.
 <<PHS trees: execute tests>>=
   call test (phs_tree_2, "phs_tree_2", &
        "check phs tree with resonances", &
        u, results)
 <<PHS trees: test declarations>>=
   public :: phs_tree_2
 <<PHS trees: tests>>=
   subroutine phs_tree_2 (u)
     integer, intent(in) :: u
     type(phs_tree_t) :: tree
     type(model_data_t), target :: model
     type(mapping_defaults_t) :: mapping_defaults
     type(flavor_t), dimension(5) :: flv
     type(resonance_history_t) :: res_history
     integer :: i
 
     write (u, "(A)")  "* Test output: phs_tree_2"
     write (u, "(A)")  "*   Purpose: test PHS tree with resonances"
     write (u, "(A)")
 
     write (u, "(A)")  "* Read model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up flavors"
     write (u, "(A)")
 
     call flv%init ([1, -2, 24, 5, -5], model)
     do i = 1, 5
        write (u, "(1x)", advance="no")
        call flv(i)%write (u)
     end do
     write (u, *)
 
     write (u, "(A)")
     write (u, "(A)")  "* Create tree with mappings"
     write (u, "(A)")
 
     call tree%init (2, 3, 0, 0)
     call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16])
     call tree%set_mass_sum (flv)
 
     call tree%init_mapping (3_TC, var_str ("s_channel"), -24, model)
     call tree%init_mapping (7_TC, var_str ("s_channel"), 23, model)
 
     call tree%set_mapping_parameters (mapping_defaults, variable_limits=.false.)
     call tree%set_effective_masses ()
 
     call tree%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract resonances from mappings"
     write (u, "(A)")
 
     call tree%extract_resonance_history (res_history)
     call res_history%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call tree%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_tree_2"
 
   end subroutine phs_tree_2
 
 @ %def phs_tree_2
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{The phase-space forest}
 Simply stated, a phase-space forest is a collection of phase-space
 trees.  More precisely, a [[phs_forest]] object contains all
 parameterizations of phase space that \whizard\ will use for a single
 hard process, prepared in the form of [[phs_tree]] objects.  This is
 suitable for evaluation by the \vamp\ integration package:  each
 parameterization (tree) is a valid channel in the multi-channel
 adaptive integration, and each variable in a tree corresponds to an
 integration dimension, defined by an appropriate mapping of the
 $(0,1)$ interval to the allowed range of the integration variable.
 
 The trees are grouped in groves.  The trees (integration channels)
 within a grove share a common weight, assuming that they are related
 by some approximate symmetry.
 
 Trees/channels that are related by an exact symmetry are connected by
 an array of equivalences; each equivalence object holds the data that
 relate one channel to another.
 
 The phase-space setup, i.e., the detailed structure of trees and
 forest, are read from a file.  Therefore, this module also contains
 the syntax definition and the parser needed for interpreting this
 file.
 <<[[phs_forests.f90]]>>=
 <<File header>>
 
 module phs_forests
 
 <<Use kinds>>
   use kinds, only: TC
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_19
   use diagnostics
   use lorentz
   use numeric_utils
   use permutations
   use ifiles
   use syntax_rules
   use lexers
   use parser
   use model_data
   use model_data
   use flavors
   use interactions
 
   use phs_base
   use resonances, only: resonance_history_t
   use resonances, only: resonance_history_set_t
   use mappings
   use phs_trees
 
 <<Standard module head>>
 
 <<PHS forests: public>>
 
 <<PHS forests: types>>
 
 <<PHS forests: interfaces>>
 
 <<PHS forests: variables>>
 
 contains
 
 <<PHS forests: procedures>>
 
 end module phs_forests
 @ %def phs_forests
 @
 \subsection{Phase-space setup parameters}
 This transparent container holds the parameters that the algorithm
 needs for phase-space setup, with reasonable defaults.
 
 The threshold mass (for considering a particle as effectively
 massless) is specified separately for s- and t-channel. The default is
 to treat $W$ and $Z$ bosons as massive in the s-channel, but as
 massless in the t-channel.  The $b$-quark is treated always massless,
 the $t$-quark always massive.
 <<PHS forests: public>>=
   public :: phs_parameters_t
 <<PHS forests: types>>=
   type :: phs_parameters_t
      real(default) :: sqrts = 0
      real(default) :: m_threshold_s = 50._default
      real(default) :: m_threshold_t = 100._default
      integer :: off_shell = 1
      integer :: t_channel = 2
      logical :: keep_nonresonant = .true.
    contains
    <<PHS forests: phs parameters: TBP>>
   end type phs_parameters_t
 
 @ %def phs_parameters_t
 @ Write phase-space parameters to file.
 <<PHS forests: phs parameters: TBP>>=
   procedure :: write => phs_parameters_write
 <<PHS forests: procedures>>=
   subroutine phs_parameters_write (phs_par, unit)
     class(phs_parameters_t), intent(in) :: phs_par
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A," // FMT_19 // ")") "sqrts         = ", phs_par%sqrts
     write (u, "(3x,A," // FMT_19 // ")") "m_threshold_s = ", phs_par%m_threshold_s
     write (u, "(3x,A," // FMT_19 // ")") "m_threshold_t = ", phs_par%m_threshold_t
     write (u, "(3x,A,I0)") "off_shell = ", phs_par%off_shell
     write (u, "(3x,A,I0)") "t_channel = ", phs_par%t_channel
     write (u, "(3x,A,L1)") "keep_nonresonant = ", phs_par%keep_nonresonant
   end subroutine phs_parameters_write
 
 @ %def phs_parameters_write
 @ Read phase-space parameters from file.
 <<PHS forests: public>>=
   public :: phs_parameters_read
 <<PHS forests: procedures>>=
   subroutine phs_parameters_read (phs_par, unit)
     type(phs_parameters_t), intent(out) :: phs_par
     integer, intent(in) :: unit
     character(20) :: dummy
     character :: equals
     read (unit, *)  dummy, equals, phs_par%sqrts
     read (unit, *)  dummy, equals, phs_par%m_threshold_s
     read (unit, *)  dummy, equals, phs_par%m_threshold_t
     read (unit, *)  dummy, equals, phs_par%off_shell
     read (unit, *)  dummy, equals, phs_par%t_channel
     read (unit, *)  dummy, equals, phs_par%keep_nonresonant
   end subroutine phs_parameters_read
 
 @ %def phs_parameters_write
 @ Comparison.
 <<PHS forests: interfaces>>=
   interface operator(==)
      module procedure phs_parameters_eq
   end interface
   interface operator(/=)
      module procedure phs_parameters_ne
   end interface
 <<PHS forests: procedures>>=
   function phs_parameters_eq (phs_par1, phs_par2) result (equal)
     logical :: equal
     type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
     equal = phs_par1%sqrts == phs_par2%sqrts &
          .and. phs_par1%m_threshold_s == phs_par2%m_threshold_s &
          .and. phs_par1%m_threshold_t == phs_par2%m_threshold_t &
          .and. phs_par1%off_shell == phs_par2%off_shell &
          .and. phs_par1%t_channel == phs_par2%t_channel &
          .and.(phs_par1%keep_nonresonant .eqv. phs_par2%keep_nonresonant)
   end function phs_parameters_eq
 
   function phs_parameters_ne (phs_par1, phs_par2) result (ne)
     logical :: ne
     type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
     ne = phs_par1%sqrts /= phs_par2%sqrts &
          .or. phs_par1%m_threshold_s /= phs_par2%m_threshold_s &
          .or. phs_par1%m_threshold_t /= phs_par2%m_threshold_t &
          .or. phs_par1%off_shell /= phs_par2%off_shell &
          .or. phs_par1%t_channel /= phs_par2%t_channel &
          .or.(phs_par1%keep_nonresonant .neqv. phs_par2%keep_nonresonant)
   end function phs_parameters_ne
 
 @ %def phs_parameters_eq phs_parameters_ne
 @
 \subsection{Equivalences}
 This type holds information about equivalences between phase-space
 trees.  We make a linked list, where each node contains the two
 trees which are equivalent and the corresponding permutation of
 external particles.  Two more arrays are to be filled: The permutation
 of mass variables and the permutation of angular variables, where the
 signature indicates a necessary exchange of daughter branches.
 <<PHS forests: types>>=
   type :: equivalence_t
      private
      integer :: left, right
      type(permutation_t) :: perm
      type(permutation_t) :: msq_perm, angle_perm
      logical, dimension(:), allocatable :: angle_sig
      type(equivalence_t), pointer :: next => null ()
   end type equivalence_t
 
 @ %def equivalence_t
 <<PHS forests: types>>=
   type :: equivalence_list_t
      private
      integer :: length = 0
      type(equivalence_t), pointer :: first => null ()
      type(equivalence_t), pointer :: last => null ()
   end type equivalence_list_t
 
 @ %def equivalence_list_t
 @ Append an equivalence to the list
 <<PHS forests: procedures>>=
   subroutine equivalence_list_add (eql, left, right, perm)
     type(equivalence_list_t), intent(inout) :: eql
     integer, intent(in) :: left, right
     type(permutation_t), intent(in) :: perm
     type(equivalence_t), pointer :: eq
     allocate (eq)
     eq%left = left
     eq%right = right
     eq%perm = perm
     if (associated (eql%last)) then
        eql%last%next => eq
     else
        eql%first => eq
     end if
     eql%last => eq
     eql%length = eql%length + 1
   end subroutine equivalence_list_add
 
 @ %def equivalence_list_add
 @ Delete the list contents.  Has to be pure because it is called from
 an elemental subroutine.
 <<PHS forests: procedures>>=
   pure subroutine equivalence_list_final (eql)
     type(equivalence_list_t), intent(inout) :: eql
     type(equivalence_t), pointer :: eq
     do while (associated (eql%first))
        eq => eql%first
        eql%first => eql%first%next
        deallocate (eq)
     end do
     eql%last => null ()
     eql%length = 0
   end subroutine equivalence_list_final
 
 @ %def equivalence_list_final
 @ Make a deep copy of the equivalence list.  This allows for deep
 copies of groves and forests.
 <<PHS forests: interfaces>>=
   interface assignment(=)
      module procedure equivalence_list_assign
   end interface
 
 <<PHS forests: procedures>>=
   subroutine equivalence_list_assign (eql_out, eql_in)
     type(equivalence_list_t), intent(out) :: eql_out
     type(equivalence_list_t), intent(in) :: eql_in
     type(equivalence_t), pointer :: eq, eq_copy
     eq => eql_in%first
     do while (associated (eq))
        allocate (eq_copy)
        eq_copy = eq
        eq_copy%next => null ()
        if (associated (eql_out%first)) then
           eql_out%last%next => eq_copy
        else
           eql_out%first => eq_copy
        end if
        eql_out%last => eq_copy
        eq => eq%next
     end do
   end subroutine equivalence_list_assign
 
 @ %def equivalence_list_assign
 @ The number of list entries
 <<PHS forests: procedures>>=
   elemental function equivalence_list_length (eql) result (length)
     integer :: length
     type(equivalence_list_t), intent(in) :: eql
     length = eql%length
   end function equivalence_list_length
 
 @ %def equivalence_list_length
 @ Recursively write the equivalences list
 <<PHS forests: procedures>>=
   subroutine equivalence_list_write (eql, unit)
     type(equivalence_list_t), intent(in) :: eql
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     if (associated (eql%first)) then
        call equivalence_write_rec (eql%first, u)
     else
        write (u, *) " [empty]"
     end if
   contains
     recursive subroutine equivalence_write_rec (eq, u)
       type(equivalence_t), intent(in) :: eq
       integer, intent(in) :: u
       integer :: i
       write (u, "(3x,A,1x,I0,1x,I0,2x,A)", advance="no") &
            "Equivalence:", eq%left, eq%right, "Final state permutation:"
       call permutation_write (eq%perm, u)
       write (u, "(1x,12x,1x,A,1x)", advance="no") &
            "       msq permutation:  "
       call permutation_write (eq%msq_perm, u)
       write (u, "(1x,12x,1x,A,1x)", advance="no") &
            "       angle permutation:"
       call permutation_write (eq%angle_perm, u)
       write (u, "(1x,12x,1x,26x)", advance="no")
       do i = 1, size (eq%angle_sig)
          if (eq%angle_sig(i)) then
             write (u, "(1x,A)", advance="no") "+"
          else
             write (u, "(1x,A)", advance="no") "-"
          end if
       end do
       write (u, *)
       if (associated (eq%next))  call equivalence_write_rec (eq%next, u)
     end subroutine equivalence_write_rec
   end subroutine equivalence_list_write
 
 @ %def equivalence_list_write
 @
 \subsection{Groves}
 A grove is a group of trees (phase-space channels) that share a common
 weight in the integration.  Within a grove, channels can be declared
 equivalent, so they also share their integration grids (up to
 symmetries).  The grove contains a list of equivalences.  The
 [[tree_count_offset]] is the total number of trees of the preceding
 groves; when the trees are counted per forest (integration channels),
 the offset has to be added to all tree indices.
 <<PHS forests: types>>=
   type :: phs_grove_t
      private
      integer :: tree_count_offset
      type(phs_tree_t), dimension(:), allocatable :: tree
      type(equivalence_list_t) :: equivalence_list
   end type phs_grove_t
 
 @ %def phs_grove_t
 @ Call [[phs_tree_init]] which is also elemental:
 <<PHS forests: procedures>>=
   elemental subroutine phs_grove_init &
        (grove, n_trees, n_in, n_out, n_masses, n_angles)
     type(phs_grove_t), intent(inout) :: grove
     integer, intent(in) :: n_trees, n_in, n_out, n_masses, n_angles
     grove%tree_count_offset = 0
     allocate (grove%tree (n_trees))
     call phs_tree_init (grove%tree, n_in, n_out, n_masses, n_angles)
   end subroutine phs_grove_init
 
 @ %def phs_grove_init
 @ The trees do not have pointer components, thus no call to
 [[phs_tree_final]]:
 <<PHS forests: procedures>>=
   elemental subroutine phs_grove_final (grove)
     type(phs_grove_t), intent(inout) :: grove
     deallocate (grove%tree)
     call equivalence_list_final (grove%equivalence_list)
   end subroutine phs_grove_final
 
 @ %def phs_grove_final
 @ Deep copy.
 <<PHS forests: interfaces>>=
   interface assignment(=)
      module procedure phs_grove_assign0
      module procedure phs_grove_assign1
   end interface
 
 <<PHS forests: procedures>>=
   subroutine phs_grove_assign0 (grove_out, grove_in)
     type(phs_grove_t), intent(out) :: grove_out
     type(phs_grove_t), intent(in) :: grove_in
     grove_out%tree_count_offset = grove_in%tree_count_offset
     if (allocated (grove_in%tree)) then
        allocate (grove_out%tree (size (grove_in%tree)))
        grove_out%tree = grove_in%tree
     end if
     grove_out%equivalence_list = grove_in%equivalence_list
   end subroutine phs_grove_assign0
 
   subroutine phs_grove_assign1 (grove_out, grove_in)
     type(phs_grove_t), dimension(:), intent(out) :: grove_out
     type(phs_grove_t), dimension(:), intent(in) :: grove_in
     integer :: i
     do i = 1, size (grove_in)
        call phs_grove_assign0 (grove_out(i), grove_in(i))
     end do
   end subroutine phs_grove_assign1
 
 @ %def phs_grove_assign
 @ Get the global (s-channel) mappings.  Implemented as a subroutine
 which returns an array (slice).
 <<PHS forests: procedures>>=
   subroutine phs_grove_assign_s_mappings (grove, mapping)
     type(phs_grove_t), intent(in) :: grove
     type(mapping_t), dimension(:), intent(out) :: mapping
     integer :: i
     if (size (mapping) == size (grove%tree)) then
        do i = 1, size (mapping)
           call phs_tree_assign_s_mapping (grove%tree(i), mapping(i))
        end do
     else
        call msg_bug ("phs_grove_assign_s_mappings: array size mismatch")
     end if
   end subroutine phs_grove_assign_s_mappings
 
 @ %def phs_grove_assign_s_mappings
 @
 \subsection{The forest type}
 This is a collection of trees and associated particles.  In a given
 tree, each branch code corresponds to a particle in the [[prt]] array.
 Furthermore, we have an array of mass sums which is independent of the
 decay tree and of the particular event.  The mappings directly
 correspond to the decay trees, and the decay groves collect the trees
 in classes.  The permutation list consists of all permutations of
 outgoing particles that map the decay forest onto itself.
 
 The particle codes [[flv]] (one for each external particle) are needed
 for determining masses and such.  The trees and associated information
 are collected in the [[grove]] array, together with a lookup table
 that associates tree indices to groves.  Finally, the [[prt]] array
 serves as workspace for phase-space evaluation.
 
 The [[prt_combination]] is a list of index pairs, namely the particle
 momenta pairs that need to be combined in order to provide all
 momentum combinations that the phase-space trees need to know.
 <<PHS forests: public>>=
   public :: phs_forest_t
 <<PHS forests: types>>=
   type :: phs_forest_t
      private
      integer :: n_in, n_out, n_tot
      integer :: n_masses, n_angles, n_dimensions
      integer :: n_trees, n_equivalences
      type(flavor_t), dimension(:), allocatable :: flv
      type(phs_grove_t), dimension(:), allocatable :: grove
      integer, dimension(:), allocatable :: grove_lookup
      type(phs_prt_t), dimension(:), allocatable :: prt_in
      type(phs_prt_t), dimension(:), allocatable :: prt_out
      type(phs_prt_t), dimension(:), allocatable :: prt
      integer(TC), dimension(:,:), allocatable :: prt_combination
      type(mapping_t), dimension(:), allocatable :: s_mapping
    contains
    <<PHS forests: phs forest: TBP>>
   end type phs_forest_t
 
 @ %def phs_forest_t
 @
 The initialization merely allocates memory.  We have to know how many
 trees there are in each grove, so we can initialize everything.  The
 number of groves is the size of the [[n_tree]] array.
 
 In the [[grove_lookup]] table we store the grove index that belongs to
 each absolute tree index.  The difference between the absolute index
 and the relative (to the grove) index is stored, for each grove, as
 [[tree_count_offset]].
 
 The particle array is allocated according to the total number of
 branches each tree has, but not filled.
 <<PHS forests: public>>=
   public :: phs_forest_init
 <<PHS forests: procedures>>=
   subroutine phs_forest_init (forest, n_tree, n_in, n_out)
     type(phs_forest_t), intent(inout) :: forest
     integer, dimension(:), intent(in) :: n_tree
     integer, intent(in) :: n_in, n_out
     integer :: g, count, k_root
     forest%n_in = n_in
     forest%n_out = n_out
     forest%n_tot = n_in + n_out
     forest%n_masses = max (n_out - 2, 0)
     forest%n_angles = max (2*n_out - 2, 0)
     forest%n_dimensions = forest%n_masses + forest%n_angles
     forest%n_trees = sum (n_tree)
     forest%n_equivalences = 0
     allocate (forest%grove (size (n_tree)))
     call phs_grove_init &
          (forest%grove, n_tree, n_in, n_out, forest%n_masses, &
           forest%n_angles)
     allocate (forest%grove_lookup (forest%n_trees))
     count = 0
     do g = 1, size (forest%grove)
        forest%grove(g)%tree_count_offset = count
        forest%grove_lookup (count+1:count+n_tree(g)) = g
        count = count + n_tree(g)
     end do
     allocate (forest%prt_in  (n_in))
     allocate (forest%prt_out (forest%n_out))
     k_root = 2**forest%n_tot - 1
     allocate (forest%prt (k_root))
     allocate (forest%prt_combination (2, k_root))
     allocate (forest%s_mapping (forest%n_trees))
   end subroutine phs_forest_init
 
 @ %def phs_forest_init
 @ Assign the global (s-channel) mappings.
 <<PHS forests: public>>=
   public :: phs_forest_set_s_mappings
 <<PHS forests: procedures>>=
   subroutine phs_forest_set_s_mappings (forest)
     type(phs_forest_t), intent(inout) :: forest
     integer :: g, i0, i1, n
     do g = 1, size (forest%grove)
        call phs_forest_get_grove_bounds (forest, g, i0, i1, n)
        call phs_grove_assign_s_mappings &
             (forest%grove(g), forest%s_mapping(i0:i1))
     end do
   end subroutine phs_forest_set_s_mappings
 
 @ %def phs_forest_set_s_mappings
 @ The grove finalizer is called because it contains the equivalence list:
 <<PHS forests: public>>=
   public :: phs_forest_final
 <<PHS forests: procedures>>=
   subroutine phs_forest_final (forest)
     type(phs_forest_t), intent(inout) :: forest
     if (allocated (forest%grove)) then
        call phs_grove_final (forest%grove)
        deallocate (forest%grove)
     end if
     if (allocated (forest%grove_lookup))  deallocate (forest%grove_lookup)
     if (allocated (forest%prt))  deallocate (forest%prt)
     if (allocated (forest%s_mapping))  deallocate (forest%s_mapping)
   end subroutine phs_forest_final
 
 @ %def phs_forest_final
 @
 \subsection{Screen output}
 Write the particles that are non-null, then the trees which point to
 them:
 <<PHS forests: public>>=
   public :: phs_forest_write
 <<PHS forests: phs forest: TBP>>=
   procedure :: write => phs_forest_write
 <<PHS forests: procedures>>=
   subroutine phs_forest_write (forest, unit)
     class(phs_forest_t), intent(in) :: forest
     integer, intent(in), optional :: unit
     integer :: u
     integer :: i, g, k
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "Phase space forest:"
     write (u, "(3x,A,I0)") "n_in  = ", forest%n_in
     write (u, "(3x,A,I0)") "n_out = ", forest%n_out
     write (u, "(3x,A,I0)") "n_tot = ", forest%n_tot
     write (u, "(3x,A,I0)") "n_masses = ", forest%n_masses
     write (u, "(3x,A,I0)") "n_angles = ", forest%n_angles
     write (u, "(3x,A,I0)") "n_dim    = ", forest%n_dimensions
     write (u, "(3x,A,I0)") "n_trees  = ", forest%n_trees
     write (u, "(3x,A,I0)") "n_equiv  = ", forest%n_equivalences
     write (u, "(3x,A)", advance="no") "flavors  ="
     if (allocated (forest%flv)) then
        do i = 1, size (forest%flv)
           write (u, "(1x,I0)", advance="no")  forest%flv(i)%get_pdg ()
        end do
        write (u, "(A)")
     else
        write (u, "(1x,A)") "[empty]"
     end if
     write (u, "(1x,A)") "Particle combinations:"
     if (allocated (forest%prt_combination)) then
        do k = 1, size (forest%prt_combination, 2)
           if (forest%prt_combination(1, k) /= 0) then
              write (u, "(3x,I0,1x,'<=',1x,I0,1x,'+',1x,I0)") &
                   k, forest%prt_combination(:,k)
           end if
        end do
     else
        write (u, "(3x,A)") "  [empty]"
     end if
     write (u, "(1x,A)") "Groves and trees:"
     if (allocated (forest%grove)) then
        do g = 1, size (forest%grove)
           write (u, "(3x,A,1x,I0)") "Grove    ", g
           call phs_grove_write (forest%grove(g), unit)
        end do
     else
        write (u, "(3x,A)") "  [empty]"
     end if
     write (u, "(1x,A,I0)") "Total number of equivalences: ", &
          forest%n_equivalences
     write (u, "(A)")
     write (u, "(1x,A)") "Global s-channel mappings:"
     if (allocated (forest%s_mapping)) then
        do i = 1, size (forest%s_mapping)
           associate (mapping => forest%s_mapping(i))
             if (mapping_is_s_channel (mapping) &
                  .or. mapping_is_on_shell (mapping)) then
                write (u, "(1x,I0,':',1x)", advance="no")  i
                call mapping_write (forest%s_mapping(i), unit)
             end if
           end associate
        end do
     else
        write (u, "(3x,A)") "  [empty]"
     end if
     write (u, "(A)")
     write (u, "(1x,A)") "Incoming particles:"
     if (allocated (forest%prt_in)) then
        if (any (phs_prt_is_defined (forest%prt_in))) then
           do i = 1, size (forest%prt_in)
              if (phs_prt_is_defined (forest%prt_in(i))) then
                 write (u, "(1x,A,1x,I0)")  "Particle", i
                 call phs_prt_write (forest%prt_in(i), u)
              end if
           end do
        else
           write (u, "(3x,A)")  "[all undefined]"
        end if
     else
        write (u, "(3x,A)")  "  [empty]"
     end if
     write (u, "(A)")
     write (u, "(1x,A)") "Outgoing particles:"
     if (allocated (forest%prt_out)) then
        if (any (phs_prt_is_defined (forest%prt_out))) then
           do i = 1, size (forest%prt_out)
              if (phs_prt_is_defined (forest%prt_out(i))) then
                 write (u, "(1x,A,1x,I0)")  "Particle", i
                 call phs_prt_write (forest%prt_out(i), u)
              end if
           end do
        else
           write (u, "(3x,A)")  "[all undefined]"
        end if
     else
        write (u, "(1x,A)")  "  [empty]"
     end if
     write (u, "(A)")
     write (u, "(1x,A)") "Tree particles:"
     if (allocated (forest%prt)) then
        if (any (phs_prt_is_defined (forest%prt))) then
           do i = 1, size (forest%prt)
              if (phs_prt_is_defined (forest%prt(i))) then
                 write (u, "(1x,A,1x,I0)")  "Particle", i
                 call phs_prt_write (forest%prt(i), u)
              end if
           end do
        else
           write (u, "(3x,A)")  "[all undefined]"
        end if
     else
        write (u, "(3x,A)")  "  [empty]"
     end if
   end subroutine phs_forest_write
 
   subroutine phs_grove_write (grove, unit)
     type(phs_grove_t), intent(in) :: grove
     integer, intent(in), optional :: unit
     integer :: u
     integer :: t
     u = given_output_unit (unit);  if (u < 0)  return
     do t = 1, size (grove%tree)
        write (u, "(3x,A,I0)") "Tree      ", t
        call phs_tree_write (grove%tree(t), unit)
     end do
     write (u, "(1x,A)") "Equivalence list:"
     call equivalence_list_write (grove%equivalence_list, unit)
   end subroutine phs_grove_write
 
 @ %def phs_grove_write phs_forest_write
 @ Deep copy.
 <<PHS forests: public>>=
   public :: assignment(=)
 <<PHS forests: interfaces>>=
   interface assignment(=)
      module procedure phs_forest_assign
   end interface
 
 <<PHS forests: procedures>>=
   subroutine phs_forest_assign (forest_out, forest_in)
     type(phs_forest_t), intent(out) :: forest_out
     type(phs_forest_t), intent(in) :: forest_in
     forest_out%n_in  = forest_in%n_in
     forest_out%n_out = forest_in%n_out
     forest_out%n_tot = forest_in%n_tot
     forest_out%n_masses = forest_in%n_masses
     forest_out%n_angles = forest_in%n_angles
     forest_out%n_dimensions  = forest_in%n_dimensions
     forest_out%n_trees  = forest_in%n_trees
     forest_out%n_equivalences  = forest_in%n_equivalences
     if (allocated (forest_in%flv)) then
        allocate (forest_out%flv (size (forest_in%flv)))
        forest_out%flv = forest_in%flv
     end if
     if (allocated (forest_in%grove)) then
        allocate (forest_out%grove (size (forest_in%grove)))
        forest_out%grove = forest_in%grove
     end if
     if (allocated (forest_in%grove_lookup)) then
        allocate (forest_out%grove_lookup (size (forest_in%grove_lookup)))
        forest_out%grove_lookup = forest_in%grove_lookup
     end if
     if (allocated (forest_in%prt_in)) then
        allocate (forest_out%prt_in (size (forest_in%prt_in)))
        forest_out%prt_in = forest_in%prt_in
     end if
     if (allocated (forest_in%prt_out)) then
        allocate (forest_out%prt_out (size (forest_in%prt_out)))
        forest_out%prt_out = forest_in%prt_out
     end if
     if (allocated (forest_in%prt)) then
        allocate (forest_out%prt (size (forest_in%prt)))
        forest_out%prt = forest_in%prt
     end if
     if (allocated (forest_in%s_mapping)) then
        allocate (forest_out%s_mapping (size (forest_in%s_mapping)))
        forest_out%s_mapping = forest_in%s_mapping
     end if
     if (allocated (forest_in%prt_combination)) then
        allocate (forest_out%prt_combination &
             (2, size (forest_in%prt_combination, 2)))
        forest_out%prt_combination = forest_in%prt_combination
     end if
   end subroutine phs_forest_assign
 
 @ %def phs_forest_assign
 @
 \subsection{Accessing contents}
 Get the number of integration parameters
 <<PHS forests: public>>=
   public :: phs_forest_get_n_parameters
 <<PHS forests: procedures>>=
   function phs_forest_get_n_parameters (forest) result (n)
     integer :: n
     type(phs_forest_t), intent(in) :: forest
     n = forest%n_dimensions
   end function phs_forest_get_n_parameters
 
 @ %def phs_forest_get_n_parameters
 @ Get the number of integration channels
 <<PHS forests: public>>=
   public :: phs_forest_get_n_channels
 <<PHS forests: procedures>>=
   function phs_forest_get_n_channels (forest) result (n)
     integer :: n
     type(phs_forest_t), intent(in) :: forest
     n = forest%n_trees
   end function phs_forest_get_n_channels
 
 @ %def phs_forest_get_n_channels
 @ Get the number of groves
 <<PHS forests: public>>=
   public :: phs_forest_get_n_groves
 <<PHS forests: procedures>>=
   function phs_forest_get_n_groves (forest) result (n)
     integer :: n
     type(phs_forest_t), intent(in) :: forest
     n = size (forest%grove)
   end function phs_forest_get_n_groves
 
 @ %def phs_forest_get_n_groves
 @ Get the index bounds for a specific grove.
 <<PHS forests: public>>=
   public :: phs_forest_get_grove_bounds
 <<PHS forests: procedures>>=
   subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n)
     type(phs_forest_t), intent(in) :: forest
     integer, intent(in) :: g
     integer, intent(out) :: i0, i1, n
     n = size (forest%grove(g)%tree)
     i0 = forest%grove(g)%tree_count_offset + 1
     i1 = forest%grove(g)%tree_count_offset + n
   end subroutine phs_forest_get_grove_bounds
 
 @ %def phs_forest_get_grove_bounds
 @ Get the number of equivalences
 <<PHS forests: public>>=
   public :: phs_forest_get_n_equivalences
 <<PHS forests: procedures>>=
   function phs_forest_get_n_equivalences (forest) result (n)
     integer :: n
     type(phs_forest_t), intent(in) :: forest
     n = forest%n_equivalences
   end function phs_forest_get_n_equivalences
 
 @ %def phs_forest_get_n_equivalences
 @ Return true if a particular channel has a global (s-channel)
 mapping; also return the resonance mass and width for this mapping.
 <<PHS forests: public>>=
   public :: phs_forest_get_s_mapping
   public :: phs_forest_get_on_shell
 <<PHS forests: procedures>>=
   subroutine phs_forest_get_s_mapping (forest, channel, flag, mass, width)
     type(phs_forest_t), intent(in) :: forest
     integer, intent(in) :: channel
     logical, intent(out) :: flag
     real(default), intent(out) :: mass, width
     flag = mapping_is_s_channel (forest%s_mapping(channel))
     if (flag) then
        mass = mapping_get_mass (forest%s_mapping(channel))
        width = mapping_get_width (forest%s_mapping(channel))
     else
        mass = 0
        width = 0
     end if
   end subroutine phs_forest_get_s_mapping
 
   subroutine phs_forest_get_on_shell (forest, channel, flag, mass)
     type(phs_forest_t), intent(in) :: forest
     integer, intent(in) :: channel
     logical, intent(out) :: flag
     real(default), intent(out) :: mass
     flag = mapping_is_on_shell (forest%s_mapping(channel))
     if (flag) then
        mass = mapping_get_mass (forest%s_mapping(channel))
     else
        mass = 0
     end if
   end subroutine phs_forest_get_on_shell
 
 @ %def phs_forest_get_s_mapping
 @ %def phs_forest_get_on_shell
 @
 Extract the set of unique resonance histories, in form of an array.
 <<PHS forests: phs forest: TBP>>=
   procedure :: extract_resonance_history_set &
        => phs_forest_extract_resonance_history_set
 <<PHS forests: procedures>>=
   subroutine phs_forest_extract_resonance_history_set &
        (forest, res_set, include_trivial)
     class(phs_forest_t), intent(in) :: forest
     type(resonance_history_set_t), intent(out) :: res_set
     logical, intent(in), optional :: include_trivial
     type(resonance_history_t) :: rh
     integer :: g, t
     logical :: triv
     triv = .false.;  if (present (include_trivial))  triv = include_trivial
     call res_set%init ()
     do g = 1, size (forest%grove)
        associate (grove => forest%grove(g))
           do t = 1, size (grove%tree)
              call grove%tree(t)%extract_resonance_history (rh)
              call res_set%enter (rh, include_trivial)
           end do
        end associate
     end do
     call res_set%freeze ()
   end subroutine phs_forest_extract_resonance_history_set
 
 @ %def phs_forest_extract_resonance_history_set
 @
 \subsection{Read the phase space setup from file}
 The phase space setup is stored in a file.  The file may be generated
 by the [[cascades]] module below, or by other means.  This file has to
 be read and parsed to create the PHS forest as the internal
 phase-space representation.
 
 Create lexer and syntax:
 <<PHS forests: procedures>>=
   subroutine define_phs_forest_syntax (ifile)
     type(ifile_t) :: ifile
     call ifile_append (ifile, "SEQ phase_space_list = process_phase_space*")
     call ifile_append (ifile, "SEQ process_phase_space = " &
          // "process_def process_header phase_space")
     call ifile_append (ifile, "SEQ process_def = process process_list")
     call ifile_append (ifile, "KEY process")
     call ifile_append (ifile, "LIS process_list = process_tag*")
     call ifile_append (ifile, "IDE process_tag")
     call ifile_append (ifile, "SEQ process_header = " &
          // "md5sum_process = md5sum " &
          // "md5sum_model_par = md5sum " &
          // "md5sum_phs_config = md5sum " &
          // "sqrts = real " &
          // "m_threshold_s = real " &
          // "m_threshold_t = real " &
          // "off_shell = integer " &
          // "t_channel = integer " &
          // "keep_nonresonant = logical")
     call ifile_append (ifile, "KEY '='")
     call ifile_append (ifile, "KEY '-'")
     call ifile_append (ifile, "KEY md5sum_process")
     call ifile_append (ifile, "KEY md5sum_model_par")
     call ifile_append (ifile, "KEY md5sum_phs_config")
     call ifile_append (ifile, "KEY sqrts")
     call ifile_append (ifile, "KEY m_threshold_s")
     call ifile_append (ifile, "KEY m_threshold_t")
     call ifile_append (ifile, "KEY off_shell")
     call ifile_append (ifile, "KEY t_channel")
     call ifile_append (ifile, "KEY keep_nonresonant")
     call ifile_append (ifile, "QUO md5sum = '""' ... '""'")
     call ifile_append (ifile, "REA real")
     call ifile_append (ifile, "INT integer")
     call ifile_append (ifile, "IDE logical")
     call ifile_append (ifile, "SEQ phase_space = grove_def+")
     call ifile_append (ifile, "SEQ grove_def = grove tree_def+")
     call ifile_append (ifile, "KEY grove")
     call ifile_append (ifile, "SEQ tree_def = tree bincodes mapping*")
     call ifile_append (ifile, "KEY tree")
     call ifile_append (ifile, "SEQ bincodes = bincode*")
     call ifile_append (ifile, "INT bincode")
     call ifile_append (ifile, "SEQ mapping = map bincode channel signed_pdg")
     call ifile_append (ifile, "KEY map")
     call ifile_append (ifile, "ALT channel = &
          &s_channel | t_channel | u_channel | &
          &collinear | infrared | radiation | on_shell")
     call ifile_append (ifile, "KEY s_channel")
     ! call ifile_append (ifile, "KEY t_channel")   !!! Key already exists
     call ifile_append (ifile, "KEY u_channel")
     call ifile_append (ifile, "KEY collinear")
     call ifile_append (ifile, "KEY infrared")
     call ifile_append (ifile, "KEY radiation")
     call ifile_append (ifile, "KEY on_shell")
     call ifile_append (ifile, "ALT signed_pdg = &
          &pdg | negative_pdg")
     call ifile_append (ifile, "SEQ negative_pdg = '-' pdg")
     call ifile_append (ifile, "INT pdg")
   end subroutine define_phs_forest_syntax
 
 @ %def define_phs_forest_syntax
 @ The model-file syntax and lexer are fixed, therefore stored as
 module variables:
 <<PHS forests: variables>>=
   type(syntax_t), target, save :: syntax_phs_forest
 
 @ %def syntax_phs_forest
 <<PHS forests: public>>=
   public :: syntax_phs_forest_init
 <<PHS forests: procedures>>=
   subroutine syntax_phs_forest_init ()
     type(ifile_t) :: ifile
     call define_phs_forest_syntax (ifile)
     call syntax_init (syntax_phs_forest, ifile)
     call ifile_final (ifile)
   end subroutine syntax_phs_forest_init
 
 @ %def syntax_phs_forest_init
 <<PHS forests: procedures>>=
   subroutine lexer_init_phs_forest (lexer)
     type(lexer_t), intent(out) :: lexer
     call lexer_init (lexer, &
          comment_chars = "#!", &
          quote_chars = '"', &
          quote_match = '"', &
          single_chars = "-", &
          special_class = ["="] , &
          keyword_list = syntax_get_keyword_list_ptr (syntax_phs_forest))
   end subroutine lexer_init_phs_forest
 
 @ %def lexer_init_phs_forest
 <<PHS forests: public>>=
   public :: syntax_phs_forest_final
 <<PHS forests: procedures>>=
   subroutine syntax_phs_forest_final ()
     call syntax_final (syntax_phs_forest)
   end subroutine syntax_phs_forest_final
 
 @ %def syntax_phs_forest_final
 <<PHS forests: public>>=
   public :: syntax_phs_forest_write
 <<PHS forests: procedures>>=
   subroutine syntax_phs_forest_write (unit)
     integer, intent(in), optional :: unit
     call syntax_write (syntax_phs_forest, unit)
   end subroutine syntax_phs_forest_write
 
 @ %def syntax_phs_forest_write
 @ The concrete parser and interpreter.  Generate an input stream for
 the external [[unit]], read the parse tree (with given [[syntax]] and
 [[lexer]]) from this stream, and transfer the contents of the parse
 tree to the PHS [[forest]].
 
 We look for the matching [[process]] tag, count groves and trees for
 initializing the [[forest]], and fill the trees.
 
 If the optional parameters are set, compare the parameters stored in
 the file to those.  Set [[match]] true if everything agrees.
 <<PHS forests: public>>=
   public :: phs_forest_read
 <<PHS forests: interfaces>>=
   interface phs_forest_read
      module procedure phs_forest_read_file
      module procedure phs_forest_read_unit
      module procedure phs_forest_read_parse_tree
   end interface
 
 <<PHS forests: procedures>>=
   subroutine phs_forest_read_file &
        (forest, filename, process_id, n_in, n_out, model, found, &
         md5sum_process, md5sum_model_par, &
         md5sum_phs_config, phs_par, match)
     type(phs_forest_t), intent(out) :: forest
     type(string_t), intent(in) :: filename
     type(string_t), intent(in) :: process_id
     integer, intent(in) :: n_in, n_out
     class(model_data_t), intent(in), target :: model
     logical, intent(out) :: found
     character(32), intent(in), optional :: &
          md5sum_process, md5sum_model_par, md5sum_phs_config
     type(phs_parameters_t), intent(in), optional :: phs_par
     logical, intent(out), optional :: match
     type(parse_tree_t), target :: parse_tree
     type(stream_t), target :: stream
     type(lexer_t) :: lexer
     call lexer_init_phs_forest (lexer)
     call stream_init (stream, char (filename))
     call lexer_assign_stream (lexer, stream)
     call parse_tree_init (parse_tree, syntax_phs_forest, lexer)
     call phs_forest_read (forest, parse_tree, &
          process_id, n_in, n_out, model, found, &
          md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
     call stream_final (stream)
     call lexer_final (lexer)
     call parse_tree_final (parse_tree)
   end subroutine phs_forest_read_file
 
   subroutine phs_forest_read_unit &
        (forest, unit, process_id, n_in, n_out, model, found, &
         md5sum_process, md5sum_model_par, md5sum_phs_config, &
         phs_par, match)
     type(phs_forest_t), intent(out) :: forest
     integer, intent(in) :: unit
     type(string_t), intent(in) :: process_id
     integer, intent(in) :: n_in, n_out
     class(model_data_t), intent(in), target :: model
     logical, intent(out) :: found
     character(32), intent(in), optional :: &
          md5sum_process, md5sum_model_par, md5sum_phs_config
     type(phs_parameters_t), intent(in), optional :: phs_par
     logical, intent(out), optional :: match
     type(parse_tree_t), target :: parse_tree
     type(stream_t), target :: stream
     type(lexer_t) :: lexer
     call lexer_init_phs_forest (lexer)
     call stream_init (stream, unit)
     call lexer_assign_stream (lexer, stream)
     call parse_tree_init (parse_tree, syntax_phs_forest, lexer)
     call phs_forest_read (forest, parse_tree, &
          process_id, n_in, n_out, model, found, &
          md5sum_process, md5sum_model_par, md5sum_phs_config, &
          phs_par, match)
     call stream_final (stream)
     call lexer_final (lexer)
     call parse_tree_final (parse_tree)
   end subroutine phs_forest_read_unit
 
   subroutine phs_forest_read_parse_tree &
        (forest, parse_tree, process_id, n_in, n_out, model, found, &
         md5sum_process, md5sum_model_par, md5sum_phs_config, &
         phs_par, match)
     type(phs_forest_t), intent(out) :: forest
     type(parse_tree_t), intent(in), target :: parse_tree
     type(string_t), intent(in) :: process_id
     integer, intent(in) :: n_in, n_out
     class(model_data_t), intent(in), target :: model
     logical, intent(out) :: found
     character(32), intent(in), optional :: &
          md5sum_process, md5sum_model_par, md5sum_phs_config
     type(phs_parameters_t), intent(in), optional :: phs_par
     logical, intent(out), optional :: match
     type(parse_node_t), pointer :: node_header, node_phs, node_grove
     integer :: n_grove, g
     integer, dimension(:), allocatable :: n_tree
     integer :: t
     node_header => parse_tree_get_process_ptr (parse_tree, process_id)
     found = associated (node_header);  if (.not. found)  return
     if (present (match)) then
        call phs_forest_check_input (node_header, &
             md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
        if (.not. match)  return
     end if
     node_phs => parse_node_get_next_ptr (node_header)
     n_grove = parse_node_get_n_sub (node_phs)
     allocate (n_tree (n_grove))
     do g = 1, n_grove
        node_grove => parse_node_get_sub_ptr (node_phs, g)
        n_tree(g) = parse_node_get_n_sub (node_grove) - 1
     end do
     call phs_forest_init (forest, n_tree, n_in, n_out)
     do g = 1, n_grove
        node_grove => parse_node_get_sub_ptr (node_phs, g)
        do t = 1, n_tree(g)
           call phs_tree_set (forest%grove(g)%tree(t), &
                parse_node_get_sub_ptr (node_grove, t+1), model)
        end do
     end do
   end subroutine phs_forest_read_parse_tree
 
 @ %def phs_forest
 @ Check the input for consistency.  If any MD5 sum or phase-space
 parameter disagrees, the phase-space file cannot be used.  The MD5
 sum checks are skipped if the stored MD5 sum is empty.
 <<PHS forests: procedures>>=
   subroutine phs_forest_check_input (pn_header, &
        md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
     type(parse_node_t), intent(in), target :: pn_header
     character(32), intent(in) :: &
          md5sum_process, md5sum_model_par, md5sum_phs_config
     type(phs_parameters_t), intent(in), optional :: phs_par
     logical, intent(out) :: match
     type(parse_node_t), pointer :: pn_md5sum, pn_rval, pn_ival, pn_lval
     character(32) :: md5sum
     type(phs_parameters_t) :: phs_par_old
     character(1) :: lstr
     pn_md5sum => parse_node_get_sub_ptr (pn_header, 3)
     md5sum = parse_node_get_string (pn_md5sum)
     if (md5sum /= "" .and. md5sum /= md5sum_process) then
        call msg_message ("Phase space: discarding old configuration &
             &(process changed)")
        match = .false.;  return
     end if
     pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3)
     md5sum = parse_node_get_string (pn_md5sum)
     if (md5sum /= "" .and. md5sum /= md5sum_model_par) then
        call msg_message ("Phase space: discarding old configuration &
             &(model parameters changed)")
        match = .false.;  return
     end if
     pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3)
     md5sum = parse_node_get_string (pn_md5sum)
     if (md5sum /= "" .and. md5sum /= md5sum_phs_config) then
        call msg_message ("Phase space: discarding old configuration &
             &(configuration parameters changed)")
        match = .false.;  return
     end if
     if (present (phs_par)) then
        pn_rval => parse_node_get_next_ptr (pn_md5sum, 3)
        phs_par_old%sqrts = parse_node_get_real (pn_rval)
        pn_rval => parse_node_get_next_ptr (pn_rval, 3)
        phs_par_old%m_threshold_s = parse_node_get_real (pn_rval)
        pn_rval => parse_node_get_next_ptr (pn_rval, 3)
        phs_par_old%m_threshold_t = parse_node_get_real (pn_rval)
        pn_ival => parse_node_get_next_ptr (pn_rval, 3)
        phs_par_old%off_shell = parse_node_get_integer (pn_ival)
        pn_ival => parse_node_get_next_ptr (pn_ival, 3)
        phs_par_old%t_channel = parse_node_get_integer (pn_ival)
        pn_lval => parse_node_get_next_ptr (pn_ival, 3)
        lstr = parse_node_get_string (pn_lval)
        read (lstr, "(L1)")  phs_par_old%keep_nonresonant
        if (phs_par_old /= phs_par) then
           call msg_message &
                ("Phase space: discarding old configuration &
                &(configuration parameters changed)")
           match = .false.;  return
        end if
     end if
     match = .true.
   end subroutine phs_forest_check_input
 
 @ %def phs_forest_check_input
 @ Initialize a specific tree in the forest, using the contents of the
 'tree' node.  First, count the bincodes, allocate an array and read
 them in, and make the tree.  Each $t$-channel tree is flipped to
 $s$-channel.  Then, find mappings and initialize them.
 <<PHS forests: procedures>>=
   subroutine phs_tree_set (tree, node, model)
     type(phs_tree_t), intent(inout) :: tree
     type(parse_node_t), intent(in), target :: node
     class(model_data_t), intent(in), target :: model
     type(parse_node_t), pointer :: node_bincodes, node_mapping, pn_pdg
     integer :: n_bincodes, offset
     integer(TC), dimension(:), allocatable :: bincode
     integer :: b, n_mappings, m
     integer(TC) :: k
     type(string_t) :: type
     integer :: pdg
     node_bincodes => parse_node_get_sub_ptr (node, 2)
     if (associated (node_bincodes)) then
        select case (char (parse_node_get_rule_key (node_bincodes)))
        case ("bincodes")
           n_bincodes = parse_node_get_n_sub (node_bincodes)
           offset = 2
        case default
           n_bincodes = 0
           offset = 1
        end select
     else
        n_bincodes = 0
        offset = 2
     end if
     allocate (bincode (n_bincodes))
     do b = 1, n_bincodes
        bincode(b) = parse_node_get_integer &
             (parse_node_get_sub_ptr (node_bincodes, b))
     end do
     call phs_tree_from_array (tree, bincode)
     call phs_tree_flip_t_to_s_channel (tree)
     call phs_tree_canonicalize (tree)
     n_mappings = parse_node_get_n_sub (node) - offset
     do m = 1, n_mappings
        node_mapping => parse_node_get_sub_ptr (node, m + offset)
        k = parse_node_get_integer &
             (parse_node_get_sub_ptr (node_mapping, 2))
        type = parse_node_get_key &
             (parse_node_get_sub_ptr (node_mapping, 3))
        pn_pdg => parse_node_get_sub_ptr (node_mapping, 4)
        select case (char (pn_pdg%get_rule_key ()))
        case ("pdg")
           pdg = pn_pdg%get_integer ()
        case ("negative_pdg")
           pdg = - parse_node_get_integer (pn_pdg%get_sub_ptr (2))
        end select
        call phs_tree_init_mapping (tree, k, type, pdg, model)
     end do
   end subroutine phs_tree_set
 
 @ %def phs_tree_set
 @
 \subsection{Preparation}
 The trees that we read from file do not carry flavor information.
 This is set separately:
 
 The flavor list must be unique for a unique set of masses; if a given
 particle can have different flavor, the mass must be degenerate, so we
 can choose one of the possible flavor combinations.
 <<PHS forests: public>>=
   public :: phs_forest_set_flavors
 <<PHS forests: procedures>>=
   subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra)
     type(phs_forest_t), intent(inout) :: forest
     type(flavor_t), dimension(:), intent(in) :: flv
     integer, intent(in), dimension(:), allocatable, optional :: reshuffle
     type(flavor_t), intent(in), optional :: flv_extra
     integer :: i, n_flv0
     if (present (reshuffle) .and. present (flv_extra)) then
        n_flv0 = size (flv)
        do i = 1, n_flv0
           if (reshuffle(i) <= n_flv0) then
              forest%flv(i) = flv (reshuffle(i))
           else
              forest%flv(i) = flv_extra
           end if
        end do
     else
        allocate (forest%flv (size (flv)))
        forest%flv = flv
     end if
   end subroutine phs_forest_set_flavors
 
 @ %def phs_forest_set_flavors
 @
 <<PHS forests: public>>=
   public :: phs_forest_set_momentum_links
 <<PHS forests: procedures>>=
   subroutine phs_forest_set_momentum_links (forest, list)
     type(phs_forest_t), intent(inout) :: forest
     integer, intent(in), dimension(:), allocatable :: list
     integer :: g, t
     do g = 1, size (forest%grove)
       do t = 1, size (forest%grove(g)%tree)
         associate (tree => forest%grove(g)%tree(t))
           call phs_tree_set_momentum_links (tree, list)
 !!!          call phs_tree_reshuffle_mappings (tree)
         end associate
       end do
     end do
   end subroutine phs_forest_set_momentum_links
 
 @ %def phs_forest_set_momentum_links
 @ Once the parameter set is fixed, the masses and the widths of the
 particles are known and the [[mass_sum]] arrays as well as the mapping
 parameters can be computed.  Note that order is important: we first
 compute the mass sums, then the ordinary mappings.  The resonances
 obtained here determine the effective masses, which in turn are used
 to implement step mappings for resonance decay products that are not
 mapped otherwise.
 <<PHS forests: public>>=
   public :: phs_forest_set_parameters
 <<PHS forests: procedures>>=
   subroutine phs_forest_set_parameters &
        (forest, mapping_defaults, variable_limits)
     type(phs_forest_t), intent(inout) :: forest
     type(mapping_defaults_t), intent(in) :: mapping_defaults
     logical, intent(in) :: variable_limits
     integer :: g, t
     do g = 1, size (forest%grove)
        do t = 1, size (forest%grove(g)%tree)
           call phs_tree_set_mass_sum &
                (forest%grove(g)%tree(t), forest%flv(forest%n_in+1:))
           call phs_tree_set_mapping_parameters (forest%grove(g)%tree(t), &
                mapping_defaults, variable_limits)
           call phs_tree_set_effective_masses (forest%grove(g)%tree(t))
           if (mapping_defaults%step_mapping) then
              call phs_tree_set_step_mappings (forest%grove(g)%tree(t), &
                   mapping_defaults%step_mapping_exp, variable_limits)
           end if
        end do
     end do
   end subroutine phs_forest_set_parameters
 
 @ %def phs_forest_set_parameters
 @ Generate the particle combination table.  Scan all trees and merge
 their individual combination tables.  At the end, valid entries are
 non-zero, and they indicate the indices of a pair of particles to be
 combined to a new particle.  If a particle is accessible by more than
 one tree (this is usual), only keep the first possibility.
 <<PHS forests: public>>=
   public :: phs_forest_setup_prt_combinations
 <<PHS forests: procedures>>=
   subroutine phs_forest_setup_prt_combinations (forest)
     type(phs_forest_t), intent(inout) :: forest
     integer :: g, t
     integer, dimension(:,:), allocatable :: tree_prt_combination
     forest%prt_combination = 0
     allocate (tree_prt_combination (2, size (forest%prt_combination, 2)))
     do g = 1, size (forest%grove)
        do t = 1, size (forest%grove(g)%tree)
           call phs_tree_setup_prt_combinations &
                (forest%grove(g)%tree(t), tree_prt_combination)
           where (tree_prt_combination /= 0 .and. forest%prt_combination == 0)
              forest%prt_combination = tree_prt_combination
           end where
        end do
     end do
   end subroutine phs_forest_setup_prt_combinations
 
 @ %def phs_forest_setup_prt_combinations
 @
 \subsection{Accessing the particle arrays}
 Set the incoming particles from the contents of an interaction.
 <<PHS forests: public>>=
   public :: phs_forest_set_prt_in
 <<PHS forests: interfaces>>=
   interface phs_forest_set_prt_in
      module procedure phs_forest_set_prt_in_int, phs_forest_set_prt_in_mom
   end interface phs_forest_set_prt_in
 <<PHS forests: procedures>>=
   subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab)
     type(phs_forest_t), intent(inout) :: forest
     type(interaction_t), intent(in) :: int
     type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     if (present (lt_cm_to_lab)) then
        call phs_prt_set_momentum (forest%prt_in, &
             inverse (lt_cm_to_lab) * &
             int%get_momenta (outgoing=.false.))
     else
        call phs_prt_set_momentum (forest%prt_in, &
             int%get_momenta (outgoing=.false.))
     end if
     associate (m_in => forest%flv(:forest%n_in)%get_mass ())
       call phs_prt_set_msq (forest%prt_in, m_in ** 2)
     end associate
     call phs_prt_set_defined (forest%prt_in)
   end subroutine phs_forest_set_prt_in_int
 
   subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab)
     type(phs_forest_t), intent(inout) :: forest
     type(vector4_t), dimension(size (forest%prt_in)), intent(in) :: mom
     type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     if (present (lt_cm_to_lab)) then
        call phs_prt_set_momentum (forest%prt_in, &
             inverse (lt_cm_to_lab) * mom)
     else
        call phs_prt_set_momentum (forest%prt_in, mom)
     end if
     associate (m_in => forest%flv(:forest%n_in)%get_mass ())
       call phs_prt_set_msq (forest%prt_in, m_in ** 2)
     end associate
     call phs_prt_set_defined (forest%prt_in)
   end subroutine phs_forest_set_prt_in_mom
 
 @ %def phs_forest_set_prt_in
 @ Set the outgoing particles from the contents of an interaction.
 <<PHS forests: public>>=
   public :: phs_forest_set_prt_out
 <<PHS forests: interfaces>>=
   interface phs_forest_set_prt_out
      module procedure phs_forest_set_prt_out_int, phs_forest_set_prt_out_mom
   end interface phs_forest_set_prt_out
 <<PHS forests: procedures>>=
   subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab)
     type(phs_forest_t), intent(inout) :: forest
     type(interaction_t), intent(in) :: int
     type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     if (present (lt_cm_to_lab)) then
        call phs_prt_set_momentum (forest%prt_out, &
             inverse (lt_cm_to_lab) * &
             int%get_momenta (outgoing=.true.))
     else
        call phs_prt_set_momentum (forest%prt_out, &
             int%get_momenta (outgoing=.true.))
     end if
     associate (m_out => forest%flv(forest%n_in+1:)%get_mass ())
       call phs_prt_set_msq (forest%prt_out, m_out ** 2)
     end associate
     call phs_prt_set_defined (forest%prt_out)
   end subroutine phs_forest_set_prt_out_int
 
   subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab)
     type(phs_forest_t), intent(inout) :: forest
     type(vector4_t), dimension(size (forest%prt_out)), intent(in) :: mom
     type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     if (present (lt_cm_to_lab)) then
        call phs_prt_set_momentum (forest%prt_out, &
             inverse (lt_cm_to_lab) * mom)
     else
        call phs_prt_set_momentum (forest%prt_out, mom)
     end if
     associate (m_out => forest%flv(forest%n_in+1:)%get_mass ())
       call phs_prt_set_msq (forest%prt_out, m_out ** 2)
     end associate
     call phs_prt_set_defined (forest%prt_out)
   end subroutine phs_forest_set_prt_out_mom
 
 @ %def phs_forest_set_prt_out
 @ Combine particles as described by the particle combination table.
 Particle momentum sums will be calculated only if the resulting
 particle is contained in at least one of the trees in the current
 forest.  The others are kept undefined.
 <<PHS forests: public>>=
   public :: phs_forest_combine_particles
 <<PHS forests: procedures>>=
   subroutine phs_forest_combine_particles (forest)
     type(phs_forest_t), intent(inout) :: forest
     integer :: k
     integer, dimension(2) :: kk
     do k = 1, size (forest%prt_combination, 2)
        kk = forest%prt_combination(:,k)
        if (kk(1) /= 0) then
           call phs_prt_combine (forest%prt(k), &
                forest%prt(kk(1)), forest%prt(kk(2)))
        end if
     end do
   end subroutine phs_forest_combine_particles
 
 @ %def phs_forest_combine_particles
 @ Extract the outgoing particles and insert into an interaction.
 <<PHS forests: public>>=
   public :: phs_forest_get_prt_out
 <<PHS forests: procedures>>=
   subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab)
     type(phs_forest_t), intent(in) :: forest
     type(interaction_t), intent(inout) :: int
     type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     if (present (lt_cm_to_lab)) then
        call int%set_momenta (lt_cm_to_lab * &
             phs_prt_get_momentum (forest%prt_out), outgoing=.true.)
     else
        call int%set_momenta (phs_prt_get_momentum (forest%prt_out), &
             outgoing=.true.)
     end if
   end subroutine phs_forest_get_prt_out
 
 @ %def phs_forest_get_prt_out
 @ Extract the outgoing particle momenta
 <<PHS forests: public>>=
   public :: phs_forest_get_momenta_out
 <<PHS forests: procedures>>=
   function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p)
     type(phs_forest_t), intent(in) :: forest
     type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     type(vector4_t), dimension(size (forest%prt_out)) :: p
     p = phs_prt_get_momentum (forest%prt_out)
     if (present (lt_cm_to_lab)) p = p * lt_cm_to_lab
   end function phs_forest_get_momenta_out
 
 @ %def phs_forest_get_momenta_out
 @
 \subsection{Find equivalences among phase-space trees}
 Scan phase space for equivalences.  We generate the complete set of
 unique permutations for the given list of outgoing particles, and use
 this for scanning equivalences within each grove.
 @ We scan all pairs of trees, using all permutations.  This implies
 that trivial equivalences are included, and equivalences between
 different trees are recorded twice.  This is intentional.
 <<PHS forests: procedures>>=
   subroutine phs_grove_set_equivalences (grove, perm_array)
     type(phs_grove_t), intent(inout) :: grove
     type(permutation_t), dimension(:), intent(in) :: perm_array
     type(equivalence_t), pointer :: eq
     integer :: t1, t2, i
     do t1 = 1, size (grove%tree)
        do t2 = 1, size (grove%tree)
           SCAN_PERM: do i = 1, size (perm_array)
              if (phs_tree_equivalent &
                   (grove%tree(t1), grove%tree(t2), perm_array(i))) then
                 call equivalence_list_add &
                      (grove%equivalence_list, t1, t2, perm_array(i))
                 eq => grove%equivalence_list%last
                 call phs_tree_find_msq_permutation &
                      (grove%tree(t1), grove%tree(t2), eq%perm, &
                       eq%msq_perm)
                 call phs_tree_find_angle_permutation &
                      (grove%tree(t1), grove%tree(t2), eq%perm, &
                       eq%angle_perm, eq%angle_sig)
              end if
           end do SCAN_PERM
        end do
     end do
   end subroutine phs_grove_set_equivalences
 
 @ %def phs_grove_set_equivalences
 <<PHS forests: public>>=
   public :: phs_forest_set_equivalences
 <<PHS forests: procedures>>=
   subroutine phs_forest_set_equivalences (forest)
     type(phs_forest_t), intent(inout) :: forest
     type(permutation_t), dimension(:), allocatable :: perm_array
     integer :: i
     call permutation_array_make &
          (perm_array, forest%flv(forest%n_in+1:)%get_pdg ())
     do i = 1, size (forest%grove)
        call phs_grove_set_equivalences (forest%grove(i), perm_array)
     end do
     forest%n_equivalences = sum (forest%grove%equivalence_list%length)
   end subroutine phs_forest_set_equivalences
 
 @ %def phs_forest_set_equivalences
 @
 \subsection{Interface for channel equivalences}
 Here, we store the equivalence list in the appropriate containers that
 the [[phs_base]] module provides.  There is one separate list for each
 channel.
 <<PHS forests: public>>=
   public :: phs_forest_get_equivalences
 <<PHS forests: procedures>>=
   subroutine phs_forest_get_equivalences (forest, channel, azimuthal_dependence)
     type(phs_forest_t), intent(in) :: forest
     type(phs_channel_t), dimension(:), intent(out) :: channel
     logical, intent(in) :: azimuthal_dependence
     integer :: n_masses, n_angles
     integer :: mode_azimuthal_angle
     integer, dimension(:), allocatable :: n_eq
     type(equivalence_t), pointer :: eq
     integer, dimension(:), allocatable :: perm, mode
     integer :: g, c, j, left, right
     n_masses = forest%n_masses
     n_angles = forest%n_angles
     allocate (n_eq (forest%n_trees), source = 0)
     allocate (perm (forest%n_dimensions))
     allocate (mode (forest%n_dimensions), source = EQ_IDENTITY)
     do g = 1, size (forest%grove)
        eq => forest%grove(g)%equivalence_list%first
        do while (associated (eq))
           left = eq%left + forest%grove(g)%tree_count_offset
           n_eq(left) = n_eq(left) + 1
           eq => eq%next
        end do
     end do
     do c = 1, size (channel)
        allocate (channel(c)%eq (n_eq(c)))
        do j = 1, n_eq(c)
           call channel(c)%eq(j)%init (forest%n_dimensions)
        end do
     end do
     n_eq = 0
     if (azimuthal_dependence) then
        mode_azimuthal_angle = EQ_IDENTITY
     else
        mode_azimuthal_angle = EQ_INVARIANT
     end if
     do g = 1, size (forest%grove)
        eq => forest%grove(g)%equivalence_list%first
        do while (associated (eq))
           left = eq%left + forest%grove(g)%tree_count_offset
           right = eq%right + forest%grove(g)%tree_count_offset
           do j = 1, n_masses
              perm(j) = permute (j, eq%msq_perm)
              mode(j) = EQ_IDENTITY
           end do
           do j = 1, n_angles
              perm(n_masses+j) = n_masses + permute (j, eq%angle_perm)
              if (j == 1) then
                 mode(n_masses+j) = mode_azimuthal_angle   ! first az. angle
              else if (mod(j,2) == 1) then
                 mode(n_masses+j) = EQ_SYMMETRIC          ! other az. angles
              else if (eq%angle_sig(j)) then
                 mode(n_masses+j) = EQ_IDENTITY           ! polar angle +
              else
                 mode(n_masses+j) = EQ_INVERT             ! polar angle -
              end if
           end do
           n_eq(left) = n_eq(left) + 1
           associate (eq_cur => channel(left)%eq(n_eq(left)))
             eq_cur%c = right
             eq_cur%perm = perm
             eq_cur%mode = mode
           end associate
           eq => eq%next
        end do
     end do
   end subroutine phs_forest_get_equivalences
 
 @ %def phs_forest_get_equivalences
 @
 \subsection{Phase-space evaluation}
 Given one row of the [[x]] parameter array and the corresponding
 channel index, compute first all relevant momenta and then recover the
 remainder of the [[x]] array, the Jacobians [[phs_factor]], and the
 phase-space [[volume]].
 
 The output argument [[ok]] indicates whether this was successful.
 <<PHS forests: public>>=
   public :: phs_forest_evaluate_selected_channel
 <<PHS forests: procedures>>=
   subroutine phs_forest_evaluate_selected_channel &
        (forest, channel, active, sqrts, x, phs_factor, volume, ok)
     type(phs_forest_t), intent(inout) :: forest
     integer, intent(in) :: channel
     logical, dimension(:), intent(in) :: active
     real(default), intent(in) :: sqrts
     real(default), dimension(:,:), intent(inout) :: x
     real(default), dimension(:), intent(out) :: phs_factor
     real(default), intent(out) :: volume
     logical, intent(out) :: ok
     integer :: g, t
     integer(TC) :: k, k_root, k_in
 
     g = forest%grove_lookup (channel)
     t = channel - forest%grove(g)%tree_count_offset
     call phs_prt_set_undefined (forest%prt)
     call phs_prt_set_undefined (forest%prt_out)
     k_in = forest%n_tot
 
     do k = 1,forest%n_in
        forest%prt(ibset(0,k_in-k)) = forest%prt_in(k)
     end do
 
     do k = 1, forest%n_out
        call phs_prt_set_msq (forest%prt(ibset(0,k-1)), &
             forest%flv(forest%n_in+k)%get_mass () ** 2)
     end do
 
 
     k_root = 2**forest%n_out - 1
     select case (forest%n_in)
     case (1)
        forest%prt(k_root) = forest%prt_in(1)
     case (2)
        call phs_prt_combine &
             (forest%prt(k_root), forest%prt_in(1), forest%prt_in(2))
     end select
     call phs_tree_compute_momenta_from_x (forest%grove(g)%tree(t), &
          forest%prt, phs_factor(channel), volume, sqrts, x(:,channel), ok)
     if (ok) then
        do k = 1, forest%n_out
           forest%prt_out(k) = forest%prt(ibset(0,k-1))
        end do
     end if
   end subroutine phs_forest_evaluate_selected_channel
 
 @ %def phs_forest_evaluate_selected_channel
 @ The remainder: recover $x$ values for all channels except for the current
 channel.
 
 NOTE: OpenMP not used for the first loop.  [[combine_particles]] is not a
 channel-local operation.
 <<PHS forests: public>>=
   public :: phs_forest_evaluate_other_channels
 <<PHS forests: procedures>>=
   subroutine phs_forest_evaluate_other_channels &
        (forest, channel, active, sqrts, x, phs_factor, combine)
     type(phs_forest_t), intent(inout) :: forest
     integer, intent(in) :: channel
     logical, dimension(:), intent(in) :: active
     real(default), intent(in) :: sqrts
     real(default), dimension(:,:), intent(inout) :: x
     real(default), dimension(:), intent(inout) :: phs_factor
     logical, intent(in) :: combine
     integer :: g, t, ch, n_channel
 
     g = forest%grove_lookup (channel)
     t = channel - forest%grove(g)%tree_count_offset
 
     n_channel = forest%n_trees
     if (combine) then
        do ch = 1, n_channel
           if (ch == channel)  cycle
           if (active(ch)) then
              g = forest%grove_lookup(ch)
              t = ch - forest%grove(g)%tree_count_offset
              call phs_tree_combine_particles &
                   (forest%grove(g)%tree(t), forest%prt)
           end if
        end do
     end if
 
     !OMP PARALLEL PRIVATE (g,t,ch) SHARED(active,forest,sqrts,x,channel)
     !OMP DO SCHEDULE(STATIC)
     do ch = 1, n_channel
        if (ch == channel)  cycle
        if (active(ch)) then
           g = forest%grove_lookup(ch)
           t = ch - forest%grove(g)%tree_count_offset
           call phs_tree_compute_x_from_momenta &
                (forest%grove(g)%tree(t), &
                forest%prt, phs_factor(ch), sqrts, x(:,ch))
        end if
     end do
     !OMP END DO
     !OMP END PARALLEL
 
   end subroutine phs_forest_evaluate_other_channels
 
 @ %def phs_forest_evaluate_other_channels
 @ The complement: recover one row of the [[x]] array and the
 associated Jacobian entry, corresponding to
 [[channel]], from incoming and outgoing momenta.  Also compute the
 phase-space volume.
 <<PHS forests: public>>=
   public :: phs_forest_recover_channel
 <<PHS forests: procedures>>=
   subroutine phs_forest_recover_channel &
        (forest, channel, sqrts, x, phs_factor, volume)
     type(phs_forest_t), intent(inout) :: forest
     integer, intent(in) :: channel
     real(default), intent(in) :: sqrts
     real(default), dimension(:,:), intent(inout) :: x
     real(default), dimension(:), intent(inout) :: phs_factor
     real(default), intent(out) :: volume
     integer :: g, t
     integer(TC) :: k, k_in
     g = forest%grove_lookup (channel)
     t = channel - forest%grove(g)%tree_count_offset
     call phs_prt_set_undefined (forest%prt)
     k_in = forest%n_tot
     forall (k = 1:forest%n_in)
        forest%prt(ibset(0,k_in-k)) = forest%prt_in(k)
     end forall
     forall (k = 1:forest%n_out)
        forest%prt(ibset(0,k-1)) = forest%prt_out(k)
     end forall
     call phs_forest_combine_particles (forest)
     call phs_tree_compute_volume &
          (forest%grove(g)%tree(t), sqrts, volume)
     call phs_tree_compute_x_from_momenta &
          (forest%grove(g)%tree(t), &
          forest%prt, phs_factor(channel), sqrts, x(:,channel))
   end subroutine phs_forest_recover_channel
 
 @ %def phs_forest_recover_channel
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[phs_forests_ut.f90]]>>=
 <<File header>>
 
 module phs_forests_ut
   use unit_tests
   use phs_forests_uti
 
 <<Standard module head>>
 
 <<PHS forests: public test>>
 
 contains
 
 <<PHS forests: test driver>>
 
 end module phs_forests_ut
 @ %def phs_forests_ut
 @
 <<[[phs_forests_uti.f90]]>>=
 <<File header>>
 
 module phs_forests_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_12
   use lorentz
   use flavors
   use interactions
   use model_data
   use mappings
   use phs_base
   use resonances, only: resonance_history_set_t
 
   use phs_forests
 
 <<Standard module head>>
 
 <<PHS forests: test declarations>>
 
 contains
 
 <<PHS forests: tests>>
 
 end module phs_forests_uti
 @ %def phs_forests_ut
 @ API: driver for the unit tests below.
 <<PHS forests: public test>>=
   public :: phs_forests_test
 <<PHS forests: test driver>>=
   subroutine phs_forests_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS forests: execute tests>>
   end subroutine phs_forests_test
 
 @  %def phs_forests_test
 @
 \subsubsection{Basic universal test}
 Write a possible phase-space file for a $2\to 3$ process and make the
 corresponding forest, print the forest. Choose some in-particle
 momenta and a random-number array and evaluate out-particles and
 phase-space factors.
 <<PHS forests: execute tests>>=
   call test (phs_forest_1, "phs_forest_1", &
        "check phs forest setup", &
        u, results)
 <<PHS forests: test declarations>>=
   public :: phs_forest_1
 <<PHS forests: tests>>=
   subroutine phs_forest_1 (u)
     use os_interface
     integer, intent(in) :: u
     type(phs_forest_t) :: forest
     type(phs_channel_t), dimension(:), allocatable :: channel
     type(model_data_t), target :: model
     type(string_t) :: process_id
     type(flavor_t), dimension(5) :: flv
     type(string_t) :: filename
     type(interaction_t) :: int
     integer :: unit_fix
     type(mapping_defaults_t) :: mapping_defaults
     logical :: found_process, ok
     integer :: n_channel, ch, i
     logical, dimension(4) :: active = .true.
     real(default) :: sqrts = 1000
     real(default), dimension(5,4) :: x
     real(default), dimension(4) :: factor
     real(default) :: volume
 
     write (u, "(A)")  "* Test output: PHS forest"
     write (u, "(A)")  "*   Purpose: test PHS forest routines"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Create phase-space file 'phs_forest_test.phs'"
     write (u, "(A)")
 
     call flv%init ([11, -11, 11, -11, 22], model)
     unit_fix = free_unit ()
     open (file="phs_forest_test.phs", unit=unit_fix, action="write")
     write (unit_fix, *) "process foo"
     write (unit_fix, *) 'md5sum_process    = "6ABA33BC2927925D0F073B1C1170780A"'
     write (unit_fix, *) 'md5sum_model_par  = "1A0B151EE6E2DEB92D880320355A3EAB"'
     write (unit_fix, *) 'md5sum_phs_config = "B6A8877058809A8BDD54753CDAB83ACE"'
     write (unit_fix, *) "sqrts         =    100.00000000000000"
     write (unit_fix, *) "m_threshold_s =    50.000000000000000"
     write (unit_fix, *) "m_threshold_t =    100.00000000000000"
     write (unit_fix, *) "off_shell =            2"
     write (unit_fix, *) "t_channel =            6"
     write (unit_fix, *) "keep_nonresonant =  F"
     write (unit_fix, *) ""
     write (unit_fix, *) "  grove"
     write (unit_fix, *) "    tree 3 7"
     write (unit_fix, *) "      map 3 s_channel 23"
     write (unit_fix, *) "    tree 5 7"
     write (unit_fix, *) "    tree 6 7"
     write (unit_fix, *) "  grove"
     write (unit_fix, *) "    tree 9 11"
     write (unit_fix, *) "      map 9 t_channel 22"
     close (unit_fix)
 
     write (u, "(A)")
     write (u, "(A)")  "* Read phase-space file 'phs_forest_test.phs'"
 
     call syntax_phs_forest_init ()
     process_id = "foo"
     filename = "phs_forest_test.phs"
     call phs_forest_read &
          (forest, filename, process_id, 2, 3, model, found_process)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parameters, flavors, equiv, momenta"
     write (u, "(A)")
 
     call phs_forest_set_flavors (forest, flv)
     call phs_forest_set_parameters (forest, mapping_defaults, .false.)
     call phs_forest_setup_prt_combinations (forest)
     call phs_forest_set_equivalences (forest)
     call int%basic_init (2, 0, 3)
     call int%set_momentum &
          (vector4_moving (500._default, 500._default, 3), 1)
     call int%set_momentum &
          (vector4_moving (500._default,-500._default, 3), 2)
     call phs_forest_set_prt_in (forest, int)
     n_channel = 2
     x = 0
     x(:,n_channel) = [0.3, 0.4, 0.1, 0.9, 0.6]
     write (u, "(A)")  "   Input values:"
     write (u, "(3x,5(1x," // FMT_12 // "))")  x(:,n_channel)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluating phase space"
 
     call phs_forest_evaluate_selected_channel (forest, &
          n_channel, active, sqrts, x, factor, volume, ok)
     call phs_forest_evaluate_other_channels (forest, &
          n_channel, active, sqrts, x, factor, combine=.true.)
     call phs_forest_get_prt_out (forest, int)
     write (u, "(A)")  "   Output values:"
     do ch = 1, 4
        write (u, "(3x,5(1x," // FMT_12 // "))")  x(:,ch)
     end do
     call int%basic_write (u)
     write (u, "(A)")  "   Factors:"
     write (u, "(3x,5(1x," // FMT_12 // "))")  factor
     write (u, "(A)")  "   Volume:"
     write (u, "(3x,5(1x," // FMT_12 // "))")  volume
     call phs_forest_write (forest, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute equivalences"
 
     n_channel = 4
     allocate (channel (n_channel))
     call phs_forest_get_equivalences (forest, &
          channel, .true.)
     do i = 1, n_channel
        write (u, "(1x,I0,':')", advance = "no")  ch
        call channel(i)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
     call phs_forest_final (forest)
     call syntax_phs_forest_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_forest_1"
 
   end subroutine phs_forest_1
 
 @ %def phs_forest_1
 @
 \subsubsection{Resonance histories}
 Read a suitably nontrivial forest from file and recover the set of
 resonance histories.
 <<PHS forests: execute tests>>=
   call test (phs_forest_2, "phs_forest_2", &
        "handle phs forest resonance content", &
        u, results)
 <<PHS forests: test declarations>>=
   public :: phs_forest_2
 <<PHS forests: tests>>=
   subroutine phs_forest_2 (u)
     use os_interface
     integer, intent(in) :: u
     integer :: unit_fix
     type(phs_forest_t) :: forest
     type(model_data_t), target :: model
     type(string_t) :: process_id
     type(string_t) :: filename
     logical :: found_process
     type(resonance_history_set_t) :: res_set
     integer :: i
 
     write (u, "(A)")  "* Test output: phs_forest_2"
     write (u, "(A)")  "*   Purpose: test PHS forest routines"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
 
     call model%init_sm_test ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Create phase-space file 'phs_forest_2.phs'"
     write (u, "(A)")
 
     unit_fix = free_unit ()
     open (file="phs_forest_2.phs", unit=unit_fix, action="write")
     write (unit_fix, *) "process foo"
     write (unit_fix, *) 'md5sum_process    = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"'
     write (unit_fix, *) 'md5sum_model_par  = "1A0B151EE6E2DEB92D880320355A3EAB"'
     write (unit_fix, *) 'md5sum_phs_config = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"'
     write (unit_fix, *) "sqrts         =    100.00000000000000"
     write (unit_fix, *) "m_threshold_s =    50.000000000000000"
     write (unit_fix, *) "m_threshold_t =    100.00000000000000"
     write (unit_fix, *) "off_shell =            2"
     write (unit_fix, *) "t_channel =            6"
     write (unit_fix, *) "keep_nonresonant =  F"
     write (unit_fix, *) ""
     write (unit_fix, *) "  grove"
     write (unit_fix, *) "    tree 3 7"
     write (unit_fix, *) "    tree 3 7"
     write (unit_fix, *) "      map 3 s_channel -24"
     write (unit_fix, *) "    tree 5 7"
     write (unit_fix, *) "    tree 3 7"
     write (unit_fix, *) "      map 3 s_channel -24"
     write (unit_fix, *) "      map 7 s_channel 23"
     write (unit_fix, *) "    tree 5 7"
     write (unit_fix, *) "      map 7 s_channel 25"
     write (unit_fix, *) "    tree 3 11"
     write (unit_fix, *) "      map 3 s_channel -24"
     close (unit_fix)
 
     write (u, "(A)")  "* Read phase-space file 'phs_forest_2.phs'"
 
     call syntax_phs_forest_init ()
     process_id = "foo"
     filename = "phs_forest_2.phs"
     call phs_forest_read &
          (forest, filename, process_id, 2, 3, model, found_process)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract resonance history set"
     write (u, "(A)")
 
     call forest%extract_resonance_history_set (res_set)
     call res_set%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
     call phs_forest_final (forest)
     call syntax_phs_forest_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_forest_2"
 
   end subroutine phs_forest_2
 
 @ %def phs_forest_2
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Finding phase space parameterizations}
 If the phase space configuration is not found in the appropriate file,
 we should generate one.
 
 The idea is to construct all Feynman diagrams subject to certain
 constraints which eliminate everything that is probably irrelevant for
 the integration.  These Feynman diagrams (cascades) are grouped in
 groves by finding equivalence classes related by symmetry and ordered
 with respect to their importance (resonances).  Finally, the result
 (or part of it) is written to file and used for the integration.
 
 This module may eventually disappear and be replaced by CAML code.
 In particular, we need here a set of Feynman rules (vertices with
 particle codes, but not the factors).  Thus, the module works for the
 Standard Model only.
 
 Note that this module is stand-alone, it communicates to the main
 program only via the generated ASCII phase-space configuration file.
 <<[[cascades.f90]]>>=
 <<File header>>
 
 module cascades
 
 <<Use kinds>>
   use kinds, only: TC, i8, i32
 <<Use strings>>
 <<Use debug>>
   use io_units
   use constants, only: one
   use format_defs, only: FMT_12, FMT_19
   use numeric_utils
   use diagnostics
   use hashes
   use sorting
   use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
   use physics_defs, only: UNDEFINED
   use model_data
   use flavors
   use lorentz
 
   use resonances, only: resonance_info_t
   use resonances, only: resonance_history_t
   use resonances, only: resonance_history_set_t
   use phs_forests
 
 <<Standard module head>>
 
 <<Cascades: public>>
 
 <<Cascades: parameters>>
 
 <<Cascades: types>>
 
 <<Cascades: interfaces>>
 
 contains
 
 <<Cascades: procedures>>
 
 end module cascades
 @ %def cascades
 @
 \subsection{The mapping modes}
 The valid mapping modes, to be used below.  We will make use of the convention
 that mappings of internal particles have a positive value.  Only for positive
 values, the flavor code is propagated when combining cascades.
 <<Mapping modes>>=
   integer, parameter :: &
        & EXTERNAL_PRT = -1, &
        & NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL =  2, U_CHANNEL = 3, &
        & RADIATION = 4, COLLINEAR = 5, INFRARED = 6, &
        & STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, &
        & ON_SHELL = 99
 @ %def EXTERNAL_PRT
 @ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL
 @ %def RADIATION COLLINEAR INFRARED
 @ %def STEP_MAPPING_E STEP_MAPPING_H
 @ %def ON_SHELL
 <<Cascades: parameters>>=
 <<Mapping modes>>
 @
 \subsection{The cascade type}
 A cascade is essentially the same as a decay tree (both definitions
 may be merged in a later version).  It contains a linked tree of
 nodes, each of which representing an internal particle.  In contrast
 to decay trees, each node has a definite particle code.  These nodes
 need not be modified, therefore we can use pointers and do not have to
 copy them.  Thus, physically each cascades has only a single node, the
 mother particle.  However, to be able to compare trees quickly, we
 store in addition an array of binary codes which is always sorted in
 ascending order.  This is accompanied by a corresponding list of
 particle codes.  The index is the location of the corresponding
 cascade in the cascade set, this may be used to access the daughters
 directly.
 
 The real mass is the particle mass belonging to the particle code.
 The minimal mass is the sum of the real masses of all its daughters;
 this is the kinematical cutoff.  The effective mass may be zero if the
 particle mass is below a certain threshold; it may be the real mass if
 the particle is resonant; or it may be some other value.
 
 The logical [[t_channel]] is set if this a $t$-channel line, while
 [[initial]] is true only for an initial particle.  Note that both
 initial particles are also [[t_channel]] by definition, and that they
 are distinguished by the direction of the tree:  One of them decays
 and is the root of the tree, while the other one is one of the leaves.
 
 The cascade is a list of nodes (particles) which are linked via the
 [[daughter]] entries.  The node is the mother particle of
 the decay cascade.  Much of the information in the nodes is repeated
 in arrays, to be accessible more easily.  The arrays will be kept
 sorted by binary codes.
 
 The counter [[n_off_shell]] is increased for each internal line that
 is neither resonant nor log-enhanced.  It is set to zero if the
 current line is resonant, since this implies on-shell particle production
 and subsequent decay.
 
 The counter [[n_t_channel]] is non-negative once an initial particle
 is included in the tree: then, it counts the number of $t$-channel lines.
 
 The [[multiplicity]] is the number of branchings to follow until all
 daughters are on-shell.  A resonant or non-decaying particle has
 multiplicity one.  Merging nodes, the multiplicities add unless the
 mother is a resonance.  An initial or final node has multiplicity
 zero.
 
 The arrays correspond to the subnode tree [[tree]] of the current
 cascade.  PDG codes are stored only for those positions which are
 resonant, with the exception of the last entry, i.e., the current node.
 Other positions, in particular external legs, are assigned undefined
 PDG code.
 
 A cascade is uniquely identified by its tree, the tree of PDG codes,
 and the tree of mappings.  The tree of resonances is kept only to mask
 the PDG tree as described above.
 <<Cascades: types>>=
   type :: cascade_t
      private
      ! counters
      integer :: index = 0
      integer :: grove = 0
      ! status
      logical :: active = .false.
      logical :: complete = .false.
      logical :: incoming = .false.
      ! this node
      integer(TC) :: bincode = 0
      type(flavor_t) :: flv
      integer :: pdg = UNDEFINED
      logical :: is_vector = .false.
      real(default) :: m_min = 0
      real(default) :: m_rea = 0
      real(default) :: m_eff = 0
      integer :: mapping = NO_MAPPING
      logical :: on_shell = .false.
      logical :: resonant = .false.
      logical :: log_enhanced = .false.
      logical :: t_channel = .false.
      ! global tree properties
      integer :: multiplicity = 0
      integer :: internal = 0
      integer :: n_off_shell = 0
      integer :: n_resonances = 0
      integer :: n_log_enhanced = 0
      integer :: n_t_channel = 0
      integer :: res_hash = 0
      ! the sub-node tree
      integer :: depth = 0
      integer(TC), dimension(:), allocatable :: tree
      integer, dimension(:), allocatable :: tree_pdg
      integer, dimension(:), allocatable :: tree_mapping
      logical, dimension(:), allocatable :: tree_resonant
      ! branch connections
      logical :: has_children = .false.
      type(cascade_t), pointer :: daughter1 => null ()
      type(cascade_t), pointer :: daughter2 => null ()
      type(cascade_t), pointer :: mother => null ()
      ! next in list
      type(cascade_t), pointer :: next => null ()
    contains
    <<Cascades: cascade: TBP>>
   end type cascade_t
 
 @ %def cascade_t
 <<Cascades: procedures>>=
   subroutine cascade_init (cascade, depth)
     type(cascade_t), intent(out) :: cascade
     integer, intent(in) :: depth
     integer, save :: index = 0
     index = cascade_index ()
     cascade%index = index
     cascade%depth = depth
     cascade%active = .true.
     allocate (cascade%tree (depth))
     allocate (cascade%tree_pdg (depth))
     allocate (cascade%tree_mapping (depth))
     allocate (cascade%tree_resonant (depth))
   end subroutine cascade_init
 @ %def cascade_init
 @ Keep and increment a global index
 <<Cascades: procedures>>=
   function cascade_index (seed) result (index)
     integer :: index
     integer, intent(in), optional :: seed
     integer, save :: i = 0
     if (present (seed))  i = seed
     i = i + 1
     index = i
   end function cascade_index
 
 @ %def cascade_index
 @ We need three versions of writing cascades.  This goes to the
 phase-space file.
 
 For t/u channel mappings, we use the absolute value of the PDG code.
 <<Cascades: procedures>>=
   subroutine cascade_write_file_format (cascade, model, unit)
     type(cascade_t), intent(in) :: cascade
     class(model_data_t), intent(in), target :: model
     integer, intent(in), optional :: unit
     type(flavor_t) :: flv
     integer :: u, i
 2   format(3x,A,1x,I3,1x,A,1x,I9,1x,'!',1x,A)
     u = given_output_unit (unit);  if (u < 0)  return
     call write_reduced (cascade%tree, u)
     write (u, "(A)")
     do i = 1, cascade%depth
        call flv%init (cascade%tree_pdg(i), model)
        select case (cascade%tree_mapping(i))
        case (NO_MAPPING, EXTERNAL_PRT)
        case (S_CHANNEL)
           write(u,2) 'map', &
                cascade%tree(i), 's_channel', cascade%tree_pdg(i), &
                char (flv%get_name ())
        case (T_CHANNEL)
           write(u,2) 'map', &
                cascade%tree(i), 't_channel', abs (cascade%tree_pdg(i)), &
                char (flv%get_name ())
        case (U_CHANNEL)
           write(u,2) 'map', &
                cascade%tree(i), 'u_channel', abs (cascade%tree_pdg(i)), &
                char (flv%get_name ())
        case (RADIATION)
           write(u,2) 'map', &
                cascade%tree(i), 'radiation', cascade%tree_pdg(i), &
                char (flv%get_name ())
        case (COLLINEAR)
           write(u,2) 'map', &
                cascade%tree(i), 'collinear', cascade%tree_pdg(i), &
                char (flv%get_name ())
        case (INFRARED)
           write(u,2) 'map', &
                cascade%tree(i), 'infrared ', cascade%tree_pdg(i), &
                char (flv%get_name ())
        case (ON_SHELL)
           write(u,2) 'map', &
                cascade%tree(i), 'on_shell ', cascade%tree_pdg(i), &
                char (flv%get_name ())
        case default
           call msg_bug (" Impossible mapping mode encountered")
        end select
     end do
   contains
     subroutine write_reduced (array, unit)
       integer(TC), dimension(:), intent(in) :: array
       integer, intent(in) :: unit
       integer :: i
       write (u, "(3x,A,1x)", advance="no")  "tree"
       do i = 1, size (array)
          if (decay_level (array(i)) > 1) then
             write (u, "(1x,I0)", advance="no")  array(i)
          end if
       end do
     end subroutine write_reduced
 
     elemental function decay_level (k) result (l)
       integer(TC), intent(in) :: k
       integer :: l
       integer :: i
       l = 0
       do i = 0, bit_size(k) - 1
          if (btest(k,i)) l = l + 1
       end do
     end function decay_level
     subroutine start_comment (u)
       integer, intent(in) :: u
       write(u, '(1x,A)', advance='no') '!'
     end subroutine start_comment
   end subroutine cascade_write_file_format
 
 @ %def cascade_write_file_format
 @ This creates metapost source for graphical display:
 <<Cascades: procedures>>=
   subroutine cascade_write_graph_format (cascade, count, unit)
     type(cascade_t), intent(in) :: cascade
     integer, intent(in) :: count
     integer, intent(in), optional :: unit
     integer :: u
     integer(TC) :: mask
     type(string_t) :: left_str, right_str
     u = given_output_unit (unit);  if (u < 0)  return
     mask = 2**((cascade%depth+3)/2) - 1
     left_str = ""
     right_str = ""
     write (u, '(A)') "\begin{minipage}{105pt}"
     write (u, '(A)') "\vspace{30pt}"
     write (u, '(A)') "\begin{center}"
     write (u, '(A)') "\begin{fmfgraph*}(55,55)"
     call graph_write (cascade, mask)
     write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}"
     write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}"
     write (u, '(A)') "\end{fmfgraph*}\\"
     write (u, '(A,I5,A)') "\fbox{$", count, "$}"
     write (u, '(A)') "\end{center}"
     write (u, '(A)') "\end{minipage}"
     write (u, '(A)') "%"
   contains
     recursive subroutine graph_write (cascade, mask, reverse)
       type(cascade_t), intent(in) :: cascade
       integer(TC), intent(in) :: mask
       logical, intent(in), optional :: reverse
       type(flavor_t) :: anti
       logical :: rev
       rev = .false.;  if (present(reverse))  rev = reverse
       if (cascade%has_children) then
          if (.not.rev) then
             call vertex_write (cascade, cascade%daughter1, mask)
             call vertex_write (cascade, cascade%daughter2, mask)
          else
             call vertex_write (cascade, cascade%daughter2, mask, .true.)
             call vertex_write (cascade, cascade%daughter1, mask, .true.)
          end if
          if (cascade%complete) then
             call vertex_write (cascade, cascade%mother, mask, .true.)
             write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}"
          end if
       else
          if (cascade%incoming) then
             anti = cascade%flv%anti ()
             call external_write (cascade%bincode, anti%get_tex_name (), &
                  left_str)
          else
             call external_write (cascade%bincode, cascade%flv%get_tex_name (), &
                  right_str)
          end if
       end if
     end subroutine graph_write
     recursive subroutine vertex_write (cascade, daughter, mask, reverse)
       type(cascade_t), intent(in) :: cascade, daughter
       integer(TC), intent(in) :: mask
       logical, intent(in), optional :: reverse
       integer :: bincode
       if (cascade%complete) then
          bincode = 0
       else
          bincode = cascade%bincode
       end if
       call graph_write (daughter, mask, reverse)
       if (daughter%has_children) then
          call line_write (bincode, daughter%bincode, daughter%flv, &
               mapping=daughter%mapping)
       else
          call line_write (bincode, daughter%bincode, daughter%flv)
       end if
     end subroutine vertex_write
     subroutine line_write (i1, i2, flv, mapping)
       integer(TC), intent(in) :: i1, i2
       type(flavor_t), intent(in) :: flv
       integer, intent(in), optional :: mapping
       integer :: k1, k2
       type(string_t) :: prt_type
       select case (flv%get_spin_type ())
       case (SCALAR);       prt_type = "plain"
       case (SPINOR);       prt_type = "fermion"
       case (VECTOR);       prt_type = "boson"
       case (VECTORSPINOR); prt_type = "fermion"
       case (TENSOR);       prt_type = "dbl_wiggly"
       case default;        prt_type = "dashes"
       end select
       if (flv%is_antiparticle ()) then
          k1 = i2;  k2 = i1
       else
          k1 = i1;  k2 = i2
       end if
       if (present (mapping)) then
          select case (mapping)
          case (S_CHANNEL)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=blue,lab=\sm\blue$" // &
                  & char (flv%get_tex_name ()) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case (T_CHANNEL, U_CHANNEL)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=cyan,lab=\sm\cyan$" // &
                  & char (flv%get_tex_name ()) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case (RADIATION)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=green,lab=\sm\green$" // &
                  & char (flv%get_tex_name ()) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case (COLLINEAR)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=magenta,lab=\sm\magenta$" // &
                  & char (flv%get_tex_name ()) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case (INFRARED)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=red,lab=\sm\red$" // &
                  & char (flv%get_tex_name ()) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case default
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=black}" // &
                  & "{v", k1, ",v", k2, "}"
          end select
       else
          write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & "}" // &
                  & "{v", k1, ",v", k2, "}"
       end if
     end subroutine line_write
     subroutine external_write (bincode, name, ext_str)
       integer(TC), intent(in) :: bincode
       type(string_t), intent(in) :: name
       type(string_t), intent(inout) :: ext_str
       character(len=20) :: str
       write (str, '(A2,I0)') ",v", bincode
       ext_str = ext_str // trim (str)
       write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" &
         // char (name) &
         // "\,(", bincode, ")" &
         // "$}{v", bincode, "}"
     end subroutine external_write
   end subroutine cascade_write_graph_format
 
 @ %def cascade_write_graph_format
 @ This is for screen/debugging output:
 <<Cascades: procedures>>=
   subroutine cascade_write (cascade, unit)
     type(cascade_t), intent(in) :: cascade
     integer, intent(in), optional :: unit
     integer :: u
     character(9) :: depth
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(A,(1x,I7))") 'Cascade #', cascade%index
     write (u, "(A,(1x,I7))") '  Grove:       #', cascade%grove
     write (u, "(A,3(1x,L1))") '  act/cmp/inc:  ', &
          cascade%active, cascade%complete, cascade%incoming
     write (u, "(A,I0)") '  Bincode:      ', cascade%bincode
     write (u, "(A)", advance="no") '  Flavor:       '
     call cascade%flv%write (unit)
     write (u, "(A,I9)") '  Active flavor:', cascade%pdg
     write (u, "(A,L1)") '  Is vector:    ', cascade%is_vector
     write (u, "(A,3(1x," // FMT_19 // "))") '  Mass (m/r/e): ', &
          cascade%m_min, cascade%m_rea, cascade%m_eff
     write (u, "(A,I1)") '  Mapping:      ', cascade%mapping
     write (u, "(A,3(1x,L1))") '  res/log/tch:  ', &
          cascade%resonant, cascade%log_enhanced, cascade%t_channel
     write (u, "(A,(1x,I7))") '  Multiplicity: ', cascade%multiplicity
     write (u, "(A,2(1x,I7))") '  n intern/off: ', &
          cascade%internal, cascade%n_off_shell
     write (u, "(A,3(1x,I7))") '  n res/log/tch:', &
          cascade%n_resonances, cascade%n_log_enhanced, cascade%n_t_channel
     write (u, "(A,I7)") '  Depth:        ', cascade%depth
     write (depth, "(I7)") cascade%depth
     write (u, "(A," // depth // "(1x,I7))") &
        '  Tree:         ', cascade%tree
     write (u, "(A," // depth // "(1x,I7))") &
        '  Tree(PDG):    ', cascade%tree_pdg
     write (u, "(A," // depth // "(1x,I7))") &
        '  Tree(mapping):', cascade%tree_mapping
     write (u, "(A," // depth // "(1x,L1))") &
        '  Tree(res):    ', cascade%tree_resonant
     if (cascade%has_children) then
        write (u, "(A,I7,1x,I7)") '  Daughter1/2:  ', &
             cascade%daughter1%index, cascade%daughter2%index
     end if
     if (associated (cascade%mother)) then
        write (u, "(A,I7)") '  Mother:       ', cascade%mother%index
     end if
   end subroutine cascade_write
 
 @ %def cascade_write
 @
 \subsection{Creating new cascades}
 This initializes a single-particle cascade (external, final state).
 The PDG entry in the tree is set undefined because the cascade is not
 resonant.  However, the flavor entry is set, so the cascade flavor
 is identified nevertheless.
 <<Cascades: procedures>>=
   subroutine cascade_init_outgoing (cascade, flv, pos, m_thr)
     type(cascade_t), intent(out) :: cascade
     type(flavor_t), intent(in) :: flv
     integer, intent(in) :: pos
     real(default), intent(in) :: m_thr
     call cascade_init (cascade, 1)
     cascade%bincode = ibset (0_TC, pos-1)
     cascade%flv = flv
     cascade%pdg = cascade%flv%get_pdg ()
     cascade%is_vector = flv%get_spin_type () == VECTOR
     cascade%m_min = flv%get_mass ()
     cascade%m_rea = cascade%m_min
     if (cascade%m_rea >= m_thr) then
        cascade%m_eff = cascade%m_rea
     end if
     cascade%on_shell = .true.
     cascade%multiplicity = 1
     cascade%tree(1) = cascade%bincode
     cascade%tree_pdg(1) = cascade%pdg
     cascade%tree_mapping(1) = EXTERNAL_PRT
     cascade%tree_resonant(1) = .false.
   end subroutine cascade_init_outgoing
 
 @ %def cascade_init_outgoing
 @ The same for an incoming line:
 <<Cascades: procedures>>=
   subroutine cascade_init_incoming (cascade, flv, pos, m_thr)
     type(cascade_t), intent(out) :: cascade
     type(flavor_t), intent(in) :: flv
     integer, intent(in) :: pos
     real(default), intent(in) :: m_thr
     call cascade_init (cascade, 1)
     cascade%incoming = .true.
     cascade%bincode = ibset (0_TC, pos-1)
     cascade%flv = flv%anti ()
     cascade%pdg = cascade%flv%get_pdg ()
     cascade%is_vector = flv%get_spin_type () == VECTOR
     cascade%m_min = flv%get_mass ()
     cascade%m_rea = cascade%m_min
     if (cascade%m_rea >= m_thr) then
        cascade%m_eff = cascade%m_rea
     end if
     cascade%on_shell = .true.
     cascade%n_t_channel = 0
     cascade%n_off_shell = 0
     cascade%tree(1) = cascade%bincode
     cascade%tree_pdg(1) = cascade%pdg
     cascade%tree_mapping(1) = EXTERNAL_PRT
     cascade%tree_resonant(1) = .false.
   end subroutine cascade_init_incoming
 
 @ %def cascade_init_outgoing
 @
 \subsection{Tools}
 This function returns true if the two cascades share no common
 external particle.  This is a requirement for joining them.
 <<Cascades: interfaces>>=
   interface operator(.disjunct.)
      module procedure cascade_disjunct
   end interface
 
 <<Cascades: procedures>>=
   function cascade_disjunct (cascade1, cascade2) result (flag)
     logical :: flag
     type(cascade_t), intent(in) :: cascade1, cascade2
     flag = iand (cascade1%bincode, cascade2%bincode) == 0
   end function cascade_disjunct
 
 @ %def cascade_disjunct
 @ %def .disjunct.
 @ Compute a hash code for the resonance pattern of a cascade.  We count the
 number of times each particle appears as a resonance.
 
 We pack the PDG codes of the resonances in two arrays (s-channel and
 t-channel), sort them both, concatenate the results, transfer to
 [[i8]] integers, and compute the hash code from this byte stream.
 
 For t/u-channel, we remove the sign for antiparticles since this is not
 well-defined.
 <<Cascades: procedures>>=
   subroutine cascade_assign_resonance_hash (cascade)
     type(cascade_t), intent(inout) :: cascade
     integer(i8), dimension(1) :: mold
     cascade%res_hash = hash (transfer &
          ([sort (pack (cascade%tree_pdg, &
                  cascade%tree_resonant)), &
            sort (pack (abs (cascade%tree_pdg), &
                  cascade%tree_mapping == T_CHANNEL .or. &
                  cascade%tree_mapping == U_CHANNEL))], &
           mold))
   end subroutine cascade_assign_resonance_hash
 
 @ %def cascade_assign_resonance_hash
 @
 \subsection{Hash entries for cascades}
 We will set up a hash array which contains keys of and pointers to
 cascades.  We hold a list of cascade (pointers) within each bucket.
 This is not for collision resolution, but for keeping similar, but
 unequal cascades together.
 <<Cascades: types>>=
   type :: cascade_p
      type(cascade_t), pointer :: cascade => null ()
      type(cascade_p), pointer :: next => null ()
   end type cascade_p
 
 @ %def cascade_p
 @ Here is the bucket or hash entry type:
 <<Cascades: types>>=
   type :: hash_entry_t
      integer(i32) :: hashval = 0
      integer(i8), dimension(:), allocatable :: key
      type(cascade_p), pointer :: first => null ()
      type(cascade_p), pointer :: last => null ()
   end type hash_entry_t
 
 @ %def hash_entry_t
 <<Cascades: public>>=
   public :: hash_entry_init
 <<Cascades: procedures>>=
   subroutine hash_entry_init (entry, entry_in)
     type(hash_entry_t), intent(out) :: entry
     type(hash_entry_t), intent(in) :: entry_in
     type(cascade_p), pointer :: casc_iter, casc_copy
     entry%hashval = entry_in%hashval
     entry%key = entry_in%key
     casc_iter => entry_in%first
     do while (associated (casc_iter))
        allocate (casc_copy)
        casc_copy = casc_iter
        casc_copy%next => null ()
        if (associated (entry%first)) then
           entry%last%next => casc_copy
        else
           entry%first => casc_copy
        end if
        entry%last => casc_copy
        casc_iter => casc_iter%next
     end do
   end subroutine hash_entry_init
 
 @ %def hash_entry_init
 @ Finalize: just deallocate the list; the contents are just pointers.
 <<Cascades: procedures>>=
   subroutine hash_entry_final (hash_entry)
     type(hash_entry_t), intent(inout) :: hash_entry
     type(cascade_p), pointer :: current
     do while (associated (hash_entry%first))
        current => hash_entry%first
        hash_entry%first => current%next
        deallocate (current)
     end do
   end subroutine hash_entry_final
 
 @ %def hash_entry_final
 @ Output: concise format for debugging, just list cascade indices.
 <<Cascades: procedures>>=
   subroutine hash_entry_write (hash_entry, unit)
     type(hash_entry_t), intent(in) :: hash_entry
     integer, intent(in), optional :: unit
     type(cascade_p), pointer :: current
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)", advance="no")  "Entry:"
     do i = 1, size (hash_entry%key)
        write (u, "(1x,I0)", advance="no")  hash_entry%key(i)
     end do
     write (u, "(1x,A)", advance="no")  "->"
     current => hash_entry%first
     do while (associated (current))
        write (u, "(1x,I7)", advance="no") current%cascade%index
        current => current%next
     end do
     write (u, *)
   end subroutine hash_entry_write
 
 @ %def hash_entry_write
 @ This function adds a cascade pointer to the bucket.  If [[ok]] is
 present, check first if it is already there and return failure if yes.
 If [[cascade_ptr]] is also present, set it to the current cascade if
 successful.  If not, set it to the cascade that is already there.
 <<Cascades: procedures>>=
   subroutine hash_entry_add_cascade_ptr (hash_entry, cascade, ok, cascade_ptr)
     type(hash_entry_t), intent(inout) :: hash_entry
     type(cascade_t), intent(in), target :: cascade
     logical, intent(out), optional :: ok
     type(cascade_t), optional, pointer :: cascade_ptr
     type(cascade_p), pointer :: current
     if (present (ok)) then
        call hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr)
        if (.not. ok)  return
     end if
     allocate (current)
     current%cascade => cascade
     if (associated (hash_entry%last)) then
        hash_entry%last%next => current
     else
        hash_entry%first => current
     end if
     hash_entry%last => current
   end subroutine hash_entry_add_cascade_ptr
 
 @ %def hash_entry_add_cascade_ptr
 @ This function checks whether a cascade is already in the bucket.
 For incomplete cascades, we look for an exact match. It should suffice
 to verify the tree, the PDG codes, and the mapping modes.  This is the
 information that is written to the phase space file.
 
 For complete cascades, we ignore the PDG code at positions with
 mappings infrared, collinear, or t/u-channel.  Thus a cascade which is
 distinguished only by PDG code at such places, is flagged existent.
 If the convention is followed that light particles come before heavier
 ones (in the model definition), this ensures that the lightest
 particle is kept in the appropriate place, corresponding to the
 strongest peak.
 
 For external cascades (incoming/outgoing) we take the PDG code into
 account even though it is zeroed in the PDG-code tree.
 <<Cascades: procedures>>=
   subroutine hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr)
     type(hash_entry_t), intent(in), target :: hash_entry
     type(cascade_t), intent(in), target :: cascade
     logical, intent(out) :: ok
     type(cascade_t), optional, pointer :: cascade_ptr
     type(cascade_p), pointer :: current
     integer, dimension(:), allocatable :: tree_pdg
     ok = .true.
     allocate (tree_pdg (size (cascade%tree_pdg)))
     if (cascade%complete) then
        where (cascade%tree_mapping == INFRARED .or. &
             cascade%tree_mapping == COLLINEAR .or. &
             cascade%tree_mapping == T_CHANNEL .or. &
             cascade%tree_mapping == U_CHANNEL)
           tree_pdg = 0
        elsewhere
           tree_pdg = cascade%tree_pdg
        end where
     else
        tree_pdg = cascade%tree_pdg
     end if
     current => hash_entry%first
     do while (associated (current))
        if (current%cascade%depth == cascade%depth) then
           if (all (current%cascade%tree == cascade%tree)) then
              if (all (current%cascade%tree_mapping == cascade%tree_mapping)) &
                   then
                 if (all (current%cascade%tree_pdg .match. tree_pdg)) then
                    if (present (cascade_ptr))  cascade_ptr => current%cascade
                    ok = .false.;  return
                 end if
              end if
           end if
        end if
        current => current%next
     end do
     if (present (cascade_ptr))  cascade_ptr => cascade
   end subroutine hash_entry_check_cascade
 
 @ %def hash_entry_check_cascade
 @ For PDG codes, we specify that the undefined code matches any code.
 This is already defined for flavor objects, but here we need it for
 the codes themselves.
 <<Cascades: interfaces>>=
   interface operator(.match.)
      module procedure pdg_match
   end interface
 <<Cascades: procedures>>=
   elemental function pdg_match (pdg1, pdg2) result (flag)
     logical :: flag
     integer(TC), intent(in) :: pdg1, pdg2
     select case (pdg1)
     case (0)
        flag = .true.
     case default
        select case (pdg2)
        case (0)
           flag = .true.
        case default
           flag = pdg1 == pdg2
        end select
     end select
   end function pdg_match
 
 @ %def .match.
 @
 \subsection{The cascade set}
 The cascade set will later be transformed into the decay forest.  It
 is set up as a linked list.  In addition to the usual [[first]] and
 [[last]] pointers, there is a [[first_t]] pointer which points to the
 first t-channel cascade (after all s-channel cascades), and a
 [[first_k]] pointer which points to the first final cascade (with a
 keystone).
 
 As an auxiliary device, the object contains a hash array with
 associated parameters where an additional pointer is stored for each
 cascade.  The keys are made from the relevant cascade data.  This hash
 is used for fast detection (and thus avoidance) of double entries in
 the cascade list.
 <<Cascades: public>>=
   public :: cascade_set_t
 <<Cascades: types>>=
   type :: cascade_set_t
      private
      class(model_data_t), pointer :: model
      integer :: n_in, n_out, n_tot
      type(flavor_t), dimension(:,:), allocatable :: flv
      integer :: depth_out, depth_tot
      real(default) :: sqrts = 0
      real(default) :: m_threshold_s = 0
      real(default) :: m_threshold_t = 0
      integer :: off_shell = 0
      integer :: t_channel = 0
      logical :: keep_nonresonant
      integer :: n_groves = 0
      ! The cascade list
      type(cascade_t), pointer :: first => null ()
      type(cascade_t), pointer :: last => null ()
      type(cascade_t), pointer :: first_t => null ()
      type(cascade_t), pointer :: first_k => null ()
      ! The hashtable
      integer :: n_entries = 0
      real :: fill_ratio = 0
      integer :: n_entries_max = 0
      integer(i32) :: mask = 0
      logical :: fatal_beam_decay = .true.
      type(hash_entry_t), dimension(:), allocatable :: entry
   end type cascade_set_t
 
 @ %def cascade_set_t
 @
 <<Cascades: public>>=
   interface cascade_set_init
      module procedure cascade_set_init_base
      module procedure cascade_set_init_from_cascade
   end interface
 @ %def cascade_set_init
 @ This might be broken. Test before using.
 <<Cascades: procedures>>=
   subroutine cascade_set_init_from_cascade (cascade_set, cascade_set_in)
     type(cascade_set_t), intent(out) :: cascade_set
     type(cascade_set_t), intent(in), target :: cascade_set_in
     type(cascade_t), pointer :: casc_iter, casc_copy
     cascade_set%model => cascade_set_in%model
     cascade_set%n_in = cascade_set_in%n_in
     cascade_set%n_out = cascade_set_in%n_out
     cascade_set%n_tot = cascade_set_in%n_tot
     cascade_set%flv = cascade_set_in%flv
     cascade_set%depth_out = cascade_set_in%depth_out
     cascade_set%depth_tot = cascade_set_in%depth_tot
     cascade_set%sqrts = cascade_set_in%sqrts
     cascade_set%m_threshold_s = cascade_set_in%m_threshold_s
     cascade_set%m_threshold_t = cascade_set_in%m_threshold_t
     cascade_set%off_shell = cascade_set_in%off_shell
     cascade_set%t_channel = cascade_set_in%t_channel
     cascade_set%keep_nonresonant = cascade_set_in%keep_nonresonant
     cascade_set%n_groves = cascade_set_in%n_groves
 
     casc_iter => cascade_set_in%first
     do while (associated (casc_iter))
        allocate (casc_copy)
        casc_copy = casc_iter
        casc_copy%next => null ()
        if (associated (cascade_set%first)) then
           cascade_set%last%next => casc_copy
        else
           cascade_set%first => casc_copy
        end if
        cascade_set%last => casc_copy
        casc_iter => casc_iter%next
     end do
 
     cascade_set%n_entries = cascade_set_in%n_entries
     cascade_set%fill_ratio = cascade_set_in%fill_ratio
     cascade_set%n_entries_max = cascade_set_in%n_entries_max
     cascade_set%mask = cascade_set_in%mask
     cascade_set%fatal_beam_decay = cascade_set_in%fatal_beam_decay
     allocate (cascade_set%entry (0:cascade_set%mask))
     cascade_set%entry = cascade_set_in%entry
   end subroutine cascade_set_init_from_cascade
 
 @ %def cascade_set_init_from_cascade
 @ Return true if there are cascades which are active and complete, so
 the phase space file would be nonempty.
 <<Cascades: public>>=
   public :: cascade_set_is_valid
 <<Cascades: procedures>>=
   function cascade_set_is_valid (cascade_set) result (flag)
     logical :: flag
     type(cascade_set_t), intent(in) :: cascade_set
     type(cascade_t), pointer :: cascade
     flag = .false.
     cascade => cascade_set%first_k
     do while (associated (cascade))
        if (cascade%active .and. cascade%complete) then
           flag = .true.
           return
        end if
        cascade => cascade%next
     end do
   end function cascade_set_is_valid
 
 @ %def cascade_set_is_valid
 @ The initializer sets up the hash table with some initial size
 guessed by looking at the number of external particles.  We choose 256
 for 3 external particles and a factor of 4 for each additional
 particle, limited at $2^{30}$=1G.
 <<Cascades: parameters>>=
   real, parameter, public :: CASCADE_SET_FILL_RATIO = 0.1
 <<Cascades: procedures>>=
   subroutine cascade_set_init_base (cascade_set, model, n_in, n_out, phs_par, &
         fatal_beam_decay, flv)
     type(cascade_set_t), intent(out) :: cascade_set
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in, n_out
     type(phs_parameters_t), intent(in) :: phs_par
     logical, intent(in) :: fatal_beam_decay
     type(flavor_t), dimension(:,:), intent(in), optional :: flv
     integer :: size_guess
     integer :: i, j
     cascade_set%model => model
     cascade_set%n_in = n_in
     cascade_set%n_out = n_out
     cascade_set%n_tot = n_in + n_out
     if (present (flv)) then
        allocate (cascade_set%flv (size (flv, 1), size (flv, 2)))
        do i = 1, size (flv, 2)
           do j = 1, size (flv, 1)
              call cascade_set%flv(j,i)%init (flv(j,i)%get_pdg (), model)
           end do
        end do
     end if
     select case (n_in)
     case (1);  cascade_set%depth_out = 2 * n_out - 3
     case (2);  cascade_set%depth_out = 2 * n_out - 1
     end select
     cascade_set%depth_tot = 2 * cascade_set%n_tot - 3
     cascade_set%sqrts = phs_par%sqrts
     cascade_set%m_threshold_s = phs_par%m_threshold_s
     cascade_set%m_threshold_t = phs_par%m_threshold_t
     cascade_set%off_shell = phs_par%off_shell
     cascade_set%t_channel = phs_par%t_channel
     cascade_set%keep_nonresonant = phs_par%keep_nonresonant
     cascade_set%fill_ratio = CASCADE_SET_FILL_RATIO
     size_guess = ishft (256, min (2 * (cascade_set%n_tot - 3), 22))
     cascade_set%n_entries_max = size_guess * cascade_set%fill_ratio
     cascade_set%mask = size_guess - 1
     allocate (cascade_set%entry (0:cascade_set%mask))
     cascade_set%fatal_beam_decay = fatal_beam_decay
   end subroutine cascade_set_init_base
 
 @ %def cascade_set_init_base
 @ The finalizer has to delete both the hash and the list.
 <<Cascades: public>>=
   public :: cascade_set_final
 <<Cascades: procedures>>=
   subroutine cascade_set_final (cascade_set)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), pointer :: current
     integer :: i
     if (allocated (cascade_set%entry)) then
        do i = 0, cascade_set%mask
           call hash_entry_final (cascade_set%entry(i))
        end do
        deallocate (cascade_set%entry)
     end if
     do while (associated (cascade_set%first))
        current => cascade_set%first
        cascade_set%first => cascade_set%first%next
        deallocate (current)
     end do
   end subroutine cascade_set_final
 
 @ %def cascade_set_final
 @ Write the process in ASCII format, in columns that are headed by the
 corresponding bincode.
 <<Cascades: public>>=
   public :: cascade_set_write_process_bincode_format
 <<Cascades: procedures>>=
   subroutine cascade_set_write_process_bincode_format (cascade_set, unit)
     type(cascade_set_t), intent(in), target :: cascade_set
     integer, intent(in), optional :: unit
     integer, dimension(:), allocatable :: bincode, field_width
     integer :: n_in, n_out, n_tot, n_flv
     integer :: u, f, i, bc
     character(20) :: str
     type(string_t) :: fmt_head
     type(string_t), dimension(:), allocatable :: fmt_proc
     u = given_output_unit (unit);  if (u < 0)  return
     if (.not. allocated (cascade_set%flv)) return
     write (u, "('!',1x,A)")  "List of subprocesses with particle bincodes:"
     n_in  = cascade_set%n_in
     n_out = cascade_set%n_out
     n_tot = cascade_set%n_tot
     n_flv = size (cascade_set%flv, 2)
     allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot))
     bc = 1
     do i = 1, n_out
        bincode(n_in + i) = bc
        bc = 2 * bc
     end do
     do i = n_in, 1, -1
        bincode(i) = bc
        bc = 2 * bc
     end do
     do i = 1, n_tot
        write (str, "(I0)")  bincode(i)
        field_width(i) = len_trim (str)
        do f = 1, n_flv
           field_width(i) = max (field_width(i), &
                len (cascade_set%flv(i,f)%get_name ()))
        end do
     end do
     fmt_head = "('!'"
     do i = 1, n_tot
        fmt_head = fmt_head // ",1x,"
        fmt_proc(i) = "(1x,"
        write (str, "(I0)")  field_width(i)
        fmt_head = fmt_head // "I" // trim(str)
        fmt_proc(i) = fmt_proc(i) // "A" // trim(str)
        if (i == n_in) then
           fmt_head = fmt_head // ",1x,'  '"
        end if
     end do
     do i = 1, n_tot
        fmt_proc(i) = fmt_proc(i) // ")"
     end do
     fmt_head = fmt_head // ")"
     write (u, char (fmt_head))  bincode
     do f = 1, n_flv
        write (u, "('!')", advance="no")
        do i = 1, n_tot
           write (u, char (fmt_proc(i)), advance="no") &
                char (cascade_set%flv(i,f)%get_name ())
           if (i == n_in)  write (u, "(1x,'=>')", advance="no")
        end do
        write (u, *)
     end do
     write (u, char (fmt_head))  bincode
   end subroutine cascade_set_write_process_bincode_format
 
 @ %def cascade_set_write_process_tex_format
 @ Write the process as a \LaTeX\ expression.
 <<Cascades: procedures>>=
   subroutine cascade_set_write_process_tex_format (cascade_set, unit)
     type(cascade_set_t), intent(in), target :: cascade_set
     integer, intent(in), optional :: unit
     integer :: u, f, i
     u = given_output_unit (unit);  if (u < 0)  return
     if (.not. allocated (cascade_set%flv)) return
     write (u, "(A)")  "\begin{align*}"
     do f = 1, size (cascade_set%flv, 2)
        do i = 1, cascade_set%n_in
           if (i > 1)  write (u, "(A)", advance="no") "\quad "
           write (u, "(A)", advance="no") &
                char (cascade_set%flv(i,f)%get_tex_name ())
        end do
        write (u, "(A)", advance="no")  "\quad &\to\quad "
        do i = cascade_set%n_in + 1, cascade_set%n_tot
           if (i > cascade_set%n_in + 1)  write (u, "(A)", advance="no") "\quad "
           write (u, "(A)", advance="no") &
                char (cascade_set%flv(i,f)%get_tex_name ())
        end do
        if (f < size (cascade_set%flv, 2)) then
           write (u, "(A)")  "\\"
        else
           write (u, "(A)")  ""
        end if
     end do
     write (u, "(A)")  "\end{align*}"
   end subroutine cascade_set_write_process_tex_format
 
 @ %def cascade_set_write_process_tex_format
 @ Three output routines: phase-space file, graph source code, and
 screen output.
 
 This version generates the phase space file.  It deals only with
 complete cascades.
 <<Cascades: public>>=
   public :: cascade_set_write_file_format
 <<Cascades: procedures>>=
   subroutine cascade_set_write_file_format (cascade_set, unit)
     type(cascade_set_t), intent(in), target :: cascade_set
     integer, intent(in), optional :: unit
     type(cascade_t), pointer :: cascade
     integer :: u, grove, count
     logical :: first_in_grove
     u = given_output_unit (unit);  if (u < 0)  return
     count = 0
     do grove = 1, cascade_set%n_groves
        first_in_grove = .true.
        cascade => cascade_set%first_k
        do while (associated (cascade))
           if (cascade%active .and. cascade%complete) then
              if (cascade%grove == grove) then
                 if (first_in_grove) then
                    first_in_grove = .false.
                    write (u, "(A)")
                    write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') &
                       'Multiplicity =', cascade%multiplicity, ","
                    select case (cascade%n_resonances)
                    case (0)
                       write (u, '(1x,A)', advance='no') 'no resonances, '
                    case (1)
                       write (u, '(1x,A)', advance='no') '1 resonance,  '
                    case default
                       write (u, '(1x,I0,1x,A)', advance='no') &
                            cascade%n_resonances, 'resonances, '
                    end select
                    write (u, '(1x,I0,1x,A)', advance='no') &
                         cascade%n_log_enhanced, 'logs, '
                    write (u, '(1x,I0,1x,A)', advance='no') &
                         cascade%n_off_shell, 'off-shell, '
                    select case (cascade%n_t_channel)
                    case (0);  write (u, '(1x,A)') 's-channel graph'
                    case (1);  write (u, '(1x,A)') '1 t-channel line'
                    case default
                       write(u,'(1x,I0,1x,A)') &
                            cascade%n_t_channel, 't-channel lines'
                    end select
                    write (u, '(1x,A,I0)') 'grove #', grove
                 end if
                 count = count + 1
                 write (u, "(1x,'!',1x,A,I0)")  "Channel #", count
                 call cascade_write_file_format (cascade, cascade_set%model, u)
              end if
           end if
           cascade => cascade%next
        end do
     end do
   end subroutine cascade_set_write_file_format
 
 @ %def cascade_set_write_file_format
 @ This is the graph output format, the driver-file
 <<Cascades: public>>=
   public :: cascade_set_write_graph_format
 <<Cascades: procedures>>=
   subroutine cascade_set_write_graph_format &
       (cascade_set, filename, process_id, unit)
     type(cascade_set_t), intent(in), target :: cascade_set
     type(string_t), intent(in) :: filename, process_id
     integer, intent(in), optional :: unit
     type(cascade_t), pointer :: cascade
     integer :: u, grove, count, pgcount
     logical :: first_in_grove
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, '(A)') "\documentclass[10pt]{article}"
     write (u, '(A)') "\usepackage{amsmath}"
     write (u, '(A)') "\usepackage{feynmp}"
     write (u, '(A)') "\usepackage{url}"
     write (u, '(A)') "\usepackage{color}"
     write (u, *)
     write (u, '(A)') "\textwidth 18.5cm"
     write (u, '(A)') "\evensidemargin -1.5cm"
     write (u, '(A)') "\oddsidemargin -1.5cm"
     write (u, *)
     write (u, '(A)') "\newcommand{\blue}{\color{blue}}"
     write (u, '(A)') "\newcommand{\green}{\color{green}}"
     write (u, '(A)') "\newcommand{\red}{\color{red}}"
     write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}"
     write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}"
     write (u, '(A)') "\newcommand{\sm}{\footnotesize}"
     write (u, '(A)') "\setlength{\parindent}{0pt}"
     write (u, '(A)') "\setlength{\parsep}{20pt}"
     write (u, *)
     write (u, '(A)') "\begin{document}"
     write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}"
     write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}"
     write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}"
     write (u, '(A)') "\begin{fmfshrink}{0.5}"
     write (u, '(A)') "\begin{flushleft}"
     write (u, *)
     write (u, '(A)') "\noindent" // &
          & "\textbf{\large\texttt{WHIZARD} phase space channels}" // &
          & "\hfill\today"
     write (u, *)
     write (u, '(A)') "\vspace{10pt}"
     write (u, '(A)') "\noindent" // &
          & "\textbf{Process:} \url{" // char (process_id) // "}"
     call cascade_set_write_process_tex_format (cascade_set, u)
     write (u, *)
     write (u, '(A)') "\noindent" // &
          & "\textbf{Note:} These are pseudo Feynman graphs that "
     write (u, '(A)') "visualize phase-space parameterizations " // &
          & "(``integration channels'').  "
     write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // &
          & "matrix element."
     write (u, *)
     write (u, '(A)') "\textbf{Color code:} " // &
          & "{\blue resonance,} " // &
          & "{\cyan t-channel,} " // &
          & "{\green radiation,} "
     write (u, '(A)') "{\red infrared,} " // &
          & "{\magenta collinear,} " // &
          & "external/off-shell"
     write (u, *)
     write (u, '(A)') "\noindent" // &
          & "\textbf{Black square:} Keystone, indicates ordering of " // &
          & "phase space parameters."
     write (u, *)
     write (u, '(A)') "\vspace{-20pt}"
     count = 0
     pgcount = 0
     do grove = 1, cascade_set%n_groves
        first_in_grove = .true.
        cascade => cascade_set%first
        do while (associated (cascade))
           if (cascade%active .and. cascade%complete) then
              if (cascade%grove == grove) then
                 if (first_in_grove) then
                    first_in_grove = .false.
                    write (u, *)
                    write (u, '(A)') "\vspace{20pt}"
                    write (u, '(A)') "\begin{tabular}{l}"
                    write (u, '(A,I5,A)') &
                         & "\fbox{\bf Grove \boldmath$", grove, "$} \\[10pt]"
                    write (u, '(A,I1,A)') "Multiplicity: ", &
                         cascade%multiplicity, "\\"
                    write (u, '(A,I1,A)') "Resonances:   ", &
                         cascade%n_resonances, "\\"
                    write (u, '(A,I1,A)') "Log-enhanced: ", &
                         cascade%n_log_enhanced, "\\"
                    write (u, '(A,I1,A)') "Off-shell:    ", &
                         cascade%n_off_shell, "\\"
                    write (u, '(A,I1,A)') "t-channel:    ", &
                         cascade%n_t_channel, ""
                    write (u, '(A)') "\end{tabular}"
                 end if
                 count = count + 1
                 call cascade_write_graph_format (cascade, count, unit)
                 if (pgcount >= 250) then
                    write (u, '(A)') "\clearpage"
                    pgcount = 0
                 end if
              end if
           end if
           cascade => cascade%next
        end do
     end do
     write (u, '(A)') "\end{flushleft}"
     write (u, '(A)') "\end{fmfshrink}"
     write (u, '(A)') "\end{fmffile}"
     write (u, '(A)') "\end{document}"
  end subroutine cascade_set_write_graph_format
 
 @ %def cascade_set_write_graph_format
 @ This is for screen output and debugging:
 <<Cascades: public>>=
   public :: cascade_set_write
 <<Cascades: procedures>>=
   subroutine cascade_set_write (cascade_set, unit, active_only, complete_only)
     type(cascade_set_t), intent(in), target :: cascade_set
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: active_only, complete_only
     logical :: active, complete
     type(cascade_t), pointer :: cascade
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     active = .true.;  if (present (active_only))  active = active_only
     complete = .false.;  if (present (complete_only))  complete = complete_only
     write (u, "(A)") "Cascade set:"
     write (u, "(3x,A)", advance="no")  "Model:"
     if (associated (cascade_set%model)) then
        write (u, "(1x,A)") char (cascade_set%model%get_name ())
     else
        write (u, "(1x,A)") "[none]"
     end if
     write (u, "(3x,A)", advance="no")  "n_in/out/tot  ="
     write (u, "(3(1x,I7))")  &
          cascade_set%n_in, cascade_set%n_out, cascade_set%n_tot
     write (u, "(3x,A)", advance="no")  "depth_out/tot ="
     write (u, "(2(1x,I7))")  cascade_set%depth_out, cascade_set%depth_tot
     write (u, "(3x,A)", advance="no")  "mass thr(s/t) ="
     write (u, "(2(1x," // FMT_19 // "))")  &
          cascade_set%m_threshold_s, cascade_set%m_threshold_t
     write (u, "(3x,A)", advance="no")  "off shell     ="
     write (u, "(1x,I7)")  cascade_set%off_shell
     write (u, "(3x,A)", advance="no")  "keep_nonreson ="
     write (u, "(1x,L1)")  cascade_set%keep_nonresonant
     write (u, "(3x,A)", advance="no")  "n_groves      ="
     write (u, "(1x,I7)")  cascade_set%n_groves
     write (u, "(A)")
     write (u, "(A)") "Cascade list:"
     if (associated (cascade_set%first)) then
        cascade => cascade_set%first
        do while (associated (cascade))
           if (active .and. .not. cascade%active)  cycle
           if (complete .and. .not. cascade%complete)  cycle
           call cascade_write (cascade, unit)
           cascade => cascade%next
        end do
     else
        write (u, "(A)") "[empty]"
     end if
     write (u, "(A)") "Hash array"
     write (u, "(3x,A)", advance="no")  "n_entries     ="
     write (u, "(1x,I7)")  cascade_set%n_entries
     write (u, "(3x,A)", advance="no")  "fill_ratio    ="
     write (u, "(1x," // FMT_12 // ")")  cascade_set%fill_ratio
     write (u, "(3x,A)", advance="no")  "n_entries_max ="
     write (u, "(1x,I7)")  cascade_set%n_entries_max
     write (u, "(3x,A)", advance="no")  "mask          ="
     write (u, "(1x,I0)")  cascade_set%mask
     do i = 0, ubound (cascade_set%entry, 1)
        if (allocated (cascade_set%entry(i)%key)) then
           write (u, "(1x,I7)") i
           call hash_entry_write (cascade_set%entry(i), u)
        end if
     end do
   end subroutine cascade_set_write
 
 @ %def cascade_set_write
 @
 \subsection{Adding cascades}
 Add a deep copy of a cascade to the set.  The copy has all content of the
 original, but the pointers are nullified.  We do not care whether insertion
 was successful or not.  The pointer argument, if present, is assigned to the
 input cascade, or to the hash entry if it is already present.
 
 The procedure is recursive: any daughter or mother entries are also
 deep-copied and added to the cascade set before the current copy is added.
 <<Cascades: procedures>>=
   recursive subroutine cascade_set_add_copy &
        (cascade_set, cascade_in, cascade_ptr)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in) :: cascade_in
     type(cascade_t), optional, pointer :: cascade_ptr
     type(cascade_t), pointer :: cascade
     logical :: ok
     allocate (cascade)
     cascade = cascade_in
     if (associated (cascade_in%daughter1))  call cascade_set_add_copy &
          (cascade_set, cascade_in%daughter1, cascade%daughter1)
     if (associated (cascade_in%daughter2))  call cascade_set_add_copy &
          (cascade_set, cascade_in%daughter2, cascade%daughter2)
     if (associated (cascade_in%mother))  call cascade_set_add_copy &
          (cascade_set, cascade_in%mother, cascade%mother)
     cascade%next => null ()
     call cascade_set_add (cascade_set, cascade, ok, cascade_ptr)
     if (.not. ok)  deallocate (cascade)
   end subroutine cascade_set_add_copy
 
 @ %def cascade_set_add_copy
 @ Add a cascade to the set.  This does not deep-copy.  We first try to insert
 it in the hash array.  If successful, add it to the list.  Failure indicates
 that it is already present, and we drop it.
 
 The hash key is built solely from the tree array, so neither particle
 codes nor resonances count, just topology.
 
 Technically, hash and list receive only pointers, so the cascade can
 be considered as being in either of both.  We treat it as part of the
 list.
 <<Cascades: procedures>>=
   subroutine cascade_set_add (cascade_set, cascade, ok, cascade_ptr)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in), target :: cascade
     logical, intent(out) :: ok
     type(cascade_t), optional, pointer :: cascade_ptr
     integer(i8), dimension(1) :: mold
     call cascade_set_hash_insert &
          (cascade_set, transfer (cascade%tree, mold), cascade, ok, cascade_ptr)
     if (ok)  call cascade_set_list_add (cascade_set, cascade)
   end subroutine cascade_set_add
 
 @ %def cascade_set_add
 @ Add a new cascade to the list:
 <<Cascades: procedures>>=
   subroutine cascade_set_list_add (cascade_set, cascade)
     type(cascade_set_t), intent(inout) :: cascade_set
     type(cascade_t), intent(in), target :: cascade
     if (associated (cascade_set%last)) then
        cascade_set%last%next => cascade
     else
        cascade_set%first => cascade
     end if
     cascade_set%last => cascade
   end subroutine cascade_set_list_add
 
 @ %def cascade_set_list_add
 @ Add a cascade entry to the hash array:
 <<Cascades: procedures>>=
   subroutine cascade_set_hash_insert &
        (cascade_set, key, cascade, ok, cascade_ptr)
     type(cascade_set_t), intent(inout), target :: cascade_set
     integer(i8), dimension(:), intent(in) :: key
     type(cascade_t), intent(in), target :: cascade
     logical, intent(out) :: ok
     type(cascade_t), optional, pointer :: cascade_ptr
     integer(i32) :: h
     if (cascade_set%n_entries >= cascade_set%n_entries_max) &
          call cascade_set_hash_expand (cascade_set)
     h = hash (key)
     call cascade_set_hash_insert_rec &
          (cascade_set, h, h, key, cascade, ok, cascade_ptr)
   end subroutine cascade_set_hash_insert
 
 @ %def cascade_set_hash_insert
 @ Double the hashtable size when necesssary:
 <<Cascades: procedures>>=
   subroutine cascade_set_hash_expand (cascade_set)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(hash_entry_t), dimension(:), allocatable, target :: table_tmp
     type(cascade_p), pointer :: current
     integer :: i, s
     allocate (table_tmp (0:cascade_set%mask))
     table_tmp = cascade_set%entry
     deallocate (cascade_set%entry)
     s = 2 * size (table_tmp)
     cascade_set%n_entries = 0
     cascade_set%n_entries_max = s * cascade_set%fill_ratio
     cascade_set%mask = s - 1
     allocate (cascade_set%entry (0:cascade_set%mask))
     do i = 0, ubound (table_tmp, 1)
        current => table_tmp(i)%first
        do while (associated (current))
           call cascade_set_hash_insert_rec &
                (cascade_set, table_tmp(i)%hashval, table_tmp(i)%hashval, &
                 table_tmp(i)%key, current%cascade)
           current => current%next
        end do
     end do
   end subroutine cascade_set_hash_expand
 
 @ %def cascade_set_hash_expand
 @ Insert the cascade at the bucket determined by the hash value.  If
 the bucket is filled, check first for a collision (unequal keys).  In
 that case, choose the following bucket and repeat.  Otherwise, add the
 cascade to the bucket.
 
 If the bucket is empty, record the hash value, allocate and store the
 key, and then add the cascade to the bucket.
 
 If [[ok]] is present, before insertion we check whether the cascade is
 already stored, and return failure if yes.
 <<Cascades: procedures>>=
   recursive subroutine cascade_set_hash_insert_rec &
        (cascade_set, h, hashval, key, cascade, ok, cascade_ptr)
     type(cascade_set_t), intent(inout) :: cascade_set
     integer(i32), intent(in) :: h, hashval
     integer(i8), dimension(:), intent(in) :: key
     type(cascade_t), intent(in), target :: cascade
     logical, intent(out), optional :: ok
     type(cascade_t), optional, pointer :: cascade_ptr
     integer(i32) :: i
     i = iand (h, cascade_set%mask)
     if (allocated (cascade_set%entry(i)%key)) then
        if (size (cascade_set%entry(i)%key) /= size (key)) then
           call cascade_set_hash_insert_rec &
                (cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr)
        else if (any (cascade_set%entry(i)%key /= key)) then
           call cascade_set_hash_insert_rec &
                (cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr)
        else
           call hash_entry_add_cascade_ptr &
                (cascade_set%entry(i), cascade, ok, cascade_ptr)
        end if
     else
        cascade_set%entry(i)%hashval = hashval
        allocate (cascade_set%entry(i)%key (size (key)))
        cascade_set%entry(i)%key = key
        call hash_entry_add_cascade_ptr &
             (cascade_set%entry(i), cascade, ok, cascade_ptr)
        cascade_set%n_entries = cascade_set%n_entries + 1
     end if
   end subroutine cascade_set_hash_insert_rec
 
 @ %def cascade_set_hash_insert_rec
 @
 \subsection{External particles}
 We want to initialize the cascade set with the outgoing particles.  In
 case of multiple processes, initial cascades are prepared for all of
 them.  The hash array check ensures that no particle appears more than
 once at the same place.
 <<Cascades: interfaces>>=
   interface cascade_set_add_outgoing
      module procedure cascade_set_add_outgoing1
      module procedure cascade_set_add_outgoing2
   end interface
 
 <<Cascades: procedures>>=
   subroutine cascade_set_add_outgoing2 (cascade_set, flv)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(flavor_t), dimension(:,:), intent(in) :: flv
     integer :: pos, prc, n_out, n_prc
     type(cascade_t), pointer :: cascade
     logical :: ok
     n_out = size (flv, dim=1)
     n_prc = size (flv, dim=2)
     do prc = 1, n_prc
        do pos = 1, n_out
           allocate (cascade)
           call cascade_init_outgoing &
                (cascade, flv(pos,prc), pos, cascade_set%m_threshold_s)
           call cascade_set_add (cascade_set, cascade, ok)
           if (.not. ok) then
              deallocate (cascade)
           end if
        end do
     end do
   end subroutine cascade_set_add_outgoing2
 
   subroutine cascade_set_add_outgoing1 (cascade_set, flv)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(flavor_t), dimension(:), intent(in) :: flv
     integer :: pos, n_out
     type(cascade_t), pointer :: cascade
     logical :: ok
     n_out = size (flv, dim=1)
     do pos = 1, n_out
        allocate (cascade)
        call cascade_init_outgoing &
             (cascade, flv(pos), pos, cascade_set%m_threshold_s)
        call cascade_set_add (cascade_set, cascade, ok)
        if (.not. ok) then
           deallocate (cascade)
        end if
     end do
   end subroutine cascade_set_add_outgoing1
 
 @ %def cascade_set_add_outgoing
 @ The incoming particles are added one at a time.  Nevertheless, we
 may have several processes which are looped over.  At the first
 opportunity, we set the pointer [[first_t]] in the cascade set which
 should point to the first t-channel cascade.
 
 Return the indices of the first and last cascade generated.
 <<Cascades: interfaces>>=
   interface cascade_set_add_incoming
      module procedure cascade_set_add_incoming0
      module procedure cascade_set_add_incoming1
   end interface
 
 <<Cascades: procedures>>=
   subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv)
     type(cascade_set_t), intent(inout), target :: cascade_set
     integer, intent(out) :: n1, n2
     integer, intent(in) :: pos
     type(flavor_t), dimension(:), intent(in) :: flv
     integer :: prc, n_prc
     type(cascade_t), pointer :: cascade
     logical :: ok
     n1 = 0
     n2 = 0
     n_prc = size (flv)
     do prc = 1, n_prc
        allocate (cascade)
        call cascade_init_incoming &
             (cascade, flv(prc), pos, cascade_set%m_threshold_t)
        call cascade_set_add (cascade_set, cascade, ok)
        if (ok) then
           if (n1 == 0)  n1 = cascade%index
           n2 = cascade%index
           if (.not. associated (cascade_set%first_t)) then
              cascade_set%first_t => cascade
           end if
        else
           deallocate (cascade)
        end if
     end do
   end subroutine cascade_set_add_incoming1
 
   subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv)
     type(cascade_set_t), intent(inout), target :: cascade_set
     integer, intent(out) :: n1, n2
     integer, intent(in) :: pos
     type(flavor_t), intent(in) :: flv
     type(cascade_t), pointer :: cascade
     logical :: ok
     n1 = 0
     n2 = 0
     allocate (cascade)
     call cascade_init_incoming &
          (cascade, flv, pos, cascade_set%m_threshold_t)
     call cascade_set_add (cascade_set, cascade, ok)
     if (ok) then
        if (n1 == 0)  n1 = cascade%index
        n2 = cascade%index
        if (.not. associated (cascade_set%first_t)) then
           cascade_set%first_t => cascade
        end if
     else
        deallocate (cascade)
     end if
   end subroutine cascade_set_add_incoming0
 
 @ %def cascade_set_add_incoming
 @
 \subsection{Cascade combination I: flavor assignment}
 We have two disjunct cascades, now use the vertex table to determine
 the possible flavors of the combination cascade.  For each
 possibility, try to generate a new cascade.  The total cascade depth
 has to be one less than the limit, because this is reached by setting
 the keystone.
 <<Cascades: procedures>>=
   subroutine cascade_match_pair (cascade_set, cascade1, cascade2, s_channel)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in), target :: cascade1, cascade2
     logical, intent(in) :: s_channel
     integer, dimension(:), allocatable :: pdg3
     integer :: i, depth_max
     type(flavor_t) :: flv
     if (s_channel) then
        depth_max = cascade_set%depth_out
     else
        depth_max = cascade_set%depth_tot
     end if
     if (cascade1%depth + cascade2%depth < depth_max) then
        call cascade_set%model%match_vertex ( &
             cascade1%flv%get_pdg (), &
             cascade2%flv%get_pdg (), &
             pdg3)
        do i = 1, size (pdg3)
           call flv%init (pdg3(i), cascade_set%model)
           if (s_channel) then
              call cascade_combine_s (cascade_set, cascade1, cascade2, flv)
           else
              call cascade_combine_t (cascade_set, cascade1, cascade2, flv)
           end if
        end do
        deallocate (pdg3)
     end if
   end subroutine cascade_match_pair
 
 @ %def cascade_match_pair
 @ The triplet version takes a third cascade, and we check whether this
 triplet has a matching vertex in the database.  If yes, we make a
 keystone cascade.
 <<Cascades: procedures>>=
   subroutine cascade_match_triplet &
        (cascade_set, cascade1, cascade2, cascade3, s_channel)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
     logical, intent(in) :: s_channel
     integer :: depth_max
     depth_max = cascade_set%depth_tot
     if (cascade1%depth + cascade2%depth + cascade3%depth == depth_max) then
        if (cascade_set%model%check_vertex ( &
             cascade1%flv%get_pdg (), &
             cascade2%flv%get_pdg (), &
             cascade3%flv%get_pdg ())) then
           call cascade_combine_keystone &
                (cascade_set, cascade1, cascade2, cascade3, s_channel)
        end if
     end if
   end subroutine cascade_match_triplet
 
 @ %def cascade_match_triplet
 @
 \subsection{Cascade combination II: kinematics setup and check}
 Having three matching flavors, we start constructing the combination
 cascade.  We look at the mass hierarchies and determine whether the
 cascade is to be kept.  In passing we set mapping modes, resonance
 properties and such.
 
 If successful, the cascade is finalized.  For a resonant cascade, we
 prepare in addition a copy without the resonance.
 <<Cascades: procedures>>=
   subroutine cascade_combine_s (cascade_set, cascade1, cascade2, flv)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in), target :: cascade1, cascade2
     type(flavor_t), intent(in) :: flv
     type(cascade_t), pointer :: cascade3, cascade4
     logical :: keep
     keep = .false.
     allocate (cascade3)
     call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1)
     cascade3%bincode = ior (cascade1%bincode, cascade2%bincode)
     cascade3%flv = flv%anti ()
     cascade3%pdg = cascade3%flv%get_pdg ()
     cascade3%is_vector = flv%get_spin_type () == VECTOR
     cascade3%m_min = cascade1%m_min + cascade2%m_min
     cascade3%m_rea = flv%get_mass ()
     if (cascade3%m_rea > cascade_set%m_threshold_s) then
        cascade3%m_eff = cascade3%m_rea
     end if
     ! Potentially resonant cases [sqrts = m_rea for on-shell decay]
     if (cascade3%m_rea > cascade3%m_min &
          .and. cascade3%m_rea <= cascade_set%sqrts) then
        if (flv%get_width () /= 0) then
           if (cascade1%on_shell .or. cascade2%on_shell) then
              keep = .true.
              cascade3%mapping = S_CHANNEL
              cascade3%resonant = .true.
           end if
        else
           call warn_decay (flv)
        end if
     ! Collinear and IR singular cases
     else if (cascade3%m_rea < cascade_set%sqrts) then
        ! Massless splitting
        if (cascade1%m_eff == 0 .and. cascade2%m_eff == 0 &
             .and. cascade3%depth <= 3) then
           keep = .true.
           cascade3%log_enhanced = .true.
           if (cascade3%is_vector) then
              if (cascade1%is_vector .and. cascade2%is_vector) then
                 cascade3%mapping = COLLINEAR   ! three-vector-vertex
              else
                 cascade3%mapping = INFRARED    ! vector splitting into matter
              end if
           else
              if (cascade1%is_vector .or. cascade2%is_vector) then
                 cascade3%mapping = COLLINEAR   ! vector radiation off matter
              else
                 cascade3%mapping = INFRARED    ! scalar radiation/splitting
              end if
           end if
        ! IR radiation off massive particle
        else if (cascade3%m_eff > 0 .and. cascade1%m_eff > 0 &
             .and. cascade2%m_eff == 0 &
             .and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) &
             .and. abs (cascade3%m_eff - cascade1%m_eff) &
                        < cascade_set%m_threshold_s) &
             then
           keep = .true.
           cascade3%log_enhanced = .true.
           cascade3%mapping = RADIATION
        else if (cascade3%m_eff > 0 .and. cascade2%m_eff > 0 &
             .and. cascade1%m_eff == 0 &
             .and. (cascade2%on_shell .or. cascade2%mapping == RADIATION) &
             .and. abs (cascade3%m_eff - cascade2%m_eff) &
                   < cascade_set%m_threshold_s) &
             then
           keep = .true.
           cascade3%log_enhanced = .true.
           cascade3%mapping = RADIATION
        end if
     end if
     ! Non-singular cases, including failed resonances
     if (.not. keep) then
        ! Two on-shell particles from a virtual mother
        if (cascade1%on_shell .or. cascade2%on_shell) then
           keep = .true.
           cascade3%m_eff = max (cascade3%m_min, &
                                 cascade1%m_eff + cascade2%m_eff)
           if (cascade3%m_eff < cascade_set%m_threshold_s) then
              cascade3%m_eff = 0
           end if
        end if
     end if
     ! Complete and register the cascade (two in case of resonance)
     if (keep) then
        cascade3%on_shell = cascade3%resonant .or. cascade3%log_enhanced
        if (cascade3%resonant) then
           cascade3%pdg = cascade3%flv%get_pdg ()
           if (cascade_set%keep_nonresonant) then
              allocate (cascade4)
              cascade4 = cascade3
              cascade4%index = cascade_index ()
              cascade4%pdg = UNDEFINED
              cascade4%mapping = NO_MAPPING
              cascade4%resonant = .false.
              cascade4%on_shell = .false.
           end if
           cascade3%m_min = cascade3%m_rea
           call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
           if (cascade_set%keep_nonresonant) then
              call cascade_fusion (cascade_set, cascade1, cascade2, cascade4)
           end if
        else
           call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
        end if
     else
        deallocate (cascade3)
     end if
   contains
     subroutine warn_decay (flv)
       type(flavor_t), intent(in) :: flv
       integer :: i
       integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0
       LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE
          if (warned_code(i) == 0) then
             warned_code(i) = flv%get_pdg ()
             write (msg_buffer, "(A)") &
                  & " Intermediate decay of zero-width particle " &
                  & // char (flv%get_name ()) &
                  & // " may be possible."
             call msg_warning
             exit LOOP_WARNED
          else if (warned_code(i) == flv%get_pdg ()) then
             exit LOOP_WARNED
          end if
       end do LOOP_WARNED
     end subroutine warn_decay
   end subroutine cascade_combine_s
 
 @ %def cascade_combine_s
 <<Cascades: parameters>>=
   integer, parameter, public :: MAX_WARN_RESONANCE = 50
 @ %def MAX_WARN_RESONANCE
 @ This is the t-channel version.  [[cascade1]] is t-channel and
 contains the seed, [[cascade2]] is s-channel.  We check for
 kinematically allowed beam decay (which is a fatal error), or massless
 splitting / soft radiation.  The cascade is kept in all remaining
 cases and submitted for registration.
 <<Cascades: procedures>>=
   subroutine cascade_combine_t (cascade_set, cascade1, cascade2, flv)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in), target :: cascade1, cascade2
     type(flavor_t), intent(in) :: flv
     type(cascade_t), pointer :: cascade3
     allocate (cascade3)
     call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1)
     cascade3%bincode = ior (cascade1%bincode, cascade2%bincode)
     cascade3%flv = flv%anti ()
     cascade3%pdg = abs (cascade3%flv%get_pdg ())
     cascade3%is_vector = flv%get_spin_type () == VECTOR
     if (cascade1%incoming) then
        cascade3%m_min = cascade2%m_min
     else
        cascade3%m_min = cascade1%m_min + cascade2%m_min
     end if
     cascade3%m_rea = flv%get_mass ()
     if (cascade3%m_rea > cascade_set%m_threshold_t) then
        cascade3%m_eff = max (cascade3%m_rea, cascade2%m_eff)
     else if (cascade2%m_eff > cascade_set%m_threshold_t) then
        cascade3%m_eff = cascade2%m_eff
     else
        cascade3%m_eff = 0
     end if
     ! Allowed decay of beam particle
     if (cascade1%incoming &
          .and. cascade1%m_rea > cascade2%m_rea + cascade3%m_rea) then
          call beam_decay (cascade_set%fatal_beam_decay)
     ! Massless splitting
     else if (cascade1%m_eff == 0 &
          .and. cascade2%m_eff < cascade_set%m_threshold_t &
          .and. cascade3%m_eff == 0) then
        cascade3%mapping = U_CHANNEL
        cascade3%log_enhanced = .true.
     ! IR radiation off massive particle
     else if (cascade1%m_eff /= 0 .and. cascade2%m_eff == 0 &
          .and. cascade3%m_eff /= 0 &
          .and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) &
          .and. abs (cascade1%m_eff - cascade3%m_eff) &
                < cascade_set%m_threshold_t) &
          then
        cascade3%pdg = flv%get_pdg ()
        cascade3%log_enhanced = .true.
        cascade3%mapping = RADIATION
     end if
     cascade3%t_channel = .true.
     call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
   contains
     subroutine beam_decay (fatal_beam_decay)
       logical, intent(in) :: fatal_beam_decay
       write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") &
            char (cascade1%flv%get_name ()), &
            char (cascade3%flv%get_name ()), &
            char (cascade2%flv%get_name ())
       call msg_message
       write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
            char (cascade1%flv%get_name ()), cascade1%m_rea
       call msg_message
       write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
            char (cascade3%flv%get_name ()), cascade3%m_rea
       call msg_message
       write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
            char (cascade2%flv%get_name ()), cascade2%m_rea
       call msg_message
       if (fatal_beam_decay) then
          call msg_fatal (" Phase space: Initial beam particle can decay")
       else
          call msg_warning (" Phase space: Initial beam particle can decay")
       end if
     end subroutine beam_decay
   end subroutine cascade_combine_t
 
 @ %def cascade_combine_t
 @ Here we complete a decay cascade.  The third input is the
 single-particle cascade for the initial particle.  There is no
 resonance or mapping assignment.  The only condition for keeping the
 cascade is the mass sum of the final state, which must be less than
 the available energy.
 
 Two modifications are necessary for scattering cascades: a pure
 s-channel diagram (cascade1 is the incoming particle) do not have a
 logarithmic mapping at top-level.  And in a t-channel diagram, the
 last line exchanged is mapped t-channel, not u-channel.  Finally, we
 can encounter the case of a $2\to 1$ process, where cascade1 is
 incoming, and cascade2 is the outgoing particle.  In all three cases
 we register a new cascade with the modified mapping.
 <<Cascades: procedures>>=
   subroutine cascade_combine_keystone &
        (cascade_set, cascade1, cascade2, cascade3, s_channel)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
     logical, intent(in) :: s_channel
     type(cascade_t), pointer :: cascade4, cascade0
     logical :: keep, ok
     keep = .false.
     allocate (cascade4)
     call cascade_init &
          (cascade4, cascade1%depth + cascade2%depth + cascade3%depth)
     cascade4%complete = .true.
     if (s_channel) then
        cascade4%bincode = ior (cascade1%bincode, cascade2%bincode)
     else
        cascade4%bincode = cascade3%bincode
     end if
     cascade4%flv = cascade3%flv
     cascade4%pdg = cascade3%pdg
     cascade4%mapping = EXTERNAL_PRT
     cascade4%is_vector = cascade3%is_vector
     cascade4%m_min = cascade1%m_min + cascade2%m_min
     cascade4%m_rea = cascade3%m_rea
     cascade4%m_eff = cascade3%m_rea
     if (cascade4%m_min < cascade_set%sqrts) then
        keep = .true.
     end if
     if (keep) then
        if (cascade1%incoming .and. cascade2%log_enhanced) then
           allocate (cascade0)
           cascade0 = cascade2
           cascade0%next => null ()
           cascade0%index = cascade_index ()
           cascade0%mapping = NO_MAPPING
           cascade0%log_enhanced = .false.
           cascade0%n_log_enhanced = cascade0%n_log_enhanced - 1
           cascade0%tree_mapping(cascade0%depth) = NO_MAPPING
           call cascade_keystone &
                (cascade_set, cascade1, cascade0, cascade3, cascade4, ok)
           if (ok) then
              call cascade_set_add (cascade_set, cascade0, ok)
           else
              deallocate (cascade0)
           end if
        else if (cascade1%t_channel .and. cascade1%mapping == U_CHANNEL) then
           allocate (cascade0)
           cascade0 = cascade1
           cascade0%next => null ()
           cascade0%index = cascade_index ()
           cascade0%mapping = T_CHANNEL
           cascade0%tree_mapping(cascade0%depth) = T_CHANNEL
           call cascade_keystone &
                (cascade_set, cascade0, cascade2, cascade3, cascade4, ok)
           if (ok) then
              call cascade_set_add (cascade_set, cascade0, ok)
           else
              deallocate (cascade0)
           end if
        else if (cascade1%incoming .and. cascade2%depth == 1) then
           allocate (cascade0)
           cascade0 = cascade2
           cascade0%next => null ()
           cascade0%index = cascade_index ()
           cascade0%mapping = ON_SHELL
           cascade0%tree_mapping(cascade0%depth) = ON_SHELL
           call cascade_keystone &
                (cascade_set, cascade1, cascade0, cascade3, cascade4, ok)
           if (ok) then
              call cascade_set_add (cascade_set, cascade0, ok)
           else
              deallocate (cascade0)
           end if
        else
           call cascade_keystone &
                (cascade_set, cascade1, cascade2, cascade3, cascade4, ok)
        end if
     else
        deallocate (cascade4)
     end if
   end subroutine cascade_combine_keystone
 
 @ %def cascade_combine_keystone
 @
 \subsection{Cascade combination III: node connections and tree fusion}
 Here we assign global tree properties.  If the allowed number of
 off-shell lines is exceeded, discard the new cascade.  Otherwise,
 assign the trees, sort them, and assign connections.  Finally, append
 the cascade to the list.  This may fail (because in the hash array
 there is already an equivalent cascade).  On failure, discard the
 cascade.
 <<Cascades: procedures>>=
   subroutine cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in), target :: cascade1, cascade2
     type(cascade_t), pointer :: cascade3
     integer :: i1, i2, i3, i4
     logical :: ok
     cascade3%internal = (cascade3%depth - 3) / 2
     if (cascade3%resonant) then
        cascade3%multiplicity = 1
        cascade3%n_resonances = &
             cascade1%n_resonances + cascade2%n_resonances + 1
     else
        cascade3%multiplicity = cascade1%multiplicity + cascade2%multiplicity
        cascade3%n_resonances = cascade1%n_resonances + cascade2%n_resonances
     end if
     if (cascade3%log_enhanced) then
        cascade3%n_log_enhanced = &
             cascade1%n_log_enhanced + cascade2%n_log_enhanced + 1
     else
        cascade3%n_log_enhanced = &
             cascade1%n_log_enhanced + cascade2%n_log_enhanced
     end if
     if (cascade3%resonant) then
        cascade3%n_off_shell = 0
     else if (cascade3%log_enhanced) then
        cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell
     else
        cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell + 1
     end if
     if (cascade3%t_channel) then
        cascade3%n_t_channel = cascade1%n_t_channel + 1
     end if
     if (cascade3%n_off_shell > cascade_set%off_shell) then
        deallocate (cascade3)
     else if (cascade3%n_t_channel > cascade_set%t_channel) then
        deallocate (cascade3)
     else
        i1 = cascade1%depth
        i2 = i1 + 1
        i3 = i1 + cascade2%depth
        i4 = cascade3%depth
        cascade3%tree(:i1) = cascade1%tree
        where (cascade1%tree_mapping > NO_MAPPING)
           cascade3%tree_pdg(:i1) = cascade1%tree_pdg
        elsewhere
           cascade3%tree_pdg(:i1) = UNDEFINED
        end where
        cascade3%tree_mapping(:i1) = cascade1%tree_mapping
        cascade3%tree_resonant(:i1) = cascade1%tree_resonant
        cascade3%tree(i2:i3) = cascade2%tree
        where (cascade2%tree_mapping > NO_MAPPING)
           cascade3%tree_pdg(i2:i3) = cascade2%tree_pdg
        elsewhere
           cascade3%tree_pdg(i2:i3) = UNDEFINED
        end where
        cascade3%tree_mapping(i2:i3) = cascade2%tree_mapping
        cascade3%tree_resonant(i2:i3) = cascade2%tree_resonant
        cascade3%tree(i4) = cascade3%bincode
        cascade3%tree_pdg(i4) = cascade3%pdg
        cascade3%tree_mapping(i4) = cascade3%mapping
        cascade3%tree_resonant(i4) = cascade3%resonant
        call tree_sort (cascade3%tree, &
             cascade3%tree_pdg, cascade3%tree_mapping, cascade3%tree_resonant)
        cascade3%has_children = .true.
        cascade3%daughter1 => cascade1
        cascade3%daughter2 => cascade2
        call cascade_set_add (cascade_set, cascade3, ok)
        if (.not. ok)  deallocate (cascade3)
     end if
   end subroutine cascade_fusion
 
 @ %def cascade_fusion
 @ Here we combine a cascade pair with an incoming particle, i.e., we
 set a keystone.  Otherwise, this is similar.  On the first
 opportunity, we set the [[first_k]] pointer in the cascade set.
 <<Cascades: procedures>>=
   subroutine cascade_keystone &
        (cascade_set, cascade1, cascade2, cascade3, cascade4, ok)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
     type(cascade_t), pointer :: cascade4
     logical, intent(out) :: ok
     integer :: i1, i2, i3, i4
     cascade4%internal = (cascade4%depth - 3) / 2
     cascade4%multiplicity = cascade1%multiplicity + cascade2%multiplicity
     cascade4%n_resonances = cascade1%n_resonances + cascade2%n_resonances
     cascade4%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell
     cascade4%n_log_enhanced = &
             cascade1%n_log_enhanced + cascade2%n_log_enhanced
     cascade4%n_t_channel = cascade1%n_t_channel + cascade2%n_t_channel
     if (cascade4%n_off_shell > cascade_set%off_shell) then
        deallocate (cascade4)
        ok = .false.
     else if (cascade4%n_t_channel > cascade_set%t_channel) then
        deallocate (cascade4)
        ok = .false.
     else
        i1 = cascade1%depth
        i2 = i1 + 1
        i3 = i1 + cascade2%depth
        i4 = cascade4%depth
        cascade4%tree(:i1) = cascade1%tree
        where (cascade1%tree_mapping > NO_MAPPING)
           cascade4%tree_pdg(:i1) = cascade1%tree_pdg
        elsewhere
           cascade4%tree_pdg(:i1) = UNDEFINED
        end where
        cascade4%tree_mapping(:i1) = cascade1%tree_mapping
        cascade4%tree_resonant(:i1) = cascade1%tree_resonant
        cascade4%tree(i2:i3) = cascade2%tree
        where (cascade2%tree_mapping > NO_MAPPING)
           cascade4%tree_pdg(i2:i3) = cascade2%tree_pdg
        elsewhere
           cascade4%tree_pdg(i2:i3) = UNDEFINED
        end where
        cascade4%tree_mapping(i2:i3) = cascade2%tree_mapping
        cascade4%tree_resonant(i2:i3) = cascade2%tree_resonant
        cascade4%tree(i4) = cascade4%bincode
        cascade4%tree_pdg(i4) = UNDEFINED
        cascade4%tree_mapping(i4) = cascade4%mapping
        cascade4%tree_resonant(i4) = .false.
        call tree_sort (cascade4%tree, &
             cascade4%tree_pdg, cascade4%tree_mapping, cascade4%tree_resonant)
        cascade4%has_children = .true.
        cascade4%daughter1 => cascade1
        cascade4%daughter2 => cascade2
        cascade4%mother => cascade3
        call cascade_set_add (cascade_set, cascade4, ok)
        if (ok) then
           if (.not. associated (cascade_set%first_k)) then
              cascade_set%first_k => cascade4
           end if
        else
           deallocate (cascade4)
        end if
     end if
   end subroutine cascade_keystone
 
 @ %def cascade_keystone
 @
 Sort a tree (array of binary codes) and particle code array
 simultaneously, by ascending binary codes.  A convenient method is to
 use the [[maxloc]] function iteratively, to find and remove the
 largest entry in the tree array one by one.
 <<Cascades: procedures>>=
   subroutine tree_sort (tree, pdg, mapping, resonant)
     integer(TC), dimension(:), intent(inout) :: tree
     integer, dimension(:), intent(inout) :: pdg, mapping
     logical, dimension(:), intent(inout) :: resonant
     integer(TC), dimension(size(tree)) :: tree_tmp
     integer, dimension(size(pdg)) :: pdg_tmp, mapping_tmp
     logical, dimension(size(resonant)) :: resonant_tmp
     integer, dimension(1) :: pos
     integer :: i
     tree_tmp = tree
     pdg_tmp = pdg
     mapping_tmp = mapping
     resonant_tmp = resonant
     do i = size(tree),1,-1
        pos = maxloc (tree_tmp)
        tree(i) = tree_tmp (pos(1))
        pdg(i) = pdg_tmp (pos(1))
        mapping(i) = mapping_tmp (pos(1))
        resonant(i) = resonant_tmp (pos(1))
        tree_tmp(pos(1)) = 0
     end do
   end subroutine tree_sort
 
 @ %def tree_sort
 @
 \subsection{Cascade set generation}
 These procedures loop over cascades and build up the cascade set.  After each
 iteration of the innermost loop, we set a breakpoint.
 
 s-channel: We use a nested scan to combine all cascades with all other
 cascades.
 <<Cascades: procedures>>=
   subroutine cascade_set_generate_s (cascade_set)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), pointer :: cascade1, cascade2
     cascade1 => cascade_set%first
     LOOP1: do while (associated (cascade1))
        cascade2 => cascade_set%first
        LOOP2: do while (associated (cascade2))
           if (cascade2%index >= cascade1%index)  exit LOOP2
           if (cascade1 .disjunct. cascade2) then
              call cascade_match_pair (cascade_set, cascade1, cascade2, .true.)
           end if
           call terminate_now_if_signal ()
           cascade2 => cascade2%next
        end do LOOP2
        cascade1 => cascade1%next
     end do LOOP1
   end subroutine cascade_set_generate_s
 
 @ %def cascade_set_generate_s
 @ The t-channel cascades are directed and have a seed (one of the
 incoming particles) and a target (the other one).  We loop over all
 possible seeds and targets.  Inside this, we loop over all t-channel
 cascades ([[cascade1]]) and s-channel cascades ([[cascade2]]) and try
 to combine them.
 <<Cascades: procedures>>=
   subroutine cascade_set_generate_t (cascade_set, pos_seed, pos_target)
     type(cascade_set_t), intent(inout), target :: cascade_set
     integer, intent(in) :: pos_seed, pos_target
     type(cascade_t), pointer :: cascade_seed, cascade_target
     type(cascade_t), pointer :: cascade1, cascade2
     integer(TC) :: bc_seed, bc_target
     bc_seed = ibset (0_TC, pos_seed-1)
     bc_target = ibset (0_TC, pos_target-1)
     cascade_seed => cascade_set%first_t
     LOOP_SEED: do while (associated (cascade_seed))
        if (cascade_seed%bincode == bc_seed) then
           cascade_target => cascade_set%first_t
           LOOP_TARGET: do while (associated (cascade_target))
              if (cascade_target%bincode == bc_target) then
                 cascade1 => cascade_set%first_t
                 LOOP_T: do while (associated (cascade1))
                    if ((cascade1 .disjunct. cascade_target) &
                         .and. .not. (cascade1 .disjunct. cascade_seed)) then
                       cascade2 => cascade_set%first
                       LOOP_S: do while (associated (cascade2))
                          if ((cascade2 .disjunct. cascade_target) &
                               .and. (cascade2 .disjunct. cascade1)) then
                             call cascade_match_pair &
                                  (cascade_set, cascade1, cascade2, .false.)
                          end if
                          call terminate_now_if_signal ()
                          cascade2 => cascade2%next
                       end do LOOP_S
                    end if
                    call terminate_now_if_signal ()
                    cascade1 => cascade1%next
                 end do LOOP_T
              end if
              call terminate_now_if_signal ()
              cascade_target => cascade_target%next
           end do LOOP_TARGET
        end if
        call terminate_now_if_signal ()
        cascade_seed => cascade_seed%next
     end do LOOP_SEED
   end subroutine cascade_set_generate_t
 
 @ %def cascade_set_generate_t
 @ This part completes the phase space for decay processes.  It is
 similar to s-channel cascade generation, but combines two cascade with
 the particular cascade of the incoming particle.  This particular
 cascade is expected to be pointed at by [[first_t]].
 <<Cascades: procedures>>=
   subroutine cascade_set_generate_decay (cascade_set)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), pointer :: cascade1, cascade2
     type(cascade_t), pointer :: cascade_in
     cascade_in => cascade_set%first_t
     cascade1 => cascade_set%first
     do while (associated (cascade1))
        if (cascade1 .disjunct. cascade_in) then
           cascade2 => cascade1%next
           do while (associated (cascade2))
              if ((cascade2 .disjunct. cascade1) &
                   .and. (cascade2 .disjunct. cascade_in)) then
                 call cascade_match_triplet (cascade_set, &
                      cascade1, cascade2, cascade_in, .true.)
              end if
              call terminate_now_if_signal ()
              cascade2 => cascade2%next
           end do
        end if
        call terminate_now_if_signal ()
        cascade1 => cascade1%next
     end do
   end subroutine cascade_set_generate_decay
 
 @ %def cascade_set_generate_decay
 @ This part completes the phase space for scattering processes.  We
 combine a t-channel cascade (containing the seed) with a s-channel
 cascade and the target.
 <<Cascades: procedures>>=
   subroutine cascade_set_generate_scattering &
        (cascade_set, ns1, ns2, nt1, nt2, pos_seed, pos_target)
     type(cascade_set_t), intent(inout), target :: cascade_set
     integer, intent(in) :: pos_seed, pos_target
     integer, intent(in) :: ns1, ns2, nt1, nt2
     type(cascade_t), pointer :: cascade_seed, cascade_target
     type(cascade_t), pointer :: cascade1, cascade2
     integer(TC) :: bc_seed, bc_target
     bc_seed = ibset (0_TC, pos_seed-1)
     bc_target = ibset (0_TC, pos_target-1)
     cascade_seed => cascade_set%first_t
     LOOP_SEED: do while (associated (cascade_seed))
        if (cascade_seed%index < ns1) then
           cascade_seed => cascade_seed%next
           cycle LOOP_SEED
        else if (cascade_seed%index > ns2) then
           exit LOOP_SEED
        else if (cascade_seed%bincode == bc_seed) then
           cascade_target => cascade_set%first_t
           LOOP_TARGET: do while (associated (cascade_target))
              if (cascade_target%index < nt1) then
                 cascade_target => cascade_target%next
                 cycle LOOP_TARGET
              else if (cascade_target%index > nt2) then
                 exit LOOP_TARGET
              else if (cascade_target%bincode == bc_target) then
                 cascade1 => cascade_set%first_t
                 LOOP_T: do while (associated (cascade1))
                    if ((cascade1 .disjunct. cascade_target) &
                         .and. .not. (cascade1 .disjunct. cascade_seed)) then
                       cascade2 => cascade_set%first
                       LOOP_S: do while (associated (cascade2))
                          if ((cascade2 .disjunct. cascade_target) &
                               .and. (cascade2 .disjunct. cascade1)) then
                             call cascade_match_triplet (cascade_set, &
                                  cascade1, cascade2, cascade_target, .false.)
                          end if
                          call terminate_now_if_signal ()
                          cascade2 => cascade2%next
                       end do LOOP_S
                    end if
                    call terminate_now_if_signal ()
                    cascade1 => cascade1%next
                 end do LOOP_T
              end if
              call terminate_now_if_signal ()
              cascade_target => cascade_target%next
           end do LOOP_TARGET
        end if
        call terminate_now_if_signal ()
        cascade_seed => cascade_seed%next
     end do LOOP_SEED
   end subroutine cascade_set_generate_scattering
 
 @ %def cascade_set_generate_scattering
 @
 \subsection{Groves}
 Before assigning groves, assign hashcodes to the resonance patterns, so they
 can easily be compared.
 <<Cascades: procedures>>=
   subroutine cascade_set_assign_resonance_hash (cascade_set)
     type(cascade_set_t), intent(inout) :: cascade_set
     type(cascade_t), pointer :: cascade
     cascade => cascade_set%first_k
     do while (associated (cascade))
        call cascade_assign_resonance_hash (cascade)
        cascade => cascade%next
     end do
   end subroutine cascade_set_assign_resonance_hash
 
 @ %def cascade_assign_resonance_hash
 @ After all cascades are recorded, we group the complete cascades in
 groves.  A grove consists of cascades with identical multiplicity,
 number of resonances, log-enhanced, t-channel lines, and resonance flavors.
 <<Cascades: procedures>>=
   subroutine cascade_set_assign_groves (cascade_set)
     type(cascade_set_t), intent(inout), target :: cascade_set
     type(cascade_t), pointer :: cascade1, cascade2
     integer :: multiplicity
     integer :: n_resonances, n_log_enhanced, n_t_channel, n_off_shell
     integer :: res_hash
     integer :: grove
     grove = 0
     cascade1 => cascade_set%first_k
     do while (associated (cascade1))
        if (cascade1%active .and. cascade1%complete &
             .and. cascade1%grove == 0) then
           grove = grove + 1
           cascade1%grove = grove
           multiplicity = cascade1%multiplicity
           n_resonances = cascade1%n_resonances
           n_log_enhanced = cascade1%n_log_enhanced
           n_off_shell = cascade1%n_off_shell
           n_t_channel = cascade1%n_t_channel
           res_hash = cascade1%res_hash
           cascade2 => cascade1%next
           do while (associated (cascade2))
              if (cascade2%grove == 0) then
                 if (cascade2%multiplicity == multiplicity &
                      .and. cascade2%n_resonances == n_resonances &
                      .and. cascade2%n_log_enhanced == n_log_enhanced &
                      .and. cascade2%n_off_shell == n_off_shell &
                      .and. cascade2%n_t_channel == n_t_channel &
                      .and. cascade2%res_hash == res_hash) then
                    cascade2%grove = grove
                 end if
              end if
              call terminate_now_if_signal ()
              cascade2 => cascade2%next
           end do
        end if
        call terminate_now_if_signal ()
        cascade1 => cascade1%next
     end do
     cascade_set%n_groves = grove
   end subroutine cascade_set_assign_groves
 
 @ %def cascade_set_assign_groves
 @
 \subsection{Generate the phase space file}
 Generate a complete phase space configuration.
 
 For each flavor assignment: First, all s-channel
 graphs that can be built up from the outgoing particles.  Then we
 distinguish (1) decay, where we complete the s-channel graphs by
 connecting to the input line, and (2) scattering, where we now
 generate t-channel graphs by introducing an incoming particle, and
 complete this by connecting to the other incoming particle.
 
 After all cascade sets have been generated, merge them into a common set.
 This eliminates redunancies between flavor assignments.
 <<Cascades: public>>=
   public :: cascade_set_generate
 <<Cascades: procedures>>=
   subroutine cascade_set_generate &
        (cascade_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay)
     type(cascade_set_t), intent(out) :: cascade_set
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in, n_out
     type(flavor_t), dimension(:,:), intent(in) :: flv
     type(phs_parameters_t), intent(in) :: phs_par
     logical, intent(in) :: fatal_beam_decay
     type(cascade_set_t), dimension(:), allocatable :: cset
     type(cascade_t), pointer :: cascade
     integer :: i
     if (phase_space_vanishes (phs_par%sqrts, n_in, flv))  return
     call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, &
        fatal_beam_decay, flv)
     allocate (cset (size (flv, 2)))
     do i = 1, size (cset)
        call cascade_set_generate_single (cset(i), &
             model, n_in, n_out, flv(:,i), phs_par, fatal_beam_decay)
        cascade => cset(i)%first_k
        do while (associated (cascade))
           if (cascade%active .and. cascade%complete) then
              call cascade_set_add_copy (cascade_set, cascade)
           end if
           cascade => cascade%next
        end do
        call cascade_set_final (cset(i))
     end do
     cascade_set%first_k => cascade_set%first
     call cascade_set_assign_resonance_hash (cascade_set)
     call cascade_set_assign_groves (cascade_set)
   end subroutine cascade_set_generate
 
 @ %def cascade_set_generate
 @ This generates phase space for a single channel, without assigning groves.
 <<Cascades: procedures>>=
   subroutine cascade_set_generate_single (cascade_set, &
       model, n_in, n_out, flv, phs_par, fatal_beam_decay)
     type(cascade_set_t), intent(out) :: cascade_set
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in, n_out
     type(flavor_t), dimension(:), intent(in) :: flv
     type(phs_parameters_t), intent(in) :: phs_par
     logical, intent(in) :: fatal_beam_decay
     integer :: n11, n12, n21, n22
     call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, &
        fatal_beam_decay)
     call cascade_set_add_outgoing (cascade_set, flv(n_in+1:))
     call cascade_set_generate_s (cascade_set)
     select case (n_in)
     case(1)
        call cascade_set_add_incoming &
             (cascade_set, n11, n12, n_out + 1, flv(1))
        call cascade_set_generate_decay (cascade_set)
     case(2)
        call cascade_set_add_incoming &
             (cascade_set, n11, n12, n_out + 1, flv(2))
        call cascade_set_add_incoming &
             (cascade_set, n21, n22, n_out + 2, flv(1))
        call cascade_set_generate_t (cascade_set, n_out + 1, n_out + 2)
        call cascade_set_generate_t (cascade_set, n_out + 2, n_out + 1)
        call cascade_set_generate_scattering &
             (cascade_set, n11, n12, n21, n22, n_out + 1, n_out + 2)
        call cascade_set_generate_scattering &
             (cascade_set, n21, n22, n11, n12, n_out + 2, n_out + 1)
     end select
   end subroutine cascade_set_generate_single
 
 @ %def cascade_set_generate_single
 @ Sanity check: Before anything else is done, check if there could
 possibly be any phase space.
 <<Cascades: public>>=
   public :: phase_space_vanishes
 <<Cascades: procedures>>=
   function phase_space_vanishes (sqrts, n_in, flv) result (flag)
     logical :: flag
     real(default), intent(in) :: sqrts
     integer, intent(in) :: n_in
     type(flavor_t), dimension(:,:), intent(in) :: flv
     real(default), dimension(:,:), allocatable :: mass
     real(default), dimension(:), allocatable :: mass_in, mass_out
     integer :: n_prt, n_flv, i, j
     flag = .false.
     if (sqrts <= 0) then
        call msg_error ("Phase space vanishes (sqrts must be positive)")
        flag = .true.;  return
     end if
     n_prt = size (flv, 1)
     n_flv = size (flv, 2)
     allocate (mass (n_prt, n_flv), mass_in (n_flv), mass_out (n_flv))
     mass = flv%get_mass ()
     mass_in = sum (mass(:n_in,:), 1)
     mass_out = sum (mass(n_in+1:,:), 1)
     if (any (mass_in > sqrts)) then
        call msg_error ("Mass sum of incoming particles " &
             // "is more than available energy")
        flag = .true.;  return
     end if
     if (any (mass_out > sqrts)) then
        call msg_error ("Mass sum of outgoing particles " &
             // "is more than available energy")
        flag = .true.;  return
     end if
   end function phase_space_vanishes
 
 @ %def phase_space_vanishes
 @
 \subsection{Return the resonance histories for subtraction}
 This appears to be essential (re-export of some imported assignment?)!
 <<Cascades: public>>=
   public :: assignment(=)
 @
 Extract the resonance set from a complete cascade.
 <<Cascades: cascade: TBP>>=
   procedure :: extract_resonance_history => cascade_extract_resonance_history
 <<Cascades: procedures>>=
   subroutine cascade_extract_resonance_history &
        (cascade, res_hist, model, n_out)
     class(cascade_t), intent(in), target :: cascade
     type(resonance_history_t), intent(out) :: res_hist
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_out
     type(resonance_info_t) :: resonance
     integer :: i, mom_id, pdg
     if (debug_on) call msg_debug2 (D_PHASESPACE, "cascade_extract_resonance_history")
     if (cascade%n_resonances > 0) then
        if (cascade%has_children) then
           if (debug_on) call msg_debug2 (D_PHASESPACE, "cascade has resonances and children")
           do i = 1, size(cascade%tree_resonant)
              if (cascade%tree_resonant (i)) then
                 mom_id = cascade%tree (i)
                 pdg = cascade%tree_pdg (i)
                 call resonance%init (mom_id, pdg, model, n_out)
                 if (debug2_active (D_PHASESPACE)) then
                    print *, 'D: Adding resonance'
                    call resonance%write ()
                 end if
                 call res_hist%add_resonance (resonance)
              end if
           end do
        end if
     end if
   end subroutine cascade_extract_resonance_history
 
 @ %def cascade_extract_resonance_history
 @
 <<Cascades: public>>=
   public :: cascade_set_get_n_trees
 <<Cascades: procedures>>=
   function cascade_set_get_n_trees (cascade_set) result (n)
     type(cascade_set_t), intent(in), target :: cascade_set
     integer :: n
     type(cascade_t), pointer :: cascade
     integer :: grove
     if (debug_on) call msg_debug (D_PHASESPACE, "cascade_set_get_n_trees")
     n = 0
     do grove = 1, cascade_set%n_groves
        cascade => cascade_set%first_k
        do while (associated (cascade))
           if (cascade%active .and. cascade%complete) then
              if (cascade%grove == grove) then
                 n = n + 1
              end if
           end if
           cascade => cascade%next
        end do
     end do
     if (debug_on) call msg_debug (D_PHASESPACE, "n", n)
   end function cascade_set_get_n_trees
 
 @ %def cascade_set_get_n_trees
 @ Distill the set of resonance histories from the cascade set.  The
 result is an array which contains each valid history exactly once.
 <<Cascades: public>>=
   public :: cascade_set_get_resonance_histories
 <<Cascades: procedures>>=
   subroutine cascade_set_get_resonance_histories (cascade_set, n_filter, res_hists)
     type(cascade_set_t), intent(in), target :: cascade_set
     integer, intent(in), optional :: n_filter
     type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_hists
     type(resonance_history_t), dimension(:), allocatable :: tmp
     type(cascade_t), pointer :: cascade
     type(resonance_history_t) :: res_hist
     type(resonance_history_set_t) :: res_hist_set
     integer :: grove, i, n_hists
     logical :: included, add_to_list
     if (debug_on) call msg_debug (D_PHASESPACE, "cascade_set_get_resonance_histories")
     call res_hist_set%init (n_filter = n_filter)
     do grove = 1, cascade_set%n_groves
        cascade => cascade_set%first_k
        do while (associated (cascade))
           if (cascade%active .and. cascade%complete) then
              if (cascade%grove == grove) then
                 if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", grove)
                 call cascade%extract_resonance_history &
                      (res_hist, cascade_set%model, cascade_set%n_out)
                 call res_hist_set%enter (res_hist)
              end if
           end if
           cascade => cascade%next
        end do
     end do
     call res_hist_set%freeze ()
     call res_hist_set%to_array (res_hists)
   end subroutine cascade_set_get_resonance_histories
 
 @ %def cascade_set_get_resonance_histories
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[cascades_ut.f90]]>>=
 <<File header>>
 
 module cascades_ut
   use unit_tests
   use cascades_uti
 
 <<Standard module head>>
 
 <<Cascades: public test>>
 
 contains
 
 <<Cascades: test driver>>
 
 end module cascades_ut
 @ %def cascades_ut
 @
 <<[[cascades_uti.f90]]>>=
 <<File header>>
 
 module cascades_uti
 
 <<Use kinds>>
 <<Use strings>>
   use numeric_utils
   use flavors
   use model_data
   use phs_forests, only: phs_parameters_t
   use resonances, only: resonance_history_t
 
   use cascades
 
 <<Standard module head>>
 
 <<Cascades: test declarations>>
 
 contains
 
 <<Cascades: tests>>
 
 end module cascades_uti
 @ %def cascades_ut
 @ API: driver for the unit tests below.
 <<Cascades: public test>>=
   public :: cascades_test
 <<Cascades: test driver>>=
   subroutine cascades_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Cascades: execute tests>>
   end subroutine cascades_test
 
 @ %def cascades_test
 \subsubsection{Check cascade setup}
 @ Checking the basic setup up of the phase space cascade parameterizations.
 <<Cascades: execute tests>>=
   call test (cascades_1, "cascades_1", &
        "check cascade setup", &
        u, results)
 <<Cascades: test declarations>>=
   public :: cascades_1
 <<Cascades: tests>>=
   subroutine cascades_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(5,2) :: flv
     type(cascade_set_t) :: cascade_set
     type(phs_parameters_t) :: phs_par
 
     write (u, "(A)")  "* Test output: cascades_1"
     write (u, "(A)")  "*   Purpose: test cascade phase space functions"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initializing"
     write (u, "(A)")
 
     call model%init_sm_test ()
 
     call flv(1,1)%init ( 2, model)
     call flv(2,1)%init (-2, model)
     call flv(3,1)%init ( 1, model)
     call flv(4,1)%init (-1, model)
     call flv(5,1)%init (21, model)
     call flv(1,2)%init ( 2, model)
     call flv(2,2)%init (-2, model)
     call flv(3,2)%init ( 2, model)
     call flv(4,2)%init (-2, model)
     call flv(5,2)%init (21, model)
     phs_par%sqrts = 1000._default
     phs_par%off_shell = 2
 
     write (u, "(A)")
     write (u, "(A)")  "* Generating the cascades"
     write (u, "(A)")
 
     call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.)
     call cascade_set_write (cascade_set, u)
     call cascade_set_write_file_format (cascade_set, u)
 
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     call cascade_set_final (cascade_set)
     call model%final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: cascades_1"
 
   end subroutine cascades_1
 
 @ %def cascades_1
 @
 \subsubsection{Check resonance history}
 <<Cascades: execute tests>>=
   call test(cascades_2, "cascades_2", &
             "Check resonance history", u, results)
 <<Cascades: test declarations>>=
   public :: cascades_2
 <<Cascades: tests>>=
   subroutine cascades_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(5,1) :: flv
     type(cascade_set_t) :: cascade_set
     type(phs_parameters_t) :: phs_par
     type(resonance_history_t), dimension(:), allocatable :: res_hists
     integer :: n, i
     write (u, "(A)")  "* Test output: cascades_2"
     write (u, "(A)")  "*   Purpose: Check resonance history"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initializing"
     write (u, "(A)")
 
     call model%init_sm_test ()
 
     call flv(1,1)%init ( 2, model)
     call flv(2,1)%init (-2, model)
     call flv(3,1)%init ( 1, model)
     call flv(4,1)%init (-1, model)
     call flv(5,1)%init (22, model)
     phs_par%sqrts = 1000._default
     phs_par%off_shell = 2
 
     write (u, "(A)")
     write (u, "(A)")  "* Generating the cascades"
     write (u, "(A)")
 
     call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.)
     call cascade_set_get_resonance_histories (cascade_set, res_hists = res_hists)
     n = cascade_set_get_n_trees (cascade_set)
     call assert_equal (u, n, 24, "Number of trees")
     do i = 1, size(res_hists)
        call res_hists(i)%write (u)
        write (u, "(A)")
     end do
 
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     call cascade_set_final (cascade_set)
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: cascades_2"
   end subroutine cascades_2
 
 @ %def cascades_2
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{WOOD phase space}
 
 This is the module that interfaces the [[phs_forests]] phase-space
 treatment and the [[cascades]] module for generating phase-space
 channels.  As an extension of the [[phs_base]] abstract type,
 the phase-space configuration and instance implement the standard API.
 
 (Currently, this is the only generic phase-space implementation of
 \whizard.  For trivial two-particle phase space, there is
 [[phs_wood]] as an alternative.)
 <<[[phs_wood.f90]]>>=
 <<File header>>
 
 module phs_wood
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use constants
   use numeric_utils
   use diagnostics
   use os_interface
   use md5
   use physics_defs
   use lorentz
   use model_data
   use flavors
   use process_constants
   use sf_mappings
   use sf_base
   use phs_base
   use mappings
   use resonances, only: resonance_history_set_t
   use phs_forests
   use cascades
   use cascades2
 
 <<Standard module head>>
 
 <<PHS wood: public>>
 
 <<PHS wood: parameters>>
 
 <<PHS wood: types>>
 
 contains
 
 <<PHS wood: procedures>>
 
 end module phs_wood
 @ %def phs_wood
 @
 \subsection{Configuration}
 <<PHS wood: parameters>>=
   integer, parameter, public :: EXTENSION_NONE = 0
   integer, parameter, public :: EXTENSION_DEFAULT = 1
   integer, parameter, public :: EXTENSION_DGLAP = 2
 
 <<PHS wood: public>>=
   public :: phs_wood_config_t
 <<PHS wood: types>>=
   type, extends (phs_config_t) :: phs_wood_config_t
      character(32) :: md5sum_forest = ""
      type(string_t) :: phs_path
      integer :: io_unit = 0
      logical :: io_unit_keep_open = .false.
      logical :: use_equivalences = .false.
      logical :: fatal_beam_decay = .true.
      type(mapping_defaults_t) :: mapping_defaults
      type(phs_parameters_t) :: par
      type(string_t) :: run_id
      type(cascade_set_t), allocatable :: cascade_set
      logical :: use_cascades2 = .false.
      type(feyngraph_set_t), allocatable :: feyngraph_set
      type(phs_forest_t) :: forest
      type(os_data_t) :: os_data
      integer :: extension_mode = EXTENSION_NONE
    contains
    <<PHS wood: phs wood config: TBP>>
   end type phs_wood_config_t
 
 @ %def phs_wood_config_t
 @ Finalizer.  We should delete the cascade set and the forest subobject.
 
 Also close the I/O unit, just in case.  (We assume that [[io_unit]] is
 not standard input/output.)
 <<PHS wood: phs wood config: TBP>>=
   procedure :: final => phs_wood_config_final
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_final (object)
     class(phs_wood_config_t), intent(inout) :: object
     logical :: opened
     if (object%io_unit /= 0) then
        inquire (unit = object%io_unit, opened = opened)
        if (opened)  close (object%io_unit)
     end if
     call object%clear_phase_space ()
     call phs_forest_final (object%forest)
   end subroutine phs_wood_config_final
 
 @ %def phs_wood_config_final
 @
 <<PHS wood: phs wood config: TBP>>=
   procedure :: increase_n_par => phs_wood_config_increase_n_par
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_increase_n_par (phs_config)
     class(phs_wood_config_t), intent(inout) :: phs_config
     select case (phs_config%extension_mode)
     case (EXTENSION_DEFAULT)
        phs_config%n_par = phs_config%n_par + 3
     case (EXTENSION_DGLAP)
        phs_config%n_par = phs_config%n_par + 4
     end select
   end subroutine phs_wood_config_increase_n_par
 
 @ %def phs_wood_config_increase_n_par
 @
 <<PHS wood: phs wood config: TBP>>=
   procedure :: set_extension_mode => phs_wood_config_set_extension_mode
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_set_extension_mode (phs_config, mode)
     class(phs_wood_config_t), intent(inout) :: phs_config
     integer, intent(in) :: mode
     phs_config%extension_mode = mode
   end subroutine phs_wood_config_set_extension_mode
 
 @ %def phs_wood_config_set_extension_mode
 @ Output.  The contents of the PHS forest are not printed explicitly.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: write => phs_wood_config_write
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_write (object, unit, include_id)
     class(phs_wood_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: include_id
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)") &
          "Partonic phase-space configuration (phase-space forest):"
     call object%base_write (unit)
     write (u, "(1x,A)")    "Phase-space configuration parameters:"
     call object%par%write (u)
     call object%mapping_defaults%write (u)
     write (u, "(3x,A,A,A)")  "Run ID: '", char (object%run_id), "'"
   end subroutine phs_wood_config_write
 
 @ %def phs_wood_config_write
 @ Print the PHS forest contents.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: write_forest => phs_wood_config_write_forest
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_write_forest (object, unit)
     class(phs_wood_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     call phs_forest_write (object%forest, u)
   end subroutine phs_wood_config_write_forest
 
 @ %def phs_wood_config_write_forest
 @ Set the phase-space parameters that the configuration generator requests.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: set_parameters => phs_wood_config_set_parameters
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_set_parameters (phs_config, par)
     class(phs_wood_config_t), intent(inout) :: phs_config
     type(phs_parameters_t), intent(in) :: par
     phs_config%par = par
   end subroutine phs_wood_config_set_parameters
 
 @ %def phs_wood_config_set_parameters
 @ Enable the generation of channel equivalences (when calling [[configure]]).
 <<PHS wood: phs wood config: TBP>>=
   procedure :: enable_equivalences => phs_wood_config_enable_equivalences
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_enable_equivalences (phs_config)
     class(phs_wood_config_t), intent(inout) :: phs_config
     phs_config%use_equivalences = .true.
   end subroutine phs_wood_config_enable_equivalences
 
 @ %def phs_wood_config_enable_equivalences
 @ Set the phase-space mapping parameters that the configuration generator
 requests.g
 <<PHS wood: phs wood config: TBP>>=
   procedure :: set_mapping_defaults => phs_wood_config_set_mapping_defaults
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_set_mapping_defaults (phs_config, mapping_defaults)
     class(phs_wood_config_t), intent(inout) :: phs_config
     type(mapping_defaults_t), intent(in) :: mapping_defaults
     phs_config%mapping_defaults = mapping_defaults
   end subroutine phs_wood_config_set_mapping_defaults
 
 @ %def phs_wood_config_set_mapping_defaults
 @ Define the input stream for the phase-space file as an open logical unit.
 The unit must be connected.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: set_input => phs_wood_config_set_input
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_set_input (phs_config, unit)
     class(phs_wood_config_t), intent(inout) :: phs_config
     integer, intent(in) :: unit
     phs_config%io_unit = unit
     rewind (unit)
   end subroutine phs_wood_config_set_input
 
 @ %def phs_wood_config_set_input
 @
 \subsection{Phase-space generation}
 This subroutine generates a phase space configuration using the
 [[cascades]] module.   Note that this may take time, and the
 [[cascade_set]] subobject may consume a large amount of memory.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: generate_phase_space => phs_wood_config_generate_phase_space
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_generate_phase_space (phs_config)
     class(phs_wood_config_t), intent(inout) :: phs_config
     integer :: off_shell, extra_off_shell
     logical :: valid
     integer :: unit_fds
     type(string_t) :: file_name
     logical :: file_exists
     call msg_message ("Phase space: generating configuration ...")
     off_shell = phs_config%par%off_shell
     if (phs_config%use_cascades2) then
        file_name = char (phs_config%id) // ".fds"
        inquire (file=char (file_name), exist=file_exists)
        if (.not. file_exists) call msg_fatal &
             ("The O'Mega input file " // char (file_name) // &
             " does not exist. " // "Please make sure that the " // &
             "variable ?omega_write_phs_output has been set correctly.")
        unit_fds = free_unit ()
        open (unit=unit_fds, file=char(file_name), status='old', action='read')
        do extra_off_shell = 0, max (phs_config%n_tot - 3, 0)
           phs_config%par%off_shell = off_shell + extra_off_shell
           allocate (phs_config%feyngraph_set)
           call feyngraph_set_generate (phs_config%feyngraph_set, &
                phs_config%model, phs_config%n_in, phs_config%n_out, &
                phs_config%flv, &
                phs_config%par, phs_config%fatal_beam_decay, unit_fds, &
                phs_config%vis_channels)
           if (feyngraph_set_is_valid (phs_config%feyngraph_set)) then
              exit
           else
              call msg_message ("Phase space: ... failed.  &
                   &Increasing phs_off_shell ...")
              call phs_config%feyngraph_set%final ()
              deallocate (phs_config%feyngraph_set)
           end if
        end do
        close (unit_fds)
     else
        allocate (phs_config%cascade_set)
        do extra_off_shell = 0, max (phs_config%n_tot - 3, 0)
           phs_config%par%off_shell = off_shell + extra_off_shell
           call cascade_set_generate (phs_config%cascade_set, &
                phs_config%model, phs_config%n_in, phs_config%n_out, &
                phs_config%flv, &
                phs_config%par, phs_config%fatal_beam_decay)
           if (cascade_set_is_valid (phs_config%cascade_set)) then
              exit
           else
              call msg_message ("Phase space: ... failed.  &
                   &Increasing phs_off_shell ...")
           end if
        end do
     end if
     if (phs_config%use_cascades2) then
        valid = feyngraph_set_is_valid (phs_config%feyngraph_set)
     else
        valid = cascade_set_is_valid (phs_config%cascade_set)
     end if
     if (valid) then
        call msg_message ("Phase space: ... success.")
     else
        call msg_fatal ("Phase-space: generation failed")
     end if
   end subroutine phs_wood_config_generate_phase_space
 
 @ %def phs_wood_config_generate_phase_space
 @ Using the generated phase-space configuration, write an appropriate
 phase-space file to the stored (or explicitly specified) I/O unit.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: write_phase_space => phs_wood_config_write_phase_space
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_write_phase_space (phs_config, &
        filename_vis, unit)
     class(phs_wood_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     type(string_t), intent(in), optional :: filename_vis
     type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi
     integer :: u, unit_tex, unit_dev, status
     if (allocated (phs_config%cascade_set) .or. allocated (phs_config%feyngraph_set)) then
        if (present (unit)) then
           u = unit
        else
           u = phs_config%io_unit
        end if
        write (u, "(1x,A,A)") "process ", char (phs_config%id)
        write (u, "(A)")
        if (phs_config%use_cascades2) then
           call feyngraph_set_write_process_bincode_format (phs_config%feyngraph_set, u)
        else
           call cascade_set_write_process_bincode_format (phs_config%cascade_set, u)
        end if
        write (u, "(A)")
        write (u, "(3x,A,A,A32,A)") "md5sum_process    = ", &
             '"', phs_config%md5sum_process, '"'
        write (u, "(3x,A,A,A32,A)") "md5sum_model_par  = ", &
             '"', phs_config%md5sum_model_par, '"'
        write (u, "(3x,A,A,A32,A)") "md5sum_phs_config = ", &
             '"', phs_config%md5sum_phs_config, '"'
        call phs_config%par%write (u)
        if (phs_config%use_cascades2) then
           call feyngraph_set_write_file_format (phs_config%feyngraph_set, u)
        else
           call cascade_set_write_file_format (phs_config%cascade_set, u)
        end if
        if (phs_config%vis_channels) then
           unit_tex = free_unit ()
           open (unit=unit_tex, file=char(filename_vis // ".tex"), &
                action="write", status="replace")
           if (phs_config%use_cascades2) then
              call feyngraph_set_write_graph_format (phs_config%feyngraph_set, &
                   filename_vis // "-graphs", phs_config%id, unit_tex)
           else
              call cascade_set_write_graph_format (phs_config%cascade_set, &
                   filename_vis // "-graphs", phs_config%id, unit_tex)
           end if
           close (unit_tex)
           call msg_message ("Phase space: visualizing channels in file " &
                // char(trim(filename_vis)) // "...")
           if (phs_config%os_data%event_analysis_ps) then
              BLOCK: do
                 unit_dev = free_unit ()
                 open (file = "/dev/null", unit = unit_dev, &
                      action = "write", iostat = status)
                 if (status /= 0) then
                    pipe = ""
                    pipe_dvi = ""
                 else
                    pipe = " > /dev/null"
                    pipe_dvi = " 2>/dev/null 1>/dev/null"
                 end if
                 close (unit_dev)
                 if (phs_config%os_data%whizard_texpath /= "") then
                    setenv_tex = "TEXINPUTS=" // &
                         phs_config%os_data%whizard_texpath // ":$TEXINPUTS "
                    setenv_mp = "MPINPUTS=" // &
                         phs_config%os_data%whizard_texpath // ":$MPINPUTS "
                 else
                    setenv_tex = ""
                    setenv_mp = ""
                 end if
                 call os_system_call (setenv_tex // &
                      phs_config%os_data%latex // " " // &
                      filename_vis // ".tex " // pipe, status)
                 if (status /= 0)  exit BLOCK
                 if (phs_config%os_data%mpost /= "") then
                    call os_system_call (setenv_mp // &
                         phs_config%os_data%mpost // " " // &
                         filename_vis // "-graphs.mp" // pipe, status)
                 else
                    call msg_fatal ("Could not use MetaPOST.")
                 end if
                 if (status /= 0)  exit BLOCK
                 call os_system_call (setenv_tex // &
                      phs_config%os_data%latex // " " // &
                      filename_vis // ".tex" // pipe, status)
                 if (status /= 0)  exit BLOCK
                 call os_system_call &
                      (phs_config%os_data%dvips // " -o " // filename_vis &
                      // ".ps " // filename_vis // ".dvi" // pipe_dvi, status)
                 if (status /= 0)  exit BLOCK
                 if (phs_config%os_data%event_analysis_pdf) then
                    call os_system_call (phs_config%os_data%ps2pdf // " " // &
                         filename_vis // ".ps", status)
                    if (status /= 0)  exit BLOCK
                 end if
                 exit BLOCK
              end do BLOCK
              if (status /= 0) then
                 call msg_error ("Unable to compile analysis output file")
              end if
           end if
        end if
     else
        call msg_fatal ("Phase-space configuration: &
             &no phase space object generated")
     end if
   end subroutine phs_wood_config_write_phase_space
 
 @ %def phs_config_write_phase_space
 @ Clear the phase-space configuration.  This is useful since the
 object may become \emph{really} large.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: clear_phase_space => phs_wood_config_clear_phase_space
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_clear_phase_space (phs_config)
     class(phs_wood_config_t), intent(inout) :: phs_config
     if (allocated (phs_config%cascade_set)) then
        call cascade_set_final (phs_config%cascade_set)
        deallocate (phs_config%cascade_set)
     end if
     if (allocated (phs_config%feyngraph_set)) then
        call phs_config%feyngraph_set%final ()
        deallocate (phs_config%feyngraph_set)
     end if
   end subroutine phs_wood_config_clear_phase_space
 
 @ %def phs_wood_config_clear_phase_space
 @
 Extract the set of resonance histories
 <<PHS wood: phs wood config: TBP>>=
   procedure :: extract_resonance_history_set &
        => phs_wood_config_extract_resonance_history_set
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_extract_resonance_history_set &
        (phs_config, res_set, include_trivial)
     class(phs_wood_config_t), intent(in) :: phs_config
     type(resonance_history_set_t), intent(out) :: res_set
     logical, intent(in), optional :: include_trivial
     call phs_config%forest%extract_resonance_history_set &
          (res_set, include_trivial)
   end subroutine phs_wood_config_extract_resonance_history_set
 
 @ %def phs_wood_config_extract_resonance_history_set
 @
 \subsection{Phase-space configuration}
 We read the phase-space configuration from the stored I/O unit.  If
 this is not set, we assume that we have to generate a phase space
 configuration.  When done, we open a scratch file and write the
 configuration.
 
 If [[rebuild]] is set, we should trash any existing phase space file
 and build a new one.  Otherwise, we try to use an old one, which we
 check for existence and integrity.  If [[ignore_mismatch]] is set, we
 reuse an existing file even if it does not match the current setup.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: configure => phs_wood_config_configure
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_configure (phs_config, sqrts, &
        sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, ignore_mismatch, &
        nlo_type, subdir)
     class(phs_wood_config_t), intent(inout) :: phs_config
     real(default), intent(in) :: sqrts
     logical, intent(in), optional :: sqrts_fixed
     logical, intent(in), optional :: cm_frame
     logical, intent(in), optional :: azimuthal_dependence
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     integer, intent(in), optional :: nlo_type
     type(string_t), intent(in), optional :: subdir
     type(string_t) :: filename, filename_vis
     logical :: variable_limits
     logical :: ok, exist, found, check, match, rebuild_phs
     integer :: g, c0, c1, n
     if (present (nlo_type)) then
       phs_config%nlo_type = nlo_type
     else
       phs_config%nlo_type = BORN
     end if
     phs_config%sqrts = sqrts
     phs_config%par%sqrts = sqrts
     if (present (sqrts_fixed)) &
          phs_config%sqrts_fixed = sqrts_fixed
     if (present (cm_frame)) &
          phs_config%cm_frame = cm_frame
     if (present (azimuthal_dependence)) &
          phs_config%azimuthal_dependence = azimuthal_dependence
     if (present (rebuild)) then
        rebuild_phs = rebuild
     else
        rebuild_phs = .true.
     end if
     if (present (ignore_mismatch)) then
        check = .not. ignore_mismatch
        if (ignore_mismatch) &
             call msg_warning ("Reading phs file: MD5 sum check disabled")
     else
        check = .true.
     end if
     phs_config%md5sum_forest = ""
     call phs_config%compute_md5sum (include_id = .false.)
     if (phs_config%io_unit == 0) then
        filename = phs_config%make_phs_filename (subdir)
        filename_vis = phs_config%make_phs_filename (subdir) // "-vis"
        if (.not. rebuild_phs) then
           if (check) then
              call phs_config%read_phs_file (exist, found, match, subdir=subdir)
              rebuild_phs = .not. (exist .and. found .and. match)
           else
              call phs_config%read_phs_file (exist, found, subdir=subdir)
              rebuild_phs = .not. (exist .and. found)
           end if
        end if
        if (.not. mpi_is_comm_master ()) then
           rebuild_phs = .false.
           call msg_message ("MPI: Workers do not build phase space configuration.")
        end if
        if (rebuild_phs) then
           call phs_config%generate_phase_space ()
           phs_config%io_unit = free_unit ()
           if (phs_config%id /= "") then
              call msg_message ("Phase space: writing configuration file '" &
                   // char (filename) // "'")
              open (phs_config%io_unit, file = char (filename), &
                   status = "replace", action = "readwrite")
           else
              open (phs_config%io_unit, status = "scratch", action = "readwrite")
           end if
           call phs_config%write_phase_space (filename_vis)
           rewind (phs_config%io_unit)
        else
           call msg_message ("Phase space: keeping configuration file '" &
                // char (filename) // "'")
        end if
     end if
     if (phs_config%io_unit == 0) then
        ok = .true.
     else
       call phs_forest_read (phs_config%forest, phs_config%io_unit, &
             phs_config%id, phs_config%n_in, phs_config%n_out, &
             phs_config%model, ok)
        if (.not. phs_config%io_unit_keep_open) then
           close (phs_config%io_unit)
           phs_config%io_unit = 0
        end if
     end if
     if (ok) then
        call phs_forest_set_flavors (phs_config%forest, phs_config%flv(:,1))
        variable_limits = .not. phs_config%cm_frame
        call phs_forest_set_parameters &
             (phs_config%forest, phs_config%mapping_defaults, variable_limits)
        call phs_forest_setup_prt_combinations (phs_config%forest)
        phs_config%n_channel = phs_forest_get_n_channels (phs_config%forest)
        phs_config%n_par = phs_forest_get_n_parameters (phs_config%forest)
        allocate (phs_config%channel (phs_config%n_channel))
        if (phs_config%use_equivalences) then
           call phs_forest_set_equivalences (phs_config%forest)
           call phs_forest_get_equivalences (phs_config%forest, &
                phs_config%channel, phs_config%azimuthal_dependence)
           phs_config%provides_equivalences = .true.
        end if
        call phs_forest_set_s_mappings (phs_config%forest)
        call phs_config%record_on_shell ()
        if (phs_config%mapping_defaults%enable_s_mapping) then
           call phs_config%record_s_mappings ()
        end if
        allocate (phs_config%chain (phs_config%n_channel), source = 0)
        do g = 1, phs_forest_get_n_groves (phs_config%forest)
           call phs_forest_get_grove_bounds (phs_config%forest, g, c0, c1, n)
           phs_config%chain (c0:c1) = g
        end do
        phs_config%provides_chains = .true.
        call phs_config%compute_md5sum_forest ()
     else
        write (msg_buffer, "(A,A,A)") &
             "Phase space: process '", &
             char (phs_config%id), "' not found in configuration file"
        call msg_fatal ()
     end if
   end subroutine phs_wood_config_configure
 
 @ %def phs_wood_config_configure
 @ The MD5 sum of the forest is computed in addition to the MD5 sum of
 the configuration.  The reason is that the forest may depend on a
 user-provided external file.  On the other hand, this MD5 sum encodes
 all information that is relevant for further processing.  Therefore,
 the [[get_md5sum]] method returns this result, once it is available.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: compute_md5sum_forest => phs_wood_config_compute_md5sum_forest
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_compute_md5sum_forest (phs_config)
     class(phs_wood_config_t), intent(inout) :: phs_config
     integer :: u
     u = free_unit ()
     open (u, status = "scratch", action = "readwrite")
     call phs_config%write_forest (u)
     rewind (u)
     phs_config%md5sum_forest = md5sum (u)
     close (u)
   end subroutine phs_wood_config_compute_md5sum_forest
 
 @ %def phs_wood_config_compute_md5sum_forest
 @ Create filenames according to standard conventions.  The [[id]] is the
 process name including the suffix [[_iX]] where [[X]] stands for the component
 identifier (an integer).  The [[run_id]] may be set or unset.
 
 The convention for file names that include the run ID is to separate prefix, run
 ID, and any extensions by dots.  We construct the file name by concatenating
 the individual elements accordingly.  If there is no run ID, we nevertheless
 replace [[_iX]] by [[.iX]].
 <<PHS wood: phs wood config: TBP>>=
   procedure :: make_phs_filename => phs_wood_make_phs_filename
 <<PHS wood: procedures>>=
   function phs_wood_make_phs_filename (phs_config, subdir) result (filename)
     class(phs_wood_config_t), intent(in) :: phs_config
     type(string_t), intent(in), optional :: subdir
     type(string_t) :: filename
     type(string_t) :: basename, suffix, comp_code, comp_index
     basename = phs_config%id
     call split (basename, suffix, "_", back=.true.)
     comp_code = extract (suffix, 1, 1)
     comp_index = extract (suffix, 2)
     if (comp_code == "i" .and. verify (comp_index, "1234567890") == 0) then
        suffix = "." // comp_code // comp_index
     else
        basename = phs_config%id
        suffix = ""
     end if
     if (phs_config%run_id /= "") then
        filename = basename // "." // phs_config%run_id // suffix // ".phs"
     else
        filename = basename // suffix // ".phs"
     end if
     if (present (subdir)) then
        filename = subdir // "/" // filename
     end if
   end function phs_wood_make_phs_filename
 
 @ %def phs_wood_make_phs_filename
 @
 <<PHS wood: phs wood config: TBP>>=
   procedure :: reshuffle_flavors => phs_wood_config_reshuffle_flavors
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_reshuffle_flavors (phs_config, reshuffle, flv_extra)
     class(phs_wood_config_t), intent(inout) :: phs_config
     integer, intent(in), dimension(:), allocatable :: reshuffle
     type(flavor_t), intent(in) :: flv_extra
     call phs_forest_set_flavors (phs_config%forest, phs_config%flv(:,1), reshuffle, flv_extra)
   end subroutine phs_wood_config_reshuffle_flavors
 
 @ %def phs_wood_config_reshuffle_flavors
 @
 <<PHS wood: phs wood config: TBP>>=
   procedure :: set_momentum_links => phs_wood_config_set_momentum_links
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle)
     class(phs_wood_config_t), intent(inout) :: phs_config
     integer, intent(in), dimension(:), allocatable :: reshuffle
     call phs_forest_set_momentum_links (phs_config%forest, reshuffle)
   end subroutine phs_wood_config_set_momentum_links
 
 @ %def phs_wood_config_set_momentum_links
 @ Identify resonances which are marked by s-channel mappings for the
 whole phase space and report them to the channel array.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: record_s_mappings => phs_wood_config_record_s_mappings
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_record_s_mappings (phs_config)
     class(phs_wood_config_t), intent(inout) :: phs_config
     logical :: flag
     real(default) :: mass, width
     integer :: c
     do c = 1, phs_config%n_channel
        call phs_forest_get_s_mapping (phs_config%forest, c, flag, mass, width)
        if (flag) then
           if (mass == 0) then
              call msg_fatal ("Phase space: s-channel resonance " &
                   // " has zero mass")
           end if
           if (width == 0) then
              call msg_fatal ("Phase space: s-channel resonance " &
                   // " has zero width")
           end if
           call phs_config%channel(c)%set_resonant (mass, width)
        end if
     end do
   end subroutine phs_wood_config_record_s_mappings
 
 @ %def phs_wood_config_record_s_mappings
 @ Identify on-shell mappings for the whole phase space and report them
 to the channel array.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: record_on_shell => phs_wood_config_record_on_shell
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_record_on_shell (phs_config)
     class(phs_wood_config_t), intent(inout) :: phs_config
     logical :: flag
     real(default) :: mass
     integer :: c
     do c = 1, phs_config%n_channel
        call phs_forest_get_on_shell (phs_config%forest, c, flag, mass)
        if (flag) then
           call phs_config%channel(c)%set_on_shell (mass)
        end if
     end do
   end subroutine phs_wood_config_record_on_shell
 
 @ %def phs_wood_config_record_on_shell
 @ Return the most relevant MD5 sum.  This overrides the method of the
 base type.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: get_md5sum => phs_wood_config_get_md5sum
 <<PHS wood: procedures>>=
   function phs_wood_config_get_md5sum (phs_config) result (md5sum)
     class(phs_wood_config_t), intent(in) :: phs_config
     character(32) :: md5sum
     if (phs_config%md5sum_forest /= "") then
        md5sum = phs_config%md5sum_forest
     else
        md5sum = phs_config%md5sum_phs_config
     end if
   end function phs_wood_config_get_md5sum
 
 @ %def phs_wood_config_get_md5sum
 @ Check whether a phase-space configuration for the current process exists.
 We look for the phase-space file that should correspond to the current
 process.  If we find it, we check the MD5 sums stored in the file against the
 MD5 sums in the current configuration (if required).
 
 If successful, read the PHS file.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: read_phs_file => phs_wood_read_phs_file
 <<PHS wood: procedures>>=
   subroutine phs_wood_read_phs_file (phs_config, exist, found, match, subdir)
     class(phs_wood_config_t), intent(inout) :: phs_config
     logical, intent(out) :: exist
     logical, intent(out) :: found
     logical, intent(out), optional :: match
     type(string_t), intent(in), optional :: subdir
     type(string_t) :: filename
     integer :: u
     filename = phs_config%make_phs_filename (subdir)
     inquire (file = char (filename), exist = exist)
     if (exist) then
        u = free_unit ()
        open (u, file = char (filename), action = "read", status = "old")
        call phs_forest_read (phs_config%forest, u, &
             phs_config%id, phs_config%n_in, phs_config%n_out, &
             phs_config%model, found, &
             phs_config%md5sum_process, &
             phs_config%md5sum_model_par, &
             phs_config%md5sum_phs_config, &
             match = match)
        close (u)
     else
        found = .false.
        if (present (match))  match = .false.
     end if
   end subroutine phs_wood_read_phs_file
 
 @ %def phs_wood_read_phs_file
 @ Startup message, after configuration is complete.
 <<PHS wood: phs wood config: TBP>>=
   procedure :: startup_message => phs_wood_config_startup_message
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_startup_message (phs_config, unit)
     class(phs_wood_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     integer :: n_groves, n_eq
     n_groves = phs_forest_get_n_groves (phs_config%forest)
     n_eq = phs_forest_get_n_equivalences (phs_config%forest)
     call phs_config%base_startup_message (unit)
     if (phs_config%n_channel == 1) then
        write (msg_buffer, "(A,2(I0,A))") &
             "Phase space: found ", phs_config%n_channel, &
             " channel, collected in ", n_groves, &
             " grove."
     else if (n_groves == 1) then
        write (msg_buffer, "(A,2(I0,A))") &
             "Phase space: found ", phs_config%n_channel, &
             " channels, collected in ", n_groves, &
             " grove."
        else
        write (msg_buffer, "(A,2(I0,A))") &
             "Phase space: found ", phs_config%n_channel, &
             " channels, collected in ", &
             phs_forest_get_n_groves (phs_config%forest), &
             " groves."
     end if
     call msg_message (unit = unit)
     if (phs_config%use_equivalences) then
        if (n_eq == 1) then
           write (msg_buffer, "(A,I0,A)") &
                "Phase space: Using ", n_eq, &
                " equivalence between channels."
        else
           write (msg_buffer, "(A,I0,A)") &
                "Phase space: Using ", n_eq, &
                " equivalences between channels."
        end if
     else
        write (msg_buffer, "(A)") &
             "Phase space: no equivalences between channels used."
     end if
     call msg_message (unit = unit)
     write (msg_buffer, "(A,2(1x,I0,1x,A))") &
          "Phase space: wood"
     call msg_message (unit = unit)
   end subroutine phs_wood_config_startup_message
 
 @ %def phs_wood_config_startup_message
 @ Allocate an instance: the actual phase-space object.
 <<PHS wood: phs wood config: TBP>>=
   procedure, nopass :: allocate_instance => phs_wood_config_allocate_instance
 <<PHS wood: procedures>>=
   subroutine phs_wood_config_allocate_instance (phs)
     class(phs_t), intent(inout), pointer :: phs
     allocate (phs_wood_t :: phs)
   end subroutine phs_wood_config_allocate_instance
 
 @ %def phs_wood_config_allocate_instance
 @
 \subsection{Kinematics implementation}
 We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle.
 <<PHS wood: public>>=
   public :: phs_wood_t
 <<PHS wood: types>>=
   type, extends (phs_t) :: phs_wood_t
      real(default) :: sqrts = 0
      type(phs_forest_t) :: forest
      real(default), dimension(3) :: r_real
      integer :: n_r_born = 0
    contains
    <<PHS wood: phs wood: TBP>>
   end type phs_wood_t
 
 @ %def phs_wood_t
 @ Output.  The [[verbose]] setting is irrelevant, we just display the contents
 of the base object.
 <<PHS wood: phs wood: TBP>>=
   procedure :: write => phs_wood_write
 <<PHS wood: procedures>>=
   subroutine phs_wood_write (object, unit, verbose)
     class(phs_wood_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     call object%base_write (u)
   end subroutine phs_wood_write
 
 @ %def phs_wood_write
 @ Write the forest separately.
 <<PHS wood: phs wood: TBP>>=
   procedure :: write_forest => phs_wood_write_forest
 <<PHS wood: procedures>>=
   subroutine phs_wood_write_forest (object, unit)
     class(phs_wood_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     call phs_forest_write (object%forest, u)
   end subroutine phs_wood_write_forest
 
 @ %def phs_wood_write_forest
 @ Finalizer.
 <<PHS wood: phs wood: TBP>>=
   procedure :: final => phs_wood_final
 <<PHS wood: procedures>>=
   subroutine phs_wood_final (object)
     class(phs_wood_t), intent(inout) :: object
     call phs_forest_final (object%forest)
   end subroutine phs_wood_final
 
 @ %def phs_wood_final
 @ Initialization.  We allocate arrays ([[base_init]]) and adjust the
 phase-space volume.  The two-particle phase space volume is
 \begin{equation}
   \Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5}
 \end{equation}
 independent of the particle masses.
 <<PHS wood: phs wood: TBP>>=
   procedure :: init => phs_wood_init
 <<PHS wood: procedures>>=
   subroutine phs_wood_init (phs, phs_config)
     class(phs_wood_t), intent(out) :: phs
     class(phs_config_t), intent(in), target :: phs_config
     call phs%base_init (phs_config)
     select type (phs_config)
     type is (phs_wood_config_t)
        phs%forest = phs_config%forest
        select case (phs_config%extension_mode)
        case (EXTENSION_DEFAULT)
           phs%n_r_born = phs_config%n_par - 3
        case (EXTENSION_DGLAP)
           phs%n_r_born = phs_config%n_par - 4
        end select
     end select
   end subroutine phs_wood_init
 
 @ %def phs_wood_init
 @
 \subsection{Evaluation}
 We compute the outgoing momenta from the incoming momenta and
 the input parameter set [[r_in]] in channel [[r_in]].  We also compute the
 [[r]] parameters and Jacobians [[f]] for all other channels.
 
 We do \emph{not} need to a apply a transformation from/to the c.m.\ frame,
 because in [[phs_base]] the momenta are already boosted to the c.m.\ frame
 before assigning them in the [[phs]] object, and inversely boosted when
 extracting them.
 <<PHS wood: phs wood: TBP>>=
   procedure :: evaluate_selected_channel => phs_wood_evaluate_selected_channel
   procedure :: evaluate_other_channels => phs_wood_evaluate_other_channels
 <<PHS wood: procedures>>=
   subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in)
     class(phs_wood_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     real(default), intent(in), dimension(:) :: r_in
     logical :: ok
     phs%q_defined = .false.
     if (phs%p_defined) then
        call phs_forest_set_prt_in (phs%forest, phs%p)
        phs%r(:,c_in) = r_in
        call phs_forest_evaluate_selected_channel (phs%forest, &
             c_in, phs%active_channel, &
             phs%sqrts_hat, phs%r, phs%f, phs%volume, ok)
        select type (config => phs%config)
        type is (phs_wood_config_t)
           if (config%extension_mode > EXTENSION_NONE) then
              if (phs%n_r_born > 0) then
                 phs%r_real = r_in (phs%n_r_born + 1 : phs%n_r_born + 3)
              else
                 call msg_fatal ("n_r_born should be larger than 0!")
              end if
           end if
        end select
        if (ok) then
           phs%q = phs_forest_get_momenta_out (phs%forest)
           phs%q_defined = .true.
        end if
     end if
   end subroutine phs_wood_evaluate_selected_channel
 
   subroutine phs_wood_evaluate_other_channels (phs, c_in)
     class(phs_wood_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     integer :: c
     if (phs%q_defined) then
        call phs_forest_evaluate_other_channels (phs%forest, &
             c_in, phs%active_channel, &
             phs%sqrts_hat, phs%r, phs%f, combine=.true.)
        select type (config => phs%config)
        type is (phs_wood_config_t)
           if (config%extension_mode > EXTENSION_NONE) then
              if (phs%n_r_born > 0) then
                 do c = 1, size (phs%r, 2)
                    phs%r(phs%n_r_born + 1 : phs%n_r_born + 3, c) = phs%r_real
                 end do
              else
                 phs%r_defined = .false.
              end if
           end if
        end select
        phs%r_defined = .true.
     end if
   end subroutine phs_wood_evaluate_other_channels
 
 @ %def phs_wood_evaluate_selected_channel
 @ %def phs_wood_evaluate_other_channels
 @ Inverse evaluation.
 <<PHS wood: phs wood: TBP>>=
   procedure :: inverse => phs_wood_inverse
 <<PHS wood: procedures>>=
   subroutine phs_wood_inverse (phs)
     class(phs_wood_t), intent(inout) :: phs
     if (phs%p_defined .and. phs%q_defined) then
        call phs_forest_set_prt_in (phs%forest, phs%p)
        call phs_forest_set_prt_out (phs%forest, phs%q)
        call phs_forest_recover_channel (phs%forest, &
             1, &
             phs%sqrts_hat, phs%r, phs%f, phs%volume)
        call phs_forest_evaluate_other_channels (phs%forest, &
             1, phs%active_channel, &
             phs%sqrts_hat, phs%r, phs%f, combine=.false.)
        phs%r_defined = .true.
     end if
   end subroutine phs_wood_inverse
 
 @ %def phs_wood_inverse
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[phs_wood_ut.f90]]>>=
 <<File header>>
 
 module phs_wood_ut
   use unit_tests
   use phs_wood_uti
 
 <<Standard module head>>
 
 <<PHS wood: public test>>
 
 <<PHS wood: public test auxiliary>>
 
 contains
 
 <<PHS wood: test driver>>
 
 end module phs_wood_ut
 @ %def phs_wood_ut
 @
 <<[[phs_wood_uti.f90]]>>=
 <<File header>>
 
 module phs_wood_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use os_interface
   use lorentz
   use flavors
   use model_data
   use process_constants
   use mappings
   use phs_base
   use phs_forests
 
   use phs_wood
 
   use phs_base_ut, only: init_test_process_data, init_test_decay_data
 
 <<Standard module head>>
 
 <<PHS wood: public test auxiliary>>
 
 <<PHS wood: test declarations>>
 
 contains
 
 <<PHS wood: tests>>
 
 <<PHS wood: test auxiliary>>
 
 end module phs_wood_uti
 @ %def phs_wood_ut
 @ API: driver for the unit tests below.
 <<PHS wood: public test>>=
   public :: phs_wood_test
 <<PHS wood: test driver>>=
   subroutine phs_wood_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS wood: execute tests>>
   end subroutine phs_wood_test
 
 @ %def phs_wood_test
 <<PHS wood: public test>>=
   public :: phs_wood_vis_test
 <<PHS wood: test driver>>=
   subroutine phs_wood_vis_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<PHS wood: execute vis tests>>
   end subroutine phs_wood_vis_test
 
 @ %def phs_wood_vis_test
 @
 \subsubsection{Phase-space configuration data}
 Construct and display a test phase-space configuration object.  Also
 check the [[azimuthal_dependence]] flag.
 
 This auxiliary routine writes a phase-space configuration file to unit
 [[u_phs]].
 <<PHS wood: public test auxiliary>>=
   public :: write_test_phs_file
 <<PHS wood: test auxiliary>>=
   subroutine write_test_phs_file (u_phs, procname)
     integer, intent(in) :: u_phs
     type(string_t), intent(in), optional :: procname
     if (present (procname)) then
        write (u_phs, "(A,A)")  "process ", char (procname)
     else
        write (u_phs, "(A)")  "process testproc"
     end if
     write (u_phs, "(A,A)")  "   md5sum_process    = ", '""'
     write (u_phs, "(A,A)")  "   md5sum_model_par  = ", '""'
     write (u_phs, "(A,A)")  "   md5sum_phs_config = ", '""'
     write (u_phs, "(A)")  "   sqrts         = 1000"
     write (u_phs, "(A)")  "   m_threshold_s =   50"
     write (u_phs, "(A)")  "   m_threshold_t =  100"
     write (u_phs, "(A)")  "   off_shell = 2"
     write (u_phs, "(A)")  "   t_channel = 6"
     write (u_phs, "(A)")  "   keep_nonresonant = T"
     write (u_phs, "(A)")  "  grove #1"
     write (u_phs, "(A)")  "    tree 3"
   end subroutine write_test_phs_file
 
 @ %def write_test_phs_file
 @
 <<PHS wood: execute tests>>=
   call test (phs_wood_1, "phs_wood_1", &
        "phase-space configuration", &
        u, results)
 <<PHS wood: test declarations>>=
   public :: phs_wood_1
 <<PHS wood: tests>>=
   subroutine phs_wood_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable :: phs_data
     type(mapping_defaults_t) :: mapping_defaults
     real(default) :: sqrts
     integer :: u_phs, iostat
     character(32) :: buffer
 
     write (u, "(A)")  "* Test output: phs_wood_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &phase-space configuration data"
     write (u, "(A)")
 
     call model%init_test ()
 
     call syntax_phs_forest_init ()
 
     write (u, "(A)")  "* Initialize a process"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_wood_1"), process_data)
 
     write (u, "(A)")  "* Create a scratch phase-space file"
     write (u, "(A)")
 
     u_phs = free_unit ()
     open (u_phs, status = "scratch", action = "readwrite")
     call write_test_phs_file (u_phs, var_str ("phs_wood_1"))
     rewind (u_phs)
     do
        read (u_phs, "(A)", iostat = iostat)  buffer
        if (iostat /= 0)  exit
        write (u, "(A)") trim (buffer)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup phase-space configuration object"
     write (u, "(A)")
 
     mapping_defaults%step_mapping = .false.
 
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_input (u_phs)
        call phs_data%set_mapping_defaults (mapping_defaults)
     end select
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs_data%write (u)
     write (u, "(A)")
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%write_forest (u)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     close (u_phs)
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_wood_1"
 
   end subroutine phs_wood_1
 
 @ %def phs_wood_1
 @
 \subsubsection{Phase space evaluation}
 Compute kinematics for given parameters, also invert the calculation.
 <<PHS wood: execute tests>>=
   call test (phs_wood_2, "phs_wood_2", &
        "phase-space evaluation", &
        u, results)
 <<PHS wood: test declarations>>=
   public :: phs_wood_2
 <<PHS wood: tests>>=
   subroutine phs_wood_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(process_constants_t) :: process_data
     real(default) :: sqrts, E
     class(phs_config_t), allocatable, target :: phs_data
     class(phs_t), pointer :: phs => null ()
     type(vector4_t), dimension(2) :: p, q
     integer :: u_phs
 
     write (u, "(A)")  "* Test output: phs_wood_2"
     write (u, "(A)")  "*   Purpose: test simple single-channel phase space"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
 
     write (u, "(A)")  "* Initialize a process and a matching &
          &phase-space configuration"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_wood_2"), process_data)
     u_phs = free_unit ()
     open (u_phs, status = "scratch", action = "readwrite")
     call write_test_phs_file (u_phs, var_str ("phs_wood_2"))
     rewind (u_phs)
 
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_input (u_phs)
     end select
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs_data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%write (u, verbose=.true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming momenta"
     write (u, "(A)")
 
     E = sqrts / 2
     p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute phase-space point &
          &for x = 0.125, 0.5"
     write (u, "(A)")
 
     call phs%evaluate_selected_channel (1, [0.125_default, 0.5_default])
     call phs%evaluate_other_channels (1)
     call phs%write (u)
     write (u, "(A)")
     select type (phs)
     type is (phs_wood_t)
        call phs%write_forest (u)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     call phs%final ()
     deallocate (phs)
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call phs%write (u)
     write (u, "(A)")
     select type (phs)
     type is (phs_wood_t)
        call phs%write_forest (u)
     end select
 
     call phs%final ()
     deallocate (phs)
 
     close (u_phs)
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_wood_2"
 
   end subroutine phs_wood_2
 
 @ %def phs_wood_2
 @
 \subsubsection{Phase-space generation}
 Generate phase space for a simple process.
 <<PHS wood: execute tests>>=
   call test (phs_wood_3, "phs_wood_3", &
        "phase-space generation", &
        u, results)
 <<PHS wood: test declarations>>=
   public :: phs_wood_3
 <<PHS wood: tests>>=
   subroutine phs_wood_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     type(phs_parameters_t) :: phs_par
     class(phs_config_t), allocatable :: phs_data
     integer :: iostat
     character(80) :: buffer
 
     write (u, "(A)")  "* Test output: phs_wood_3"
     write (u, "(A)")  "*   Purpose: generate a phase-space configuration"
     write (u, "(A)")
 
     call model%init_test ()
 
     call syntax_phs_forest_init ()
 
     write (u, "(A)")  "* Initialize a process and phase-space parameters"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_wood_3"), process_data)
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     phs_par%sqrts = 1000
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
        phs_data%io_unit_keep_open = .true.
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate a scratch phase-space file"
     write (u, "(A)")
 
     call phs_data%configure (phs_par%sqrts)
 
     select type (phs_data)
     type is (phs_wood_config_t)
        rewind (phs_data%io_unit)
        do
           read (phs_data%io_unit, "(A)", iostat = iostat)  buffer
           if (iostat /= 0)  exit
           write (u, "(A)") trim (buffer)
        end do
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_wood_3"
 
   end subroutine phs_wood_3
 
 @ %def phs_wood_3
 @
 \subsubsection{Nontrivial process}
 Generate phase space for a $2\to 3$ process.
 <<PHS wood: execute tests>>=
   call test (phs_wood_4, "phs_wood_4", &
        "nontrivial process", &
        u, results)
 <<PHS wood: test declarations>>=
   public :: phs_wood_4
 <<PHS wood: tests>>=
   subroutine phs_wood_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     type(phs_parameters_t) :: phs_par
     class(phs_config_t), allocatable, target :: phs_data
     integer :: iostat
     character(80) :: buffer
     class(phs_t), pointer :: phs => null ()
     real(default) :: E, pL
     type(vector4_t), dimension(2) :: p
     type(vector4_t), dimension(3) :: q
 
     write (u, "(A)")  "* Test output: phs_wood_4"
     write (u, "(A)")  "*   Purpose: generate a phase-space configuration"
     write (u, "(A)")
 
     call model%init_test ()
 
     call syntax_phs_forest_init ()
 
     write (u, "(A)")  "* Initialize a process and phase-space parameters"
     write (u, "(A)")
 
     process_data%id = "phs_wood_4"
     process_data%model_name = "Test"
     process_data%n_in = 2
     process_data%n_out = 3
     process_data%n_flv = 1
     allocate (process_data%flv_state (process_data%n_in + process_data%n_out, &
          process_data%n_flv))
     process_data%flv_state(:,1) = [25, 25, 25, 6, -6]
 
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     phs_par%sqrts = 1000
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
        phs_data%io_unit_keep_open = .true.
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate a scratch phase-space file"
     write (u, "(A)")
 
     call phs_data%configure (phs_par%sqrts)
 
     select type (phs_data)
     type is (phs_wood_config_t)
        rewind (phs_data%io_unit)
        do
           read (phs_data%io_unit, "(A)", iostat = iostat)  buffer
           if (iostat /= 0)  exit
           write (u, "(A)") trim (buffer)
        end do
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize the phase-space instance"
     write (u, "(A)")
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     write (u, "(A)")  "* Set incoming momenta"
     write (u, "(A)")
 
     select type (phs_data)
     type is (phs_wood_config_t)
        E = phs_data%sqrts / 2
        pL = sqrt (E**2 - phs_data%flv(1,1)%get_mass ()**2)
     end select
     p(1) = vector4_moving (E, pL, 3)
     p(2) = vector4_moving (E, -pL, 3)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
 
     write (u, "(A)")  "* Compute phase-space point &
          &for x = 0.1, 0.2, 0.3, 0.4, 0.5"
     write (u, "(A)")
 
     call phs%evaluate_selected_channel (1, &
          [0.1_default, 0.2_default, 0.3_default, 0.4_default, 0.5_default])
     call phs%evaluate_other_channels (1)
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call phs%get_outgoing_momenta (q)
     call phs%final ()
     deallocate (phs)
 
     call phs_data%allocate_instance (phs)
     call phs%init (phs_data)
 
     call phs%set_incoming_momenta (p)
     call phs%compute_flux ()
     call phs%set_outgoing_momenta (q)
 
     call phs%inverse ()
     call phs%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call phs%final ()
     deallocate (phs)
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_wood_4"
 
   end subroutine phs_wood_4
 
 @ %def phs_wood_4
 @
 \subsubsection{Equivalences}
 Generate phase space for a simple process, including channel equivalences.
 <<PHS wood: execute tests>>=
   call test (phs_wood_5, "phs_wood_5", &
        "equivalences", &
        u, results)
 <<PHS wood: test declarations>>=
   public :: phs_wood_5
 <<PHS wood: tests>>=
   subroutine phs_wood_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     type(phs_parameters_t) :: phs_par
     class(phs_config_t), allocatable :: phs_data
 
     write (u, "(A)")  "* Test output: phs_wood_5"
     write (u, "(A)")  "*   Purpose: generate a phase-space configuration"
     write (u, "(A)")
 
     call model%init_test ()
 
     call syntax_phs_forest_init ()
 
     write (u, "(A)")  "* Initialize a process and phase-space parameters"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_wood_5"), process_data)
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     phs_par%sqrts = 1000
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
        call phs_data%enable_equivalences ()
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate a scratch phase-space file"
     write (u, "(A)")
 
     call phs_data%configure (phs_par%sqrts)
     call phs_data%write (u)
     write (u, "(A)")
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%write_forest (u)
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_wood_5"
 
   end subroutine phs_wood_5
 
 @ %def phs_wood_5
 @
 \subsubsection{MD5 sum checks}
 Generate phase space for a simple process.  Repeat this with and without
 parameter change.
 <<PHS wood: execute tests>>=
   call test (phs_wood_6, "phs_wood_6", &
        "phase-space generation", &
        u, results)
 <<PHS wood: test declarations>>=
   public :: phs_wood_6
 <<PHS wood: tests>>=
   subroutine phs_wood_6 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     type(phs_parameters_t) :: phs_par
     class(phs_config_t), allocatable :: phs_data
     logical :: exist, found, match
     integer :: u_phs
     character(*), parameter :: filename = "phs_wood_6_p.phs"
 
     write (u, "(A)")  "* Test output: phs_wood_6"
     write (u, "(A)")  "*   Purpose: generate and check  phase-space file"
     write (u, "(A)")
 
     call model%init_test ()
 
     call syntax_phs_forest_init ()
 
     write (u, "(A)")  "* Initialize a process and phase-space parameters"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_wood_6"), process_data)
     process_data%id = "phs_wood_6_p"
     process_data%md5sum = "1234567890abcdef1234567890abcdef"
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
 
     phs_par%sqrts = 1000
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
     end select
 
     write (u, "(A)")  "* Remove previous phs file, if any"
     write (u, "(A)")
 
     inquire (file = filename, exist = exist)
     if (exist) then
        u_phs = free_unit ()
        open (u_phs, file = filename, action = "write")
        close (u_phs, status = "delete")
     end if
 
     write (u, "(A)")  "* Check phase-space file (should fail)"
     write (u, "(A)")
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%read_phs_file (exist, found, match)
        write (u, "(1x,A,L1)")  "exist = ", exist
        write (u, "(1x,A,L1)")  "found = ", found
        write (u, "(1x,A,L1)")  "match = ", match
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate a phase-space file"
     write (u, "(A)")
 
     call phs_data%configure (phs_par%sqrts)
 
     write (u, "(1x,A,A,A)")  "MD5 sum (process)    = '", &
          phs_data%md5sum_process, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (model par)  = '", &
          phs_data%md5sum_model_par, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (phs config) = '", &
          phs_data%md5sum_phs_config, "'"
 
     write (u, "(A)")
     write (u, "(A)")  "* Check MD5 sum"
     write (u, "(A)")
 
     call phs_data%final ()
     deallocate (phs_data)
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
     phs_par%sqrts = 1000
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
        phs_data%sqrts = phs_par%sqrts
        phs_data%par%sqrts = phs_par%sqrts
     end select
     call phs_data%compute_md5sum ()
 
     write (u, "(1x,A,A,A)")  "MD5 sum (process)    = '", &
          phs_data%md5sum_process, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (model par)  = '", &
          phs_data%md5sum_model_par, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (phs config) = '", &
          phs_data%md5sum_phs_config, "'"
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%read_phs_file (exist, found, match)
        write (u, "(1x,A,L1)")  "exist = ", exist
        write (u, "(1x,A,L1)")  "found = ", found
        write (u, "(1x,A,L1)")  "match = ", match
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Modify sqrts and check MD5 sum"
     write (u, "(A)")
 
     call phs_data%final ()
     deallocate (phs_data)
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
     phs_par%sqrts = 500
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
        phs_data%sqrts = phs_par%sqrts
        phs_data%par%sqrts = phs_par%sqrts
     end select
     call phs_data%compute_md5sum ()
 
     write (u, "(1x,A,A,A)")  "MD5 sum (process)    = '", &
          phs_data%md5sum_process, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (model par)  = '", &
          phs_data%md5sum_model_par, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (phs config) = '", &
          phs_data%md5sum_phs_config, "'"
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%read_phs_file (exist, found, match)
        write (u, "(1x,A,L1)")  "exist = ", exist
        write (u, "(1x,A,L1)")  "found = ", found
        write (u, "(1x,A,L1)")  "match = ", match
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Modify process and check MD5 sum"
     write (u, "(A)")
 
     call phs_data%final ()
     deallocate (phs_data)
     process_data%md5sum = "77777777777777777777777777777777"
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
     phs_par%sqrts = 1000
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
        phs_data%sqrts = phs_par%sqrts
        phs_data%par%sqrts = phs_par%sqrts
     end select
     call phs_data%compute_md5sum ()
 
     write (u, "(1x,A,A,A)")  "MD5 sum (process)    = '", &
          phs_data%md5sum_process, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (model par)  = '", &
          phs_data%md5sum_model_par, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (phs config) = '", &
          phs_data%md5sum_phs_config, "'"
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%read_phs_file (exist, found, match)
        write (u, "(1x,A,L1)")  "exist = ", exist
        write (u, "(1x,A,L1)")  "found = ", found
        write (u, "(1x,A,L1)")  "match = ", match
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Modify phs parameter and check MD5 sum"
     write (u, "(A)")
 
     call phs_data%final ()
     deallocate (phs_data)
     allocate (phs_wood_config_t :: phs_data)
     process_data%md5sum = "1234567890abcdef1234567890abcdef"
     call phs_data%init (process_data, model)
     phs_par%sqrts = 1000
     phs_par%off_shell = 17
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
        phs_data%sqrts = phs_par%sqrts
        phs_data%par%sqrts = phs_par%sqrts
     end select
     call phs_data%compute_md5sum ()
 
     write (u, "(1x,A,A,A)")  "MD5 sum (process)    = '", &
          phs_data%md5sum_process, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (model par)  = '", &
          phs_data%md5sum_model_par, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (phs config) = '", &
          phs_data%md5sum_phs_config, "'"
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%read_phs_file (exist, found, match)
        write (u, "(1x,A,L1)")  "exist = ", exist
        write (u, "(1x,A,L1)")  "found = ", found
        write (u, "(1x,A,L1)")  "match = ", match
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Modify model parameter and check MD5 sum"
     write (u, "(A)")
 
     call phs_data%final ()
     deallocate (phs_data)
     allocate (phs_wood_config_t :: phs_data)
     call model%set_par (var_str ("ms"), 100._default)
     call phs_data%init (process_data, model)
     phs_par%sqrts = 1000
     phs_par%off_shell = 1
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_parameters (phs_par)
        phs_data%sqrts = phs_par%sqrts
        phs_data%par%sqrts = phs_par%sqrts
     end select
     call phs_data%compute_md5sum ()
 
     write (u, "(1x,A,A,A)")  "MD5 sum (process)    = '", &
          phs_data%md5sum_process, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (model par)  = '", &
          phs_data%md5sum_model_par, "'"
     write (u, "(1x,A,A,A)")  "MD5 sum (phs config) = '", &
          phs_data%md5sum_phs_config, "'"
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%read_phs_file (exist, found, match)
        write (u, "(1x,A,L1)")  "exist = ", exist
        write (u, "(1x,A,L1)")  "found = ", found
        write (u, "(1x,A,L1)")  "match = ", match
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_wood_6"
 
   end subroutine phs_wood_6
 
 @ %def phs_wood_6
 @
 <<PHS wood: execute vis tests>>=
   call test (phs_wood_vis_1, "phs_wood_vis_1", &
        "visualizing phase space channels", &
        u, results)
 <<PHS wood: test declarations>>=
   public :: phs_wood_vis_1
 <<PHS wood: tests>>=
   subroutine phs_wood_vis_1 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(process_constants_t) :: process_data
     class(phs_config_t), allocatable :: phs_data
     type(mapping_defaults_t) :: mapping_defaults
     type(string_t) :: vis_file, pdf_file, ps_file
     real(default) :: sqrts
     logical :: exist, exist_pdf, exist_ps
     integer :: u_phs, iostat, u_vis
     character(95) :: buffer
 
     write (u, "(A)")  "* Test output: phs_wood_vis_1"
     write (u, "(A)")  "*   Purpose: visualizing the &
          &phase-space configuration"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_test ()
 
     call syntax_phs_forest_init ()
 
     write (u, "(A)")  "* Initialize a process"
     write (u, "(A)")
 
     call init_test_process_data (var_str ("phs_wood_vis_1"), process_data)
 
     write (u, "(A)")  "* Create a scratch phase-space file"
     write (u, "(A)")
 
     u_phs = free_unit ()
     open (u_phs, status = "scratch", action = "readwrite")
     call write_test_phs_file (u_phs, var_str ("phs_wood_vis_1"))
     rewind (u_phs)
     do
        read (u_phs, "(A)", iostat = iostat)  buffer
        if (iostat /= 0)  exit
        write (u, "(A)") trim (buffer)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Setup phase-space configuration object"
     write (u, "(A)")
 
     mapping_defaults%step_mapping = .false.
 
     allocate (phs_wood_config_t :: phs_data)
     call phs_data%init (process_data, model)
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%set_input (u_phs)
        call phs_data%set_mapping_defaults (mapping_defaults)
        phs_data%os_data = os_data
        phs_data%io_unit = 0
        phs_data%io_unit_keep_open = .true.
        phs_data%vis_channels = .true.
     end select
 
     sqrts = 1000._default
     call phs_data%configure (sqrts)
 
     call phs_data%write (u)
     write (u, "(A)")
 
     select type (phs_data)
     type is (phs_wood_config_t)
        call phs_data%write_forest (u)
     end select
 
     vis_file = "phs_wood_vis_1.phs-vis.tex"
     ps_file  = "phs_wood_vis_1.phs-vis.ps"
     pdf_file = "phs_wood_vis_1.phs-vis.pdf"
     inquire (file = char (vis_file), exist = exist)
     if (exist) then
        u_vis = free_unit ()
        open (u_vis, file = char (vis_file), action = "read", status = "old")
        iostat = 0
        do while (iostat == 0)
           read (u_vis, "(A)", iostat = iostat)  buffer
           if (iostat == 0)  write (u, "(A)")  trim (buffer)
        end do
        close (u_vis)
     else
        write (u, "(A)")  "[Visualize LaTeX file is missing]"
     end if
     inquire (file = char (ps_file), exist = exist_ps)
     if (exist_ps) then
        write (u, "(A)")  "[Visualize Postscript file exists and is nonempty]"
     else
        write (u, "(A)")  "[Visualize Postscript file is missing/non-regular]"
     end if
     inquire (file = char (pdf_file), exist = exist_pdf)
     if (exist_pdf) then
        write (u, "(A)")  "[Visualize PDF file exists and is nonempty]"
     else
        write (u, "(A)")  "[Visualize PDF file is missing/non-regular]"
     end if
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     close (u_phs)
     call phs_data%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: phs_wood_vis_1"
 
   end subroutine phs_wood_vis_1
 
 @ %def phs_wood_vis_1
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{The FKS phase space}
 <<[[phs_fks.f90]]>>=
 <<File header>>
 
 module phs_fks
 
 <<Use kinds>>
 <<Use strings>>
 <<Use debug>>
   use constants
   use diagnostics
   use io_units, only: given_output_unit, free_unit
   use format_utils, only: write_separator
   use lorentz
   use physics_defs
   use flavors
   use pdg_arrays, only: is_colored
   use models, only: model_t
   use sf_mappings
   use sf_base
   use phs_base
   use resonances, only: resonance_contributors_t, resonance_history_t
   use phs_forests, only: phs_forest_final
   use phs_wood
   use cascades
   use cascades2
   use process_constants
   use process_libraries
   use ttv_formfactors, only: generate_on_shell_decay_threshold, m1s_to_mpole
   use format_defs, only: FMT_17
 
 <<Standard module head>>
 
 <<phs fks: public>>
 
 <<phs fks: parameters>>
 
 <<phs fks: types>>
 
 <<phs fks: interfaces>>
 
 contains
 
 <<phs fks: procedures>>
 
 end module phs_fks
 
 @ %def phs_fks
 @
 @ A container for the $x_\oplus$- and $x_\ominus$-values for initial-state
 phase spaces.
 <<phs fks: public>>=
   public :: isr_kinematics_t
 <<phs fks: types>>=
   type :: isr_kinematics_t
     integer :: n_in
     real(default), dimension(2) :: x = one
     real(default), dimension(2) :: z = zero
     real(default), dimension(2) :: z_coll = zero
     real(default) :: sqrts_born = zero
     real(default) :: beam_energy = zero
     real(default) :: fac_scale = zero
     real(default), dimension(2) :: jacobian = one
     integer :: isr_mode = SQRTS_FIXED
   end type isr_kinematics_t
 
 @ %def type isr_kinematics_t
 @
 <<phs fks: public>>=
   public :: phs_point_set_t
 <<phs fks: types>>=
   type :: phs_point_set_t
      type(phs_point_t), dimension(:), allocatable :: phs_point
      logical :: initialized = .false.
   contains
   <<phs fks: phs point set: TBP>>
   end type phs_point_set_t
 
 @ %def phs_point_set_t
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: init => phs_point_set_init
 <<phs fks: procedures>>=
   subroutine phs_point_set_init (phs_point_set, n_particles, n_phs)
     class(phs_point_set_t), intent(out) :: phs_point_set
     integer, intent(in) :: n_particles, n_phs
     integer :: i_phs
     allocate (phs_point_set%phs_point (n_phs))
     do i_phs = 1, n_phs
        phs_point_set%phs_point(i_phs) = n_particles
     end do
     phs_point_set%initialized = .true.
   end subroutine phs_point_set_init
 
 @ %def phs_point_set_init
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: write => phs_point_set_write
 <<phs fks: procedures>>=
   subroutine phs_point_set_write (phs_point_set, i_phs, contributors, unit, show_mass, &
          testflag, check_conservation, ultra, n_in)
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in), optional :: i_phs
     integer, intent(in), dimension(:), optional :: contributors
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_mass
     logical, intent(in), optional :: testflag, ultra
     logical, intent(in), optional :: check_conservation
     integer, intent(in), optional :: n_in
     integer :: i, u
     type(vector4_t) :: p_sum
     u = given_output_unit (unit); if (u < 0) return
     if (present (i_phs)) then
        call phs_point_set%phs_point(i_phs)%write &
             (unit = u, show_mass = show_mass, testflag = testflag, &
             check_conservation = check_conservation, ultra = ultra, n_in = n_in)
     else
        do i = 1, size(phs_point_set%phs_point)
           call phs_point_set%phs_point(i)%write &
                (unit = u, show_mass = show_mass, testflag = testflag, &
                check_conservation = check_conservation, ultra = ultra, n_in = n_in)
        end do
     end if
     if (present (contributors)) then
        p_sum = vector4_null
        if (debug_on) call msg_debug (D_SUBTRACTION, "Invariant masses for real emission: ")
        associate (p => phs_point_set%phs_point(i_phs)%p)
           do i = 1, size (contributors)
              p_sum = p_sum + p(contributors(i))
           end do
           p_sum = p_sum + p(size(p))
        end associate
        if (debug_active (D_SUBTRACTION)) &
             call vector4_write (p_sum, unit = unit, show_mass = show_mass, &
                  testflag = testflag, ultra = ultra)
     end if
   end subroutine phs_point_set_write
 
 @ %def phs_point_set_write
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: get_n_momenta => phs_point_set_get_n_momenta
 <<phs fks: procedures>>=
   elemental function phs_point_set_get_n_momenta (phs_point_set, i_res) result (n)
     integer :: n
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in) :: i_res
     n = phs_point_set%phs_point(i_res)%n_momenta
   end function phs_point_set_get_n_momenta
 
 @ %def phs_point_set_get_n_momenta
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: get_momenta => phs_point_set_get_momenta
 <<phs fks: procedures>>=
   pure function phs_point_set_get_momenta (phs_point_set, i_phs, n_in) result (p)
     type(vector4_t), dimension(:), allocatable :: p
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in) :: i_phs
     integer, intent(in), optional :: n_in
     if (present (n_in)) then
        allocate (p (n_in), source = phs_point_set%phs_point(i_phs)%p(1:n_in))
     else
        allocate (p (phs_point_set%phs_point(i_phs)%n_momenta), &
             source = phs_point_set%phs_point(i_phs)%p)
     end if
   end function phs_point_set_get_momenta
 
 @ %def phs_point_set_get_momenta
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: get_momentum => phs_point_set_get_momentum
 <<phs fks: procedures>>=
   pure function phs_point_set_get_momentum (phs_point_set, i_phs, i_mom) result (p)
     type(vector4_t) :: p
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in) :: i_phs, i_mom
     p = phs_point_set%phs_point(i_phs)%p(i_mom)
   end function phs_point_set_get_momentum
 
 @ %def phs_point_set_get_momentum
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: get_energy => phs_point_set_get_energy
 <<phs fks: procedures>>=
   pure function phs_point_set_get_energy (phs_point_set, i_phs, i_mom) result (E)
     real(default) :: E
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in) :: i_phs, i_mom
     E = phs_point_set%phs_point(i_phs)%p(i_mom)%p(0)
   end function phs_point_set_get_energy
 
 @ %def phs_point_set_get_energy
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: get_sqrts => phs_point_set_get_sqrts
 <<phs fks: procedures>>=
   function phs_point_set_get_sqrts (phs_point_set, i_phs) result (sqrts)
     real(default) :: sqrts
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in) :: i_phs
     associate (p => phs_point_set%phs_point(i_phs)%p)
        sqrts = (p(1) + p(2))**1
     end associate
   end function phs_point_set_get_sqrts
 
 @ %def phs_point_set_get_sqrts
 @
 <<phs fks: phs point set: TBP>>=
   generic :: set_momenta => set_momenta_p, set_momenta_phs_point
   procedure :: set_momenta_p => phs_point_set_set_momenta_p
 <<phs fks: procedures>>=
   subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p)
     class(phs_point_set_t), intent(inout) :: phs_point_set
     integer, intent(in) :: i_phs
     type(vector4_t), intent(in), dimension(:) :: p
     phs_point_set%phs_point(i_phs)%p = p
   end subroutine phs_point_set_set_momenta_p
 
 @ %def phs_point_set_set_momenta_p
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: set_momenta_phs_point => phs_point_set_set_momenta_phs_point
 <<phs fks: procedures>>=
   subroutine phs_point_set_set_momenta_phs_point (phs_point_set, i_phs, p)
     class(phs_point_set_t), intent(inout) :: phs_point_set
     integer, intent(in) :: i_phs
     type(phs_point_t), intent(in) :: p
     phs_point_set%phs_point(i_phs) = p
   end subroutine phs_point_set_set_momenta_phs_point
 
 @ %def phs_point_set_set_momenta_phs_point
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: get_n_particles => phs_point_set_get_n_particles
 <<phs fks: procedures>>=
   function phs_point_set_get_n_particles (phs_point_set, i) result (n_particles)
     integer :: n_particles
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in), optional :: i
     integer :: j
     j = 1; if (present (i)) j = i
     n_particles = size (phs_point_set%phs_point(j)%p)
   end function phs_point_set_get_n_particles
 
 @ %def phs_point_set_get_n_particles
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: get_n_phs => phs_point_set_get_n_phs
 <<phs fks: procedures>>=
   function phs_point_set_get_n_phs (phs_point_set) result (n_phs)
     integer :: n_phs
     class(phs_point_set_t), intent(in) :: phs_point_set
     n_phs = size (phs_point_set%phs_point)
   end function phs_point_set_get_n_phs
 
 @ %def phs_point_set_get_n_phs
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: get_invariant_mass => phs_point_set_get_invariant_mass
 <<phs fks: procedures>>=
   function phs_point_set_get_invariant_mass (phs_point_set, i_phs, i_part) result (m2)
     real(default) :: m2
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in) :: i_phs
     integer, intent(in), dimension(:) :: i_part
     type(vector4_t) :: p
     integer :: i
     p = vector4_null
     do i = 1, size (i_part)
        p = p + phs_point_set%phs_point(i_phs)%p(i_part(i))
     end do
     m2 = p**2
   end function phs_point_set_get_invariant_mass
 
 @ %def phs_point_set_get_invariant_mass
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: write_phs_point => phs_point_set_write_phs_point
 <<phs fks: procedures>>=
   subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, unit, show_mass, &
      testflag, check_conservation, ultra, n_in)
     class(phs_point_set_t), intent(in) :: phs_point_set
     integer, intent(in) :: i_phs
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: show_mass
     logical, intent(in), optional :: testflag, ultra
     logical, intent(in), optional :: check_conservation
     integer, intent(in), optional :: n_in
     call phs_point_set%phs_point(i_phs)%write (unit, show_mass, testflag, &
        check_conservation, ultra, n_in)
   end subroutine phs_point_set_write_phs_point
 
 @ %def phs_point_set_write_phs_point
 @
 <<phs fks: phs point set: TBP>>=
   procedure :: final => phs_point_set_final
 <<phs fks: procedures>>=
   subroutine phs_point_set_final (phs_point_set)
     class(phs_point_set_t), intent(inout) :: phs_point_set
     integer :: i
     do i = 1, size (phs_point_set%phs_point)
        call phs_point_set%phs_point(i)%final ()
     end do
     deallocate (phs_point_set%phs_point)
     phs_point_set%initialized = .false.
   end subroutine phs_point_set_final
 
 @ %def phs_point_set_final
 @
 <<phs fks: public>>=
   public :: real_jacobian_t
 <<phs fks: types>>=
   type :: real_jacobian_t
     real(default), dimension(4) :: jac = 1._default
   end type real_jacobian_t
 
 @ %def real_jacobian_t
 @
 <<phs fks: public>>=
   public :: real_kinematics_t
 <<phs fks: types>>=
   type :: real_kinematics_t
     logical :: supply_xi_max = .true.
     real(default) :: xi_tilde
     real(default) :: phi
     real(default), dimension(:), allocatable :: xi_max, y
     real(default) :: xi_mismatch, y_mismatch
     type(real_jacobian_t), dimension(:), allocatable :: jac
     real(default) :: jac_mismatch
     type(phs_point_set_t) :: p_born_cms
     type(phs_point_set_t) :: p_born_lab
     type(phs_point_set_t) :: p_real_cms
     type(phs_point_set_t) :: p_real_lab
     type(phs_point_set_t) :: p_born_onshell
     type(phs_point_set_t), dimension(2) :: p_real_onshell
     integer, dimension(:), allocatable :: alr_to_i_phs
     real(default), dimension(3) :: x_rad
     real(default), dimension(:), allocatable :: jac_rand
     real(default), dimension(:), allocatable :: y_soft
     real(default) :: cms_energy2
     type(vector4_t), dimension(:), allocatable :: xi_ref_momenta
   contains
   <<phs fks: real kinematics: TBP>>
   end type real_kinematics_t
 
 @ %def real_kinematics_t
 @
 <<phs fks: real kinematics: TBP>>=
   procedure :: init => real_kinematics_init
 <<phs fks: procedures>>=
   subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr)
     class(real_kinematics_t), intent(inout) :: r
     integer, intent(in) :: n_tot, n_phs, n_alr, n_contr
     allocate (r%xi_max (n_phs))
     allocate (r%y (n_phs))
     allocate (r%y_soft (n_phs))
     call r%p_born_cms%init (n_tot - 1, 1)
     call r%p_born_lab%init (n_tot - 1, 1)
     call r%p_real_cms%init (n_tot, n_phs)
     call r%p_real_lab%init (n_tot, n_phs)
     allocate (r%jac (n_phs), r%jac_rand (n_phs))
     allocate (r%alr_to_i_phs (n_alr))
     allocate (r%xi_ref_momenta (n_contr))
     r%alr_to_i_phs = 0
     r%xi_tilde = zero; r%xi_mismatch = zero
     r%xi_max = zero
     r%y = zero; r%y_mismatch = zero
     r%y_soft = zero
     r%phi = zero
     r%cms_energy2 = zero
     r%xi_ref_momenta = vector4_null
     r%jac_mismatch = one
     r%jac_rand = one
   end subroutine real_kinematics_init
 
 @ %def real_kinematics_init
 @
 <<phs fks: real kinematics: TBP>>=
   procedure :: init_onshell => real_kinematics_init_onshell
 <<phs fks: procedures>>=
   subroutine real_kinematics_init_onshell (r, n_tot, n_phs)
     class(real_kinematics_t), intent(inout) :: r
     integer, intent(in) :: n_tot, n_phs
     call r%p_born_onshell%init (n_tot - 1, 1)
     call r%p_real_onshell(1)%init (n_tot, n_phs)
     call r%p_real_onshell(2)%init (n_tot, n_phs)
   end subroutine real_kinematics_init_onshell
 
 @ %def real_kinematics_init_onshell
 @
 <<phs fks: real kinematics: TBP>>=
   procedure :: write => real_kinematics_write
 <<phs fks: procedures>>=
   subroutine real_kinematics_write (r, unit)
     class(real_kinematics_t), intent(in) :: r
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit); if (u < 0) return
     write (u,"(A)") "Real kinematics: "
     write (u,"(A," // FMT_17 // ",1X)") "xi_tilde: ", r%xi_tilde
     write (u,"(A," // FMT_17 // ",1X)") "phi: ", r%phi
     do i = 1, size (r%xi_max)
        write (u,"(A,I1,1X)") "i_phs: ", i
        write (u,"(A," // FMT_17 // ",1X)") "xi_max: ", r%xi_max(i)
        write (u,"(A," // FMT_17 // ",1X)") "y: ", r%y(i)
        write (u,"(A," // FMT_17 // ",1X)") "jac_rand: ", r%jac_rand(i)
        write (u,"(A," // FMT_17 // ",1X)") "y_soft: ", r%y_soft(i)
     end do
     write (u, "(A)") "Born Momenta: "
     write (u, "(A)") "CMS: "
     call r%p_born_cms%write (unit = u)
     write (u, "(A)") "Lab: "
     call r%p_born_lab%write (unit = u)
     write (u, "(A)") "Real Momenta: "
     write (u, "(A)") "CMS: "
     call r%p_real_cms%write (unit = u)
     write (u, "(A)") "Lab: "
     call r%p_real_lab%write (unit = u)
   end subroutine real_kinematics_write
 
 @ %def real_kinematics_write
 @ The boost to the center-of-mass system only has a reasonable meaning
 above the threshold. Below the threshold, we do not apply boost at all, so
 that the top quarks stay in the rest frame. However, with top quarks exactly
 at rest, problems arise in the matrix elements (e.g. in the computation
 of angles). Therefore, we apply a boost which is not exactly 1, but has a
 tiny value differing from that.
 <<phs fks: public>>=
   public :: get_boost_for_threshold_projection
 <<phs fks: procedures>>=
   function get_boost_for_threshold_projection (p, sqrts, mtop) result (L)
     type(lorentz_transformation_t) :: L
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(in) :: sqrts, mtop
     type(vector4_t) :: p_tmp
     type(vector3_t) :: dir
     real(default) :: scale_factor, arg
     p_tmp = p(THR_POS_WP) + p(THR_POS_B)
     arg = sqrts**2 - four * mtop**2
     if (arg > zero) then
        scale_factor = sqrt (arg) / two
     else
        scale_factor = tiny_07*1000
     end if
     dir = scale_factor * create_unit_vector (p_tmp)
     p_tmp = [sqrts / two, dir%p]
     L = boost (p_tmp, mtop)
   end function get_boost_for_threshold_projection
 
 @ %def get_boost_for_threshold_projection
 @ This routine recomputes the value of $\phi$ used to generate the real phase space.
 <<phs fks: procedures>>=
   function get_generation_phi (p_born, p_real, emitter, i_gluon) result (phi)
     real(default) :: phi
     type(vector4_t), intent(in), dimension(:) :: p_born, p_real
     integer, intent(in) :: emitter, i_gluon
     type(vector4_t) :: p1, p2, pp
     type(lorentz_transformation_t) :: rot_to_gluon, rot_to_z
     type(vector3_t) :: dir, z
     real(default) :: cpsi
     pp = p_real(emitter) + p_real(i_gluon)
     cpsi = (space_part_norm (pp)**2 - space_part_norm (p_real(emitter))**2 &
            + space_part_norm (p_real(i_gluon))**2) / &
            (two * space_part_norm (pp) * space_part_norm (p_real(i_gluon)))
     dir = create_orthogonal (space_part (p_born(emitter)))
     rot_to_gluon = rotation (cpsi, sqrt (one - cpsi**2), dir)
     pp = rot_to_gluon * p_born(emitter)
     z%p = [0, 0, 1]
     rot_to_z = rotation_to_2nd &
          (space_part (p_born(emitter)) / space_part_norm (p_born(emitter)), z)
     p1 = rot_to_z * pp / space_part_norm (pp)
     p2 = rot_to_z * p_real(i_gluon)
     phi = azimuthal_distance (p1, p2)
     if (phi < zero) phi = twopi - abs(phi)
   end function get_generation_phi
 
 @ %def get_generation_phi
 @
 <<phs fks: real kinematics: TBP>>=
   procedure :: apply_threshold_projection_real => real_kinematics_apply_threshold_projection_real
 <<phs fks: procedures>>=
   subroutine real_kinematics_apply_threshold_projection_real (r, i_phs, mtop, L_to_cms, invert)
     class(real_kinematics_t), intent(inout) :: r
     integer, intent(in) :: i_phs
     real(default), intent(in) :: mtop
     type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms
     logical, intent(in) :: invert
     integer :: leg, other_leg
     type(vector4_t), dimension(4) :: k_tmp
     type(vector4_t), dimension(4) :: k_decay_onshell_real
     type(vector4_t), dimension(3) :: k_decay_onshell_born
     do leg = 1, 2
        other_leg = 3 - leg
        associate (p_real => r%p_real_cms%phs_point(i_phs)%p, &
             p_real_onshell => r%p_real_onshell(leg)%phs_point(i_phs)%p)
           p_real_onshell(1:2) = p_real(1:2)
           k_tmp(1) = p_real(7)
           k_tmp(2) = p_real(ass_quark(leg))
           k_tmp(3) = p_real(ass_boson(leg))
           k_tmp(4) = [mtop, zero, zero, zero]
           call generate_on_shell_decay_threshold (k_tmp(1:3), &
                k_tmp(4), k_decay_onshell_real (2:4))
           k_decay_onshell_real (1) = k_tmp(4)
           k_tmp(1) = p_real(ass_quark(other_leg))
           k_tmp(2) = p_real(ass_boson(other_leg))
           k_decay_onshell_born = create_two_particle_decay (mtop**2, k_tmp(1), k_tmp(2))
           p_real_onshell(THR_POS_GLUON) = L_to_cms(leg) * k_decay_onshell_real (2)
           p_real_onshell(ass_quark(leg)) = L_to_cms(leg) * k_decay_onshell_real(3)
           p_real_onshell(ass_boson(leg)) = L_to_cms(leg) * k_decay_onshell_real(4)
           p_real_onshell(ass_quark(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (2)
           p_real_onshell(ass_boson(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (3)
           if (invert) then
              call vector4_invert_direction (p_real_onshell (ass_quark(other_leg)))
              call vector4_invert_direction (p_real_onshell (ass_boson(other_leg)))
           end if
        end associate
     end do
   end subroutine real_kinematics_apply_threshold_projection_real
 
 @ %def real_kinematics_apply_threshold_projection_real
 @
 <<phs fks: public>>=
   public :: threshold_projection_born
 <<phs fks: procedures>>=
   subroutine threshold_projection_born (mtop, L_to_cms, p_in, p_onshell)
     real(default), intent(in) :: mtop
     type(lorentz_transformation_t), intent(in) :: L_to_cms
     type(vector4_t), intent(in), dimension(:) :: p_in
     type(vector4_t), intent(out), dimension(:) :: p_onshell
     type(vector4_t), dimension(3) :: k_decay_onshell
     type(vector4_t) :: p_tmp_1, p_tmp_2
     type(lorentz_transformation_t) :: L_to_cms_inv
     p_onshell(1:2) = p_in(1:2)
     L_to_cms_inv = inverse (L_to_cms)
     p_tmp_1 = L_to_cms_inv * p_in(THR_POS_B)
     p_tmp_2 = L_to_cms_inv * p_in(THR_POS_WP)
     k_decay_onshell = create_two_particle_decay (mtop**2, &
          p_tmp_1, p_tmp_2)
     p_onshell([THR_POS_B, THR_POS_WP]) = k_decay_onshell([2, 3])
     p_tmp_1 = L_to_cms * p_in(THR_POS_BBAR)
     p_tmp_2 = L_to_cms * p_in(THR_POS_WM)
     k_decay_onshell = create_two_particle_decay (mtop**2, &
          p_tmp_1, p_tmp_2)
     p_onshell([THR_POS_BBAR, THR_POS_WM]) = k_decay_onshell([2, 3])
     p_onshell([THR_POS_WP, THR_POS_B]) = L_to_cms * p_onshell([THR_POS_WP, THR_POS_B])
     p_onshell([THR_POS_WM, THR_POS_BBAR]) = L_to_cms_inv * p_onshell([THR_POS_WM, THR_POS_BBAR])
   end subroutine threshold_projection_born
 
 @ %def threshold_projection_born
 @ This routine computes the bounds of the Dalitz region for massive emitters, see below.
 It is also used by [[Powheg]], so the routine is public.
 The input parameter [[m2]] corresponds to the squared mass of the emitter.
 <<phs fks: public>>=
   public :: compute_dalitz_bounds
 <<phs fks: procedures>>=
   pure subroutine compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max)
     real(default), intent(in) :: q0, m2, mrec2
     real(default), intent(out) :: z1, z2, k0_rec_max
     k0_rec_max = (q0**2 - m2 + mrec2) / (two * q0)
     z1 = (k0_rec_max + sqrt(k0_rec_max**2 - mrec2)) / q0
     z2 = (k0_rec_max - sqrt(k0_rec_max**2 - mrec2)) / q0
   end subroutine compute_dalitz_bounds
 
 @ %def compute_dalitz_bounds
 @ Compute the [[kt2]] of a given emitter
 <<phs fks: real kinematics: TBP>>=
   procedure :: kt2 => real_kinematics_kt2
 <<phs fks: procedures>>=
   function real_kinematics_kt2 &
      (real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2)
     real(default) :: kt2
     class(real_kinematics_t), intent(in) :: real_kinematics
     integer, intent(in) :: emitter, i_phs, kt2_type
     real(default), intent(in), optional :: xi, y
     real(default) :: xii, yy
     real(default) :: q, E_em, z, z1, z2, m2, mrec2, k0_rec_max
     type(vector4_t) :: p_emitter
     if (present (y)) then
        yy = y
     else
        yy = real_kinematics%y (i_phs)
     end if
     if (present (xi)) then
        xii = xi
     else
        xii = real_kinematics%xi_tilde * real_kinematics%xi_max (i_phs)
     end if
     select case (kt2_type)
     case (FSR_SIMPLE)
        kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy)
     case (FSR_MASSIVE)
        q = sqrt (real_kinematics%cms_energy2)
        p_emitter = real_kinematics%p_born_cms%phs_point(1)%p(emitter)
        mrec2 = (q - p_emitter%p(0))**2 - sum (p_emitter%p(1:3)**2)
        m2 = p_emitter**2
        E_em = energy (p_emitter)
        call compute_dalitz_bounds (q, m2, mrec2, z1, z2, k0_rec_max)
        z = z2 - (z2 - z1) * (one + yy) / two
        kt2 = xii**2 * q**3 * (one - z) / &
           (two * E_em - z * xii * q)
     case (FSR_MASSLESS_RECOILER)
        kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy**2) / two
     case default
        kt2 = zero
        call msg_bug ("kt2_type must be set to a known value")
     end select
   end function real_kinematics_kt2
 
 @ %def real_kinematics_kt2
 @
 <<phs fks: parameters>>=
   integer, parameter, public :: FSR_SIMPLE = 1
   integer, parameter, public :: FSR_MASSIVE = 2
   integer, parameter, public :: FSR_MASSLESS_RECOILER = 3
 @ %def FSR_SIMPLE FSR_MASSIVE FSR_MASSLESS_RECOILER
 @
 <<phs fks: real kinematics: TBP>>=
   procedure :: final => real_kinematics_final
 <<phs fks: procedures>>=
   subroutine real_kinematics_final (real_kin)
     class(real_kinematics_t), intent(inout) :: real_kin
     if (allocated (real_kin%xi_max)) deallocate (real_kin%xi_max)
     if (allocated (real_kin%y)) deallocate (real_kin%y)
     if (allocated (real_kin%alr_to_i_phs)) deallocate (real_kin%alr_to_i_phs)
     if (allocated (real_kin%jac_rand)) deallocate (real_kin%jac_rand)
     if (allocated (real_kin%y_soft)) deallocate (real_kin%y_soft)
     if (allocated (real_kin%xi_ref_momenta)) deallocate (real_kin%xi_ref_momenta)
     call real_kin%p_born_cms%final (); call real_kin%p_born_lab%final ()
     call real_kin%p_real_cms%final (); call real_kin%p_real_lab%final ()
   end subroutine real_kinematics_final
 
 @ %def real_kinematics_final
 @
 <<phs fks: parameters>>=
   integer, parameter, public :: I_XI = 1
   integer, parameter, public :: I_Y = 2
   integer, parameter, public :: I_PHI = 3
 
   integer, parameter, public :: PHS_MODE_UNDEFINED = 0
   integer, parameter, public :: PHS_MODE_ADDITIONAL_PARTICLE = 1
   integer, parameter, public :: PHS_MODE_COLLINEAR_REMNANT = 2
 
 @ %def parameters
 @
 <<phs fks: public>>=
   public :: phs_fks_config_t
 <<phs fks: types>>=
   type, extends (phs_wood_config_t) :: phs_fks_config_t
     integer :: mode = PHS_MODE_UNDEFINED
     character(32) :: md5sum_born_config
     logical :: make_dalitz_plot = .false.
   contains
   <<phs fks: fks config: TBP>>
   end type phs_fks_config_t
 
 @ %def phs_fks_config_t
 @
 <<phs fks: fks config: TBP>>=
   procedure :: clear_phase_space => fks_config_clear_phase_space
 <<phs fks: procedures>>=
   subroutine fks_config_clear_phase_space (phs_config)
     class(phs_fks_config_t), intent(inout) :: phs_config
   end subroutine fks_config_clear_phase_space
 
 @ %def fks_config_clear_phase_space
 @
 <<phs fks: fks config: TBP>>=
   procedure :: write => phs_fks_config_write
 <<phs fks: procedures>>=
   subroutine phs_fks_config_write (object, unit, include_id)
     class(phs_fks_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: include_id
     integer :: u
     u = given_output_unit (unit)
     call object%phs_wood_config_t%write (u)
     write (u, "(A,A)") "Extra Born md5sum: ", object%md5sum_born_config
   end subroutine phs_fks_config_write
 
 @ %def phs_fks_config_write
 @
 <<phs fks: fks config: TBP>>=
   procedure :: set_mode => phs_fks_config_set_mode
 <<phs fks: procedures>>=
   subroutine phs_fks_config_set_mode (phs_config, mode)
     class(phs_fks_config_t), intent(inout) :: phs_config
     integer, intent(in) :: mode
     select case (mode)
     case (NLO_REAL, NLO_MISMATCH)
        phs_config%mode = PHS_MODE_ADDITIONAL_PARTICLE
     case (NLO_DGLAP)
        phs_config%mode = PHS_MODE_COLLINEAR_REMNANT
     end select
   end subroutine phs_fks_config_set_mode
 
 @ %def phs_fks_config_set_mod
 @
 <<phs fks: fks config: TBP>>=
   procedure :: configure => phs_fks_config_configure
 <<phs fks: procedures>>=
   subroutine phs_fks_config_configure (phs_config, sqrts, &
         sqrts_fixed, cm_frame, azimuthal_dependence, rebuild, &
         ignore_mismatch, nlo_type, subdir)
     class(phs_fks_config_t), intent(inout) :: phs_config
     real(default), intent(in) :: sqrts
     logical, intent(in), optional :: sqrts_fixed
     logical, intent(in), optional :: cm_frame
     logical, intent(in), optional :: azimuthal_dependence
     logical, intent(in), optional :: rebuild
     logical, intent(in), optional :: ignore_mismatch
     integer, intent(in), optional :: nlo_type
     type(string_t), intent(in), optional :: subdir
     if (phs_config%extension_mode == EXTENSION_NONE) then
        select case (phs_config%mode)
        case (PHS_MODE_ADDITIONAL_PARTICLE)
           phs_config%n_par = phs_config%n_par + 3
        case (PHS_MODE_COLLINEAR_REMNANT)
           phs_config%n_par = phs_config%n_par + 1
        end select
     end if
 !!! Channel equivalences not accessible yet
     phs_config%provides_equivalences = .false.
     call phs_config%compute_md5sum ()
   end subroutine phs_fks_config_configure
 
 @ %def phs_fks_config_configure
 @
 <<phs fks: fks config: TBP>>=
   procedure :: startup_message => phs_fks_config_startup_message
 <<phs fks: procedures>>=
   subroutine phs_fks_config_startup_message (phs_config, unit)
     class(phs_fks_config_t), intent(in) :: phs_config
     integer, intent(in), optional :: unit
     call phs_config%phs_wood_config_t%startup_message (unit)
   end subroutine phs_fks_config_startup_message
 
 @ %def phs_fks_config_startup_message
 @
 <<phs fks: fks config: TBP>>=
   procedure, nopass :: allocate_instance => phs_fks_config_allocate_instance
 <<phs fks: procedures>>=
   subroutine phs_fks_config_allocate_instance (phs)
     class(phs_t), intent(inout), pointer :: phs
     allocate (phs_fks_t :: phs)
   end subroutine phs_fks_config_allocate_instance
 
 @ %def phs_fks_config_allocate_instance
 @ If the phase space is generated from file, but we want to have resonance
 histories, we must force the cascade sets to be generated. However, it must
 be assured that Born flavors are used for this.
 <<phs fks: fks config: TBP>>=
   procedure :: generate_phase_space_extra => phs_fks_config_generate_phase_space_extra
 <<phs fks: procedures>>=
   subroutine phs_fks_config_generate_phase_space_extra (phs_config)
     class(phs_fks_config_t), intent(inout) :: phs_config
     integer :: off_shell, extra_off_shell
     type(flavor_t), dimension(:,:), allocatable :: flv_born
     integer :: i, j
     integer :: n_state, n_flv_born
     integer :: unit_fds
     logical :: valid
     type(string_t) :: file_name
     logical :: file_exists
     if (phs_config%use_cascades2) then
        allocate (phs_config%feyngraph_set)
     else
        allocate (phs_config%cascade_set)
     end if
     n_flv_born = size (phs_config%flv, 1) - 1
     n_state = size (phs_config%flv, 2)
     allocate (flv_born (n_flv_born, n_state))
     do i = 1, n_flv_born
        do j = 1, n_state
           flv_born(i, j) = phs_config%flv(i, j)
        end do
     end do
     if (phs_config%use_cascades2) then
        file_name = char (phs_config%id) // ".fds"
        inquire (file=char (file_name), exist=file_exists)
        if (.not. file_exists) call msg_fatal &
             ("The O'Mega input file " // char (file_name) // &
             " does not exist. " // "Please make sure that the " // &
             "variable ?omega_write_phs_output has been set correctly.")
        unit_fds = free_unit ()
        open (unit=unit_fds, file=char(file_name), status='old', action='read')
     end if
     off_shell = phs_config%par%off_shell
     do extra_off_shell = 0, max (n_flv_born - 2, 0)
        phs_config%par%off_shell = off_shell + extra_off_shell
        if (phs_config%use_cascades2) then
           call feyngraph_set_generate (phs_config%feyngraph_set, &
                phs_config%model, phs_config%n_in, phs_config%n_out - 1, &
                flv_born, phs_config%par, phs_config%fatal_beam_decay, unit_fds, &
                phs_config%vis_channels)
           if (feyngraph_set_is_valid (phs_config%feyngraph_set)) exit
        else
           call cascade_set_generate (phs_config%cascade_set, &
                phs_config%model, phs_config%n_in, phs_config%n_out - 1, &
                flv_born, phs_config%par, phs_config%fatal_beam_decay)
           if (cascade_set_is_valid (phs_config%cascade_set)) exit
        end if
     end do
     if (phs_config%use_cascades2) then
        close (unit_fds)
        valid = feyngraph_set_is_valid (phs_config%feyngraph_set)
     else
        valid = cascade_set_is_valid (phs_config%cascade_set)
     end if
     if (.not. valid) &
        call msg_fatal ("Resonance extraction: Phase space generation failed")
   end subroutine phs_fks_config_generate_phase_space_extra
 
 @ %def phs_fks_config_generate_phase_space_extra
 @
 <<phs fks: fks config: TBP>>=
   procedure :: set_born_config => phs_fks_config_set_born_config
 <<phs fks: procedures>>=
   subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born)
     class(phs_fks_config_t), intent(inout) :: phs_config
     type(phs_wood_config_t), intent(in), target :: phs_cfg_born
     if (debug_on) call msg_debug (D_PHASESPACE, "phs_fks_config_set_born_config")
     phs_config%forest = phs_cfg_born%forest
     phs_config%n_channel = phs_cfg_born%n_channel
     allocate (phs_config%channel (phs_config%n_channel))
     phs_config%channel = phs_cfg_born%channel
     phs_config%n_par = phs_cfg_born%n_par
     phs_config%n_state = phs_cfg_born%n_state
     phs_config%sqrts = phs_cfg_born%sqrts
     phs_config%par = phs_cfg_born%par
     phs_config%sqrts_fixed = phs_cfg_born%sqrts_fixed
     phs_config%azimuthal_dependence = phs_cfg_born%azimuthal_dependence
     phs_config%provides_chains = phs_cfg_born%provides_chains
     phs_config%cm_frame = phs_cfg_born%cm_frame
     phs_config%vis_channels = phs_cfg_born%vis_channels
     allocate (phs_config%chain (size (phs_cfg_born%chain)))
     phs_config%chain = phs_cfg_born%chain
     phs_config%model => phs_cfg_born%model
     phs_config%use_cascades2 = phs_cfg_born%use_cascades2
     if (allocated (phs_cfg_born%cascade_set)) then
        allocate (phs_config%cascade_set)
        phs_config%cascade_set = phs_cfg_born%cascade_set
     end if
     if (allocated (phs_cfg_born%feyngraph_set)) then
        allocate (phs_config%feyngraph_set)
        phs_config%feyngraph_set = phs_cfg_born%feyngraph_set
     end if
     phs_config%md5sum_born_config = phs_cfg_born%md5sum_phs_config
   end subroutine phs_fks_config_set_born_config
 
 @ %def phs_fks_config_set_born_config
 @
 <<phs fks: fks config: TBP>>=
   procedure :: get_resonance_histories => phs_fks_config_get_resonance_histories
 <<phs fks: procedures>>=
   function phs_fks_config_get_resonance_histories (phs_config) result (resonance_histories)
     type(resonance_history_t), dimension(:), allocatable :: resonance_histories
     class(phs_fks_config_t), intent(inout) :: phs_config
     if (allocated (phs_config%cascade_set)) then
        call cascade_set_get_resonance_histories &
           (phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories)
     else if (allocated (phs_config%feyngraph_set)) then
        call feyngraph_set_get_resonance_histories &
             (phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories)
     else
        if (debug_on) call msg_debug (D_PHASESPACE, "Have to rebuild phase space for resonance histories")
        call phs_config%generate_phase_space_extra ()
        if (phs_config%use_cascades2) then
           call feyngraph_set_get_resonance_histories &
                (phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories)
        else
           call cascade_set_get_resonance_histories &
                (phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories)
        end if
     end if
   end function phs_fks_config_get_resonance_histories
 
 @ %def phs_fks_config_get_resonance_histories
 @
 <<phs fks: public>>=
   public :: dalitz_plot_t
 <<phs fks: types>>=
   type :: dalitz_plot_t
      integer :: unit = -1
      type(string_t) :: filename
      logical :: active = .false.
      logical :: inverse = .false.
   contains
   <<phs fks: dalitz plot: TBP>>
   end type dalitz_plot_t
 
 @ %def dalitz_plot_t
 @
 <<phs fks: dalitz plot: TBP>>=
   procedure :: init => dalitz_plot_init
 <<phs fks: procedures>>=
   subroutine dalitz_plot_init (plot, unit, filename, inverse)
     class(dalitz_plot_t), intent(inout) :: plot
     integer, intent(in) :: unit
     type(string_t), intent(in) :: filename
     logical, intent(in) :: inverse
     plot%active = .true.
     plot%unit = unit
     plot%inverse = inverse
     open (plot%unit, file = char (filename), action = "write")
   end subroutine dalitz_plot_init
 
 @ %def daltiz_plot_init
 @
 <<phs fks: dalitz plot: TBP>>=
   procedure :: write_header => dalitz_plot_write_header
 <<phs fks: procedures>>=
   subroutine dalitz_plot_write_header (plot)
     class(dalitz_plot_t), intent(in) :: plot
     write (plot%unit, "(A36)") "### Dalitz plot generated by WHIZARD"
     if (plot%inverse) then
        write (plot%unit, "(A10,1x,A4)") "### k0_n+1", "k0_n"
     else
        write (plot%unit, "(A8,1x,A6)") "### k0_n", "k0_n+1"
     end if
   end subroutine dalitz_plot_write_header
 
 @ %def dalitz_plot_write_header
 @
 <<phs fks: dalitz plot: TBP>>=
   procedure :: register => dalitz_plot_register
 <<phs fks: procedures>>=
   subroutine dalitz_plot_register (plot, k0_n, k0_np1)
     class(dalitz_plot_t), intent(in) :: plot
     real(default), intent(in) :: k0_n, k0_np1
     if (plot%inverse) then
        write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n
     else
        write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n
     end if
   end subroutine dalitz_plot_register
 
 @ %def dalitz_plot_register
 @
 <<phs fks: dalitz plot: TBP>>=
   procedure :: final => dalitz_plot_final
 <<phs fks: procedures>>=
   subroutine dalitz_plot_final (plot)
     class(dalitz_plot_t), intent(inout) :: plot
     logical :: opened
     plot%active = .false.
     plot%inverse = .false.
     if (plot%unit >= 0) then
        inquire (unit = plot%unit, opened = opened)
        if (opened) close (plot%unit)
     end if
     plot%filename = var_str ('')
     plot%unit = -1
   end subroutine dalitz_plot_final
 
 @ %def dalitz_plot_final
 @
 <<phs fks: parameters>>=
   integer, parameter, public :: GEN_REAL_PHASE_SPACE = 1
   integer, parameter, public :: GEN_SOFT_MISMATCH = 2
   integer, parameter, public :: GEN_SOFT_LIMIT_TEST = 3
   integer, parameter, public :: GEN_COLL_LIMIT_TEST = 4
   integer, parameter, public :: GEN_ANTI_COLL_LIMIT_TEST = 5
   integer, parameter, public :: GEN_SOFT_COLL_LIMIT_TEST = 6
   integer, parameter, public :: GEN_SOFT_ANTI_COLL_LIMIT_TEST = 7
 
   integer, parameter, public :: SQRTS_FIXED = 1
   integer, parameter, public :: SQRTS_VAR = 2
 
   real(default), parameter :: xi_tilde_test_soft = 0.00001_default
   real(default), parameter :: xi_tilde_test_coll = 0.5_default
   real(default), parameter :: y_test_soft = 0.5_default
   real(default), parameter :: y_test_coll = 0.9999999_default
 
 @
 @ Very soft or collinear phase-space points can become a problem for
 matrix elements providers, as some scalar products cannot be evaluated
 properly. Here, a nonsensical result can spoil the whole integration.
 We therefore check the scalar products appearing to be below a certain
 tolerance.
 <<phs fks: public>>=
   public :: check_scalar_products
 <<phs fks: procedures>>=
   function check_scalar_products (p) result (valid)
     logical :: valid
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), parameter :: tolerance = 1E-7_default
     integer :: i, j
     valid = .true.
     do i = 1, size (p)
        do j = i, size (p)
           if (i /= j) then
              if (abs(p(i) * p(j)) < tolerance) then
                 valid = .false.
                 exit
              end if
           end if
        end do
     end do
   end function check_scalar_products
 
 @ %def check_scalar_products
 @ [[xi_min]] should be set to a non-zero value in order to avoid
 phase-space points with [[p_real(emitter) = 0]].
 <<phs fks: public>>=
   public :: phs_fks_generator_t
 <<phs fks: types>>=
   type :: phs_fks_generator_t
     integer, dimension(:), allocatable :: emitters
     type(real_kinematics_t), pointer :: real_kinematics => null()
     type(isr_kinematics_t), pointer :: isr_kinematics => null()
     integer :: n_in
     real(default) :: xi_min = tiny_07
     real(default) :: y_max = one
     real(default) :: sqrts
     real(default) :: E_gluon
     real(default) :: mrec2
     real(default), dimension(:), allocatable :: m2
     logical :: massive_phsp = .false.
     logical, dimension(:), allocatable :: is_massive
     logical :: singular_jacobian = .false.
     integer :: i_fsr_first = -1
     type(resonance_contributors_t), dimension(:), allocatable :: resonance_contributors !!! Put somewhere else?
     integer :: mode = GEN_REAL_PHASE_SPACE
   contains
   <<phs fks: phs fks generator: TBP>>
   end type phs_fks_generator_t
 
 @ %def phs_fks_generator_t
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: connect_kinematics => phs_fks_generator_connect_kinematics
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_connect_kinematics &
          (generator, isr_kinematics, real_kinematics, massive_phsp)
     class(phs_fks_generator_t), intent(inout) :: generator
     type(isr_kinematics_t), intent(in), pointer :: isr_kinematics
     type(real_kinematics_t), intent(in), pointer :: real_kinematics
     logical, intent(in) :: massive_phsp
     generator%real_kinematics => real_kinematics
     generator%isr_kinematics => isr_kinematics
     generator%massive_phsp = massive_phsp
   end subroutine phs_fks_generator_connect_kinematics
 
 @ %def phs_fks_generator_connect_kinematics
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_isr_kinematics => phs_fks_generator_compute_isr_kinematics
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_isr_kinematics (generator, r, p_in)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: r
     type(vector4_t), dimension(2), intent(in), optional :: p_in
     integer :: em
     type(vector4_t), dimension(2) :: p
 
     if (present (p_in)) then
        p = p_in
     else
        p = generator%real_kinematics%p_born_lab%phs_point(1)%p(1:2)
     end if
 
     associate (isr => generator%isr_kinematics)
        do em = 1, 2
           isr%x(em) = p(em)%p(0) / isr%beam_energy
           isr%z(em) = one - (one - isr%x(em)) * r
           isr%jacobian(em) =  one - isr%x(em)
        end do
        isr%sqrts_born = (p(1) + p(2))**1
     end associate
   end subroutine phs_fks_generator_compute_isr_kinematics
 
 @ %def phs_fks_generator_compute_isr_kinematics
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: final => phs_fks_generator_final
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_final (generator)
     class(phs_fks_generator_t), intent(inout) :: generator
     if (allocated (generator%emitters)) deallocate (generator%emitters)
     if (associated (generator%real_kinematics)) nullify (generator%real_kinematics)
     if (associated (generator%isr_kinematics)) nullify (generator%isr_kinematics)
     if (allocated (generator%m2)) deallocate (generator%m2)
     generator%massive_phsp = .false.
     if (allocated (generator%is_massive)) deallocate (generator%is_massive)
     generator%singular_jacobian = .false.
     generator%i_fsr_first = -1
     if (allocated (generator%resonance_contributors)) &
            deallocate (generator%resonance_contributors)
     generator%mode = GEN_REAL_PHASE_SPACE
   end subroutine phs_fks_generator_final
 
 @ %def phs_fks_generator_final
 @ A resonance phase space is uniquely specified via the resonance contributors and the
 corresponding emitters. The [[phs_identifier]] type also checks whether
 the given contributor-emitter configuration has already been evaluated to
 avoid duplicate computations.
 <<phs fks: public>>=
   public :: phs_identifier_t
 <<phs fks: types>>=
   type :: phs_identifier_t
      integer, dimension(:), allocatable :: contributors
      integer :: emitter = -1
      logical :: evaluated = .false.
   contains
   <<phs fks: phs identifier: TBP>>
   end type phs_identifier_t
 
 @ %def phs_identifier_t
 @
 <<phs fks: phs identifier: TBP>>=
   generic :: init => init_from_emitter, init_from_emitter_and_contributors
   procedure :: init_from_emitter => phs_identifier_init_from_emitter
   procedure :: init_from_emitter_and_contributors &
      => phs_identifier_init_from_emitter_and_contributors
 <<phs fks: procedures>>=
   subroutine phs_identifier_init_from_emitter (phs_id, emitter)
     class(phs_identifier_t), intent(out) :: phs_id
     integer, intent(in) :: emitter
     phs_id%emitter = emitter
   end subroutine phs_identifier_init_from_emitter
 
   subroutine phs_identifier_init_from_emitter_and_contributors &
      (phs_id, emitter, contributors)
      class(phs_identifier_t), intent(out) :: phs_id
      integer, intent(in) :: emitter
      integer, intent(in), dimension(:) :: contributors
      allocate (phs_id%contributors (size (contributors)))
      phs_id%contributors = contributors
      phs_id%emitter = emitter
   end subroutine phs_identifier_init_from_emitter_and_contributors
 @ %def phs_identifier_init_from_emitter
 @ %def phs_identifier_init_from_emitter_and_contributors
 @
 <<phs fks: phs identifier: TBP>>=
   procedure :: check => phs_identifier_check
 <<phs fks: procedures>>=
   function phs_identifier_check (phs_id, emitter, contributors) result (check)
     logical :: check
     class(phs_identifier_t), intent(in) :: phs_id
     integer, intent(in) :: emitter
     integer, intent(in), dimension(:), optional :: contributors
     check = phs_id%emitter == emitter
     if (present (contributors)) then
        if (.not. allocated (phs_id%contributors)) &
           call msg_fatal ("Phs identifier: contributors not allocated!")
        check = check .and. all (phs_id%contributors == contributors)
     end if
   end function phs_identifier_check
 
 @ %def phs_identifier_check
 @
 <<phs fks: phs identifier: TBP>>=
   procedure :: write => phs_identifier_write
 <<phs fks: procedures>>=
   subroutine phs_identifier_write (phs_id, unit)
     class(phs_identifier_t), intent(in) :: phs_id
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit); if (u < 0) return
     write (u, '(A)') 'phs_identifier: '
     write (u, '(A,1X,I1)') 'Emitter: ', phs_id%emitter
     if (allocated (phs_id%contributors)) then
        write (u, '(A)', advance = 'no') 'Resonance contributors: '
        do i = 1, size (phs_id%contributors)
           write (u, '(I1,1X)', advance = 'no') phs_id%contributors(i)
        end do
     else
        write (u, '(A)') 'No Contributors allocated'
     end if
   end subroutine phs_identifier_write
 
 @ %def phs_identifier_write
 @
 <<phs fks: public>>=
   public :: check_for_phs_identifier
 <<phs fks: procedures>>=
   subroutine check_for_phs_identifier (phs_id, n_in, emitter, contributors, phs_exist, i_phs)
      type(phs_identifier_t), intent(in), dimension(:) :: phs_id
      integer, intent(in) :: n_in, emitter
      integer, intent(in), dimension(:), optional :: contributors
      logical, intent(out) :: phs_exist
      integer, intent(out) :: i_phs
      integer :: i
      phs_exist = .false.
      i_phs = -1
      do i = 1, size (phs_id)
         if (phs_id(i)%emitter < 0) then
            i_phs = i
            exit
         end if
         phs_exist = phs_id(i)%emitter == emitter
         if (present (contributors)) &
            phs_exist = phs_exist .and. all (phs_id(i)%contributors == contributors)
         if (phs_exist) then
            i_phs = i
            exit
         end if
      end do
   end subroutine check_for_phs_identifier
 
 @ %def check_for_phs_identifier
 @
 @ The fks phase space type contains the wood phase space and
 separately the in- and outcoming momenta for the real process and the
 corresponding Born momenta. Additionally, there are the variables
 $\xi$,$\xi_{max}$, $y$ and $\phi$ which are used to create the real
 phase space, as well as the jacobian and its corresponding soft and
 collinear limit. Lastly, the array \texttt{ch\_to\_em} connects each
 channel with an emitter.
 <<phs fks: public>>=
   public :: phs_fks_t
 <<phs fks: types>>=
   type, extends (phs_wood_t) :: phs_fks_t
     integer :: mode = PHS_MODE_UNDEFINED
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: q_born
     type(vector4_t), dimension(:), allocatable :: p_real
     type(vector4_t), dimension(:), allocatable :: q_real
     type(vector4_t), dimension(:), allocatable :: p_born_tot
     type(phs_fks_generator_t) :: generator
     logical :: perform_generation = .true.
     real(default) :: r_isr
     type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
   contains
   <<phs fks: phs fks: TBP>>
   end type phs_fks_t
 
 @ %def phs_fks_t
 @
 <<phs fks: interfaces>>=
 
   interface compute_beta
     module procedure compute_beta_massless
     module procedure compute_beta_massive
   end interface
 
   interface get_xi_max_fsr
     module procedure get_xi_max_fsr_massless
     module procedure get_xi_max_fsr_massive
   end interface
 
 @ %def interfaces
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: write => phs_fks_write
 <<phs fks: procedures>>=
   subroutine phs_fks_write (object, unit, verbose)
     class(phs_fks_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i, n_id
     u = given_output_unit (unit)
     call object%base_write ()
     n_id = size (object%phs_identifiers)
     if (n_id == 0) then
        write (u, "(A)") "No phs identifiers allocated! "
     else
        do i = 1, n_id
           call object%phs_identifiers(i)%write (u)
        end do
     end if
   end subroutine phs_fks_write
 
 @ %def phs_fks_write
 @ Initializer for the phase space. Calls the initialization of the
 corresponding Born phase space, sets up the
 channel-emitter-association and allocates space for the momenta.
 <<phs fks: phs fks: TBP>>=
   procedure :: init => phs_fks_init
 <<phs fks: procedures>>=
   subroutine phs_fks_init (phs, phs_config)
     class(phs_fks_t), intent(out) :: phs
     class(phs_config_t), intent(in), target :: phs_config
 
     call phs%base_init (phs_config)
     select type (phs_config)
     type is (phs_fks_config_t)
        phs%config => phs_config
        phs%forest = phs_config%forest
     end select
 
     select type(phs)
     type is (phs_fks_t)
       select type (phs_config)
       type is (phs_fks_config_t)
          phs%mode = phs_config%mode
       end select
 
       select case (phs%mode)
       case (PHS_MODE_ADDITIONAL_PARTICLE)
          phs%n_r_born = phs%config%n_par - 3
       case (PHS_MODE_COLLINEAR_REMNANT)
          phs%n_r_born = phs%config%n_par - 1
       end select
     end select
   end subroutine phs_fks_init
 
 @ %def phs_fks_init
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: allocate_momenta => phs_fks_allocate_momenta
 <<phs fks: procedures>>=
   subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born)
     class(phs_fks_t), intent(inout) :: phs
     class(phs_config_t), intent(in) :: phs_config
     logical, intent(in) :: data_is_born
     integer :: n_out_born
     allocate (phs%p_born (phs_config%n_in))
     allocate (phs%p_real (phs_config%n_in))
     select case (phs%mode)
     case (PHS_MODE_ADDITIONAL_PARTICLE)
        if (data_is_born) then
           n_out_born = phs_config%n_out
        else
           n_out_born = phs_config%n_out - 1
        end if
        allocate (phs%q_born (n_out_born))
        allocate (phs%q_real (n_out_born + 1))
        allocate (phs%p_born_tot (phs_config%n_in + n_out_born))
     end select
   end subroutine phs_fks_allocate_momenta
 
 @ %def phs_fks_allocate_momenta
 @ Evaluate selected channel. First, the subroutine calls the
 evaluation procedure of the underlying Born phase space, using $n_r -
 3$ random numbers. Then, the remaining three random numbers are used
 to create $\xi$, $y$ and $\phi$, from which the real momenta are
 calculated from the Born momenta.
 <<phs fks: phs fks: TBP>>=
   procedure :: evaluate_selected_channel => phs_fks_evaluate_selected_channel
 <<phs fks: procedures>>=
   subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in)
     class(phs_fks_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     real(default), intent(in), dimension(:) :: r_in
     integer :: n_in
 
     call phs%phs_wood_t%evaluate_selected_channel (c_in, r_in)
     phs%r(:,c_in) = r_in
 
     phs%q_defined = phs%phs_wood_t%q_defined
     if (.not. phs%q_defined) return
 
     if (phs%perform_generation) then
        select case (phs%mode)
        case (PHS_MODE_ADDITIONAL_PARTICLE)
           n_in = phs%config%n_in
           phs%p_born = phs%phs_wood_t%p
           phs%q_born = phs%phs_wood_t%q
           phs%p_born_tot (1: n_in) = phs%p_born
           phs%p_born_tot (n_in + 1 :) = phs%q_born
           call phs%set_reference_frames (.true.)
           call phs%set_isr_kinematics (.true.)
        case (PHS_MODE_COLLINEAR_REMNANT)
           call phs%compute_isr_kinematics (r_in(phs%n_r_born + 1))
           phs%r_isr = r_in(phs%n_r_born + 1)
        end select
     end if
   end subroutine phs_fks_evaluate_selected_channel
 
 @ %def phs_fks_evaluate_selected_channel
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: evaluate_other_channels => phs_fks_evaluate_other_channels
 <<phs fks: procedures>>=
   subroutine phs_fks_evaluate_other_channels (phs, c_in)
     class(phs_fks_t), intent(inout) :: phs
     integer, intent(in) :: c_in
     call phs%phs_wood_t%evaluate_other_channels (c_in)
     phs%r_defined = .true.
   end subroutine phs_fks_evaluate_other_channels
 
 @ %def phs_fks_evaluate_other_channels
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: get_mcpar => phs_fks_get_mcpar
 <<phs fks: procedures>>=
   subroutine phs_fks_get_mcpar (phs, c, r)
     class(phs_fks_t), intent(in) :: phs
     integer, intent(in) :: c
     real(default), dimension(:), intent(out) :: r
     r(1 : phs%n_r_born) = phs%r(1 : phs%n_r_born,c)
     select case (phs%mode)
     case (PHS_MODE_ADDITIONAL_PARTICLE)
        r(phs%n_r_born + 1 :) = phs%r_real
     case (PHS_MODE_COLLINEAR_REMNANT)
        r(phs%n_r_born + 1 :) = phs%r_isr
     end select
   end subroutine phs_fks_get_mcpar
 
 @ %def phs_fks_get_mcpar
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: set_beam_energy => phs_fks_set_beam_energy
 <<phs fks: procedures>>=
   subroutine phs_fks_set_beam_energy (phs)
     class(phs_fks_t), intent(inout) :: phs
     call phs%generator%set_sqrts_hat (phs%config%sqrts)
   end subroutine phs_fks_set_beam_energy
 
 @ %def phs_fks_set_beam_energy
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: set_emitters => phs_fks_set_emitters
 <<phs fks: procedures>>=
   subroutine phs_fks_set_emitters (phs, emitters)
     class(phs_fks_t), intent(inout) :: phs
     integer, intent(in), dimension(:), allocatable :: emitters
     call phs%generator%set_emitters (emitters)
   end subroutine phs_fks_set_emitters
 
 @ %def phs_fks_set_emitters
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: set_momenta => phs_fks_set_momenta
 <<phs fks: procedures>>=
   subroutine phs_fks_set_momenta (phs, p)
     class(phs_fks_t), intent(inout) :: phs
     type(vector4_t), intent(in), dimension(:) :: p
     integer :: n_in, n_tot_born
     select case (phs%mode)
     case (PHS_MODE_ADDITIONAL_PARTICLE)
        n_in = phs%config%n_in; n_tot_born = phs%config%n_tot - 1
        phs%p_born = p(1 : n_in)
        phs%q_born = p(n_in + 1 : n_tot_born)
        phs%p_born_tot = p
     end select
   end subroutine phs_fks_set_momenta
 
 @ %def phs_fks_set_momenta
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: setup_masses => phs_fks_setup_masses
 <<phs fks: procedures>>=
   subroutine phs_fks_setup_masses (phs, n_tot)
     class(phs_fks_t), intent(inout) :: phs
     integer, intent(in) :: n_tot
     call phs%generator%setup_masses (n_tot)
   end subroutine phs_fks_setup_masses
 
 @ %def phs_fks_setup_masses
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: get_born_momenta => phs_fks_get_born_momenta
 <<phs fks: procedures>>=
   subroutine phs_fks_get_born_momenta (phs, p)
     class(phs_fks_t), intent(inout) :: phs
     type(vector4_t), intent(out), dimension(:) :: p
     select case (phs%mode)
     case (PHS_MODE_ADDITIONAL_PARTICLE)
        p(1 : phs%config%n_in) = phs%p_born
        p(phs%config%n_in + 1 :) = phs%q_born
     case (PHS_MODE_COLLINEAR_REMNANT)
        p(1:phs%config%n_in) = phs%phs_wood_t%p
        p(phs%config%n_in + 1 : ) = phs%phs_wood_t%q
     end select
     if (.not. phs%config%cm_frame)  p = phs%lt_cm_to_lab * p
   end subroutine phs_fks_get_born_momenta
 
 @ %def phs_fks_get_born_momenta
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: get_outgoing_momenta => phs_fks_get_outgoing_momenta
 <<phs fks: procedures>>=
   subroutine phs_fks_get_outgoing_momenta (phs, q)
     class(phs_fks_t), intent(in) :: phs
     type(vector4_t), intent(out), dimension(:) :: q
     select case (phs%mode)
     case (PHS_MODE_ADDITIONAL_PARTICLE)
        q = phs%q_real
     case (PHS_MODE_COLLINEAR_REMNANT)
        q = phs%phs_wood_t%q
     end select
   end subroutine phs_fks_get_outgoing_momenta
 
 @ %def phs_fks_get_outgoing_momenta
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: get_incoming_momenta => phs_fks_get_incoming_momenta
 <<phs fks: procedures>>=
   subroutine phs_fks_get_incoming_momenta (phs, p)
     class(phs_fks_t), intent(in) :: phs
     type(vector4_t), intent(inout), dimension(:), allocatable :: p
     p = phs%p_real
   end subroutine phs_fks_get_incoming_momenta
 
 @ %def phs_fks_get_incoming_momenta
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: set_isr_kinematics => phs_fks_set_isr_kinematics
 <<phs fks: procedures>>=
   subroutine phs_fks_set_isr_kinematics (phs, requires_boost)
     class(phs_fks_t), intent(inout) :: phs
     logical, intent(in) :: requires_boost
     type(vector4_t), dimension(2) :: p
     if (phs%generator%isr_kinematics%isr_mode == SQRTS_VAR) then
        if (requires_boost) then
           p = phs%lt_cm_to_lab * phs%generator%real_kinematics%p_born_cms%phs_point(1)%p(1:2)
        else
           p = phs%generator%real_kinematics%p_born_lab%phs_point(1)%p(1:2)
        end if
        call phs%generator%set_isr_kinematics (p)
     end if
   end subroutine phs_fks_set_isr_kinematics
 
 @ %def phs_fks_set_isr_kinematics
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: generate_radiation_variables => &
      phs_fks_generate_radiation_variables
 <<phs fks: procedures>>=
   subroutine phs_fks_generate_radiation_variables (phs, r_in, threshold)
     class(phs_fks_t), intent(inout) :: phs
     real(default), intent(in), dimension(:) :: r_in
     logical, intent(in) :: threshold
     type(vector4_t), dimension(:), allocatable :: p_born
     if (size (r_in) /= 3) call msg_fatal &
          ("Real kinematics need to be generated using three random numbers!")
     select case (phs%mode)
     case (PHS_MODE_ADDITIONAL_PARTICLE)
        allocate (p_born (size (phs%p_born_tot)))
        if (threshold) then
           p_born = phs%get_onshell_projected_momenta ()
        else
           p_born = phs%p_born_tot
        if (.not. phs%is_cm_frame ()) &
             p_born = inverse (phs%lt_cm_to_lab) * p_born
        end if
        call phs%generator%generate_radiation_variables &
             (r_in, p_born, phs%phs_identifiers, threshold)
        phs%r_real = r_in
     end select
   end subroutine phs_fks_generate_radiation_variables
 
 @ %def phs_fks_generate_radiation_variables
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: compute_xi_ref_momenta => phs_fks_compute_xi_ref_momenta
 <<phs fks: procedures>>=
   subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors)
     class(phs_fks_t), intent(inout) :: phs
     type(vector4_t), intent(in), dimension(:), optional :: p_in
     type(resonance_contributors_t), intent(in), dimension(:), optional :: contributors
     if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then
        if (present (p_in)) then
           call phs%generator%compute_xi_ref_momenta (p_in, contributors)
        else
           call phs%generator%compute_xi_ref_momenta (phs%p_born_tot, contributors)
        end if
     end if
   end subroutine phs_fks_compute_xi_ref_momenta
 
 @ %def phs_fks_compute_xi_ref_momenta
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: compute_xi_ref_momenta_threshold => phs_fks_compute_xi_ref_momenta_threshold
 <<phs fks: procedures>>=
   subroutine phs_fks_compute_xi_ref_momenta_threshold (phs)
     class(phs_fks_t), intent(inout) :: phs
     select case (phs%mode)
     case (PHS_MODE_ADDITIONAL_PARTICLE)
        call phs%generator%compute_xi_ref_momenta_threshold &
             (phs%get_onshell_projected_momenta ())
     end select
   end subroutine phs_fks_compute_xi_ref_momenta_threshold
 
 @ %def phs_fks_compute_xi_ref_momenta
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: compute_cms_energy => phs_fks_compute_cms_energy
 <<phs fks: procedures>>=
   subroutine phs_fks_compute_cms_energy (phs)
     class(phs_fks_t), intent(inout) :: phs
     if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) &
          call phs%generator%compute_cms_energy (phs%p_born_tot)
   end subroutine phs_fks_compute_cms_energy
 
 @ %def phs_fks_compute_cms_energy
 @ When initial-state radiation is involved, either due to beamnstrahlung or
 QCD corrections, it is important to have access to both the phase space points
 in the center-of-mass and lab frame.
 <<phs fks: phs fks: TBP>>=
   procedure :: set_reference_frames => phs_fks_set_reference_frames
 <<phs fks: procedures>>=
   subroutine phs_fks_set_reference_frames (phs, is_cms)
     class(phs_fks_t), intent(inout) :: phs
     logical, intent(in) :: is_cms
     type(lorentz_transformation_t) :: lt
     associate (real_kinematics => phs%generator%real_kinematics)
        if (phs%config%cm_frame) then
           real_kinematics%p_born_cms%phs_point(1)%p = phs%p_born_tot
           real_kinematics%p_born_lab%phs_point(1)%p = phs%p_born_tot
        else
           if (is_cms) then
              real_kinematics%p_born_cms%phs_point(1)%p = phs%p_born_tot
              lt = phs%lt_cm_to_lab
              real_kinematics%p_born_lab%phs_point(1)%p = &
                   lt * phs%p_born_tot
           else
              real_kinematics%p_born_lab%phs_point(1)%p = phs%p_born_tot
              lt = inverse (phs%lt_cm_to_lab)
              real_kinematics%p_born_cms%phs_point(1)%p = &
                   lt * phs%p_born_tot
           end if
        end if
     end associate
   end subroutine phs_fks_set_reference_frames
 
 @ %def phs_fks_set_reference_frames
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: i_phs_is_isr => phs_fks_i_phs_is_isr
 <<phs fks: procedures>>=
   function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr)
     logical :: is_isr
     class(phs_fks_t), intent(in) :: phs
     integer, intent(in) :: i_phs
     is_isr = phs%phs_identifiers(i_phs)%emitter <= phs%generator%n_in
   end function phs_fks_i_phs_is_isr
 
 @ %def phs_fks_i_phs_is_isr
 @
 \subsection{Creation of the real phase space - FSR}
 At this point, the Born phase space has been generated, as well as the
 three random variables $\xi$, $y$ and $\phi$. The question is how the
 real phase space is generated for a final-state emission
 configuration. We work with two different sets of momenta, the Born
 configuration $\Bigl\{ \bar{k}_{\oplus}, \bar{k}_{\ominus}, \bar{k}_{1}, ...,
 \bar{k}_{n} \Bigr\}$ and the real configuration $\Bigl\{ k_{\oplus},
 k_{\ominus}, k_1,..., k_n, k_{n+1} \Bigr\}$. We define the momentum of
 the emitter to be on the $n$-th position and the momentum of the
 radiated particle to be at position $n+1$. The magnitude of the
 spatial component of k is denoted by $\underline{k}$.
 
 For final-state emissions, it is $\bar{k}_\oplus = k_\oplus$ and
 $\bar{k}_\ominus = k_\ominus$. Thus, the center-of-mass systems
 coincide and it is
 \begin{equation}
   q = \sum_{i=1}^n \bar{k}_i = \sum_{i=1}^{n+1} k_i,
 \end{equation}
 with $\vec{q} = 0$ and $q^2 = \left(q^0\right)^2$.
 
 We want to construct the real phase space from the Born phase space
 using three random numbers. They are defined as follows:
 \begin{itemize}
 \item $\xi = \frac{2k_{n+1}^0}{\sqrt{s}} \in [0, \xi_{max}]$, where
   $k_{n+1}$ denotes the four-momentum of the radiated particle.
 \item $y = \cos\theta = \frac{\vec{k}_n \cdot
     \vec{k}_{n+1}}{\underline{k}_n \underline{k}_{n+1}}$ is the
   splitting angle.
 \item The angle between tho two splitting particles in the transversal
   plane, $phi \in [0,2\pi]$.
 \end{itemize}
 Further, $k_{rec} = \sum_{i=1}^{n-1} k_i$ denotes the sum of all
 recoiling momenta.
 <<phs fks: phs fks generator: TBP>>=
   generic :: generate_fsr => generate_fsr_default, generate_fsr_resonances
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_fsr_default => phs_fks_generator_generate_fsr_default
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_fsr_default (generator, emitter, i_phs, &
      p_born, p_real, xi_y_phi, no_jacobians)
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: emitter, i_phs
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(inout), dimension(:) :: p_real
     real(default), intent(in), dimension(3), optional :: xi_y_phi
     logical, intent(in), optional :: no_jacobians
     real(default) :: q0
 
     call generator%generate_fsr_in (p_born, p_real)
     q0 = sum (p_born(1:generator%n_in))**1
     generator%i_fsr_first = generator%n_in + 1
     call generator%generate_fsr_out (emitter, i_phs, p_born, p_real, q0, &
          xi_y_phi = xi_y_phi, no_jacobians = no_jacobians)
     if (debug_active (D_PHASESPACE)) then
        call vector4_check_momentum_conservation (p_real, generator%n_in, &
            rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07)
     end if
   end subroutine phs_fks_generator_generate_fsr_default
 
 @ %def phs_fks_generator_generate_fsr
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_fsr_resonances => phs_fks_generator_generate_fsr_resonances
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_fsr_resonances (generator, &
        emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians)
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: emitter, i_phs
     integer, intent(in) :: i_con
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(inout), dimension(:) :: p_real
     real(default), intent(in), dimension(3), optional :: xi_y_phi
     logical, intent(in), optional :: no_jacobians
     integer, dimension(:), allocatable :: resonance_list
     integer, dimension(size(p_born)) :: inv_resonance_list
     type(vector4_t), dimension(:), allocatable :: p_tmp_born
     type(vector4_t), dimension(:), allocatable :: p_tmp_real
     type(vector4_t) :: p_resonance
     real(default) :: q0
     integer :: i, j, nlegborn, nlegreal
     integer :: i_emitter
     type(lorentz_transformation_t) :: boost_to_resonance
     integer :: n_resonant_particles
     if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances")
     nlegborn = size (p_born); nlegreal = nlegborn + 1
     allocate (resonance_list (size (generator%resonance_contributors(i_con)%c)))
     resonance_list = generator%resonance_contributors(i_con)%c
     n_resonant_particles = size (resonance_list)
 
     if (.not. any (resonance_list == emitter)) then
        call msg_fatal ("Emitter must be included in the resonance list!")
     else
        do i = 1, n_resonant_particles
           if (resonance_list (i) == emitter) i_emitter = i
        end do
     end if
 
     inv_resonance_list = &
        create_inverse_resonance_list (nlegborn, resonance_list)
 
     allocate (p_tmp_born (n_resonant_particles))
     allocate (p_tmp_real (n_resonant_particles + 1))
     p_tmp_born = vector4_null
     p_tmp_real = vector4_null
     j = 1
     do i = 1, n_resonant_particles
        p_tmp_born(j) = p_born(resonance_list(i))
        j = j + 1
     end do
 
     call generator%generate_fsr_in (p_born, p_real)
 
     p_resonance = generator%real_kinematics%xi_ref_momenta(i_con)
     q0 = p_resonance**1
 
     boost_to_resonance = inverse (boost (p_resonance, q0))
     p_tmp_born = boost_to_resonance * p_tmp_born
 
     generator%i_fsr_first = 1
     call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, p_tmp_real, &
          q0, i_emitter, xi_y_phi)
     p_tmp_real = inverse (boost_to_resonance) * p_tmp_real
 
     do i = generator%n_in + 1, nlegborn
        if (any (resonance_list == i)) then
           p_real(i) = p_tmp_real(inv_resonance_list (i))
        else
           p_real(i) = p_born (i)
        end if
     end do
     p_real(nlegreal) = p_tmp_real (n_resonant_particles + 1)
 
     if (debug_active (D_PHASESPACE)) then
        call vector4_check_momentum_conservation (p_real, generator%n_in, &
             rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07)
     end if
 
   contains
 
     function create_inverse_resonance_list (nlegborn, resonance_list) &
        result (inv_resonance_list)
        integer, intent(in) :: nlegborn
        integer, intent(in), dimension(:) :: resonance_list
        integer, dimension(nlegborn) :: inv_resonance_list
        integer :: i, j
        inv_resonance_list = 0
        j = 1
        do i = 1, nlegborn
           if (any (i == resonance_list)) then
              inv_resonance_list (i) = j
              j = j + 1
           end if
        end do
     end function create_inverse_resonance_list
 
     function boosted_energy () result (E)
       real(default) :: E
       type(vector4_t) :: p_boost
       p_boost = boost_to_resonance * p_resonance
       E = p_boost%p(0)
     end function boosted_energy
   end subroutine phs_fks_generator_generate_fsr_resonances
 
 @ %def phs_fks_generator_generate_fsr_resonances
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_fsr_threshold => phs_fks_generator_generate_fsr_threshold
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_fsr_threshold (generator, &
        emitter, i_phs, p_born, p_real, xi_y_phi)
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: emitter, i_phs
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(inout), dimension(:) :: p_real
     real(default), intent(in), dimension(3), optional :: xi_y_phi
     type(vector4_t), dimension(2) :: p_tmp_born
     type(vector4_t), dimension(3) :: p_tmp_real
     integer :: nlegborn, nlegreal
     type(vector4_t) :: p_top
     real(default) :: q0
     type(lorentz_transformation_t) :: boost_to_top
     integer :: leg, other_leg
     real(default) :: sqrts, mtop
     if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances")
     nlegborn = size (p_born); nlegreal = nlegborn + 1
 
     leg = thr_leg(emitter); other_leg = 3 - leg
 
     p_tmp_born(1) = p_born (ass_boson(leg))
     p_tmp_born(2) = p_born (ass_quark(leg))
 
     call generator%generate_fsr_in (p_born, p_real)
 
     p_top = generator%real_kinematics%xi_ref_momenta(leg)
 
     q0 = p_top**1
     sqrts = two * p_born(1)%p(0)
     mtop = m1s_to_mpole (sqrts)
     if (sqrts**2 - four * mtop**2 > zero) then
        boost_to_top = inverse (boost (p_top, q0))
     else
        boost_to_top = identity
     end if
     p_tmp_born = boost_to_top * p_tmp_born
 
     generator%i_fsr_first = 1
     call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, &
          p_tmp_real, q0, 2, xi_y_phi)
     p_tmp_real = inverse (boost_to_top) * p_tmp_real
 
     p_real(ass_boson(leg)) = p_tmp_real(1)
     p_real(ass_quark(leg)) = p_tmp_real(2)
     p_real(ass_boson(other_leg)) = p_born(ass_boson(other_leg))
     p_real(ass_quark(other_leg)) = p_born(ass_quark(other_leg))
     p_real(THR_POS_GLUON) = p_tmp_real(3)
 
   end subroutine phs_fks_generator_generate_fsr_threshold
 
 @ %def phs_fks_generator_generate_fsr_threshold
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_fsr_in => phs_fks_generator_generate_fsr_in
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_fsr_in (generator, p_born, p_real)
     class(phs_fks_generator_t), intent(inout) :: generator
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(inout), dimension(:) :: p_real
     integer :: i
     do i = 1, generator%n_in
        p_real(i) = p_born(i)
     end do
   end subroutine phs_fks_generator_generate_fsr_in
 
 @ %def phs_fks_generator_generate_fsr_in
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_fsr_out => phs_fks_generator_generate_fsr_out
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_fsr_out (generator, &
       emitter, i_phs, p_born, p_real, q0, p_emitter_index, xi_y_phi, no_jacobians)
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: emitter, i_phs
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(inout), dimension(:) :: p_real
     real(default), intent(in) :: q0
     integer, intent(in), optional :: p_emitter_index
     real(default), intent(in), dimension(3), optional :: xi_y_phi
     logical, intent(in), optional :: no_jacobians
     real(default) :: xi, y, phi
     integer :: nlegborn, nlegreal
     real(default) :: uk_np1, uk_n
     real(default) :: uk_rec, k_rec0
     type(vector3_t) :: k_n_born, k
     real(default) :: uk_n_born, uk, k2, k0_n
     real(default) :: cpsi, beta
     type(vector3_t) :: vec, vec_orth
     type(lorentz_transformation_t) :: rot
     integer :: i, p_em
     logical :: compute_jac
     p_em = emitter; if (present (p_emitter_index)) p_em = p_emitter_index
     compute_jac = .true.
     if (present (no_jacobians)) compute_jac = .not. no_jacobians
     if (generator%i_fsr_first < 0) &
        call msg_fatal ("FSR generator is called for outgoing particles but "&
             &"i_fsr_first is not set!")
 
     if (present (xi_y_phi)) then
        xi = xi_y_phi(I_XI)
        y = xi_y_phi(I_Y)
        phi = xi_y_phi(I_PHI)
     else
        associate (rad_var => generator%real_kinematics)
           xi = rad_var%xi_tilde
           if (rad_var%supply_xi_max) xi = xi * rad_var%xi_max(i_phs)
           y = rad_var%y(i_phs)
           phi = rad_var%phi
        end associate
     end if
 
     nlegborn = size (p_born)
     nlegreal = nlegborn + 1
     generator%E_gluon = q0 * xi / two
     uk_np1 = generator%E_gluon
     k_n_born = p_born(p_em)%p(1:3)
     uk_n_born = k_n_born**1
 
     generator%mrec2 = (q0 - p_born(p_em)%p(0))**2 &
          - space_part_norm(p_born(p_em))**2
     if (generator%is_massive(emitter)) then
        call generator%compute_emitter_kinematics (y, emitter, &
             i_phs, q0, k0_n, uk_n, uk, compute_jac)
     else
        call generator%compute_emitter_kinematics (y, q0, uk_n, uk)
        generator%real_kinematics%y_soft(i_phs) = y
        k0_n = uk_n
     end if
 
     if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_out")
     call debug_input_values ()
 
     vec = uk_n / uk_n_born * k_n_born
     vec_orth = create_orthogonal (vec)
     p_real(p_em)%p(0) = k0_n
     p_real(p_em)%p(1:3) = vec%p(1:3)
     cpsi = (uk_n**2 + uk**2 - uk_np1**2) / (two * uk_n * uk)
     !!! This is to catch the case where cpsi = 1, but numerically
     !!! turns out to be slightly larger than 1.
     call check_cpsi_bound (cpsi)
     rot = rotation (cpsi, - sqrt (one - cpsi**2), vec_orth)
     p_real(p_em) = rot * p_real(p_em)
     vec = uk_np1 / uk_n_born * k_n_born
     vec_orth = create_orthogonal (vec)
     p_real(nlegreal)%p(0) = uk_np1
     p_real(nlegreal)%p(1:3) = vec%p(1:3)
     cpsi = (uk_np1**2 + uk**2 - uk_n**2) / (two * uk_np1 * uk)
     call check_cpsi_bound (cpsi)
     rot = rotation (cpsi, sqrt (one - cpsi**2), vec_orth)
     p_real(nlegreal) = rot * p_real(nlegreal)
     call construct_recoiling_momenta ()
     if (compute_jac) call compute_jacobians ()
 
   contains
 
 <<phs fks: generator generate fsr out procedures>>
 
   end subroutine phs_fks_generator_generate_fsr_out
 
 @ %def phs_fks_generator_generate_fsr_out
 @
 <<phs fks: generator generate fsr out procedures>>=
   subroutine debug_input_values ()
     if (debug2_active (D_PHASESPACE)) then
        call generator%write ()
        print *, 'emitter =    ', emitter
        print *, 'p_born:'
        call vector4_write_set (p_born)
        print *, 'p_real:'
        call vector4_write_set (p_real)
        print *, 'q0 =    ', q0
        if (present(p_emitter_index)) then
           print *, 'p_emitter_index =    ', p_emitter_index
        else
           print *, 'p_emitter_index not given'
        end if
     end if
   end subroutine debug_input_values
 
 <<phs fks: generator generate fsr out procedures>>=
   subroutine check_cpsi_bound (cpsi)
     real(default), intent(inout) :: cpsi
     if (cpsi > one) then
        cpsi = one
     else if (cpsi < -one) then
        cpsi = - one
     end if
   end subroutine check_cpsi_bound
 
 @ Construction of the recoiling momenta. The reshuffling of momenta
 must not change the invariant mass of the recoiling system, which
 means $k_{\rm{rec}}^2 = \bar{k_{\rm{rec}}}^2$. Therefore, the momenta
 are related by a boost, $\bar{k}_i = \Lambda k_i$. The boost parameter
 is
 \begin{equation*}
   \beta = \frac{q^2 - (k_{\rm{rec}}^0 +
     \underline{k}_{\rm{rec}})^2}{q^2 + (k_{\rm{rec}}^0 +
     \underline{k}_{\rm{rec}})^2}
 \end{equation*}
 <<phs fks: generator generate fsr out procedures>>=
   subroutine construct_recoiling_momenta ()
     type(lorentz_transformation_t) :: lambda
     k_rec0 = q0 - p_real(p_em)%p(0) - p_real(nlegreal)%p(0)
     if (k_rec0**2 > generator%mrec2) then
        uk_rec = sqrt (k_rec0**2 - generator%mrec2)
     else
        uk_rec = 0
     end if
     if (generator%is_massive(emitter)) then
        beta = compute_beta (q0**2, k_rec0, uk_rec, &
               p_born(p_em)%p(0), uk_n_born)
     else
        beta = compute_beta (q0**2, k_rec0, uk_rec)
     end if
     k = p_real(p_em)%p(1:3) + p_real(nlegreal)%p(1:3)
     vec%p(1:3) = one / uk * k%p(1:3)
     lambda = boost (beta / sqrt(one - beta**2), vec)
     do i = generator%i_fsr_first, nlegborn
       if (i /= p_em) then
          p_real(i) = lambda * p_born(i)
       end if
     end do
     vec%p(1:3) = p_born(p_em)%p(1:3) / uk_n_born
     rot = rotation (cos(phi), sin(phi), vec)
     p_real(nlegreal) = rot * p_real(nlegreal)
     p_real(p_em) = rot * p_real(p_em)
   end subroutine construct_recoiling_momenta
 
 @ The factor $\frac{q^2}{(4\pi)^3}$ is not included here since it is
 supplied during phase space generation. Also, we already divide by
 $\xi$.
 <<phs fks: generator generate fsr out procedures>>=
   subroutine compute_jacobians ()
     associate (jac => generator%real_kinematics%jac(i_phs))
        if (generator%is_massive(emitter)) then
           jac%jac(1) = jac%jac(1) * four / q0 / uk_n_born / xi
        else
           k2 = two * uk_n * uk_np1* (one - y)
           jac%jac(1) = uk_n**2 / uk_n_born / (uk_n - k2 / (two * q0))
        end if
        jac%jac(2) = one
        jac%jac(3) = one - xi / two * q0 / uk_n_born
     end associate
   end subroutine compute_jacobians
 
 @ %def compute_jacobians
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: generate_fsr_in => phs_fks_generate_fsr_in
 <<phs fks: procedures>>=
   subroutine phs_fks_generate_fsr_in (phs)
     class(phs_fks_t), intent(inout) :: phs
     type(vector4_t), dimension(:), allocatable :: p
     p = phs%generator%real_kinematics%p_born_lab%get_momenta (1, phs%generator%n_in)
   end subroutine phs_fks_generate_fsr_in
 
 @ %def phs_fks_generate_fsr_in
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: generate_fsr => phs_fks_generate_fsr
 <<phs fks: procedures>>=
   subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, i_con, &
          xi_y_phi, no_jacobians)
     class(phs_fks_t), intent(inout) :: phs
     integer, intent(in) :: emitter, i_phs
     type(vector4_t), intent(inout), dimension(:) :: p_real
     integer, intent(in), optional :: i_con
     real(default), intent(in), dimension(3), optional :: xi_y_phi
     logical, intent(in), optional :: no_jacobians
     type(vector4_t), dimension(:), allocatable :: p
     associate (generator => phs%generator)
        allocate (p (1:generator%real_kinematics%p_born_cms%get_n_particles()), &
             source = generator%real_kinematics%p_born_cms%phs_point(1)%p)
        generator%real_kinematics%supply_xi_max = .true.
        if (present (i_con)) then
           call generator%generate_fsr (emitter, i_phs, i_con, p, p_real, &
                xi_y_phi, no_jacobians)
        else
           call generator%generate_fsr (emitter, i_phs, p, p_real, &
                xi_y_phi, no_jacobians)
        end if
        generator%real_kinematics%p_real_cms%phs_point(i_phs)%p = p_real
        if (.not. phs%config%cm_frame)  p_real = phs%lt_cm_to_lab * p_real
        generator%real_kinematics%p_real_lab%phs_point(i_phs)%p = p_real
     end associate
   end subroutine phs_fks_generate_fsr
 
 @ %def phs_fks_generate_fsr
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: get_onshell_projected_momenta => phs_fks_get_onshell_projected_momenta
 <<phs fks: procedures>>=
   pure function phs_fks_get_onshell_projected_momenta (phs) result (p)
     type(vector4_t), dimension(:), allocatable :: p
     class(phs_fks_t), intent(in) :: phs
     p = phs%generator%real_kinematics%p_born_onshell%phs_point(1)%p
   end function phs_fks_get_onshell_projected_momenta
 
 @ %def phs_fks_get_onshell_projected_momenta
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: generate_fsr_threshold => phs_fks_generate_fsr_threshold
 <<phs fks: procedures>>=
   subroutine phs_fks_generate_fsr_threshold (phs, emitter, i_phs, p_real)
     class(phs_fks_t), intent(inout) :: phs
     integer, intent(in) :: emitter, i_phs
     type(vector4_t), intent(inout), dimension(:), optional :: p_real
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: pp
     integer :: leg
     associate (generator => phs%generator)
        generator%real_kinematics%supply_xi_max = .true.
        allocate (p_born (1 : generator%real_kinematics%p_born_cms%get_n_particles()))
        p_born = generator%real_kinematics%p_born_onshell%get_momenta (1)
        allocate (pp (size (p_born) + 1))
        call generator%generate_fsr_threshold (emitter, i_phs, p_born, pp)
        leg = thr_leg (emitter)
        call generator%real_kinematics%p_real_onshell(leg)%set_momenta (i_phs, pp)
        if (present (p_real))  p_real = pp
     end associate
   end subroutine phs_fks_generate_fsr_threshold
 
 @ %def phs_fks_generate_fsr_threshold
 @
 <<phs fks: phs fks: TBP>>=
   generic :: compute_xi_max => compute_xi_max_internal, compute_xi_max_with_output
   procedure :: compute_xi_max_internal => phs_fks_compute_xi_max_internal
 <<phs fks: procedures>>=
   subroutine phs_fks_compute_xi_max_internal (phs, p, threshold)
     class(phs_fks_t), intent(inout) :: phs
     type(vector4_t), intent(in), dimension(:) :: p
     logical, intent(in) :: threshold
     integer :: i_phs, i_con, emitter
     do i_phs = 1, size (phs%phs_identifiers)
        associate (phs_id => phs%phs_identifiers(i_phs), generator => phs%generator)
           emitter = phs_id%emitter
           if (threshold) then
              call generator%compute_xi_max (emitter, i_phs, p, &
                   generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter))
           else if (allocated (phs_id%contributors)) then
              do i_con = 1, size (phs_id%contributors)
                 call generator%compute_xi_max (emitter, i_phs, p, &
                      generator%real_kinematics%xi_max(i_phs), i_con = 1)
              end do
           else
              call generator%compute_xi_max (emitter, i_phs, p, &
                   generator%real_kinematics%xi_max(i_phs))
           end if
        end associate
     end do
   end subroutine phs_fks_compute_xi_max_internal
 
 @ %def phs_fks_compute_xi_max
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: compute_xi_max_with_output => phs_fks_compute_xi_max_with_output
 <<phs fks: procedures>>=
   subroutine phs_fks_compute_xi_max_with_output (phs, emitter, i_phs, y, p, xi_max)
     class(phs_fks_t), intent(inout) :: phs
     integer, intent(in) :: i_phs, emitter
     real(default), intent(in) :: y
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(out) :: xi_max
     call phs%generator%compute_xi_max (emitter, i_phs, p, xi_max, y_in = y)
   end subroutine phs_fks_compute_xi_max_with_output
 
 @ %def phs_fks_compute_xi_max_with_output
 @
 <<phs fks: phs fks generator: TBP>>=
   generic :: compute_emitter_kinematics => &
      compute_emitter_kinematics_massless, &
      compute_emitter_kinematics_massive
   procedure :: compute_emitter_kinematics_massless => &
      phs_fks_generator_compute_emitter_kinematics_massless
   procedure :: compute_emitter_kinematics_massive => &
      phs_fks_generator_compute_emitter_kinematics_massive
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_emitter_kinematics_massless &
      (generator, y, q0, uk_em, uk)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: y, q0
     real(default), intent(out) :: uk_em, uk
     real(default) :: k0_np1, q2
 
     k0_np1 = generator%E_gluon
     q2 = q0**2
 
     uk_em = (q2 - generator%mrec2 - two * q0 * k0_np1) / (two * (q0 - k0_np1 * (one - y)))
     uk = sqrt (uk_em**2 + k0_np1**2 + two * uk_em * k0_np1 * y)
   end subroutine phs_fks_generator_compute_emitter_kinematics_massless
 
   subroutine phs_fks_generator_compute_emitter_kinematics_massive &
       (generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: y
     integer, intent(in) :: em, i_phs
     real(default), intent(in) :: q0
     real(default), intent(inout) :: k0_em, uk_em, uk
     logical, intent(in) :: compute_jac
     real(default) :: k0_np1, q2, mrec2, m2
     real(default) :: k0_rec_max, k0_em_max, k0_rec, uk_rec
     real(default) :: z, z1, z2
 
     k0_np1 = generator%E_gluon
     q2 = q0**2
     mrec2 = generator%mrec2
     m2 = generator%m2(em)
 
     k0_rec_max = (q2 - m2 + mrec2) / (two * q0)
     k0_em_max = (q2 + m2 - mrec2)  /(two * q0)
     z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0
     z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0
     z = z2 - (z2 - z1) * (one + y) / two
     k0_em = k0_em_max - k0_np1 * z
     k0_rec = q0 - k0_np1 - k0_em
     uk_em = sqrt(k0_em**2 - m2)
     uk_rec = sqrt(k0_rec**2 - mrec2)
     uk = uk_rec
     if (compute_jac) &
          generator%real_kinematics%jac(i_phs)%jac = q0 * (z1 - z2) / four * k0_np1
     generator%real_kinematics%y_soft(i_phs) = &
        (two * q2 * z - q2 - mrec2 + m2) / (sqrt(k0_em_max**2 - m2) * q0) / two
   end subroutine phs_fks_generator_compute_emitter_kinematics_massive
 
 @ %def phs_fks_generator_compute_emitter_kinematics
 @
 <<phs fks: procedures>>=
   function recompute_xi_max (q0, mrec2, m2, y) result (xi_max)
     real(default) :: xi_max
     real(default), intent(in) :: q0, mrec2, m2, y
     real(default) :: q2, k0_np1_max, k0_rec_max
     real(default) :: z1, z2, z
     q2 = q0**2
     k0_rec_max = (q2 - m2 + mrec2) / (two * q0)
     z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0
     z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0
     z = z2 - (z2 - z1) * (one + y) / 2
     k0_np1_max = - (q2 * z**2 - two * q0 * k0_rec_max * z + mrec2) / (two * q0 * z * (one - z))
     xi_max = two * k0_np1_max / q0
   end function recompute_xi_max
 
 @ %def recompute_xi_max
 @
 <<phs fks: procedures>>=
   function compute_beta_massless (q2, k0_rec, uk_rec) result (beta)
     real(default), intent(in) :: q2, k0_rec, uk_rec
     real(default) :: beta
     beta = (q2 - (k0_rec + uk_rec)**2) / (q2 + (k0_rec + uk_rec)**2)
   end function compute_beta_massless
 
   function compute_beta_massive (q2, k0_rec, uk_rec, &
      k0_em_born, uk_em_born) result (beta)
     real(default), intent(in) :: q2, k0_rec, uk_rec
     real(default), intent(in) :: k0_em_born, uk_em_born
     real(default) :: beta
     real(default) :: k0_rec_born, uk_rec_born, alpha
     k0_rec_born = sqrt(q2) - k0_em_born
     uk_rec_born = uk_em_born
     alpha = (k0_rec + uk_rec) / (k0_rec_born + uk_rec_born)
     beta = (one - alpha**2) / (one + alpha**2)
   end function compute_beta_massive
 
 @ %def compute_beta
 @ The momentum of the radiated particle is computed according to
 \begin{equation}
   \label{eq:phs fks:compute k_n}
   \underline{k}_n = \frac{q^2 - M_{\rm{rec}}^2 -
     2q^0\underline{k}_{n+1}}{2(q^0 - \underline{k}_{n+1}(1-y))},
 \end{equation}
 with $k = k_n + k_{n+1}$ and $M_{\rm{rec}}^2 = k_{\rm{rec}}^2 =
 \left(q-k\right)^2$. Because of $\boldsymbol{\bar{k}}_n \parallel
 \boldsymbol{k}_n + \boldsymbol{k}_{n+1}$ we find $M_{\rm{rec}}^2 =
 \left(q-\bar{k}_n\right)^2$.
 Equation \ref{eq:phs fks: compute k_n} follows from the fact that
 $\left(\boldsymbol{k} - \boldsymbol{k}_n\right)^2 =
 \boldsymbol{k}_{n+1}^2$, which is equivalent to $\boldsymbol{k}_n
 \cdot \boldsymbol{k} = \frac{1}{2} \left(\underline{k}_n^2 +
   \underline{k}^2 - \underline{k}_{n+1}^2\right)$.\\
 $\boldsymbol{k}_n$ and $\boldsymbol{k}_{n+1}$ are obtained by first
 setting up vectors parallel to $\boldsymbol{\bar{k}}_n$,
 \begin{equation*}
   \boldsymbol{k}_n' = \underline{k}_n
   \frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, \quad \pmb{k}_{n+1}'
   = \underline{k}_{n+1}\frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n},
 \end{equation*}
 and then rotating these vectors by an amount of $\cos\psi_n =
 \frac{\boldsymbol{k}_n\cdot\pmb{k}}{\underline{k}_n \underline{k}}$.
 @ The emitted particle cannot have more momentum than the emitter has
 in the Born phase space. Thus, there is an upper bound for $\xi$,
 determined by the condition $k_{n+1}^0 = \underline{\bar{k}}_n$, which
 is equal to
 \begin{equation*}
 \xi_{\rm{max}} = \frac{2}{\underline{\bar{k}}_n}{q^0}.
 \end{equation*}
 <<phs fks: procedures>>=
   pure function get_xi_max_fsr_massless (p_born, q0, emitter) result (xi_max)
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: q0
     integer, intent(in) :: emitter
     real(default) :: xi_max
     real(default) :: uk_n_born
     uk_n_born = space_part_norm (p_born(emitter))
     xi_max = two * uk_n_born / q0
   end function get_xi_max_fsr_massless
 
 @ %def get_xi_max_fsr_massless
 @ The computation of $\xi_{\rm{max}}$ for massive emitters is described
 in arXiv:1202.0465. Let's recapitulate it here.
 
 We consider the Dalitz-domain created by $k_{n+1}^0$, $k_n^0$ and
 $k_{\rm{rec}}^0$ and introduce the parameterization
 \begin{equation*}
   k_n^0 = \bar{k}_n^0 - zk_{n+1}^0
 \end{equation*}
 Then, for each value of $z$, there exists a maximum value of
 $\underline{k}_{n+1}$ from which $\xi_{\rm{max}}$ can be extracted via
 $\xi_{\rm{max}} = 2k_{n+1}^0/q$. It is determined by the condition
 \begin{equation*}
   \underline{k}_{n+1} \pm \underline{k}_n \pm \underline{k}_{\rm{rec}} = 0.
 \end{equation*}
 This can be manipulated to yield
 \begin{equation*}
   \left(\underline{k}_{n+1}^2 + \underline{k}_n^2 -
   \underline{k}_{\rm{rec}}^2\right)^2 =
   4\underline{k}^2_{n+1}\underline{k}_n^2.
 \end{equation*}
 Here we can use $\underline{k}_n^2 = \left(k_n^0\right)^2 - m^2$ and
 $\underline{k}_{\rm{rec}}^2 = \left(q - k_n^0 - k_{n+1}^0\right)^2 -
 M_{\rm{rec}}^2$, as well as the above parameterization of $k_n^0$, to
 obtain
 \begin{equation*}
   4\underline{k}_{n+1}^2\left(2\underline{k}_{n+1}qz(1-z) +
   q^2z^2 - 2q\bar{k}_{\rm{rec}}^0z + M_{\rm{rec}}^2\right) = 0.
 \end{equation*}
 Solving for $k_{n+1}^0$ gives
 \begin{equation}
   k_{n+1}^0 = \frac{2q\bar{k}^0_{\rm{rec}}z - q^2z^2 - M_{\rm{rec}}^2}{2qz(1-z)}.
   \label{XiMaxMassive}
 \end{equation}
 It is still open how to compute $z$. For this, consider that the
 right-hand-side of equation (\ref{XiMaxMassive}) vanishes for
 \begin{equation*}
   z_{1,2} = \left(\bar{k}_{\rm{rec}}^0 \pm
   \sqrt{\left(\bar{k}_{\rm{rec}}^0\right)^2 - M_{\rm{rec}}^2}\right)/q,
 \end{equation*}
 which corresponds to the borders of the Dalitz-region where the gluon
 momentum vanishes. Thus we define
 \begin{equation*}
   z = z_2 - \frac{1}{2} (z_2 - z_1)(1+y).
 \end{equation*}
 <<phs fks: procedures>>=
   pure function get_xi_max_fsr_massive (p_born, q0, emitter, m2, y) result (xi_max)
     real(default) :: xi_max
     type(vector4_t), intent(in), dimension(:) :: p_born
     real(default), intent(in) :: q0
     integer, intent(in) :: emitter
     real(default), intent(in) :: m2, y
     real(default) :: mrec2
     real(default) :: k0_rec_max
     real(default) :: z, z1, z2
     real(default) :: k0_np1_max
     associate (p => p_born(emitter)%p)
        mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2
     end associate
     call compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max)
     z = z2 - (z2 - z1) * (one + y) / two
     k0_np1_max = - (q0**2 * z**2 - two * q0 * k0_rec_max * z + mrec2) &
        / (two * q0 * z * (one - z))
     xi_max = two * k0_np1_max / q0
   end function get_xi_max_fsr_massive
 
 @ %def get_xi_max_fsr_massive
 @
 <<phs fks: parameters>>=
   integer, parameter, public :: I_PLUS = 1
   integer, parameter, public :: I_MINUS = 2
 
 @ %def parameters
-@
+@ Computes $\xi_{\text{max}}$ in the case of ISR as documented in eq. \ref{eqn:xi_max_isr}.
 <<phs fks: procedures>>=
   function get_xi_max_isr (xb, y) result (xi_max)
     real(default) :: xi_max
     real(default), dimension(2), intent(in) :: xb
     real(default), intent(in) :: y
     xi_max = one - max (xi_max_isr_plus (xb(I_PLUS), y), xi_max_isr_minus (xb(I_MINUS), y))
+  contains
+    function xi_max_isr_plus (x, y)
+      real(default) :: xi_max_isr_plus
+      real(default), intent(in) :: x, y
+      real(default) :: deno
+      deno = sqrt ((one + x**2)**2 * (one - y)**2 + 16 * y * x**2) + (one - y) * (1 - x**2)
+      xi_max_isr_plus = two * (one + y) * x**2 / deno
+    end function xi_max_isr_plus
+
+    function xi_max_isr_minus (x, y)
+      real(default) :: xi_max_isr_minus
+      real(default), intent(in) :: x, y
+      real(default) :: deno
+      deno = sqrt ((one + x**2)**2 * (one + y)**2 - 16 * y * x**2) + (one + y) * (1 - x**2)
+      xi_max_isr_minus = two * (one - y) * x**2 / deno
+    end function xi_max_isr_minus
   end function get_xi_max_isr
 
 @ %def get_xi_max_isr
 @
 <<phs fks: procedures>>=
-  function xi_max_isr_plus (x, y)
-    real(default) :: xi_max_isr_plus
-    real(default), intent(in) :: x, y
-    real(default) :: deno
-    deno = sqrt ((one + x**2)**2 * (one - y)**2 + 16 * y * x**2) + (one - y) * (1 - x**2)
-    xi_max_isr_plus = two * (one + y) * x**2 / deno
-  end function xi_max_isr_plus
-
-  function xi_max_isr_minus (x, y)
-    real(default) :: xi_max_isr_minus
-    real(default), intent(in) :: x, y
-    real(default) :: deno
-    deno = sqrt ((one + x**2)**2 * (one + y)**2 - 16 * y * x**2) + (one + y) * (1 - x**2)
-    xi_max_isr_minus = two * (one - y) * x**2 / deno
-  end function xi_max_isr_minus
-
-
-@ %def xi_max_isr_plus, xi_max_isr_minus
-@
-<<phs fks: procedures>>=
   recursive function get_xi_max_isr_decay (p) result (xi_max)
      real(default) :: xi_max
      type(vector4_t), dimension(:), intent(in) :: p
      integer :: n_tot
      type(vector4_t), dimension(:), allocatable :: p_dec_new
      n_tot = size (p)
      if (n_tot == 3) then
         xi_max = xi_max_one_to_two (p(1), p(2), p(3))
      else
         allocate (p_dec_new (n_tot - 1))
         p_dec_new(1) = sum (p (3 : ))
         p_dec_new(2 : n_tot - 1) = p (3 : n_tot)
         xi_max = min (xi_max_one_to_two (p(1), p(2), sum(p(3 : ))), &
              get_xi_max_isr_decay (p_dec_new))
      end if
   contains
     function xi_max_one_to_two (p_in, p_out1, p_out2) result (xi_max)
       real(default) :: xi_max
       type(vector4_t), intent(in) :: p_in, p_out1, p_out2
       real(default) :: m_in, m_out1, m_out2
       m_in = p_in**1
       m_out1 = p_out1**1; m_out2 = p_out2**1
       xi_max = one - (m_out1 + m_out2)**2 / m_in**2
     end function xi_max_one_to_two
   end function get_xi_max_isr_decay
 
 @ %def get_xi_max_isr_decay
 @
 \subsection{Creation of the real phase space - ISR}
 <<phs fks: phs fks: TBP>>=
   procedure :: generate_isr => phs_fks_generate_isr
 <<phs fks: procedures>>=
   subroutine phs_fks_generate_isr (phs, i_phs, p_real)
     class(phs_fks_t), intent(inout) :: phs
     integer, intent(in) :: i_phs
     type(vector4_t), intent(inout), dimension(:) :: p_real
     type(vector4_t) :: p0, p1
     type(lorentz_transformation_t) :: lt
     real(default) :: sqrts_hat
     type(vector4_t), dimension(:), allocatable :: p_work
 
     associate (generator => phs%generator)
        select case (generator%n_in)
        case (1)
           allocate (p_work (1:generator%real_kinematics%p_born_cms%get_n_particles()), &
                source = generator%real_kinematics%p_born_cms%phs_point(1)%p)
           call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real)
           phs%config%cm_frame = .true.
        case (2)
           select case (generator%isr_kinematics%isr_mode)
           case (SQRTS_FIXED)
              allocate (p_work (1:generator%real_kinematics%p_born_cms%get_n_particles()), &
                   source = generator%real_kinematics%p_born_cms%phs_point(1)%p)
              call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real)
           case (SQRTS_VAR)
              allocate (p_work (1:generator%real_kinematics%p_born_lab%get_n_particles()), &
                   source = generator%real_kinematics%p_born_lab%phs_point(1)%p)
              call generator%generate_isr (i_phs, p_work, p_real)
           end select
        end select
        generator%real_kinematics%p_real_lab%phs_point(i_phs)%p = p_real
        if (.not. phs%config%cm_frame) then
           sqrts_hat = (p_real(1) + p_real(2))**1
           p0 = p_real(1) + p_real(2)
           lt = boost (p0, sqrts_hat)
           p1 = inverse(lt) * p_real(1)
           lt = lt * rotation_to_2nd (3, space_part (p1))
           phs%generator%real_kinematics%p_real_cms%phs_point(i_phs)%p = &
                inverse (lt) * p_real
        else
           phs%generator%real_kinematics%p_real_cms%phs_point(i_phs)%p = p_real
        end if
      end associate
   end subroutine phs_fks_generate_isr
 
 @ %def phs_fks_generate_isr
 @ The real phase space for an inital-state emission involved in a decay
 process is generated by first setting the gluon momentum like in the
 scattering case by using its angular coordinates $y$ and $\phi$ and then
 adjusting the gluon energy with $\xi$. The emitter momentum is kept
 identical to the Born case, i.e.  $p_{\rm{in}} = \bar{p}_{\rm{in}}$, so
 that after the emission it has momentum $p_{\rm{virt}} = p_{\rm{in}} -
 p_{\rm{g}}$ and invariant mass $m^2 = p_{\rm{virt}}^2$.  Note that the
 final state momenta have to remain on-shell, so that $p_1^2 =
 \bar{p}_1^2 = m_1^2$ and $p_2^2 = \bar{p}_2^2 = m_2^2$. Let $\Lambda$ be
 the boost from into the rest frame of the emitter after emission, i.e.
 $\Lambda p_{\rm{virt}} = \left(m, 0, 0, 0\right)$.  In this reference
 frame, the spatial components of the final-state momenta sum up to zero,
 and their magnitude is
 \begin{equation*}
   p = \frac{\sqrt {\lambda (m^2, m_1^2, m_2^2)}}{2m},
 \end{equation*}
 a fact already used in the evaluation of the phase space trees of
 [[phs_forest]].  Obviously, from this, the final-state energies can be
 deferred via $E_i^2 = m_i^2 - p^2$.  In the next step, the $p_{1,2}$ are
 set up as vectors $(E,0,0,\pm p)$ along the z-axis and then rotated
 about the same azimuthal and polar angles as in the Born system.
 Finally, the momenta are boosted out of the rest frame by multiplying
 with $\Lambda$.
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_isr_fixed_beam_energy => phs_fks_generator_generate_isr_fixed_beam_energy
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_isr_fixed_beam_energy (generator, i_phs, p_born, p_real)
      class(phs_fks_generator_t), intent(inout) :: generator
      integer, intent(in) :: i_phs
      type(vector4_t), intent(in), dimension(:) :: p_born
      type(vector4_t), intent(inout), dimension(:) :: p_real
      real(default) :: xi_max, xi, y, phi
      integer :: nlegborn, nlegreal, i
      real(default) :: k0_np1
      real(default) :: msq_in
      type(vector4_t) :: p_virt
      real(default) :: jac_real
 
      associate (rad_var => generator%real_kinematics)
         xi_max = rad_var%xi_max(i_phs)
         xi = rad_var%xi_tilde * xi_max
         y = rad_var%y(i_phs)
         phi = rad_var%phi
         rad_var%y_soft(i_phs) = y
      end associate
 
      nlegborn = size (p_born)
      nlegreal = nlegborn + 1
 
      msq_in = sum (p_born(1:generator%n_in))**2
      generator%real_kinematics%jac(i_phs)%jac = one
 
      p_real(1) = p_born(1)
      if (generator%n_in > 1) p_real(2) = p_born(2)
      k0_np1 = zero
      do i = 1, generator%n_in
         k0_np1 = k0_np1 + p_real(i)%p(0) * xi / two
      end do
      p_real(nlegreal)%p(0) = k0_np1
      p_real(nlegreal)%p(1) = k0_np1 * sqrt(one - y**2) * sin(phi)
      p_real(nlegreal)%p(2) = k0_np1 * sqrt(one - y**2) * cos(phi)
      p_real(nlegreal)%p(3) = k0_np1 * y
 
      p_virt = sum (p_real(1:generator%n_in)) - p_real(nlegreal)
 
      jac_real = one
      call generate_on_shell_decay (p_virt, &
           p_born(generator%n_in + 1 : nlegborn), p_real(generator%n_in + 1 : nlegreal - 1), &
           1, msq_in, jac_real)
 
      associate (jac => generator%real_kinematics%jac(i_phs))
         jac%jac(1) = jac_real
         jac%jac(2) = one
      end associate
 
   end subroutine phs_fks_generator_generate_isr_fixed_beam_energy
 
 @ %def phs_fks_generator_generate_isr_fixed_beam_energy
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_isr_factorized => phs_fks_generator_generate_isr_factorized
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_isr_factorized (generator, i_phs, emitter, p_born, p_real)
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: i_phs, emitter
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(inout), dimension(:) :: p_real
     type(vector4_t), dimension(3) :: p_tmp_born
     type(vector4_t), dimension(4) :: p_tmp_real
     type(vector4_t) :: p_top
     type(lorentz_transformation_t) :: boost_to_rest_frame
     integer, parameter :: nlegreal = 7 !!! Factorized phase space so far only required for ee -> bwbw
 
     p_tmp_born = vector4_null; p_tmp_real = vector4_null
     p_real(1:2) = p_born(1:2)
     if (emitter == THR_POS_B) then
        p_top = p_born (THR_POS_WP) + p_born (THR_POS_B)
        p_tmp_born(2) = p_born (THR_POS_WP)
        p_tmp_born(3) = p_born (THR_POS_B)
     else if (emitter == THR_POS_BBAR) then
        p_top = p_born (THR_POS_WM) + p_born (THR_POS_BBAR)
        p_tmp_born(2) = p_born (THR_POS_WM)
        p_tmp_born(3) = p_born (THR_POS_BBAR)
     else
        call msg_fatal ("Threshold computation requires emitters to be at position 5 and 6 " // &
           "Please check if your process specification fulfills this requirement.")
     end if
     p_tmp_born (1) = p_top
     boost_to_rest_frame = inverse (boost (p_top, p_top**1))
     p_tmp_born = boost_to_rest_frame * p_tmp_born
     call generator%compute_xi_max_isr_factorized (i_phs, p_tmp_born)
     call generator%generate_isr_fixed_beam_energy (i_phs, p_tmp_born, p_tmp_real)
     p_tmp_real = inverse (boost_to_rest_frame) * p_tmp_real
     if (emitter == THR_POS_B) then
        p_real(THR_POS_WP) = p_tmp_real(2)
        p_real(THR_POS_B) = p_tmp_real(3)
        p_real(THR_POS_WM) = p_born(THR_POS_WM)
        p_real(THR_POS_BBAR) = p_born(THR_POS_BBAR)
     !!! Exception has been handled above
     else
        p_real(THR_POS_WM) = p_tmp_real(2)
        p_real(THR_POS_BBAR) = p_tmp_real(3)
        p_real(THR_POS_WP) = p_born(THR_POS_WP)
        p_real(THR_POS_B) = p_born(THR_POS_B)
     end if
     p_real(nlegreal) = p_tmp_real(4)
   end subroutine phs_fks_generator_generate_isr_factorized
 
 @ %def phs_fks_generator_generate_isr_factorized
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_isr => phs_fks_generator_generate_isr
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_isr (generator, i_phs, p_born, p_real)
     !!! Important: Import momenta in the lab frame
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: i_phs
     type(vector4_t), intent(in) , dimension(:) :: p_born
     type(vector4_t), intent(inout), dimension(:) :: p_real
     real(default) :: xi_max, xi_tilde, xi, y, phi
     integer :: nlegborn, nlegreal
     real(default) :: sqrts_real
     real(default) :: k0_np1
     type(lorentz_transformation_t) :: lambda_transv, lambda_longit, lambda_longit_inv
     real(default) :: x_plus, x_minus, xb_plus, xb_minus
     real(default) :: onemy, onepy
     integer :: i
     real(default) :: xi_plus, xi_minus
     real(default) :: beta_gamma
     type(vector3_t) :: beta_vec
 
     associate (rad_var => generator%real_kinematics)
        xi_max = rad_var%xi_max(i_phs)
        xi_tilde = rad_var%xi_tilde
        xi = xi_tilde * xi_max
        y = rad_var%y(i_phs)
        onemy = one - y; onepy = one + y
        phi = rad_var%phi
        rad_var%y_soft(i_phs) = y
     end associate
 
     nlegborn = size (p_born)
     nlegreal = nlegborn + 1
     generator%isr_kinematics%sqrts_born = (p_born(1) + p_born(2))**1
 
     !!! Initial state real momenta
     xb_plus = generator%isr_kinematics%x(I_PLUS)
     xb_minus = generator%isr_kinematics%x(I_MINUS)
     x_plus = xb_plus / sqrt(one - xi) * sqrt ((two - xi * onemy) / (two - xi * onepy))
     x_minus = xb_minus / sqrt(one - xi) * sqrt ((two - xi * onepy) / (two - xi * onemy))
     xi_plus = xi_tilde * (one - xb_plus)
     xi_minus = xi_tilde * (one - xb_minus)
     p_real(I_PLUS) = x_plus / xb_plus * p_born(I_PLUS)
     p_real(I_MINUS) = x_minus / xb_minus * p_born(I_MINUS)
     generator%isr_kinematics%z(I_PLUS) = x_plus / xb_plus
     generator%isr_kinematics%z(I_MINUS) = x_minus / xb_minus
     generator%isr_kinematics%z_coll(I_PLUS) = one / (one - xi_plus)
     generator%isr_kinematics%z_coll(I_MINUS) = one / (one - xi_minus)
 
     !!! Create radiation momentum
     sqrts_real = generator%isr_kinematics%sqrts_born / sqrt (one - xi)
     k0_np1 = sqrts_real * xi / two
     p_real(nlegreal)%p(0) = k0_np1
     p_real(nlegreal)%p(1) = k0_np1 * sqrt (one - y**2) * sin(phi)
     p_real(nlegreal)%p(2) = k0_np1 * sqrt (one - y**2) * cos(phi)
     p_real(nlegreal)%p(3) = k0_np1 * y
 
     call get_boost_parameters (p_real, beta_gamma, beta_vec)
     lambda_longit = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .true.)
     p_real(nlegreal) = lambda_longit * p_real(nlegreal)
 
     call get_boost_parameters (p_born, beta_gamma, beta_vec)
     lambda_longit = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .false.)
     forall (i = 3 : nlegborn)  p_real(i) = lambda_longit * p_born(i)
 
     lambda_transv = create_transversal_boost (p_real(nlegreal), xi, sqrts_real)
     forall (i = 3 : nlegborn)  p_real(i) = lambda_transv * p_real(i)
 
     lambda_longit_inv = create_longitudinal_boost (beta_gamma, beta_vec, inverse = .true.)
     forall (i = 3 : nlegborn)  p_real(i) = lambda_longit_inv * p_real(i)
 
     !!! Compute jacobians
     associate (jac => generator%real_kinematics%jac(i_phs))
        !!! Additional 1 / (1 - xi) factor because in the real jacobian,
        !!! there is s_real in the numerator
        !!! We also have to adapt the flux factor, which is 1/2s_real for the real component
        !!! The reweighting factor is s_born / s_real, cancelling the (1-x) factor from above
        jac%jac(1) = one / (one - xi)
        jac%jac(2) = one
        jac%jac(3) = one / (one - xi_plus)**2
        jac%jac(4) = one / (one - xi_minus)**2
     end associate
   contains
     subroutine get_boost_parameters (p, beta_gamma, beta_vec)
        type(vector4_t), intent(in), dimension(:) :: p
        real(default), intent(out) :: beta_gamma
        type(vector3_t), intent(out) :: beta_vec
        beta_vec = (p(1)%p(1:3) + p(2)%p(1:3)) / (p(1)%p(0) + p(2)%p(0))
        beta_gamma = beta_vec**1 / sqrt (one - beta_vec**2)
        beta_vec = beta_vec / beta_vec**1
     end subroutine get_boost_parameters
 
     function create_longitudinal_boost (beta_gamma, beta_vec, inverse) result (lambda)
        real(default), intent(in) :: beta_gamma
        type(vector3_t), intent(in) :: beta_vec
        logical, intent(in) :: inverse
        type(lorentz_transformation_t) :: lambda
        if (inverse) then
           lambda = boost (beta_gamma, beta_vec)
        else
           lambda = boost (-beta_gamma, beta_vec)
        end if
     end function create_longitudinal_boost
 
     function create_transversal_boost (p_rad, xi, sqrts_real) result (lambda)
        type(vector4_t), intent(in) :: p_rad
        real(default), intent(in) :: xi, sqrts_real
        type(lorentz_transformation_t) :: lambda
        type(vector3_t) :: vec_transverse
        real(default) :: pt2, beta, beta_gamma
        pt2 = transverse_part (p_rad)**2
        beta = one / sqrt (one + sqrts_real**2 * (one - xi) / pt2)
        beta_gamma = beta / sqrt (one - beta**2)
        vec_transverse%p(1:2) = p_rad%p(1:2)
        vec_transverse%p(3) = zero
        vec_transverse = normalize (vec_transverse)
        lambda = boost (-beta_gamma, vec_transverse)
     end function create_transversal_boost
   end subroutine phs_fks_generator_generate_isr
 
 @ %def phs_fks_generator_generate_isr
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: set_sqrts_hat => phs_fks_generator_set_sqrts_hat
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: sqrts
     generator%sqrts = sqrts
   end subroutine phs_fks_generator_set_sqrts_hat
 
 @ %def phs_fks_generator_set_sqrts_hat
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: set_emitters => phs_fks_generator_set_emitters
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_set_emitters (generator, emitters)
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in), dimension(:), allocatable ::  emitters
     allocate (generator%emitters (size (emitters)))
     generator%emitters = emitters
   end subroutine phs_fks_generator_set_emitters
 
 @ %def phs_fks_generator_set_emitters
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: setup_masses => phs_fks_generator_setup_masses
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_setup_masses (generator, n_tot)
     class (phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: n_tot
     if (.not. allocated (generator%m2)) then
        allocate (generator%is_massive (n_tot))
        allocate (generator%m2 (n_tot))
        generator%is_massive = .false.
        generator%m2 = zero
     end if
   end subroutine phs_fks_generator_setup_masses
 
 @ %def phs_fks_generator_setup_masses
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: set_xi_and_y_bounds => phs_fks_generator_set_xi_and_y_bounds
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_set_xi_and_y_bounds (generator, xi_min, y_max)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: xi_min, y_max
     generator%xi_min = xi_min
     generator%y_max = y_max
   end subroutine phs_fks_generator_set_xi_and_y_bounds
 
 @ %def phs_fks_generator_set_xi_and_y_bounds
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: set_isr_kinematics => phs_fks_generator_set_isr_kinematics
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_set_isr_kinematics (generator, p)
     class(phs_fks_generator_t), intent(inout) :: generator
     type(vector4_t), dimension(2), intent(in) :: p
 
     generator%isr_kinematics%x = p%p(0) / generator%isr_kinematics%beam_energy
   end subroutine phs_fks_generator_set_isr_kinematics
 
 @ %def phs_fks_generator_set_isr_kinematics
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_radiation_variables => &
      phs_fks_generator_generate_radiation_variables
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_radiation_variables &
      (generator, r_in, p_born, phs_identifiers, threshold)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in), dimension(:) :: r_in
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     logical, intent(in), optional :: threshold
 
     associate (rad_var => generator%real_kinematics)
        rad_var%phi = r_in (I_PHI) * twopi
        select case (generator%mode)
        case (GEN_REAL_PHASE_SPACE)
           rad_var%jac_rand = twopi
           call generator%compute_y_real_phs (r_in(I_Y), p_born, phs_identifiers, &
                rad_var%jac_rand, rad_var%y, threshold)
        case (GEN_SOFT_MISMATCH)
           rad_var%jac_mismatch = twopi
           call generator%compute_y_mismatch (r_in(I_Y), rad_var%jac_mismatch, &
                rad_var%y_mismatch, rad_var%y_soft)
        case default
           call generator%compute_y_test (rad_var%y)
        end select
        call generator%compute_xi_tilde (r_in(I_XI))
        call generator%set_masses (p_born, phs_identifiers)
     end associate
   end subroutine phs_fks_generator_generate_radiation_variables
 
 @ %def phs_fks_generator_generate_radiation_variables
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_xi_ref_momenta => phs_fks_generator_compute_xi_ref_momenta
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_xi_ref_momenta &
          (generator, p_born, resonance_contributors)
     class(phs_fks_generator_t), intent(inout) :: generator
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(resonance_contributors_t), intent(in), dimension(:), optional &
        :: resonance_contributors
     integer :: i_con, n_contributors
     if (present (resonance_contributors)) then
        n_contributors = size (resonance_contributors)
        if (.not. allocated (generator%resonance_contributors)) &
           allocate (generator%resonance_contributors (n_contributors))
        do i_con = 1, n_contributors
           generator%real_kinematics%xi_ref_momenta(i_con) = &
                get_resonance_momentum (p_born, resonance_contributors(i_con)%c)
           generator%resonance_contributors(i_con) = resonance_contributors(i_con)
        end do
     else
        generator%real_kinematics%xi_ref_momenta(1) = sum (p_born(1:generator%n_in))
     end if
   end subroutine phs_fks_generator_compute_xi_ref_momenta
 
 @ %def phs_fks_generator_compute_xi_ref_momenta
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_xi_ref_momenta_threshold &
        => phs_fks_generator_compute_xi_ref_momenta_threshold
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_xi_ref_momenta_threshold (generator, p_born)
     class(phs_fks_generator_t), intent(inout) :: generator
     type(vector4_t), intent(in), dimension(:) :: p_born
     generator%real_kinematics%xi_ref_momenta(1) = p_born(THR_POS_WP) + p_born(THR_POS_B)
     generator%real_kinematics%xi_ref_momenta(2) = p_born(THR_POS_WM) + p_born(THR_POS_BBAR)
   end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold
 
 @ %def phs_fks_generator_compute_xi_ref_momenta
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_cms_energy => phs_fks_generator_compute_cms_energy
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_cms_energy (generator, p_born)
     class(phs_fks_generator_t), intent(inout) :: generator
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t) :: p_sum
     p_sum = sum (p_born (1 : generator%n_in))
     generator%real_kinematics%cms_energy2 = p_sum**2
   end subroutine phs_fks_generator_compute_cms_energy
 
 @ %def phs_fks_generator_compute_cms_energy
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_xi_max => phs_fks_generator_compute_xi_max
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_xi_max (generator, emitter, &
        i_phs, p, xi_max, i_con, y_in)
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: i_phs, emitter
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), intent(out) :: xi_max
     integer, intent(in), optional :: i_con
     real(default), intent(in), optional :: y_in
     real(default) :: q0
     type(vector4_t), dimension(:), allocatable :: pp, pp_decay
     type(vector4_t) :: p_res
     type(lorentz_transformation_t) :: L_to_resonance
     real(default) :: y
     if (.not. any (generator%emitters == emitter)) return
     allocate (pp (size (p)))
     associate (rad_var => generator%real_kinematics)
        if (present (i_con)) then
           q0 = rad_var%xi_ref_momenta(i_con)**1
        else
           q0 = energy (sum (p(1:generator%n_in)))
        end if
        if (present (y_in)) then
           y = y_in
        else
           y = rad_var%y(i_phs)
        end if
        if (present (i_con)) then
           p_res = rad_var%xi_ref_momenta(i_con)
           L_to_resonance = inverse (boost (p_res, q0))
           pp = L_to_resonance * p
        else
           pp = p
        end if
        if (emitter <= generator%n_in) then
           select case (generator%isr_kinematics%isr_mode)
           case (SQRTS_FIXED)
              if (generator%n_in > 1) then
                 allocate (pp_decay (size (pp) - 1))
              else
                 allocate (pp_decay (size (pp)))
              end if
              pp_decay (1) = sum (pp(1:generator%n_in))
              pp_decay (2 : ) = pp (generator%n_in + 1 : )
              xi_max = get_xi_max_isr_decay (pp_decay)
              deallocate (pp_decay)
           case (SQRTS_VAR)
              xi_max = get_xi_max_isr (generator%isr_kinematics%x, y)
           end select
        else
           if (generator%is_massive(emitter)) then
              xi_max = get_xi_max_fsr (pp, q0, emitter, generator%m2(emitter), y)
           else
              xi_max = get_xi_max_fsr (pp, q0, emitter)
           end if
        end if
        deallocate (pp)
     end associate
   end subroutine phs_fks_generator_compute_xi_max
 
 @ %def phs_fks_generator_compute_xi_max
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_xi_max_isr_factorized &
      => phs_fks_generator_compute_xi_max_isr_factorized
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_xi_max_isr_factorized &
      (generator, i_phs, p)
     class(phs_fks_generator_t), intent(inout) :: generator
     integer, intent(in) :: i_phs
     type(vector4_t), intent(in), dimension(:) :: p
     generator%real_kinematics%xi_max(i_phs) = get_xi_max_isr_decay (p)
   end subroutine phs_fks_generator_compute_xi_max_isr_factorized
 
 @ %def phs_fks_generator_compute_xi_max_isr_factorized
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: set_masses => phs_fks_generator_set_masses
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_set_masses (generator, p, phs_identifiers)
     class(phs_fks_generator_t), intent(inout) :: generator
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     type(vector4_t), intent(in), dimension(:) :: p
     integer :: emitter, i_phs
     do i_phs = 1, size (phs_identifiers)
        emitter = phs_identifiers(i_phs)%emitter
        if (any (generator%emitters == emitter) .and. emitter > 0) then
           if (generator%is_massive (emitter) .and. emitter > generator%n_in) &
              generator%m2(emitter) = p(emitter)**2
        end if
     end do
   end subroutine phs_fks_generator_set_masses
 
 @ %def phs_fhs_generator_set_masses
 @
 <<phs fks: public>>=
   public :: compute_y_from_emitter
 <<phs fks: procedures>>=
   subroutine compute_y_from_emitter (r_y, p, n_in, emitter, massive, &
          y_max, jac_rand, y, contributors, threshold)
     real(default), intent(in) :: r_y
     type(vector4_t), intent(in), dimension(:) :: p
     integer, intent(in) :: n_in
     integer, intent(in) :: emitter
     logical, intent(in) :: massive
     real(default), intent(in) :: y_max
     real(default), intent(inout) :: jac_rand
     real(default), intent(out) :: y
     integer, intent(in), dimension(:), allocatable, optional :: contributors
     logical, intent(in), optional :: threshold
     logical :: thr, resonance
     type(vector4_t) :: p_res, p_em
     real(default) :: q0
     type(lorentz_transformation_t) :: boost_to_resonance
     integer :: i
     real(default) :: beta, one_m_beta, one_p_beta
     thr = .false.; if (present (threshold)) thr = threshold
     p_res = vector4_null
     if (present (contributors)) then
        resonance = allocated (contributors)
     else
        resonance = .false.
     end if
     if (massive) then
        if (resonance) then
           do i = 1, size (contributors)
              p_res = p_res + p(contributors(i))
           end do
        else if (thr) then
           p_res = p(ass_boson(thr_leg(emitter))) + p(ass_quark(thr_leg(emitter)))
        else
           p_res = sum (p(1:n_in))
        end if
        q0 = p_res**1
        boost_to_resonance = inverse (boost (p_res, q0))
        p_em = boost_to_resonance * p(emitter)
        beta = beta_emitter (q0, p_em)
        one_m_beta = one - beta
        one_p_beta = one + beta
        y = one / beta * (one - one_p_beta * &
               exp ( - r_y * log(one_p_beta / one_m_beta)))
        jac_rand = jac_rand * &
               (one - beta * y) * log(one_p_beta / one_m_beta) / beta
     else
        y = (one - two * r_y) * y_max
        jac_rand = jac_rand * 3 * (one - y**2)
        y = 1.5_default * (y - y**3 / 3)
     end if
   end subroutine compute_y_from_emitter
 
 @ %def compute_y_from_emitter
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_y_real_phs => phs_fks_generator_compute_y_real_phs
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_y_real_phs (generator, r_y, p, phs_identifiers, &
        jac_rand, y, threshold)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: r_y
     type(vector4_t), intent(in), dimension(:) :: p
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     real(default), intent(inout), dimension(:) :: jac_rand
     real(default), intent(out), dimension(:) :: y
     logical, intent(in), optional :: threshold
     real(default) :: beta, one_p_beta, one_m_beta
     type(lorentz_transformation_t) :: boost_to_resonance
     real(default) :: q0
     type(vector4_t) :: p_res, p_em
     integer :: i, i_phs, emitter
     logical :: thr
     logical :: construct_massive_fsr
     construct_massive_fsr = .false.
     thr = .false.; if (present (threshold)) thr = threshold
     do i_phs = 1, size (phs_identifiers)
        emitter = phs_identifiers(i_phs)%emitter
        !!! We need this additional check because of decay phase spaces
        !!! t -> bW has a massive emitter at position 1, which should
        !!! not be treated here.
        construct_massive_fsr = emitter > generator%n_in
        if (construct_massive_fsr) construct_massive_fsr = &
             construct_massive_fsr .and. generator%is_massive (emitter)
        call compute_y_from_emitter (r_y, p, generator%n_in, emitter, construct_massive_fsr, &
             generator%y_max, jac_rand(i_phs), y(i_phs), &
             phs_identifiers(i_phs)%contributors, threshold)
     end do
   end subroutine phs_fks_generator_compute_y_real_phs
 
 @ %def phs_fks_generator_compute_y_real_phs
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_y_mismatch => phs_fks_generator_compute_y_mismatch
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_y_mismatch (generator, r_y, jac_rand, y, y_soft)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: r_y
     real(default), intent(inout) :: jac_rand
     real(default), intent(out) :: y
     real(default), intent(out), dimension(:) :: y_soft
     y = (one - two * r_y) * generator%y_max
     jac_rand = jac_rand * 3 * (one - y**2)
     y = 1.5_default * (y - y**3 / 3)
     y_soft = y
   end subroutine phs_fks_generator_compute_y_mismatch
 
 @ %def phs_fks_generator_compute_y_mismatch
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_y_test => phs_fks_generator_compute_y_test
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_compute_y_test (generator, y)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(out), dimension(:):: y
     select case (generator%mode)
     case (GEN_SOFT_LIMIT_TEST)
        y = y_test_soft
     case (GEN_COLL_LIMIT_TEST)
        y = y_test_coll
     case (GEN_ANTI_COLL_LIMIT_TEST)
        y = - y_test_coll
     case (GEN_SOFT_COLL_LIMIT_TEST)
        y = y_test_coll
     case (GEN_SOFT_ANTI_COLL_LIMIT_TEST)
        y = - y_test_coll
     end select
   end subroutine phs_fks_generator_compute_y_test
 
 @ %def phs_fks_generator_compute_y_test
 @
 <<phs fks: public>>=
   public :: beta_emitter
 <<phs fks: procedures>>=
   pure function beta_emitter (q0, p) result (beta)
     real(default), intent(in) :: q0
     type(vector4_t), intent(in) :: p
     real(default) :: beta
     real(default) :: m2, mrec2, k0_max
     m2 = p**2
     mrec2 = (q0 - p%p(0))**2 - p%p(1)**2 - p%p(2)**2 - p%p(3)**2
     k0_max = (q0**2 - mrec2 + m2) / (two * q0)
     beta = sqrt(one - m2 / k0_max**2)
   end function beta_emitter
 
 @ %def beta_emitter
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: compute_xi_tilde => phs_fks_generator_compute_xi_tilde
 <<phs fks: procedures>>=
   pure subroutine phs_fks_generator_compute_xi_tilde (generator, r)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: r
     real(default) :: deno
     associate (rad_var => generator%real_kinematics)
        select case (generator%mode)
        case (GEN_REAL_PHASE_SPACE)
           if (generator%singular_jacobian) then
              rad_var%xi_tilde = (one - generator%xi_min) - (one - r)**2 * &
                 (one - two * generator%xi_min)
              rad_var%jac_rand = rad_var%jac_rand * two * (one - r) * &
                 (one - two * generator%xi_min)
           else
              rad_var%xi_tilde = generator%xi_min + r * (one - generator%xi_min)
              rad_var%jac_rand = rad_var%jac_rand * (one - generator%xi_min)
           end if
        case (GEN_SOFT_MISMATCH)
           deno = one - r
           if (deno < tiny_13) deno = tiny_13
           rad_var%xi_mismatch = generator%xi_min + r / deno
           rad_var%jac_mismatch = rad_var%jac_mismatch / deno**2
        case (GEN_SOFT_LIMIT_TEST)
           rad_var%xi_tilde = r * two * xi_tilde_test_soft
           rad_var%jac_rand = two * xi_tilde_test_soft
        case (GEN_COLL_LIMIT_TEST)
           rad_var%xi_tilde = xi_tilde_test_coll
           rad_var%jac_rand = xi_tilde_test_coll
        case (GEN_ANTI_COLL_LIMIT_TEST)
           rad_var%xi_tilde = xi_tilde_test_coll
           rad_var%jac_rand = xi_tilde_test_coll
        case (GEN_SOFT_COLL_LIMIT_TEST)
           rad_var%xi_tilde = r * two * xi_tilde_test_soft
           rad_var%jac_rand = two * xi_tilde_test_soft
        case (GEN_SOFT_ANTI_COLL_LIMIT_TEST)
           rad_var%xi_tilde = r * two * xi_tilde_test_soft
           rad_var%jac_rand = two * xi_tilde_test_soft
        end select
     end associate
   end subroutine phs_fks_generator_compute_xi_tilde
 
 @ %def phs_fks_generator_compute_xi_tilde
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: prepare_generation => phs_fks_generator_prepare_generation
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_prepare_generation (generator, r_in, i_phs, &
      emitter, p_born, phs_identifiers, contributors, i_con)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), dimension(3), intent(in) :: r_in
     integer, intent(in) :: i_phs, emitter
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
     type(resonance_contributors_t), intent(in), dimension(:), optional :: contributors
     integer, intent(in), optional :: i_con
     call generator%generate_radiation_variables (r_in, p_born, phs_identifiers)
     call generator%compute_xi_ref_momenta (p_born, contributors)
     call generator%compute_xi_max (emitter, i_phs, p_born, &
          generator%real_kinematics%xi_max(i_phs), i_con = i_con)
   end subroutine phs_fks_generator_prepare_generation
 
 @ %def phs_fks_generator_prepare_generation
 @ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and
 generate an FSR phase space. Note that the flag [[supply\_xi\_max]] is
 set to [[.false.]] because it is assumed that the upper bound on [[xi]]
 has already been taken into account during its generation.
 <<phs fks: phs fks generator: TBP>>=
   procedure :: generate_fsr_from_xi_and_y => &
      phs_fks_generator_generate_fsr_from_xi_and_y
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_generate_fsr_from_xi_and_y (generator, xi, y, &
      phi, emitter, i_phs, p_born, p_real)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: xi, y, phi
     integer, intent(in) :: emitter, i_phs
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(inout), dimension(:) :: p_real
     associate (rad_var => generator%real_kinematics)
        rad_var%supply_xi_max = .false.
        rad_var%xi_tilde = xi
        rad_var%y(i_phs) = y
        rad_var%phi = phi
     end associate
     call generator%set_sqrts_hat (p_born(1)%p(0) + p_born(2)%p(0))
     call generator%generate_fsr (emitter, i_phs, p_born, p_real)
   end subroutine phs_fks_generator_generate_fsr_from_xi_and_y
 
 @ %def phs_fks_generator_generate_fsr_from_xi_and_y
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: get_radiation_variables => &
      phs_fks_generator_get_radiation_variables
 <<phs fks: procedures>>=
   pure subroutine phs_fks_generator_get_radiation_variables (generator, &
      i_phs, xi, y, phi)
     class(phs_fks_generator_t), intent(in) :: generator
     integer, intent(in) :: i_phs
     real(default), intent(out) :: xi, y
     real(default), intent(out), optional :: phi
     associate (rad_var => generator%real_kinematics)
        xi = rad_var%xi_max(i_phs) * rad_var%xi_tilde
        y = rad_var%y(i_phs)
        if (present (phi)) phi = rad_var%phi
     end associate
   end subroutine phs_fks_generator_get_radiation_variables
 
 @ %def phs_fks_generator_get_radiation_variables
 @
 <<phs fks: phs fks generator: TBP>>=
   procedure :: write => phs_fks_generator_write
 <<phs fks: procedures>>=
   subroutine phs_fks_generator_write (generator, unit)
     class(phs_fks_generator_t), intent(in) :: generator
     integer, intent(in), optional :: unit
     integer :: u
     type(string_t) :: massive_phsp
     u = given_output_unit (unit); if (u < 0) return
     if (generator%massive_phsp) then
        massive_phsp = " massive "
     else
        massive_phsp = " massless "
     end if
     write (u, "(A)") char ("This is a generator for a" &
          // massive_phsp // "phase space")
     if (associated (generator%real_kinematics)) then
        call generator%real_kinematics%write ()
     else
        write (u, "(A)") "Warning: There are no real " // &
             "kinematics associated with this generator"
     end if
     call write_separator (u)
     write (u, "(A," // FMT_17 // ",1X)") "sqrts: ", generator%sqrts
     write (u, "(A," // FMT_17 // ",1X)") "E_gluon: ", generator%E_gluon
     write (u, "(A," // FMT_17 // ",1X)") "mrec2: ", generator%mrec2
   end subroutine phs_fks_generator_write
 
 @ %def phs_fks_generator_write
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: compute_isr_kinematics => phs_fks_compute_isr_kinematics
 <<phs fks: procedures>>=
   subroutine phs_fks_compute_isr_kinematics (phs, r)
     class(phs_fks_t), intent(inout) :: phs
     real(default), intent(in) :: r
     if (.not. phs%config%cm_frame) then
        call phs%generator%compute_isr_kinematics (r, phs%lt_cm_to_lab * phs%phs_wood_t%p)
     else
        call phs%generator%compute_isr_kinematics (r, phs%phs_wood_t%p)
     end if
   end subroutine phs_fks_compute_isr_kinematics
 
 @ %def phs_fks_compute_isr_kinematics
 @
 <<phs fks: phs fks: TBP>>=
   procedure :: final => phs_fks_final
 <<phs fks: procedures>>=
   subroutine phs_fks_final (object)
     class(phs_fks_t), intent(inout) :: object
     call phs_forest_final (object%forest)
     call object%generator%final ()
   end subroutine phs_fks_final
 
 @ %def phs_fks_final
 @
 <<phs fks: public>>=
   public :: get_filtered_resonance_histories
 <<phs fks: procedures>>=
   subroutine filter_particles_from_resonances (res_hist, exclusion_list, &
     model, res_hist_filtered)
     type(resonance_history_t), intent(in), dimension(:) :: res_hist
     type(string_t), intent(in), dimension(:) :: exclusion_list
     type(model_t), intent(in) :: model
     type(resonance_history_t), intent(out), dimension(:), allocatable :: res_hist_filtered
     integer :: i_hist, i_flv, i_new, n_orig
     logical, dimension(size (res_hist)) :: to_filter
     type(flavor_t) :: flv
     to_filter = .false.
     n_orig = size (res_hist)
     do i_flv = 1, size (exclusion_list)
        call flv%init (exclusion_list (i_flv), model)
        do i_hist = 1, size (res_hist)
           if (res_hist(i_hist)%has_flavor (flv)) to_filter (i_hist) = .true.
        end do
     end do
     allocate (res_hist_filtered (n_orig - count (to_filter)))
     i_new = 1
     do i_hist = 1, size (res_hist)
        if (.not. to_filter (i_hist)) then
           res_hist_filtered (i_new) = res_hist (i_hist)
           i_new = i_new + 1
        end if
     end do
   end subroutine filter_particles_from_resonances
 
 @ %def filter_particles_from_resonances
 @
 <<phs fks: procedures>>=
   subroutine clean_resonance_histories (res_hist, n_in, flv, res_hist_clean, success)
     type(resonance_history_t), intent(in), dimension(:) :: res_hist
     integer, intent(in) :: n_in
     integer, intent(in), dimension(:) :: flv
     type(resonance_history_t), intent(out), dimension(:), allocatable :: res_hist_clean
     logical, intent(out) :: success
     integer :: i_hist
     type(resonance_history_t), dimension(:), allocatable :: res_hist_colored, res_hist_contracted
 
     if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_init")
     if (debug_active (D_SUBTRACTION)) then
        call msg_debug (D_SUBTRACTION, "Original resonances:")
        do i_hist = 1, size(res_hist)
           call res_hist(i_hist)%write ()
        end do
     end if
 
     call remove_uncolored_resonances ()
     call contract_resonances (res_hist_colored, res_hist_contracted)
     call remove_subresonances (res_hist_contracted, res_hist_clean)
     !!! Here, we are still not sure whether we actually would rather use
     !!! call remove_multiple_resonances (res_hist_contracted, res_hist_clean)
     if (debug_active (D_SUBTRACTION)) then
        call msg_debug (D_SUBTRACTION, "Resonances after removing uncolored and duplicates: ")
        do i_hist = 1, size (res_hist_clean)
           call res_hist_clean(i_hist)%write ()
        end do
     end if
     if (size (res_hist_clean) == 0) then
        call msg_warning ("No resonances found. Proceed in usual FKS mode.")
        success = .false.
     else
        success = .true.
     end if
 
   contains
     subroutine remove_uncolored_resonances ()
       type(resonance_history_t), dimension(:), allocatable :: res_hist_tmp
       integer :: n_hist, nleg_out, n_removed
       integer :: i_res, i_hist
       n_hist = size (res_hist)
       nleg_out = size (flv) - n_in
       allocate (res_hist_tmp (n_hist))
       allocate (res_hist_colored (n_hist))
       do i_hist = 1, n_hist
          res_hist_tmp(i_hist) = res_hist(i_hist)
          call res_hist_tmp(i_hist)%add_offset (n_in)
          n_removed = 0
          do i_res = 1, res_hist_tmp(i_hist)%n_resonances
             associate (resonance => res_hist_tmp(i_hist)%resonances(i_res - n_removed))
                if (.not. any (is_colored (flv (resonance%contributors%c))) &
                   .or. size (resonance%contributors%c) == nleg_out) then
                      call res_hist_tmp(i_hist)%remove_resonance (i_res - n_removed)
                      n_removed = n_removed + 1
                end if
             end associate
          end do
          if (allocated (res_hist_tmp(i_hist)%resonances)) then
             if (any (res_hist_colored == res_hist_tmp(i_hist))) then
                cycle
             else
                do i_res = 1, res_hist_tmp(i_hist)%n_resonances
                   associate (resonance => res_hist_tmp(i_hist)%resonances(i_res))
                      call res_hist_colored(i_hist)%add_resonance (resonance)
                   end associate
                end do
             end if
          end if
       end do
     end subroutine remove_uncolored_resonances
 
     subroutine contract_resonances (res_history_in, res_history_out)
       type(resonance_history_t), intent(in), dimension(:) :: res_history_in
       type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
       logical, dimension(:), allocatable :: i_non_zero
       integer :: n_hist_non_zero, n_hist
       integer :: i_hist_new
       n_hist = size (res_history_in); n_hist_non_zero = 0
       allocate (i_non_zero (n_hist))
       i_non_zero = .false.
       do i_hist = 1, n_hist
          if (res_history_in(i_hist)%n_resonances /= 0) then
             n_hist_non_zero = n_hist_non_zero + 1
             i_non_zero(i_hist) = .true.
          end if
       end do
       allocate (res_history_out (n_hist_non_zero))
       i_hist_new = 1
       do i_hist = 1, n_hist
          if (i_non_zero (i_hist)) then
             res_history_out (i_hist_new) = res_history_in (i_hist)
             i_hist_new = i_hist_new + 1
          end if
       end do
     end subroutine contract_resonances
 
     subroutine remove_subresonances (res_history_in, res_history_out)
       type(resonance_history_t), intent(in), dimension(:) :: res_history_in
       type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
       logical, dimension(:), allocatable :: i_non_sub_res
       integer :: n_hist, n_hist_non_sub_res
       integer :: i_hist1, i_hist2
       logical :: is_not_subres
       n_hist = size (res_history_in); n_hist_non_sub_res = 0
       allocate (i_non_sub_res (n_hist)); i_non_sub_res = .false.
       do i_hist1 = 1, n_hist
          is_not_subres = .true.
          do i_hist2 = 1, n_hist
             if (i_hist1 == i_hist2) cycle
             is_not_subres = is_not_subres .and. &
                .not.(res_history_in(i_hist2) .contains. res_history_in(i_hist1))
          end do
          if (is_not_subres) then
             n_hist_non_sub_res = n_hist_non_sub_res + 1
             i_non_sub_res (i_hist1) = .true.
          end if
       end do
 
       allocate (res_history_out (n_hist_non_sub_res))
       i_hist2 = 1
       do i_hist1 = 1, n_hist
          if (i_non_sub_res (i_hist1)) then
             res_history_out (i_hist2) = res_history_in (i_hist1)
             i_hist2 = i_hist2 + 1
          end if
       end do
     end subroutine remove_subresonances
 
     subroutine remove_multiple_resonances (res_history_in, res_history_out)
       type(resonance_history_t), intent(in), dimension(:) :: res_history_in
       type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
       integer :: n_hist, n_hist_single
       logical, dimension(:), allocatable :: i_hist_single
       integer :: i_hist, j
       n_hist = size (res_history_in)
       n_hist_single = 0
       allocate (i_hist_single (n_hist)); i_hist_single = .false.
       do i_hist = 1, n_hist
          if (res_history_in(i_hist)%n_resonances == 1) then
             n_hist_single = n_hist_single + 1
             i_hist_single(i_hist) = .true.
          end if
       end do
 
       allocate (res_history_out (n_hist_single))
       j = 1
       do i_hist = 1, n_hist
          if (i_hist_single(i_hist)) then
             res_history_out(j) = res_history_in(i_hist)
             j = j + 1
          end if
       end do
     end subroutine remove_multiple_resonances
   end subroutine clean_resonance_histories
 
 @ %def clean_resonance_histories
 @
 <<phs fks: procedures>>=
   subroutine get_filtered_resonance_histories (phs_config, n_in, flv_state, model, &
      excluded_resonances, resonance_histories_filtered, success)
     type(phs_fks_config_t), intent(inout) :: phs_config
     integer, intent(in) :: n_in
     integer, intent(in), dimension(:,:), allocatable :: flv_state
     type(model_t), intent(in) :: model
     type(string_t), intent(in), dimension(:), allocatable :: excluded_resonances
     type(resonance_history_t), intent(out), dimension(:), &
        allocatable :: resonance_histories_filtered
     logical, intent(out) :: success
     type(resonance_history_t), dimension(:), allocatable :: resonance_histories
     type(resonance_history_t), dimension(:), allocatable :: &
        resonance_histories_clean!, resonance_histories_filtered
     allocate (resonance_histories (size (phs_config%get_resonance_histories ())))
     resonance_histories = phs_config%get_resonance_histories ()
     call clean_resonance_histories (resonance_histories, &
          n_in, flv_state (:,1), resonance_histories_clean, success)
     if (success .and. allocated (excluded_resonances)) then
        call filter_particles_from_resonances (resonance_histories_clean, &
             excluded_resonances, model, resonance_histories_filtered)
     else
        allocate (resonance_histories_filtered (size (resonance_histories_clean)))
        resonance_histories_filtered = resonance_histories_clean
     end if
   end subroutine get_filtered_resonance_histories
 
 @ %def get_filtered_resonance_histories
 @
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \subsection{Unit tests}
 Test module for FKS phase space, followed by the corresponding implementation module.
 <<[[phs_fks_ut.f90]]>>=
 <<File header>>
 
 module phs_fks_ut
   use unit_tests
   use phs_fks_uti
 
 <<Standard module head>>
 
 <<phs fks: public test>>
 
 contains
 
 <<phs fks: test driver>>
 
 end module phs_fks_ut
 @ %def phs_fks_ut
 @
 <<[[phs_fks_uti.f90]]>>=
 <<File header>>
 
 module phs_fks_uti
 
 <<Use kinds>>
   use format_utils, only: write_separator, pac_fmt
   use format_defs, only: FMT_15, FMT_19
   use numeric_utils, only: nearly_equal
   use constants, only: tiny_07, zero, one, two
   use lorentz
 
   use physics_defs, only: THR_POS_B, THR_POS_BBAR, THR_POS_WP, THR_POS_WM, THR_POS_GLUON
   use physics_defs, only: thr_leg
 
   use resonances, only: resonance_contributors_t
   use phs_fks
 
 <<Standard module head>>
 
 <<phs fks: test declarations>>
 
 contains
 
 <<phs fks: tests>>
 
 end module phs_fks_uti
 @ %def phs_fks_uti
 @ API: driver for the unit tests below.
 <<phs fks: public test>>=
   public :: phs_fks_generator_test
 <<phs fks: test driver>>=
   subroutine phs_fks_generator_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
     call test(phs_fks_generator_1, "phs_fks_generator_1", &
          "Test the generation of FKS phase spaces", u, results)
     call test(phs_fks_generator_2, "phs_fks_generator_2", &
          "Test the generation of an ISR FKS phase space", u, results)
     call test(phs_fks_generator_3, "phs_fks_generator_3", &
          "Test the generation of a real phase space for decays", &
          u, results)
     call test(phs_fks_generator_4, "phs_fks_generator_4", &
          "Test the generation of an FSR phase space with "&
          &"conserved invariant resonance masses", u, results)
     call test(phs_fks_generator_5, "phs_fks_generator_5", &
          "Test on-shell projection of a Born phase space and the generation"&
          &" of a real phase-space from that", u, results)
     call test(phs_fks_generator_6, "phs_fks_generator_6", &
          "Test the generation of a real phase space for 1 -> 3 decays", &
          u, results)
     call test(phs_fks_generator_7, "phs_fks_generator_7", &
          "Test the generation of an ISR FKS phase space for fixed beam energy", &
          u, results)
   end subroutine phs_fks_generator_test
 
 @ %def phs_fks_generator_test
 @
 <<phs fks: test declarations>>=
   public :: phs_fks_generator_1
 <<phs fks: tests>>=
   subroutine phs_fks_generator_1 (u)
     integer, intent(in) :: u
     type(phs_fks_generator_t) :: generator
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: p_real
     integer :: emitter, i_phs
     real(default) :: x1, x2, x3
     real(default), parameter :: sqrts = 250.0_default
     type(phs_identifier_t), dimension(2) :: phs_identifiers
     write (u, "(A)") "* Test output: phs_fks_generator_1"
     write (u, "(A)") "* Purpose: Create massless fsr phase space"
     write (u, "(A)")
 
     allocate (p_born (4))
     p_born(1)%p(0) = 125.0_default
     p_born(1)%p(1:2) = 0.0_default
     p_born(1)%p(3) = 125.0_default
     p_born(2)%p(0) = 125.0_default
     p_born(2)%p(1:2) = 0.0_default
     p_born(2)%p(3) = -125.0_default
     p_born(3)%p(0) = 125.0_default
     p_born(3)%p(1) = -39.5618_default
     p_born(3)%p(2) = -20.0791_default
     p_born(3)%p(3) = -114.6957_default
     p_born(4)%p(0) = 125.0_default
     p_born(4)%p(1:3) = -p_born(3)%p(1:3)
 
     allocate (generator%isr_kinematics)
     generator%n_in = 2
     generator%isr_kinematics%isr_mode = SQRTS_FIXED
 
     call generator%set_sqrts_hat (sqrts)
 
     write (u, "(A)") "* Use four-particle phase space containing: "
     call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
     write (u, "(A)") "***********************"
     write (u, "(A)")
 
     x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default
     write (u, "(A)" ) "* Use random numbers: "
     write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
        "x1: ", x1, "x2: ", x2, "x3: ", x3
 
     allocate (generator%real_kinematics)
     call generator%real_kinematics%init (4, 2, 2, 1)
 
     allocate (generator%emitters (2))
     generator%emitters(1) = 3; generator%emitters(2) = 4
     allocate (generator%m2 (4))
     generator%m2 = zero
     allocate (generator%is_massive (4))
     generator%is_massive(1:2) = .false.
     generator%is_massive(3:4) = .true.
     phs_identifiers(1)%emitter = 3
     phs_identifiers(2)%emitter = 4
     call generator%compute_xi_ref_momenta (p_born)
     call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
     do i_phs = 1, 2
        emitter = phs_identifiers(i_phs)%emitter
        call generator%compute_xi_max (emitter, i_phs, p_born, &
             generator%real_kinematics%xi_max(i_phs))
     end do
     write (u, "(A)")  &
          "* With these, the following radiation variables have been produced:"
     associate (rad_var => generator%real_kinematics)
       write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde
       write (u, "(A,F3.2)") "y: " , rad_var%y(1)
       write (u, "(A,F3.2)") "phi: ", rad_var%phi
     end associate
     call write_separator (u)
     write (u, "(A)") "Produce real momenta: "
     i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
     write (u, "(A,I1)") "emitter: ", emitter
 
     allocate (p_real (5))
     call generator%generate_fsr (emitter, i_phs, p_born, p_real)
     call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
     call write_separator (u)
     write (u, "(A)")
     write (u, "(A)") "* Test output end: phs_fks_generator_1"
 
   end subroutine phs_fks_generator_1
 
 @ %def phs_fks_generator_1
 @
 <<phs fks: test declarations>>=
   public :: phs_fks_generator_2
 <<phs fks: tests>>=
   subroutine phs_fks_generator_2 (u)
     integer, intent(in) :: u
     type(phs_fks_generator_t) :: generator
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: p_real
     integer :: emitter, i_phs
     real(default) :: x1, x2, x3
     real(default), parameter :: sqrts_hadronic = 250.0_default
     type(phs_identifier_t), dimension(2) :: phs_identifiers
     write (u, "(A)") "* Test output: phs_fks_generator_2"
     write (u, "(A)") "* Purpose: Create massless ISR phase space"
     write (u, "(A)")
 
 
     allocate (p_born (4))
     p_born(1)%p(0) = 114.661_default
     p_born(1)%p(1:2) = 0.0_default
     p_born(1)%p(3) = 114.661_default
     p_born(2)%p(0) = 121.784_default
     p_born(2)%p(1:2) = 0.0_default
     p_born(2)%p(3) = -121.784_default
     p_born(3)%p(0) = 115.148_default
     p_born(3)%p(1) = -46.250_default
     p_born(3)%p(2) = -37.711_default
     p_born(3)%p(3) = 98.478_default
     p_born(4)%p(0) = 121.296_default
     p_born(4)%p(1:2) = -p_born(3)%p(1:2)
     p_born(4)%p(3) = -105.601_default
 
     phs_identifiers(1)%emitter = 1
     phs_identifiers(2)%emitter = 2
 
     allocate (generator%emitters (2))
     allocate (generator%isr_kinematics)
     generator%emitters(1) = 1; generator%emitters(2) = 2
     generator%sqrts = sqrts_hadronic
     generator%isr_kinematics%beam_energy = sqrts_hadronic / two
     call generator%set_sqrts_hat (sqrts_hadronic)
     call generator%set_isr_kinematics (p_born)
     generator%n_in = 2
     generator%isr_kinematics%isr_mode = SQRTS_VAR
 
     write (u, "(A)") "* Use four-particle phase space containing: "
     call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
     write (u, "(A)") "***********************"
     write (u, "(A)")
 
     x1=0.5_default; x2=0.25_default; x3=0.65_default
     write (u, "(A)" ) "* Use random numbers: "
     write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
        "x1: ", x1, "x2: ", x2, "x3: ", x3
 
     allocate (generator%real_kinematics)
     call generator%real_kinematics%init (4, 2, 2, 1)
     call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)
 
     allocate (generator%m2 (2))
     generator%m2(1) = 0._default; generator%m2(2) = 0._default
     allocate (generator%is_massive (4))
     generator%is_massive = .false.
     call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
     call generator%compute_xi_ref_momenta (p_born)
     do i_phs = 1, 2
        emitter = phs_identifiers(i_phs)%emitter
        call generator%compute_xi_max (emitter, i_phs, p_born, &
             generator%real_kinematics%xi_max(i_phs))
     end do
     write (u, "(A)")  &
          "* With these, the following radiation variables have been produced:"
     associate (rad_var => generator%real_kinematics)
       write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde
       write (u, "(A,F3.2)") "y: " , rad_var%y(1)
       write (u, "(A,F3.2)") "phi: ", rad_var%phi
     end associate
     write (u, "(A)") "Initial-state momentum fractions: "
     associate (xb => generator%isr_kinematics%x)
        write (u, "(A,F3.2)") "x_born_plus: ", xb(1)
        write (u, "(A,F3.2)") "x_born_minus: ", xb(2)
     end associate
     call write_separator (u)
     write (u, "(A)") "Produce real momenta: "
     i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
     write (u, "(A,I1)") "emitter: ", emitter
     allocate (p_real(5))
     call generator%generate_isr (i_phs, p_born, p_real)
     call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
     call write_separator (u)
     write (u, "(A)")
     write (u, "(A)") "* Test output end: phs_fks_generator_2"
 
   end subroutine phs_fks_generator_2
 
 @ %def phs_fks_generator_2
 @
 <<phs fks: test declarations>>=
   public :: phs_fks_generator_3
 <<phs fks: tests>>=
   subroutine phs_fks_generator_3 (u)
     integer, intent(in) :: u
     type(phs_fks_generator_t) :: generator
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: p_real
     real(default) :: x1, x2, x3
     real(default) :: mB, mW, mT
     integer :: i, emitter, i_phs
     type(phs_identifier_t), dimension(2) :: phs_identifiers
 
     write (u, "(A)") "* Test output: phs_fks_generator_3"
     write (u, "(A)") "* Puropse: Create real phase space for particle decays"
     write (u, "(A)")
 
     allocate (p_born(3))
     p_born(1)%p(0) = 172._default
     p_born(1)%p(1) = 0._default
     p_born(1)%p(2) = 0._default
     p_born(1)%p(3) = 0._default
     p_born(2)%p(0) = 104.72866679_default
     p_born(2)%p(1) = 45.028053213_default
     p_born(2)%p(2) = 29.450337581_default
     p_born(2)%p(3) = -5.910229156_default
     p_born(3)%p(0) = 67.271333209_default
     p_born(3)%p(1:3) = -p_born(2)%p(1:3)
 
     generator%n_in = 1
     allocate (generator%isr_kinematics)
     generator%isr_kinematics%isr_mode = SQRTS_FIXED
 
     mB = 4.2_default
     mW = 80.376_default
     mT = 172._default
 
     generator%sqrts = mT
 
     write (u, "(A)") "* Use three-particle phase space containing: "
     call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
     write (u, "(A)") "**********************"
     write (u, "(A)")
 
     x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
     write (u, "(A)") "* Use random numbers: "
     write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
        "x1: ", x1, "x2: ", x2, "x3: ", x3
 
     allocate (generator%real_kinematics)
     call generator%real_kinematics%init (3, 2, 2, 1)
     call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)
 
     allocate (generator%emitters(2))
     generator%emitters(1) = 1
     generator%emitters(2) = 3
     allocate (generator%m2 (3), generator%is_massive(3))
     generator%m2(1) = mT**2
     generator%m2(2) = mW**2
     generator%m2(3) = mB**2
     generator%is_massive = .true.
     phs_identifiers(1)%emitter = 1
     phs_identifiers(2)%emitter = 3
 
     call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
     call generator%compute_xi_ref_momenta (p_born)
     do i_phs = 1, 2
        emitter = phs_identifiers(i_phs)%emitter
        call generator%compute_xi_max (emitter, i_phs, p_born, &
             generator%real_kinematics%xi_max(i_phs))
     end do
 
     write (u, "(A)") &
        "* With these, the following radiation variables have been produced: "
     associate (rad_var => generator%real_kinematics)
       write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
       do i = 1, 2
          write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
       end do
       write (u, "(A,F4.2)") "phi: ", rad_var%phi
     end associate
 
     call write_separator (u)
     write (u, "(A)") "Produce real momenta via initial-state emission: "
     i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
     write (u, "(A,I1)") "emitter: ", emitter
     allocate (p_real (4))
     call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
     call pacify (p_real, 1E-6_default)
     call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
     call write_separator(u)
     write (u, "(A)") "Produce real momenta via final-state emisson: "
     i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
     write (u, "(A,I1)") "emitter: ", emitter
     call generator%generate_fsr (emitter, i_phs, p_born, p_real)
     call pacify (p_real, 1E-6_default)
     call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
     write (u, "(A)")
     write (u, "(A)") "* Test output end: phs_fks_generator_3"
 
   end subroutine phs_fks_generator_3
 
 @ %def phs_fks_generator_3
 @
 <<phs fks: test declarations>>=
   public :: phs_fks_generator_4
 <<phs fks: tests>>=
   subroutine phs_fks_generator_4 (u)
     integer, intent(in) :: u
     type(phs_fks_generator_t) :: generator
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: p_real
     integer, dimension(:), allocatable :: emitters
     integer, dimension(:,:), allocatable :: resonance_lists
     type(resonance_contributors_t), dimension(2) :: alr_contributors
     real(default) :: x1, x2, x3
     real(default), parameter :: sqrts = 250.0_default
     integer, parameter :: nlegborn = 6
     integer :: i_phs, i_con, emitter
     real(default) :: m_inv_born, m_inv_real
     character(len=7) :: fmt
     type(phs_identifier_t), dimension(2) :: phs_identifiers
 
     call pac_fmt (fmt, FMT_19, FMT_15, .true.)
 
     write (u, "(A)") "* Test output: phs_fks_generator_4"
     write (u, "(A)") "* Purpose: Create FSR phase space with fixed resonances"
     write (u, "(A)")
 
     allocate (p_born (nlegborn))
     p_born(1)%p(0) = 250._default
     p_born(1)%p(1) = 0._default
     p_born(1)%p(2) = 0._default
     p_born(1)%p(3) = 250._default
     p_born(2)%p(0) = 250._default
     p_born(2)%p(1) = 0._default
     p_born(2)%p(2) = 0._default
     p_born(2)%p(3) = -250._default
     p_born(3)%p(0) = 145.91184486_default
     p_born(3)%p(1) = 50.39727589_default
     p_born(3)%p(2) = 86.74156041_default
     p_born(3)%p(3) = -69.03608748_default
     p_born(4)%p(0) = 208.1064784_default
     p_born(4)%p(1) = -44.07610020_default
     p_born(4)%p(2) = -186.34264578_default
     p_born(4)%p(3) = 13.48038407_default
     p_born(5)%p(0) = 26.25614471_default
     p_born(5)%p(1) = -25.12258068_default
     p_born(5)%p(2) = -1.09540228_default
     p_born(5)%p(3) = -6.27703505_default
     p_born(6)%p(0) = 119.72553196_default
     p_born(6)%p(1) = 18.80140499_default
     p_born(6)%p(2) = 100.69648766_default
     p_born(6)%p(3) = 61.83273846_default
 
     allocate (generator%isr_kinematics)
     generator%n_in = 2
     generator%isr_kinematics%isr_mode = SQRTS_FIXED
 
     call generator%set_sqrts_hat (sqrts)
 
     write (u, "(A)") "* Test process: e+ e- -> W+ W- b b~"
     write (u, "(A)") "* Resonance pairs: (3,5) and (4,6)"
     write (u, "(A)") "* Use four-particle phase space containing: "
     call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
     write (u, "(A)") "******************************"
     write (u, "(A)")
 
     x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default
     write (u, "(A)") "* Use random numbers: "
     write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
        "x1: ", x1, "x2: ", x2, "x3: ", x3
 
     allocate (generator%real_kinematics)
     call generator%real_kinematics%init (nlegborn, 2, 2, 2)
 
     allocate (generator%emitters (2))
     generator%emitters(1) = 5; generator%emitters(2) = 6
     allocate (generator%m2 (nlegborn))
     generator%m2 = p_born**2
     allocate (generator%is_massive (nlegborn))
     generator%is_massive (1:2) = .false.
     generator%is_massive (3:6) = .true.
 
     phs_identifiers(1)%emitter = 5
     phs_identifiers(2)%emitter = 6
     do i_phs = 1, 2
        allocate (phs_identifiers(i_phs)%contributors (2))
     end do
     allocate (resonance_lists (2, 2))
     resonance_lists (1,:) = [3,5]
     resonance_lists (2,:) = [4,6]
     !!! Here is obviously some redundance. Surely we can improve on this.
     do i_phs = 1, 2
        phs_identifiers(i_phs)%contributors = resonance_lists(i_phs,:)
     end do
     do i_con = 1, 2
        allocate (alr_contributors(i_con)%c (size (resonance_lists(i_con,:))))
        alr_contributors(i_con)%c = resonance_lists(i_con,:)
     end do
     call generator%generate_radiation_variables &
        ([x1, x2, x3], p_born, phs_identifiers)
 
     allocate (p_real(nlegborn + 1))
     call generator%compute_xi_ref_momenta (p_born, alr_contributors)
     !!! Keep the distinction between i_phs and i_con because in general,
     !!! they are not the same.
     do i_phs = 1, 2
        i_con = i_phs
        emitter = phs_identifiers(i_phs)%emitter
        write (u, "(A,I1,1X,A,I1,A,I1,A)") &
             "* Generate FSR phase space for emitter ", emitter, &
             "and resonance pair (",  resonance_lists (i_con, 1), ",", &
             resonance_lists (i_con, 2), ")"
        call generator%compute_xi_max (emitter, i_phs, p_born, &
             generator%real_kinematics%xi_max(i_phs), i_con = i_con)
        call generator%generate_fsr (emitter, i_phs, i_con, p_born, p_real)
        call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
        call write_separator(u)
        write (u, "(A)") "* Check if resonance masses are conserved: "
        m_inv_born = compute_resonance_mass (p_born, resonance_lists (i_con,:))
        m_inv_real = compute_resonance_mass (p_real, resonance_lists (i_con,:), 7)
        write (u, "(A,1X, " // fmt // ")") "m_inv_born = ", m_inv_born
        write (u, "(A,1X, " // fmt // ")") "m_inv_real = ", m_inv_real
        if (abs (m_inv_born - m_inv_real) < tiny_07) then
           write (u, "(A)") " Success! "
        else
           write (u, "(A)") " Failure! "
        end if
        call write_separator(u)
        call write_separator(u)
     end do
     deallocate (p_real)
     write (u, "(A)")
     write (u, "(A)") "* Test output end: phs_fks_generator_4"
   end subroutine phs_fks_generator_4
 
 @ %def phs_fks_generator_4
 @
 <<phs fks: test declarations>>=
   public :: phs_fks_generator_5
 <<phs fks: tests>>=
   subroutine phs_fks_generator_5 (u)
     use ttv_formfactors, only: init_parameters
     integer, intent(in) :: u
     type(phs_fks_generator_t) :: generator
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: p_born_onshell
     type(vector4_t), dimension(:), allocatable :: p_real
     real(default) :: x1, x2, x3
     real(default) :: mB, mW, mtop, mcheck
     integer :: i, emitter, i_phs
     type(phs_identifier_t), dimension(2) :: phs_identifiers
     type(lorentz_transformation_t) :: L_to_cms
     real(default), parameter :: sqrts = 360._default
     real(default), parameter :: momentum_tolerance = 1E-10_default
     real(default) :: mpole, gam_out
 
     write (u, "(A)") "* Test output: phs_fks_generator_5"
     write (u, "(A)") "* Puropse: Perform threshold on-shell projection of "
     write (u, "(A)") "*          Born momenta and create a real phase-space "
     write (u, "(A)") "*          point from those. "
     write (u, "(A)")
 
     allocate (p_born(6), p_born_onshell(6))
     p_born(1)%p(0) = sqrts / two
     p_born(1)%p(1:2) = zero
     p_born(1)%p(3) = sqrts / two
     p_born(2)%p(0) = sqrts / two
     p_born(2)%p(1:2) = zero
     p_born(2)%p(3) = -sqrts / two
     p_born(3)%p(0) = 117.1179139230_default
     p_born(3)%p(1) = 56.91215483880_default
     p_born(3)%p(2) = -40.02386013017_default
     p_born(3)%p(3) = -49.07634310496_default
     p_born(4)%p(0) = 98.91904548743_default
     p_born(4)%p(1) = 56.02241403836_default
     p_born(4)%p(2) = -8.302977504723_default
     p_born(4)%p(3) = -10.50293716131_default
     p_born(5)%p(0) = 62.25884689208_default
     p_born(5)%p(1) = -60.00786540278_default
     p_born(5)%p(2) = 4.753602375910_default
     p_born(5)%p(3) = 15.32916731546_default
     p_born(6)%p(0) = 81.70419369751_default
     p_born(6)%p(1) = -52.92670347439_default
     p_born(6)%p(2) = 43.57323525898_default
     p_born(6)%p(3) = 44.25011295081_default
 
     generator%n_in = 2
     allocate (generator%isr_kinematics)
     generator%isr_kinematics%isr_mode = SQRTS_FIXED
 
     mB = 4.2_default
     mW = 80.376_default
     mtop = 172._default
 
     generator%sqrts = sqrts
 
     !!! Dummy-initialization of the threshold model because generate_fsr_threshold
     !!! uses m1s_to_mpole to determine if it is above or below threshold.
     call init_parameters (mpole, gam_out, mtop, one, one / 1.5_default, 125._default, &
          0.47_default, 0.118_default, 91._default, 80._default, 4.2_default, &
          one, one, one, one, zero, zero, zero, zero, zero, zero, .false., zero)
 
     write (u, "(A)") "* Use four-particle phase space containing: "
     call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
     call vector4_check_momentum_conservation &
          (p_born, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.)
     write (u, "(A)") "**********************"
     write (u, "(A)")
 
     allocate (generator%real_kinematics)
     call generator%real_kinematics%init (7, 2, 2, 2)
     call generator%real_kinematics%init_onshell (7, 2)
     generator%real_kinematics%p_born_cms%phs_point(1)%p = p_born
 
     write (u, "(A)") "Get boost projection system -> CMS: "
     L_to_cms = get_boost_for_threshold_projection (p_born, sqrts, mtop)
     call L_to_cms%write (u, testflag = .true., ultra = .true.)
     write (u, "(A)") "**********************"
     write (u, "(A)")
 
     write (u, "(A)") "* Perform onshell-projection:"
     associate (p_born => generator%real_kinematics%p_born_cms%phs_point(1)%p, &
          p_born_onshell => generator%real_kinematics%p_born_onshell%phs_point(1)%p)
        call threshold_projection_born (mtop, L_to_cms, p_born, p_born_onshell)
     end associate
     call generator%real_kinematics%p_born_onshell%write (1, unit = u, testflag = .true., &
          ultra = .true.)
     associate (p => generator%real_kinematics%p_born_onshell%phs_point(1)%p)
        p_born_onshell = p
        call check_phsp (p, 0)
     end associate
 
     allocate (generator%emitters (2))
     generator%emitters(1) = THR_POS_B; generator%emitters(2) = THR_POS_BBAR
 
     allocate (generator%m2 (6), generator%is_massive(6))
     generator%m2 = p_born**2
     generator%is_massive (1:2) = .false.
     generator%is_massive (3:6) = .true.
 
     phs_identifiers(1)%emitter = THR_POS_B
     phs_identifiers(2)%emitter = THR_POS_BBAR
 
     x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
     write (u, "(A)") "* Use random numbers: "
     write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
        "x1: ", x1, "x2: ", x2, "x3: ", x3
 
 
     call generator%generate_radiation_variables ([x1,x2,x3], p_born_onshell, phs_identifiers)
     do i_phs = 1, 2
        emitter = phs_identifiers(i_phs)%emitter
        call generator%compute_xi_ref_momenta_threshold (p_born_onshell)
        call generator%compute_xi_max (emitter, i_phs, p_born_onshell, &
             generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter))
     end do
     write (u, "(A)") &
        "* With these, the following radiation variables have been produced: "
     associate (rad_var => generator%real_kinematics)
       write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
       write (u, "(A)") "xi_max: "
       write (u, "(2F5.2)") rad_var%xi_max(1), rad_var%xi_max(2)
       write (u, "(A)") "y: "
       write (u, "(2F5.2)") rad_var%y(1), rad_var%y(2)
       write (u, "(A,F4.2)") "phi: ", rad_var%phi
     end associate
 
     call write_separator (u)
     write (u, "(A)") "* Produce real momenta from on-shell phase space: "
     allocate (p_real(7))
     do i_phs = 1, 2
        emitter = phs_identifiers(i_phs)%emitter
        write (u, "(A,I1)") "emitter: ", emitter
        call generator%generate_fsr_threshold (emitter, i_phs, p_born_onshell, p_real)
        call check_phsp (p_real, emitter)
     end do
 
     call write_separator(u)
     write (u, "(A)")
     write (u, "(A)") "* Test output end: phs_fks_generator_5"
 
   contains
     subroutine check_phsp (p, emitter)
        type(vector4_t), intent(inout), dimension(:) :: p
        integer, intent(in) :: emitter
        type(vector4_t) :: pp
        real(default) :: E_tot
        logical :: check
        write (u, "(A)") "* Check momentum conservation: "
        call vector4_check_momentum_conservation &
             (p, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.)
        write (u, "(A)") "* Check invariant masses: "
        write (u, "(A)", advance = "no") "inv(W+, b, gl): "
        pp = p(THR_POS_WP) + p(THR_POS_B)
        if (emitter == THR_POS_B) pp = pp + p(THR_POS_GLUON)
        if (nearly_equal (pp**1, mtop)) then
           write (u, "(A)") "CHECK"
        else
           write (u, "(A,F7.3)") "FAIL: ", pp**1
        end if
        write (u, "(A)", advance = "no") "inv(W-, bbar): "
        pp = p(THR_POS_WM) + p(THR_POS_BBAR)
        if (emitter == THR_POS_BBAR) pp = pp + p(THR_POS_GLUON)
        if (nearly_equal (pp**1, mtop)) then
           write (u, "(A)") "CHECK"
        else
           write (u, "(A,F7.3)") "FAIL: ", pp**1
        end if
        write (u, "(A)") "* Sum of energies equal to sqrts?"
        E_tot = sum(p(1:2)%p(0)); check = nearly_equal (E_tot, sqrts)
        write (u, "(A,L1)") "Initial state: ", check
        if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot
        if (emitter > 0) then
           E_tot = sum(p(3:7)%p(0))
        else
           E_tot = sum(p(3:6)%p(0))
        end if
        check = nearly_equal (E_tot, sqrts)
        write (u, "(A,L1)") "Final state  : ", check
        if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot
        call pacify (p, 1E-6_default)
        call vector4_write_set (p, u, testflag = .true., ultra = .true.)
 
     end subroutine check_phsp
   end subroutine phs_fks_generator_5
 
 @ %def phs_fks_generator_5
 @
 
 <<phs fks: test declarations>>=
   public :: phs_fks_generator_6
 <<phs fks: tests>>=
   subroutine phs_fks_generator_6 (u)
     integer, intent(in) :: u
     type(phs_fks_generator_t) :: generator
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: p_real
     real(default) :: x1, x2, x3
     real(default) :: mB, mW, mT
     integer :: i, emitter, i_phs
     type(phs_identifier_t), dimension(2) :: phs_identifiers
 
     write (u, "(A)") "* Test output: phs_fks_generator_6"
     write (u, "(A)") "* Puropse: Create real phase space for particle decays"
     write (u, "(A)")
 
     allocate (p_born(4))
     p_born(1)%p(0) = 173.1_default
     p_born(1)%p(1) = zero
     p_born(1)%p(2) = zero
     p_born(1)%p(3) = zero
     p_born(2)%p(0) = 68.17074462929_default
     p_born(2)%p(1) = -37.32578717617_default
     p_born(2)%p(2) = 30.99675959336_default
     p_born(2)%p(3) = -47.70321718398_default
     p_born(3)%p(0) = 65.26639312326_default
     p_born(3)%p(1) = -1.362927648502_default
     p_born(3)%p(2) = -33.25327150840_default
     p_born(3)%p(3) = 56.14324922494_default
     p_born(4)%p(0) = 39.66286224745_default
     p_born(4)%p(1) = 38.68871482467_default
     p_born(4)%p(2) = 2.256511915049_default
     p_born(4)%p(3) = -8.440032040958_default
 
     generator%n_in = 1
     allocate (generator%isr_kinematics)
     generator%isr_kinematics%isr_mode = SQRTS_FIXED
 
     mB = 4.2_default
     mW = 80.376_default
     mT = 173.1_default
 
     generator%sqrts = mT
 
     write (u, "(A)") "* Use four-particle phase space containing: "
     call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
     write (u, "(A)") "**********************"
     write (u, "(A)")
 
     x1=0.5_default; x2=0.25_default; x3=0.6_default
     write (u, "(A)") "* Use random numbers: "
     write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
        "x1: ", x1, "x2: ", x2, "x3: ", x3
 
     allocate (generator%real_kinematics)
     call generator%real_kinematics%init (3, 2, 2, 1)
     call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)
 
     allocate (generator%emitters(2))
     generator%emitters(1) = 1
     generator%emitters(2) = 2
     allocate (generator%m2 (4), generator%is_massive(4))
     generator%m2(1) = mT**2
     generator%m2(2) = mB**2
     generator%m2(3) = zero
     generator%m2(4) = zero
     generator%is_massive(1:2) = .true.
     generator%is_massive(3:4) = .false.
     phs_identifiers(1)%emitter = 1
     phs_identifiers(2)%emitter = 2
 
     call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
     call generator%compute_xi_ref_momenta (p_born)
     do i_phs = 1, 2
        emitter = phs_identifiers(i_phs)%emitter
        call generator%compute_xi_max (emitter, i_phs, p_born, &
             generator%real_kinematics%xi_max(i_phs))
     end do
 
     write (u, "(A)") &
        "* With these, the following radiation variables have been produced: "
     associate (rad_var => generator%real_kinematics)
       write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
       do i = 1, 2
          write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
       end do
       write (u, "(A,F4.2)") "phi: ", rad_var%phi
     end associate
 
     call write_separator (u)
     write (u, "(A)") "Produce real momenta via initial-state emission: "
     i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
     write (u, "(A,I1)") "emitter: ", emitter
     allocate (p_real(5))
     call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
     call pacify (p_real, 1E-6_default)
     call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
     call write_separator(u)
     write (u, "(A)") "Produce real momenta via final-state emisson: "
     i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
     write (u, "(A,I1)") "emitter: ", emitter
     call generator%generate_fsr (emitter, i_phs, p_born, p_real)
     call pacify (p_real, 1E-6_default)
     call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
     write (u, "(A)")
     write (u, "(A)") "* Test output end: phs_fks_generator_6"
 
   end subroutine phs_fks_generator_6
 
 @ %def phs_fks_generator_6
 @
 <<phs fks: test declarations>>=
   public :: phs_fks_generator_7
 <<phs fks: tests>>=
   subroutine phs_fks_generator_7 (u)
     integer, intent(in) :: u
     type(phs_fks_generator_t) :: generator
     type(vector4_t), dimension(:), allocatable :: p_born
     type(vector4_t), dimension(:), allocatable :: p_real
     real(default) :: x1, x2, x3
     integer :: i, emitter, i_phs
     type(phs_identifier_t), dimension(2) :: phs_identifiers
     real(default), parameter :: sqrts = 1000.0_default
 
     write (u, "(A)") "* Test output: phs_fks_generator_7"
     write (u, "(A)") "* Puropse: Create real phase space for scattering ISR"
     write (u, "(A)") "*          keeping the beam energy fixed."
     write (u, "(A)")
 
     allocate (p_born(4))
     p_born(1)%p(0) = 500._default
     p_born(1)%p(1) = 0._default
     p_born(1)%p(2) = 0._default
     p_born(1)%p(3) = 500._default
     p_born(2)%p(0) = 500._default
     p_born(2)%p(1) = 0._default
     p_born(2)%p(2) = 0._default
     p_born(2)%p(3) = -500._default
     p_born(3)%p(0) = 500._default
     p_born(3)%p(1) = 11.275563070_default
     p_born(3)%p(2) = -13.588797663_default
     p_born(3)%p(3) = 486.93070588_default
     p_born(4)%p(0) = 500._default
     p_born(4)%p(1:3) = -p_born(3)%p(1:3)
 
     phs_identifiers(1)%emitter = 1
     phs_identifiers(2)%emitter = 2
 
     allocate (generator%emitters(2))
     generator%n_in = 2
     allocate (generator%isr_kinematics)
     generator%isr_kinematics%isr_mode = SQRTS_FIXED
     generator%emitters(1) = 1; generator%emitters(2) = 2
     generator%sqrts = sqrts
 
     write (u, "(A)") "* Use 2 -> 2 phase space containing: "
     call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
     write (u, "(A)") "**********************"
     write (u, "(A)")
 
     x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
     write (u, "(A)") "* Use random numbers: "
     write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
        "x1: ", x1, "x2: ", x2, "x3: ", x3
 
     allocate (generator%real_kinematics)
     call generator%real_kinematics%init (4, 2, 2, 1)
     call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)
 
     allocate (generator%m2 (4))
     generator%m2 = 0._default
     allocate (generator%is_massive(4))
     generator%is_massive = .false.
     call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
     call generator%compute_xi_ref_momenta (p_born)
     do i_phs = 1, 2
        emitter = phs_identifiers(i_phs)%emitter
        call generator%compute_xi_max (emitter, i_phs, p_born, &
             generator%real_kinematics%xi_max(i_phs))
     end do
 
     write (u, "(A)") &
        "* With these, the following radiation variables have been produced: "
     associate (rad_var => generator%real_kinematics)
        write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
        do i = 1, 2
           write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
        end do
        write (u, "(A,F4.2)") "phi: ", rad_var%phi
     end associate
 
     call write_separator (u)
     write (u, "(A)") "Produce real momenta via initial-state emission: "
     i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
     write (u, "(A,I1)") "emitter: ", emitter
     allocate (p_real(5))
     call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
     call pacify (p_real, 1E-6_default)
     call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
     call write_separator(u)
     i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
     write (u, "(A,I1)") "emitter: ", emitter
     call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
     call pacify (p_real, 1E-6_default)
     call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
     write (u, "(A)")
     write (u, "(A)") "* Test output end: phs_fks_generator_7"
 
   end subroutine phs_fks_generator_7
 
 @ %def phs_fks_generator_3
 @
 \section{Dispatch}
 <<[[dispatch_phase_space.f90]]>>=
 <<File header>>
 
 module dispatch_phase_space
 
 <<Use kinds>>
 <<Use strings>>
   use io_units, only: free_unit
   use variables, only: var_list_t
   use os_interface, only: os_data_t
   use diagnostics
 
   use sf_mappings, only: sf_channel_t
   use beam_structures, only: beam_structure_t
   use dispatch_beams, only: sf_prop_t, strfun_mode
 
   use mappings
   use phs_forests, only: phs_parameters_t
   use phs_base
   use phs_none
   use phs_single
   use phs_rambo
   use phs_wood
   use phs_fks
 
 <<Standard module head>>
 
 <<Dispatch phs: public>>
 
 contains
 
 <<Dispatch phs: procedures>>
 
 end module dispatch_phase_space
 @ %def dispatch_phase_space
 Allocate a phase-space object according to the variable [[$phs_method]].
 <<Dispatch phs: public>>=
   public :: dispatch_phs
 <<Dispatch phs: procedures>>=
   subroutine dispatch_phs (phs, var_list, os_data, process_id, &
          mapping_defaults, phs_par, phs_method_in)
     class(phs_config_t), allocatable, intent(inout) :: phs
     type(var_list_t), intent(in) :: var_list
     type(os_data_t), intent(in) :: os_data
     type(string_t), intent(in) :: process_id
     type(mapping_defaults_t), intent(in), optional :: mapping_defaults
     type(phs_parameters_t), intent(in), optional :: phs_par
     type(string_t), intent(in), optional :: phs_method_in
     type(string_t) :: phs_method, phs_file, run_id
     logical :: use_equivalences, vis_channels, fatal_beam_decay
     integer :: u_phs
     logical :: exist
     if (present (phs_method_in)) then
        phs_method = phs_method_in
     else
        phs_method = &
             var_list%get_sval (var_str ("$phs_method"))
     end if
     phs_file = &
          var_list%get_sval (var_str ("$phs_file"))
     use_equivalences = &
          var_list%get_lval (var_str ("?use_vamp_equivalences"))
     vis_channels = &
          var_list%get_lval (var_str ("?vis_channels"))
     fatal_beam_decay = &
          var_list%get_lval (var_str ("?fatal_beam_decay"))
     run_id = &
          var_list%get_sval (var_str ("$run_id"))
     select case (char (phs_method))
     case ("none")
        allocate (phs_none_config_t :: phs)
     case ("single")
        allocate (phs_single_config_t :: phs)
        if (vis_channels) then
           call msg_warning ("Visualizing phase space channels not " // &
                "available for method 'single'.")
        end if
     case ("rambo")
        allocate (phs_rambo_config_t :: phs)
        if (vis_channels) &
           call msg_warning ("Visualizing phase space channels not " // &
               "available for method 'rambo'.")
     case ("fks")
       allocate (phs_fks_config_t :: phs)
     case ("wood", "default", "fast_wood")
        call dispatch_wood ()
     case default
        call msg_fatal ("Phase space: parameterization method '" &
             // char (phs_method) // "' not implemented")
     end select
   contains
   <<Dispatch phs: dispatch phs: procedures>>
   end subroutine dispatch_phs
 
 @ %def dispatch_phs
 @
 <<Dispatch phs: dispatch phs: procedures>>=
   subroutine dispatch_wood ()
     allocate (phs_wood_config_t :: phs)
     select type (phs)
     type is (phs_wood_config_t)
        if (phs_file /= "") then
           inquire (file = char (phs_file), exist = exist)
           if (exist) then
              call msg_message ("Phase space: reading configuration from '" &
                   // char (phs_file) // "'")
              u_phs = free_unit ()
              open (u_phs, file = char (phs_file), &
                   action = "read", status = "old")
              call phs%set_input (u_phs)
           else
              call msg_fatal ("Phase space: configuration file '" &
                   // char (phs_file) // "' not found")
           end if
        end if
        if (present (phs_par)) &
             call phs%set_parameters (phs_par)
        if (use_equivalences) &
             call phs%enable_equivalences ()
        if (present (mapping_defaults)) &
             call phs%set_mapping_defaults (mapping_defaults)
        if (phs_method == "fast_wood") phs%use_cascades2 = .true.
        phs%vis_channels = vis_channels
        phs%fatal_beam_decay = fatal_beam_decay
        phs%os_data = os_data
        phs%run_id = run_id
     end select
   end subroutine dispatch_wood
 
 @
 @ Configure channel mappings, using some conditions
 from the phase space configuration.  If there are no structure
 functions, we enable a default setup with a single (dummy)
 structure-function channel.  Otherwise, we look at the channel
 collection that we got from the phase-space configuration step.  Each
 entry should be translated into an independent structure-function
 channel, where typically there is one default entry, which could be
 mapped using a standard s-channel mapping if the structure function
 setup recommends this, and other entries with s-channel resonances.
 The latter need to be translated into global mappings from the
 structure-function chain.
 <<Dispatch phs: public>>=
   public :: dispatch_sf_channels
 <<Dispatch phs: procedures>>=
   subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, coll, &
          var_list, sqrts, beam_structure)
     type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel
     type(string_t), intent(out) :: sf_string
     type(sf_prop_t), intent(in) :: sf_prop
     type(phs_channel_collection_t), intent(in) :: coll
     type(var_list_t), intent(in) :: var_list
     real(default), intent(in) :: sqrts
     type(beam_structure_t), intent(in) :: beam_structure
     type(beam_structure_t) :: beam_structure_tmp
     class(channel_prop_t), allocatable :: prop
     integer :: n_strfun, n_sf_channel, i
     logical :: sf_allow_s_mapping, circe1_map, circe1_generate
     logical :: s_mapping_enable, endpoint_mapping, power_mapping
     logical :: single_parameter
     integer, dimension(:), allocatable :: s_mapping, single_mapping
     real(default) :: s_mapping_power
     real(default) :: circe1_mapping_slope, endpoint_mapping_slope
     real(default) :: power_mapping_eps
     beam_structure_tmp = beam_structure
     call beam_structure_tmp%expand (strfun_mode)
     n_strfun = beam_structure_tmp%get_n_record ()
     sf_string = beam_structure_tmp%to_string (sf_only = .true.)
     sf_allow_s_mapping = &
          var_list%get_lval (var_str ("?sf_allow_s_mapping"))
     circe1_generate = &
          var_list%get_lval (var_str ("?circe1_generate"))
     circe1_map = &
          var_list%get_lval (var_str ("?circe1_map"))
     circe1_mapping_slope = &
          var_list%get_rval (var_str ("circe1_mapping_slope"))
     s_mapping_enable = .false.
     s_mapping_power = 1
     endpoint_mapping = .false.
     endpoint_mapping_slope = 1
     power_mapping = .false.
     single_parameter = .false.
     select case (char (sf_string))
     case ("", "[any particles]")
     case ("pdf_builtin, none", &
          "pdf_builtin_photon, none", &
          "none, pdf_builtin", &
          "none, pdf_builtin_photon", &
          "lhapdf, none", &
          "lhapdf_photon, none", &
          "none, lhapdf", &
          "none, lhapdf_photon")
          single_parameter = .true.
     case ("pdf_builtin, none => none, pdf_builtin", &
           "pdf_builtin, none => none, pdf_builtin_photon", &
           "pdf_builtin_photon, none => none, pdf_builtin", &
           "pdf_builtin_photon, none => none, pdf_builtin_photon", &
           "lhapdf, none => none, lhapdf", &
           "lhapdf, none => none, lhapdf_photon", &
           "lhapdf_photon, none => none, lhapdf", &
           "lhapdf_photon, none => none, lhapdf_photon")
        allocate (s_mapping (2), source = [1, 2])
        s_mapping_enable = .true.
        s_mapping_power = 2
     case ("pdf_builtin, none => none, pdf_builtin => epa, none => none, epa", &
           "pdf_builtin, none => none, pdf_builtin => ewa, none => none, ewa", &
           "pdf_builtin, none => none, pdf_builtin => ewa, none => none, epa", &
           "pdf_builtin, none => none, pdf_builtin => epa, none => none, ewa")
        allocate (s_mapping (2), source = [1, 2])
        s_mapping_enable = .true.
        s_mapping_power = 2
     case ("isr, none", &
          "none, isr")
        allocate (single_mapping (1), source = [1])
        single_parameter = .true.
     case ("isr, none => none, isr")
        allocate (s_mapping (2), source = [1, 2])
        power_mapping = .true.
        power_mapping_eps = minval (sf_prop%isr_eps)
     case ("isr, none => none, isr => epa, none => none, epa", &
           "isr, none => none, isr => ewa, none => none, ewa", &
           "isr, none => none, isr => ewa, none => none, epa", &
           "isr, none => none, isr => epa, none => none, ewa")
        allocate (s_mapping (2), source = [1, 2])
        power_mapping = .true.
        power_mapping_eps = minval (sf_prop%isr_eps)
     case ("circe1 => isr, none => none, isr => epa, none => none, epa", &
           "circe1 => isr, none => none, isr => ewa, none => none, ewa", &
           "circe1 => isr, none => none, isr => ewa, none => none, epa", &
           "circe1 => isr, none => none, isr => epa, none => none, ewa")
        if (circe1_generate) then
           allocate (s_mapping (2), source = [2, 3])
        else
           allocate (s_mapping (3), source = [1, 2, 3])
           endpoint_mapping = .true.
           endpoint_mapping_slope = circe1_mapping_slope
        end if
        power_mapping = .true.
        power_mapping_eps = minval (sf_prop%isr_eps)
     case ("pdf_builtin, none => none, isr", &
          "pdf_builtin_photon, none => none, isr", &
          "lhapdf, none => none, isr", &
          "lhapdf_photon, none => none, isr")
        allocate (single_mapping (1), source = [2])
     case ("isr, none => none, pdf_builtin", &
          "isr, none => none, pdf_builtin_photon", &
          "isr, none => none, lhapdf", &
          "isr, none => none, lhapdf_photon")
        allocate (single_mapping (1), source = [1])
     case ("epa, none", &
           "none, epa")
        allocate (single_mapping (1), source = [1])
        single_parameter = .true.
     case ("epa, none => none, epa")
        allocate (single_mapping (2), source = [1, 2])
     case ("epa, none => none, isr", &
          "isr, none => none, epa", &
          "ewa, none => none, isr", &
          "isr, none => none, ewa")
        allocate (single_mapping (2), source = [1, 2])
     case ("pdf_builtin, none => none, epa", &
          "pdf_builtin_photon, none => none, epa", &
          "lhapdf, none => none, epa", &
          "lhapdf_photon, none => none, epa")
        allocate (single_mapping (1), source = [2])
     case ("pdf_builtin, none => none, ewa", &
          "pdf_builtin_photon, none => none, ewa", &
          "lhapdf, none => none, ewa", &
          "lhapdf_photon, none => none, ewa")
        allocate (single_mapping (1), source = [2])
     case ("epa, none => none, pdf_builtin", &
          "epa, none => none, pdf_builtin_photon", &
          "epa, none => none, lhapdf", &
          "epa, none => none, lhapdf_photon")
        allocate (single_mapping (1), source = [1])
     case ("ewa, none => none, pdf_builtin", &
          "ewa, none => none, pdf_builtin_photon", &
          "ewa, none => none, lhapdf", &
          "ewa, none => none, lhapdf_photon")
        allocate (single_mapping (1), source = [1])
     case ("ewa, none", &
           "none, ewa")
        allocate (single_mapping (1), source = [1])
        single_parameter = .true.
     case ("ewa, none => none, ewa")
        allocate (single_mapping (2), source = [1, 2])
     case ("energy_scan, none => none, energy_scan")
        allocate (s_mapping (2), source = [1, 2])
     case ("sf_test_1, none => none, sf_test_1")
        allocate (s_mapping (2), source = [1, 2])
     case ("circe1")
        if (circe1_generate) then
           !!! no mapping
        else if (circe1_map) then
           allocate (s_mapping (1), source = [1])
           endpoint_mapping = .true.
           endpoint_mapping_slope = circe1_mapping_slope
        else
           allocate (s_mapping (1), source = [1])
           s_mapping_enable = .true.
        end if
     case ("circe1 => isr, none => none, isr")
        if (circe1_generate) then
           allocate (s_mapping (2), source = [2, 3])
        else
           allocate (s_mapping (3), source = [1, 2, 3])
           endpoint_mapping = .true.
           endpoint_mapping_slope = circe1_mapping_slope
        end if
        power_mapping = .true.
        power_mapping_eps = minval (sf_prop%isr_eps)
     case ("circe1 => isr, none", &
          "circe1 => none, isr")
        allocate (single_mapping (1), source = [2])
     case ("circe1 => epa, none => none, epa")
        if (circe1_generate) then
           allocate (single_mapping (2), source = [2, 3])
        else
           call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
                &only")
        end if
     case ("circe1 => ewa, none => none, ewa")
        if (circe1_generate) then
           allocate (single_mapping (2), source = [2, 3])
        else
           call msg_fatal ("CIRCE/EWA: supported with ?circe1_generate=true &
                &only")
        end if
     case ("circe1 => epa, none", &
          "circe1 => none, epa")
        if (circe1_generate) then
           allocate (single_mapping (1), source = [2])
        else
           call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
                &only")
        end if
     case ("circe1 => epa, none => none, isr", &
          "circe1 => isr, none => none, epa", &
          "circe1 => ewa, none => none, isr", &
          "circe1 => isr, none => none, ewa")
        if (circe1_generate) then
           allocate (single_mapping (2), source = [2, 3])
        else
           call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
                &only")
        end if
     case ("circe2", &
          "gaussian", &
          "beam_events")
        !!! no mapping
     case ("circe2 => isr, none => none, isr", &
        "gaussian => isr, none => none, isr", &
        "beam_events => isr, none => none, isr")
        allocate (s_mapping (2), source = [2, 3])
        power_mapping = .true.
        power_mapping_eps = minval (sf_prop%isr_eps)
     case ("circe2 => isr, none", &
          "circe2 => none, isr", &
          "gaussian => isr, none", &
          "gaussian => none, isr", &
          "beam_events => isr, none", &
          "beam_events => none, isr")
        allocate (single_mapping (1), source = [2])
     case ("circe2 => epa, none => none, epa", &
          "gaussian => epa, none => none, epa", &
          "beam_events => epa, none => none, epa")
        allocate (single_mapping (2), source = [2, 3])
     case ("circe2 => epa, none", &
          "circe2 => none, epa", &
          "circe2 => ewa, none", &
          "circe2 => none, ewa", &
          "gaussian => epa, none", &
          "gaussian => none, epa", &
          "gaussian => ewa, none", &
          "gaussian => none, ewa", &
          "beam_events => epa, none", &
          "beam_events => none, epa", &
          "beam_events => ewa, none", &
          "beam_events => none, ewa")
        allocate (single_mapping (1), source = [2])
     case ("circe2 => epa, none => none, isr", &
          "circe2 => isr, none => none, epa", &
          "circe2 => ewa, none => none, isr", &
          "circe2 => isr, none => none, ewa", &
          "gaussian => epa, none => none, isr", &
          "gaussian => isr, none => none, epa", &
          "gaussian => ewa, none => none, isr", &
          "gaussian => isr, none => none, ewa", &
          "beam_events => epa, none => none, isr", &
          "beam_events => isr, none => none, epa", &
          "beam_events => ewa, none => none, isr", &
          "beam_events => isr, none => none, ewa")
        allocate (single_mapping (2), source = [2, 3])
     case ("energy_scan")
     case default
        call msg_fatal ("Beam structure: " &
             // char (sf_string) // " not supported")
     end select
     if (sf_allow_s_mapping .and. coll%n > 0) then
        n_sf_channel = coll%n
        allocate (sf_channel (n_sf_channel))
        do i = 1, n_sf_channel
           call sf_channel(i)%init (n_strfun)
           if (allocated (single_mapping)) then
              call sf_channel(i)%activate_mapping (single_mapping)
           end if
           if (allocated (prop))  deallocate (prop)
           call coll%get_entry (i, prop)
           if (allocated (prop)) then
              if (endpoint_mapping .and. power_mapping) then
                 select type (prop)
                 type is (resonance_t)
                    call sf_channel(i)%set_eir_mapping (s_mapping, &
                         a = endpoint_mapping_slope, eps = power_mapping_eps, &
                         m = prop%mass / sqrts, w = prop%width / sqrts)
                 type is (on_shell_t)
                    call sf_channel(i)%set_eio_mapping (s_mapping, &
                         a = endpoint_mapping_slope, eps = power_mapping_eps, &
                         m = prop%mass / sqrts)
                 end select
              else if (endpoint_mapping) then
                 select type (prop)
                 type is (resonance_t)
                    call sf_channel(i)%set_epr_mapping (s_mapping, &
                         a = endpoint_mapping_slope, &
                         m = prop%mass / sqrts, w = prop%width / sqrts)
                 type is (on_shell_t)
                    call sf_channel(i)%set_epo_mapping (s_mapping, &
                         a = endpoint_mapping_slope, &
                         m = prop%mass / sqrts)
                 end select
              else if (power_mapping) then
                 select type (prop)
                 type is (resonance_t)
                    call sf_channel(i)%set_ipr_mapping (s_mapping, &
                         eps = power_mapping_eps, &
                         m = prop%mass / sqrts, w = prop%width / sqrts)
                 type is (on_shell_t)
                    call sf_channel(i)%set_ipo_mapping (s_mapping, &
                         eps = power_mapping_eps, &
                         m = prop%mass / sqrts)
                 end select
              else if (allocated (s_mapping)) then
                 select type (prop)
                 type is (resonance_t)
                    call sf_channel(i)%set_res_mapping (s_mapping, &
                         m = prop%mass / sqrts, w = prop%width / sqrts, &
                         single = single_parameter)
                 type is (on_shell_t)
                    call sf_channel(i)%set_os_mapping (s_mapping, &
                         m = prop%mass / sqrts, &
                         single = single_parameter)
                 end select
              else if (allocated (single_mapping)) then
                 select type (prop)
                 type is (resonance_t)
                    call sf_channel(i)%set_res_mapping (single_mapping, &
                            m = prop%mass / sqrts, w = prop%width / sqrts, &
                            single = single_parameter)
                 type is (on_shell_t)
                    call sf_channel(i)%set_os_mapping (single_mapping, &
                         m = prop%mass / sqrts, &
                         single = single_parameter)
                 end select
              end if
           else if (endpoint_mapping .and. power_mapping) then
              call sf_channel(i)%set_ei_mapping (s_mapping, &
                   a = endpoint_mapping_slope, eps = power_mapping_eps)
           else if (endpoint_mapping .and. .not. allocated (single_mapping)) then
              call sf_channel(i)%set_ep_mapping (s_mapping, &
                   a = endpoint_mapping_slope)
           else if (power_mapping .and. .not. allocated (single_mapping)) then
              call sf_channel(i)%set_ip_mapping (s_mapping, &
                   eps = power_mapping_eps)
           else if (s_mapping_enable .and. .not. allocated (single_mapping)) then
              call sf_channel(i)%set_s_mapping (s_mapping, &
                   power = s_mapping_power)
           end if
        end do
     else if (sf_allow_s_mapping) then
        allocate (sf_channel (1))
        call sf_channel(1)%init (n_strfun)
        if (allocated (single_mapping)) then
           call sf_channel(1)%activate_mapping (single_mapping)
        else if (endpoint_mapping .and. power_mapping) then
           call sf_channel(i)%set_ei_mapping (s_mapping, &
                a = endpoint_mapping_slope, eps = power_mapping_eps)
        else if (endpoint_mapping) then
           call sf_channel(1)%set_ep_mapping (s_mapping, &
                   a = endpoint_mapping_slope)
        else if (power_mapping) then
           call sf_channel(1)%set_ip_mapping (s_mapping, &
                   eps = power_mapping_eps)
        else if (s_mapping_enable) then
           call sf_channel(1)%set_s_mapping (s_mapping, &
                power = s_mapping_power)
        end if
     else
        allocate (sf_channel (1))
        call sf_channel(1)%init (n_strfun)
        if (allocated (single_mapping)) then
           call sf_channel(1)%activate_mapping (single_mapping)
        end if
     end if
   end subroutine dispatch_sf_channels
 
 @ %def dispatch_sf_channels
 @
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[dispatch_phs_ut.f90]]>>=
 <<File header>>
 
 module dispatch_phs_ut
   use unit_tests
   use dispatch_phs_uti
 
 <<Standard module head>>
 
 <<Dispatch phs: public test>>
 
 contains
 
 <<Dispatch phs: test driver>>
 
 end module dispatch_phs_ut
 @ %def dispatch_phs_ut
 @
 <<[[dispatch_phs_uti.f90]]>>=
 <<File header>>
 
 module dispatch_phs_uti
 
 <<Use kinds>>
 <<Use strings>>
   use variables
   use io_units, only: free_unit
   use os_interface, only: os_data_t
   use process_constants
   use model_data
   use models
   use phs_base
   use phs_none
   use phs_forests
   use phs_wood
   use mappings
   use dispatch_phase_space
 
 <<Standard module head>>
 
 <<Dispatch phs: test declarations>>
 
 contains
 
 <<Dispatch phs: tests>>
 
 end module dispatch_phs_uti
 @ %def dispatch_phs_ut
 @ API: driver for the unit tests below.
 <<Dispatch phs: public test>>=
   public ::dispatch_phs_test
 <<Dispatch phs: test driver>>=
   subroutine dispatch_phs_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Dispatch phs: execute tests>>
   end subroutine dispatch_phs_test
 
 @  %def dispatch_phs_test
 @
 \subsubsection{Select type: phase-space configuration object}
 <<Dispatch phs: execute tests>>=
   call test (dispatch_phs_1, "dispatch_phs_1", &
        "phase-space configuration", &
        u, results)
 <<Dispatch phs: test declarations>>=
   public :: dispatch_phs_1
 <<Dispatch phs: tests>>=
   subroutine dispatch_phs_1 (u)
     integer, intent(in) :: u
     type(var_list_t) :: var_list
     class(phs_config_t), allocatable :: phs
     type(phs_parameters_t) :: phs_par
     type(os_data_t) :: os_data
     type(mapping_defaults_t) :: mapping_defs
 
     write (u, "(A)")  "* Test output: dispatch_phs_1"
     write (u, "(A)")  "*   Purpose: select phase-space configuration method"
     write (u, "(A)")
 
     call var_list%init_defaults (0)
 
     write (u, "(A)")  "* Allocate PHS as phs_none_t"
     write (u, "(A)")
 
     call var_list%set_string (&
          var_str ("$phs_method"), &
          var_str ("none"), is_known = .true.)
     call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate PHS as phs_single_t"
     write (u, "(A)")
 
     call var_list%set_string (&
          var_str ("$phs_method"), &
          var_str ("single"), is_known = .true.)
     call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate PHS as phs_wood_t"
     write (u, "(A)")
 
     call var_list%set_string (&
          var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
     call phs%write (u)
 
     call phs%final ()
     deallocate (phs)
 
     write (u, "(A)")
     write (u, "(A)")  "* Setting parameters for phs_wood_t"
     write (u, "(A)")
 
     phs_par%m_threshold_s = 123
     phs_par%m_threshold_t = 456
     phs_par%t_channel = 42
     phs_par%off_shell = 17
     phs_par%keep_nonresonant = .false.
     mapping_defs%energy_scale = 987
     mapping_defs%invariant_mass_scale = 654
     mapping_defs%momentum_transfer_scale = 321
     mapping_defs%step_mapping = .false.
     mapping_defs%step_mapping_exp = .false.
     mapping_defs%enable_s_mapping = .true.
     call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"), &
          mapping_defs, phs_par)
     call phs%write (u)
 
     call phs%final ()
 
     call var_list%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: dispatch_phs_1"
 
   end subroutine dispatch_phs_1
 
 @ %def dispatch_phs_1
 @
 \subsubsection{Phase-space configuration with file}
 <<Dispatch phs: execute tests>>=
   call test (dispatch_phs_2, "dispatch_phs_2", &
        "configure phase space using file", &
        u, results)
 <<Dispatch phs: test declarations>>=
   public :: dispatch_phs_2
 <<Dispatch phs: tests>>=
   subroutine dispatch_phs_2 (u)
     use phs_base_ut, only: init_test_process_data
     use phs_wood_ut, only: write_test_phs_file
     use phs_forests
     integer, intent(in) :: u
     type(var_list_t) :: var_list
     type(os_data_t) :: os_data
     type(process_constants_t) :: process_data
     type(model_list_t) :: model_list
     type(model_t), pointer :: model
     class(phs_config_t), allocatable :: phs
     integer :: u_phs
 
     write (u, "(A)")  "* Test output: dispatch_phs_2"
     write (u, "(A)")  "*   Purpose: select 'wood' phase-space &
          &for a test process"
     write (u, "(A)")  "*            and read phs configuration from file"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize a process"
     write (u, "(A)")
 
     call var_list%init_defaults (0)
     call os_data%init ()
     call syntax_model_file_init ()
     call model_list%read_model &
          (var_str ("Test"), var_str ("Test.mdl"), os_data, model)
 
     call syntax_phs_forest_init ()
 
     call init_test_process_data (var_str ("dispatch_phs_2"), process_data)
 
     write (u, "(A)")  "* Write phase-space file"
 
     u_phs = free_unit ()
     open (u_phs, file = "dispatch_phs_2.phs", action = "write", status = "replace")
     call write_test_phs_file (u_phs, var_str ("dispatch_phs_2"))
     close (u_phs)
 
     write (u, "(A)")
     write (u, "(A)")  "* Allocate PHS as phs_wood_t"
     write (u, "(A)")
 
     call var_list%set_string (&
          var_str ("$phs_method"), &
          var_str ("wood"), is_known = .true.)
     call var_list%set_string (&
          var_str ("$phs_file"), &
          var_str ("dispatch_phs_2.phs"), is_known = .true.)
     call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_2"))
 
     call phs%init (process_data, model)
     call phs%configure (sqrts = 1000._default)
 
     call phs%write (u)
     write (u, "(A)")
     select type (phs)
     type is (phs_wood_config_t)
        call phs%write_forest (u)
     end select
 
     call phs%final ()
 
     call var_list%final ()
     call syntax_model_file_final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: dispatch_phs_2"
 
   end subroutine dispatch_phs_2
 
 @ %def dispatch_phs_2
 @%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{A lexer for O'Mega's phase-space output}
 This module provides three data types. One of them is the type
 [[dag_string_t]] which should contain the information of all Feynman
 diagrams in the factorized form which is provided by O'Mega in its
 phase-space outout. This output is translated into a string of tokens (in
 the form of an a array of the type [[dag_token_t]]) which have a certain
 meaning. The purpose of this module is only to identify these tokens
 correctly and to provide some procedures and interfaces which allow us to
 use these strings in a similar way as variables of the basic character
 type or the type [[iso_varying_string]]. Both [[character]] and
 [[iso_varying_string]] have some disadvantages at least if one wants to
 keep support for some older compiler versions. These can be circumvented
 by the [[dag_string_t]] type. Finally the [[dag_chain_t]] type is used
 to create a larger string in several steps without always recreating the
 string, which is done in the form of a simple linked list. In the end
 one can create a single [[dag_string]] out of this list, which is more
 useful.
 <<[[cascades2_lexer.f90]]>>=
 <<File header>>
 
 module cascades2_lexer
 
 <<Use kinds>>
   use kinds, only: TC, i8
 
 <<Standard module head>>
 
 <<Cascades2 lexer: public>>
 
 <<Cascades2 lexer: parameters>>
 
 <<Cascades2 lexer: types>>
 
 <<Cascades2 lexer: interfaces>>
 
 contains
 
 <<Cascades2 lexer: procedures>>
 
 end module cascades2_lexer
 
 @ %def cascades2_lexer
 @ This is the token type. By default the variable [[type]] is [[EMPTY_TK]]
 but can obtain other values corresponding to the parameters defined below.
 The type of the token corresponds to a particular sequence of characters.
 When the token corresponds to a node of a tree, i.e. some particle in the
 Feynman diagram, the type is [[NODE_TK]] and the [[particle_name]] variable
 is holding the name of the particle. O'Megas output contains in
 addition to the particle name some numbers which indicate the external
 momenta that are flowing through this line. These numbers are translated
 into a binary code and saved in the variable [[bincode]]. In this case
 the number 1 corresponds to a bit set at position 0, 2 corresponds to a
 bit set at position 1, etc. Instead of numbers which are composed out of
 several digits, letters are used, i.e. A instead of 10 (bit at position 9),
 B instead of 11 (bit at position 10), etc.\\
 When the DAG is reconstructed from a [[dag_string]] which was built from
 O'Mega's output, this string is modified such that a substring (a set of
 tokens) is replaced by a single token where the type variable is one of
 the three parameters [[DAG_NODE_TK]], [[DAG_OPTIONS_TK]] and
 [[DAG_COMBINATION_TK]]. These parameters correspond to the three types
 [[dag_node_t]], [[dag_options_t]] and [[dag_combination_t]] (see [[cascades2]]
 for more information. In this case, since these objects are organized
 in arrays, the [[index]] variable holds the corresponding position in
 the array.\\
 In any case, we want to be able to reproduce the character string from
 which a token (or a string) has been created. The variable [[char_len]]
 is the length of this string. For tokens with the type [[DAG_NODE_TK]],
 [[DAG_OPTIONS_TK]] and [[DAG_COMBINATION_TK]] we use output of the form
 [[<N23>]], [[<O23>]] or [[<C23>]] which is useful for debugging the parser.
 Here 23 is the [[index]] and [[N]], [[O]] or [[C]] obviously corresponds
 to the [[type]].
 <<Cascades2 lexer: parameters>>=
   integer, parameter :: PRT_NAME_LEN = 20
 @ %def PRT_NAME_LEN
 <<Cascades2 lexer: public>>=
   public :: dag_token_t
 <<Cascades2 lexer: types>>=
   type :: dag_token_t
      integer :: type = EMPTY_TK
      integer :: char_len = 0
      integer(TC) :: bincode = 0
      character (PRT_NAME_LEN) :: particle_name=""
      integer :: index = 0
    contains
      <<Cascades2 lexer: dag token: TBP>>
   end type dag_token_t
 
 @ %def dag_token_t
 @ This is the string type. It also holds the number of characters in the
 corresponding character string. It contains an array of tokens. If the
 [[dag_string]] is constructed using the type [[dag_chain_t]], which creates
 a linked list, we also need the pointer [[next]].
 <<Cascades2 lexer: public>>=
   public :: dag_string_t
 <<Cascades2 lexer: types>>=
   type :: dag_string_t
      integer :: char_len = 0
      type (dag_token_t), dimension(:), allocatable :: t
      type (dag_string_t), pointer :: next => null ()
    contains
      <<Cascades2 lexer: dag string: TBP>>
   end type dag_string_t
 
 @ %def dag_string_t
 @ This is the chain of [[dag_strings]]. It allows us to construct a large
 string by appending new strings to the linked list, which can later be
 merged to a single string. This is very useful because the file written
 by O'Mega contains large strings where each string contains all Feynman
 diagrams in a factorized form, but these large strings are cut into
 several pieces and distributed over many lines. As the file can become
 large, rewriting a new [[dag_string]] (or [[iso_varying_string]]) would
 consume more and more time with each additional line. For recreating a
 single [[dag_string]] out of this chain, we need the total character
 length and the sum of all sizes of the [[dag_token]] arrays [[t]].
 <<Cascades2 lexer: public>>=
   public :: dag_chain_t
 <<Cascades2 lexer: types>>=
   type :: dag_chain_t
      integer :: char_len = 0
      integer :: t_size = 0
      type (dag_string_t), pointer :: first => null ()
      type (dag_string_t), pointer :: last => null ()
    contains
      <<Cascades2 lexer: dag chain: TBP>>
   end type dag_chain_t
 
 @ %def dag_chain_t
 @ We define two parameters holding the characters corresponding to a
 backslash and a blanc space.
 <<Cascades2 lexer: parameters>>=
   character(len=1), parameter, public :: BACKSLASH_CHAR = "\\"
   character(len=1), parameter :: BLANC_CHAR = " "
 @ %def BACKSLASH_CHAR BLANC_CHAR
 @ These are the parameters which correspond to meaningful types
 of [[token]].
 <<Cascades2 lexer: parameters>>=
   integer, parameter, public :: NEW_LINE_TK = -2
   integer, parameter :: BLANC_SPACE_TK = -1
   integer, parameter :: EMPTY_TK = 0
   integer, parameter, public :: NODE_TK = 1
   integer, parameter, public :: DAG_NODE_TK = 2
   integer, parameter, public :: DAG_OPTIONS_TK = 3
   integer, parameter, public :: DAG_COMBINATION_TK = 4
   integer, parameter, public :: COLON_TK = 11
   integer, parameter, public :: COMMA_TK = 12
   integer, parameter, public :: VERTICAL_BAR_TK = 13
   integer, parameter, public :: OPEN_PAR_TK = 21
   integer, parameter, public :: CLOSED_PAR_TK = 22
   integer, parameter, public :: OPEN_CURLY_TK = 31
   integer, parameter, public :: CLOSED_CURLY_TK = 32
 
 @ %def NEW_LINE_TK BLANC_SPACE_TK EMPTY_TK NODE_TK
 @ %def COLON_TK COMMA_TK VERTICAL_LINE_TK OPEN_PAR_TK
 @ %def CLOSED_PAR_TK OPEN_CURLY_TK CLOSED_CURLY_TK
 @ Different sorts of assignment. This contains the conversion
 of a [[character]] variable into a [[dag_token]] or [[dag_string]].
 <<Cascades2 lexer: public>>=
   public :: assignment (=)
 <<Cascades2 lexer: interfaces>>=
   interface assignment (=)
      module procedure dag_token_assign_from_char_string
      module procedure dag_token_assign_from_dag_token
      module procedure dag_string_assign_from_dag_token
      module procedure dag_string_assign_from_char_string
      module procedure dag_string_assign_from_dag_string
      module procedure dag_string_assign_from_dag_token_array
   end interface assignment (=)
 
 @ %def interfaces
 <<Cascades2 lexer: dag token: TBP>>=
   procedure :: init_dag_object_token => dag_token_init_dag_object_token
 <<Cascades2 lexer: procedures>>=
   subroutine dag_token_init_dag_object_token (dag_token, type, index)
     class (dag_token_t), intent (out) :: dag_token
     integer, intent (in) :: index
     integer :: type
     dag_token%type = type
     dag_token%char_len = integer_n_dec_digits (index) + 3
     dag_token%index = index
   contains
     function integer_n_dec_digits (number) result (n_digits)
       integer, intent (in) :: number
       integer :: n_digits
       integer :: div_number
       n_digits = 0
       div_number = number
       do
          div_number = div_number / 10
          n_digits = n_digits + 1
          if (div_number == 0) exit
       enddo
     end function integer_n_dec_digits
   end subroutine dag_token_init_dag_object_token
 
 @ %def dag_token_init_dag_object_token
 <<Cascades2 lexer: procedures>>=
   elemental subroutine dag_token_assign_from_char_string (dag_token, char_string)
     type (dag_token_t), intent (out) :: dag_token
     character (len=*), intent (in) :: char_string
     integer :: i, j
     logical :: set_bincode
     integer :: bit_pos
     character (len=10) :: index_char
     dag_token%char_len = len (char_string)
     if (dag_token%char_len == 1) then
        select case (char_string(1:1))
        case (BACKSLASH_CHAR)
           dag_token%type = NEW_LINE_TK
        case (" ")
           dag_token%type = BLANC_SPACE_TK
        case (":")
           dag_token%type = COLON_TK
        case (",")
           dag_token%type = COMMA_TK
        case ("|")
           dag_token%type = VERTICAL_BAR_TK
        case ("(")
           dag_token%type = OPEN_PAR_TK
        case (")")
           dag_token%type = CLOSED_PAR_TK
        case ("{")
           dag_token%type = OPEN_CURLY_TK
        case ("}")
           dag_token%type = CLOSED_CURLY_TK
        end select
     else if (char_string(1:1) == "<") then
        select case (char_string(2:2))
           case ("N")
              dag_token%type = DAG_NODE_TK
           case ("O")
              dag_token%type = DAG_OPTIONS_TK
           case ("C")
              dag_token%type = DAG_COMBINATION_TK
        end select
        read(char_string(3:dag_token%char_len-1), fmt="(I10)") dag_token%index
     else
        dag_token%bincode = 0
        set_bincode = .false.
        do i=1, dag_token%char_len
           select case (char_string(i:i))
           case ("[")
              dag_token%type = NODE_TK
              if (i > 1) then
                 do j = 1, i - 1
                    dag_token%particle_name(j:j) = char_string(j:j)
                 enddo
              end if
              set_bincode = .true.
           case ("]")
              set_bincode = .false.
           case default
              dag_token%type = NODE_TK
              if (set_bincode) then
                 select case (char_string(i:i))
                 case ("1", "2", "3", "4", "5", "6", "7", "8", "9")
                    read (char_string(i:i), fmt="(I1)") bit_pos
                 case ("A")
                    bit_pos = 10
                 case ("B")
                    bit_pos = 11
                 case ("C")
                    bit_pos = 12
                 end select
                 dag_token%bincode = ibset(dag_token%bincode, bit_pos - 1)
              end if
           end select
           if (dag_token%type /= NODE_TK) exit
        enddo
     end if
   end subroutine dag_token_assign_from_char_string
 
 @ %def dag_token_assign_from_char_string
 <<Cascades2 lexer: procedures>>=
   elemental subroutine dag_token_assign_from_dag_token (token_out, token_in)
     type (dag_token_t), intent (out) :: token_out
     type (dag_token_t), intent (in) :: token_in
     token_out%type = token_in%type
     token_out%char_len = token_in%char_len
     token_out%bincode = token_in%bincode
     token_out%particle_name = token_in%particle_name
     token_out%index = token_in%index
   end subroutine dag_token_assign_from_dag_token
 
 @ %def dag_token_assign_from_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental subroutine dag_string_assign_from_dag_token (dag_string, dag_token)
     type (dag_string_t), intent (out) :: dag_string
     type (dag_token_t), intent (in) :: dag_token
     allocate (dag_string%t(1))
     dag_string%t(1) = dag_token
     dag_string%char_len = dag_token%char_len
   end subroutine dag_string_assign_from_dag_token
 
 @ %def dag_string_assign_from_dag_token
 <<Cascades2 lexer: procedures>>=
   subroutine dag_string_assign_from_dag_token_array (dag_string, dag_token)
     type (dag_string_t), intent (out) :: dag_string
     type (dag_token_t), dimension(:), intent (in) :: dag_token
     allocate (dag_string%t(size(dag_token)))
     dag_string%t = dag_token
     dag_string%char_len = sum(dag_token%char_len)
   end subroutine dag_string_assign_from_dag_token_array
 
 @ %def dag_string_assign_from_dag_token_array
 <<Cascades2 lexer: procedures>>=
   elemental subroutine dag_string_assign_from_char_string (dag_string, char_string)
     type (dag_string_t), intent (out) :: dag_string
     character (len=*), intent (in) :: char_string
     type (dag_token_t), dimension(:), allocatable :: token
     integer :: token_pos
     integer :: i
     character (len=len(char_string)) :: node_char
     integer :: node_char_len
     node_char = ""
     dag_string%char_len = len (char_string)
     if (dag_string%char_len > 0) then
        allocate (token(dag_string%char_len))
        token_pos = 0
        node_char_len = 0
        do i=1, dag_string%char_len
           select case (char_string(i:i))
           case (BACKSLASH_CHAR, " ", ":", ",", "|", "(", ")", "{", "}")
              if (node_char_len > 0) then
                 token_pos = token_pos + 1
                 token(token_pos) = node_char(:node_char_len)
                 node_char_len = 0
              end if
              token_pos = token_pos + 1
              token(token_pos) = char_string(i:i)
           case default
              node_char_len = node_char_len + 1
              node_char(node_char_len:node_char_len) = char_string(i:i)
           end select
        enddo
        if (node_char_len > 0) then
           token_pos = token_pos + 1
           token(token_pos) = node_char(:node_char_len)
        end if
        if (token_pos > 0) then
           allocate (dag_string%t(token_pos))
           dag_string%t = token(:token_pos)
           deallocate (token)
        end if
     end if
   end subroutine dag_string_assign_from_char_string
 
 @ %def dag_string_assign_from_char_string
 <<Cascades2 lexer: procedures>>=
   elemental subroutine dag_string_assign_from_dag_string (string_out, string_in)
     type (dag_string_t), intent (out) :: string_out
     type (dag_string_t), intent (in) :: string_in
     if (allocated (string_in%t)) then
        allocate (string_out%t (size(string_in%t)))
        string_out%t = string_in%t
     end if
     string_out%char_len = string_in%char_len
   end subroutine dag_string_assign_from_dag_string
 
 @ %def dag_string_assign_from_dag_string
 @ Concatenate strings/tokens. The result is always a [[dag_string]].
 <<Cascades2 lexer: public>>=
   public :: operator (//)
 <<Cascades2 lexer: interfaces>>=
   interface operator (//)
      module procedure concat_dag_token_dag_token
      module procedure concat_dag_string_dag_token
      module procedure concat_dag_token_dag_string
      module procedure concat_dag_string_dag_string
   end interface operator (//)
 
 @ %def interfaces
 <<Cascades2 lexer: procedures>>=
   function concat_dag_token_dag_token (token1, token2) result (res_string)
     type (dag_token_t), intent (in) :: token1, token2
     type (dag_string_t) :: res_string
     if (token1%type == EMPTY_TK) then
        res_string = token2
     else if (token2%type == EMPTY_TK) then
        res_string = token1
     else
        allocate (res_string%t(2))
        res_string%t(1) = token1
        res_string%t(2) = token2
        res_string%char_len = token1%char_len + token2%char_len
     end if
   end function concat_dag_token_dag_token
 
 @ %def concat_dag_token_dag_token
 <<Cascades2 lexer: procedures>>=
   function concat_dag_string_dag_token (dag_string, dag_token) result (res_string)
     type (dag_string_t), intent (in) :: dag_string
     type (dag_token_t), intent (in) :: dag_token
     type (dag_string_t) :: res_string
     integer :: t_size
     if (dag_string%char_len == 0) then
        res_string = dag_token
     else if (dag_token%type == EMPTY_TK) then
        res_string = dag_string
     else
        t_size = size (dag_string%t)
        allocate (res_string%t(t_size+1))
        res_string%t(:t_size) = dag_string%t
        res_string%t(t_size+1) = dag_token
        res_string%char_len = dag_string%char_len + dag_token%char_len
     end if
   end function concat_dag_string_dag_token
 
 @ %def concat_dag_string_dag_token
 <<Cascades2 lexer: procedures>>=
   function concat_dag_token_dag_string (dag_token, dag_string) result (res_string)
     type (dag_token_t), intent (in) :: dag_token
     type (dag_string_t), intent (in) :: dag_string
     type (dag_string_t) :: res_string
     integer :: t_size
     if (dag_token%type == EMPTY_TK) then
        res_string = dag_string
     else if (dag_string%char_len == 0) then
        res_string = dag_token
     else
        t_size = size (dag_string%t)
        allocate (res_string%t(t_size+1))
        res_string%t(2:t_size+1) = dag_string%t
        res_string%t(1) = dag_token
        res_string%char_len = dag_token%char_len + dag_string%char_len
     end if
   end function concat_dag_token_dag_string
 
 @ %def concat_dag_token_dag_string
 <<Cascades2 lexer: procedures>>=
   function concat_dag_string_dag_string (string1, string2) result (res_string)
     type (dag_string_t), intent (in) :: string1, string2
     type (dag_string_t) :: res_string
     integer :: t1_size, t2_size, t_size
     if (string1%char_len == 0) then
        res_string = string2
     else if (string2%char_len == 0) then
        res_string = string1
     else
        t1_size = size (string1%t)
        t2_size = size (string2%t)
        t_size = t1_size + t2_size
        if (t_size > 0) then
           allocate (res_string%t(t_size))
           res_string%t(:t1_size) = string1%t
           res_string%t(t1_size+1:) = string2%t
           res_string%char_len = string1%char_len + string2%char_len
        end if
     end if
   end function concat_dag_string_dag_string
 
 @ %def concat_dag_string_dag_string
 @ Compare strings/tokens/characters. Each character is relevant, including
 all blanc spaces. An exception is the [[newline]] character which is not
 treated by the types used in this module (not to confused with the type
 parameter [[NEW_LINE_TK]] which corresponds to the backslash character
 and simply tells us that the string continues on the next line in the file).
 <<Cascades2 lexer: public>>=
   public :: operator (==)
 <<Cascades2 lexer: interfaces>>=
   interface operator (==)
      module procedure dag_token_eq_dag_token
      module procedure dag_string_eq_dag_string
      module procedure dag_token_eq_dag_string
      module procedure dag_string_eq_dag_token
      module procedure dag_token_eq_char_string
      module procedure char_string_eq_dag_token
      module procedure dag_string_eq_char_string
      module procedure char_string_eq_dag_string
   end interface operator (==)
 
 @ %def interfaces
 <<Cascades2 lexer: procedures>>=
   elemental function dag_token_eq_dag_token (token1, token2) result (flag)
     type (dag_token_t), intent (in) :: token1, token2
     logical :: flag
     flag = (token1%type == token2%type) .and. &
          (token1%char_len == token2%char_len) .and. &
          (token1%bincode == token2%bincode) .and. &
          (token1%index == token2%index) .and. &
          (token1%particle_name == token2%particle_name)
   end function dag_token_eq_dag_token
 
 @ %def dag_token_eq_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental function dag_string_eq_dag_string (string1, string2) result (flag)
     type (dag_string_t), intent (in) :: string1, string2
     logical :: flag
     flag = (string1%char_len == string2%char_len) .and. &
          (allocated (string1%t) .eqv. allocated (string2%t))
     if (flag) then
        if (allocated (string1%t)) flag = all (string1%t == string2%t)
     end if
   end function dag_string_eq_dag_string
 
 @ %def dag_string_eq_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental function dag_token_eq_dag_string (dag_token, dag_string) result (flag)
     type (dag_token_t), intent (in) :: dag_token
     type (dag_string_t), intent (in) :: dag_string
     logical :: flag
     flag = size (dag_string%t) == 1 .and. &
          dag_string%char_len == dag_token%char_len
     if (flag) flag = (dag_string%t(1) == dag_token)
   end function dag_token_eq_dag_string
 
 @ %def dag_token_eq_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental function dag_string_eq_dag_token (dag_string, dag_token) result (flag)
     type (dag_token_t), intent (in) :: dag_token
     type (dag_string_t), intent (in) :: dag_string
     logical :: flag
     flag = (dag_token == dag_string)
   end function dag_string_eq_dag_token
 
 @ %def dag_string_eq_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental function dag_token_eq_char_string (dag_token, char_string) result (flag)
     type (dag_token_t), intent (in) :: dag_token
     character (len=*), intent (in) :: char_string
     logical :: flag
     flag = (char (dag_token) == char_string)
   end function dag_token_eq_char_string
 
 @ %def dag_token_eq_char_string
 <<Cascades2 lexer: procedures>>=
   elemental function char_string_eq_dag_token (char_string, dag_token) result (flag)
     type (dag_token_t), intent (in) :: dag_token
     character (len=*), intent (in) :: char_string
     logical :: flag
     flag = (char (dag_token) == char_string)
   end function char_string_eq_dag_token
 
 @ %def char_string_eq_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental function dag_string_eq_char_string (dag_string, char_string) result (flag)
     type (dag_string_t), intent (in) :: dag_string
     character (len=*), intent (in) :: char_string
     logical :: flag
     flag = (char (dag_string) == char_string)
   end function dag_string_eq_char_string
 
 @ %def dag_string_eq_char_string
 <<Cascades2 lexer: procedures>>=
   elemental function char_string_eq_dag_string (char_string, dag_string) result (flag)
     type (dag_string_t), intent (in) :: dag_string
     character (len=*), intent (in) :: char_string
     logical :: flag
     flag = (char (dag_string) == char_string)
   end function char_string_eq_dag_string
 
 @ %def char_string_eq_dag_string
 <<Cascades2 lexer: public>>=
   public :: operator (/=)
 <<Cascades2 lexer: interfaces>>=
   interface operator (/=)
      module procedure dag_token_ne_dag_token
      module procedure dag_string_ne_dag_string
      module procedure dag_token_ne_dag_string
      module procedure dag_string_ne_dag_token
      module procedure dag_token_ne_char_string
      module procedure char_string_ne_dag_token
      module procedure dag_string_ne_char_string
      module procedure char_string_ne_dag_string
   end interface operator (/=)
 
 @ %def interfaces
 <<Cascades2 lexer: procedures>>=
   elemental function dag_token_ne_dag_token (token1, token2) result (flag)
     type (dag_token_t), intent (in) :: token1, token2
     logical :: flag
     flag = .not. (token1 == token2)
   end function dag_token_ne_dag_token
 
 @ %def dag_token_ne_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental function dag_string_ne_dag_string (string1, string2) result (flag)
     type (dag_string_t), intent (in) :: string1, string2
     logical :: flag
     flag = .not. (string1 == string2)
   end function dag_string_ne_dag_string
 
 @ %def dag_string_ne_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental function dag_token_ne_dag_string (dag_token, dag_string) result (flag)
     type (dag_token_t), intent (in) :: dag_token
     type (dag_string_t), intent (in) :: dag_string
     logical :: flag
     flag = .not. (dag_token == dag_string)
   end function dag_token_ne_dag_string
 
 @ %def dag_token_ne_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental function dag_string_ne_dag_token (dag_string, dag_token) result (flag)
     type (dag_token_t), intent (in) :: dag_token
     type (dag_string_t), intent (in) :: dag_string
     logical :: flag
     flag = .not. (dag_string == dag_token)
   end function dag_string_ne_dag_token
 
 @ %def dag_string_ne_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental function dag_token_ne_char_string (dag_token, char_string) result (flag)
     type (dag_token_t), intent (in) :: dag_token
     character (len=*), intent (in) :: char_string
     logical :: flag
     flag = .not. (dag_token == char_string)
   end function dag_token_ne_char_string
 
 @ %def dag_token_ne_char_string
 <<Cascades2 lexer: procedures>>=
   elemental function char_string_ne_dag_token (char_string, dag_token) result (flag)
     type (dag_token_t), intent (in) :: dag_token
     character (len=*), intent (in) :: char_string
     logical :: flag
     flag = .not. (char_string == dag_token)
   end function char_string_ne_dag_token
 
 @ %def char_string_ne_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental function dag_string_ne_char_string (dag_string, char_string) result (flag)
     type (dag_string_t), intent (in) :: dag_string
     character (len=*), intent (in) :: char_string
     logical :: flag
     flag = .not. (dag_string == char_string)
   end function dag_string_ne_char_string
 
 @ %def dag_string_ne_char_string
 <<Cascades2 lexer: procedures>>=
   elemental function char_string_ne_dag_string (char_string, dag_string) result (flag)
     type (dag_string_t), intent (in) :: dag_string
     character (len=*), intent (in) :: char_string
     logical :: flag
     flag = .not. (char_string == dag_string)
   end function char_string_ne_dag_string
 
 @ %def char_string_ne_dag_string
 @ Convert a [[dag_token]] or [[dag_string]] to character.
 <<Cascades2 lexer: public>>=
   public :: char
 <<Cascades2 lexer: interfaces>>=
   interface char
      module procedure char_dag_token
      module procedure char_dag_string
   end interface char
 
 @ %def interfaces
 <<Cascades2 lexer: procedures>>=
   pure function char_dag_token (dag_token) result (char_string)
     type (dag_token_t), intent (in) :: dag_token
     character (dag_token%char_len) :: char_string
     integer :: i
     integer :: name_len
     integer :: bc_pos
     integer :: n_digits
     character (len=9) :: fmt_spec
     select case (dag_token%type)
     case (EMPTY_TK)
        char_string = ""
     case (NEW_LINE_TK)
        char_string = BACKSLASH_CHAR
     case (BLANC_SPACE_TK)
        char_string = " "
     case (COLON_TK)
        char_string = ":"
     case (COMMA_TK)
        char_string = ","
     case (VERTICAL_BAR_TK)
        char_string = "|"
     case (OPEN_PAR_TK)
        char_string = "("
     case (CLOSED_PAR_TK)
        char_string = ")"
     case (OPEN_CURLY_TK)
        char_string = "{"
     case (CLOSED_CURLY_TK)
        char_string = "}"
     case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
        n_digits = dag_token%char_len - 3
        fmt_spec = ""
        if (n_digits > 9) then
           write (fmt_spec, fmt="(A,I2,A)") "(A,I", n_digits, ",A)"
        else
           write (fmt_spec, fmt="(A,I1,A)") "(A,I", n_digits, ",A)"
        end if
        select case (dag_token%type)
           case (DAG_NODE_TK)
              write (char_string, fmt=fmt_spec) "<N", dag_token%index, ">"
           case (DAG_OPTIONS_TK)
              write (char_string, fmt=fmt_spec) "<O", dag_token%index, ">"
           case (DAG_COMBINATION_TK)
              write (char_string, fmt=fmt_spec) "<C", dag_token%index, ">"
           end select
     case (NODE_TK)
        name_len = len_trim (dag_token%particle_name)
        char_string = dag_token%particle_name
        bc_pos = name_len + 1
        char_string(bc_pos:bc_pos) = "["
        do i=0, bit_size (dag_token%bincode) - 1
           if (btest (dag_token%bincode, i)) then
              bc_pos = bc_pos + 1
              select case (i)
              case (0, 1, 2, 3, 4, 5, 6, 7, 8)
                 write (char_string(bc_pos:bc_pos), fmt="(I1)") i + 1
              case (9)
                 write (char_string(bc_pos:bc_pos), fmt="(A1)") "A"
              case (10)
                 write (char_string(bc_pos:bc_pos), fmt="(A1)") "B"
              case (11)
                 write (char_string(bc_pos:bc_pos), fmt="(A1)") "C"
              end select
              bc_pos = bc_pos + 1
              if (bc_pos == dag_token%char_len) then
                 write (char_string(bc_pos:bc_pos), fmt="(A1)") "]"
                 return
              else
                 write (char_string(bc_pos:bc_pos), fmt="(A1)") "/"
              end if
           end if
        enddo
     end select
   end function char_dag_token
 
 @ %def char_dag_token
 <<Cascades2 lexer: procedures>>=
   pure function char_dag_string (dag_string) result (char_string)
     type (dag_string_t), intent (in) :: dag_string
     character (dag_string%char_len) :: char_string
     integer :: pos
     integer :: i
     char_string = ""
     pos = 0
     do i=1, size(dag_string%t)
        char_string(pos+1:pos+dag_string%t(i)%char_len) = char (dag_string%t(i))
        pos = pos + dag_string%t(i)%char_len
     enddo
   end function char_dag_string
 
 @ %def char_dag_string
 @ Remove all tokens which are irrelevant for parsing. These are of type
 [[NEW_LINE_TK]], [[BLANC_SPACE_TK]] and [[EMTPY_TK]].
 <<Cascades2 lexer: dag string: TBP>>=
   procedure :: clean => dag_string_clean
 <<Cascades2 lexer: procedures>>=
   subroutine dag_string_clean (dag_string)
     class (dag_string_t), intent (inout) :: dag_string
     type (dag_token_t), dimension(:), allocatable :: tmp_token
     integer :: n_keep
     integer :: i
     n_keep = 0
     dag_string%char_len = 0
     allocate (tmp_token (size(dag_string%t)))
     do i=1, size (dag_string%t)
        select case (dag_string%t(i)%type)
        case(NEW_LINE_TK, BLANC_SPACE_TK, EMPTY_TK)
        case default
           n_keep = n_keep + 1
           tmp_token(n_keep) = dag_string%t(i)
           dag_string%char_len = dag_string%char_len + dag_string%t(i)%char_len
        end select
     enddo
     deallocate (dag_string%t)
     allocate (dag_string%t(n_keep))
     dag_string%t = tmp_token(:n_keep)
   end subroutine dag_string_clean
 
 @ %def dag_string_clean
 @ If we operate explicitly on the [[token]] array [[t]] of a [[dag_string]],
 the variable [[char_len]] is not automatically modified. It can however be
 determined afterwards using the following subroutine.
 <<Cascades2 lexer: dag string: TBP>>=
   procedure :: update_char_len => dag_string_update_char_len
 <<Cascades2 lexer: procedures>>=
   subroutine dag_string_update_char_len (dag_string)
     class (dag_string_t), intent (inout) :: dag_string
     integer :: char_len
     integer :: i
     char_len = 0
     if (allocated (dag_string%t)) then
        do i=1, size (dag_string%t)
           char_len = char_len + dag_string%t(i)%char_len
        enddo
     end if
     dag_string%char_len = char_len
   end subroutine dag_string_update_char_len
 
 @ %def dag_string_update_char_len
 @ Append a [[dag_string]] to a [[dag_chain]]. The argument [[char_string]]
 is of type [[character]] because the subroutine is used for reading from
 the file produced by O'Mega which is first read line by line to a character
 variable.
 <<Cascades2 lexer: dag chain: TBP>>=
   procedure :: append => dag_chain_append_string
 <<Cascades2 lexer: procedures>>=
   subroutine dag_chain_append_string (dag_chain, char_string)
     class (dag_chain_t), intent (inout) :: dag_chain
     character (len=*), intent (in) :: char_string
     if (.not. associated (dag_chain%first)) then
        allocate (dag_chain%first)
        dag_chain%last => dag_chain%first
     else
        allocate (dag_chain%last%next)
        dag_chain%last => dag_chain%last%next
     end if
     dag_chain%last = char_string
     dag_chain%char_len = dag_chain%char_len + dag_chain%last%char_len
     dag_chain%t_size = dag_chain%t_size + size (dag_chain%last%t)
   end subroutine dag_chain_append_string
 
 @ %def dag_chain_append_string
 @ Reduce the linked list of [[dag_string]] objects which are attached
 to a given [[dag_chain]] object to a single [[dag_string]].
 <<Cascades2 lexer: dag chain: TBP>>=
   procedure :: compress => dag_chain_compress
 <<Cascades2 lexer: procedures>>=
   subroutine dag_chain_compress (dag_chain)
     class (dag_chain_t), intent (inout) :: dag_chain
     type (dag_string_t), pointer :: current
     type (dag_string_t), pointer :: remove
     integer :: filled_t
     current => dag_chain%first
     dag_chain%first => null ()
     allocate (dag_chain%first)
     dag_chain%last => dag_chain%first
     dag_chain%first%char_len = dag_chain%char_len
     allocate (dag_chain%first%t (dag_chain%t_size))
     filled_t = 0
     do while (associated (current))
        dag_chain%first%t(filled_t+1:filled_t+size(current%t)) = current%t
        filled_t = filled_t + size (current%t)
        remove => current
        current => current%next
        deallocate (remove)
     enddo
   end subroutine dag_chain_compress
 
 @ %def dag_chain_compress
 @ Finalizer for [[dag_string_t]].
 <<Cascades2 lexer: dag string: TBP>>=
   procedure :: final => dag_string_final
 <<Cascades2 lexer: procedures>>=
   subroutine dag_string_final (dag_string)
     class (dag_string_t), intent (inout) :: dag_string
     if (allocated (dag_string%t)) deallocate (dag_string%t)
     dag_string%next => null ()
   end subroutine dag_string_final
 
 @ %def dag_string_final
 @ Finalizer for [[dag_chain_t]].
 <<Cascades2 lexer: dag chain: TBP>>=
   procedure :: final => dag_chain_final
 <<Cascades2 lexer: procedures>>=
   subroutine dag_chain_final (dag_chain)
     class (dag_chain_t), intent (inout) :: dag_chain
     type (dag_string_t), pointer :: current
     current => dag_chain%first
     do while (associated (current))
        dag_chain%first => dag_chain%first%next
        call current%final ()
        deallocate (current)
        current => dag_chain%first
     enddo
     dag_chain%last => null ()
   end subroutine dag_chain_final
 
 @ %def dag_chain_final
 <<[[cascades2_lexer_ut.f90]]>>=
 <<File header>>
 
 module cascades2_lexer_ut
   use unit_tests
   use cascades2_lexer_uti
 
 <<Standard module head>>
 
 <<Cascades2 lexer: public test>>
 
 contains
 
 <<Cascades2 lexer: test driver>>
 
 end module cascades2_lexer_ut
 @ %def cascades2_lexer_ut
 @
 <<[[cascades2_lexer_uti.f90]]>>=
 <<File header>>
 
 module cascades2_lexer_uti
 
 <<Use kinds>>
 <<Use strings>>
   use numeric_utils
 
   use cascades2_lexer
 
 <<Standard module head>>
 
 <<Cascades2 lexer: test declarations>>
 
 contains
 
 <<Cascades2 lexer: tests>>
 
 end module cascades2_lexer_uti
 @ %def cascades2_lexer_uti
 @ API: driver for the unit tests below.
 <<Cascades2 lexer: public test>>=
   public :: cascades2_lexer_test
 <<Cascades2 lexer: test driver>>=
   subroutine cascades2_lexer_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Cascades2 lexer: execute tests>>
   end subroutine cascades2_lexer_test
 
 @ %def cascades2_lexer_test
 @
 <<Cascades2 lexer: execute tests>>=
   call test (cascades2_lexer_1, "cascades2_lexer_1", &
        "make phase-space", u, results)
 <<Cascades2 lexer: test declarations>>=
   public :: cascades2_lexer_1
 <<Cascades2 lexer: tests>>=
   subroutine cascades2_lexer_1 (u)
     integer, intent(in) :: u
     integer :: u_in = 8
     character (len=300) :: line
     integer :: stat
     logical :: fail
     type (dag_string_t) :: dag_string
 
     write (u, "(A)")  "* Test output: cascades2_lexer_1"
     write (u, "(A)")  "*   Purpose: read lines of O'Mega's phase space output, translate"
     write (u, "(A)")  "*            to dag_string, retranslate to character string and"
     write (u, "(A)")  "*            compare"
     write (u, "(A)")
 
     open (unit=u_in, file="cascades2_lexer_1.fds", status='old', action='read')
 
     stat = 0
     fail = .false.
     read (unit=u_in, fmt="(A)", iostat=stat) line
     do while (stat == 0 .and. .not. fail)
        read (unit=u_in, fmt="(A)", iostat=stat) line
        if (stat /= 0) exit
        dag_string = line
        fail = (char(dag_string) /= line)
     enddo
     if (fail) then
        write (u, "(A)")  "* Test result: Test failed!"
     else
        write (u, "(A)")  "* Test result: Test passed"
     end if
 
     close (u_in)
     write (u, *)
     write (u, "(A)")  "* Test output end: cascades2_lexer_1"
   end subroutine cascades2_lexer_1
 
 @ %def cascades2_lexer_1
 @%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{An alternative cascades module}
 This module might replace the module [[cascades]], which generates
 suitable phase space parametrizations and generates the phase space file.
 The mappings, as well as the criteria to determine these, do not change.
 
 The advantage of this module is that it makes use of the [[O'Mega]] matrix
 element generator which provides the relevant Feynman diagrams (the ones
 which can be constructed only from 3-vertices). In principle, the
 construction of these diagrams is also one of the tasks of the existing
 [[cascades]] module, in which the diagrams would correspond to a set of
 cascades. It starts by creating cascades which correspond to the
 outgoing particles. These are combined to a new cascade using the
 vertices of the model. In this way, since each cascade knows the
 daughter cascades from which it is built, complete Feynman diagrams are
 represented by sets of cascades, as soon as the existing cascades can be
 recombined with the incoming particle(s).
 
 In this module, the Feynman diagrams are represented by the type
 [[feyngraph_t]], which represents the Feynman diagrams as a tree of
 nodes. The object which contains the necessary kinematical information
 to determine mappings, and hence sensible phase space parametrizations
 is of another type, called [[kingraph_t]], which is built from a
 corresponding [[feyngraph]] object.
 
 There are two types of output which can be produced by [[O'Mega]] and
 are potentially relevant here. The first type contains all tree
 diagrams for the process under consideration, where each line of the
 output corresponds to one Feynman diagram. This output is easy to read,
 but can be very large, depending on the number of particles involved in
 the process. Moreover, it repeats substructures of the diagrams which
 are part of more than one diagram. One could in principle work with
 this output and construct a [[feyngraph]] from each line, if allowed,
 i.e. if there are only 3-vertices.
 
 The other output contains also all of these Feynman diagrams, but in
 a factorized form. This means that the substructures which appear in
 several Feynman diagrams, are written only once, if possible. This
 leads to a much shorter input file, which speeds up the parsing
 process. Furthermore it makes it possible to reconstruct the
 [[feyngraphs]] in such a way that the calculations concerning
 subdiagrams which reappear in other [[feyngraphs]] have to be
 performed only once. This is already the case in the existing
 [[cascades]] module but can be exploited more efficiently here
 because the possible graphs are well known from the input file, whereas
 the [[cascades]] module would create a large number of [[cascades]]
 which do not lead to a complete Feynman diagram of the given process.
 <<[[cascades2.f90]]>>=
 <<File header>>
 
 module cascades2
 
 <<Use kinds>>
   use kinds, only: TC, i8
 <<Use debug>>
   use cascades2_lexer
   use sorting
   use flavors
   use model_data
   use iso_varying_string, string_t => varying_string
   use io_units
   use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
   use phs_forests, only: phs_parameters_t
   use diagnostics
   use hashes
   use cascades, only: phase_space_vanishes, MAX_WARN_RESONANCE
   use, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit
   use resonances, only: resonance_info_t
   use resonances, only: resonance_history_t
   use resonances, only: resonance_history_set_t
 
 <<Standard module head>>
 
 <<Cascades2: public>>
 
 <<Cascades2: parameters>>
 
 <<Cascades2: types>>
 
 <<Cascades2: interfaces>>
 
 contains
 
 <<Cascades2: procedures>>
 
 end module cascades2
 
 @ %def cascades2
 @
 \subsection{Particle properties}
 We define a type holding the properties of the particles which are needed
 for parsing and finding the phase space parametrizations and mappings.
 The properties of all particles which appear in the parsed
 Feynman diagrams for the given process will be stored in a central place,
 and only pointers to these objects are used.
 <<Cascades2: types>>=
   type :: part_prop_t
      character (len=LABEL_LEN) :: particle_label
      integer :: pdg = 0
      real(default) :: mass = 0.
      real :: width = 0.
      integer :: spin_type = 0
      logical :: is_vector = .false.
      logical :: empty = .true.
      type (part_prop_t), pointer :: anti => null ()
      type (string_t) :: tex_name
    contains
    <<Cascades2: part prop: TBP>>
   end type part_prop_t
 
 @ %def part_prop_t
 @ The [[particle_label]] in [[part_prop_t]] is simply the particle name
 (e.g. 'W+'). The corresponding variable in the type [[f_node_t]] contains
 some additional information related to the external momenta, see below.
 The length of the [[character]] variable is fixed as:
 <<Cascades2: parameters>>=
   integer, parameter :: LABEL_LEN=30
 @ %def LABEL_LEN
 <<Cascades2: part prop: TBP>>=
 procedure :: final => part_prop_final
 <<Cascades2: procedures>>=
   subroutine part_prop_final (part)
     class(part_prop_t), intent(inout) :: part
     part%anti => null ()
   end subroutine part_prop_final
 
 @ %def part_prop_final
 @
 \subsection{The mapping modes}
 The possible mappings are essentially the same as in [[cascades]], but we
 introduce in addition the mapping constant [[NON_RESONANT]], which does
 not refer to a new mapping; it corresponds to the nonresonant version of
 a potentially resonant particle (or [[k_node]]). This becomes relevant
 when we compare [[k_nodes]] to eliminate equivalences.
 <<Cascades2: parameters>>=
   integer, parameter :: &
        & NONRESONANT = -2, EXTERNAL_PRT = -1, &
        & NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL =  2, U_CHANNEL = 3, &
        & RADIATION = 4, COLLINEAR = 5, INFRARED = 6, &
        & STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, &
        & ON_SHELL = 99
 @ %def NONRESONANT EXTERNAL_PRT
 @ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL
 @ %def RADIATION COLLINEAR INFRARED
 @ %def STEP_MAPPING_E STEP_MAPPING_H
 @ %def ON_SHELL
 @
 \subsection{Grove properties}
 The channels or [[kingraphs]] will be grouped in groves, i.e. sets of
 channels, which share some characteristic numbers. These numbers are
 stored in the following type:
 <<Cascades2: types>>=
   type :: grove_prop_t
      integer :: multiplicity = 0
      integer :: n_resonances = 0
      integer :: n_log_enhanced = 0
      integer :: n_off_shell = 0
      integer :: n_t_channel = 0
      integer :: res_hash = 0
   end type grove_prop_t
 
 @ %def grove_prop_t
 @
 \subsection{The tree type}
 This type contains all the information which is needed to
 reconstruct a [[feyngraph]] or [[kingraph]]. We store bincodes, pdg codes
 and mappings for all nodes of a valid [[kingraph]]. If we label the
 external particles as given in the process definition with integer
 numbers representing their position in the process definition, the bincode
 would be the number that one obtains by setting the bit at the position
 that is given by this number. If we combine two particles/nodes to a third
 one (using a three-vertex of the given model), the bincode is the number which
 one obtains by setting all the bits which are set for the two particles.
 The [[pdg]] and [[mapping]] are simply the pdg-code and mapping at the
 position (i.e. propagator or external particle) which is specified by the
 corresponding bincode. We use [[tree_t]] not only for completed [[kingraphs]],
 but also for all [[k_nodes]], which are a subtree of a [[kingraph]].
 <<Cascades2: types>>=
   type :: tree_t
      integer(TC), dimension(:), allocatable :: bc
      integer, dimension(:), allocatable :: pdg
      integer, dimension(:), allocatable :: mapping
      integer :: n_entries = 0
      logical :: keep = .true.
      logical :: empty = .true.
    contains
    <<Cascades2: tree: TBP>>
   end type tree_t
 
 @ %def tree_t
 <<Cascades2: tree: TBP>>=
   procedure :: final => tree_final
 <<Cascades2: procedures>>=
   subroutine tree_final (tree)
     class (tree_t), intent (inout) :: tree
     if (allocated (tree%bc)) deallocate (tree%bc)
     if (allocated (tree%pdg)) deallocate (tree%pdg)
     if (allocated (tree%mapping)) deallocate (tree%mapping)
   end subroutine tree_final
 
 @ %def tree_final
 <<Cascades2: interfaces>>=
   interface assignment (=)
      module procedure tree_assign
   end interface assignment (=)
 
 <<Cascades2: procedures>>=
   subroutine tree_assign (tree1, tree2)
     type (tree_t), intent (inout) :: tree1
     type (tree_t), intent (in) :: tree2
     if (allocated (tree2%bc)) then
        allocate (tree1%bc(size(tree2%bc)))
        tree1%bc = tree2%bc
     end if
     if (allocated (tree2%pdg)) then
        allocate (tree1%pdg(size(tree2%pdg)))
        tree1%pdg = tree2%pdg
     end if
     if (allocated (tree2%mapping)) then
        allocate (tree1%mapping(size(tree2%mapping)))
        tree1%mapping = tree2%mapping
     end if
     tree1%n_entries = tree2%n_entries
     tree1%keep = tree2%keep
     tree1%empty = tree2%empty
   end subroutine tree_assign
 
 @ %def tree_assign
 @
 \subsection{Add entries to the tree}
 The following procedures fill the arrays in [[tree_t]] with entries
 resulting from the bincode and mapping assignment.
 <<Cascades2: tree: TBP>>=
   procedure :: add_entry_from_numbers => tree_add_entry_from_numbers
   procedure :: add_entry_from_node => tree_add_entry_from_node
   generic :: add_entry =>  add_entry_from_numbers, add_entry_from_node
 @ Here we add a single entry to each of the arrays. This will exclusively
 be used for external particles.
 <<Cascades2: procedures>>=
   subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping)
     class (tree_t), intent (inout) :: tree
     integer(TC), intent (in) :: bincode
     integer, intent (in) :: pdg
     integer, intent (in) :: mapping
     integer :: pos
     if (tree%empty) then
        allocate (tree%bc(1))
        allocate (tree%pdg(1))
        allocate (tree%mapping(1))
        pos = tree%n_entries + 1
        tree%bc(pos) = bincode
        tree%pdg(pos) = pdg
        tree%mapping(pos) = mapping
        tree%n_entries = pos
        tree%empty = .false.
     end if
   end subroutine tree_add_entry_from_numbers
 
 @ %def tree_add_entry_from_numbers
 @ Here we merge two existing subtrees and a single entry (bc, pdg and
 mapping).
 <<Cascades2: procedures>>=
   subroutine tree_merge (tree, tree1, tree2, bc, pdg, mapping)
     class (tree_t), intent (inout) :: tree
     type (tree_t), intent (in) :: tree1, tree2
     integer(TC), intent (in) :: bc
     integer, intent (in) :: pdg, mapping
     integer :: tree_size
     integer :: i1, i2
     if (tree%empty) then
        i1 = tree1%n_entries
        i2 = tree1%n_entries + tree2%n_entries
        tree_size = tree1%n_entries + tree2%n_entries + 1
        allocate (tree%bc (tree_size))
        allocate (tree%pdg (tree_size))
        allocate (tree%mapping (tree_size))
        tree%bc(:i1) = tree1%bc
        tree%pdg(:i1) = tree1%pdg
        tree%mapping(:i1) = tree1%mapping
        tree%bc(i1+1:i2) = tree2%bc
        tree%pdg(i1+1:i2) = tree2%pdg
        tree%mapping(i1+1:i2) = tree2%mapping
        tree%bc(tree_size) = bc
        tree%pdg(tree_size) = pdg
        tree%mapping(tree_size) = mapping
        tree%n_entries = tree_size
        tree%empty = .false.
     end if
   end subroutine tree_merge
 
 @ %def tree_merge
 @ Here we add entries to a tree for a given [[k_node]], which means that
 we first have to determine whether the node is external or internal.
 The arrays are sorted after the entries have been added (see below for
 details).
 <<Cascades2: procedures>>=
   subroutine tree_add_entry_from_node (tree, node)
     class (tree_t), intent (inout) :: tree
     type (k_node_t), intent (in) :: node
     integer :: pdg
     if (node%t_line) then
        pdg = abs (node%particle%pdg)
     else
        pdg = node%particle%pdg
     end if
     if (associated (node%daughter1) .and. &
          associated (node%daughter2)) then
        call tree_merge (tree, node%daughter1%subtree, &
             node%daughter2%subtree, node%bincode, &
             node%particle%pdg, node%mapping)
     else
        call tree_add_entry_from_numbers (tree, node%bincode, &
             node%particle%pdg, node%mapping)
     end if
     call tree%sort ()
   end subroutine tree_add_entry_from_node
 
 @ %def tree_add_entry_from_node
 @ For a well-defined order of the elements of the arrays in [[tree_t]],
 the elements can be sorted. The bincodes (entries of [[bc]]) are
 simply ordered by size, the [[pdg]] and [[mapping]] entries go to the
 positions of the corresponding [[bc]] values.
 <<Cascades2: tree: TBP>>=
   procedure :: sort => tree_sort
 <<Cascades2: procedures>>=
   subroutine tree_sort (tree)
     class (tree_t), intent (inout) :: tree
     integer(TC), dimension(size(tree%bc)) :: bc_tmp
     integer, dimension(size(tree%pdg)) :: pdg_tmp, mapping_tmp
     integer, dimension(1) :: pos
     integer :: i
     bc_tmp = tree%bc
     pdg_tmp = tree%pdg
     mapping_tmp = tree%mapping
     do i = size(tree%bc),1,-1
        pos = maxloc (bc_tmp)
        tree%bc(i) = bc_tmp (pos(1))
        tree%pdg(i) = pdg_tmp (pos(1))
        tree%mapping(i) = mapping_tmp (pos(1))
        bc_tmp(pos(1)) = 0
     end do
   end subroutine tree_sort
 
 @ %def tree_sort
 @
 \subsection{Graph types}
 We define an abstract type which will give rise to two different types:
 The type [[feyngraph_t]] contains the pure information of the
 corresponding Feynman diagram, but also a list of objects of the
 [[kingraph]] type which contain the kinematically relevant data for the
 mapping calculation as well as the mappings themselves. Every graph
 should have an index which is unique. Graphs which are not needed any
 more can be disabled by setting the [[keep]] variable to [[false]].
 <<Cascades2: types>>=
   type, abstract :: graph_t
      integer :: index = 0
      integer :: n_nodes = 0
      logical :: keep = .true.
   end type graph_t
 
 @ %def graph_t
 @ This is the type representing the Feynman diagrams which are read from
 an input file created by O'Mega. It is a tree of nodes, which we call
 [[f_nodes]], so that [[feyngraph_t]] contains a pointer to the root of
 this tree, and each node can have two daughter nodes. The case of only
 one associated daughter should never appear, because in the method of
 phase space parametrization which is used here, we combine always two
 particle momenta to a third one. The [[feyngraphs]] will be arranged in
 a linked list. This is why we have a pointer to the next graph. The
 [[kingraphs]] on the other hand are arranged in linked lists which are
 attached to the corresponding [[feyngraph]]. In general, a [[feyngraph]]
 can give rise to more than one [[kingraph]] because we make a copy
 every time a particle can be resonant, so that in the copy we keep
 the particle nonresonant.
 <<Cascades2: types>>=
   type, extends (graph_t) :: feyngraph_t
      type (string_t) :: omega_feyngraph_output
      type (f_node_t), pointer :: root => null ()
      type (feyngraph_t), pointer :: next => null()
      type (kingraph_t), pointer :: kin_first => null ()
      type (kingraph_t), pointer :: kin_last => null ()
    contains
    <<Cascades2: feyngraph: TBP>>
   end type feyngraph_t
 
 @ %def feyngraph_t
 @ A container for a pointer of type [[feyngraph_t]]. This is used to
 realize arrays of these pointers.
 <<Cascades2: types>>=
   type :: feyngraph_ptr_t
      type (feyngraph_t), pointer :: graph => null ()
   end type feyngraph_ptr_t
 
 @ %def feyngraph_ptr_t
 @
 The length of a string describing a Feynman diagram which is produced by
 O'Mega is fixed by the parameter
 <<Cascades2: parameters>>=
   integer, parameter :: FEYNGRAPH_LEN=300
 @ %def feyngraph_len
 <<Cascades2: feyngraph: TBP>>=
   procedure :: final => feyngraph_final
 <<Cascades2: procedures>>=
   subroutine feyngraph_final (graph)
     class(feyngraph_t), intent(inout) :: graph
     type (kingraph_t), pointer :: current
     graph%root => null ()
     graph%kin_last => null ()
     do while (associated (graph%kin_first))
        current => graph%kin_first
        graph%kin_first => graph%kin_first%next
        call current%final ()
        deallocate (current)
     enddo
   end subroutine feyngraph_final
 
 @ %def feyngraph_final
 This is the type of graph which is used to find the phase space channels,
 or in other words, each kingraph could correspond to a channel, if it is
 not eliminated for kinematical reasons or due to an equivalence. For the
 linked list which is attached to the corresponding [[feyngraph]], we
 need the [[next]] pointer, whereas [[grove_next]] points to the next
 [[kingraph]] within a grove. The information which is relevant for the
 specification of a channel is stored in [[tree]]. We use [[grove_prop]]
 to sort the [[kingraph]] in a grove in which all [[kingraphs]] are
 characterized by the numbers contained in [[grove_prop]]. Later these
 groves are further subdevided using the resonance hash. A [[kingraph]]
 which is constructed directly from the output of O'Mega, is not
 [[inverse]]. In this case the first incoming particle is the root ofthe
 tree. In a scattering process, we can also construct a [[kingraph]]
 where the root of the tree is the second incoming particle. In this
 case the value of [[inverse]] is [[.true.]].
 <<Cascades2: types>>=
   type, extends (graph_t) :: kingraph_t
      type (k_node_t), pointer :: root => null ()
      type (kingraph_t), pointer :: next => null()
      type (kingraph_t), pointer :: grove_next => null ()
      type (tree_t) :: tree
      type (grove_prop_t) :: grove_prop
      logical :: inverse = .false.
      integer :: prc_component = 0
      contains
    <<Cascades2: kingraph: TBP>>
   end type kingraph_t
 
 @ %def kingraph_t
 @ Another container for a pointer to emulate arrays of pointers:
 <<Cascades2: types>>=
   type :: kingraph_ptr_t
      type (kingraph_t), pointer :: graph => null ()
   end type kingraph_ptr_t
 
 @ %def kingraph_ptr_t
 @
 <<Cascades2: kingraph: TBP>>=
   procedure :: final => kingraph_final
 <<Cascades2: procedures>>=
   subroutine kingraph_final (graph)
     class(kingraph_t), intent(inout) :: graph
     graph%root => null ()
     graph%next => null ()
     graph%grove_next => null ()
     call graph%tree%final ()
   end subroutine kingraph_final
 
 @ %def kingraph_final
 @
 \subsection{The node types}
 We define an abstract type containing variables which are needed for
 [[f_node_t]] as well as [[k_node_t]]. We say that a node is on the
 t-line if it lies between the two nodes which correspond to the two
 incoming particles. [[incoming]] and [[tline]] are used only for
 scattering processes and remain [[.false.]] in decay processes. The
 variable [[n_subtree_nodes]] holds the number of nodes (including the
 node itself) of the subtree of which the node is the root.
 <<Cascades2: types>>=
   type, abstract :: node_t
      type (part_prop_t), pointer :: particle => null ()
      logical :: incoming = .false.
      logical :: t_line = .false.
      integer :: index = 0
      logical :: keep = .true.
      integer :: n_subtree_nodes = 1
   end type node_t
 
 @  %def node_t
 @ We use two different list types for the different kinds of nodes. We
 therefore start with an abstract type:
 <<Cascades2: types>>=
   type, abstract :: list_t
      integer :: n_entries = 0
   end type list_t
 
 @ %def list_t
 @ Since the contents of the lists are different, we introduce two
 different entry types. Since the trees of nodes use pointers, the nodes
 should only be allocated by a type-bound procedure of the corresponding
 list type, such that we can keep track of all nodes, eventually reuse
 and in the end deallocate nodes correctly, without forgetting any nodes.
 Here is the type for the [[k_nodes]]. The list is a linked list. We want
 to reuse (recycle) the [[k_nodes]] which are neither [[incoming]] nore
 [[t_line]].
 <<Cascades2: types>>=
   type :: k_node_entry_t
      type (k_node_t), pointer :: node => null ()
      type (k_node_entry_t), pointer :: next => null ()
      logical :: recycle = .false.
    contains
    <<Cascades2: k node entry: TBP>>
   end type k_node_entry_t
 
 @ %def k_node_entry_t
 <<Cascades2: k node entry: TBP>>=
   procedure :: final => k_node_entry_final
 <<Cascades2: procedures>>=
   subroutine k_node_entry_final (entry)
     class(k_node_entry_t), intent(inout) :: entry
     if (associated (entry%node)) then
        call entry%node%final
        deallocate (entry%node)
     end if
     entry%next => null ()
   end subroutine k_node_entry_final
 
 @ %def k_node_entry_final
 <<Cascades2: k node entry: TBP>>=
   procedure :: write => k_node_entry_write
 <<Cascades2: procedures>>=
   subroutine k_node_entry_write (k_node_entry, u)
     class (k_node_entry_t), intent (in) :: k_node_entry
     integer, intent (in) :: u
   end subroutine k_node_entry_write
 
 @ %def k_node_entry_write
 @ Here is the list type for [[k_nodes]]. A [[k_node_list]] can be
 declared to be an observer. In this case it does not create any nodes by
 itself, but the entries set their pointers to existing nodes. In this
 way we can use the list structure and the type bound procedures for
 existing nodes.
 <<Cascades2: types>>=
   type, extends (list_t) :: k_node_list_t
      type (k_node_entry_t), pointer :: first => null ()
      type (k_node_entry_t), pointer :: last => null ()
      integer :: n_recycle
      logical :: observer = .false.
    contains
    <<Cascades2: k node list: TBP>>
   end type k_node_list_t
 
 @ %def k_node_list_t
 <<Cascades2: k node list: TBP>>=
   procedure :: final => k_node_list_final
 <<Cascades2: procedures>>=
   subroutine k_node_list_final (list)
     class(k_node_list_t), intent(inout) :: list
     type (k_node_entry_t), pointer :: current
     do while (associated (list%first))
        current => list%first
        list%first => list%first%next
        if (list%observer) current%node => null ()
        call current%final ()
        deallocate (current)
     enddo
   end subroutine k_node_list_final
 
 @ %def k_node_list_final
 @ The [[f_node_t]] type contains the [[particle_label]] variable which is
 extracted from the input file. It consists not only of the particle
 name, but also of some numbers in brackets. These numbers indicate which
 external particles are part of the subtree of this node. The [[f_node]]
 contains also a list of [[k_nodes]]. Therefore, if the nodes are not
 [[incoming]] or [[t_line]], the mapping calculations for these
 [[k_nodes]] which can appear in several [[kingraphs]] have to be
 performed only once.
 <<Cascades2: types>>=
   type, extends (node_t) :: f_node_t
      type (f_node_t), pointer :: daughter1 => null ()
      type (f_node_t), pointer :: daughter2 => null ()
      character (len=LABEL_LEN) :: particle_label
      type (k_node_list_t) :: k_node_list
    contains
    <<Cascades2: f node: TBP>>
   end type f_node_t
 
 @ %def f_node_t
 @ The finalizer nullifies the daughter pointers, since they are
 deallocated, like the [[f_node]] itself, with the finalizer of the
 [[f_node_list]].
 <<Cascades2: f node: TBP>>=
   procedure :: final => f_node_final
 <<Cascades2: procedures>>=
   recursive subroutine f_node_final (node)
     class(f_node_t), intent(inout) :: node
     call node%k_node_list%final ()
     node%daughter1 => null ()
     node%daughter2 => null ()
   end subroutine f_node_final
 
 @ %def f_node_final
 @ Finaliser for [[f_node_entry]].
 <<Cascades2: f node entry: TBP>>=
   procedure :: final => f_node_entry_final
 <<Cascades2: procedures>>=
   subroutine f_node_entry_final (entry)
     class(f_node_entry_t), intent(inout) :: entry
     if (associated (entry%node)) then
        call entry%node%final ()
        deallocate (entry%node)
     end if
     entry%next => null ()
   end subroutine f_node_entry_final
 
 @ %def f_node_entry_final
 @ Set index if not yet done, i.e. if it is zero.
 <<Cascades2: f node: TBP>>=
   procedure :: set_index => f_node_set_index
 <<Cascades2: procedures>>=
   subroutine f_node_set_index (f_node)
     class (f_node_t), intent (inout) :: f_node
     integer, save :: counter = 0
     if (f_node%index == 0) then
        counter = counter + 1
        f_node%index = counter
     end if
   end subroutine f_node_set_index
 
 @ %def f_node_set_index
 @
 Type for the nodes of the tree (lines of the Feynman diagrams). We also need a type containing a
 pointer to a node, which is needed for creating arrays of pointers. This will be used for scattering
 processes where we can take either the first or the second particle to be the root of the tree. Since
 we need both cases for the calculations and O'Mega only gives us one of these, we have to perform a
 transformation of the graph in which some nodes (on the line which we hereafter call t-line) need
 to know their mother and sister nodes, which become their daughters within this transformation.
 <<Cascades2: types>>=
   type :: f_node_ptr_t
      type (f_node_t), pointer :: node => null ()
      contains
        <<Cascades2: f node ptr: TBP>>
   end type f_node_ptr_t
 
 @ %def f_node_ptr_t
 <<Cascades2: f node ptr: TBP>>=
   procedure :: final => f_node_ptr_final
 <<Cascades2: procedures>>=
   subroutine f_node_ptr_final (f_node_ptr)
     class (f_node_ptr_t), intent (inout) :: f_node_ptr
     f_node_ptr%node => null ()
   end subroutine f_node_ptr_final
 
 @ %def f_node_ptr_final
 <<Cascades2: interfaces>>=
   interface assignment (=)
      module procedure f_node_ptr_assign
   end interface assignment (=)
 <<Cascades2: procedures>>=
   subroutine f_node_ptr_assign (ptr1, ptr2)
     type (f_node_ptr_t), intent (out) :: ptr1
     type (f_node_ptr_t), intent (in) :: ptr2
     ptr1%node => ptr2%node
   end subroutine f_node_ptr_assign
 
 @  %def f_node_ptr_assign
 @
 <<Cascades2: types>>=
   type :: k_node_ptr_t
      type (k_node_t), pointer :: node => null ()
   end type k_node_ptr_t
 
 @ %def k_node_ptr_t
 @
 <<Cascades2: types>>=
   type, extends (node_t) :: k_node_t
      type (k_node_t), pointer :: daughter1 => null ()
      type (k_node_t), pointer :: daughter2 => null ()
      type (k_node_t), pointer :: inverse_daughter1 => null ()
      type (k_node_t), pointer :: inverse_daughter2 => null ()
      type (f_node_t), pointer :: f_node => null ()
      type (tree_t) :: subtree
      real (default) :: ext_mass_sum = 0.
      real (default) :: effective_mass = 0.
      logical :: resonant = .false.
      logical :: on_shell = .false.
      logical :: log_enhanced = .false.
      integer :: mapping = NO_MAPPING
      integer(TC) :: bincode = 0
      logical :: mapping_assigned = .false.
      logical :: is_nonresonant_copy = .false.
      logical :: subtree_checked = .false.
      integer :: n_off_shell = 0
      integer :: n_log_enhanced = 0
      integer :: n_resonances = 0
      integer :: multiplicity = 0
      integer :: n_t_channel = 0
      integer :: f_node_index = 0
    contains
    <<Cascades2: k node: TBP>>
   end type k_node_t
 
 @ %def k_node_t
 @
 Subroutine for [[k_node]] assignment.
 <<Cascades2: interfaces>>=
   interface assignment (=)
      module procedure k_node_assign
   end interface assignment (=)
 <<Cascades2: procedures>>=
   subroutine k_node_assign (k_node1, k_node2)
     type (k_node_t), intent (inout) :: k_node1
     type (k_node_t), intent (in) :: k_node2
     k_node1%f_node => k_node2%f_node
     k_node1%particle => k_node2%particle
     k_node1%incoming = k_node2%incoming
     k_node1%t_line = k_node2%t_line
     k_node1%keep = k_node2%keep
     k_node1%n_subtree_nodes = k_node2%n_subtree_nodes
     k_node1%ext_mass_sum = k_node2%ext_mass_sum
     k_node1%effective_mass = k_node2%effective_mass
     k_node1%resonant = k_node2%resonant
     k_node1%on_shell = k_node2%on_shell
     k_node1%log_enhanced = k_node2%log_enhanced
     k_node1%mapping = k_node2%mapping
     k_node1%bincode = k_node2%bincode
     k_node1%mapping_assigned = k_node2%mapping_assigned
     k_node1%is_nonresonant_copy = k_node2%is_nonresonant_copy
     k_node1%n_off_shell = k_node2%n_off_shell
     k_node1%n_log_enhanced = k_node2%n_log_enhanced
     k_node1%n_resonances = k_node2%n_resonances
     k_node1%multiplicity = k_node2%multiplicity
     k_node1%n_t_channel = k_node2%n_t_channel
     k_node1%f_node_index = k_node2%f_node_index
   end subroutine k_node_assign
 
 @  %def k_node_assign
 @ The finalizer of [[k_node_t]] nullifies all pointers to nodes, since the
 deallocation of these nodes takes place in the finalizer of the list by which
 they were created.
 <<Cascades2: k node: TBP>>=
   procedure :: final => k_node_final
 <<Cascades2: procedures>>=
   recursive subroutine k_node_final (k_node)
     class(k_node_t), intent(inout) :: k_node
     k_node%daughter1 => null ()
     k_node%daughter2 => null ()
     k_node%inverse_daughter1 => null ()
     k_node%inverse_daughter2 => null ()
     k_node%f_node => null ()
   end subroutine k_node_final
 
 @ %def k_node_final
 @ Set an index to a [[k_node]], if not yet done, i.e. if it is zero. The
 indices are simply positive integer numbers starting from 1.
 <<Cascades2: k node: TBP>>=
   procedure :: set_index => k_node_set_index
 <<Cascades2: procedures>>=
   subroutine k_node_set_index (k_node)
     class (k_node_t), intent (inout) :: k_node
     integer, save :: counter = 0
     if (k_node%index == 0) then
        counter = counter + 1
        k_node%index = counter
     end if
   end subroutine k_node_set_index
 
 @ %def k_node_set_index
 @ The process type (decay or scattering) is given by an integer which is
 equal to the number of incoming particles.
 <<Cascades2: public>>=
   public :: DECAY, SCATTERING
 <<Cascades2: parameters>>=
   integer, parameter :: DECAY=1, SCATTERING=2
 
 @ %def decay scattering
 @ The entries of the [[f_node_list]] contain the substring of the input
 file from which the node's subtree will be constructed (or a modified
 string containing placeholders for substrings). We use the
 length of this string for fast comparison to find the nodes in the
 [[f_node_list]] which we want to reuse.
 <<Cascades2: types>>=
   type :: f_node_entry_t
      character (len=FEYNGRAPH_LEN) :: subtree_string
      integer :: string_len = 0
      type (f_node_t), pointer :: node => null ()
      type (f_node_entry_t), pointer :: next => null ()
      integer :: subtree_size = 0
    contains
    <<Cascades2: f node entry: TBP>>
   end type f_node_entry_t
 
 @ %def f_node_entry_t
 @ A write method for [[f_node_entry]].
 <<Cascades2: f node entry: TBP>>=
   procedure :: write => f_node_entry_write
 <<Cascades2: procedures>>=
   subroutine f_node_entry_write (f_node_entry, u)
     class (f_node_entry_t), intent (in) :: f_node_entry
     integer, intent (in) :: u
     write (unit=u, fmt='(A)') trim(f_node_entry%subtree_string)
   end subroutine f_node_entry_write
 
 @ %def f_node_entry_write
 <<Cascades2: interfaces>>=
   interface assignment (=)
      module procedure f_node_entry_assign
   end interface assignment (=)
 <<Cascades2: procedures>>=
   subroutine f_node_entry_assign (entry1, entry2)
     type (f_node_entry_t), intent (out) :: entry1
     type (f_node_entry_t), intent (in) :: entry2
     entry1%node => entry2%node
     entry1%subtree_string = entry2%subtree_string
     entry1%string_len = entry2%string_len
     entry1%subtree_size = entry2%subtree_size
   end subroutine f_node_entry_assign
 
 @ %def f_node_entry_assign
 @ This is the list type for [[f_nodes]]. The variable [[max_tree_size]]
 is the number of nodes which appear in a complete graph.
 <<Cascades2: types>>=
   type, extends (list_t) :: f_node_list_t
      type (f_node_entry_t), pointer :: first => null ()
      type (f_node_entry_t), pointer :: last => null ()
      type (k_node_list_t), pointer :: k_node_list => null ()
      integer :: max_tree_size = 0
    contains
    <<Cascades2: f node list: TBP>>
   end type f_node_list_t
 
 @ %def f_node_list_t
 @ Add an entry to the [[f_node_list]]. If the node might be reused, we check first
 using the [[subtree_string]] if there is already a node in the list which
 is the root of exactly the same subtree. Otherwise we add an entry to the
 list and allocate the node. In both cases we return a pointer to the node
 which allows to access the node.
 <<Cascades2: f node list: TBP>>=
   procedure :: add_entry => f_node_list_add_entry
 <<Cascades2: procedures>>=
   subroutine f_node_list_add_entry (list, subtree_string, ptr_to_node, &
        recycle, subtree_size)
     class (f_node_list_t), intent (inout) :: list
     character (len=*), intent (in) :: subtree_string
     type (f_node_t), pointer, intent (out) :: ptr_to_node
     logical, intent (in) :: recycle
     integer, intent (in), optional :: subtree_size
     type (f_node_entry_t), pointer :: current
     type (f_node_entry_t), pointer :: second
     integer :: subtree_len
     ptr_to_node => null ()
     if (recycle) then
        subtree_len = len_trim (subtree_string)
        current => list%first
        do while (associated (current))
           if (present (subtree_size)) then
              if (current%subtree_size /= subtree_size) exit
           end if
           if (current%string_len == subtree_len) then
              if (trim (current%subtree_string) == trim (subtree_string)) then
                 ptr_to_node => current%node
                 exit
              end if
           end if
           current => current%next
        enddo
     end if
     if (.not. associated (ptr_to_node)) then
        if (list%n_entries == 0) then
           allocate (list%first)
           list%last => list%first
        else
           second => list%first
           list%first => null ()
           allocate (list%first)
           list%first%next => second
        end if
        list%n_entries = list%n_entries + 1
        list%first%subtree_string = trim(subtree_string)
        list%first%string_len = subtree_len
        if (present (subtree_size)) list%first%subtree_size = subtree_size
        allocate (list%first%node)
        call list%first%node%set_index ()
        ptr_to_node => list%first%node
     end if
   end subroutine f_node_list_add_entry
 
 @ %def f_node_list_add_entry
 @ A write method for debugging.
 <<Cascades2: f node list: TBP>>=
   procedure :: write => f_node_list_write
 <<Cascades2: procedures>>=
   subroutine f_node_list_write (f_node_list, u)
     class (f_node_list_t), intent (in) :: f_node_list
     integer, intent (in) :: u
     type (f_node_entry_t), pointer :: current
     integer :: pos = 0
     current => f_node_list%first
     do while (associated (current))
        pos = pos + 1
        write (unit=u, fmt='(A,I10)') 'entry #: ', pos
        call current%write (u)
        write (unit=u, fmt=*)
        current => current%next
     enddo
   end subroutine f_node_list_write
 
 @ %def f_node_list_write
 <<Cascades2: interfaces>>=
   interface assignment (=)
      module procedure k_node_entry_assign
   end interface assignment (=)
 <<Cascades2: procedures>>=
   subroutine k_node_entry_assign (entry1, entry2)
     type (k_node_entry_t), intent (out) :: entry1
     type (k_node_entry_t), intent (in) :: entry2
     entry1%node => entry2%node
     entry1%recycle = entry2%recycle
   end subroutine k_node_entry_assign
 
 @ %def k_node_entry_assign
 @ Add an entry to the [[k_node_list]]. We have to specify if the
 node can be reused. The check for existing reusable nodes happens with
 [[k_node_list_get_nodes]] (see below).
 <<Cascades2: k node list: TBP>>=
   procedure :: add_entry => k_node_list_add_entry
 <<Cascades2: procedures>>=
   recursive subroutine k_node_list_add_entry (list, ptr_to_node, recycle)
     class (k_node_list_t), intent (inout) :: list
     type (k_node_t), pointer, intent (out) :: ptr_to_node
     logical, intent (in) :: recycle
     if (list%n_entries == 0) then
        allocate (list%first)
        list%last => list%first
     else
        allocate (list%last%next)
        list%last => list%last%next
     end if
     list%n_entries = list%n_entries + 1
     list%last%recycle = recycle
     allocate (list%last%node)
     call list%last%node%set_index ()
     ptr_to_node => list%last%node
   end subroutine k_node_list_add_entry
 
 @ %def k_node_list_add_entry
 @ We need a similar subroutine for adding only a pointer to a list. This
 is needed for a [[k_node_list]] which is only an observer, i.e. it does
 not create any nodes by itself.
 <<Cascades2: k node list: TBP>>=
   procedure :: add_pointer => k_node_list_add_pointer
 <<Cascades2: procedures>>=
   subroutine k_node_list_add_pointer (list, ptr_to_node, recycle)
     class (k_node_list_t), intent (inout) :: list
     type (k_node_t), pointer, intent (in) :: ptr_to_node
     logical, optional, intent (in) :: recycle
     logical :: rec
     if (present (recycle)) then
        rec = recycle
     else
        rec = .false.
     end if
     if (list%n_entries == 0) then
        allocate (list%first)
        list%last => list%first
     else
        allocate (list%last%next)
        list%last => list%last%next
     end if
     list%n_entries = list%n_entries + 1
     list%last%recycle = rec
     list%last%node => ptr_to_node
   end subroutine k_node_list_add_pointer
 
 @ %def k_node_list_add_pointer
 @ The [[k_node_list]] can also be used to collect [[k_nodes]] which belong to
 different [[f_nodes]] in order to compare these. This is done only for nodes
 which have the same number of subtree nodes. We compare all nodes of the
 list with each other (as long as the node is not deactivated, i.e. if
 the [[keep]] variable is set to [[.true.]]) using the subroutine
 [[subtree_select]]. If it turns out that two nodes are equivalent, we
 keep only one of them. The term equivalent in this module refers to trees
 or subtrees which differ in the pdg codes at positions where
 the trivial mapping is used ([[NO_MAPPING]] or [[NON_RESONANT]]) so that
 the mass of the particle does not matter. Depending on the available
 couplings, two equivalent subtrees could eventually lead to the same phase
 space channels, which is why only one of them is kept.
 <<Cascades2: k node list: TBP>>=
   procedure :: check_subtree_equivalences => k_node_list_check_subtree_equivalences
 <<Cascades2: procedures>>=
   subroutine k_node_list_check_subtree_equivalences (list, model)
     class (k_node_list_t), intent (inout) :: list
     type (model_data_t), intent (in) :: model
     type (k_node_ptr_t), dimension (:), allocatable :: set
     type (k_node_entry_t), pointer :: current
     integer :: pos
     integer :: i,j
     if (list%n_entries == 0) return
     allocate (set (list%n_entries))
     current => list%first
     pos = 0
     do while (associated (current))
        pos = pos + 1
        set(pos)%node => current%node
        current => current%next
     enddo
     do i=1, list%n_entries
        if (set(i)%node%keep) then
           do j=i+1, list%n_entries
              if (set(j)%node%keep) then
                 if (set(i)%node%bincode == set(j)%node%bincode) then
                    call subtree_select (set(i)%node%subtree,set(j)%node%subtree, model)
                    if (.not. set(i)%node%subtree%keep) then
                       set(i)%node%keep = .false.
                       exit
                    else if (.not. set(j)%node%subtree%keep) then
                       set(j)%node%keep = .false.
                    end if
                 end if
              end if
           enddo
        end if
     enddo
     deallocate (set)
   end subroutine k_node_list_check_subtree_equivalences
 
 @ %def k_node_list_check_subtree_equivalences
 @ This subroutine is used to obtain all [[k_nodes]] of a [[k_node_list]]
 which can be recycled and are not disabled for some reason. We pass an
 allocatable array of the type [[k_node_ptr_t]] which will be allocated
 if there are any such nodes in the list and the pointers will be
 associated with these nodes.
 <<Cascades2: k node list: TBP>>=
   procedure :: get_nodes => k_node_list_get_nodes
 <<Cascades2: procedures>>=
   subroutine k_node_list_get_nodes (list, nodes)
     class (k_node_list_t), intent (inout) :: list
     type (k_node_ptr_t), dimension(:), allocatable, intent (out) :: nodes
     integer :: n_nodes
     integer :: pos
     type (k_node_entry_t), pointer :: current, garbage
     n_nodes = 0
     current => list%first
     do while (associated (current))
        if (current%recycle .and. current%node%keep) n_nodes = n_nodes + 1
        current => current%next
     enddo
     if (n_nodes /= 0) then
        pos = 1
        allocate (nodes (n_nodes))
        do while (associated (list%first) .and. .not. list%first%node%keep)
           garbage => list%first
           list%first => list%first%next
           call garbage%final ()
           deallocate (garbage)
        enddo
        current => list%first
        do while (associated (current))
           do while (associated (current%next))
              if (.not. current%next%node%keep) then
                 garbage => current%next
                 current%next => current%next%next
                 call garbage%final
                 deallocate (garbage)
              else
                 exit
              end if
           enddo
           if (current%recycle .and. current%node%keep) then
              nodes(pos)%node => current%node
              pos = pos + 1
           end if
           current => current%next
        enddo
     end if
   end subroutine k_node_list_get_nodes
 
 @ %def k_node_list_get_nodes
 <<Cascades2: f node list: TBP>>=
   procedure :: final => f_node_list_final
 <<Cascades2: procedures>>=
   subroutine f_node_list_final (list)
     class (f_node_list_t) :: list
     type (f_node_entry_t), pointer :: current
     list%k_node_list => null ()
     do while (associated (list%first))
        current => list%first
        list%first => list%first%next
        call current%final ()
        deallocate (current)
     enddo
   end subroutine f_node_list_final
 
 @ %def f_node_list_final
 @
 \subsection{The grove list}
 First a type is introduced in order to speed up the comparison of kingraphs
 with the purpose to quickly find the graphs that might be equivalent.
 This is done solely on the basis of a number (which is given
 by the value of [[depth]] in [[compare_tree_t]]) of bincodes, which are
 the highest ones that do not belong to external particles.
 The highest such value determines the index of the element in the [[entry]]
 array of the [[compare_tree]]. The next lower such value determines
 the index of the element in the [[entry]] array of this [[entry]], and so
 on and so forth. This results in a tree structure where the number of
 levels is given by [[depth]] and should not be too large for reasons of
 memory.
 This is the entry type.
 <<Cascades2: types>>=
   type :: compare_tree_entry_t
      type (compare_tree_entry_t), dimension(:), pointer :: entry => null ()
      type (kingraph_ptr_t), dimension(:), allocatable :: graph_entry
    contains
      <<Cascades2: compare tree entry: TBP>>
   end type compare_tree_entry_t
 
 @ %def compare_tree_entry_t
 @ This is the tree type.
 <<Cascades2: types>>=
   type :: compare_tree_t
     integer :: depth = 3
     type (compare_tree_entry_t), dimension(:), pointer :: entry => null ()
   contains
     <<Cascades2: compare tree: TBP>>
   end type compare_tree_t
 
 @ %def compare_tree_t
 @ Finalizers for both types. The one for the entry type has to be recursive.
 <<Cascades2: compare tree: TBP>>=
   procedure :: final => compare_tree_final
 <<Cascades2: procedures>>=
   subroutine compare_tree_final (ctree)
     class (compare_tree_t), intent (inout) :: ctree
     integer :: i
     if (associated (ctree%entry)) then
        do i=1, size (ctree%entry)
           call ctree%entry(i)%final ()
           deallocate (ctree%entry)
        end do
     end if
   end subroutine compare_tree_final
 
 @ %def compare_tree_final
 <<Cascades2: compare tree entry: TBP>>=
   procedure :: final => compare_tree_entry_final
 <<Cascades2: procedures>>=
   recursive subroutine compare_tree_entry_final (ct_entry)
     class (compare_tree_entry_t), intent (inout) :: ct_entry
     integer :: i
     if (associated (ct_entry%entry)) then
        do i=1, size (ct_entry%entry)
           call ct_entry%entry(i)%final ()
        enddo
        deallocate (ct_entry%entry)
     else
        deallocate (ct_entry%graph_entry)
     end if
   end subroutine compare_tree_entry_final
 
 @ %def compare_tree_entry_final
 @ Check the presence of a graph which is considered as equivalent and
 select between the two. If there is no such graph, the current one
 is added to the list. First the entry has to be found:
 <<Cascades2: compare tree: TBP>>=
   procedure :: check_kingraph => compare_tree_check_kingraph
 <<Cascades2: procedures>>=
   subroutine compare_tree_check_kingraph (ctree, kingraph, model, preliminary)
     class (compare_tree_t), intent (inout) :: ctree
     type (kingraph_t), intent (inout), pointer :: kingraph
     type (model_data_t), intent (in) :: model
     logical, intent (in) :: preliminary
     integer :: i
     integer :: pos
     integer(TC) :: sz
     integer(TC), dimension(:), allocatable :: identifier
     if (.not. associated (ctree%entry)) then
        sz = 0_TC
        do i = size(kingraph%tree%bc), 1, -1
           sz = ior (sz, kingraph%tree%bc(i))
        enddo
        if (sz > 0) then
           allocate (ctree%entry (sz))
        else
           call msg_bug ("Compare tree could not be created")
        end if
     end if
     allocate (identifier (ctree%depth))
     pos = 0
     do i = size(kingraph%tree%bc), 1, -1
        if (popcnt (kingraph%tree%bc(i)) /= 1) then
           pos = pos + 1
           identifier(pos) = kingraph%tree%bc(i)
           if (pos == ctree%depth) exit
        end if
     enddo
     if (size (identifier) > 1) then
        call ctree%entry(identifier(1))%check_kingraph (kingraph, model, &
             preliminary, identifier(1), identifier(2:))
     else if (size (identifier) == 1) then
        call ctree%entry(identifier(1))%check_kingraph (kingraph, model, preliminary)
     end if
     deallocate (identifier)
   end subroutine compare_tree_check_kingraph
 
 @ %def compare_tree_check_kingraph
 @ Then the graphs of the entry are checked.
 <<Cascades2: compare tree entry: TBP>>=
   procedure :: check_kingraph => compare_tree_entry_check_kingraph
 <<Cascades2: procedures>>=
   recursive subroutine compare_tree_entry_check_kingraph (ct_entry, kingraph, &
        model, preliminary, subtree_size, identifier)
     class (compare_tree_entry_t), intent (inout) :: ct_entry
     type (kingraph_t), pointer, intent (inout) :: kingraph
     type (model_data_t), intent (in) :: model
     logical, intent (in) :: preliminary
     integer, intent (in), optional :: subtree_size
     integer, dimension (:), intent (in), optional :: identifier
     if (present (identifier)) then
        if (.not. associated (ct_entry%entry)) &
             allocate (ct_entry%entry(subtree_size))
        if (size (identifier) > 1) then
           call ct_entry%entry(identifier(1))%check_kingraph (kingraph, &
                model, preliminary, identifier(1), identifier(2:))
        else if (size (identifier) == 1) then
           call ct_entry%entry(identifier(1))%check_kingraph (kingraph, &
                model, preliminary)
        end if
     else
        if (allocated (ct_entry%graph_entry)) then
           call perform_check
        else
           allocate (ct_entry%graph_entry(1))
           ct_entry%graph_entry(1)%graph => kingraph
        end if
     end if
 
     contains
 
       subroutine perform_check
         integer :: i
         logical :: rebuild
         rebuild = .true.
         do i=1, size(ct_entry%graph_entry)
            if (ct_entry%graph_entry(i)%graph%keep) then
               if (preliminary .or. &
                    ct_entry%graph_entry(i)%graph%prc_component /= kingraph%prc_component) then
                  call kingraph_select (ct_entry%graph_entry(i)%graph, kingraph, model, preliminary)
                  if (.not. kingraph%keep) then
                     return
                  else if (rebuild .and. .not. ct_entry%graph_entry(i)%graph%keep) then
                     ct_entry%graph_entry(i)%graph => kingraph
                     rebuild = .false.
                  end if
               end if
            end if
         enddo
         if (rebuild) call rebuild_graph_entry
       end subroutine perform_check
 
       subroutine rebuild_graph_entry
         type (kingraph_ptr_t), dimension(:), allocatable :: tmp_ptr
         integer :: i
         integer :: pos
         allocate (tmp_ptr(size(ct_entry%graph_entry)+1))
         pos = 0
         do i=1, size(ct_entry%graph_entry)
            pos = pos + 1
            tmp_ptr(pos)%graph => ct_entry%graph_entry(i)%graph
         enddo
         pos = pos + 1
         tmp_ptr(pos)%graph => kingraph
         deallocate (ct_entry%graph_entry)
         allocate (ct_entry%graph_entry (pos))
         do i=1, pos
            ct_entry%graph_entry(i)%graph => tmp_ptr(i)%graph
         enddo
         deallocate (tmp_ptr)
       end subroutine rebuild_graph_entry
   end subroutine compare_tree_entry_check_kingraph
 
 @ %def compare_tree_entry_check_kingraph
 @ The grove to which a completed [[kingraph]] will be added is determined by the
 entries of [[grove_prop]]. We use another list type (linked list) to
 arrange the groves. Each [[grove]] contains again a linked list of
 [[kingraphs]].
 <<Cascades2: types>>=
   type :: grove_t
      type (grove_prop_t) :: grove_prop
      type (grove_t), pointer :: next => null ()
      type (kingraph_t), pointer :: first => null ()
      type (kingraph_t), pointer :: last => null ()
      type (compare_tree_t) :: compare_tree
    contains
    <<Cascades2: grove: TBP>>
   end type grove_t
 
 @ %def grove_t
 @ Container for a pointer of type [[grove_t]]:
 <<Cascades2: types>>=
   type :: grove_ptr_t
      type (grove_t), pointer :: grove => null ()
   end type grove_ptr_t
 
 @ %def grove_ptr_t
 <<Cascades2: grove: TBP>>=
   procedure :: final => grove_final
 <<Cascades2: procedures>>=
   subroutine grove_final (grove)
     class(grove_t), intent(inout) :: grove
     grove%first => null ()
     grove%last  => null ()
     grove%next => null ()
   end subroutine grove_final
 
 @ %def grove_final
 @ This is the list type:
 <<Cascades2: types>>=
   type :: grove_list_t
      type (grove_t), pointer :: first => null ()
    contains
    <<Cascades2: grove list: TBP>>
   end type grove_list_t
 
 @ %def grove_list_t
 <<Cascades2: grove list: TBP>>=
   procedure :: final => grove_list_final
 <<Cascades2: procedures>>=
   subroutine grove_list_final (list)
     class(grove_list_t), intent(inout) :: list
     class(grove_t), pointer :: current
     do while (associated (list%first))
        current => list%first
        list%first => list%first%next
        call current%final ()
        deallocate (current)
     end do
   end subroutine grove_list_final
 
 @ %def grove_list_final
 @
 \subsection{The feyngraph set}
 The fundament of the module is the public type [[feyngraph_set_t]]. It
 is not only a linked list of all [[feyngraphs]] but contains an array
 of all particle properties ([[particle]]), an [[f_node_list]] and a
 pointer of the type [[grove_list_t]], since several [[feyngraph_sets]]
 can share a common [[grove_list]]. In addition it keeps the data which
 unambiguously specifies the process, as well as the model which
 provides information which allows us to choose between equivalent
 subtrees or complete [[kingraphs]].
 <<Cascades2: public>>=
   public :: feyngraph_set_t
 <<Cascades2: types>>=
   type :: feyngraph_set_t
      type (model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(:,:), allocatable :: flv
      integer :: n_in = 0
      integer :: n_out = 0
      integer :: process_type = DECAY
      type (phs_parameters_t) :: phs_par
      logical :: fatal_beam_decay = .true.
      type (part_prop_t), dimension (:), pointer :: particle => null ()
      type (f_node_list_t) :: f_node_list
      type (feyngraph_t), pointer :: first => null ()
      type (feyngraph_t), pointer :: last => null ()
      integer :: n_graphs = 0
      type (grove_list_t), pointer :: grove_list => null ()
      logical :: use_dag = .true.
      type (dag_t), pointer :: dag => null ()
      type (feyngraph_set_t), dimension (:), pointer :: fset => null ()
    contains
    <<Cascades2: feyngraph set: TBP>>
   end type feyngraph_set_t
 
 @ %def feyngraph_set_t
 @ This final procedure contains calls to all other necessary final
 procedures.
 <<Cascades2: feyngraph set: TBP>>=
   procedure :: final => feyngraph_set_final
 <<Cascades2: procedures>>=
   recursive subroutine feyngraph_set_final (set)
     class(feyngraph_set_t), intent(inout) :: set
     class(feyngraph_t), pointer :: current
     integer :: i
     if (associated (set%fset)) then
        do i=1, size (set%fset)
           call set%fset(i)%final ()
        enddo
        deallocate (set%fset)
     else
        set%particle => null ()
        set%grove_list => null ()
     end if
     set%model => null ()
     if (allocated (set%flv)) deallocate (set%flv)
     set%last => null ()
     do while (associated (set%first))
        current => set%first
        set%first => set%first%next
        call current%final ()
        deallocate (current)
     end do
     if (associated (set%particle)) then
        do i = 1, size (set%particle)
           call set%particle(i)%final ()
        end do
        deallocate (set%particle)
     end if
     if (associated (set%grove_list)) then
        if (debug_on) call msg_debug (D_PHASESPACE, "grove_list: final")
        call set%grove_list%final ()
        deallocate (set%grove_list)
     end if
     if (debug_on) call msg_debug (D_PHASESPACE, "f_node_list: final")
     call set%f_node_list%final ()
     if (associated (set%dag)) then
        if (debug_on) call msg_debug (D_PHASESPACE, "dag: final")
        if (associated (set%dag)) then
           call set%dag%final ()
           deallocate (set%dag)
        end if
     end if
   end subroutine feyngraph_set_final
 
 @ %def feyngraph_set_final
 @
 \subsection{Construct the feyngraph set}
 We construct the [[feyngraph_set]] from an input file. Therefore we pass
 a unit to [[feyngraph_set_build]]. The parsing subroutines are chosen
 depending on the value of [[use_dag]]. In the DAG output, which is the one
 that is produced by default, we have to work on a string of one line,
 where the lenght of this string becomes larger the more particles are
 involved in the process. The other output (which is now only used in a
 unit test) contains one Feynman diagram per line and each line starts with an open
 parenthesis so that we read the file line per line and create a
 [[feyngraph]] for every line. Only after this, nodes are created. In both
 decay and scattering processes the diagrams are represented like in a decay
 process, i.e. in a scattering process one of the incoming particles appears
 as an outgoing particle.
 <<Cascades2: feyngraph set: TBP>>=
   procedure :: build => feyngraph_set_build
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_build (feyngraph_set, u_in)
     class (feyngraph_set_t), intent (inout) :: feyngraph_set
     integer, intent (in) :: u_in
     integer :: stat = 0
     character (len=FEYNGRAPH_LEN) :: omega_feyngraph_output
     type (feyngraph_t), pointer :: current_graph
     type (feyngraph_t), pointer :: compare_graph
     logical :: present
     if (feyngraph_set%use_dag) then
        allocate (feyngraph_set%dag)
        if (.not. associated (feyngraph_set%first)) then
           call feyngraph_set%dag%read_string (u_in, feyngraph_set%flv(:,1))
           call feyngraph_set%dag%construct (feyngraph_set)
           call feyngraph_set%dag%make_feyngraphs (feyngraph_set)
        end if
     else
        if (.not. associated (feyngraph_set%first)) then
           read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output
           if (omega_feyngraph_output(1:1) == '(') then
              allocate (feyngraph_set%first)
              feyngraph_set%first%omega_feyngraph_output = trim(omega_feyngraph_output)
              feyngraph_set%last => feyngraph_set%first
              feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
           else
              call msg_fatal ("Invalid input file")
           end if
           read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output
           do while (stat == 0)
              if (omega_feyngraph_output(1:1) == '(') then
                 compare_graph => feyngraph_set%first
                 present = .false.
                 do while (associated (compare_graph))
                    if (len_trim(compare_graph%omega_feyngraph_output) &
                         == len_trim(omega_feyngraph_output)) then
                       if (compare_graph%omega_feyngraph_output == omega_feyngraph_output) then
                          present = .true.
                          exit
                       end if
                    end if
                    compare_graph => compare_graph%next
                 enddo
                 if (.not. present) then
                    allocate (feyngraph_set%last%next)
                    feyngraph_set%last => feyngraph_set%last%next
                    feyngraph_set%last%omega_feyngraph_output = trim(omega_feyngraph_output)
                    feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
                 end if
                 read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') omega_feyngraph_output
              else
                 exit
              end if
           enddo
           current_graph => feyngraph_set%first
           do while (associated (current_graph))
              call feyngraph_construct (feyngraph_set, current_graph)
              current_graph => current_graph%next
           enddo
           feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes
        end if
     end if
   end subroutine feyngraph_set_build
 
 @ %def feyngraph_set_build
 @ Read the string from the file. The output which is produced by O'Mega
 contains the DAG in a factorised form as a long string, distributed over
 several lines (in addition, in the case of a scattering process, it
 contains a similar string for the same process, but with the other
 incoming particle as the root of the tree structure). In general, such a
 file can contain many of these strings, belonging to different process
 components. Therefore we first have to find the correct position of the
 string for the process in question. Therefore we look for a line
 containing a pair of colons, in which case the line contains a process
 string. Then we check if the process string describes the correct
 process, which is done by checking for all the incoming and outgoing
 particle names. If the process is correct, the dag output should start
 in the following line. As long as we do not find the correct process
 string, we continue searching. If we reach the end of the file, we
 rewind the unit once, and repeat searching. If the process is still not
 found, there must be some sort of error.
 <<Cascades2: dag: TBP>>=
   procedure :: read_string => dag_read_string
 <<Cascades2: procedures>>=
   subroutine dag_read_string (dag, u_in, flv)
     class (dag_t), intent (inout) :: dag
     integer, intent (in) :: u_in
     type(flavor_t), dimension(:), intent(in) :: flv
     character (len=BUFFER_LEN) :: process_string
     logical :: process_found
     logical :: rewound
 !!! find process string in file
     process_found = .false.
     rewound = .false.
     do while (.not. process_found)
        process_string = ""
        read (unit=u_in, fmt='(A)') process_string
        if (len_trim(process_string) /= 0) then
           if (index (process_string, "::") > 0) then
              process_found = process_string_match (trim (process_string), flv)
           end if
        else if (.not. rewound) then
           rewind (u_in)
           rewound = .true.
        else
           call msg_bug ("Process string not found in O'Mega input file.")
        end if
     enddo
     call fds_file_get_line (u_in, dag%string)
     call dag%string%clean ()
     if (.not. allocated (dag%string%t) .or. dag%string%char_len == 0) &
          call msg_bug ("Process string not found in O'Mega input file.")
   end subroutine dag_read_string
 
 @ %def dag_read_string
 @ The output of factorized Feynman diagrams which is created by O'Mega
 for a given process could in principle be written to a single line in
 the file. This can however lead to different problems with different
 compilers as soon as such lines become too long. This is the reason why
 the line is cut into smaller pieces. This means that a new line starts
 after each vertical bar. For this long string the type [[dag_string_t]]
 has been introduced. In order to read the file quickly into such a
 [[dag_string]] we use another type, [[dag_chain_t]] which is a linked
 list of such [[dag_strings]]. This has the advantage that we do not
 have to recreate a new [[dag_string]] for every line which has been
 read from file. Only in the end of this operation we compress the
 list of strings to a single string, removing useless [[dag_tokens]],
 such as blanc space tokens. This subroutine reads all lines starting
 from the position in the file the unit is connected to, until no
 backslash character is found at the end of a line (the backslash
 means that the next line also belongs to the current string).
 <<Cascades2: parameters>>=
   integer, parameter :: BUFFER_LEN = 1000
   integer, parameter :: STACK_SIZE = 100
 @ %def BUFFER_LEN STACK_SIZE
 <<Cascades2: procedures>>=
   subroutine fds_file_get_line (u, string)
     integer, intent (in) :: u
     type (dag_string_t), intent (out) :: string
     type (dag_chain_t) :: chain
     integer :: string_size, current_len
     character (len=BUFFER_LEN) :: buffer
     integer :: fragment_len
     integer :: stat
     current_len = 0
     stat = 0
     string_size = 0
     do while (stat == 0)
        read (unit=u, fmt='(A)', iostat=stat) buffer
        if (stat /= 0) exit
        fragment_len = len_trim (buffer)
        if (fragment_len == 0) then
           exit
        else if (buffer (fragment_len:fragment_len) == BACKSLASH_CHAR) then
           fragment_len = fragment_len - 1
        end if
        call chain%append (buffer(:fragment_len))
        if (buffer(fragment_len+1:fragment_len+1) /= BACKSLASH_CHAR) exit
     enddo
     if (associated (chain%first)) then
        call chain%compress ()
        string = chain%first
        call chain%final ()
     end if
   end subroutine fds_file_get_line
 
 @ %def fds_file_get_line
 @ We check, if the process string which has been read from file
 corresponds to the process for which we want to extract the Feynman
 diagrams.
 <<Cascades2: procedures>>=
   function process_string_match (string, flv) result (match)
     character (len=*), intent(in) :: string
     type(flavor_t), dimension(:), intent(in) :: flv
     logical :: match
     integer :: pos
     integer :: occurence
     integer :: i
     pos = 1
     match = .false.
     do i=1, size (flv)
        occurence = index (string(pos:), char(flv(i)%get_name()))
        if (occurence > 0) then
           pos = pos + occurence
           match = .true.
        else
           match = .false.
           exit
        end if
     enddo
   end function process_string_match
 
 @ %def process_string_match
 @
 \subsection{Particle properties}
 This subroutine initializes a model instance with the Standard Model
 data. It is only relevant for a unit test.
 We do not have to care about the model initialization in this module
 because the [[model]] is passed to [[feyngraph_set_generate]] when
 it is called.
 <<Cascades2: public>>=
   public :: init_sm_full_test
 <<Cascades2: procedures>>=
   subroutine init_sm_full_test (model)
     class(model_data_t), intent(out) :: model
     type(field_data_t), pointer :: field
     integer, parameter :: n_real = 17
     integer, parameter :: n_field = 21
     integer, parameter :: n_vtx = 56
     integer :: i
     call model%init (var_str ("SM_vertex_test"), &
          n_real, 0, n_field, n_vtx)
     call model%init_par (1, var_str ("mZ"), 91.1882_default)
     call model%init_par (2, var_str ("mW"), 80.419_default)
     call model%init_par (3, var_str ("mH"), 125._default)
     call model%init_par (4, var_str ("me"), 0.000510997_default)
     call model%init_par (5, var_str ("mmu"), 0.105658389_default)
     call model%init_par (6, var_str ("mtau"), 1.77705_default)
     call model%init_par (7, var_str ("ms"), 0.095_default)
     call model%init_par (8, var_str ("mc"), 1.2_default)
     call model%init_par (9, var_str ("mb"), 4.2_default)
     call model%init_par (10, var_str ("mtop"), 173.1_default)
     call model%init_par (11, var_str ("wtop"), 1.523_default)
     call model%init_par (12, var_str ("wZ"), 2.443_default)
     call model%init_par (13, var_str ("wW"), 2.049_default)
     call model%init_par (14, var_str ("wH"), 0.004143_default)
     call model%init_par (15, var_str ("ee"), 0.3079561542961_default)
     call model%init_par (16, var_str ("cw"), 8.819013863636E-01_default)
     call model%init_par (17, var_str ("sw"), 4.714339240339E-01_default)
     i = 0
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("D_QUARK"), 1)
     call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
     call field%set (name = [var_str ("d")], anti = [var_str ("dbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("U_QUARK"), 2)
     call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
     call field%set (name = [var_str ("u")], anti = [var_str ("ubar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("S_QUARK"), 3)
     call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
     call field%set (mass_data=model%get_par_real_ptr (7))
     call field%set (name = [var_str ("s")], anti = [var_str ("sbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("C_QUARK"), 4)
     call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (8))
     call field%set (name = [var_str ("c")], anti = [var_str ("cbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("B_QUARK"), 5)
     call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
     call field%set (mass_data=model%get_par_real_ptr (9))
     call field%set (name = [var_str ("b")], anti = [var_str ("bbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("T_QUARK"), 6)
     call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (10))
     call field%set (width_data=model%get_par_real_ptr (11))
     call field%set (name = [var_str ("t")], anti = [var_str ("tbar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("E_LEPTON"), 11)
     call field%set (spin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (4))
     call field%set (name = [var_str ("e-")], anti = [var_str ("e+")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("E_NEUTRINO"), 12)
     call field%set (spin_type=2, is_left_handed=.true.)
     call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("MU_LEPTON"), 13)
     call field%set (spin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (5))
     call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("MU_NEUTRINO"), 14)
     call field%set (spin_type=2, is_left_handed=.true.)
     call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("TAU_LEPTON"), 15)
     call field%set (spin_type=2)
     call field%set (mass_data=model%get_par_real_ptr (6))
     call field%set (name = [var_str ("tau-")], anti = [var_str ("tau+")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("TAU_NEUTRINO"), 16)
     call field%set (spin_type=2, is_left_handed=.true.)
     call field%set (name = [var_str ("nutau")], anti = [var_str ("nutaubar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("GLUON"), 21)
     call field%set (spin_type=3, color_type=8)
     call field%set (name = [var_str ("gl")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("PHOTON"), 22)
     call field%set (spin_type=3)
     call field%set (name = [var_str ("A")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("Z_BOSON"), 23)
     call field%set (spin_type=3)
     call field%set (mass_data=model%get_par_real_ptr (1))
     call field%set (width_data=model%get_par_real_ptr (12))
     call field%set (name = [var_str ("Z")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("W_BOSON"), 24)
     call field%set (spin_type=3)
     call field%set (mass_data=model%get_par_real_ptr (2))
     call field%set (width_data=model%get_par_real_ptr (13))
     call field%set (name = [var_str ("W+")], anti = [var_str ("W-")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("HIGGS"), 25)
     call field%set (spin_type=1)
     call field%set (mass_data=model%get_par_real_ptr (3))
     call field%set (width_data=model%get_par_real_ptr (14))
     call field%set (name = [var_str ("H")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("PROTON"), 2212)
     call field%set (spin_type=2)
     call field%set (name = [var_str ("p")], anti = [var_str ("pbar")])
 !    call field%set (mass_data=model%get_par_real_ptr (12))
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91)
     call field%set (color_type=1)
     call field%set (name = [var_str ("hr1")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92)
     call field%set (color_type=3)
     call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")])
     i = i + 1
     field => model%get_field_ptr_by_index (i)
     call field%init (var_str ("HADRON_REMNANT_OCTET"), 93)
     call field%set (color_type=8)
     call field%set (name = [var_str ("hr8")])
     call model%freeze_fields ()
     i = 0
     i = i + 1
 !!! QED
     call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("A")])
     i = i + 1
 !!!
     call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("mu+"), var_str ("mu-"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("A")])
     i = i + 1
 !!! QCD
     call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), &
          var_str ("gl"), var_str ("gl")])
     i = i + 1
 !!!
     call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("gl")])
     i = i + 1
     call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("gl")])
     i = i + 1
 !!! Neutral currents
     call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("Z")])
     i = i + 1
 !!!
     call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("mu+"), var_str ("muu-"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("nuebar"), var_str ("nue"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("numubar"), var_str ("numu"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("nutaubar"), var_str ("nutau"), &
          var_str ("Z")])
     i = i + 1
 !!! Charged currents
     call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")])
     i = i + 1
     call model%set_vertex (i, [var_str ("cbar"), var_str ("s"), var_str ("W+")])
     i = i + 1
     call model%set_vertex (i, [var_str ("tbar"), var_str ("b"), var_str ("W+")])
     i = i + 1
     call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")])
     i = i + 1
     call model%set_vertex (i, [var_str ("sbar"), var_str ("c"), var_str ("W-")])
     i = i + 1
     call model%set_vertex (i, [var_str ("bbar"), var_str ("t"), var_str ("W-")])
     i = i + 1
 !!!
     call model%set_vertex (i, [var_str ("nuebar"), var_str ("e-"), var_str ("W+")])
     i = i + 1
     call model%set_vertex (i, [var_str ("numubar"), var_str ("mu-"), var_str ("W+")])
     i = i + 1
     call model%set_vertex (i, [var_str ("nutaubar"), var_str ("tau-"), var_str ("W+")])
     i = i + 1
     call model%set_vertex (i, [var_str ("e+"), var_str ("nue"), var_str ("W-")])
     i = i + 1
     call model%set_vertex (i, [var_str ("mu+"), var_str ("numu"), var_str ("W-")])
     i = i + 1
     call model%set_vertex (i, [var_str ("tau+"), var_str ("nutau"), var_str ("W-")])
     i = i + 1
 !!! Yukawa
 !!! keeping only 3rd generation for the moment
     ! call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("H")])
     ! i = i + 1
     ! call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("H")])
     ! i = i + 1
     call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("H")])
     i = i + 1
     call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("H")])
     i = i + 1
     ! call model%set_vertex (i, [var_str ("mubar"), var_str ("mu"), var_str ("H")])
     ! i = i + 1
     call model%set_vertex (i, [var_str ("taubar"), var_str ("tau"), var_str ("H")])
     i = i + 1
 !!! Vector-boson self-interactions
     call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z")])
     i = i + 1
 !!!
     call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("W+"), var_str ("W+"), var_str ("W-"), var_str ("W-")])
     i = i + 1
     call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("A")])
     i = i + 1
     call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A"), var_str ("A")])
     i = i + 1
 !!! Higgs - vector boson
     ! call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("A")])
     ! i = i + 1
     ! call model%set_vertex (i, [var_str ("H"), var_str ("A"), var_str ("A")])
     ! i = i + 1
     ! call model%set_vertex (i, [var_str ("H"), var_str ("gl"), var_str ("gl")])
     ! i = i + 1
 !!!
     call model%set_vertex (i, [var_str ("H"), var_str ("W+"), var_str ("W-")])
     i = i + 1
     call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("Z")])
     i = i + 1
     call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("W+"), var_str ("W-")])
     i = i + 1
     call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("Z"), var_str ("Z")])
     i = i + 1
 !!! Higgs self-interactions
     call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H")])
     i = i + 1
     call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H"), var_str ("H")])
     i = i + 1
     call model%freeze_vertices ()
   end subroutine init_sm_full_test
 
 @ %def init_sm_full_test
 @ Initialize a [[part_prop]] object by passing a [[particle_label]],
 which is simply the particle name. [[part_prop]] should be part of the
 [[particle]] array of [[feyngraph_set]]. We use the [[model]] of
 [[feyngraph_set]] to obtain the relevant data of the particle which is
 needed to find [[phase_space]] parametrizations. When a [[part_prop]]
 is initialized, we add and initialize also the corresponding anti-
 particle [[part_prop]] if it is not yet in the array.
 <<Cascades2: part prop: TBP>>=
   procedure :: init => part_prop_init
 <<Cascades2: procedures>>=
   recursive subroutine part_prop_init (part_prop, feyngraph_set, particle_label)
     class (part_prop_t), intent (out), target :: part_prop
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     character (len=*), intent (in) :: particle_label
     type (flavor_t) :: flv, anti
     type (string_t) :: name
     integer :: i
     name = particle_label
     call flv%init (name, feyngraph_set%model)
     part_prop%particle_label = particle_label
     part_prop%pdg = flv%get_pdg ()
     part_prop%mass = flv%get_mass ()
     part_prop%width = flv%get_width()
     part_prop%spin_type = flv%get_spin_type ()
     part_prop%is_vector = flv%get_spin_type () == VECTOR
     part_prop%empty = .false.
     part_prop%tex_name = flv%get_tex_name ()
     anti = flv%anti ()
     if (flv%get_pdg() == anti%get_pdg()) then
        select type (part_prop)
        type is (part_prop_t)
           part_prop%anti => part_prop
        end select
     else
        do i=1, size (feyngraph_set%particle)
           if (feyngraph_set%particle(i)%pdg == (- part_prop%pdg)) then
              part_prop%anti => feyngraph_set%particle(i)
              exit
           else if (feyngraph_set%particle(i)%empty) then
              part_prop%anti => feyngraph_set%particle(i)
              call feyngraph_set%particle(i)%init (feyngraph_set, char(anti%get_name()))
              exit
           end if
        enddo
     end if
   end subroutine part_prop_init
 
 @ %def part_prop_init
 @ This subroutine assigns to a node the particle properties. Since these
 properties do not change and are simply read from the model file, we
 use pointers to the elements of the [[particle]] array of the
 [[feyngraph_set]]. If there is no corresponding array element, we
 have to initialize the first empty element of the array.
 <<Cascades2: parameters>>=
   integer, parameter :: PRT_ARRAY_SIZE = 200
 <<Cascades2: f node: TBP>>=
   procedure :: assign_particle_properties => f_node_assign_particle_properties
 <<Cascades2: procedures>>=
   subroutine f_node_assign_particle_properties (node, feyngraph_set)
     class (f_node_t), intent (inout ) :: node
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     character (len=LABEL_LEN) :: particle_label
     integer :: i
     particle_label = node%particle_label(1:index (node%particle_label, '[')-1)
     if (.not. associated (feyngraph_set%particle)) then
        allocate (feyngraph_set%particle (PRT_ARRAY_SIZE))
     end if
     do i = 1, size (feyngraph_set%particle)
        if (particle_label == feyngraph_set%particle(i)%particle_label) then
           node%particle => feyngraph_set%particle(i)
           exit
        else if (feyngraph_set%particle(i)%empty) then
           call feyngraph_set%particle(i)%init (feyngraph_set, particle_label)
           node%particle => feyngraph_set%particle(i)
           exit
        end if
     enddo
 !!! Since the O'Mega output uses the anti-particles instead of the particles specified
 !!! in the process definition, we revert this here. An exception is the first particle
 !!! in the parsable DAG output
     node%particle => node%particle%anti
   end subroutine f_node_assign_particle_properties
 
 @ %def f_node_assign_particle_properties
 @ From the output of a Feynman diagram (in the non-factorized output)
 we need to find out how many daughter nodes would be required to
 reconstruct it correctly, to make sure that we keep
 only those [[feyngraphs]] which are constructed solely on the basis of
 the 3-vertices which are provided by the model. The number of daughter
 particles can easily be determined from the syntax of O'Mega's output:
 The particle which appears before the colon ':' is the mother particle.
 The particles or subtrees (i.e. whole parentheses) follow after the
 colon and are separated by commas.
 <<Cascades2: procedures>>=
   function get_n_daughters (subtree_string, pos_first_colon) &
        result (n_daughters)
     character (len=*), intent (in) :: subtree_string
     integer, intent (in) :: pos_first_colon
     integer :: n_daughters
     integer :: n_open_par
     integer :: i
     n_open_par = 1
     n_daughters = 0
     if (len_trim(subtree_string) > 0) then
        if (pos_first_colon > 0) then
           do i=pos_first_colon, len_trim(subtree_string)
              if (subtree_string(i:i) == ',') then
                 if (n_open_par == 1) n_daughters = n_daughters + 1
              else if (subtree_string(i:i) == '(') then
                 n_open_par = n_open_par + 1
              else if (subtree_string(i:i) == ')') then
                 n_open_par = n_open_par - 1
              end if
           end do
           if (n_open_par == 0) then
              n_daughters = n_daughters + 1
           end if
        end if
     end if
   end function get_n_daughters
 
 @ %def get_n_daughters
 @
 \subsection{Reconstruction of trees}
 The reconstruction of a tree or subtree with the non-factorized input can
 be done recursively, i.e. we first find the root of the tree in the
 string and create an [[f_node]]. Then we look for daughters, which in the
 string appear either as single particles or subtrees (which are of the
 same form as the tree which we want to reconstruct. Therefore the
 subroutine can simply be called again and again until there are no more
 daughter nodes to create. When we meet a vertex which requires more than
 two daughter particles, we stop the recursion and disable the node using
 its [[keep]] variable. Whenever a daughter node is not kept, we do not
 keep the mother node as well.
 <<Cascades2: procedures>>=
   recursive subroutine node_construct_subtree_rec (feyngraph_set, &
        feyngraph, subtree_string, mother_node)
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (feyngraph_t), intent (inout) :: feyngraph
     character (len=*), intent (in) :: subtree_string
     type (f_node_t), pointer, intent (inout) :: mother_node
     integer :: n_daughters
     integer :: pos_first_colon
     integer :: current_daughter
     integer :: pos_subtree_begin, pos_subtree_end
     integer :: i
     integer :: n_open_par
     if (.not. associated (mother_node)) then
        call feyngraph_set%f_node_list%add_entry (subtree_string, mother_node, .true.)
        current_daughter = 1
        n_open_par = 1
        pos_first_colon = index (subtree_string, ':')
        n_daughters = get_n_daughters (subtree_string, pos_first_colon)
        if (pos_first_colon == 0) then
           mother_node%particle_label = subtree_string
        else
           mother_node%particle_label = subtree_string(2:pos_first_colon-1)
        end if
        if (.not. associated (mother_node%particle)) then
           call mother_node%assign_particle_properties (feyngraph_set)
        end if
        if (n_daughters /= 2 .and. n_daughters /= 0) then
           mother_node%keep = .false.
           feyngraph%keep = .false.
           return
        end if
        pos_subtree_begin = pos_first_colon + 1
        do i = pos_first_colon + 1, len(trim(subtree_string))
           if (current_daughter == 2) then
              pos_subtree_end = len(trim(subtree_string)) - 1
              call node_construct_subtree_rec (feyngraph_set, feyngraph, &
                   subtree_string(pos_subtree_begin:pos_subtree_end), &
                   mother_node%daughter2)
              exit
           else if (subtree_string(i:i) == ',') then
              if (n_open_par == 1) then
                 pos_subtree_end = i - 1
                 call node_construct_subtree_rec (feyngraph_set, feyngraph, &
                      subtree_string(pos_subtree_begin:pos_subtree_end), &
                      mother_node%daughter1)
                 current_daughter = 2
                 pos_subtree_begin = i + 1
              end if
           else if (subtree_string(i:i) == '(') then
              n_open_par = n_open_par + 1
           else if (subtree_string(i:i) == ')') then
              n_open_par = n_open_par - 1
           end if
        end do
     end if
     if (associated (mother_node%daughter1)) then
        if (.not. mother_node%daughter1%keep) then
           mother_node%keep = .false.
        end if
     end if
     if (associated (mother_node%daughter2)) then
        if (.not. mother_node%daughter2%keep) then
           mother_node%keep = .false.
        end if
     end if
     if (associated (mother_node%daughter1) .and. &
          associated (mother_node%daughter2)) then
        mother_node%n_subtree_nodes = &
             mother_node%daughter1%n_subtree_nodes &
             + mother_node%daughter2%n_subtree_nodes + 1
     end if
     if (.not. mother_node%keep) then
        feyngraph%keep = .false.
     end if
   end subroutine node_construct_subtree_rec
 
 @ %def node_construct_subtree_rec
 @ When the non-factorized version of the O'Mega output is used, the
 [[feyngraph]] is reconstructed from the contents of its [[string_t]]
 variable [[omega_feyngraph_output]]. This can be used for the recursive
 reconstruction of the tree of [[k_nodes]] with
 [[node_construct_subtree_rec]].
 <<Cascades2: procedures>>=
   subroutine feyngraph_construct (feyngraph_set, feyngraph)
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (feyngraph_t), pointer, intent (inout) :: feyngraph
     call node_construct_subtree_rec (feyngraph_set, feyngraph, &
          char(feyngraph%omega_feyngraph_output), feyngraph%root)
     feyngraph%n_nodes = feyngraph%root%n_subtree_nodes
   end subroutine feyngraph_construct
 
 @ %def feyngraph_construct
 @ We introduce another node type, which is called [[dag_node_t]] and
 is used to reproduce the dag structure which is represented by the input.
 The [[dag_nodes]] can have several combinations of daughters 1 and 2.
 The [[dag]] type contains an array of [[dag_nodes]] and is only used
 for the reconstruction of [[feyngraphs]] which are factorized as well, but
 in the other direction as the original output. This means in particular
 that the outgoing particles in the output file (which there can appear
 many times) exist only once as [[f_nodes]]. To represent combinations of
 daughters and alternatives (options), we further use the types
 [[dag_options_t]] and [[dag_combination_t]]. The [[dag_nodes]],
 [[dag_options]] and [[dag_combinations]] correspond to a substring of
 the string which has been read from file (and transformed into an object
 of type [[dag_string_t]], which is simply another compact representation
 of this string), or a modified version of this substring. The aim is to
 create only one object for a given substring, even if it appears several
 times in the original string and then create trees of [[f_nodes]], which
 build up the [[feyngraph]], such that as many [[f_nodes]] as possible can be reused.
 An outgoing particle (always interpreting the input as a decay) is
 called a [[leaf]] in the context of a [[dag]].
 <<Cascades2: types>>=
   type :: dag_node_t
      integer :: string_len
      type (dag_string_t) :: string
      logical :: leaf = .false.
      type (f_node_ptr_t), dimension (:), allocatable :: f_node
      integer :: subtree_size = 0
    contains
      <<Cascades2: dag node: TBP>>
   end type dag_node_t
 
 @ %def dag_node_t
 <<Cascades2: dag node: TBP>>=
   procedure :: final => dag_node_final
 <<Cascades2: procedures>>=
   subroutine dag_node_final (dag_node)
     class (dag_node_t), intent (inout) :: dag_node
     integer :: i
     call dag_node%string%final ()
     if (allocated (dag_node%f_node)) then
        do i=1, size (dag_node%f_node)
           if (associated (dag_node%f_node(i)%node)) then
              call dag_node%f_node(i)%node%final ()
              deallocate (dag_node%f_node(i)%node)
           end if
        enddo
        deallocate (dag_node%f_node)
     end if
   end subroutine dag_node_final
 
 @ %def dag_node_final
 @ Whenever there are more than one possible subtrees (represented by
 a [[dag_node]]) or combinations of subtrees to daughters (represented
 by [[dag_combination_t]]), we use the type [[dag_options_t]]. In the
 syntax of the factorized output, options are listed within curly
 braces, separated by horizontal bars.
 <<Cascades2: types>>=
   type :: dag_options_t
      integer :: string_len
      type (dag_string_t) :: string
      type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1
      type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2
    contains
      <<Cascades2: dag options: TBP>>
   end type dag_options_t
 
 @ %def dag_node_options_t
 <<Cascades2: dag options: TBP>>=
   procedure :: final => dag_options_final
 <<Cascades2: procedures>>=
   subroutine dag_options_final (dag_options)
     class (dag_options_t), intent (inout) :: dag_options
     integer :: i
     call dag_options%string%final ()
     if (allocated (dag_options%f_node_ptr1)) then
        do i=1, size (dag_options%f_node_ptr1)
           dag_options%f_node_ptr1(i)%node => null ()
        enddo
        deallocate (dag_options%f_node_ptr1)
     end if
         if (allocated (dag_options%f_node_ptr2)) then
        do i=1, size (dag_options%f_node_ptr2)
           dag_options%f_node_ptr2(i)%node => null ()
        enddo
        deallocate (dag_options%f_node_ptr2)
     end if
   end subroutine dag_options_final
 
 @ %def dag_options_final
 @ A pair of two daughters (which can be [[dag_nodes]] or [[dag_options]])
 is represented by the type [[dag_combination_t]]. In the original string,
 a [[dag_combination]] appears between parentheses, which contain a comma,
 but not a colon. If we find a colon between these parentheses, it is a
 a [[dag_node]] instead.
 <<Cascades2: types>>=
   type :: dag_combination_t
      integer :: string_len
      type (dag_string_t) :: string
      integer, dimension (2) :: combination
      type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1
      type (f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2
    contains
      <<Cascades2: dag combination: TBP>>
   end type dag_combination_t
 
 @ %def dag_combination_t
 <<Cascades2: dag combination: TBP>>=
   procedure :: final => dag_combination_final
 <<Cascades2: procedures>>=
   subroutine dag_combination_final (dag_combination)
     class (dag_combination_t), intent (inout) :: dag_combination
     integer :: i
     call dag_combination%string%final ()
     if (allocated (dag_combination%f_node_ptr1)) then
        do i=1, size (dag_combination%f_node_ptr1)
           dag_combination%f_node_ptr1(i)%node => null ()
        enddo
        deallocate (dag_combination%f_node_ptr1)
     end if
     if (allocated (dag_combination%f_node_ptr2)) then
        do i=1, size (dag_combination%f_node_ptr2)
           dag_combination%f_node_ptr2(i)%node => null ()
        enddo
        deallocate (dag_combination%f_node_ptr2)
     end if
   end subroutine dag_combination_final
 
 @ %def dag_combination_final
 @ Here is the type representing the DAG, i.e. it holds arrays of the
 [[dag_nodes]], [[dag_options]] and [[dag_combinations]]. The root node
 of the [[dag]] is the last filled element of the [[node]] array.
 <<Cascades2: types>>=
   type :: dag_t
      type (dag_string_t) :: string
      type (dag_node_t), dimension (:), allocatable :: node
      type (dag_options_t), dimension (:), allocatable :: options
      type (dag_combination_t), dimension (:), allocatable :: combination
      integer :: n_nodes = 0
      integer :: n_options = 0
      integer :: n_combinations = 0
    contains
      <<Cascades2: dag: TBP>>
   end type dag_t
 
 @ %def dag_t
 <<Cascades2: dag: TBP>>=
   procedure :: final => dag_final
 <<Cascades2: procedures>>=
   subroutine dag_final (dag)
     class (dag_t), intent (inout) :: dag
     integer :: i
     call dag%string%final ()
     if (allocated (dag%node)) then
        do i=1, size (dag%node)
           call dag%node(i)%final ()
        enddo
        deallocate (dag%node)
     end if
     if (allocated (dag%options)) then
        do i=1, size (dag%options)
           call dag%options(i)%final ()
        enddo
        deallocate (dag%options)
     end if
     if (allocated (dag%combination)) then
        do i=1, size (dag%combination)
           call dag%combination(i)%final ()
        enddo
        deallocate (dag%combination)
     end if
   end subroutine dag_final
 
 @ %def dag_final
 @ We construct the DAG from the given [[dag_string]] which is modified
 several times so that in the end the remaining string corresponds to a
 simple [[dag_node]], the root of the factorized tree. This means that
 we first identify the leaves, i.e. outgoing particles. Then we identify
 [[dag_nodes]], [[dag_combinations]] and [[options]] until the number of
 these objects does not change any more. Identifying means that we add
 a corresponding object to the array (if not yet present), which can be identified
 with the corresponding substring, and replace the substring in the
 original [[dag_string]] by a [[dag_token]] of the corresponding type
 (in the char output of this token, this corresponds to a place holder
 like e.g. '<O23>' which in this particular case corresponds to an option
 and can be found at the position 23 in the array). The character output
 of the substrings turns out to be very useful for debugging.
 <<Cascades2: dag: TBP>>=
   procedure :: construct => dag_construct
 <<Cascades2: procedures>>=
   subroutine dag_construct (dag, feyngraph_set)
     class (dag_t), intent (inout) :: dag
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     integer :: n_nodes
     integer :: n_options
     integer :: n_combinations
     logical :: continue_loop
     integer :: subtree_size
     integer :: i,j
     subtree_size = 1
     call dag%get_nodes_and_combinations (leaves = .true.)
     do i=1, dag%n_nodes
        call dag%node(i)%make_f_nodes (feyngraph_set, dag)
     enddo
     continue_loop = .true.
     subtree_size = subtree_size + 2
     do while (continue_loop)
        n_nodes = dag%n_nodes
        n_options = dag%n_options
        n_combinations = dag%n_combinations
        call dag%get_nodes_and_combinations (leaves = .false.)
        if (n_nodes /= dag%n_nodes) then
           dag%node(n_nodes+1:dag%n_nodes)%subtree_size = subtree_size
           do i = n_nodes+1, dag%n_nodes
              call dag%node(i)%make_f_nodes (feyngraph_set, dag)
           enddo
           subtree_size = subtree_size + 2
        end if
        if (n_combinations /= dag%n_combinations) then
           !$OMP PARALLEL DO
           do i = n_combinations+1, dag%n_combinations
              call dag%combination(i)%make_f_nodes (feyngraph_set, dag)
           enddo
           !$OMP END PARALLEL DO
        end if
        call dag%get_options ()
        if (n_options /= dag%n_options) then
           !$OMP PARALLEL DO
           do i = n_options+1, dag%n_options
              call dag%options(i)%make_f_nodes (feyngraph_set, dag)
           enddo
           !$OMP END PARALLEL DO
        end if
        if (n_nodes == dag%n_nodes .and. n_options == dag%n_options &
             .and. n_combinations == dag%n_combinations) then
           continue_loop = .false.
        end if
     enddo
 !!! add root node to dag
     call dag%add_node (dag%string%t, leaf = .false.)
     dag%node(dag%n_nodes)%subtree_size = subtree_size
     call dag%node(dag%n_nodes)%make_f_nodes (feyngraph_set, dag)
     if (debug2_active (D_PHASESPACE)) then
        call dag%write (output_unit)
     end if
 !!! set indices for all f_nodes
     do i=1, dag%n_nodes
        if (allocated (dag%node(i)%f_node)) then
           do j=1, size (dag%node(i)%f_node)
              if (associated (dag%node(i)%f_node(j)%node)) &
                   call dag%node(i)%f_node(j)%node%set_index ()
           enddo
        end if
     enddo
   end subroutine dag_construct
 
 @ %def dag_construct
 @ Identify [[dag_nodes]] and [[dag_combinations]]. Leaves are simply
 nodes (i.e. of type [[NODE_TK]]) where only one bit in the bincode is
 set. The [[dag_nodes]] and [[dag_combinations]] have in common that they
 are surrounded by parentheses. There is however a way to distinguish
 between them because the corresponding substring contains a colon (or
 [[dag_token]] with type [[COLON_TK]]) if it is a [[dag_node]]. Otherwise
 it is a [[dag_combination]]. The string of the [[dag_node]] or
 [[dag_combination]] should not contain curly braces, because these
 correspond to [[dag_options]] and should be identified before.
 <<Cascades2: dag: TBP>>=
   procedure :: get_nodes_and_combinations => dag_get_nodes_and_combinations
 <<Cascades2: procedures>>=
   subroutine dag_get_nodes_and_combinations (dag, leaves)
     class (dag_t), intent (inout) :: dag
     logical, intent (in) :: leaves
     type (dag_string_t) :: new_string
     integer :: i, j, k
     integer :: i_node
     integer :: new_size
     integer :: first_colon
     logical :: combination
 !!! Create nodes also for external particles, except for the incoming one which
 !!! appears as the root of the tree. These can easily be identified by their
 !!! bincodes, since they should contain only one bit which is set.
     if (leaves) then
        first_colon = minloc (dag%string%t%type, 1, dag%string%t%type == COLON_TK)
        do i = first_colon + 1, size (dag%string%t)
           if (dag%string%t(i)%type == NODE_TK) then
              if (popcnt(dag%string%t(i)%bincode) == 1) then
                 call dag%add_node (dag%string%t(i:i), .true., i_node)
                 call dag%string%t(i)%init_dag_object_token (DAG_NODE_TK, i_node)
              end if
           end if
        enddo
        call dag%string%update_char_len ()
     else
 !!! Create a node or combination for every closed pair of parentheses
 !!! which do not contain any other parentheses or curly braces.
 !!! A node (not outgoing) contains a colon. This is not the case
 !!! for combinations, which we use as the criteria to distinguish
 !!! between both.
        allocate (new_string%t (size (dag%string%t)))
        i = 1
        new_size = 0
        do while (i <= size(dag%string%t))
           if (dag%string%t(i)%type == OPEN_PAR_TK) then
              combination = .true.
              do j = i+1, size (dag%string%t)
                 select case (dag%string%t(j)%type)
                 case (CLOSED_PAR_TK)
                    new_size = new_size + 1
                    if (combination) then
                       call dag%add_combination (dag%string%t(i:j), i_node)
                       call new_string%t(new_size)%init_dag_object_token (DAG_COMBINATION_TK, i_node)
                    else
                       call dag%add_node (dag%string%t(i:j), leaves, i_node)
                       call new_string%t(new_size)%init_dag_object_token (DAG_NODE_TK, i_node)
                    end if
                    i = j + 1
                    exit
                 case (OPEN_PAR_TK, OPEN_CURLY_TK, CLOSED_CURLY_TK)
                    new_size = new_size + 1
                    new_string%t(new_size) = dag%string%t(i)
                    i = i + 1
                    exit
                 case (COLON_TK)
                    combination = .false.
                 end select
              enddo
           else
              new_size = new_size + 1
              new_string%t(new_size) = dag%string%t(i)
              i = i + 1
           end if
        enddo
        dag%string = new_string%t(:new_size)
        call dag%string%update_char_len ()
     end if
   end subroutine dag_get_nodes_and_combinations
 
 @ %def dag_get_nodes_and_combinations
 @ Identify [[dag_options]], i.e. lists of rival nodes or combinations
 of nodes. These are identified by the surrounding curly braces. They
 should not contain any parentheses any more, because these correspond
 either to nodes or to combinations and should be identified before.
 <<Cascades2: dag: TBP>>=
   procedure :: get_options => dag_get_options
 <<Cascades2: procedures>>=
   subroutine dag_get_options (dag)
     class (dag_t), intent (inout) :: dag
     type (dag_string_t) :: new_string
     integer :: i, j, k
     integer :: new_size
     integer :: i_options
     character (len=10) :: index_char
     integer :: index_start, index_end
 !!! Create a node or combination for every closed pair of parentheses
 !!! which do not contain any other parentheses or curly braces.
 !!! A node (not outgoing) contains a colon. This is not the case
 !!! for combinations, which we use as the criteria to distinguish
 !!! between both.
     allocate (new_string%t (size (dag%string%t)))
     i = 1
     new_size = 0
     do while (i <= size(dag%string%t))
        if (dag%string%t(i)%type == OPEN_CURLY_TK) then
           do j = i+1, size (dag%string%t)
              select case (dag%string%t(j)%type)
              case (CLOSED_CURLY_TK)
                 new_size = new_size + 1
                 call dag%add_options (dag%string%t(i:j), i_options)
                 call new_string%t(new_size)%init_dag_object_token (DAG_OPTIONS_TK, i_options)
                 i = j + 1
                 exit
              case (OPEN_PAR_TK, CLOSED_PAR_TK, OPEN_CURLY_TK)
                 new_size = new_size + 1
                 new_string%t(new_size) = dag%string%t(i)
                 i = i + 1
                 exit
              end select
           enddo
        else
           new_size = new_size + 1
           new_string%t(new_size) = dag%string%t(i)
           i = i + 1
        end if
     enddo
     dag%string = new_string%t(:new_size)
     call dag%string%update_char_len ()
   end subroutine dag_get_options
 
 @ %def dag_get_options
 @ Add a [[dag_node]] to the list. The optional argument returns the index
 of the node. The node might already exist. In this case we only return
 the index.
 <<Cascades2: dag: TBP>>=
   procedure :: add_node => dag_add_node
 <<Cascades2: parameters>>=
   integer, parameter :: DAG_STACK_SIZE = 1000
 <<Cascades2: procedures>>=
   subroutine dag_add_node (dag, string, leaf, i_node)
     class (dag_t), intent (inout) :: dag
     type (dag_token_t), dimension (:), intent (in) :: string
     logical, intent (in) :: leaf
     integer, intent (out), optional :: i_node
     type (dag_node_t), dimension (:), allocatable :: tmp_node
     integer :: string_len
     integer :: i
     string_len = sum (string%char_len)
     if (.not. allocated (dag%node)) then
         allocate (dag%node (DAG_STACK_SIZE))
      else if (dag%n_nodes == size (dag%node)) then
         allocate (tmp_node (dag%n_nodes))
         tmp_node = dag%node
         deallocate (dag%node)
         allocate (dag%node (dag%n_nodes+DAG_STACK_SIZE))
         dag%node(:dag%n_nodes) = tmp_node
         deallocate (tmp_node)
      end if
      do i = 1, dag%n_nodes
         if (dag%node(i)%string_len == string_len) then
            if (size (dag%node(i)%string%t) == size (string)) then
               if (all(dag%node(i)%string%t == string)) then
                  if (present (i_node)) i_node = i
                  return
               end if
            end if
         end if
      enddo
      dag%n_nodes = dag%n_nodes + 1
      dag%node(dag%n_nodes)%string = string
      dag%node(dag%n_nodes)%string_len = string_len
      if (present (i_node)) i_node = dag%n_nodes
      dag%node(dag%n_nodes)%leaf = leaf
   end subroutine dag_add_node
 
 @ %def dag_add_node
 @ A similar subroutine for options.
 <<Cascades2: dag: TBP>>=
   procedure :: add_options => dag_add_options
 <<Cascades2: procedures>>=
   subroutine dag_add_options (dag, string, i_options)
     class (dag_t), intent (inout) :: dag
     type (dag_token_t), dimension (:), intent (in) :: string
     integer, intent (out), optional :: i_options
     type (dag_options_t), dimension (:), allocatable :: tmp_options
     integer :: string_len
     integer :: i
     string_len = sum (string%char_len)
     if (.not. allocated (dag%options)) then
         allocate (dag%options (DAG_STACK_SIZE))
      else if (dag%n_options == size (dag%options)) then
         allocate (tmp_options (dag%n_options))
         tmp_options = dag%options
         deallocate (dag%options)
         allocate (dag%options (dag%n_options+DAG_STACK_SIZE))
         dag%options(:dag%n_options) = tmp_options
         deallocate (tmp_options)
      end if
      do i = 1, dag%n_options
         if (dag%options(i)%string_len == string_len) then
            if (size (dag%options(i)%string%t) == size (string)) then
               if (all(dag%options(i)%string%t == string)) then
                  if (present (i_options)) i_options = i
                  return
               end if
            end if
         end if
      enddo
      dag%n_options = dag%n_options + 1
      dag%options(dag%n_options)%string = string
      dag%options(dag%n_options)%string_len = string_len
      if (present (i_options)) i_options = dag%n_options
   end subroutine dag_add_options
 
 @ %def dag_add_options
 @ A similar subroutine for combinations.
 <<Cascades2: dag: TBP>>=
   procedure :: add_combination => dag_add_combination
 <<Cascades2: procedures>>=
   subroutine dag_add_combination (dag, string, i_combination)
     class (dag_t), intent (inout) :: dag
     type (dag_token_t), dimension (:), intent (in) :: string
     integer, intent (out), optional :: i_combination
     type (dag_combination_t), dimension (:), allocatable :: tmp_combination
     integer :: string_len
     integer :: i
     string_len = sum (string%char_len)
     if (.not. allocated (dag%combination)) then
         allocate (dag%combination (DAG_STACK_SIZE))
      else if (dag%n_combinations == size (dag%combination)) then
         allocate (tmp_combination (dag%n_combinations))
         tmp_combination = dag%combination
         deallocate (dag%combination)
         allocate (dag%combination (dag%n_combinations+DAG_STACK_SIZE))
         dag%combination(:dag%n_combinations) = tmp_combination
         deallocate (tmp_combination)
      end if
      do i = 1, dag%n_combinations
         if (dag%combination(i)%string_len == string_len) then
            if (size (dag%combination(i)%string%t) == size (string)) then
               if (all(dag%combination(i)%string%t == string)) then
                  i_combination = i
                  return
               end if
            end if
         end if
      enddo
      dag%n_combinations = dag%n_combinations + 1
      dag%combination(dag%n_combinations)%string = string
      dag%combination(dag%n_combinations)%string_len = string_len
      if (present (i_combination)) i_combination = dag%n_combinations
   end subroutine dag_add_combination
 
 @ %def dag_add_combination
 @ For a given [[dag_node]] we want to create all [[f_nodes]]. If the node
 is not a leaf, it contains in its string placeholders for options or
 combinations. For these objects there are similar subroutines which are
 needed here to obtain the sets of daughter nodes. If the [[dag_node]] is
 a leaf, it corresponds to an external particle and the token contains the
 particle name.
 <<Cascades2: dag node: TBP>>=
   procedure :: make_f_nodes => dag_node_make_f_nodes
 <<Cascades2: procedures>>=
   subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag)
     class (dag_node_t), intent (inout) :: dag_node
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (dag_t), intent (inout) :: dag
     character (len=LABEL_LEN) :: particle_label
     integer :: i, j
     integer, dimension (2) :: obj
     integer, dimension (2) :: i_obj
     integer :: n_obj
     integer :: pos
     integer :: new_size, size1, size2
     integer, dimension(:), allocatable :: match
     if (allocated (dag_node%f_node)) return
     pos = minloc (dag_node%string%t%type, 1,dag_node%string%t%type == NODE_TK)
     particle_label = char (dag_node%string%t(pos))
     if (dag_node%leaf) then
 !!! construct subtree with procedure similar to the one for the old output
        allocate (dag_node%f_node(1))
        allocate (dag_node%f_node(1)%node)
        dag_node%f_node(1)%node%particle_label = particle_label
        call dag_node%f_node(1)%node%assign_particle_properties (feyngraph_set)
        if (.not. dag_node%f_node(1)%node%keep) then
           deallocate (dag_node%f_node)
           return
        end if
     else
        n_obj = 0
        do i = 1, size (dag_node%string%t)
           select case (dag_node%string%t(i)%type)
           case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
              n_obj = n_obj + 1
              if (n_obj > 2) return
              obj(n_obj) = dag_node%string%t(i)%type
              i_obj(n_obj) = dag_node%string%t(i)%index
           end select
        enddo
        if (n_obj == 1) then
           if (obj(1) == DAG_OPTIONS_TK) then
              if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then
                 size1 = size(dag%options(i_obj(1))%f_node_ptr1)
                 allocate (dag_node%f_node(size1))
                 do i=1, size1
                    allocate (dag_node%f_node(i)%node)
                    dag_node%f_node(i)%node%particle_label = particle_label
                    call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set)
                    dag_node%f_node(i)%node%daughter1 => dag%options(i_obj(1))%f_node_ptr1(i)%node
                    dag_node%f_node(i)%node%daughter2 => dag%options(i_obj(1))%f_node_ptr2(i)%node
                    dag_node%f_node(i)%node%n_subtree_nodes = &
                         dag%options(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes &
                         + dag%options(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1
                 enddo
              end if
           else if (obj(1) == DAG_COMBINATION_TK) then
              if (allocated (dag%combination(i_obj(1))%f_node_ptr1)) then
                 size1 = size(dag%combination(i_obj(1))%f_node_ptr1)
                 allocate (dag_node%f_node(size1))
                 do i=1, size1
                    allocate (dag_node%f_node(i)%node)
                    dag_node%f_node(i)%node%particle_label = particle_label
                    call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set)
                    dag_node%f_node(i)%node%daughter1 => dag%combination(i_obj(1))%f_node_ptr1(i)%node
                    dag_node%f_node(i)%node%daughter2 => dag%combination(i_obj(1))%f_node_ptr2(i)%node
                    dag_node%f_node(i)%node%n_subtree_nodes = &
                         dag%combination(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes &
                      + dag%combination(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1
                 enddo
              end if
           end if
 !!! simply set daughter pointers, daughters are already combined correctly
        else if (n_obj == 2) then
           size1 = 0
           size2 = 0
           if (obj(1) == DAG_NODE_TK) then
              if (allocated (dag%node(i_obj(1))%f_node)) then
                 do i=1, size (dag%node(i_obj(1))%f_node)
                    if (dag%node(i_obj(1))%f_node(i)%node%keep) size1 = size1 + 1
                 enddo
              end if
           else if (obj(1) == DAG_OPTIONS_TK) then
              if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then
                 do i=1, size (dag%options(i_obj(1))%f_node_ptr1)
                    if (dag%options(i_obj(1))%f_node_ptr1(i)%node%keep) size1 = size1 + 1
                 enddo
              end if
           end if
           if (obj(2) == DAG_NODE_TK) then
              if (allocated (dag%node(i_obj(2))%f_node)) then
                 do i=1, size (dag%node(i_obj(2))%f_node)
                    if (dag%node(i_obj(2))%f_node(i)%node%keep) size2 = size2 + 1
                 enddo
              end if
           else if (obj(2) == DAG_OPTIONS_TK) then
              if (allocated (dag%options(i_obj(2))%f_node_ptr1)) then
                 do i=1, size (dag%options(i_obj(2))%f_node_ptr1)
                    if (dag%options(i_obj(2))%f_node_ptr1(i)%node%keep) size2 = size2 + 1
                 enddo
              end if
           end if
 !!! make all combinations of daughters
           select case (obj(1))
           case (DAG_NODE_TK)
              select case (obj(2))
              case (DAG_NODE_TK)
                 call combine_all_daughters(dag%node(i_obj(1))%f_node, &
                      dag%node(i_obj(2))%f_node)
              case (DAG_OPTIONS_TK)
                 call combine_all_daughters(dag%node(i_obj(1))%f_node, &
                      dag%options(i_obj(2))%f_node_ptr1)
              end select
           case (DAG_OPTIONS_TK)
              select case (obj(2))
              case (DAG_NODE_TK)
                 call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, &
                      dag%node(i_obj(2))%f_node)
              case (DAG_OPTIONS_TK)
                 call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, &
                      dag%options(i_obj(2))%f_node_ptr1)
              end select
           end select
        end if
     end if
 
   contains
 
     subroutine combine_all_daughters (daughter1_ptr, daughter2_ptr)
       type (f_node_ptr_t), dimension (:), intent (in) :: daughter1_ptr
       type (f_node_ptr_t), dimension (:), intent (in) :: daughter2_ptr
       integer :: i, j
       integer :: pos
       new_size = size1*size2
       allocate (dag_node%f_node(new_size))
       pos = 0
       do i = 1, size (daughter1_ptr)
          if (daughter1_ptr(i)%node%keep) then
             do j = 1, size (daughter2_ptr)
                if (daughter2_ptr(j)%node%keep) then
                   pos = pos + 1
                   allocate (dag_node%f_node(pos)%node)
                   dag_node%f_node(pos)%node%particle_label = particle_label
                   call dag_node%f_node(pos)%node%assign_particle_properties (feyngraph_set)
                   dag_node%f_node(pos)%node%daughter1 => daughter1_ptr(i)%node
                   dag_node%f_node(pos)%node%daughter2 => daughter2_ptr(j)%node
                   dag_node%f_node(pos)%node%n_subtree_nodes = daughter1_ptr(i)%node%n_subtree_nodes &
                        + daughter2_ptr(j)%node%n_subtree_nodes + 1
                   call feyngraph_set%model%match_vertex (daughter1_ptr(i)%node%particle%pdg, &
                        daughter2_ptr(j)%node%particle%pdg, match)
                   if (allocated (match)) then
                      if (any (abs(match) == abs(dag_node%f_node(pos)%node%particle%pdg))) then
                         dag_node%f_node(pos)%node%keep = .true.
                      else
                         dag_node%f_node(pos)%node%keep = .false.
                      end if
                      deallocate (match)
                   else
                      dag_node%f_node(pos)%node%keep = .false.
                   end if
                end if
             enddo
          end if
       enddo
     end subroutine combine_all_daughters
   end subroutine dag_node_make_f_nodes
 
 @ %def dag_node_make_f_nodes
 @ In [[dag_options_make_f_nodes_single]]
 we obtain all [[f_nodes]] for [[dag_nodes]] which correspond to a
 set of rival subtrees or nodes, which is the first possibility for
 which [[dag_options]] can appear.
 In [[dag_options_make_f_nodes_pair]]
 the options are rival pairs ([[daughter1]], [[daughter2]]).
 Therefore we have to pass two allocatable arrays of type [[f_node_ptr_t]]
 to the subroutine.
 <<Cascades2: dag options: TBP>>=
   procedure :: make_f_nodes => dag_options_make_f_nodes
 <<Cascades2: procedures>>=
   subroutine dag_options_make_f_nodes (dag_options, &
        feyngraph_set, dag)
     class (dag_options_t), intent (inout) :: dag_options
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (dag_t), intent (inout) :: dag
     integer, dimension (:), allocatable :: obj, i_obj
     integer :: n_obj
     integer :: i
     integer :: pos
 !!! read options
     if (allocated (dag_options%f_node_ptr1)) return
     n_obj = count ((dag_options%string%t%type == DAG_NODE_TK) .or. &
          (dag_options%string%t%type == DAG_OPTIONS_TK) .or. &
          (dag_options%string%t%type == DAG_COMBINATION_TK), 1)
     allocate (obj(n_obj)); allocate (i_obj(n_obj))
     pos = 0
     do i = 1, size (dag_options%string%t)
        select case (dag_options%string%t(i)%type)
        case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
           pos = pos + 1
           obj(pos) = dag_options%string%t(i)%type
           i_obj(pos) = dag_options%string%t(i)%index
        end select
     enddo
     if (any (dag_options%string%t%type == DAG_NODE_TK)) then
        call dag_options_make_f_nodes_single
     else if (any (dag_options%string%t%type == DAG_COMBINATION_TK)) then
        call dag_options_make_f_nodes_pair
     end if
     deallocate (obj, i_obj)
 
   contains
 
     subroutine dag_options_make_f_nodes_single
       integer :: i_start, i_end
       integer :: n_nodes
       n_nodes = 0
       do i=1, n_obj
          if (allocated (dag%node(i_obj(i))%f_node)) then
             n_nodes = n_nodes + size (dag%node(i_obj(i))%f_node)
          end if
       enddo
       if (n_nodes /= 0) then
          allocate (dag_options%f_node_ptr1 (n_nodes))
          i_end = 0
          do i = 1, n_obj
             if (allocated (dag%node(i_obj(i))%f_node)) then
                i_start = i_end + 1
                i_end = i_end + size (dag%node(i_obj(i))%f_node)
                dag_options%f_node_ptr1(i_start:i_end) = dag%node(i_obj(i))%f_node
             end if
          enddo
       end if
     end subroutine dag_options_make_f_nodes_single
 
     subroutine dag_options_make_f_nodes_pair
       integer :: i_start, i_end
       integer :: n_nodes
 !!! get f_nodes from each combination
       n_nodes = 0
       do i=1, n_obj
          if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then
             n_nodes = n_nodes + size (dag%combination(i_obj(i))%f_node_ptr1)
          end if
       enddo
       if (n_nodes /= 0) then
          allocate (dag_options%f_node_ptr1 (n_nodes))
          allocate (dag_options%f_node_ptr2 (n_nodes))
          i_end = 0
          do i=1, n_obj
             if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then
                i_start = i_end + 1
                i_end = i_end + size (dag%combination(i_obj(i))%f_node_ptr1)
                dag_options%f_node_ptr1(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr1
                dag_options%f_node_ptr2(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr2
             end if
          enddo
       end if
     end subroutine dag_options_make_f_nodes_pair
   end subroutine dag_options_make_f_nodes
 
 @ %def dag_options_make_f_nodes
 @ We create all combinations of daughter [[f_nodes]] for a combination.
 In the combination each daughter can be either a single [[dag_node]] or
 [[dag_options]] which are a set of single [[dag_nodes]]. Therefore, we
 first create all possible [[f_nodes]] for daughter1, then all possible
 [[f_nodes]] for daughter2. In the end we combine all [[daughter1]] nodes
 with all [[daughter2]] nodes.
 <<Cascades2: dag combination: TBP>>=
   procedure :: make_f_nodes => dag_combination_make_f_nodes
 <<Cascades2: procedures>>=
   subroutine dag_combination_make_f_nodes (dag_combination, &
        feyngraph_set, dag)
     class (dag_combination_t), intent (inout) :: dag_combination
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (dag_t), intent (inout) :: dag
     integer, dimension (2) :: obj, i_obj
     integer :: n_obj
     integer :: new_size, size1, size2
     integer :: i, j, pos
     if (allocated (dag_combination%f_node_ptr1)) return
     n_obj = 0
     do i = 1, size (dag_combination%string%t)
        select case (dag_combination%string%t(i)%type)
        case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
           n_obj = n_obj + 1
           if (n_obj > 2) return
           obj(n_obj) = dag_combination%string%t(i)%type
           i_obj(n_obj) = dag_combination%string%t(i)%index
        end select
     enddo
     size1 = 0
     size2 = 0
     if (obj(1) == DAG_NODE_TK) then
        if (allocated (dag%node(i_obj(1))%f_node)) &
             size1 = size (dag%node(i_obj(1))%f_node)
     else if (obj(1) == DAG_OPTIONS_TK) then
        if (allocated (dag%options(i_obj(1))%f_node_ptr1)) &
             size1 = size (dag%options(i_obj(1))%f_node_ptr1)
     end if
     if (obj(2) == DAG_NODE_TK) then
        if (allocated (dag%node(i_obj(2))%f_node)) &
             size2 = size (dag%node(i_obj(2))%f_node)
     else if (obj(2) == DAG_OPTIONS_TK) then
        if (allocated (dag%options(i_obj(2))%f_node_ptr1)) &
             size2 = size (dag%options(i_obj(2))%f_node_ptr1)
     end if
 !!! combine the 2 arrays of f_nodes
     new_size = size1*size2
     if (new_size /= 0) then
        allocate (dag_combination%f_node_ptr1 (new_size))
        allocate (dag_combination%f_node_ptr2 (new_size))
        pos = 0
        select case (obj(1))
        case (DAG_NODE_TK)
           select case (obj(2))
           case (DAG_NODE_TK)
              do i = 1, size1
                 do j = 1, size2
                    pos = pos + 1
                    dag_combination%f_node_ptr1(pos) = dag%node(i_obj(1))%f_node(i)
                    dag_combination%f_node_ptr2(pos) = dag%node(i_obj(2))%f_node(j)
                 enddo
              enddo
           case (DAG_OPTIONS_TK)
              do i = 1, size1
                 do j = 1, size2
                    pos = pos + 1
                    dag_combination%f_node_ptr1(pos) = dag%node(i_obj(1))%f_node(i)
                    dag_combination%f_node_ptr2(pos) = dag%options(i_obj(2))%f_node_ptr1(j)
                 enddo
              enddo
           end select
        case (DAG_OPTIONS_TK)
           select case (obj(2))
           case (DAG_NODE_TK)
              do i = 1, size1
                 do j = 1, size2
                    pos = pos + 1
                    dag_combination%f_node_ptr1(pos) = dag%options(i_obj(1))%f_node_ptr1(i)
                    dag_combination%f_node_ptr2(pos) = dag%node(i_obj(2))%f_node(j)
                 enddo
              enddo
           case (DAG_OPTIONS_TK)
              do i = 1, size1
                 do j = 1, size2
                    pos = pos + 1
                    dag_combination%f_node_ptr1(pos) = dag%options(i_obj(1))%f_node_ptr1(i)
                    dag_combination%f_node_ptr2(pos) = dag%options(i_obj(2))%f_node_ptr1(j)
                 enddo
              enddo
           end select
        end select
     end if
   end subroutine dag_combination_make_f_nodes
 
 @ %def dag_combination_make_f_nodes
 @ Here we create the [[feyngraphs]]. After the construction of the
 [[dag]] the remaining [[dag_string]] should contain a token for a
 single [[dag_node]] which corresponds to the roots of the
 [[feyngraphs]]. Therefore we make all [[f_nodes]] for this [[dag_node]]
 and create a [[feyngraph]] for each [[f_node]]. Note that only
 3-vertices are accepted. All other vertices are rejected. The
 starting point is the last dag node which has been added to the list,
 since this corresponds to the root of the tree.
 Is is important to understand that the structure of feyngraphs is not
 the same as the structure of the dag which is read from file, because
 for the calculations which are performed in this module we want to
 reuse the nodes for the outgoing particles, which means that they
 appear only once. In O'Mega's output, it is the first incoming particle
 which appears only once and the outgoing particles appear many times. This
 transition is incorporated in the subroutines which create [[f_nodes]]
 from the different dag objects.
 <<Cascades2: dag: TBP>>=
   procedure :: make_feyngraphs => dag_make_feyngraphs
 <<Cascades2: procedures>>=
   subroutine dag_make_feyngraphs (dag, feyngraph_set)
     class (dag_t), intent (inout) :: dag
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     integer :: i
     integer :: max_subtree_size
     max_subtree_size = dag%node(dag%n_nodes)%subtree_size
     if (allocated (dag%node(dag%n_nodes)%f_node)) then
        do i = 1, size (dag%node(dag%n_nodes)%f_node)
           if (.not. associated (feyngraph_set%first)) then
              allocate (feyngraph_set%last)
              feyngraph_set%first => feyngraph_set%last
           else
              allocate (feyngraph_set%last%next)
              feyngraph_set%last => feyngraph_set%last%next
           end if
           feyngraph_set%last%root => dag%node(dag%n_nodes)%f_node(i)%node
 !!! The first particle was correct in the O'Mega parsable DAG output. It was however
 !!! changed to its anti-particle in f_node_assign_particle_properties, which we revert here.
           feyngraph_set%last%root%particle => feyngraph_set%last%root%particle%anti
           feyngraph_set%last%n_nodes = feyngraph_set%last%root%n_subtree_nodes
           feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
        enddo
        feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes
     end if
   end subroutine dag_make_feyngraphs
 
 @ %def dag_make_feyngraphs
 @ A write procedure of the [[dag]] for debugging.
 <<Cascades2: dag: TBP>>=
   procedure :: write => dag_write
 <<Cascades2: procedures>>=
   subroutine dag_write (dag, u)
     class (dag_t), intent (in) :: dag
     integer, intent(in) :: u
     integer :: i
     write (u,fmt='(A)') 'nodes'
     do i=1, dag%n_nodes
        write (u,fmt='(I5,3X,A)') i, char (dag%node(i)%string)
     enddo
     write (u,fmt='(A)') 'options'
     do i=1, dag%n_options
        write (u,fmt='(I5,3X,A)') i, char (dag%options(i)%string)
     enddo
     write (u,fmt='(A)') 'combination'
     do i=1, dag%n_combinations
        write (u,fmt='(I5,3X,A)') i, char (dag%combination(i)%string)
     enddo
   end subroutine dag_write
 
 @ %def dag_write
 @ Make a copy of a resonant [[k_node]], where the copy is kept
 nonresonant.
 <<Cascades2: procedures>>=
   subroutine k_node_make_nonresonant_copy (k_node)
     type (k_node_t), intent (in) :: k_node
     type (k_node_t), pointer :: copy
     call k_node%f_node%k_node_list%add_entry (copy, recycle=.true.)
     copy%daughter1 => k_node%daughter1
     copy%daughter2 => k_node%daughter2
     copy = k_node
     copy%mapping = NONRESONANT
     copy%resonant = .false.
     copy%on_shell = .false.
     copy%mapping_assigned = .true.
     copy%is_nonresonant_copy = .true.
   end subroutine k_node_make_nonresonant_copy
 
 @ %def k_node_make_nonresonant_copy
 @ For a given [[feyngraph]] we create all possible [[kingraphs]]. Here
 we use existing [[k_nodes]] which have already been created when the
 mapping calculations of the pure s-channel subgraphs are performed. The
 nodes for the incoming particles or the nodes on the t-line will have
 to be created in all cases because they are not used in several graphs.
 To obtain the existing [[k_nodes]], we use the subroutine
 [[k_node_init_from_f_node]] which itself uses [[f_node_list_get_nodes]]
 to obtain all active [[k_nodes]] in the [[k_node_list]] of the [[f_node]].
 The created [[kingraphs]] are attached to the linked list
 of the [[feyngraph]]. For scattering processes we have to split up the
 t-line, because since all graphs are represented as a decay, different
 nodes can share daughter nodes. This happens also for the t-line or
 the incoming particle which appears as an outgoing particle. For the
 [[t_line]] or [[incoming]] nodes we do not want to recycle nodes but
 rather create a copy of this line for each [[kingraph]].
 <<Cascades2: feyngraph: TBP>>=
   procedure :: make_kingraphs => feyngraph_make_kingraphs
 <<Cascades2: procedures>>=
   subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set)
     class (feyngraph_t), intent (inout) :: feyngraph
     type (feyngraph_set_t), intent (in) :: feyngraph_set
     type (k_node_ptr_t), dimension (:), allocatable :: kingraph_root
     integer :: i
     if (.not. associated (feyngraph%kin_first)) then
        call k_node_init_from_f_node (feyngraph%root, &
             kingraph_root, feyngraph_set)
        if (.not. feyngraph%root%keep) return
        if (feyngraph_set%process_type == SCATTERING) then
           call split_up_t_lines (kingraph_root)
        end if
        do i=1, size (kingraph_root)
           if (associated (feyngraph%kin_last)) then
              allocate (feyngraph%kin_last%next)
              feyngraph%kin_last => feyngraph%kin_last%next
           else
              allocate (feyngraph%kin_last)
              feyngraph%kin_first => feyngraph%kin_last
           end if
           feyngraph%kin_last%root => kingraph_root(i)%node
           feyngraph%kin_last%n_nodes = feyngraph%n_nodes
           feyngraph%kin_last%keep = feyngraph%keep
           if (feyngraph_set%process_type == SCATTERING) then
              feyngraph%kin_last%root%bincode = &
                   f_node_get_external_bincode (feyngraph_set, feyngraph%root)
           end if
        enddo
        deallocate (kingraph_root)
     end if
   end subroutine feyngraph_make_kingraphs
 
 @ %def feyngraph_make_kingraphs
 @ Create all [[k_nodes]] for a given [[f_node]]. We return these nodes
 using [[k_node_ptr]]. If the node is external, we assign also the bincode
 to the [[k_nodes]] because this is determined from substrings of the
 input file which belong to the [[feyngraphs]] and [[f_nodes]].
 <<Cascades2: procedures>>=
   recursive subroutine k_node_init_from_f_node (f_node, k_node_ptr, feyngraph_set)
     type (f_node_t), target, intent (inout) :: f_node
     type (k_node_ptr_t), allocatable, dimension (:), intent (out) :: k_node_ptr
     type (feyngraph_set_t), intent (in) :: feyngraph_set
     type (k_node_ptr_t), allocatable, dimension(:) :: daughter_ptr1, daughter_ptr2
     integer :: n_nodes
     integer :: i, j
     integer :: pos
     integer, save :: counter = 0
     if (.not. (f_node%incoming .or. f_node%t_line)) then
        call f_node%k_node_list%get_nodes (k_node_ptr)
        if (.not. allocated (k_node_ptr) .and. f_node%k_node_list%n_entries > 0) then
           f_node%keep = .false.
           return
        end if
     end if
     if (.not. allocated (k_node_ptr)) then
        if (associated (f_node%daughter1) .and. associated (f_node%daughter2)) then
           call k_node_init_from_f_node (f_node%daughter1, daughter_ptr1, &
                feyngraph_set)
           call k_node_init_from_f_node (f_node%daughter2, daughter_ptr2, &
                feyngraph_set)
           if (.not. (f_node%daughter1%keep .and. f_node%daughter2%keep)) then
              f_node%keep = .false.
              return
           end if
           n_nodes = size (daughter_ptr1) * size (daughter_ptr2)
           allocate (k_node_ptr (n_nodes))
           pos = 1
           do i=1, size (daughter_ptr1)
              do j=1, size (daughter_ptr2)
                 if (f_node%incoming .or. f_node%t_line) then
                    call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .false.)
                 else
                    call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .true.)
                 end if
                 k_node_ptr(pos)%node%f_node => f_node
                 k_node_ptr(pos)%node%daughter1 => daughter_ptr1(i)%node
                 k_node_ptr(pos)%node%daughter2 => daughter_ptr2(j)%node
                 k_node_ptr(pos)%node%f_node_index = f_node%index
                 k_node_ptr(pos)%node%incoming = f_node%incoming
                 k_node_ptr(pos)%node%t_line = f_node%t_line
                 k_node_ptr(pos)%node%particle => f_node%particle
                 pos = pos + 1
              enddo
           enddo
           deallocate (daughter_ptr1, daughter_ptr2)
        else
           allocate (k_node_ptr(1))
           if (f_node%incoming .or. f_node%t_line) then
              call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.false.)
           else
              call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.true.)
           end if
           k_node_ptr(1)%node%f_node => f_node
           k_node_ptr(1)%node%f_node_index = f_node%index
           k_node_ptr(1)%node%incoming = f_node%incoming
           k_node_ptr(1)%node%t_line = f_node%t_line
           k_node_ptr(1)%node%particle => f_node%particle
           k_node_ptr(1)%node%bincode = f_node_get_external_bincode (feyngraph_set, &
                f_node)
        end if
     end if
   end subroutine k_node_init_from_f_node
 
 @ %def k_node_init_from_f_node
 @ The graphs resulting from [[k_node_init_from_f_node]] are fine if they
 are used only in one direction. This is however not the case when one
 wants to invert the graphs, i.e. take the other incoming particle of a
 scattering process as the decaying particle, because the outgoing
 [[f_nodes]] (and hence also the [[k_nodes]]) exist only once. This
 problem is solved here by creating a distinct t-line for each of the
 graphs. The following subroutine disentangles the data structure by
 creating new nodes such that the different t-lines are not connected
 any more.
 <<Cascades2: procedures>>=
   recursive subroutine split_up_t_lines (t_node)
     type (k_node_ptr_t), dimension(:), intent (inout) :: t_node
     type (k_node_t), pointer :: ref_node => null ()
     type (k_node_t), pointer :: ref_daughter => null ()
     type (k_node_t), pointer :: new_daughter => null ()
     type (k_node_ptr_t), dimension(:), allocatable :: t_daughter
     integer :: ref_daughter_index
     integer :: i, j
     allocate (t_daughter (size (t_node)))
     do i=1, size (t_node)
        ref_node => t_node(i)%node
        if (associated (ref_node%daughter1) .and. associated (ref_node%daughter2)) then
           ref_daughter => null ()
           if (ref_node%daughter1%incoming .or. ref_node%daughter1%t_line) then
              ref_daughter => ref_node%daughter1
              ref_daughter_index = 1
           else if (ref_node%daughter2%incoming .or. ref_node%daughter2%t_line) then
              ref_daughter => ref_node%daughter2
              ref_daughter_index = 2
           end if
           do j=1, size (t_daughter)
              if (.not. associated (t_daughter(j)%node)) then
                 t_daughter(j)%node => ref_daughter
                 exit
              else if (t_daughter(j)%node%index == ref_daughter%index) then
                 new_daughter => null ()
                 call ref_daughter%f_node%k_node_list%add_entry (new_daughter, recycle=.false.)
                 new_daughter = ref_daughter
                 new_daughter%daughter1 => ref_daughter%daughter1
                 new_daughter%daughter2 => ref_daughter%daughter2
                 if (ref_daughter_index == 1) then
                    ref_node%daughter1 => new_daughter
                 else if (ref_daughter_index == 2) then
                    ref_node%daughter2 => new_daughter
                 end if
                 ref_daughter => new_daughter
              end if
           enddo
        else
           return
        end if
     enddo
     call split_up_t_lines (t_daughter)
     deallocate (t_daughter)
   end subroutine split_up_t_lines
 
 @ %def split_up_t_lines
 @ This subroutine sets the [[inverse_daughters]] of a [[k_node]]. If we
 invert a [[kingraph]] such that not the first but the second incoming
 particle appears as the root of the tree, the [[incoming]] and [[t_line]]
 particles obtain other daughters. These are the former mother node and
 the sister node [[s_daughter]]. Here we set only the pointers for
 the [[inverse_daughters]]. The inversion happens in [[kingraph_make_inverse_copy]]
 and [[node_inverse_deep_copy]].
 <<Cascades2: procedures>>=
   subroutine kingraph_set_inverse_daughters (kingraph)
     type (kingraph_t), intent (inout) :: kingraph
     type (k_node_t), pointer :: mother
     type (k_node_t), pointer :: t_daughter
     type (k_node_t), pointer :: s_daughter
     mother => kingraph%root
     do while (associated (mother))
        if (associated (mother%daughter1) .and. &
             associated (mother%daughter2)) then
           if (mother%daughter1%t_line .or. mother%daughter1%incoming) then
              t_daughter => mother%daughter1; s_daughter => mother%daughter2
           else if (mother%daughter2%t_line .or. mother%daughter2%incoming) then
              t_daughter => mother%daughter2; s_daughter => mother%daughter1
           else
              exit
           end if
           t_daughter%inverse_daughter1 => mother
           t_daughter%inverse_daughter2 => s_daughter
           mother => t_daughter
        else
           exit
        end if
     enddo
   end subroutine kingraph_set_inverse_daughters
 
 @ %def kingraph_set_inverse_daughters
 @ Set the bincode of an [[f_node]] which corresponds to an external
 particle. This is done on the basis of the [[particle_label]] which is a
 substring of the input file. Here it is not the particle name which is
 important, but the number(s) in brackets which in general indicate the
 external particles which are connected to the current node. This function
 is however only used for external particles, so there can either be
 one or [[n_out + 1]] particles in the brackets (in the DAG input file
 always one, because also for the root there is only a single number).
 In all cases we check the number of particles (in the DAG input the
 numbers are separated by a slash).
 <<Cascades2: procedures>>=
   function f_node_get_external_bincode (feyngraph_set, f_node) result (bincode)
     type (feyngraph_set_t), intent (in) :: feyngraph_set
     type (f_node_t), intent (in) :: f_node
     integer (TC) :: bincode
     character (len=LABEL_LEN) :: particle_label
     integer :: start_pos, end_pos, n_out_decay
     integer :: n_prt ! for DAG
     integer :: i
     bincode = 0
     if (feyngraph_set%process_type == DECAY) then
        n_out_decay = feyngraph_set%n_out
     else
        n_out_decay = feyngraph_set%n_out + 1
     end if
     particle_label = f_node%particle_label
     start_pos = index (particle_label, '[') + 1
     end_pos = index (particle_label, ']') - 1
     particle_label = particle_label(start_pos:end_pos)
 !!! n_out_decay is the number of outgoing particles in the
 !!! O'Mega output, which is always represented as a decay
     if (feyngraph_set%use_dag) then
        n_prt = 1
        do i=1, len(particle_label)
           if (particle_label(i:i) == '/') n_prt = n_prt + 1
        enddo
     else
        n_prt = end_pos - start_pos + 1
     end if
     if (n_prt == 1) then
        bincode = calculate_external_bincode (particle_label, &
             feyngraph_set%process_type, n_out_decay)
     else if (n_prt == n_out_decay) then
        bincode = ibset (0, n_out_decay)
     end if
   end function f_node_get_external_bincode
 
 @ %def f_node_get_external_bincode
 @ Assign a bincode to an internal node, which is calculated from
 the bincodes of [[daughter1]] and [[daughter2]].
 <<Cascades2: procedures>>=
   subroutine node_assign_bincode (node)
     type (k_node_t), intent (inout) :: node
     if (associated (node%daughter1) .and. associated (node%daughter2) &
          .and. .not. node%incoming) then
        node%bincode = ior(node%daughter1%bincode, node%daughter2%bincode)
     end if
   end subroutine node_assign_bincode
 
 @ %def node_assign_bincode
 @ Calculate the [[bincode]] from the number in the brackets of the
 [[particle_label]], if the node is external. For the root in the
 non-factorized output, this is calculated directly in
 [[f_node_get_external_bincode]] because in this case all the other
 external particle numbers appear between the brackets.
 <<Cascades2: procedures>>=
   function calculate_external_bincode (label_number_string, process_type, n_out_decay) result (bincode)
     character (len=*), intent (in) :: label_number_string
     integer, intent (in) :: process_type
     integer, intent (in) :: n_out_decay
     character :: number_char
     integer :: number_int
     integer (kind=TC) :: bincode
     bincode = 0
     read (label_number_string, fmt='(A)') number_char
 !!! check if the character is a letter (A,B,C,...) or a number (1...9)
 !!! numbers 1 and 2 are special cases
     select case (number_char)
     case ('1')
        if (process_type == SCATTERING) then
           number_int = n_out_decay + 3
        else
           number_int = n_out_decay + 2
        end if
     case ('2')
        if (process_type == SCATTERING) then
           number_int = n_out_decay + 2
        else
           number_int = 2
        end if
     case ('A')
        number_int = 10
     case ('B')
        number_int = 11
     case ('C')
        number_int = 12
     case ('D')
        number_int = 13
     case default
        read (number_char, fmt='(I1)') number_int
     end select
     bincode = ibset (bincode, number_int - process_type - 1)
   end function calculate_external_bincode
 
 @ %def calculate_external_bincode
 @
 \subsection{Mapping calculations}
 Once a [[k_node]] and its subtree nodes have been created, we can
 perform the kinematical calculations and assign mappings, depending on
 the particle properties and the results for the subtree nodes. This
 could in principle be done recursively, calling the procedure first
 for the daughter nodes and then perform the calculations for the actual
 node. But for parallization and comparing the nodes, this will be done
 simultaneously for all nodes with the same number of subtree nodes, and the number of
 subtree nodes increases, starting from one, in steps of two. The
 actual mapping calculations are done in complete analogy to cascades.
 <<Cascades2: procedures>>=
   subroutine node_assign_mapping_s (feyngraph, node, feyngraph_set)
     type (feyngraph_t), intent (inout) :: feyngraph
     type (k_node_t), intent (inout) :: node
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     real(default) :: eff_mass_sum
     logical :: keep
     if (.not. node%mapping_assigned) then
        if (node%particle%mass > feyngraph_set%phs_par%m_threshold_s) then
           node%effective_mass = node%particle%mass
        end if
        if (associated (node%daughter1) .and. associated (node%daughter2)) then
           if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then
              node%keep = .false.; return
           end if
           node%ext_mass_sum = node%daughter1%ext_mass_sum &
                + node%daughter2%ext_mass_sum
           keep = .false.
 !!! Potentially resonant cases [sqrts = m_rea for on-shell decay]
           if (node%particle%mass > node%ext_mass_sum &
                .and. node%particle%mass <= feyngraph_set%phs_par%sqrts) then
              if (node%particle%width /= 0) then
                 if (node%daughter1%on_shell .or. node%daughter2%on_shell) then
                    keep = .true.
                    node%mapping = S_CHANNEL
                    node%resonant = .true.
                 end if
              else
                 call warn_decay (node%particle)
              end if
 !!! Collinear and IR singular cases
           else if (node%particle%mass < feyngraph_set%phs_par%sqrts) then
 !!! Massless splitting
              if (node%daughter1%effective_mass == 0 &
                   .and. node%daughter2%effective_mass == 0 &
                   .and. .not. associated (node%daughter1%daughter1) &
                   .and. .not. associated (node%daughter1%daughter2) &
                   .and. .not. associated (node%daughter2%daughter1) &
                   .and. .not. associated (node%daughter2%daughter2)) then
                 keep = .true.
                 node%log_enhanced = .true.
                 if (node%particle%is_vector) then
                    if (node%daughter1%particle%is_vector &
                         .and. node%daughter2%particle%is_vector) then
                       node%mapping = COLLINEAR   !!! three-vector-splitting
                    else
                       node%mapping = INFRARED    !!! vector spliiting into matter
                    end if
                 else
                    if (node%daughter1%particle%is_vector &
                         .or. node%daughter2%particle%is_vector) then
                       node%mapping = COLLINEAR   !!! vector radiation off matter
                    else
                       node%mapping = INFRARED    !!! scalar radiation/splitting
                    end if
                 end if
 !!! IR radiation off massive particle [cascades]
              else if (node%effective_mass > 0 .and. &
                   node%daughter1%effective_mass > 0 .and. &
                   node%daughter2%effective_mass == 0 .and. &
                   (node%daughter1%on_shell .or. &
                   node%daughter1%mapping == RADIATION) .and. &
                   abs (node%effective_mass - &
                   node%daughter1%effective_mass) < feyngraph_set%phs_par%m_threshold_s) &
                   then
                 keep = .true.
                 node%log_enhanced = .true.
                 node%mapping = RADIATION
              else if (node%effective_mass > 0 .and. &
                   node%daughter2%effective_mass > 0 .and. &
                   node%daughter1%effective_mass == 0 .and. &
                   (node%daughter2%on_shell .or. &
                   node%daughter2%mapping == RADIATION) .and. &
                   abs (node%effective_mass - &
                   node%daughter2%effective_mass) < feyngraph_set%phs_par%m_threshold_s) &
                   then
                 keep = .true.
                 node%log_enhanced = .true.
                 node%mapping = RADIATION
              end if
           end if
 !!! Non-singular cases, including failed resonances [from cascades]
           if (.not. keep) then
 !!! Two on-shell particles from a virtual mother [from cascades, here eventually more than 2]
              if (node%daughter1%on_shell .or. node%daughter2%on_shell) then
                 keep = .true.
                 eff_mass_sum = node%daughter1%effective_mass &
                      + node%daughter2%effective_mass
                 node%effective_mass = max (node%ext_mass_sum, eff_mass_sum)
                 if (node%effective_mass < feyngraph_set%phs_par%m_threshold_s) then
                    node%effective_mass = 0
                 end if
              end if
           end if
 !!! Complete and register feyngraph (make copy in case of resonance)
           if (keep) then
              node%on_shell = node%resonant .or. node%log_enhanced
              if (node%resonant) then
                 if (feyngraph_set%phs_par%keep_nonresonant) then
                    call k_node_make_nonresonant_copy (node)
                 end if
                 node%ext_mass_sum = node%particle%mass
              end if
           end if
           node%mapping_assigned = .true.
           call node_assign_bincode (node)
           call node%subtree%add_entry (node)
        else !!! external (outgoing) particle
           node%ext_mass_sum = node%particle%mass
           node%mapping = EXTERNAL_PRT
           node%multiplicity = 1
           node%mapping_assigned = .true.
           call node%subtree%add_entry (node)
           node%on_shell = .true.
           if (node%particle%mass >= feyngraph_set%phs_par%m_threshold_s) then
              node%effective_mass = node%particle%mass
           end if
        end if
     else if (node%is_nonresonant_copy) then
        call node_assign_bincode (node)
        call node%subtree%add_entry (node)
        node%is_nonresonant_copy = .false.
     end if
     call node_count_specific_properties (node)
     if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
        node%keep = .false.
     end if
   contains
     subroutine warn_decay (particle)
       type(part_prop_t), intent(in) :: particle
       integer :: i
       integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0
       LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE
          if (warned_code(i) == 0) then
             warned_code(i) = particle%pdg
             write (msg_buffer, "(A)") &
                  & " Intermediate decay of zero-width particle " &
                  & // trim(particle%particle_label) &
                  & // " may be possible."
             call msg_warning
             exit LOOP_WARNED
          else if (warned_code(i) == particle%pdg) then
             exit LOOP_WARNED
          end if
       end do LOOP_WARNED
     end subroutine warn_decay
   end subroutine node_assign_mapping_s
 
 @ %def node_assign_mapping_s
 @ We determine the numbers [[n_resonances]], [[multiplicity]],
 [[n_off_shell]] and [[n_log_enhanced]] for a given node.
 <<Cascades2: procedures>>=
   subroutine node_count_specific_properties (node)
     type (k_node_t), intent (inout) :: node
     if (associated (node%daughter1) .and. associated(node%daughter2)) then
        if (node%resonant) then
           node%multiplicity = 1
           node%n_resonances &
                = node%daughter1%n_resonances &
                + node%daughter2%n_resonances + 1
        else
           node%multiplicity &
                = node%daughter1%multiplicity &
                + node%daughter2%multiplicity
           node%n_resonances &
                = node%daughter1%n_resonances &
                + node%daughter2%n_resonances
        end if
        if (node%log_enhanced) then
           node%n_log_enhanced &
                = node%daughter1%n_log_enhanced &
                + node%daughter2%n_log_enhanced + 1
        else
           node%n_log_enhanced &
                = node%daughter1%n_log_enhanced &
                + node%daughter2%n_log_enhanced
        end if
        if (node%resonant) then
           node%n_off_shell = 0
        else if (node%log_enhanced) then
           node%n_off_shell &
                = node%daughter1%n_off_shell &
                + node%daughter2%n_off_shell
        else
           node%n_off_shell &
                = node%daughter1%n_off_shell &
                + node%daughter2%n_off_shell + 1
        end if
        if (node%t_line) then
           if (node%daughter1%t_line .or. node%daughter1%incoming) then
              node%n_t_channel = node%daughter1%n_t_channel + 1
           else if (node%daughter2%t_line .or. node%daughter2%incoming) then
              node%n_t_channel = node%daughter2%n_t_channel + 1
           end if
        end if
     end if
   end subroutine node_count_specific_properties
 
 @ %def node_count_specific_properties
 @ The subroutine [[kingraph_assign_mappings_s]] completes kinematical
 calculations for a decay process, considering the [[root]] node.
 <<Cascades2: procedures>>=
   subroutine kingraph_assign_mappings_s (feyngraph, kingraph, feyngraph_set)
     type (feyngraph_t), intent (inout) :: feyngraph
     type (kingraph_t), pointer, intent (inout) :: kingraph
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     if (.not. (kingraph%root%daughter1%keep .and. kingraph%root%daughter2%keep)) then
        kingraph%keep = .false.
        call kingraph%tree%final ()
     end if
     if (kingraph%keep) then
        kingraph%root%on_shell = .true.
        kingraph%root%mapping = EXTERNAL_PRT
        kingraph%root%mapping_assigned = .true.
        call node_assign_bincode (kingraph%root)
        kingraph%root%ext_mass_sum = &
             kingraph%root%daughter1%ext_mass_sum + &
             kingraph%root%daughter2%ext_mass_sum
        if (kingraph%root%ext_mass_sum >= feyngraph_set%phs_par%sqrts) then
           kingraph%root%keep = .false.
           kingraph%keep = .false.; call kingraph%tree%final (); return
        end if
        call kingraph%root%subtree%add_entry (kingraph%root)
        kingraph%root%multiplicity &
             = kingraph%root%daughter1%multiplicity &
             + kingraph%root%daughter2%multiplicity
        kingraph%root%n_resonances &
             = kingraph%root%daughter1%n_resonances &
             + kingraph%root%daughter2%n_resonances
        kingraph%root%n_off_shell &
             = kingraph%root%daughter1%n_off_shell &
             + kingraph%root%daughter2%n_off_shell
        kingraph%root%n_log_enhanced &
             = kingraph%root%daughter1%n_log_enhanced &
             + kingraph%root%daughter2%n_log_enhanced
        if (kingraph%root%n_off_shell > feyngraph_set%phs_par%off_shell) then
           kingraph%root%keep = .false.
           kingraph%keep = .false.; call kingraph%tree%final (); return
        else
           kingraph%grove_prop%multiplicity = &
                kingraph%root%multiplicity
           kingraph%grove_prop%n_resonances = &
                kingraph%root%n_resonances
           kingraph%grove_prop%n_off_shell = &
                kingraph%root%n_off_shell
           kingraph%grove_prop%n_log_enhanced = &
                kingraph%root%n_log_enhanced
        end if
        kingraph%tree = kingraph%root%subtree
     end if
   end subroutine kingraph_assign_mappings_s
 
 @ %def kingraph_assign_mappings_s
 @ Compute mappings for the [[t_line]] and [[incoming]] nodes. This is
 done recursively using [[node_compute_t_line]].
 <<Cascades2: procedures>>=
   subroutine kingraph_compute_mappings_t_line (feyngraph, kingraph, feyngraph_set)
     type (feyngraph_t), intent (inout) :: feyngraph
     type (kingraph_t), pointer, intent (inout) :: kingraph
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     call node_compute_t_line (feyngraph, kingraph, kingraph%root, feyngraph_set)
     if (.not. kingraph%root%keep) then
        kingraph%keep = .false.
        call kingraph%tree%final ()
     end if
     if (kingraph%keep) kingraph%tree = kingraph%root%subtree
   end subroutine kingraph_compute_mappings_t_line
 
 @ %def kingraph_compute_mappings_t_line
 @ Perform the kinematical calculations and mapping assignment for a node
 which is either [[incoming]] or [[t_line]]. This is done recursively,
 going first to the daughter node which has this property. Therefore we
 first set the pointer [[t_node]] to this daughter node and [[s_node]] to
 the other one. The mapping determination happens again in the same way as
 in [[cascades]].
 <<Cascades2: procedures>>=
   recursive subroutine node_compute_t_line (feyngraph, kingraph, node, feyngraph_set)
     type (feyngraph_t), intent (inout) :: feyngraph
     type (kingraph_t), intent (inout) :: kingraph
     type (k_node_t), intent (inout) :: node
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (k_node_t), pointer :: s_node
     type (k_node_t), pointer :: t_node
     type (k_node_t), pointer :: new_s_node
     if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then
        node%keep = .false.
        return
     end if
     s_node => null ()
     t_node => null ()
     new_s_node => null ()
     if (associated (node%daughter1) .and. associated (node%daughter2)) then
        if (node%daughter1%t_line .or. node%daughter1%incoming) then
           t_node => node%daughter1; s_node => node%daughter2
        else if (node%daughter2%t_line .or. node%daughter2%incoming) then
           t_node => node%daughter2; s_node => node%daughter1
        end if
        if (t_node%t_line) then
           call node_compute_t_line (feyngraph, kingraph, t_node, feyngraph_set)
           if (.not. t_node%keep) then
              node%keep = .false.
              return
           end if
        else if (t_node%incoming) then
           t_node%mapping = EXTERNAL_PRT
           t_node%on_shell = .true.
           t_node%ext_mass_sum = t_node%particle%mass
           if (t_node%particle%mass >= feyngraph_set%phs_par%m_threshold_t) then
              t_node%effective_mass = t_node%particle%mass
           end if
           call t_node%subtree%add_entry (t_node)
        end if
 !!! root:
        if (.not. node%incoming) then
           if (t_node%incoming) then
              node%ext_mass_sum = s_node%ext_mass_sum
           else
              node%ext_mass_sum &
                   = node%daughter1%ext_mass_sum &
                   + node%daughter2%ext_mass_sum
           end if
           if (node%particle%mass > feyngraph_set%phs_par%m_threshold_t) then
              node%effective_mass = max (node%particle%mass, &
                   s_node%effective_mass)
           else if (s_node%effective_mass > feyngraph_set%phs_par%m_threshold_t) then
              node%effective_mass = s_node%effective_mass
           else
              node%effective_mass = 0
           end if
 !!! Allowed decay of beam particle
           if (t_node%incoming &
                .and. t_node%particle%mass > s_node%particle%mass &
                + node%particle%mass) then
              call beam_decay (feyngraph_set%fatal_beam_decay)
 !!! Massless splitting
           else if (t_node%effective_mass == 0 &
                .and. s_node%effective_mass < feyngraph_set%phs_par%m_threshold_t &
                .and. node%effective_mass == 0) then
              node%mapping = U_CHANNEL
              node%log_enhanced = .true.
 !!! IR radiation off massive particle
           else if (t_node%effective_mass /= 0 &
                .and. s_node%effective_mass == 0 &
                .and. node%effective_mass /= 0 &
                .and. (t_node%on_shell &
                .or. t_node%mapping == RADIATION) &
                .and. abs (t_node%effective_mass - node%effective_mass) &
                < feyngraph_set%phs_par%m_threshold_t) then
              node%log_enhanced = .true.
              node%mapping = RADIATION
           end if
           node%mapping_assigned = .true.
           call node_assign_bincode (node)
           call node%subtree%add_entry (node)
           call node_count_specific_properties (node)
           if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
              node%keep = .false.
              kingraph%keep = .false.; call kingraph%tree%final (); return
           else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then
              node%keep = .false.;
              kingraph%keep = .false.; call kingraph%tree%final (); return
           end if
        else
           node%mapping = EXTERNAL_PRT
           node%on_shell = .true.
           node%ext_mass_sum &
                = t_node%ext_mass_sum &
                + s_node%ext_mass_sum
           node%effective_mass = node%particle%mass
           if (.not. (node%ext_mass_sum < feyngraph_set%phs_par%sqrts)) then
              node%keep = .false.
              kingraph%keep = .false.; call kingraph%tree%final (); return
           end if
           if (kingraph%keep) then
              if (t_node%incoming .and. s_node%log_enhanced) then
                 call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.)
                 new_s_node = s_node
                 new_s_node%daughter1 => s_node%daughter1
                 new_s_node%daughter2 => s_node%daughter2
                 if (s_node%index == node%daughter1%index) then
                    node%daughter1 => new_s_node
                 else if (s_node%index ==  node%daughter2%index) then
                    node%daughter2 => new_s_node
                 end if
                 new_s_node%subtree = s_node%subtree
                 new_s_node%mapping = NO_MAPPING
                 new_s_node%log_enhanced = .false.
                 new_s_node%n_log_enhanced &
                      = new_s_node%n_log_enhanced - 1
                 new_s_node%log_enhanced = .false.
                 where (new_s_node%subtree%bc == new_s_node%bincode)
                    new_s_node%subtree%mapping = NO_MAPPING
                 endwhere
              else if ((t_node%t_line .or. t_node%incoming) .and. &
                   t_node%mapping == U_CHANNEL) then
                 t_node%mapping = T_CHANNEL
                 where (t_node%subtree%bc == t_node%bincode)
                    t_node%subtree%mapping = T_CHANNEL
                 endwhere
              else if (t_node%incoming .and. &
                   .not. associated (s_node%daughter1) .and. &
                   .not. associated (s_node%daughter2)) then
                 call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.)
                 new_s_node = s_node
                 new_s_node%mapping = ON_SHELL
                 new_s_node%daughter1 => s_node%daughter1
                 new_s_node%daughter2 => s_node%daughter2
                 new_s_node%subtree = s_node%subtree
                 if (s_node%index == node%daughter1%index) then
                    node%daughter1 => new_s_node
                 else if (s_node%index == node%daughter2%index) then
                    node%daughter2 => new_s_node
                 end if
                 where (new_s_node%subtree%bc == new_s_node%bincode)
                    new_s_node%subtree%mapping = ON_SHELL
                 endwhere
              end if
           end if
           call node%subtree%add_entry (node)
           node%multiplicity &
                = node%daughter1%multiplicity &
                + node%daughter2%multiplicity
           node%n_resonances &
                = node%daughter1%n_resonances &
                + node%daughter2%n_resonances
           node%n_off_shell &
                = node%daughter1%n_off_shell &
                + node%daughter2%n_off_shell
           node%n_log_enhanced &
                = node%daughter1%n_log_enhanced &
                + node%daughter2%n_log_enhanced
           node%n_t_channel &
                = node%daughter1%n_t_channel &
                + node%daughter2%n_t_channel
           if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
              node%keep = .false.
              kingraph%keep = .false.; call kingraph%tree%final (); return
           else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then
              node%keep = .false.
              kingraph%keep = .false.; call kingraph%tree%final (); return
           else
              kingraph%grove_prop%multiplicity = node%multiplicity
              kingraph%grove_prop%n_resonances = node%n_resonances
              kingraph%grove_prop%n_off_shell = node%n_off_shell
              kingraph%grove_prop%n_log_enhanced = node%n_log_enhanced
              kingraph%grove_prop%n_t_channel = node%n_t_channel
           end if
        end if
     end if
   contains
     subroutine beam_decay (fatal_beam_decay)
       logical, intent(in) :: fatal_beam_decay
       write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") &
            t_node%particle%particle_label, &
            node%particle%particle_label, &
            s_node%particle%particle_label
       call msg_message
       write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
            t_node%particle%particle_label, t_node%particle%mass
       call msg_message
       write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
            node%particle%particle_label, node%particle%mass
       call msg_message
       write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
            s_node%particle%particle_label, s_node%particle%mass
       call msg_message
       if (fatal_beam_decay) then
          call msg_fatal (" Phase space: Initial beam particle can decay")
       else
          call msg_warning (" Phase space: Initial beam particle can decay")
       end if
     end subroutine beam_decay
   end subroutine node_compute_t_line
 
 @ %def node_compute_t_line
 @ After all pure s-channel subdiagrams have already been created from the
 corresponding [[f_nodes]] and mappings have been determined for their
 nodes, we complete the calculations here. In a first step, the
 [[kingraphs]] have to be created on the basis of the existing
 [[k_nodes]], which means in particular that a [[feyngraph]] can give
 rise to several [[kingraphs]] which will all be attached to the linked
 list of the [[feyngraph]]. The calculations which remain are of different
 kinds for decay and scattering processes. In a decay process the
 kinematical calculations have to be done for the [[root]] node. In a
 scattering process, after the creation of [[kingraphs]] in the first
 step, there will be only [[kingraphs]] with the first incoming particle
 as the [[root]] of the tree. For these graphs the [[inverse]] variable
 has the value [[.false.]]. Before performing any calculations on these
 graphs we make a so-called inverse copy of the graph (see below), which
 will also be attached to the linked list. Since the s-channel subgraph
 calculations have already been completed, only the t-line computations
 remain.
 <<Cascades2: feyngraph: TBP>>=
   procedure :: make_inverse_kingraphs => feyngraph_make_inverse_kingraphs
 <<Cascades2: procedures>>=
   subroutine feyngraph_make_inverse_kingraphs (feyngraph)
     class (feyngraph_t), intent (inout) :: feyngraph
     type (kingraph_t), pointer :: current
     current => feyngraph%kin_first
     do while (associated (current))
        if (current%inverse) exit
        call current%make_inverse_copy (feyngraph)
        current => current%next
     enddo
   end subroutine feyngraph_make_inverse_kingraphs
 
 @ %def feyngraph_make_inverse_kingraphs
 <<Cascades2: feyngraph: TBP>>=
   procedure :: compute_mappings => feyngraph_compute_mappings
 <<Cascades2: procedures>>=
   subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set)
     class (feyngraph_t), intent (inout) :: feyngraph
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (kingraph_t), pointer :: current
     current => feyngraph%kin_first
     do while (associated (current))
        if (feyngraph_set%process_type == DECAY) then
           call kingraph_assign_mappings_s (feyngraph, current, feyngraph_set)
        else if (feyngraph_set%process_type == SCATTERING) then
           call kingraph_compute_mappings_t_line (feyngraph, current, feyngraph_set)
        end if
        current => current%next
     enddo
   end subroutine feyngraph_compute_mappings
 
 @ %def feyngraph_compute_mappings
 @ Here we control the mapping calculations for the nodes of s-channel
 subgraphs. We start with the nodes with the smallest number of subtree
 nodes and always increase this number by two because nodes have exactly
 zero or two daughter nodes. We create the [[k_nodes]] using the
 [[k_node_list]] of each [[f_node]]. The number of nodes which have to
 be created depends of the number of existing daughter nodes, which means
 that we have to create a node for each combination of existing and
 valid (the ones which we [[keep]]) daughter nodes. If the node
 corresponds to an external particle, we create only one node, since
 there are no daughter nodes. If the particle is not external and
 the daughter [[f_nodes]] do not contain any valid [[k_nodes]], we do
 not create a new [[k_nodes]] either. When the calculations for all nodes
 with the same number of subtree nodes have been completed, we compare
 the valid nodes to eliminate equivalences (see below).
 <<Cascades2: procedures>>=
   subroutine f_node_list_compute_mappings_s (feyngraph_set)
     type (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (f_node_ptr_t), dimension(:), allocatable :: set
     type (k_node_ptr_t), dimension(:), allocatable :: k_set
     type (k_node_entry_t), pointer :: k_entry
     type (f_node_entry_t), pointer :: current
     type (k_node_list_t), allocatable :: compare_list
     integer :: n_entries
     integer :: pos
     integer :: i, j, k
     do i = 1, feyngraph_set%f_node_list%max_tree_size - 2, 2
 !!! Counter number of f_nodes with subtree size i for s channel calculations
        n_entries = 0
        if (feyngraph_set%use_dag) then
           do j=1, feyngraph_set%dag%n_nodes
              if (allocated (feyngraph_set%dag%node(j)%f_node)) then
                 do k=1, size(feyngraph_set%dag%node(j)%f_node)
                    if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then
                       if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming &
                            .or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) &
                            .and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then
                          n_entries = n_entries + 1
                       end if
                    end if
                 enddo
              end if
           enddo
        else
           current => feyngraph_set%f_node_list%first
           do while (associated (current))
              if (.not. (current%node%incoming .or. current%node%t_line) &
                   .and. current%node%n_subtree_nodes == i) then
                 n_entries = n_entries + 1
              end if
              current => current%next
           enddo
        end if
        if (n_entries == 0) exit
 !!! Create a temporary k node list for comparison
        allocate (set(n_entries))
        pos = 0
        if (feyngraph_set%use_dag) then
           do j=1, feyngraph_set%dag%n_nodes
              if (allocated (feyngraph_set%dag%node(j)%f_node)) then
                 do k=1, size(feyngraph_set%dag%node(j)%f_node)
                    if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then
                       if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming &
                            .or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) &
                            .and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then
                          pos = pos + 1
                          set(pos)%node => feyngraph_set%dag%node(j)%f_node(k)%node
                       end if
                    end if
                 enddo
              end if
           enddo
        else
           current => feyngraph_set%f_node_list%first
           do while (associated (current))
              if (.not. (current%node%incoming .or. current%node%t_line) &
                   .and. current%node%n_subtree_nodes == i) then
                 pos = pos + 1
                 set(pos)%node => current%node
              end if
              current => current%next
           enddo
        end if
        allocate (compare_list)
        compare_list%observer = .true.
        do j = 1, n_entries
           call k_node_init_from_f_node (set(j)%node, k_set, &
                feyngraph_set)
           if (allocated (k_set)) deallocate (k_set)
        enddo
        !$OMP PARALLEL DO PRIVATE (k_entry)
        do j = 1, n_entries
           k_entry => set(j)%node%k_node_list%first
           do while (associated (k_entry))
              call node_assign_mapping_s(feyngraph_set%first, k_entry%node, feyngraph_set)
              k_entry => k_entry%next
           enddo
        enddo
        !$OMP END PARALLEL DO
        do j = 1, size (set)
           k_entry => set(j)%node%k_node_list%first
           do while (associated (k_entry))
              if (k_entry%node%keep) then
                 if (k_entry%node%mapping == NO_MAPPING .or. k_entry%node%mapping == NONRESONANT) then
                    call compare_list%add_pointer (k_entry%node)
                 end if
              end if
              k_entry => k_entry%next
           enddo
        enddo
        deallocate (set)
        call compare_list%check_subtree_equivalences(feyngraph_set%model)
        call compare_list%final
        deallocate (compare_list)
     enddo
   end subroutine f_node_list_compute_mappings_s
 
 @ %def f_node_list_compute_mappings_s
 @
 \subsection{Fill the grove list}
 Find the [[grove]] within the [[grove_list]] for a [[kingraph]] for
 which the kinematical calculations and mapping assignments have been completed. The [[groves]]
 are defined by the [[grove_prop]] entries and the value of the resonance
 hash ([[res_hash]]). Whenever a matching grove does not exist, we
 create one. In a first step we consider only part of the grove properties
 (see [[grove_prop_match]]) and the resonance hash is ignored, which leads
 to a preliminary grove list. In the end all numbers in [[grove_prop]] as
 well as the resonance hash are compared, i.e. we create a new
 [[grove_list]].
 <<Cascades2: grove list: TBP>>=
   procedure :: get_grove => grove_list_get_grove
 <<Cascades2: procedures>>=
   subroutine grove_list_get_grove (grove_list, kingraph, return_grove, preliminary)
     class (grove_list_t), intent (inout) :: grove_list
     type (kingraph_t), intent (in), pointer :: kingraph
     type (grove_t), intent (inout), pointer :: return_grove
     logical, intent (in) :: preliminary
     type (grove_t), pointer :: current_grove
     return_grove => null ()
     if (.not. associated(grove_list%first)) then
        allocate (grove_list%first)
        grove_list%first%grove_prop = kingraph%grove_prop
        return_grove => grove_list%first
        return
     end if
     current_grove => grove_list%first
     do while (associated (current_grove))
        if ((preliminary .and. (current_grove%grove_prop .match. kingraph%grove_prop)) .or. &
             (.not. preliminary .and. current_grove%grove_prop == kingraph%grove_prop)) then
           return_grove => current_grove
           exit
        else if (.not. associated (current_grove%next)) then
           allocate (current_grove%next)
           current_grove%next%grove_prop = kingraph%grove_prop
           if (size (kingraph%tree%bc) < 9) &
                current_grove%compare_tree%depth = 1
           return_grove => current_grove%next
           exit
        end if
        if (associated (current_grove%next)) then
           current_grove => current_grove%next
        end if
     enddo
   end subroutine grove_list_get_grove
 
 @ %def grove_list_get_grove
 @ Add a valid [[kingraph]] to a [[grove_list]]. We first look for the
 [[grove]] which has the grove properties of the [[kingraph]]. If no such
 [[grove]] exists so far, it is created.
 <<Cascades2: grove list: TBP>>=
   procedure :: add_kingraph => grove_list_add_kingraph
 <<Cascades2: procedures>>=
   subroutine grove_list_add_kingraph (grove_list, kingraph, preliminary, check, model)
     class (grove_list_t), intent (inout) :: grove_list
     type (kingraph_t), pointer, intent (inout) :: kingraph
     logical, intent (in) :: preliminary
     logical, intent (in) :: check
     type (model_data_t), optional, intent (in) :: model
     type (grove_t), pointer :: grove
     type (kingraph_t), pointer :: current
     integer, save :: index = 0
     grove => null ()
     current => null ()
     if (preliminary) then
        if (kingraph%index == 0) then
           index = index + 1
           kingraph%index = index
        end if
     end if
     call grove_list%get_grove (kingraph, grove, preliminary)
     if (check) then
        call grove%compare_tree%check_kingraph (kingraph, model, preliminary)
     end if
     if (kingraph%keep) then
        if (associated (grove%first)) then
           grove%last%grove_next => kingraph
           grove%last => kingraph
        else
           grove%first => kingraph
           grove%last => kingraph
        end if
     end if
   end subroutine grove_list_add_kingraph
 
 @ %ref grove_list_add_kingraph
 @ For a given [[feyngraph]] we store all valid [[kingraphs]] in the
 [[grove_list]].
 <<Cascades2: grove list: TBP>>=
   procedure :: add_feyngraph => grove_list_add_feyngraph
 <<Cascades2: procedures>>=
   subroutine grove_list_add_feyngraph (grove_list, feyngraph, model)
     class (grove_list_t), intent (inout) :: grove_list
     type (feyngraph_t), intent (inout) :: feyngraph
     type (model_data_t), intent (in) :: model
     type (kingraph_t), pointer :: current_kingraph, add_kingraph
     do while (associated (feyngraph%kin_first))
        if (feyngraph%kin_first%keep) then
           add_kingraph => feyngraph%kin_first
           feyngraph%kin_first => feyngraph%kin_first%next
           add_kingraph%next => null ()
           call grove_list%add_kingraph (kingraph=add_kingraph, &
                preliminary=.true., check=.true., model=model)
        else
           exit
        end if
     enddo
     if (associated (feyngraph%kin_first)) then
        current_kingraph => feyngraph%kin_first
        do while (associated (current_kingraph%next))
           if (current_kingraph%next%keep) then
              add_kingraph => current_kingraph%next
              current_kingraph%next => current_kingraph%next%next
              add_kingraph%next => null ()
              call grove_list%add_kingraph (kingraph=add_kingraph, &
                   preliminary=.true., check=.true., model=model)
           else
              current_kingraph => current_kingraph%next
           end if
        enddo
     end if
   end subroutine grove_list_add_feyngraph
 
 @ %def grove_list_add_feyngraph
 @ Compare two [[grove_prop]] objects. The [[.match.]] operator is used
 for preliminary groves in which the [[kingraphs]] share only the 3
 numbers [[n_resonances]], [[n_log_enhanced]] and [[n_t_channel]]. These
 groves are only used for comparing the kingraphs, because only graphs
 within these preliminary groves can be equivalent (the numbers which are
 compared here are unambigously fixed by the combination of mappings in
 these channels).
 <<Cascades2: interfaces>>=
   interface operator (.match.)
      module procedure grove_prop_match
   end interface operator (.match.)
 <<Cascades2: procedures>>=
   function grove_prop_match (grove_prop1, grove_prop2) result (gp_match)
     type (grove_prop_t), intent (in) :: grove_prop1
     type (grove_prop_t), intent (in) :: grove_prop2
     logical :: gp_match
     gp_match = (grove_prop1%n_resonances == grove_prop2%n_resonances) &
          .and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) &
          .and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel)
   end function grove_prop_match
 
 @ %def grove_prop_match
 @ The equal operator on the other hand will be used when all valid
 [[kingraphs]] have been created and mappings have been determined, to
 split up the existing (preliminary) grove list, i.e. to create new
 groves which are determined by all entries in [[grove_prop_t]].
 <<Cascades2: interfaces>>=
   interface operator (==)
      module procedure grove_prop_equal
   end interface operator (==)
 <<Cascades2: procedures>>=
   function grove_prop_equal (grove_prop1, grove_prop2) result (gp_equal)
     type (grove_prop_t), intent (in) :: grove_prop1
     type (grove_prop_t), intent (in) :: grove_prop2
     logical :: gp_equal
     gp_equal = (grove_prop1%res_hash == grove_prop2%res_hash) &
          .and. (grove_prop1%n_resonances == grove_prop2%n_resonances) &
          .and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) &
          .and. (grove_prop1%n_off_shell == grove_prop2%n_off_shell) &
          .and. (grove_prop1%multiplicity == grove_prop2%multiplicity) &
          .and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel)
   end function grove_prop_equal
 
 @ %def grove_prop_equal
 @
 \subsection{Remove equivalent channels}
 Here we define the equivalence condition for completed [[kingraphs]].
 The aim is to keep those [[kingraphs]] which describe the strongest
 peaks of the amplitude. The [[bincodes]] and [[mappings]] have to be
 the same for an equivalence, but the [[pdgs]] can be different. At
 the same time we check if the trees are exacly the same (up to the
 sign of pdg codes) in which case we do not keep both of them. This
 can be the case when the incoming particles are the same or their
 mutual anti-particles and there are no t-channel lines in the
 Feynman diagram to which the kingraph belongs.
 <<Cascades2: parameters>>=
   integer, parameter :: EMPTY = -999
 <<Cascades2: procedures>>=
   function kingraph_eqv (kingraph1, kingraph2) result (eqv)
     type (kingraph_t), intent (in) :: kingraph1
     type (kingraph_t), intent (inout) :: kingraph2
     logical :: eqv
     integer :: i
     logical :: equal
     eqv = .false.
     do i = kingraph1%tree%n_entries, 1, -1
        if (kingraph1%tree%bc(i) /= kingraph2%tree%bc(i)) return
     enddo
     do i = kingraph1%tree%n_entries, 1, -1
        if ( .not. (kingraph1%tree%mapping(i) == kingraph2%tree%mapping(i) &
             .or. ((kingraph1%tree%mapping(i) == NO_MAPPING .or. &
             kingraph1%tree%mapping(i) == NONRESONANT) .and. &
             (kingraph2%tree%mapping(i) == NO_MAPPING .or. &
             kingraph2%tree%mapping(i) == NONRESONANT)))) return
     enddo
     equal = .true.
     do i = kingraph1%tree%n_entries, 1, -1
        if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then
           equal = .false.;
           select case (kingraph1%tree%mapping(i))
           case (S_CHANNEL, RADIATION)
              select case (kingraph2%tree%mapping(i))
              case (S_CHANNEL, RADIATION)
                 return
              end select
           end select
        end if
     enddo
     if (equal) then
        kingraph2%keep = .false.
        call kingraph2%tree%final ()
     else
        eqv = .true.
     end if
   end function kingraph_eqv
 
 @ %def kingraph_eqv
 @ Select between two [[kingraphs]] which fulfill the equivalence
 condition above. This is done by comparing the [[pdg]] values of the
 [[tree]] for increasing bincode. If the particles are different at
 some place, we usually choose the one which would be returned first by the
 subroutine [[match_vertex]] of the model for the daughter [[pdg]] codes.
 Since we work here only on the basis of the the [[trees]] of the
 completed [[kingraphs]], we have to use the [[bc]] array to determine
 the positions of the daughter nodes' entries in the array. The graph
 which has to be kept should correspond to the stronger peak at the place
 which is compared.
 <<Cascades2: procedures>>=
   subroutine kingraph_select (kingraph1, kingraph2, model, preliminary)
     type (kingraph_t), intent (inout) :: kingraph1
     type (kingraph_t), intent (inout) :: kingraph2
     type (model_data_t), intent (in) :: model
     logical, intent (in) :: preliminary
     integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc
     integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg
     integer, dimension (:), allocatable :: pdg_match
     integer :: i, j
     integer :: n_ext1, n_ext2
     if (kingraph_eqv (kingraph1, kingraph2)) then
        if (.not. preliminary) then
           kingraph2%keep = .false.; call kingraph2%tree%final ()
           return
        end if
        do i=1, size (kingraph1%tree%bc)
           if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then
              if (kingraph1%tree%mapping(i) /= EXTERNAL_PRT) then
                 n_ext1 = popcnt (kingraph1%tree%bc(i))
                 n_ext2 = n_ext1
                 do j=i+1, size (kingraph1%tree%bc)
                    if (abs(kingraph1%tree%pdg(j)) /= abs(kingraph2%tree%pdg(j))) then
                       n_ext2 = popcnt (kingraph1%tree%bc(j))
                       if (n_ext2 < n_ext1) exit
                    end if
                 enddo
                 if (n_ext2 < n_ext1) cycle
                 allocate (tmp_bc(i-1))
                 tmp_bc = kingraph1%tree%bc(:i-1)
                 allocate (tmp_pdg(i-1))
                 tmp_pdg = kingraph1%tree%pdg(:i-1)
                 do j=i-1, 1, - 1
                    where (iand (tmp_bc(:j-1),tmp_bc(j)) /= 0 &
                         .or. iand(tmp_bc(:j-1),kingraph1%tree%bc(i)) == 0)
                       tmp_bc(:j-1) = 0
                       tmp_pdg(:j-1) = 0
                    endwhere
                 enddo
                 allocate (daughter_bc(size(pack(tmp_bc, tmp_bc /= 0))))
                 daughter_bc = pack (tmp_bc, tmp_bc /= 0)
                 allocate (daughter_pdg(size(pack(tmp_pdg, tmp_pdg /= 0))))
                 daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0)
                 if (size (daughter_pdg) == 2) then
                    call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match)
                 end if
                 do j=1, size (pdg_match)
                    if (abs(pdg_match(j)) == abs(kingraph1%tree%pdg(i))) then
                       kingraph2%keep = .false.; call kingraph2%tree%final ()
                       exit
                    else if (abs(pdg_match(j)) == abs(kingraph2%tree%pdg(i))) then
                       kingraph1%keep = .false.; call kingraph1%tree%final ()
                       exit
                    end if
                 enddo
                 deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match)
                 if (.not. (kingraph1%keep .and. kingraph2%keep)) exit
              end if
           end if
        enddo
     end if
   end subroutine kingraph_select
 
 @ %def kingraph_select
 @ At the beginning we do not care about the resonance hash, but only
 about part of the grove properties, which is defined in
 [[grove_prop_match]]. In these resulting preliminary groves the kingraphs
 can be equivalent, i.e. we do not have to compare all graphs with each
 other but only all graphs within each of these preliminary groves. In the
 end we create a new grove list where the grove properties of the
 [[kingraphs]] within a [[grove]] have to be exactly the same and in
 addition the groves are distinguished by the resonance hash values. Here
 the kingraphs are not compared any more, which means that the number of
 channels is not reduced any more.
 <<Cascades2: grove list: TBP>>=
   procedure :: merge => grove_list_merge
 <<Cascades2: procedures>>=
   subroutine grove_list_merge (target_list, grove_list, model, prc_component)
     class (grove_list_t), intent (inout) :: target_list
     type (grove_list_t), intent (inout) :: grove_list
     type (model_data_t), intent (in) :: model
     integer, intent (in) :: prc_component
     type (grove_t), pointer :: current_grove
     type (kingraph_t), pointer :: current_graph
     current_grove => grove_list%first
     do while (associated (current_grove))
        do while (associated (current_grove%first))
           current_graph => current_grove%first
           current_grove%first => current_grove%first%grove_next
           current_graph%grove_next => null ()
           if (current_graph%keep) then
              current_graph%prc_component = prc_component
              call target_list%add_kingraph(kingraph=current_graph, &
                   preliminary=.false., check=.true., model=model)
           else
              call current_graph%final ()
              deallocate (current_graph)
           end if
        enddo
        current_grove => current_grove%next
     enddo
   end subroutine grove_list_merge
 
 @ %def grove_list_merge
 @ Recreate a grove list where we have different groves for different
 resonance hashes.
 <<Cascades2: grove list: TBP>>=
   procedure :: rebuild => grove_list_rebuild
 <<Cascades2: procedures>>=
   subroutine grove_list_rebuild (grove_list)
     class (grove_list_t), intent (inout) :: grove_list
     type (grove_list_t) :: tmp_list
     type (grove_t), pointer :: current_grove
     type (grove_t), pointer :: remove_grove
     type (kingraph_t), pointer :: current_graph
     type (kingraph_t), pointer :: next_graph
     tmp_list%first => grove_list%first
     grove_list%first => null ()
     current_grove => tmp_list%first
     do while (associated (current_grove))
        current_graph => current_grove%first
        do while (associated (current_graph))
           call current_graph%assign_resonance_hash ()
           next_graph => current_graph%grove_next
           current_graph%grove_next => null ()
           if (current_graph%keep) then
              call grove_list%add_kingraph (kingraph=current_graph, &
                   preliminary=.false., check=.false.)
           end if
           current_graph => next_graph
        enddo
        current_grove => current_grove%next
     enddo
     call tmp_list%final
   end subroutine grove_list_rebuild
 
 @ %def grove_list_rebuild
 @
 \subsection{Write the phase-space file}
 The phase-space file is written from the graphs which survive the
 calculations and equivalence checks and are in the grove list. It is
 written grove by grove. The output should be the same as in the
 corresponding procedure [[cascade_set_write_file_format]] of
 [[cascades]], up to the order of groves and channels.
 <<Cascades2: public>>=
   public :: feyngraph_set_write_file_format
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_write_file_format (feyngraph_set, u)
     type (feyngraph_set_t), intent (in) :: feyngraph_set
     integer, intent (in) :: u
     type (grove_t), pointer :: grove
     integer :: channel_number
     integer :: grove_number
     channel_number = 0
     grove_number = 0
     grove => feyngraph_set%grove_list%first
     do while (associated (grove))
        grove_number = grove_number + 1
        call grove%write_file_format (feyngraph_set, grove_number, channel_number, u)
        grove => grove%next
     enddo
   end subroutine feyngraph_set_write_file_format
 
 @ %def feyngraph_set_write_file_format
 @ Write the relevant information of the [[kingraphs]] of a [[grove]] and
 the grove properties in the file format.
 <<Cascades2: grove: TBP>>=
   procedure :: write_file_format => grove_write_file_format
 <<Cascades2: procedures>>=
     recursive subroutine grove_write_file_format (grove, feyngraph_set, gr_number, ch_number, u)
       class (grove_t), intent (in) :: grove
       type (feyngraph_set_t), intent (in) :: feyngraph_set
       integer, intent (in) :: u
       integer, intent (inout) :: gr_number
       integer, intent (inout) :: ch_number
       type (kingraph_t), pointer :: current
 1     format(3x,A,1x,40(1x,I4))
       write (u, "(A)")
       write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') &
            'Multiplicity =', grove%grove_prop%multiplicity, ","
       select case (grove%grove_prop%n_resonances)
       case (0)
          write (u, '(1x,A)', advance='no') 'no resonances, '
       case (1)
          write (u, '(1x,A)', advance='no') '1 resonance,  '
       case default
          write (u, '(1x,I0,1x,A)', advance='no') &
               grove%grove_prop%n_resonances, 'resonances, '
       end select
       write (u, '(1x,I0,1x,A)', advance='no') &
            grove%grove_prop%n_log_enhanced, 'logs, '
       write (u, '(1x,I0,1x,A)', advance='no') &
            grove%grove_prop%n_off_shell, 'off-shell, '
       select case (grove%grove_prop%n_t_channel)
       case (0);  write (u, '(1x,A)') 's-channel graph'
       case (1);  write (u, '(1x,A)') '1 t-channel line'
       case default
          write(u,'(1x,I0,1x,A)') &
               grove%grove_prop%n_t_channel, 't-channel lines'
       end select
       write (u, '(1x,A,I0)') 'grove #', gr_number
       current => grove%first
       do while (associated (current))
          if (current%keep) then
             ch_number = ch_number + 1
             call current%write_file_format (feyngraph_set, ch_number, u)
          end if
          current => current%grove_next
       enddo
     end subroutine grove_write_file_format
 
 @ %def grove_write_file_format
 @ Write the relevant information of a valid [[kingraph]] in the file
 format. The information is extracted from the [[tree]].
 <<Cascades2: kingraph: TBP>>=
   procedure :: write_file_format => kingraph_write_file_format
 <<Cascades2: procedures>>=
   subroutine kingraph_write_file_format (kingraph, feyngraph_set, ch_number, u)
     class (kingraph_t), intent (in) :: kingraph
     type (feyngraph_set_t), intent (in) :: feyngraph_set
     integer, intent (in) :: ch_number
     integer, intent (in) :: u
     integer :: i
     integer(TC) :: bincode_incoming
 2   format(3X,'map',1X,I3,1X,A,1X,I9,1X,'!',1X,A)
 !!! determine bincode of incoming particle from tree
     bincode_incoming = maxval (kingraph%tree%bc)
     write (unit=u, fmt='(1X,A,I0)') '! Channel #', ch_number
     write (unit=u, fmt='(3X,A,1X)', advance='no') 'tree'
     do i=1, size (kingraph%tree%bc)
        if (kingraph%tree%mapping(i) >=0 .or. kingraph%tree%mapping(i) == NONRESONANT &
             .or. (kingraph%tree%bc(i) == bincode_incoming &
             .and. feyngraph_set%process_type == DECAY)) then
           write (unit=u, fmt='(1X,I0)', advance='no') kingraph%tree%bc(i)
        end if
     enddo
     write (unit=u, fmt='(A)', advance='yes')
     do i=1, size(kingraph%tree%bc)
        select case (kingraph%tree%mapping(i))
        case (NO_MAPPING, NONRESONANT, EXTERNAL_PRT)
        case (S_CHANNEL)
           write (unit=u, fmt=2) kingraph%tree%bc(i), 's_channel', &
                kingraph%tree%pdg(i), &
                trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
        case (T_CHANNEL)
           write (unit=u, fmt=2) kingraph%tree%bc(i), 't_channel', &
                abs (kingraph%tree%pdg(i)), &
                trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i))))
        case (U_CHANNEL)
           write (unit=u, fmt=2) kingraph%tree%bc(i), 'u_channel', &
                abs (kingraph%tree%pdg(i)), &
                trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i))))
        case (RADIATION)
           write (unit=u, fmt=2) kingraph%tree%bc(i), 'radiation', &
                kingraph%tree%pdg(i), &
                trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
        case (COLLINEAR)
           write (unit=u, fmt=2) kingraph%tree%bc(i), 'collinear', &
                kingraph%tree%pdg(i), &
                trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
        case (INFRARED)
           write (unit=u, fmt=2) kingraph%tree%bc(i), 'infrared ', &
                kingraph%tree%pdg(i), &
                trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
        case (ON_SHELL)
           write (unit=u, fmt=2) kingraph%tree%bc(i), 'on_shell ', &
                kingraph%tree%pdg(i), &
                trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
        case default
           call msg_bug (" Impossible mapping mode encountered")
        end select
     enddo
   end subroutine kingraph_write_file_format
 
 @ %def kingraph_write_file_format
 @ Get the particle name from the [[particle]] array of the
 [[feyngraph_set]]. This is needed for the phs file creation.
 <<Cascades2: procedures>>=
    function get_particle_name (feyngraph_set, pdg) result (particle_name)
      type (feyngraph_set_t), intent (in) :: feyngraph_set
      integer, intent (in) :: pdg
      character (len=LABEL_LEN) :: particle_name
      integer :: i
      do i=1, size (feyngraph_set%particle)
         if (feyngraph_set%particle(i)%pdg == pdg) then
            particle_name = feyngraph_set%particle(i)%particle_label
            exit
         end if
      enddo
    end function get_particle_name
 
 @ %def get_particle_name
 @
 \subsection{Invert a graph}
 All Feynman diagrams given by O'Mega look like a decay. The [[feyngraph]]
 which is constructed from this output also looks like a decay, where one
 of the incoming particles is the decaying particle (or the root of the
 tree). The calculations can in principle be done on this data structure.
 However, it is also performed with the other incoming particle as
 the root. The first part of the calculation is the same for both cases.
 For the second part we need to transform/turn the graphs such that the
 other incoming particle becomes the root. This is done by identifying
 the incoming particles from the O'Mega output (the first one is simply
 the root of the existing tree, the second contains [2] in the
 [[particle_label]]) and the nodes/particles which connect both incoming
 particles (here we set [[t_line = .true.]]). At the same time we set the
 pointers  [[inverse_daughter1]] and [[inverse_daughter2]] for the
 corresponding node, which point to the mother node and the other daughter
 of the mother node; these will be the daughters of the node in the
 inverted [[feyngraph]].
 <<Cascades2: feyngraph: TBP>>=
   procedure :: make_invertible => feyngraph_make_invertible
 <<Cascades2: procedures>>=
   subroutine feyngraph_make_invertible (feyngraph)
     class (feyngraph_t), intent (inout) :: feyngraph
     logical :: t_line_found
     feyngraph%root%incoming = .true.
     t_line_found = .false.
     if (associated (feyngraph%root%daughter1)) then
        call f_node_t_line_check (feyngraph%root%daughter1, t_line_found)
        if (.not. t_line_found) then
           if (associated (feyngraph%root%daughter2)) then
              call f_node_t_line_check (feyngraph%root%daughter2, t_line_found)
           end if
        end if
     end if
 
   contains
 
 <<k node t line check>>
   end subroutine feyngraph_make_invertible
 
 @ %def feyngraph_make_invertible
 @ Check if a node has to be [[t_line]] or [[incoming]] and assign
 inverse daughter pointers.
 <<k node t line check>>=
   recursive subroutine f_node_t_line_check (node, t_line_found)
     type (f_node_t), target, intent (inout) :: node
     integer :: pos
     logical, intent (inout) :: t_line_found
     if (associated (node%daughter1)) then
        call f_node_t_line_check (node%daughter1, t_line_found)
        if (node%daughter1%incoming .or. node%daughter1%t_line) then
           node%t_line = .true.
        else if (associated (node%daughter2)) then
           call f_node_t_line_check (node%daughter2, t_line_found)
           if (node%daughter2%incoming .or. node%daughter2%t_line) then
              node%t_line = .true.
           end if
        end if
     else
        pos = index (node%particle_label, '[') + 1
        if (node%particle_label(pos:pos) == '2') then
           node%incoming = .true.
           t_line_found = .true.
        end if
     end if
   end subroutine f_node_t_line_check
 
 @ %def k_node_t_line_check
 @ Make an inverted copy of a [[kingraph]] using the inverse daughter
 pointers.
 <<Cascades2: kingraph: TBP>>=
   procedure :: make_inverse_copy => kingraph_make_inverse_copy
 <<Cascades2: procedures>>=
   subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph)
     class (kingraph_t), intent (inout) :: original_kingraph
     type (feyngraph_t), intent (inout) :: feyngraph
     type (kingraph_t), pointer :: kingraph_copy
     type (k_node_t), pointer :: potential_root
     allocate (kingraph_copy)
     if (associated (feyngraph%kin_last)) then
        allocate (feyngraph%kin_last%next)
        feyngraph%kin_last => feyngraph%kin_last%next
     else
        allocate(feyngraph%kin_first)
        feyngraph%kin_last => feyngraph%kin_first
     end if
     kingraph_copy => feyngraph%kin_last
     call kingraph_set_inverse_daughters (original_kingraph)
     kingraph_copy%inverse = .true.
     kingraph_copy%n_nodes = original_kingraph%n_nodes
     kingraph_copy%keep = original_kingraph%keep
     potential_root => original_kingraph%root
     do while (.not. potential_root%incoming .or. &
          (associated (potential_root%daughter1) .and. associated (potential_root%daughter2)))
        if (potential_root%daughter1%incoming .or. potential_root%daughter1%t_line) then
           potential_root => potential_root%daughter1
        else if (potential_root%daughter2%incoming .or. potential_root%daughter2%t_line) then
           potential_root => potential_root%daughter2
        end if
     enddo
     call node_inverse_deep_copy (potential_root, kingraph_copy%root)
   end subroutine kingraph_make_inverse_copy
 
 @ %def kingraph_make_inverse_copy
 @ Recursively deep-copy nodes, but along the t-line the inverse daughters
 become the new daughters. We need a deep copy only for the [[incoming]]
 or [[t_line]] nodes. For the other nodes (of s-channel subgraphs) we set
 only pointers to the existing nodes of the non-inverted graph.
 <<Cascades2: procedures>>=
   recursive subroutine node_inverse_deep_copy (original_node, node_copy)
     type (k_node_t), intent (in) :: original_node
     type (k_node_t), pointer, intent (out) :: node_copy
     call original_node%f_node%k_node_list%add_entry(node_copy, recycle=.false.)
     node_copy = original_node
     if (node_copy%t_line .or. node_copy%incoming) then
        node_copy%particle => original_node%particle%anti
     else
        node_copy%particle => original_node%particle
     end if
     if (associated (original_node%inverse_daughter1) .and. associated (original_node%inverse_daughter2)) then
        if (original_node%inverse_daughter1%incoming .or. original_node%inverse_daughter1%t_line) then
           node_copy%daughter2 => original_node%inverse_daughter2
           call node_inverse_deep_copy (original_node%inverse_daughter1, &
                node_copy%daughter1)
        else if (original_node%inverse_daughter2%incoming .or. original_node%inverse_daughter2%t_line) then
           node_copy%daughter1 => original_node%inverse_daughter1
           call node_inverse_deep_copy (original_node%inverse_daughter2, &
                node_copy%daughter2)
        end if
     end if
   end subroutine node_inverse_deep_copy
 
 @ %def node_inverse_deep_copy
 @
 \subsection{Find phase-space parametrizations}
 Perform all mapping calculations for a single process and store valid
 [[kingraphs]] (channels) into the grove list, without caring for instance
 about the resonance hash values.
 <<Cascades2: public>>=
   public :: feyngraph_set_generate_single
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_generate_single (feyngraph_set, model, n_in, n_out, &
        phs_par, fatal_beam_decay, u_in)
     type(feyngraph_set_t), intent(inout) :: feyngraph_set
     type(model_data_t), target, intent(in) :: model
     integer, intent(in) :: n_in, n_out
     type(phs_parameters_t), intent(in) :: phs_par
     logical, intent(in) :: fatal_beam_decay
     integer, intent(in) :: u_in
     feyngraph_set%n_in = n_in
     feyngraph_set%n_out = n_out
     feyngraph_set%process_type = n_in
     feyngraph_set%phs_par = phs_par
     feyngraph_set%model => model
     if (debug_on) call msg_debug (D_PHASESPACE, "Construct relevant Feynman diagrams from Omega output")
     call feyngraph_set%build (u_in)
     if (debug_on) call msg_debug (D_PHASESPACE, "Find phase-space parametrizations")
     call feyngraph_set_find_phs_parametrizations(feyngraph_set)
   end subroutine feyngraph_set_generate_single
 
 @ %def feyngraph_set_generate_single
 @ Find the phase space parametrizations. We start with the computation
 of pure s-channel subtrees, i.e. we determine mappings and compare
 subtrees in order to reduce the number of channels. This can be
 parallelized easily. When all s-channel [[k_nodes]] exist, the possible
 [[kingraphs]] are created using these nodes and we determine mappings for
 t-channel nodes.
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_find_phs_parametrizations (feyngraph_set)
     class (feyngraph_set_t), intent (inout) :: feyngraph_set
     type (feyngraph_t), pointer :: current => null ()
     type (feyngraph_ptr_t), dimension (:), allocatable :: set
     integer :: pos
     integer :: i
     allocate (set (feyngraph_set%n_graphs))
     pos = 0
     current => feyngraph_set%first
     do while (associated (current))
        pos = pos + 1
        set(pos)%graph => current
        current => current%next
     enddo
     if (feyngraph_set%process_type == SCATTERING) then
        !$OMP PARALLEL DO
        do i=1, feyngraph_set%n_graphs
           if (set(i)%graph%keep) then
              call set(i)%graph%make_invertible ()
           end if
        enddo
        !$OMP END PARALLEL DO
     end if
     call f_node_list_compute_mappings_s (feyngraph_set)
     do i=1, feyngraph_set%n_graphs
        if (set(i)%graph%keep) then
           call set(i)%graph%make_kingraphs (feyngraph_set)
        end if
     enddo
     if (feyngraph_set%process_type == SCATTERING) then
        do i=1, feyngraph_set%n_graphs
           if (set(i)%graph%keep) then
              call set(i)%graph%make_inverse_kingraphs ()
           end if
        enddo
     end if
     do i=1, feyngraph_set%n_graphs
        if (set(i)%graph%keep) then
           call set(i)%graph%compute_mappings (feyngraph_set)
        end if
     enddo
     do i=1, feyngraph_set%n_graphs
        if (set(i)%graph%keep) then
           call feyngraph_set%grove_list%add_feyngraph (set(i)%graph, &
                feyngraph_set%model)
        end if
     enddo
   end subroutine feyngraph_set_find_phs_parametrizations
 
 @ %def feyngraph_set_find_phs_parametrizations
 @ Compare objects of type [[tree_t]].
 <<Cascades2: interfaces>>=
   interface operator (==)
      module procedure tree_equal
   end interface operator (==)
 <<Cascades2: procedures>>=
   elemental function tree_equal (tree1, tree2) result (flag)
     type (tree_t), intent (in) :: tree1, tree2
     logical :: flag
     if (tree1%n_entries == tree2%n_entries) then
        if (tree1%bc(size(tree1%bc)) == tree2%bc(size(tree2%bc))) then
           flag = all (tree1%mapping == tree2%mapping) .and. &
                all (tree1%bc == tree2%bc) .and. &
                all (abs(tree1%pdg) == abs(tree2%pdg))
        else
           flag = .false.
        end if
     else
        flag = .false.
     end if
   end function tree_equal
 
 @ %def tree_equal
 @ Select between equivalent subtrees (type [[tree_t]]). This is similar
 to [[kingraph_select]], but we compare only positions with mappings
 [[NONRESONANT]] and [[NO_MAPPING]].
 <<Cascades2: interfaces>>=
   interface operator (.eqv.)
      module procedure subtree_eqv
   end interface operator (.eqv.)
 <<Cascades2: procedures>>=
   pure function subtree_eqv (subtree1, subtree2) result (eqv)
     type (tree_t), intent (in) :: subtree1, subtree2
     logical :: eqv
     integer :: root_pos
     integer :: i
     logical :: equal
     eqv = .false.
     if (subtree1%n_entries /= subtree2%n_entries) return
     root_pos = subtree1%n_entries
     if (subtree1%mapping(root_pos) == NONRESONANT .or. &
          subtree2%mapping(root_pos) == NONRESONANT .or. &
          (subtree1%mapping(root_pos) == NO_MAPPING .and. &
          subtree2%mapping(root_pos) == NO_MAPPING .and. &
          abs(subtree1%pdg(root_pos)) == abs(subtree2%pdg(root_pos)))) then
        do i = subtree1%n_entries, 1, -1
           if (subtree1%bc(i) /= subtree2%bc(i)) return
        enddo
        equal = .true.
        do i = subtree1%n_entries, 1, -1
           if (abs(subtree1%pdg(i)) /= abs (subtree2%pdg(i))) then
              select case (subtree1%mapping(i))
              case (NO_MAPPING, NONRESONANT)
                 select case (subtree2%mapping(i))
                 case (NO_MAPPING, NONRESONANT)
                    equal = .false.
                 case default
                    return
                 end select
              case default
                 return
              end select
           end if
        enddo
        do i = subtree1%n_entries, 1, -1
           if (subtree1%mapping(i) /= subtree2%mapping(i)) then
              select case (subtree1%mapping(i))
              case (NO_MAPPING, NONRESONANT)
                 select case (subtree2%mapping(i))
                 case (NO_MAPPING, NONRESONANT)
                 case default
                    return
                 end select
              case default
                 return
              end select
           end if
        enddo
        if (.not. equal) eqv = .true.
     end if
   end function subtree_eqv
 
 @ %def subtree_eqv
 <<Cascades2: procedures>>=
   subroutine subtree_select (subtree1, subtree2, model)
     type (tree_t), intent (inout) :: subtree1, subtree2
     type (model_data_t), intent (in) :: model
     integer :: j, k
     integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc
     integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg
     integer, dimension (:), allocatable :: pdg_match
     if (subtree1 .eqv. subtree2) then
        do j=1, subtree1%n_entries
           if (abs(subtree1%pdg(j)) /= abs(subtree2%pdg(j))) then
              tmp_bc = subtree1%bc(:j-1); tmp_pdg = subtree1%pdg(:j-1)
              do k=j-1, 1, - 1
                 where (iand (tmp_bc(:k-1),tmp_bc(k)) /= 0 &
                      .or. iand(tmp_bc(:k-1),subtree1%bc(j)) == 0)
                    tmp_bc(:k-1) = 0
                    tmp_pdg(:k-1) = 0
                 endwhere
              enddo
              daughter_bc = pack (tmp_bc, tmp_bc /= 0)
              daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0)
              if (size (daughter_pdg) == 2) then
                 call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match)
                 if (.not. allocated (pdg_match)) then
 !!! Relevant if tree contains only abs (pdg). In this case, changing the
 !!! sign of one of the pdg codes should give a result.
                    call model%match_vertex(-daughter_pdg(1), daughter_pdg(2), pdg_match)
                 end if
              end if
              do k=1, size (pdg_match)
                 if (abs(pdg_match(k)) == abs(subtree1%pdg(j))) then
                    if (subtree1%keep) subtree2%keep = .false.
                    exit
                 else if (abs(pdg_match(k)) == abs(subtree2%pdg(j))) then
                    if (subtree2%keep) subtree1%keep = .false.
                    exit
                 end if
              enddo
              deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match)
              if (.not. (subtree1%keep .and. subtree2%keep)) exit
           end if
        enddo
     end if
   end subroutine subtree_select
 
 @ %def subtree_select
 @ Assign a resonance hash value to a [[kingraph]], like in [[cascades]],
 but here without the array [[tree_resonant]].
 <<Cascades2: kingraph: TBP>>=
   procedure :: assign_resonance_hash => kingraph_assign_resonance_hash
 <<Cascades2: procedures>>=
   subroutine kingraph_assign_resonance_hash (kingraph)
     class (kingraph_t), intent (inout) :: kingraph
     logical, dimension (:), allocatable :: tree_resonant
     integer(i8), dimension(1) :: mold
     allocate (tree_resonant (kingraph%tree%n_entries))
     tree_resonant = (kingraph%tree%mapping == S_CHANNEL)
     kingraph%grove_prop%res_hash = hash (transfer &
          ([sort (pack (kingraph%tree%pdg, tree_resonant)), &
            sort (pack (abs (kingraph%tree%pdg), &
            kingraph%tree%mapping == T_CHANNEL .or. &
            kingraph%tree%mapping == U_CHANNEL))], mold))
     deallocate (tree_resonant)
   end subroutine kingraph_assign_resonance_hash
 
 @ %def kingraph_assign_resonance_hash
 @ Write the process in the bincode format. This is again a copy of the
 corresponding procedure in [[cascades]], using [[feyngraph_set]] instead
 of [[cascade_set]] as an argument.
 <<Cascades2: public>>=
   public :: feyngraph_set_write_process_bincode_format
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_write_process_bincode_format (feyngraph_set, unit)
     type(feyngraph_set_t), intent(in), target :: feyngraph_set
     integer, intent(in), optional :: unit
     integer, dimension(:), allocatable :: bincode, field_width
     integer :: n_in, n_out, n_tot, n_flv
     integer :: u, f, i, bc
     character(20) :: str
     type(string_t) :: fmt_head
     type(string_t), dimension(:), allocatable :: fmt_proc
     u = given_output_unit (unit);  if (u < 0)  return
     if (.not. allocated (feyngraph_set%flv)) return
     write (u, "('!',1x,A)")  "List of subprocesses with particle bincodes:"
     n_in  = feyngraph_set%n_in
     n_out = feyngraph_set%n_out
     n_tot = n_in + n_out
     n_flv = size (feyngraph_set%flv, 2)
     allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot))
     bc = 1
     do i = 1, n_out
        bincode(n_in + i) = bc
        bc = 2 * bc
     end do
     do i = n_in, 1, -1
        bincode(i) = bc
        bc = 2 * bc
     end do
     do i = 1, n_tot
        write (str, "(I0)")  bincode(i)
        field_width(i) = len_trim (str)
        do f = 1, n_flv
           field_width(i) = max (field_width(i), &
                len (feyngraph_set%flv(i,f)%get_name ()))
        end do
     end do
     fmt_head = "('!'"
     do i = 1, n_tot
        fmt_head = fmt_head // ",1x,"
        fmt_proc(i) = "(1x,"
        write (str, "(I0)")  field_width(i)
        fmt_head = fmt_head // "I" // trim(str)
        fmt_proc(i) = fmt_proc(i) // "A" // trim(str)
        if (i == n_in) then
           fmt_head = fmt_head // ",1x,'  '"
        end if
     end do
     do i = 1, n_tot
        fmt_proc(i) = fmt_proc(i) // ")"
     end do
     fmt_head = fmt_head // ")"
     write (u, char (fmt_head))  bincode
     do f = 1, n_flv
        write (u, "('!')", advance="no")
        do i = 1, n_tot
           write (u, char (fmt_proc(i)), advance="no") &
                char (feyngraph_set%flv(i,f)%get_name ())
           if (i == n_in)  write (u, "(1x,'=>')", advance="no")
        end do
        write (u, *)
     end do
     write (u, char (fmt_head))  bincode
   end subroutine feyngraph_set_write_process_bincode_format
 
 @ %def feyngraph_set_write_process_bincode_format
 @ Write tex file for graphical display of channels.
 <<Cascades2: public>>=
   public :: feyngraph_set_write_graph_format
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_write_graph_format (feyngraph_set, filename, process_id, unit)
     type(feyngraph_set_t), intent(in), target :: feyngraph_set
     type(string_t), intent(in) :: filename, process_id
     integer, intent(in), optional :: unit
     type(kingraph_t), pointer :: kingraph
     type(grove_t), pointer :: grove
     integer :: u, n_grove, count, pgcount
     logical :: first_in_grove
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, '(A)') "\documentclass[10pt]{article}"
     write (u, '(A)') "\usepackage{amsmath}"
     write (u, '(A)') "\usepackage{feynmp}"
     write (u, '(A)') "\usepackage{url}"
     write (u, '(A)') "\usepackage{color}"
     write (u, *)
     write (u, '(A)') "\textwidth 18.5cm"
     write (u, '(A)') "\evensidemargin -1.5cm"
     write (u, '(A)') "\oddsidemargin -1.5cm"
     write (u, *)
     write (u, '(A)') "\newcommand{\blue}{\color{blue}}"
     write (u, '(A)') "\newcommand{\green}{\color{green}}"
     write (u, '(A)') "\newcommand{\red}{\color{red}}"
     write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}"
     write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}"
     write (u, '(A)') "\newcommand{\sm}{\footnotesize}"
     write (u, '(A)') "\setlength{\parindent}{0pt}"
     write (u, '(A)') "\setlength{\parsep}{20pt}"
     write (u, *)
     write (u, '(A)') "\begin{document}"
     write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}"
     write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}"
     write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}"
     write (u, '(A)') "\begin{fmfshrink}{0.5}"
     write (u, '(A)') "\begin{flushleft}"
     write (u, *)
     write (u, '(A)') "\noindent" // &
          & "\textbf{\large\texttt{WHIZARD} phase space channels}" // &
          & "\hfill\today"
     write (u, *)
     write (u, '(A)') "\vspace{10pt}"
     write (u, '(A)') "\noindent" // &
          & "\textbf{Process:} \url{" // char (process_id) // "}"
     call feyngraph_set_write_process_tex_format (feyngraph_set, u)
     write (u, *)
     write (u, '(A)') "\noindent" // &
          & "\textbf{Note:} These are pseudo Feynman graphs that "
     write (u, '(A)') "visualize phase-space parameterizations " // &
          & "(``integration channels'').  "
     write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // &
          & "matrix element."
     write (u, *)
     write (u, '(A)') "\textbf{Color code:} " // &
          & "{\blue resonance,} " // &
          & "{\cyan t-channel,} " // &
          & "{\green radiation,} "
     write (u, '(A)') "{\red infrared,} " // &
          & "{\magenta collinear,} " // &
          & "external/off-shell"
     write (u, *)
     write (u, '(A)') "\noindent" // &
          & "\textbf{Black square:} Keystone, indicates ordering of " // &
          & "phase space parameters."
     write (u, *)
     write (u, '(A)') "\vspace{-20pt}"
     count = 0
     pgcount = 0
     n_grove = 0
     grove => feyngraph_set%grove_list%first
     do while (associated (grove))
        n_grove = n_grove + 1
        write (u, *)
        write (u, '(A)') "\vspace{20pt}"
        write (u, '(A)') "\begin{tabular}{l}"
        write (u, '(A,I5,A)') &
             & "\fbox{\bf Grove \boldmath$", n_grove, "$} \\[10pt]"
        write (u, '(A,I1,A)') "Multiplicity: ", &
             grove%grove_prop%multiplicity, "\\"
        write (u, '(A,I1,A)') "Resonances:   ", &
             grove%grove_prop%n_resonances, "\\"
        write (u, '(A,I1,A)') "Log-enhanced: ", &
             grove%grove_prop%n_log_enhanced, "\\"
        write (u, '(A,I1,A)') "Off-shell:    ", &
             grove%grove_prop%n_off_shell, "\\"
        write (u, '(A,I1,A)') "t-channel:    ", &
             grove%grove_prop%n_t_channel, ""
        write (u, '(A)') "\end{tabular}"
        kingraph => grove%first
        do while (associated (kingraph))
           count = count + 1
           call kingraph_write_graph_format (kingraph, count, unit)
           kingraph => kingraph%grove_next
        enddo
        grove => grove%next
     enddo
     write (u, '(A)') "\end{flushleft}"
     write (u, '(A)') "\end{fmfshrink}"
     write (u, '(A)') "\end{fmffile}"
     write (u, '(A)') "\end{document}"
   end subroutine feyngraph_set_write_graph_format
 
 @ %def feyngraph_set_write_graph_format
 @ Write the process as a \LaTeX\ expression. This is a slightly modified
 copy of [[cascade_set_write_process_tex_format]] which has only been
 adapted to the types which are used here.
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_write_process_tex_format (feyngraph_set, unit)
     type(feyngraph_set_t), intent(in), target :: feyngraph_set
     integer, intent(in), optional :: unit
     integer :: n_tot
     integer :: u, f, i
     n_tot = feyngraph_set%n_in + feyngraph_set%n_out
     u = given_output_unit (unit);  if (u < 0)  return
     if (.not. allocated (feyngraph_set%flv)) return
     write (u, "(A)")  "\begin{align*}"
     do f = 1, size (feyngraph_set%flv, 2)
        do i = 1, feyngraph_set%n_in
           if (i > 1)  write (u, "(A)", advance="no") "\quad "
           write (u, "(A)", advance="no") &
                char (feyngraph_set%flv(i,f)%get_tex_name ())
        end do
        write (u, "(A)", advance="no")  "\quad &\to\quad "
        do i = feyngraph_set%n_in + 1, n_tot
           if (i > feyngraph_set%n_in + 1)  write (u, "(A)", advance="no") "\quad "
           write (u, "(A)", advance="no") &
                char (feyngraph_set%flv(i,f)%get_tex_name ())
        end do
        if (f < size (feyngraph_set%flv, 2)) then
           write (u, "(A)")  "\\"
        else
           write (u, "(A)")  ""
        end if
     end do
     write (u, "(A)")  "\end{align*}"
   end subroutine feyngraph_set_write_process_tex_format
 
 @ %def feyngraph_set_write_process_tex_format
 @ This creates metapost source for graphical display for a given [[kingraph]].
 It is the analogon to [[cascade_write_graph_format]] (a modified copy).
 <<Cascades2: procedures>>=
   subroutine kingraph_write_graph_format (kingraph, count, unit)
     type(kingraph_t), intent(in) :: kingraph
     integer, intent(in) :: count
     integer, intent(in), optional :: unit
     integer :: u
     type(string_t) :: left_str, right_str
     u = given_output_unit (unit);  if (u < 0)  return
     left_str = ""
     right_str = ""
     write (u, '(A)') "\begin{minipage}{105pt}"
     write (u, '(A)') "\vspace{30pt}"
     write (u, '(A)') "\begin{center}"
     write (u, '(A)') "\begin{fmfgraph*}(55,55)"
     call graph_write_node (kingraph%root)
     write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}"
     write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}"
     write (u, '(A)') "\end{fmfgraph*}\\"
     write (u, '(A,I5,A)') "\fbox{$", count, "$}"
     write (u, '(A)') "\end{center}"
     write (u, '(A)') "\end{minipage}"
     write (u, '(A)') "%"
   contains
     recursive subroutine graph_write_node (node)
       type(k_node_t), intent(in) :: node
       if (associated (node%daughter1) .or. associated (node%daughter2)) then
          if (node%daughter2%t_line .or. node%daughter2%incoming) then
             call vertex_write (node, node%daughter2)
             call vertex_write (node, node%daughter1)
          else
             call vertex_write (node, node%daughter1)
             call vertex_write (node, node%daughter2)
          end if
          if (node%mapping == EXTERNAL_PRT) then
             call line_write (node%bincode, 0, node%particle)
             call external_write (node%bincode, node%particle%tex_name, &
                  left_str)
             write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}"
          end if
       else
          if (node%incoming) then
             call external_write (node%bincode, node%particle%anti%tex_name, &
                  left_str)
          else
             call external_write (node%bincode, node%particle%tex_name, &
                  right_str)
          end if
       end if
     end subroutine graph_write_node
     recursive subroutine vertex_write (node, daughter)
       type(k_node_t), intent(in) :: node, daughter
       integer :: bincode
       if (associated (node%daughter1) .and. associated (node%daughter2) &
            .and. node%mapping == EXTERNAL_PRT) then
          bincode = 0
       else
          bincode = node%bincode
       end if
       call graph_write_node (daughter)
       if (associated (node%daughter1) .or. associated (node%daughter2)) then
          call line_write (bincode, daughter%bincode, daughter%particle, &
               mapping=daughter%mapping)
       else
          call line_write (bincode, daughter%bincode, daughter%particle)
       end if
     end subroutine vertex_write
     subroutine line_write (i1, i2, particle, mapping)
       integer(TC), intent(in) :: i1, i2
       type(part_prop_t), intent(in) :: particle
       integer, intent(in), optional :: mapping
       integer :: k1, k2
       type(string_t) :: prt_type
       select case (particle%spin_type)
       case (SCALAR);       prt_type = "plain"
       case (SPINOR);       prt_type = "fermion"
       case (VECTOR);       prt_type = "boson"
       case (VECTORSPINOR); prt_type = "fermion"
       case (TENSOR);       prt_type = "dbl_wiggly"
       case default;        prt_type = "dashes"
       end select
       if (particle%pdg < 0) then
 !!! anti-particle
          k1 = i2;  k2 = i1
       else
          k1 = i1;  k2 = i2
       end if
       if (present (mapping)) then
          select case (mapping)
          case (S_CHANNEL)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=blue,lab=\sm\blue$" // &
                  & char (particle%tex_name) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case (T_CHANNEL, U_CHANNEL)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=cyan,lab=\sm\cyan$" // &
                  & char (particle%tex_name) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case (RADIATION)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=green,lab=\sm\green$" // &
                  & char (particle%tex_name) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case (COLLINEAR)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=magenta,lab=\sm\magenta$" // &
                  & char (particle%tex_name) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case (INFRARED)
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=red,lab=\sm\red$" // &
                  & char (particle%tex_name) // "$}" // &
                  & "{v", k1, ",v", k2, "}"
          case default
             write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & ",f=black}" // &
                  & "{v", k1, ",v", k2, "}"
          end select
       else
          write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
                  & "}" // &
                  & "{v", k1, ",v", k2, "}"
       end if
     end subroutine line_write
     subroutine external_write (bincode, name, ext_str)
       integer(TC), intent(in) :: bincode
       type(string_t), intent(in) :: name
       type(string_t), intent(inout) :: ext_str
       character(len=20) :: str
       write (str, '(A2,I0)') ",v", bincode
       ext_str = ext_str // trim (str)
       write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" &
         // char (name) &
         // "\,(", bincode, ")" &
         // "$}{v", bincode, "}"
     end subroutine external_write
   end subroutine kingraph_write_graph_format
 
 @ %def kingraph_write_graph_format
 @ Generate a [[feyngraph_set]] for several subprocesses. Mapping
 calculations are performed separately, but the final grove list is shared
 between the subsets [[fset]] of the [[feyngraph_set]].
 <<Cascades2: public>>=
   public :: feyngraph_set_generate
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_generate &
     (feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, &
     u_in, vis_channels, use_dag)
     type(feyngraph_set_t), intent(out) :: feyngraph_set
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_in, n_out
     type(flavor_t), dimension(:,:), intent(in) :: flv
     type(phs_parameters_t), intent(in) :: phs_par
     logical, intent(in) :: fatal_beam_decay
     integer, intent(in) :: u_in
     logical, intent(in) :: vis_channels
     logical, optional, intent(in) :: use_dag
     type(grove_t), pointer :: grove
     integer :: i, j
     type(kingraph_t), pointer :: kingraph
     if (phase_space_vanishes (phs_par%sqrts, n_in, flv))  return
     if (present (use_dag)) feyngraph_set%use_dag = use_dag
     feyngraph_set%process_type = n_in
     feyngraph_set%n_in = n_in
     feyngraph_set%n_out = n_out
     allocate (feyngraph_set%flv (size (flv, 1), size (flv, 2)))
     do i = 1, size (flv, 2)
        do j = 1, size (flv, 1)
           call feyngraph_set%flv(j,i)%init (flv(j,i)%get_pdg (), model)
        end do
     end do
     allocate (feyngraph_set%particle (PRT_ARRAY_SIZE))
     allocate (feyngraph_set%grove_list)
     allocate (feyngraph_set%fset (size (flv, 2)))
     do i = 1, size (feyngraph_set%fset)
        feyngraph_set%fset(i)%use_dag = feyngraph_set%use_dag
        allocate (feyngraph_set%fset(i)%flv(size (flv,1),1))
        feyngraph_set%fset(i)%flv(:,1) = flv(:,i)
        feyngraph_set%fset(i)%particle => feyngraph_set%particle
        allocate (feyngraph_set%fset(i)%grove_list)
        call feyngraph_set_generate_single (feyngraph_set%fset(i), &
             model, n_in, n_out, phs_par, fatal_beam_decay, u_in)
        call feyngraph_set%grove_list%merge (feyngraph_set%fset(i)%grove_list, model, i)
        if (.not. vis_channels) call feyngraph_set%fset(i)%final()
     enddo
     call feyngraph_set%grove_list%rebuild ()
   end subroutine feyngraph_set_generate
 
 @ %def feyngraph_set_generate
 @ Check whether the [[grove_list]] of the [[feyngraph_set]] contains any
 [[kingraphs]] which are valid, i.e. where the [[keep]] variable has the
 value [[.true.]]. This is necessary to write a non-empty phase-space
 file. The function is the pendant to [[cascade_set_is_valid]].
 <<Cascades2: public>>=
   public :: feyngraph_set_is_valid
 <<Cascades2: procedures>>=
   function feyngraph_set_is_valid (feyngraph_set) result (flag)
     class (feyngraph_set_t), intent(in) :: feyngraph_set
     type (kingraph_t), pointer :: kingraph
     type (grove_t), pointer :: grove
     logical :: flag
     flag = .false.
     if (associated (feyngraph_set%grove_list)) then
        grove => feyngraph_set%grove_list%first
        do while (associated (grove))
           kingraph => grove%first
           do while (associated (kingraph))
              if (kingraph%keep) then
                 flag = .true.
                 return
              end if
              kingraph => kingraph%next
           enddo
           grove => grove%next
        enddo
     end if
   end function feyngraph_set_is_valid
 
 @ %def feyngraph_set_is_valid
 @
 \subsection{Return the resonance histories for subtraction}
 The following procedures are copies of corresponding procedures in
 [[cascades]], which only have been adapted to the new types used in
 this module.\\
 Extract the resonance set from a valid [[kingraph]] which is kept in the
 final grove list.
 <<Cascades2: kingraph: TBP>>=
   procedure :: extract_resonance_history => kingraph_extract_resonance_history
 <<Cascades2: procedures>>=
   subroutine kingraph_extract_resonance_history &
        (kingraph, res_hist, model, n_out)
     class(kingraph_t), intent(in), target :: kingraph
     type(resonance_history_t), intent(out) :: res_hist
     class(model_data_t), intent(in), target :: model
     integer, intent(in) :: n_out
     type(resonance_info_t) :: resonance
     integer :: i, mom_id, pdg
     if (debug_on) call msg_debug2 (D_PHASESPACE, "kingraph_extract_resonance_history")
     if (kingraph%grove_prop%n_resonances > 0) then
        if (associated (kingraph%root%daughter1) .or. &
             associated (kingraph%root%daughter2)) then
           if (debug_on) call msg_debug2 (D_PHASESPACE, "kingraph has resonances, root has children")
           do i = 1, kingraph%tree%n_entries
              if (kingraph%tree%mapping(i) == S_CHANNEL) then
                 mom_id = kingraph%tree%bc (i)
                 pdg = kingraph%tree%pdg (i)
                 call resonance%init (mom_id, pdg, model, n_out)
                 if (debug2_active (D_PHASESPACE)) then
                    print *, 'D: Adding resonance'
                    call resonance%write ()
                 end if
                 call res_hist%add_resonance (resonance)
              end if
           end do
        end if
     end if
   end subroutine kingraph_extract_resonance_history
 
 @ %def kingraph_extract_resonance_history
 @ Determine the number of valid [[kingraphs]] in [[grove_list]].
 <<Cascades2: public>>=
   public :: grove_list_get_n_trees
 <<Cascades2: procedures>>=
   function grove_list_get_n_trees (grove_list) result (n)
     class (grove_list_t), intent (in) :: grove_list
     integer :: n
     type(kingraph_t), pointer :: kingraph
     type(grove_t), pointer :: grove
     if (debug_on) call msg_debug (D_PHASESPACE, "grove_list_get_n_trees")
     n = 0
     grove => grove_list%first
     do while (associated (grove))
        kingraph => grove%first
        do while (associated (kingraph))
           if (kingraph%keep) n = n + 1
           kingraph => kingraph%grove_next
        enddo
        grove => grove%next
     enddo
     if (debug_on) call msg_debug (D_PHASESPACE, "n", n)
   end function grove_list_get_n_trees
 
 @ %def grove_list_get_n_trees
 @ Extract the resonance histories from the [[feyngraph_set]], in complete
 analogy to [[cascade_set_get_resonance_histories]]
 <<Cascades2: public>>=
   public :: feyngraph_set_get_resonance_histories
 <<Cascades2: procedures>>=
   subroutine feyngraph_set_get_resonance_histories (feyngraph_set, n_filter, res_hists)
     type(feyngraph_set_t), intent(in), target :: feyngraph_set
     integer, intent(in), optional :: n_filter
     type(resonance_history_t), dimension(:), allocatable, intent(out) :: res_hists
     type(kingraph_t), pointer :: kingraph
     type(grove_t), pointer :: grove
     type(resonance_history_t) :: res_hist
     type(resonance_history_set_t) :: res_hist_set
     integer :: i_grove
     if (debug_on) call msg_debug (D_PHASESPACE, "grove_list_get_resonance_histories")
     call res_hist_set%init (n_filter = n_filter)
     grove => feyngraph_set%grove_list%first
     i_grove = 0
     do while (associated (grove))
        i_grove = i_grove + 1
        kingraph => grove%first
        do while (associated (kingraph))
           if (kingraph%keep) then
              if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", i_grove)
              call kingraph%extract_resonance_history &
                   (res_hist, feyngraph_set%model, feyngraph_set%n_out)
              call res_hist_set%enter (res_hist)
           end if
           kingraph => kingraph%grove_next
        end do
     end do
     call res_hist_set%freeze ()
     call res_hist_set%to_array (res_hists)
   end subroutine feyngraph_set_get_resonance_histories
 
 @ %def feyngraph_set_get_resonance_histories
 <<[[cascades2_ut.f90]]>>=
 <<File header>>
 
 module cascades2_ut
   use unit_tests
   use cascades2_uti
 
 <<Standard module head>>
 
 <<Cascades2: public test>>
 
 contains
 
 <<Cascades2: test driver>>
 
 end module cascades2_ut
 @ %def cascades2_ut
 @
 <<[[cascades2_uti.f90]]>>=
 <<File header>>
 
 module cascades2_uti
 
 <<Use kinds>>
 <<Use strings>>
   use numeric_utils
 
   use cascades2
   use flavors
   use phs_forests, only: phs_parameters_t
   use model_data
 
 <<Standard module head>>
 
 <<Cascades2: test declarations>>
 
 contains
 
 <<Cascades2: tests>>
 
 end module cascades2_uti
 @ %def cascades2_uti
 @ API: driver for the unit tests below.
 <<Cascades2: public test>>=
   public :: cascades2_test
 <<Cascades2: test driver>>=
   subroutine cascades2_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Cascades2: execute tests>>
   end subroutine cascades2_test
 
 @ %def cascades2_test
 
 @
 <<Cascades2: execute tests>>=
   call test (cascades2_1, "cascades2_1", &
        "make phase-space", u, results)
   call test (cascades2_2, "cascades2_2", &
        "make phase-space (scattering)", u, results)
 <<Cascades2: test declarations>>=
   public :: cascades2_1
 <<Cascades2: tests>>=
   subroutine cascades2_1 (u)
     integer, intent(in) :: u
     type (feyngraph_set_t) :: feyngraph_set
     type (model_data_t) :: model
     integer :: n_in = 1
     integer :: n_out = 6
     type(flavor_t), dimension(7,1) :: flv
     type (phs_parameters_t) :: phs_par
     logical :: fatal_beam_decay = .true.
     integer :: u_in = 8
 
     write (u, "(A)")  "* Test output: cascades2_1"
     write (u, "(A)")  "*   Purpose: create a test phs file (decay) with the forest"
     write (u, "(A)")  "*            output of O'Mega"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initializing"
     write (u, "(A)")
 
     call init_sm_full_test (model)
 
     call flv(1,1)%init (6, model)
     call flv(2,1)%init (5, model)
     call flv(3,1)%init (-11, model)
     call flv(4,1)%init (12, model)
     call flv(5,1)%init (21, model)
     call flv(6,1)%init (22, model)
     call flv(7,1)%init (21, model)
 
     phs_par%sqrts = 173.1_default
     phs_par%m_threshold_s = 50._default
     phs_par%m_threshold_t = 100._default
     phs_par%keep_nonresonant = .true.
     phs_par%off_shell = 2
 
     open (unit=u_in, file="cascades2_1.fds", status='old', action='read')
 
     write (u, "(A)")
     write (u, "(A)")  "* Generating phase-space parametrizations"
     write (u, "(A)")
 
     call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, &
          flv, phs_par, fatal_beam_decay, u_in, use_dag = .false., &
 	 vis_channels = .false.)
     call feyngraph_set_write_process_bincode_format (feyngraph_set, u)
     call feyngraph_set_write_file_format (feyngraph_set, u)
 
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     close (u_in)
     call feyngraph_set%final ()
     call model%final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: cascades2_1"
   end subroutine cascades2_1
 
 @ %def cascades2_1
 @
 <<Cascades2: test declarations>>=
   public :: cascades2_2
 <<Cascades2: tests>>=
   subroutine cascades2_2 (u)
     integer, intent(in) :: u
     type (feyngraph_set_t) :: feyngraph_set
     type (model_data_t) :: model
     integer :: n_in = 2
     integer :: n_out = 5
     type(flavor_t), dimension(7,1) :: flv
     type (phs_parameters_t) :: phs_par
     logical :: fatal_beam_decay = .true.
     integer :: u_in = 8
 
     write (u, "(A)")  "* Test output: cascades2_2"
     write (u, "(A)")  "*   Purpose: create a test phs file (scattering) with the"
     write (u, "(A)")  "*            parsable DAG output of O'Mega"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initializing"
     write (u, "(A)")
 
     call init_sm_full_test (model)
 
     call flv(1,1)%init (-11, model)
     call flv(2,1)%init (11, model)
     call flv(3,1)%init (-11, model)
     call flv(4,1)%init (12, model)
     call flv(5,1)%init (1, model)
     call flv(6,1)%init (-2, model)
     call flv(7,1)%init (22, model)
 
     phs_par%sqrts = 500._default
     phs_par%m_threshold_s = 50._default
     phs_par%m_threshold_t = 100._default
     phs_par%keep_nonresonant = .true.
     phs_par%off_shell = 2
     phs_par%t_channel = 6
 
     open (unit=u_in, file="cascades2_2.fds", &
          status='old', action='read')
 
     write (u, "(A)")
     write (u, "(A)")  "* Generating phase-space parametrizations"
     write (u, "(A)")
 
     call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, &
          flv, phs_par, fatal_beam_decay, u_in, use_dag = .true., &
 	 vis_channels = .false.)
     call feyngraph_set_write_process_bincode_format (feyngraph_set, u)
     call feyngraph_set_write_file_format (feyngraph_set, u)
 
     write (u, "(A)")  "* Cleanup"
     write (u, "(A)")
 
     close (u_in)
     call feyngraph_set%final ()
     call model%final ()
 
     write (u, *)
     write (u, "(A)")  "* Test output end: cascades2_2"
   end subroutine cascades2_2
 
 @ %def cascades2_2
Index: trunk/src/fks/fks.nw
===================================================================
--- trunk/src/fks/fks.nw	(revision 8357)
+++ trunk/src/fks/fks.nw	(revision 8358)
@@ -1,9658 +1,9693 @@
 % -*- 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. However, most quantities have so far been only constructed
   for final-state emissions}
 
 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, comlex 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,
 \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{emi} &
   \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 & {(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. Here, there is only one fundamental tuple, corresponding to
   a singular configuration of the momenta of the additional quarks.}
 \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, only: remove_duplicates_from_int_array
   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
   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))
        if (flavor%is_antiparticle ()) then
           flv%charge(i) = -flavor%get_charge ()
        else
           flv%charge(i) = flavor%get_charge ()
        end if
     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,0,2-2,0]$.
 Here, there are two possible [[ftuples]] which contribute to the same
 $u \rightarrow u g$ splitting, namely $(3,4)$ and $(4,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.
   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
 @
 <<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 :: 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, alr, i, j, i_res) result (sval)
     class(region_data_t), intent(inout) :: reg_data
     type(vector4_t), intent(in), dimension(:) :: p
     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)
        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, 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, p_soft, alr, emitter, i_res) result (sval)
     class(region_data_t), intent(inout) :: reg_data
     type(vector4_t), intent(in), dimension(:) :: p
     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, 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, 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 :: valid1, valid2
       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
                valid1 = flv_real%valid_pair(leg1, leg2, flv_born, model)
                valid2 = flv_real%valid_pair(leg2, leg1, flv_born, model)
                if (valid1 .or. valid2) then
                   if(valid1) then
                      flst_alr_tmp = create_alr (flv_real, &
                           reg_data%n_in, leg1, leg2)
                   else
                      flst_alr_tmp = create_alr (flv_real, &
                           reg_data%n_in, leg2, leg1)
                   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
 @ 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
 @
 <<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
     j = 0
     allocate (ftuple_tmp (reg_data%n_legs_real * (reg_data%n_legs_real - 1)))
     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
                 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.
 @ Returns the index of the real flavor structure an ftuple belongs to.
 <<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,I3)') 'Total number of regions: ', size(reg_data%regions)
      write (u, '(A3)', 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, '(I3)', 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)
       import
       class(fks_mapping_t), intent(inout) :: map
       type(singular_region_t), intent(in) :: sregion
       type(vector4_t), intent(in), dimension(:) :: p
     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_1}\\,
   d_{1i} &= \left[2E_i^2\left(1-y_i\right)\right]^{p_1}\\,
   d_{2i} &= \left[2E_i^2\left(1+y_i\right)\right]^{p_1}\\,
 \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_2}
 \end{align*}
 for final state regions. 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*}
 <<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)
     class(fks_mapping_default_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p
     real(default) :: d
     integer :: alr, i, j
 
     associate (ftuples => sregion%ftuples)
       d = zero
       do alr = 1, sregion%nregions
          call ftuples(alr)%get (i, j)
          map%pseudo_isr = ftuples(alr)%pseudo_isr
          d = d + one / map%dij (p, 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 divergences 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 \rightarrow 0}{=} \frac{2}{k_l \cdot \hat{k}}{(1-y^2)E_l},
 \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, p_soft, expo) result (dij_soft)
       real(default) :: dij_soft
       integer, intent(in) :: em
       type(vector4_t), intent(in), dimension(:) :: p
       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(THR_POS_WP) + p(THR_POS_B)
       else
          p_top = p(THR_POS_WM) + p(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
 @
 <<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 :: alr, i, j
     integer :: nlegs
     d = zero
     nlegs = size (sregion%flst_real%flst)
     associate (ftuples => sregion%ftuples)
       do alr = 1, sregion%nregions
          call ftuples(alr)%get (i ,j)
          if (j == nlegs) then
             map%pseudo_isr = ftuples(alr)%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)
     class(fks_mapping_resonances_t), intent(inout) :: map
     type(singular_region_t), intent(in) :: sregion
     type(vector4_t), intent(in), dimension(:) :: p
     real(default) :: d, pfr
     integer :: i_res, i_reg, i, j, i_con
     integer :: nlegreal
 
     nlegreal = size (p)
     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, nlegreal)
        i_con = sregion%i_reg_to_i_con (i_reg)
        d = d + pfr / map%dij (p, 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
   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
     integer :: i_part, i_flv
     real(default) :: nf, CA_factor
     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)))
     select case (char (nlo_corr_type))
     case ("QCD")
        CA_factor = CA; CF_factor = CF; TR_factor = TR
        nf = real(nf_input, default)
     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
           end do
        end do
        ! TODO vincent_r fixed nf needs replacement  !!! for testing only, needs dynamical treatment!
        nf = real(4, default)
     end select
     do i_flv = 1, size (flv_born, 2)
        do i_part = 1, size (flv_born, 1)
           if (is_corresponding_vector (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_factor(i_part, i_flv) * nf
              virt%gamma_p(i_part, i_flv) = (67._default / 9._default &
                   - two * pi**2 / three) * CA_factor &
                   - 23._default / 9._default * TR_factor(i_part, i_flv) * nf
              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
              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_corresponding_vector (pdg_nr, nlo_corr_type)
       logical :: is_corresponding_vector
       integer, intent(in) :: pdg_nr
       type(string_t), intent(in) :: nlo_corr_type
       is_corresponding_vector = .false.
       if (nlo_corr_type == "QCD") then
          is_corresponding_vector = is_gluon (pdg_nr)
       else if (nlo_corr_type == "EW") then
          is_corresponding_vector = is_photon (pdg_nr)
       end if
     end function is_corresponding_vector
     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
   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.
 <<virtual: virtual: TBP>>=
   procedure :: evaluate => virtual_evaluate
 <<virtual: procedures>>=
   subroutine virtual_evaluate (virt, reg_data, alpha_coupling, &
          p_born, separate_alrs, 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_alrs
     real(default), dimension(:), intent(inout) :: sqme_virt
     real(default) :: s, s_o_Q2
     real(default), dimension(reg_data%n_flv_born) :: QB, BI
     integer :: i_flv, ii_flv
     QB = zero; BI = zero
     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
     do i_flv = 1, reg_data%n_flv_born
        if (separate_alrs) then
           ii_flv = i_flv
        else
           ii_flv = 1
        end if
        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(ii_flv) = sqme_virt(ii_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(ii_flv) = &
                sqme_virt(ii_flv) + alpha_coupling / twopi * (QB(i_flv) + BI(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
                 print *, 'b_ij: ', i, j, 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 .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 terms is required and
-        the integral above irrelevant.
+  \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)
-          log_xi_max = log (xi_max)
        else
           E_tot2 = sqrts**2
           xi_max = two * E_em / sqrts
-          log_xi_max = log (xi_max)
        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 (ref????).  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 soft
 momentum 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$.
 <<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.
 <<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 = q^2 / 4$.\\
 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]].
 <<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*}
   \frac{J(\Phi_n,\xi,y,\phi)}{\xi} \left[(1-y)\xi^2\mathcal{R}^\alpha(\Phi_{n+1})\right]|_{y = 1},
 \end{equation*}
 and, additionally the anti-collinear case with $y = +1$, which, however,
 is completely analogous. 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) \xi^2
              \frac{1+z^2}{1-z} \mathcal{B}.
 \end{equation*}
 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$. The factor $k_\mathrm{em}^2$ in the denonimator
 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-y)
                   = -2 E_\mathrm{beam}^2 (1-z) (1-y).
 \end{equation*}
 This leads to the cancellation of the $(1-y)$ factors and one of
 the two factors of $\xi$ in the numerator. Further rewriting to
 \begin{equation*}
   E_\mathrm{beam} E_\mathrm{rad} = E_\mathrm{beam}^2 (1-z)
 \end{equation*}
 cancels another factor of $\xi$. We thus end up with
 \begin{equation*}
   g^\alpha = \frac{4\pi\alpha_s}{E_\mathrm{beam}^2} C_F \left(1 + z^2\right)\mathcal{B},
 \end{equation*}
 which is soft-finite.
 Now what about this boosting to the other beam?
 
 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
     if (isr_mode == SQRTS_VAR .and. vector_set_is_cms (p_born, coll_sub%n_in)) then
        call vector4_write_set (p_born, show_mass = .true., &
             check_conservation = .true.)
        call msg_fatal ("Collinear subtraction, ISR: Phase space point &
             &must be in lab frame")
     end if
     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
      complex(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 (0:3, 0: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}
 <<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), intent(in) :: alpha_s, alpha_qed
     real(default) :: sqme_alr, alpha_coupling
     integer :: alr, i_con, i_res, this_emitter
     logical :: same_emitter
     do alr = 1, rsub%reg_data%n_regions
        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
        if (separate_alrs) then
           sqme(alr) = sqme(alr) + sqme_alr
        else
           sqme(1) = sqme(1) + sqme_alr
        end if
     end do
     if (debug2_active (D_SUBTRACTION)) call check_s_alpha_consistency ()
   contains
     subroutine check_s_alpha_consistency ()
       real(default) :: sum_s_alpha, sum_s_alpha_soft
       integer :: i_reg, i1, i2
       if (debug_on) call msg_debug2 (D_SUBTRACTION, "Check consistency of s_alpha: ")
       do i_reg = 1, rsub%reg_data%n_regions
          sum_s_alpha = zero; sum_s_alpha_soft = zero
          do alr = 1, rsub%reg_data%regions(i_reg)%nregions
             call rsub%reg_data%regions(i_reg)%ftuples(alr)%get (i1, i2)
             call rsub%evaluate_emitter_region_debug (i_reg, alr, i1, i2, i_phs, &
                  sum_s_alpha, sum_s_alpha_soft)
          end do
       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
 @
 <<real subtraction: real subtraction: TBP>>=
   procedure :: evaluate_emitter_region_debug &
        => real_subtraction_evaluate_emitter_region_debug
 <<real subtraction: procedures>>=
   subroutine real_subtraction_evaluate_emitter_region_debug (rsub, i_reg, alr, i1, i2, &
        i_phs, sum_s_alpha, sum_s_alpha_soft)
     class(real_subtraction_t), intent(inout) :: rsub
     integer, intent(in) :: i_reg, alr, i1, i2, i_phs
     real(default), intent(inout) :: sum_s_alpha, sum_s_alpha_soft
     type(vector4_t), dimension(:), allocatable :: p_real, p_born
     integer :: i_res
     allocate (p_real (rsub%reg_data%n_legs_real))
     allocate (p_born (rsub%reg_data%n_legs_born))
     if (rsub%reg_data%has_pseudo_isr ()) then
        p_real = rsub%real_kinematics%p_real_onshell(i_phs)%get_momenta (i_phs)
        p_born = rsub%real_kinematics%p_born_onshell%get_momenta (1)
     else
        p_real = rsub%real_kinematics%p_real_cms%get_momenta (i_phs)
        p_born = rsub%real_kinematics%p_born_cms%get_momenta (1)
     end if
     i_res = rsub%get_i_res (i_reg)
     sum_s_alpha = sum_s_alpha + rsub%reg_data%get_svalue (p_real, i_reg, i1, i2, i_res)
     associate (r => rsub%real_kinematics)
        if (i1 > rsub%sub_soft%reg_data%n_in) then
           call rsub%sub_soft%create_softvec_fsr (p_born, r%y_soft(i_phs), r%phi, &
                i1, r%xi_ref_momenta(rsub%sub_soft%i_xi_ref (i_reg, i_phs)))
        else
           call rsub%sub_soft%create_softvec_isr (r%y_soft(i_phs), r%phi)
        end if
     end associate
     sum_s_alpha_soft = sum_s_alpha_soft + rsub%reg_data%get_svalue_soft &
          (p_born, rsub%sub_soft%p_soft, i_reg, i1, i_res)
   end subroutine real_subtraction_evaluate_emitter_region_debug
 
 @ %def real_subtraction_evaluate_emitter_region_debug
 @ 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.
+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,I3)') '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_gluon (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}}\xi_{\text{cut}})) \cdot \tilde{\xi}.
 \end{equation}
+There is only one factor of $\log (\xi_{\text{max}}\xi_{\text{cut}})$ 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.
 <<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 = zero
-    sqme_remn = sqme_remn + (sqme_soft - sqme_cs) * log (xi_max * xi_cut) * xi_tilde
+    sqme_remn = (sqme_soft - sqme_cs) * log (xi_max * xi_cut) * xi_tilde
   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,I2)') '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}$.
 <<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
+    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)
-       xi_max_plus = one - isr_kinematics%x(I_PLUS)
-       xi_max_minus = one - isr_kinematics%x(I_MINUS)
+       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
-    xi_tilde = real_kinematics%xi_tilde
-    sqme_remn = log(xi_max * xi_cut) * xi_tilde * sqme_soft
-    sqme_remn = sqme_remn - log (xi_max_plus * xi_cut) * xi_tilde * sqme_cs_plus &
-                          - log (xi_max_minus * xi_cut) * xi_tilde * sqme_cs_minus
+    sqme_remn = log (xi_max * xi_cut) * xi_tilde * sqme_soft &
+              - log (xi_max_plus * xi_cut) * xi_tilde * sqme_cs_plus &
+              - log (xi_max_minus * xi_cut) * xi_tilde * sqme_cs_minus
   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 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.
 <<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) ! TODO: cms or lab?
          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 ()
       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 = 0, 3
           do nu = 0, 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(0,0,emitter,i_born) &
                - 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), 0.0001_default)) 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
     integer :: i_con
     real(default) :: pfr
     associate (sregion => rsub%reg_data%regions(alr))
       sqme_coll = zero
       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
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(em)**2, &
                     TR = 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
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(sregion%emitter)**2, &
                     TR = 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
     integer :: i_con, em_pdf
     associate (sregion => rsub%reg_data%regions(alr))
       sqme_cs = zero
       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
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(em)**2, &
                     TR = 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
                call rsub%sub_coll%set_parameters (CA = zero, &
                     CF = sregion%flst_real%charge(sregion%emitter)**2, &
                     TR = 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
 @
 <<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
     f = zero
     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
           end if
        end associate
     end do
   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 = .true.
      logical :: cut_all_sqmes = .true.
      type(string_t) :: nlo_correction_type
   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_sqmes = &
          var_list%get_lval (var_str ("?nlo_cut_all_sqmes"))
     nlo_settings%nlo_correction_type = var_list%get_sval (var_str ('$nlo_correction_type'))
   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), 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
 @ 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.
 <<dglap remnant: dglap remnant: TBP>>=
   procedure :: evaluate => dglap_remnant_evaluate
 <<dglap remnant: procedures>>=
   subroutine dglap_remnant_evaluate (dglap, alpha_s, separate_alrs, sqme_dglap)
     class(dglap_remnant_t), intent(inout) :: dglap
     real(default), intent(in) :: alpha_s
     logical, intent(in) :: separate_alrs
     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
        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
        end associate
        if (separate_alrs) then
           sqme_dglap(alr) = sqme_dglap(alr) + alpha_s / twopi * sqme_alr
        else
           sqme_dglap(1) = sqme_dglap(1) + alpha_s / twopi * sqme_alr
        end if
     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}^{gg}(z) & = 2C_A \left[z + \frac{(1-z)^2}{z} + z(1-z)^2\right], \\
   \hat{P}^{qg}(z) & = C_F (1-z) \frac{1 + (1-z)^2}{z}, \\
   \hat{P}^{gq}(z) & = T_F (1 - z - 2z(1-z)^2), \\
   \hat{P}^{qq}(z) & = C_F (1 + z^2).
 \end{align}
 <<dglap remnant: dglap remnant evaluate: procedures>>=
   function p_hat_gg (z)
     real(default) :: p_hat_gg
   <<p variables>>
     p_hat_gg = two * CA * (z + onemz**2 / z + z * onemz**2)
   end function p_hat_gg
 
   function p_hat_qg (z)
     real(default) :: p_hat_qg
   <<p variables>>
     p_hat_qg = CF * onemz / z * (one + onemz**2)
   end function p_hat_qg
 
   function p_hat_gq (z)
     real(default) :: p_hat_gq
   <<p variables>>
     p_hat_gq = TR * (onemz - two * z * onemz**2)
   end function p_hat_gq
 
   function p_hat_qq (z)
     real(default) :: p_hat_qq
     real(default), intent(in) :: z
     p_hat_qq = CF * (one + z**2)
   end function p_hat_qq
 
 @ %def p_hat_qq, p_hat_gq, p_hat_qg, p_hat_gg
 @
 \begin{align}
   \frac{\partial P^{gg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = 0, \\
   \frac{\partial P^{qg}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F z, \\
   \frac{\partial P^{gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -
 2 T_F z (1-z), \\
   \frac{\partial P^{gq}(z,\epsilon)}{\partial \epsilon}|_{\epsilon = 0} & = -C_F (1-z).\\
 \end{align}
 <<dglap remnant: dglap remnant evaluate: procedures>>=
   function p_derived_gg (z)
     real(default) :: p_derived_gg
     real(default), intent(in) :: z
     p_derived_gg = zero
   end function p_derived_gg
 
   function p_derived_qg (z)
     real(default) :: p_derived_qg
     real(default), intent(in) :: z
     p_derived_qg = -CF * z
   end function p_derived_qg
 
   function p_derived_gq (z)
     real(default) :: p_derived_gq
   <<p variables>>
     p_derived_gq = -two * TR * z * onemz
   end function p_derived_gq
 
   function p_derived_qq (z)
     real(default) :: p_derived_qq
   <<p variables>>
     p_derived_qq = -CF * onemz
   end function p_derived_qq
 
 @ %def p_derived_gg, p_derived_qg, p_derived_gq, p_derived_qq
 @
 <<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
   integer :: flv_em, flv_rad
   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)
      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
   if (is_massless_vector (flv_em) .and. is_massless_vector (flv_rad)) then
      sqme_scaled = dglap%sqme_born(i_flv_born) * dglap%sf_factors(alr, emitter)
      sqme_alr = sqme_alr + p_hat_gg(z) * factor / z * sqme_scaled * jac &
           - p_hat_gg(one) * factor_soft * dglap%sqme_born(i_flv_born) * jac &
           + p_hat_gg(one) * plus_dist_remnant * dglap%sqme_born(i_flv_born)
   else if (is_fermion (flv_em) .and. is_massless_vector (flv_rad)) then
      sqme_scaled = dglap%sqme_born(i_flv_born) * dglap%sf_factors(alr, emitter)
      sqme_alr = sqme_alr + p_hat_qq(z) * factor / z * sqme_scaled * jac &
           - p_derived_qq(z) / z * sqme_scaled * jac &
           - p_hat_qq(one) * factor_soft * dglap%sqme_born(i_flv_born) * jac &
           + p_hat_qq(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_qg(z) * factor - p_derived_qg(z)) / z * jac * &
           dglap%sqme_born(i_flv_born) * dglap%sf_factors(alr, emitter)
   else if (is_massless_vector (flv_em) .and. is_fermion (flv_rad)) then
      sqme_scaled = dglap%sqme_born(i_flv_born) * dglap%sf_factors(alr, emitter)
      sqme_alr = sqme_alr + (p_hat_gq(z) * factor - p_derived_gq(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
 @