Index: trunk/src/beams/beams.nw
===================================================================
--- trunk/src/beams/beams.nw	(revision 8865)
+++ trunk/src/beams/beams.nw	(revision 8866)
@@ -1,28273 +1,28282 @@
 %% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
 % WHIZARD code as NOWEB source: beams and beam structure
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \chapter{Beams}
 \includemodulegraph{beams}
 
 These modules implement beam configuration and beam structure, the
 latter in abstract terms.
 \begin{description}
 \item[beam\_structures]
   The [[beam_structure_t]] type is a messenger type that communicates
   the user settings to the \whizard\ core.
 \item[beams]
   Beam configuration.
 \item[sf\_aux]
   Tools for handling structure functions and splitting
 \item[sf\_mappings]
   Mapping functions, useful for structure function implementation
 \item[sf\_base]
   The abstract structure-function interaction and structure-function
   chain types.
 \end{description}
 
 These are the implementation modules, the concrete counterparts of
 [[sf_base]]:
 \begin{description}
 \item[sf\_isr]
   ISR structure function (photon radiation inclusive and resummed in
   collinear and IR regions).
 \item[sf\_epa]
   Effective Photon Approximation.
 \item[sf\_ewa]
   Effective $W$ (and $Z$) approximation.
 \item[sf\_escan]
   Energy spectrum that emulates a uniform energy scan.
 \item[sf\_gaussian]
   Gaussian beam spread
 \item[sf\_beam\_events]
   Beam-event generator that reads its input from an external file.
 \item[sf\_circe1]
   CIRCE1 beam spectra for electrons and photons.
 \item[sf\_circe2]
   CIRCE2 beam spectra for electrons and photons.
 \item[hoppet\_interface]
   Support for $b$-quark matching, addon to PDF modules.
 \item[sf\_pdf\_builtin]
   Direct support for selected hadron PDFs.
 \item[sf\_lhapdf]
   LHAPDF library support.
 \end{description}
 
 \clearpage
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Beam structure}
 
 This module stores the beam structure definition as it is declared in
 the SINDARIN script.  The structure definition is not analyzed, just
 recorded for later use.
 
 We do not capture any numerical parameters, just names of particles and
 structure functions.
 <<[[beam_structures.f90]]>>=
 <<File header>>
 
 module beam_structures
 
 <<Use kinds>>
 <<Use strings>>
   use lorentz
   use polarizations
 
 <<Standard module head>>
 
 <<Beam structures: public>>
 
 <<Beam structures: types>>
 
 <<Beam structures: interfaces>>
 
   interface
 <<Beam structures: sub interfaces>>
   end interface
 
 end module beam_structures
 @ %def beam_structures
 @
 <<[[beam_structures_sub.f90]]>>=
 <<File header>>
 
 submodule (beam_structures) beam_structures_s
 
   use io_units
   use format_defs, only: FMT_19
   use diagnostics
 
   implicit none
 
 contains
 
 <<Beam structures: procedures>>
 
 end submodule beam_structures_s
 
 @ %def beam_structures_s
 @
 \subsection{Beam structure elements}
 An entry in a beam-structure record consists of a string
 that denotes a type of structure function.
 <<Beam structures: types>>=
   type :: beam_structure_entry_t
      logical :: is_valid = .false.
      type(string_t) :: name
    contains
    <<Beam structures: beam structure entry: TBP>>
   end type beam_structure_entry_t
 
 @ %def beam_structure_entry_t
 @ Output.
 <<Beam structures: beam structure entry: TBP>>=
   procedure :: to_string => beam_structure_entry_to_string
 <<Beam structures: sub interfaces>>=
     module function beam_structure_entry_to_string (object) result (string)
       class(beam_structure_entry_t), intent(in) :: object
       type(string_t) :: string
     end function beam_structure_entry_to_string
 <<Beam structures: procedures>>=
   module function beam_structure_entry_to_string (object) result (string)
     class(beam_structure_entry_t), intent(in) :: object
     type(string_t) :: string
     if (object%is_valid) then
        string = object%name
     else
        string = "none"
     end if
   end function beam_structure_entry_to_string
 
 @ %def beam_structure_entry_to_string
 @
 A record in the beam-structure sequence denotes either a
 structure-function entry, a pair of such entries, or a pair spectrum.
 <<Beam structures: types>>=
   type :: beam_structure_record_t
      type(beam_structure_entry_t), dimension(:), allocatable :: entry
   end type beam_structure_record_t
 
 @ %def beam_structure_record_t
 @
 \subsection{Beam structure type}
 The beam-structure object contains the beam particle(s) as simple strings.
 The sequence of records indicates the structure functions by name.  No
 numerical parameters are stored.
 <<Beam structures: public>>=
   public :: beam_structure_t
 <<Beam structures: types>>=
   type :: beam_structure_t
      private
      integer :: n_beam = 0
      type(string_t), dimension(:), allocatable :: prt
      type(beam_structure_record_t), dimension(:), allocatable :: record
      type(smatrix_t), dimension(:), allocatable :: smatrix
      real(default), dimension(:), allocatable :: pol_f
      real(default), dimension(:), allocatable :: p
      real(default), dimension(:), allocatable :: theta
      real(default), dimension(:), allocatable :: phi
    contains
    <<Beam structures: beam structure: TBP>>
   end type beam_structure_t
 
 @ %def beam_structure_t
 @ The finalizer deletes all contents explicitly, so we can continue
 with an empty beam record.  (It is not needed for deallocation.)  We
 have distinct finalizers for the independent parts of the beam structure.
 <<Beam structures: beam structure: TBP>>=
   procedure :: final_sf => beam_structure_final_sf
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_final_sf (object)
       class(beam_structure_t), intent(inout) :: object
     end subroutine beam_structure_final_sf
 <<Beam structures: procedures>>=
   module subroutine beam_structure_final_sf (object)
     class(beam_structure_t), intent(inout) :: object
     if (allocated (object%prt))  deallocate (object%prt)
     if (allocated (object%record))  deallocate (object%record)
     object%n_beam = 0
   end subroutine beam_structure_final_sf
 
 @ %def beam_structure_final_sf
 @ Output.  The actual information fits in a single line, therefore we can
 provide a [[to_string]] method.  The [[show]] method also lists the
 current values of relevant global variables.
 <<Beam structures: beam structure: TBP>>=
   procedure :: write => beam_structure_write
   procedure :: to_string => beam_structure_to_string
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_write (object, unit)
       class(beam_structure_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine beam_structure_write
     module function beam_structure_to_string (object, sf_only) result (string)
       class(beam_structure_t), intent(in) :: object
       logical, intent(in), optional :: sf_only
       type(string_t) :: string
     end function beam_structure_to_string
 <<Beam structures: procedures>>=
   module subroutine beam_structure_write (object, unit)
     class(beam_structure_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A,A)")  "Beam structure: ", char (object%to_string ())
     if (allocated (object%smatrix)) then
        do i = 1, size (object%smatrix)
           write (u, "(3x,A,I0,A)") "polarization (beam ", i, "):"
           call object%smatrix(i)%write (u, indent=2)
        end do
     end if
     if (allocated (object%pol_f)) then
        write (u, "(3x,A,F10.7,:,',',F10.7)")  "polarization degree =", &
             object%pol_f
     end if
     if (allocated (object%p)) then
        write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
             ")")  "momentum =", object%p
     end if
     if (allocated (object%theta)) then
        write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
             ")")  "angle th =", object%theta
     end if
     if (allocated (object%phi)) then
        write (u, "(3x,A," // FMT_19 // ",:,','," // FMT_19 // &
             ")")  "angle ph =", object%phi
     end if
   end subroutine beam_structure_write
 
   module function beam_structure_to_string (object, sf_only) result (string)
     class(beam_structure_t), intent(in) :: object
     logical, intent(in), optional :: sf_only
     type(string_t) :: string
     integer :: i, j
     logical :: with_beams
     with_beams = .true.;  if (present (sf_only))  with_beams = .not. sf_only
     select case (object%n_beam)
     case (1)
        if (with_beams) then
           string = object%prt(1)
        else
           string = ""
        end if
     case (2)
        if (with_beams) then
           string = object%prt(1) // ", " // object%prt(2)
        else
           string = ""
        end if
        if (allocated (object%record)) then
           if (size (object%record) > 0) then
              if (with_beams)  string = string // " => "
              do i = 1, size (object%record)
                 if (i > 1)  string = string // " => "
                 do j = 1, size (object%record(i)%entry)
                    if (j > 1)  string = string // ", "
                    string = string // object%record(i)%entry(j)%to_string ()
                 end do
              end do
           end if
        end if
     case default
        string = "[any particles]"
     end select
   end function beam_structure_to_string
 
 @ %def beam_structure_write beam_structure_to_string
 @ Initializer: dimension the beam structure record.  Each array
 element denotes the number of entries for a record within the
 beam-structure sequence.  The number of entries is either one or two,
 while the number of records is unlimited.
 <<Beam structures: beam structure: TBP>>=
   procedure :: init_sf => beam_structure_init_sf
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_init_sf (beam_structure, prt, dim_array)
       class(beam_structure_t), intent(inout) :: beam_structure
       type(string_t), dimension(:), intent(in) :: prt
       integer, dimension(:), intent(in), optional :: dim_array
     end subroutine beam_structure_init_sf
 <<Beam structures: procedures>>=
   module subroutine beam_structure_init_sf (beam_structure, prt, dim_array)
     class(beam_structure_t), intent(inout) :: beam_structure
     type(string_t), dimension(:), intent(in) :: prt
     integer, dimension(:), intent(in), optional :: dim_array
     integer :: i
     call beam_structure%final_sf ()
     beam_structure%n_beam = size (prt)
     allocate (beam_structure%prt (size (prt)))
     beam_structure%prt = prt
     if (present (dim_array)) then
        allocate (beam_structure%record (size (dim_array)))
        do i = 1, size (dim_array)
           allocate (beam_structure%record(i)%entry (dim_array(i)))
        end do
     else
        allocate (beam_structure%record (0))
     end if
   end subroutine beam_structure_init_sf
 
 @ %def beam_structure_init_sf
 @ Set an entry, specified by record number and entry number.
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_sf => beam_structure_set_sf
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_set_sf (beam_structure, i, j, name)
       class(beam_structure_t), intent(inout) :: beam_structure
       integer, intent(in) :: i, j
       type(string_t), intent(in) :: name
     end subroutine beam_structure_set_sf
 <<Beam structures: procedures>>=
   module subroutine beam_structure_set_sf (beam_structure, i, j, name)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: i, j
     type(string_t), intent(in) :: name
     associate (entry => beam_structure%record(i)%entry(j))
       entry%name = name
       entry%is_valid = .true.
     end associate
   end subroutine beam_structure_set_sf
 
 @ %def beam_structure_set_sf
 @ Expand the beam-structure object.  (i) For a pair spectrum, keep the
 entry.  (ii) For a single-particle structure function written as a
 single entry, replace this by a record with two entries.
 (ii) For a record with two nontrivial entries, separate this into two
 records with one trivial entry each.
 
 To achieve this, we need a function that tells us whether an entry is
 a spectrum or a structure function.  It returns 0 for a trivial entry,
 1 for a single-particle structure function, and 2 for a two-particle
 spectrum.
 <<Beam structures: interfaces>>=
   abstract interface
      function strfun_mode_fun (name) result (n)
        import
        type(string_t), intent(in) :: name
        integer :: n
      end function strfun_mode_fun
   end interface
 
 @ %def is_spectrum_t
 @ Algorithm: (1) Mark entries as invalid where necessary.  (2) Count
 the number of entries that we will need.  (3) Expand and copy
 entries to a new record array.  (4) Replace the old array by the new one.
 <<Beam structures: beam structure: TBP>>=
   procedure :: expand => beam_structure_expand
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_expand (beam_structure, strfun_mode)
       class(beam_structure_t), intent(inout) :: beam_structure
       procedure(strfun_mode_fun) :: strfun_mode
     end subroutine beam_structure_expand
 <<Beam structures: procedures>>=
   module subroutine beam_structure_expand (beam_structure, strfun_mode)
     class(beam_structure_t), intent(inout) :: beam_structure
     procedure(strfun_mode_fun) :: strfun_mode
     type(beam_structure_record_t), dimension(:), allocatable :: new
     integer :: n_record, i, j
     if (.not. allocated (beam_structure%record))  return
     do i = 1, size (beam_structure%record)
        associate (entry => beam_structure%record(i)%entry)
          do j = 1, size (entry)
             select case (strfun_mode (entry(j)%name))
             case (0);  entry(j)%is_valid = .false.
             end select
          end do
        end associate
     end do
     n_record = 0
     do i = 1, size (beam_structure%record)
        associate (entry => beam_structure%record(i)%entry)
          select case (size (entry))
          case (1)
             if (entry(1)%is_valid) then
                select case (strfun_mode (entry(1)%name))
                case (1);  n_record = n_record + 2
                case (2);  n_record = n_record + 1
                end select
             end if
          case (2)
             do j = 1, 2
                if (entry(j)%is_valid) then
                   select case (strfun_mode (entry(j)%name))
                   case (1);  n_record = n_record + 1
                   case (2)
                      call beam_structure%write ()
                      call msg_fatal ("Pair spectrum used as &
                           &single-particle structure function")
                   end select
                end if
             end do
          end select
        end associate
     end do
     allocate (new (n_record))
     n_record = 0
     do i = 1, size (beam_structure%record)
        associate (entry => beam_structure%record(i)%entry)
          select case (size (entry))
          case (1)
             if (entry(1)%is_valid) then
                select case (strfun_mode (entry(1)%name))
                case (1)
                   n_record = n_record + 1
                   allocate (new(n_record)%entry (2))
                   new(n_record)%entry(1) = entry(1)
                   n_record = n_record + 1
                   allocate (new(n_record)%entry (2))
                   new(n_record)%entry(2) = entry(1)
                case (2)
                   n_record = n_record + 1
                   allocate (new(n_record)%entry (1))
                   new(n_record)%entry(1) = entry(1)
                end select
             end if
          case (2)
             do j = 1, 2
                if (entry(j)%is_valid) then
                   n_record = n_record + 1
                   allocate (new(n_record)%entry (2))
                   new(n_record)%entry(j) = entry(j)
                end if
             end do
          end select
        end associate
     end do
     call move_alloc (from = new, to = beam_structure%record)
   end subroutine beam_structure_expand
 
 @ %def beam_structure_expand
 @
 \subsection{Polarization}
 To record polarization, we provide an allocatable array of [[smatrix]]
 objects, sparse matrices.  The polarization structure is independent of the
 structure-function setup, they are combined only when an actual beam object is
 constructed.
 <<Beam structures: beam structure: TBP>>=
   procedure :: final_pol => beam_structure_final_pol
   procedure :: init_pol => beam_structure_init_pol
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_final_pol (beam_structure)
       class(beam_structure_t), intent(inout) :: beam_structure
     end subroutine beam_structure_final_pol
     module subroutine beam_structure_init_pol (beam_structure, n)
       class(beam_structure_t), intent(inout) :: beam_structure
       integer, intent(in) :: n
     end subroutine beam_structure_init_pol
 <<Beam structures: procedures>>=
   module subroutine beam_structure_final_pol (beam_structure)
     class(beam_structure_t), intent(inout) :: beam_structure
     if (allocated (beam_structure%smatrix))  deallocate (beam_structure%smatrix)
     if (allocated (beam_structure%pol_f))  deallocate (beam_structure%pol_f)
   end subroutine beam_structure_final_pol
 
   module subroutine beam_structure_init_pol (beam_structure, n)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: n
     if (allocated (beam_structure%smatrix))  deallocate (beam_structure%smatrix)
     allocate (beam_structure%smatrix (n))
     if (.not. allocated (beam_structure%pol_f)) &
          allocate (beam_structure%pol_f (n), source = 1._default)
   end subroutine beam_structure_init_pol
 
 @ %def beam_structure_final_pol
 @ %def beam_structure_init_pol
 @ Check if polarized beams are used.
 <<Beam structures: beam structure: TBP>>=
   procedure :: has_polarized_beams => beam_structure_has_polarized_beams
 <<Beam structures: sub interfaces>>=
     elemental module function beam_structure_has_polarized_beams &
          (beam_structure) result (pol)
       logical :: pol
       class(beam_structure_t), intent(in) :: beam_structure
     end function beam_structure_has_polarized_beams
 <<Beam structures: procedures>>=
   elemental module function beam_structure_has_polarized_beams &
        (beam_structure) result (pol)
     logical :: pol
     class(beam_structure_t), intent(in) :: beam_structure
     if (allocated (beam_structure%pol_f)) then
        pol = any (beam_structure%pol_f /= 0)
     else
        pol = .false.
     end if
   end function beam_structure_has_polarized_beams
 
 @ %def beam_structure_has_polarized_beams
 @ Directly copy the spin density matrices.
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_smatrix => beam_structure_set_smatrix
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_set_smatrix (beam_structure, i, smatrix)
       class(beam_structure_t), intent(inout) :: beam_structure
       integer, intent(in) :: i
       type(smatrix_t), intent(in) :: smatrix
     end subroutine beam_structure_set_smatrix
 <<Beam structures: procedures>>=
   module subroutine beam_structure_set_smatrix (beam_structure, i, smatrix)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: i
     type(smatrix_t), intent(in) :: smatrix
     beam_structure%smatrix(i) = smatrix
   end subroutine beam_structure_set_smatrix
 
 @ %def beam_structure_set_smatrix
 @ Initialize one of the spin density matrices manually.
 <<Beam structures: beam structure: TBP>>=
   procedure :: init_smatrix => beam_structure_init_smatrix
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_init_smatrix (beam_structure, i, n_entry)
       class(beam_structure_t), intent(inout) :: beam_structure
       integer, intent(in) :: i
       integer, intent(in) :: n_entry
     end subroutine beam_structure_init_smatrix
 <<Beam structures: procedures>>=
   module subroutine beam_structure_init_smatrix (beam_structure, i, n_entry)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: i
     integer, intent(in) :: n_entry
     call beam_structure%smatrix(i)%init (2, n_entry)
   end subroutine beam_structure_init_smatrix
 
 @ %def beam_structure_init_smatrix
 @ Set a polarization entry.
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_sentry => beam_structure_set_sentry
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_set_sentry &
          (beam_structure, i, i_entry, index, value)
       class(beam_structure_t), intent(inout) :: beam_structure
       integer, intent(in) :: i
       integer, intent(in) :: i_entry
       integer, dimension(:), intent(in) :: index
       complex(default), intent(in) :: value
     end subroutine beam_structure_set_sentry
 <<Beam structures: procedures>>=
   module subroutine beam_structure_set_sentry &
        (beam_structure, i, i_entry, index, value)
     class(beam_structure_t), intent(inout) :: beam_structure
     integer, intent(in) :: i
     integer, intent(in) :: i_entry
     integer, dimension(:), intent(in) :: index
     complex(default), intent(in) :: value
     call beam_structure%smatrix(i)%set_entry (i_entry, index, value)
   end subroutine beam_structure_set_sentry
 
 @ %def beam_structure_set_sentry
 @ Set the array of polarization fractions.
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_pol_f => beam_structure_set_pol_f
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_set_pol_f (beam_structure, f)
       class(beam_structure_t), intent(inout) :: beam_structure
       real(default), dimension(:), intent(in) :: f
     end subroutine beam_structure_set_pol_f
 <<Beam structures: procedures>>=
   module subroutine beam_structure_set_pol_f (beam_structure, f)
     class(beam_structure_t), intent(inout) :: beam_structure
     real(default), dimension(:), intent(in) :: f
     if (allocated (beam_structure%pol_f))  deallocate (beam_structure%pol_f)
     allocate (beam_structure%pol_f (size (f)), source = f)
   end subroutine beam_structure_set_pol_f
 
 @ %def beam_structure_set_pol_f
 @
 \subsection{Beam momenta}
 By default, beam momenta are deduced from the [[sqrts]] value or from
 the mass of the decaying particle, assuming a c.m.\ setup.  Here we
 set them explicitly.
 <<Beam structures: beam structure: TBP>>=
   procedure :: final_mom => beam_structure_final_mom
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_final_mom (beam_structure)
       class(beam_structure_t), intent(inout) :: beam_structure
     end subroutine beam_structure_final_mom
 <<Beam structures: procedures>>=
   module subroutine beam_structure_final_mom (beam_structure)
     class(beam_structure_t), intent(inout) :: beam_structure
     if (allocated (beam_structure%p))  deallocate (beam_structure%p)
     if (allocated (beam_structure%theta))  deallocate (beam_structure%theta)
     if (allocated (beam_structure%phi))  deallocate (beam_structure%phi)
   end subroutine beam_structure_final_mom
 
 @ %def beam_structure_final_mom
 <<Beam structures: beam structure: TBP>>=
   procedure :: set_momentum => beam_structure_set_momentum
   procedure :: set_theta => beam_structure_set_theta
   procedure :: set_phi => beam_structure_set_phi
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_set_momentum (beam_structure, p)
       class(beam_structure_t), intent(inout) :: beam_structure
       real(default), dimension(:), intent(in) :: p
     end subroutine beam_structure_set_momentum
     module subroutine beam_structure_set_theta (beam_structure, theta)
       class(beam_structure_t), intent(inout) :: beam_structure
       real(default), dimension(:), intent(in) :: theta
     end subroutine beam_structure_set_theta
     module subroutine beam_structure_set_phi (beam_structure, phi)
       class(beam_structure_t), intent(inout) :: beam_structure
       real(default), dimension(:), intent(in) :: phi
     end subroutine beam_structure_set_phi
 <<Beam structures: procedures>>=
   module subroutine beam_structure_set_momentum (beam_structure, p)
     class(beam_structure_t), intent(inout) :: beam_structure
     real(default), dimension(:), intent(in) :: p
     if (allocated (beam_structure%p))  deallocate (beam_structure%p)
     allocate (beam_structure%p (size (p)), source = p)
   end subroutine beam_structure_set_momentum
 
   module subroutine beam_structure_set_theta (beam_structure, theta)
     class(beam_structure_t), intent(inout) :: beam_structure
     real(default), dimension(:), intent(in) :: theta
     if (allocated (beam_structure%theta))  deallocate (beam_structure%theta)
     allocate (beam_structure%theta (size (theta)), source = theta)
   end subroutine beam_structure_set_theta
 
   module subroutine beam_structure_set_phi (beam_structure, phi)
     class(beam_structure_t), intent(inout) :: beam_structure
     real(default), dimension(:), intent(in) :: phi
     if (allocated (beam_structure%phi))  deallocate (beam_structure%phi)
     allocate (beam_structure%phi (size (phi)), source = phi)
   end subroutine beam_structure_set_phi
 
 @ %def beam_structure_set_momentum
 @ %def beam_structure_set_theta
 @ %def beam_structure_set_phi
 @
 \subsection{Get contents}
 Look at the incoming particles.  We may also have the case that beam
 particles are not specified, but polarization.
 <<Beam structures: beam structure: TBP>>=
   procedure :: is_set => beam_structure_is_set
   procedure :: get_n_beam => beam_structure_get_n_beam
   procedure :: get_prt => beam_structure_get_prt
 <<Beam structures: sub interfaces>>=
     module function beam_structure_is_set (beam_structure) result (flag)
       class(beam_structure_t), intent(in) :: beam_structure
       logical :: flag
     end function beam_structure_is_set
     module function beam_structure_get_n_beam (beam_structure) result (n)
       class(beam_structure_t), intent(in) :: beam_structure
       integer :: n
     end function beam_structure_get_n_beam
     module function beam_structure_get_prt (beam_structure) result (prt)
       class(beam_structure_t), intent(in) :: beam_structure
       type(string_t), dimension(:), allocatable :: prt
     end function beam_structure_get_prt
 <<Beam structures: procedures>>=
   module function beam_structure_is_set (beam_structure) result (flag)
     class(beam_structure_t), intent(in) :: beam_structure
     logical :: flag
     flag = beam_structure%n_beam > 0 .or. beam_structure%asymmetric ()
   end function beam_structure_is_set
 
   module function beam_structure_get_n_beam (beam_structure) result (n)
     class(beam_structure_t), intent(in) :: beam_structure
     integer :: n
     n = beam_structure%n_beam
   end function beam_structure_get_n_beam
 
   module function beam_structure_get_prt (beam_structure) result (prt)
     class(beam_structure_t), intent(in) :: beam_structure
     type(string_t), dimension(:), allocatable :: prt
     allocate (prt (size (beam_structure%prt)))
     prt = beam_structure%prt
   end function beam_structure_get_prt
 
 @ %def beam_structure_is_set
 @ %def beam_structure_get_n_beam
 @ %def beam_structure_get_prt
 @
 Return the number of records.
 <<Beam structures: beam structure: TBP>>=
   procedure :: get_n_record => beam_structure_get_n_record
 <<Beam structures: sub interfaces>>=
     module function beam_structure_get_n_record (beam_structure) result (n)
       class(beam_structure_t), intent(in) :: beam_structure
       integer :: n
     end function beam_structure_get_n_record
 <<Beam structures: procedures>>=
   module function beam_structure_get_n_record (beam_structure) result (n)
     class(beam_structure_t), intent(in) :: beam_structure
     integer :: n
     if (allocated (beam_structure%record)) then
        n = size (beam_structure%record)
     else
        n = 0
     end if
   end function beam_structure_get_n_record
 
 @ %def beam_structure_get_n_record
 @ Return an array consisting of the beam indices affected by the valid
 entries within a record.  After expansion, there should be exactly one
 valid entry per record.
 <<Beam structures: beam structure: TBP>>=
   procedure :: get_i_entry => beam_structure_get_i_entry
 <<Beam structures: sub interfaces>>=
     module function beam_structure_get_i_entry &
          (beam_structure, i) result (i_entry)
       class(beam_structure_t), intent(in) :: beam_structure
       integer, intent(in) :: i
       integer, dimension(:), allocatable :: i_entry
     end function beam_structure_get_i_entry
 <<Beam structures: procedures>>=
   module function beam_structure_get_i_entry &
        (beam_structure, i) result (i_entry)
     class(beam_structure_t), intent(in) :: beam_structure
     integer, intent(in) :: i
     integer, dimension(:), allocatable :: i_entry
     associate (record => beam_structure%record(i))
       select case (size (record%entry))
       case (1)
          if (record%entry(1)%is_valid) then
             allocate (i_entry (2), source = [1, 2])
          else
             allocate (i_entry (0))
          end if
       case (2)
          if (all (record%entry%is_valid)) then
             allocate (i_entry (2), source = [1, 2])
          else if (record%entry(1)%is_valid) then
             allocate (i_entry (1), source = [1])
          else if (record%entry(2)%is_valid) then
             allocate (i_entry (1), source = [2])
          else
             allocate (i_entry (0))
          end if
       end select
     end associate
   end function beam_structure_get_i_entry
 
 @ %def beam_structure_get_i_entry
 @ Return the name of the first valid entry within a record.  After
 expansion, there should be exactly one valid entry per record.
 <<Beam structures: beam structure: TBP>>=
   procedure :: get_name => beam_structure_get_name
 <<Beam structures: sub interfaces>>=
     module function beam_structure_get_name (beam_structure, i) result (name)
       type(string_t) :: name
       class(beam_structure_t), intent(in) :: beam_structure
       integer, intent(in) :: i
     end function beam_structure_get_name
 <<Beam structures: procedures>>=
   module function beam_structure_get_name (beam_structure, i) result (name)
     type(string_t) :: name
     class(beam_structure_t), intent(in) :: beam_structure
     integer, intent(in) :: i
     associate (record => beam_structure%record(i))
       if (record%entry(1)%is_valid) then
          name = record%entry(1)%name
       else if (size (record%entry) == 2) then
          name = record%entry(2)%name
       end if
     end associate
   end function beam_structure_get_name
 
 @ %def beam_structure_get_name
 @
 <<Beam structures: beam structure: TBP>>=
   procedure :: has_pdf => beam_structure_has_pdf
 <<Beam structures: sub interfaces>>=
     module function beam_structure_has_pdf (beam_structure) result (has_pdf)
       logical :: has_pdf
       class(beam_structure_t), intent(in) :: beam_structure
     end function beam_structure_has_pdf
 <<Beam structures: procedures>>=
   module function beam_structure_has_pdf (beam_structure) result (has_pdf)
     logical :: has_pdf
     class(beam_structure_t), intent(in) :: beam_structure
     integer :: i
     type(string_t) :: name
     has_pdf = .false.
     do i = 1, beam_structure%get_n_record ()
        name = beam_structure%get_name (i)
        has_pdf = has_pdf .or. name == var_str ("pdf_builtin") .or. name == var_str ("lhapdf")
     end do
   end function beam_structure_has_pdf
 
 @ %def beam_structure_has_pdf
 @ Return true if the beam structure contains a particular structure
 function identifier (such as [[lhapdf]], [[isr]], etc.)
 <<Beam structures: beam structure: TBP>>=
   procedure :: contains => beam_structure_contains
 <<Beam structures: sub interfaces>>=
     module function beam_structure_contains (beam_structure, name) result (flag)
       class(beam_structure_t), intent(in) :: beam_structure
       character(*), intent(in) :: name
       logical :: flag
     end function beam_structure_contains
 <<Beam structures: procedures>>=
   module function beam_structure_contains (beam_structure, name) result (flag)
     class(beam_structure_t), intent(in) :: beam_structure
     character(*), intent(in) :: name
     logical :: flag
     integer :: i, j
     flag = .false.
     if (allocated (beam_structure%record)) then
        do i = 1, size (beam_structure%record)
           do j = 1, size (beam_structure%record(i)%entry)
              flag = beam_structure%record(i)%entry(j)%name == name
              if (flag)  return
           end do
        end do
     end if
   end function beam_structure_contains
 
 @ %def beam_structure_contains
 @ Return polarization data.
 <<Beam structures: beam structure: TBP>>=
   procedure :: polarized => beam_structure_polarized
   procedure :: get_smatrix => beam_structure_get_smatrix
   procedure :: get_pol_f => beam_structure_get_pol_f
   procedure :: asymmetric => beam_structure_asymmetric
 <<Beam structures: sub interfaces>>=
     module function beam_structure_polarized (beam_structure) result (flag)
       class(beam_structure_t), intent(in) :: beam_structure
       logical :: flag
     end function beam_structure_polarized
     module function beam_structure_get_smatrix (beam_structure) result (smatrix)
       class(beam_structure_t), intent(in) :: beam_structure
       type(smatrix_t), dimension(:), allocatable :: smatrix
     end function beam_structure_get_smatrix
     module function beam_structure_get_pol_f (beam_structure) result (pol_f)
       class(beam_structure_t), intent(in) :: beam_structure
       real(default), dimension(:), allocatable :: pol_f
     end function beam_structure_get_pol_f
     module function beam_structure_asymmetric (beam_structure) result (flag)
       class(beam_structure_t), intent(in) :: beam_structure
       logical :: flag
     end function beam_structure_asymmetric
 <<Beam structures: procedures>>=
   module function beam_structure_polarized (beam_structure) result (flag)
     class(beam_structure_t), intent(in) :: beam_structure
     logical :: flag
     flag = allocated (beam_structure%smatrix)
   end function beam_structure_polarized
 
   module function beam_structure_get_smatrix (beam_structure) result (smatrix)
     class(beam_structure_t), intent(in) :: beam_structure
     type(smatrix_t), dimension(:), allocatable :: smatrix
     allocate (smatrix (size (beam_structure%smatrix)), &
          source = beam_structure%smatrix)
   end function beam_structure_get_smatrix
 
   module function beam_structure_get_pol_f (beam_structure) result (pol_f)
     class(beam_structure_t), intent(in) :: beam_structure
     real(default), dimension(:), allocatable :: pol_f
     allocate (pol_f (size (beam_structure%pol_f)), &
          source = beam_structure%pol_f)
   end function beam_structure_get_pol_f
 
   module function beam_structure_asymmetric (beam_structure) result (flag)
     class(beam_structure_t), intent(in) :: beam_structure
     logical :: flag
     flag = allocated (beam_structure%p) &
          .or. allocated (beam_structure%theta) &
          .or. allocated (beam_structure%phi)
   end function beam_structure_asymmetric
 
 @ %def beam_structure_polarized
 @ %def beam_structure_get_smatrix
 @ %def beam_structure_get_pol_f
 @ %def beam_structure_asymmetric
 @ Return the beam momenta (the space part, i.e., three-momenta).  This
 is meaningful only if momenta and, optionally, angles have been set.
 <<Beam structures: beam structure: TBP>>=
   procedure :: get_momenta => beam_structure_get_momenta
 <<Beam structures: sub interfaces>>=
     module function beam_structure_get_momenta (beam_structure) result (p)
       class(beam_structure_t), intent(in) :: beam_structure
       type(vector3_t), dimension(:), allocatable :: p
     end function beam_structure_get_momenta
 <<Beam structures: procedures>>=
   module function beam_structure_get_momenta (beam_structure) result (p)
     class(beam_structure_t), intent(in) :: beam_structure
     type(vector3_t), dimension(:), allocatable :: p
     real(default), dimension(:), allocatable :: theta, phi
     integer :: n, i
     if (allocated (beam_structure%p)) then
        n = size (beam_structure%p)
        if (allocated (beam_structure%theta)) then
           if (size (beam_structure%theta) == n) then
              allocate (theta (n), source = beam_structure%theta)
           else
              call msg_fatal ("Beam structure: mismatch in momentum vs. &
                   &angle theta specification")
           end if
        else
           allocate (theta (n), source = 0._default)
        end if
        if (allocated (beam_structure%phi)) then
           if (size (beam_structure%phi) == n) then
              allocate (phi (n), source = beam_structure%phi)
           else
              call msg_fatal ("Beam structure: mismatch in momentum vs. &
                   &angle phi specification")
           end if
        else
           allocate (phi (n), source = 0._default)
        end if
        allocate (p (n))
        do i = 1, n
           p(i) = beam_structure%p(i) * vector3_moving ([ &
                sin (theta(i)) * cos (phi(i)), &
                sin (theta(i)) * sin (phi(i)), &
                cos (theta(i))])
        end do
        if (n == 2)  p(2) = - p(2)
     else
        call msg_fatal ("Beam structure: angle theta/phi specified but &
             &momentum/a p undefined")
     end if
   end function beam_structure_get_momenta
 
 @ %def beam_structure_get_momenta
 @ Check for a complete beam structure.  The [[applies]] flag tells if
 the beam structure should actually be used for a process with the
 given [[n_in]] number of incoming particles.
 
 It set if the beam structure matches the process as either decay or
 scattering.  It is unset if beam structure references a scattering
 setup but the process is a decay.  It is also unset if the beam
 structure itself is empty.
 
 If the beam structure cannot be used, terminate with fatal error.
 <<Beam structures: beam structure: TBP>>=
   procedure :: check_against_n_in => beam_structure_check_against_n_in
 <<Beam structures: sub interfaces>>=
     module subroutine beam_structure_check_against_n_in &
          (beam_structure, n_in, applies)
       class(beam_structure_t), intent(in) :: beam_structure
       integer, intent(in) :: n_in
       logical, intent(out) :: applies
     end subroutine beam_structure_check_against_n_in
 <<Beam structures: procedures>>=
   module subroutine beam_structure_check_against_n_in &
        (beam_structure, n_in, applies)
     class(beam_structure_t), intent(in) :: beam_structure
     integer, intent(in) :: n_in
     logical, intent(out) :: applies
     if (beam_structure%is_set ()) then
        if (n_in == beam_structure%get_n_beam ()) then
           applies = .true.
        else if (beam_structure%get_n_beam () == 0) then
           call msg_fatal &
                ("Asymmetric beams: missing beam particle specification")
           applies = .false.
        else
           call msg_fatal &
                ("Mismatch of process and beam setup (scattering/decay)")
           applies = .false.
        end if
     else
        applies = .false.
     end if
   end subroutine beam_structure_check_against_n_in
 
 @ %def beam_structure_check_against_n_in
 @
 \subsection{Unit Tests}
 Test module, followed by the corresponding implementation module.
 <<[[beam_structures_ut.f90]]>>=
 <<File header>>
 
 module beam_structures_ut
   use unit_tests
   use beam_structures_uti
 
 <<Standard module head>>
 
 <<Beam structures: public test>>
 
 contains
 
 <<Beam structures: test driver>>
 
 end module beam_structures_ut
 @ %def beam_structures_ut
 @
 <<[[beam_structures_uti.f90]]>>=
 <<File header>>
 
 module beam_structures_uti
 
 <<Use kinds>>
 <<Use strings>>
 
   use beam_structures
 
 <<Standard module head>>
 
 <<Beam structures: test declarations>>
 
 contains
 
 <<Beam structures: tests>>
 
 <<Beam structures: test auxiliary>>
 
 end module beam_structures_uti
 @ %def beam_structures_ut
 @ API: driver for the unit tests below.
 <<Beam structures: public test>>=
   public :: beam_structures_test
 <<Beam structures: test driver>>=
   subroutine beam_structures_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Beam structures: execute tests>>
 end subroutine beam_structures_test
 
 @ %def beam_structures_tests
 @
 \subsubsection{Empty structure}
 <<Beam structures: execute tests>>=
   call test (beam_structures_1, "beam_structures_1", &
        "empty beam structure record", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_1
 <<Beam structures: tests>>=
   subroutine beam_structures_1 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
 
     write (u, "(A)")  "* Test output: beam_structures_1"
     write (u, "(A)")  "*   Purpose: display empty beam structure record"
     write (u, "(A)")
 
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_1"
 
   end subroutine beam_structures_1
 
 @ %def beam_structures_1
 @
 \subsubsection{Nontrivial configurations}
 <<Beam structures: execute tests>>=
   call test (beam_structures_2, "beam_structures_2", &
        "beam structure records", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_2
 <<Beam structures: tests>>=
   subroutine beam_structures_2 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     integer, dimension(0) :: empty_array
     type(string_t) :: s
 
     write (u, "(A)")  "* Test output: beam_structures_2"
     write (u, "(A)")  "*   Purpose: setup beam structure records"
     write (u, "(A)")
 
     s = "s"
 
     call beam_structure%init_sf ([s], empty_array)
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [2])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%set_sf (1, 2, var_str ("b"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [2, 1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%set_sf (1, 2, var_str ("b"))
     call beam_structure%set_sf (2, 1, var_str ("c"))
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_2"
 
   end subroutine beam_structures_2
 
 @ %def beam_structures_2
 @
 \subsubsection{Expansion}
 Provide a function that tells, for the dummy structure function names
 used here, whether they are considered a two-particle spectrum or a
 single-particle structure function:
 <<Beam structures: test auxiliary>>=
   function test_strfun_mode (name) result (n)
     type(string_t), intent(in) :: name
     integer :: n
     select case (char (name))
     case ("a");  n = 2
     case ("b");  n = 1
     case default;  n = 0
     end select
   end function test_strfun_mode
 
 @ %def test_ist_pair_spectrum
 @
 <<Beam structures: execute tests>>=
   call test (beam_structures_3, "beam_structures_3", &
        "beam structure expansion", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_3
 <<Beam structures: tests>>=
   subroutine beam_structures_3 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     type(string_t) :: s
 
     write (u, "(A)")  "* Test output: beam_structures_3"
     write (u, "(A)")  "*   Purpose: expand beam structure records"
     write (u, "(A)")
 
     s = "s"
 
     write (u, "(A)")  "* Pair spectrum (keep as-is)"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%expand (test_strfun_mode)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure function pair (expand)"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [2])
     call beam_structure%set_sf (1, 1, var_str ("b"))
     call beam_structure%set_sf (1, 2, var_str ("b"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%expand (test_strfun_mode)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure function (separate and expand)"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_sf (1, 1, var_str ("b"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%expand (test_strfun_mode)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Combination"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1, 1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%set_sf (2, 1, var_str ("b"))
     call beam_structure%write (u)
 
     write (u, "(A)")
 
     call beam_structure%expand (test_strfun_mode)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_3"
 
   end subroutine beam_structures_3
 
 @ %def beam_structures_3
 @
 \subsubsection{Public methods}
 Check the methods that can be called to get the beam-structure
 contents.
 <<Beam structures: execute tests>>=
   call test (beam_structures_4, "beam_structures_4", &
        "beam structure contents", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_4
 <<Beam structures: tests>>=
   subroutine beam_structures_4 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     type(string_t) :: s
     type(string_t), dimension(2) :: prt
     integer :: i
 
     write (u, "(A)")  "* Test output: beam_structures_4"
     write (u, "(A)")  "*   Purpose: check the API"
     write (u, "(A)")
 
     s = "s"
 
     write (u, "(A)")  "* Structure-function combination"
     write (u, "(A)")
 
     call beam_structure%init_sf ([s, s], [1, 2, 2])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%set_sf (2, 1, var_str ("b"))
     call beam_structure%set_sf (3, 2, var_str ("c"))
     call beam_structure%write (u)
 
     write (u, *)
     write (u, "(1x,A,I0)")  "n_beam = ", beam_structure%get_n_beam ()
     prt = beam_structure%get_prt ()
     write (u, "(1x,A,2(1x,A))")  "prt =", char (prt(1)), char (prt(2))
 
     write (u, *)
     write (u, "(1x,A,I0)")  "n_record = ", beam_structure%get_n_record ()
 
     do i = 1, 3
        write (u, "(A)")
        write (u, "(1x,A,I0,A,A)")  "name(", i, ") = ", &
             char (beam_structure%get_name (i))
        write (u, "(1x,A,I0,A,2(1x,I0))")  "i_entry(", i, ") =", &
             beam_structure%get_i_entry (i)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_4"
 
   end subroutine beam_structures_4
 
 @ %def beam_structures_4
 @
 \subsubsection{Polarization}
 The polarization properties are independent from the structure-function setup.
 <<Beam structures: execute tests>>=
   call test (beam_structures_5, "beam_structures_5", &
        "polarization", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_5
 <<Beam structures: tests>>=
   subroutine beam_structures_5 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     integer, dimension(0) :: empty_array
     type(string_t) :: s
 
     write (u, "(A)")  "* Test output: beam_structures_5"
     write (u, "(A)")  "*   Purpose: setup polarization in beam structure records"
     write (u, "(A)")
 
     s = "s"
 
     call beam_structure%init_sf ([s], empty_array)
     call beam_structure%init_pol (1)
     call beam_structure%init_smatrix (1, 1)
     call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default))
     call beam_structure%set_pol_f ([0.5_default])
     call beam_structure%write (u)
 
 
     write (u, "(A)")
     call beam_structure%final_sf ()
     call beam_structure%final_pol ()
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_sf (1, 1, var_str ("a"))
     call beam_structure%init_pol (2)
     call beam_structure%init_smatrix (1, 2)
     call beam_structure%set_sentry (1, 1, [-1,1], (0.5_default,-0.5_default))
     call beam_structure%set_sentry (1, 2, [ 1,1], (1._default, 0._default))
     call beam_structure%init_smatrix (2, 0)
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_5"
 
   end subroutine beam_structures_5
 
 @ %def beam_structures_5
 @
 \subsubsection{Momenta}
 The momenta are independent from the structure-function setup.
 <<Beam structures: execute tests>>=
   call test (beam_structures_6, "beam_structures_6", &
        "momenta", &
        u, results)
 <<Beam structures: test declarations>>=
   public :: beam_structures_6
 <<Beam structures: tests>>=
   subroutine beam_structures_6 (u)
     integer, intent(in) :: u
     type(beam_structure_t) :: beam_structure
     integer, dimension(0) :: empty_array
     type(string_t) :: s
 
     write (u, "(A)")  "* Test output: beam_structures_6"
     write (u, "(A)")  "*   Purpose: setup momenta in beam structure records"
     write (u, "(A)")
 
     s = "s"
 
     call beam_structure%init_sf ([s], empty_array)
     call beam_structure%set_momentum ([500._default])
     call beam_structure%write (u)
 
 
     write (u, "(A)")
     call beam_structure%final_sf ()
     call beam_structure%final_mom ()
 
     call beam_structure%init_sf ([s, s], [1])
     call beam_structure%set_momentum ([500._default, 700._default])
     call beam_structure%set_theta ([0._default, 0.1_default])
     call beam_structure%set_phi ([0._default, 1.51_default])
     call beam_structure%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_structures_6"
 
   end subroutine beam_structures_6
 
 @ %def beam_structures_6
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Beams for collisions and decays}
 
 <<[[beams.f90]]>>=
 <<File header>>
 
 module beams
 
 <<Use kinds>>
 <<Use strings>>
   use lorentz
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use interactions
   use polarizations
   use beam_structures
 
 <<Standard module head>>
 
 <<Beams: public>>
 
 <<Beams: types>>
 
 <<Beams: interfaces>>
 
   interface
 <<Beams: sub interfaces>>
   end interface
 
 end module beams
 @ %def beams
 @
 <<[[beams_sub.f90]]>>=
 <<File header>>
 
 submodule (beams) beams_s
 
   use io_units
   use format_defs, only: FMT_19
   use numeric_utils
   use diagnostics
   use md5
 
   implicit none
 
 contains
 
 <<Beams: procedures>>
 
 end submodule beams_s
 
 @ %def beams_s
 @
 \subsection{Beam data}
 The beam data type contains beam data for one or two beams, depending
 on whether we are dealing with beam collisions or particle decay.  In
 addition, it holds the c.m.\ energy [[sqrts]], the Lorentz
 transformation [[L]] that transforms the c.m.\ system into the lab
 system, and the pair of c.m.\ momenta.
 <<Beams: public>>=
   public :: beam_data_t
 <<Beams: types>>=
   type :: beam_data_t
      logical :: initialized = .false.
      integer :: n = 0
      type(flavor_t), dimension(:), allocatable :: flv
      real(default), dimension(:), allocatable :: mass
      type(pmatrix_t), dimension(:), allocatable :: pmatrix
      logical :: lab_is_cm = .true.
      type(vector4_t), dimension(:), allocatable :: p_cm
      type(vector4_t), dimension(:), allocatable :: p
      type(lorentz_transformation_t), allocatable  :: L_cm_to_lab
      real(default) :: sqrts = 0
      character(32) :: md5sum = ""
    contains
    <<Beams: beam data: TBP>>
   end type beam_data_t
 
 @ %def beam_data_t
 @ Generic initializer.  This is called by the specific initializers
 below.  Initialize either for decay or for collision.
 <<Beams: procedures>>=
   subroutine beam_data_init (beam_data, n)
     type(beam_data_t), intent(out) :: beam_data
     integer, intent(in) :: n
     beam_data%n = n
     allocate (beam_data%flv (n))
     allocate (beam_data%mass (n))
     allocate (beam_data%pmatrix (n))
     allocate (beam_data%p_cm (n))
     allocate (beam_data%p (n))
     beam_data%initialized = .true.
   end subroutine beam_data_init
 
 @ %def beam_data_init
 @ Finalizer: needed for the polarization components of the beams.
 <<Beams: beam data: TBP>>=
   procedure :: final => beam_data_final
 <<Beams: sub interfaces>>=
     module subroutine beam_data_final (beam_data)
       class(beam_data_t), intent(inout) :: beam_data
     end subroutine beam_data_final
 <<Beams: procedures>>=
   module subroutine beam_data_final (beam_data)
     class(beam_data_t), intent(inout) :: beam_data
     beam_data%initialized = .false.
   end subroutine beam_data_final
 
 @ %def beam_data_final
 @ The verbose (default) version is for debugging.  The short version
 is for screen output in the UI.
 <<Beams: beam data: TBP>>=
   procedure :: write => beam_data_write
 <<Beams: sub interfaces>>=
     module subroutine beam_data_write (beam_data, unit, verbose, write_md5sum)
       class(beam_data_t), intent(in) :: beam_data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose, write_md5sum
     end subroutine beam_data_write
 <<Beams: procedures>>=
   module subroutine beam_data_write (beam_data, unit, verbose, write_md5sum)
     class(beam_data_t), intent(in) :: beam_data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose, write_md5sum
     integer :: prt_name_len
     logical :: verb, write_md5
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     verb = .false.;  if (present (verbose))  verb = verbose
     write_md5 = verb;  if (present (write_md5sum)) write_md5 = write_md5sum
     if (.not. beam_data%initialized) then
        write (u, "(1x,A)") "Beam data: [undefined]"
        return
     end if
     prt_name_len = maxval (len (beam_data%flv%get_name ()))
     select case (beam_data%n)
     case (1)
        write (u, "(1x,A)") "Beam data (decay):"
        if (verb) then
           call write_prt (1)
           call beam_data%pmatrix(1)%write (u)
           write (u, *) "R.f. momentum:"
           call vector4_write (beam_data%p_cm(1), u)
           write (u, *) "Lab momentum:"
           call vector4_write (beam_data%p(1), u)
        else
           call write_prt (1)
        end if
     case (2)
        write (u, "(1x,A)") "Beam data (collision):"
        if (verb) then
           call write_prt (1)
           call beam_data%pmatrix(1)%write (u)
           call write_prt (2)
           call beam_data%pmatrix(2)%write (u)
           call write_sqrts
           write (u, *) "C.m. momenta:"
           call vector4_write (beam_data%p_cm(1), u)
           call vector4_write (beam_data%p_cm(2), u)
           write (u, *) "Lab momenta:"
           call vector4_write (beam_data%p(1), u)
           call vector4_write (beam_data%p(2), u)
        else
           call write_prt (1)
           call write_prt (2)
           call write_sqrts
        end if
     end select
     if (allocated (beam_data%L_cm_to_lab)) then
        if (verb) then
           call lorentz_transformation_write (beam_data%L_cm_to_lab, u)
        else
           write (u, "(1x,A)")  "Beam structure: lab and c.m. frame differ"
        end if
     end if
     if (write_md5) then
        write (u, *) "MD5 sum: ", beam_data%md5sum
     end if
   contains
     subroutine write_sqrts
       character(80) :: sqrts_str
       write (sqrts_str, "(" // FMT_19 // ")")  beam_data%sqrts
       write (u, "(3x,A)")  "sqrts = " // trim (adjustl (sqrts_str)) // " GeV"
     end subroutine write_sqrts
     subroutine write_prt (i)
       integer, intent(in) :: i
       character(80) :: name_str, mass_str
       write (name_str, "(A)")  char (beam_data%flv(i)%get_name ())
       write (mass_str, "(ES13.7)")  beam_data%mass(i)
       write (u, "(3x,A)", advance="no") &
            name_str(:prt_name_len) // "  (mass = " &
            // trim (adjustl (mass_str)) // " GeV)"
       if (beam_data%pmatrix(i)%is_polarized ()) then
          write (u, "(2x,A)")  "polarized"
       else
          write (u, *)
       end if
     end subroutine write_prt
   end subroutine beam_data_write
 
 @ %def beam_data_write
 @ Return initialization status:
 <<Beams: beam data: TBP>>=
   procedure :: are_valid => beam_data_are_valid
 <<Beams: sub interfaces>>=
     module function beam_data_are_valid (beam_data) result (flag)
       class(beam_data_t), intent(in) :: beam_data
       logical :: flag
     end function beam_data_are_valid
 <<Beams: procedures>>=
   module function beam_data_are_valid (beam_data) result (flag)
     class(beam_data_t), intent(in) :: beam_data
     logical :: flag
     flag = beam_data%initialized
   end function beam_data_are_valid
 
 @ %def beam_data_are_valid
 @ Check whether beam data agree with the current values of relevant
 parameters.
 <<Beams: beam data: TBP>>=
   procedure :: check_scattering => beam_data_check_scattering
 <<Beams: sub interfaces>>=
     module subroutine beam_data_check_scattering (beam_data, sqrts)
       class(beam_data_t), intent(in) :: beam_data
       real(default), intent(in), optional :: sqrts
     end subroutine beam_data_check_scattering
 <<Beams: procedures>>=
   module subroutine beam_data_check_scattering (beam_data, sqrts)
     class(beam_data_t), intent(in) :: beam_data
     real(default), intent(in), optional :: sqrts
     if (beam_data_are_valid (beam_data)) then
        if (present (sqrts)) then
           if (.not. nearly_equal (sqrts, beam_data%sqrts)) then
              call msg_error ("Current setting of sqrts is inconsistent " &
                   // "with beam setup (ignored).")
           end if
        end if
     else
        call msg_bug ("Beam setup: invalid beam data")
     end if
   end subroutine beam_data_check_scattering
 
 @ %def beam_data_check_scattering
 @ Return the number of beams (1 for decays, 2 for collisions).
 <<Beams: beam data: TBP>>=
   procedure :: get_n_in => beam_data_get_n_in
 <<Beams: sub interfaces>>=
     module function beam_data_get_n_in (beam_data) result (n_in)
       class(beam_data_t), intent(in) :: beam_data
       integer :: n_in
     end function beam_data_get_n_in
 <<Beams: procedures>>=
   module function beam_data_get_n_in (beam_data) result (n_in)
     class(beam_data_t), intent(in) :: beam_data
     integer :: n_in
     n_in = beam_data%n
   end function beam_data_get_n_in
 
 @ %def beam_data_get_n_in
 @ Return the beam flavor
 <<Beams: beam data: TBP>>=
   procedure :: get_flavor => beam_data_get_flavor
 <<Beams: sub interfaces>>=
     module function beam_data_get_flavor (beam_data) result (flv)
       class(beam_data_t), intent(in) :: beam_data
       type(flavor_t), dimension(:), allocatable :: flv
     end function beam_data_get_flavor
 <<Beams: procedures>>=
   module function beam_data_get_flavor (beam_data) result (flv)
     class(beam_data_t), intent(in) :: beam_data
     type(flavor_t), dimension(:), allocatable :: flv
     allocate (flv (beam_data%n))
     flv = beam_data%flv
   end function beam_data_get_flavor
 
 @ %def beam_data_get_flavor
 @ Return the beam energies
 <<Beams: beam data: TBP>>=
   procedure :: get_energy => beam_data_get_energy
 <<Beams: sub interfaces>>=
     module function beam_data_get_energy (beam_data) result (e)
       class(beam_data_t), intent(in) :: beam_data
       real(default), dimension(:), allocatable :: e
     end function beam_data_get_energy
 <<Beams: procedures>>=
   module function beam_data_get_energy (beam_data) result (e)
     class(beam_data_t), intent(in) :: beam_data
     real(default), dimension(:), allocatable :: e
     integer :: i
     allocate (e (beam_data%n))
     if (beam_data%initialized) then
        do i = 1, beam_data%n
           e(i) = energy (beam_data%p(i))
        end do
     else
        e = 0
     end if
   end function beam_data_get_energy
 
 @ %def beam_data_get_energy
 @ Return the c.m.\ energy.
 <<Beams: beam data: TBP>>=
   procedure :: get_sqrts => beam_data_get_sqrts
 <<Beams: sub interfaces>>=
     module function beam_data_get_sqrts (beam_data) result (sqrts)
       class(beam_data_t), intent(in) :: beam_data
       real(default) :: sqrts
     end function beam_data_get_sqrts
 <<Beams: procedures>>=
   module function beam_data_get_sqrts (beam_data) result (sqrts)
     class(beam_data_t), intent(in) :: beam_data
     real(default) :: sqrts
     sqrts = beam_data%sqrts
   end function beam_data_get_sqrts
 
 @ %def beam_data_get_sqrts
 @ Return the polarization in case it is just two degrees
 <<Beams: beam data: TBP>>=
   procedure :: get_polarization => beam_data_get_polarization
 <<Beams: sub interfaces>>=
     module function beam_data_get_polarization (beam_data) result (pol)
       class(beam_data_t), intent(in) :: beam_data
       real(default), dimension(beam_data%n) :: pol
     end function beam_data_get_polarization
 <<Beams: procedures>>=
   module function beam_data_get_polarization (beam_data) result (pol)
     class(beam_data_t), intent(in) :: beam_data
     real(default), dimension(beam_data%n) :: pol
     pol = beam_data%pmatrix%get_simple_pol ()
   end function beam_data_get_polarization
 
 @ %def beam_data_get_polarization
 @
 <<Beams: beam data: TBP>>=
   procedure :: get_helicity_state_matrix => beam_data_get_helicity_state_matrix
 <<Beams: sub interfaces>>=
     module function beam_data_get_helicity_state_matrix &
          (beam_data) result (state_hel)
       type(state_matrix_t) :: state_hel
       class(beam_data_t), intent(in) :: beam_data
     end function beam_data_get_helicity_state_matrix
 <<Beams: procedures>>=
   module function beam_data_get_helicity_state_matrix &
        (beam_data) result (state_hel)
     type(state_matrix_t) :: state_hel
     class(beam_data_t), intent(in) :: beam_data
     type(polarization_t), dimension(:), allocatable :: pol
     integer :: i
     allocate (pol (beam_data%n))
     do i = 1, beam_data%n
        call pol(i)%init_pmatrix (beam_data%pmatrix(i))
     end do
     call combine_polarization_states (pol, state_hel)
   end function beam_data_get_helicity_state_matrix
 
 @ %def beam_data_get_helicity_state_matrix
 @
 <<Beams: beam data: TBP>>=
   procedure :: is_initialized => beam_data_is_initialized
 <<Beams: sub interfaces>>=
     module function beam_data_is_initialized (beam_data) result (initialized)
       logical :: initialized
       class(beam_data_t), intent(in) :: beam_data
     end function beam_data_is_initialized
 <<Beams: procedures>>=
   module function beam_data_is_initialized (beam_data) result (initialized)
     logical :: initialized
     class(beam_data_t), intent(in) :: beam_data
     initialized = any (beam_data%pmatrix%exists ())
   end function beam_data_is_initialized
 
 @ %def beam_data_is_initialized
 @ Return a MD5 checksum for beam data.  If no checksum is present
 (because beams have not been initialized), compute the checksum of the
 sqrts value.
 <<Beams: beam data: TBP>>=
   procedure :: get_md5sum => beam_data_get_md5sum
 <<Beams: sub interfaces>>=
     module function beam_data_get_md5sum &
          (beam_data, sqrts) result (md5sum_beams)
       class(beam_data_t), intent(in) :: beam_data
       real(default), intent(in) :: sqrts
       character(32) :: md5sum_beams
     end function beam_data_get_md5sum
 <<Beams: procedures>>=
   module function beam_data_get_md5sum &
        (beam_data, sqrts) result (md5sum_beams)
     class(beam_data_t), intent(in) :: beam_data
     real(default), intent(in) :: sqrts
     character(32) :: md5sum_beams
     character(80) :: buffer
     if (beam_data%md5sum /= "") then
        md5sum_beams = beam_data%md5sum
     else
        write (buffer, *)  sqrts
        md5sum_beams = md5sum (buffer)
     end if
   end function beam_data_get_md5sum
 
 @ %def beam_data_get_md5sum
 @
 \subsection{Initializers: beam structure}
 Initialize the beam data object from a beam structure object, given energy and
 model.
 <<Beams: beam data: TBP>>=
   procedure :: init_structure => beam_data_init_structure
 <<Beams: sub interfaces>>=
     module subroutine beam_data_init_structure &
          (beam_data, structure, sqrts, model, decay_rest_frame)
       class(beam_data_t), intent(out) :: beam_data
       type(beam_structure_t), intent(in) :: structure
       real(default), intent(in) :: sqrts
       class(model_data_t), intent(in), target :: model
       logical, intent(in), optional :: decay_rest_frame
     end subroutine beam_data_init_structure
 <<Beams: procedures>>=
   module subroutine beam_data_init_structure &
        (beam_data, structure, sqrts, model, decay_rest_frame)
     class(beam_data_t), intent(out) :: beam_data
     type(beam_structure_t), intent(in) :: structure
     integer :: n_beam
     real(default), intent(in) :: sqrts
     class(model_data_t), intent(in), target :: model
     logical, intent(in), optional :: decay_rest_frame
     type(flavor_t), dimension(:), allocatable :: flv
     n_beam = structure%get_n_beam ()
     allocate (flv (n_beam))
     call flv%init (structure%get_prt (), model)
     if (structure%asymmetric ()) then
        if (structure%polarized ()) then
           call beam_data%init_momenta (structure%get_momenta (), flv, &
                structure%get_smatrix (), structure%get_pol_f ())
        else
           call beam_data%init_momenta (structure%get_momenta (), flv)
        end if
     else
        select case (n_beam)
        case (1)
           if (structure%polarized ()) then
              call beam_data%init_decay (flv, &
                   structure%get_smatrix (), structure%get_pol_f (), &
                   rest_frame = decay_rest_frame)
           else
              call beam_data%init_decay (flv, &
                   rest_frame = decay_rest_frame)
           end if
        case (2)
           if (structure%polarized ()) then
              call beam_data%init_sqrts (sqrts, flv, &
                   structure%get_smatrix (), structure%get_pol_f ())
           else
              call beam_data%init_sqrts (sqrts, flv)
           end if
        case default
           call msg_bug ("Beam data: invalid beam structure object")
        end select
     end if
   end subroutine beam_data_init_structure
 
 @ %def beam_data_init_structure
 @
 \subsection{Initializers: collisions}
 This is the simplest one: just the two flavors, c.m.\ energy,
 polarization.  Color is inferred from flavor.  Beam momenta and c.m.\
 momenta coincide.
 <<Beams: beam data: TBP>>=
   procedure :: init_sqrts => beam_data_init_sqrts
 <<Beams: sub interfaces>>=
     module subroutine beam_data_init_sqrts &
          (beam_data, sqrts, flv, smatrix, pol_f)
       class(beam_data_t), intent(out) :: beam_data
       real(default), intent(in) :: sqrts
       type(flavor_t), dimension(:), intent(in) :: flv
       type(smatrix_t), dimension(:), intent(in), optional :: smatrix
       real(default), dimension(:), intent(in), optional :: pol_f
     end subroutine beam_data_init_sqrts
 <<Beams: procedures>>=
   module subroutine beam_data_init_sqrts &
        (beam_data, sqrts, flv, smatrix, pol_f)
     class(beam_data_t), intent(out) :: beam_data
     real(default), intent(in) :: sqrts
     type(flavor_t), dimension(:), intent(in) :: flv
     type(smatrix_t), dimension(:), intent(in), optional :: smatrix
     real(default), dimension(:), intent(in), optional :: pol_f
     real(default), dimension(size(flv)) :: E, p
     call beam_data_init (beam_data, size (flv))
     beam_data%sqrts = sqrts
     beam_data%lab_is_cm = .true.
     select case (beam_data%n)
     case (1)
        E = sqrts;  p = 0
        beam_data%p_cm = vector4_moving (E, p, 3)
        beam_data%p = beam_data%p_cm
     case (2)
        beam_data%p_cm = colliding_momenta (sqrts, flv%get_mass ())
        beam_data%p = colliding_momenta (sqrts, flv%get_mass ())
     end select
     call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
   end subroutine beam_data_init_sqrts
 
 @ %def beam_data_init_sqrts
 @ This version sets beam momenta directly, assuming that they are
 asymmetric, i.e., lab frame and c.m.\ frame do not coincide.
 Polarization info is deferred to a common initializer.
 
 The Lorentz transformation that we compute here is not actually used
 in the calculation; instead, it will be recomputed for each event in
 the subroutine [[phs_set_incoming_momenta]].  We compute it here for
 the nominal beam setup nevertheless, so we can print it and, in
 particular, include it in the MD5 sum.
 <<Beams: beam data: TBP>>=
   procedure :: init_momenta => beam_data_init_momenta
 <<Beams: sub interfaces>>=
     module subroutine beam_data_init_momenta &
          (beam_data, p3, flv, smatrix, pol_f)
       class(beam_data_t), intent(out) :: beam_data
       type(vector3_t), dimension(:), intent(in) :: p3
       type(flavor_t), dimension(:), intent(in) :: flv
       type(smatrix_t), dimension(:), intent(in), optional :: smatrix
       real(default), dimension(:), intent(in), optional :: pol_f
     end subroutine beam_data_init_momenta
 <<Beams: procedures>>=
   module subroutine beam_data_init_momenta &
        (beam_data, p3, flv, smatrix, pol_f)
     class(beam_data_t), intent(out) :: beam_data
     type(vector3_t), dimension(:), intent(in) :: p3
     type(flavor_t), dimension(:), intent(in) :: flv
     type(smatrix_t), dimension(:), intent(in), optional :: smatrix
     real(default), dimension(:), intent(in), optional :: pol_f
     type(vector4_t) :: p0
     type(vector4_t), dimension(:), allocatable :: p, p_cm_rot
     real(default), dimension(size(p3)) :: e
     real(default), dimension(size(flv)) :: m
     type(lorentz_transformation_t) :: L_boost, L_rot
     call beam_data_init (beam_data, size (flv))
     m = flv%get_mass ()
     e = sqrt (p3 ** 2 + m ** 2)
     allocate (p (beam_data%n))
     p = vector4_moving (e, p3)
     p0 = sum (p)
     beam_data%p = p
     beam_data%lab_is_cm = .false.
     beam_data%sqrts = p0 ** 1
     L_boost = boost (p0, beam_data%sqrts)
     allocate (p_cm_rot (beam_data%n))
     p_cm_rot = inverse (L_boost) * p
     allocate (beam_data%L_cm_to_lab)
     select case (beam_data%n)
     case (1)
        beam_data%L_cm_to_lab = L_boost
        beam_data%p_cm = vector4_at_rest (beam_data%sqrts)
     case (2)
        L_rot = rotation_to_2nd (3, space_part (p_cm_rot(1)))
        beam_data%L_cm_to_lab = L_boost * L_rot
        beam_data%p_cm = &
             colliding_momenta (beam_data%sqrts, flv%get_mass ())
     end select
     call beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
   end subroutine beam_data_init_momenta
 
 @ %def beam_data_init_momenta
 @
 Final steps:
 If requested, rotate the beams in the lab frame, and set
 the beam-data components.
 <<Beams: procedures>>=
   subroutine beam_data_finish_initialization (beam_data, flv, smatrix, pol_f)
     type(beam_data_t), intent(inout) :: beam_data
     type(flavor_t), dimension(:), intent(in) :: flv
     type(smatrix_t), dimension(:), intent(in), optional :: smatrix
     real(default), dimension(:), intent(in), optional :: pol_f
     integer :: i
     do i = 1, beam_data%n
        beam_data%flv(i) = flv(i)
        beam_data%mass(i) = flv(i)%get_mass ()
        if (present (smatrix)) then
           if (size (smatrix) /= beam_data%n) &
                call msg_fatal ("Beam data: &
                &polarization density array has wrong dimension")
           beam_data%pmatrix(i) = smatrix(i)
           if (present (pol_f)) then
              if (size (pol_f) /= size (smatrix)) &
                   call msg_fatal ("Beam data: &
                   &polarization fraction array has wrong dimension")
              call beam_data%pmatrix(i)%normalize (flv(i), pol_f(i))
           else
              call beam_data%pmatrix(i)%normalize (flv(i), 1._default)
           end if
        else
           call beam_data%pmatrix(i)%init (2, 0)
           call beam_data%pmatrix(i)%normalize (flv(i), 0._default)
        end if
     end do
     call beam_data%compute_md5sum ()
   end subroutine beam_data_finish_initialization
 
 @ %def beam_data_finish_initialization
 @
 The MD5 sum is stored within the beam-data record, so it can be
 checked for integrity in subsequent runs.
 <<Beams: beam data: TBP>>=
   procedure :: compute_md5sum => beam_data_compute_md5sum
 <<Beams: sub interfaces>>=
     module subroutine beam_data_compute_md5sum (beam_data)
       class(beam_data_t), intent(inout) :: beam_data
       integer :: unit
     end subroutine beam_data_compute_md5sum
 <<Beams: procedures>>=
   module subroutine beam_data_compute_md5sum (beam_data)
     class(beam_data_t), intent(inout) :: beam_data
     integer :: unit
     unit = free_unit ()
     open (unit = unit, status = "scratch", action = "readwrite")
     call beam_data%write (unit, write_md5sum = .false., &
        verbose = .true.)
     rewind (unit)
     beam_data%md5sum = md5sum (unit)
     close (unit)
   end subroutine beam_data_compute_md5sum
 
 @ %def beam_data_compute_md5sum
 @
 \subsection{Initializers: decays}
 This is the simplest one: decay in rest frame.  We need just flavor
 and polarization.  Color is inferred from flavor.  Beam momentum and
 c.m.\ momentum coincide.
 <<Beams: beam data: TBP>>=
   procedure :: init_decay => beam_data_init_decay
 <<Beams: sub interfaces>>=
     module subroutine beam_data_init_decay &
          (beam_data, flv, smatrix, pol_f, rest_frame)
       class(beam_data_t), intent(out) :: beam_data
       type(flavor_t), dimension(1), intent(in) :: flv
       type(smatrix_t), dimension(1), intent(in), optional :: smatrix
       real(default), dimension(:), intent(in), optional :: pol_f
       logical, intent(in), optional :: rest_frame
     end subroutine beam_data_init_decay
 <<Beams: procedures>>=
   module subroutine beam_data_init_decay &
        (beam_data, flv, smatrix, pol_f, rest_frame)
     class(beam_data_t), intent(out) :: beam_data
     type(flavor_t), dimension(1), intent(in) :: flv
     type(smatrix_t), dimension(1), intent(in), optional :: smatrix
     real(default), dimension(:), intent(in), optional :: pol_f
     logical, intent(in), optional :: rest_frame
     real(default), dimension(1) :: m
     m = flv%get_mass ()
     if (present (smatrix)) then
        call beam_data%init_sqrts (m(1), flv, smatrix, pol_f)
     else
        call beam_data%init_sqrts (m(1), flv, smatrix, pol_f)
     end if
     if (present (rest_frame))  beam_data%lab_is_cm = rest_frame
   end subroutine beam_data_init_decay
 
 @ %def beam_data_init_decay
 @
 \subsection{The beams type}
 Beam objects are interaction objects that contain the actual beam
 data including polarization and density matrix.  For collisions, the
 beam object actually contains two beams.
 <<Beams: public>>=
   public :: beam_t
 <<Beams: types>>=
   type :: beam_t
      private
      type(interaction_t) :: int
   end type beam_t
 
 @ %def beam_t
 @ The constructor contains code that converts beam data into the
 (entangled) particle-pair quantum state.  First, we set the number of
 particles and polarization mask.  (The polarization mask is handed
 over to all later interactions, so if helicity is diagonal or absent, this fact
 is used when constructing the hard-interaction events.)  Then, we
 construct the entangled state that combines helicity, flavor and color
 of the two particles (where flavor and color are unique, while several
 helicity states are possible).  Then, we transfer this state together
 with the associated values from the spin density matrix into the
 [[interaction_t]] object.
 
 Calling the [[add_state]] method of the interaction object, we keep
 the entries of the helicity density matrix without adding them up.
 This ensures that for unpolarized states, we do not normalize but end
 up with an $1/N$ entry, where $N$ is the initial-state multiplicity.
 <<Beams: public>>=
   public :: beam_init
 <<Beams: sub interfaces>>=
     module subroutine beam_init (beam, beam_data)
       type(beam_t), intent(out) :: beam
       type(beam_data_t), intent(in), target :: beam_data
     end subroutine beam_init
 <<Beams: procedures>>=
   module subroutine beam_init (beam, beam_data)
     type(beam_t), intent(out) :: beam
     type(beam_data_t), intent(in), target :: beam_data
     logical, dimension(beam_data%n) :: polarized, diagonal
     type(quantum_numbers_mask_t), dimension(beam_data%n) :: mask, mask_d
     type(state_matrix_t), target :: state_hel, state_fc, state_tmp
     type(state_iterator_t) :: it_hel, it_tmp
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     complex(default) :: value
     real(default), parameter :: tolerance = 100 * epsilon (1._default)
     polarized = beam_data%pmatrix%is_polarized ()
     diagonal = beam_data%pmatrix%is_diagonal ()
     mask = quantum_numbers_mask (.false., .false., &
          mask_h = .not. polarized, &
          mask_hd = diagonal)
     mask_d = quantum_numbers_mask (.false., .false., .false., &
          mask_hd = polarized .and. diagonal)
     call beam%int%basic_init &
          (0, 0, beam_data%n, mask = mask, store_values = .true.)
     state_hel = beam_data%get_helicity_state_matrix ()
     allocate (qn (beam_data%n))
     call qn%init (beam_data%flv, color_from_flavor (beam_data%flv, 1))
     call state_fc%init ()
     call state_fc%add_state (qn)
     call merge_state_matrices (state_hel, state_fc, state_tmp)
     call it_hel%init (state_hel)
     call it_tmp%init (state_tmp)
     do while (it_hel%is_valid ())
        qn = it_tmp%get_quantum_numbers ()
        value = it_hel%get_matrix_element ()
        if (any (qn%are_redundant (mask_d))) then
           ! skip off-diagonal elements for diagonal polarization
        else if (abs (value) <= tolerance) then
           ! skip zero entries
        else
           call beam%int%add_state (qn, value = value)
        end if
        call it_hel%advance ()
        call it_tmp%advance ()
     end do
     call beam%int%freeze ()
     call beam%int%set_momenta (beam_data%p, outgoing = .true.)
     call state_hel%final ()
     call state_fc%final ()
     call state_tmp%final ()
   end subroutine beam_init
 
 @ %def beam_init
 @ Finalizer:
 <<Beams: public>>=
   public :: beam_final
 <<Beams: sub interfaces>>=
     module subroutine beam_final (beam)
       type(beam_t), intent(inout) :: beam
     end subroutine beam_final
 <<Beams: procedures>>=
   module subroutine beam_final (beam)
     type(beam_t), intent(inout) :: beam
     call beam%int%final ()
   end subroutine beam_final
 
 @ %def beam_final
 @ I/O:
 <<Beams: public>>=
   public :: beam_write
 <<Beams: sub interfaces>>=
     module subroutine beam_write &
          (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose)
       type(beam_t), intent(in) :: beam
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
       logical, intent(in), optional :: col_verbose
     end subroutine beam_write
 <<Beams: procedures>>=
   module subroutine beam_write &
        (beam, unit, verbose, show_momentum_sum, show_mass, col_verbose)
     type(beam_t), intent(in) :: beam
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose, show_momentum_sum, show_mass
     logical, intent(in), optional :: col_verbose
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     select case (beam%int%get_n_out ())
     case (1);  write (u, *) "Decaying particle:"
     case (2);  write (u, *) "Colliding beams:"
     end select
     call beam%int%basic_write &
          (unit, verbose = verbose, show_momentum_sum = &
           show_momentum_sum, show_mass = show_mass, &
           col_verbose = col_verbose)
   end subroutine beam_write
 
 @ %def beam_write
 @ Defined assignment: deep copy
 <<Beams: public>>=
   public :: assignment(=)
 <<Beams: interfaces>>=
   interface assignment(=)
      module procedure beam_assign
   end interface
 
 <<Beams: sub interfaces>>=
     module subroutine beam_assign (beam_out, beam_in)
       type(beam_t), intent(out) :: beam_out
       type(beam_t), intent(in) :: beam_in
     end subroutine beam_assign
 <<Beams: procedures>>=
   module subroutine beam_assign (beam_out, beam_in)
     type(beam_t), intent(out) :: beam_out
     type(beam_t), intent(in) :: beam_in
     beam_out%int = beam_in%int
   end subroutine beam_assign
 
 @ %def beam_assign
 @
 \subsection{Inherited procedures}
 <<Beams: public>>=
   public :: interaction_set_source_link_beam
 <<Beams: sub interfaces>>=
     module subroutine interaction_set_source_link_beam (int, i, beam1, i1)
       type(interaction_t), intent(inout) :: int
       type(beam_t), intent(in), target :: beam1
       integer, intent(in) :: i, i1
     end subroutine interaction_set_source_link_beam
 <<Beams: procedures>>=
   module subroutine interaction_set_source_link_beam (int, i, beam1, i1)
     type(interaction_t), intent(inout) :: int
     type(beam_t), intent(in), target :: beam1
     integer, intent(in) :: i, i1
     call int%set_source_link (i, beam1%int, i1)
   end subroutine interaction_set_source_link_beam
 
 @ %def interaction_set_source_link_beam
 @
 \subsection{Accessing contents}
 Return the interaction component -- as a pointer, to avoid any copying.
 <<Beams: public>>=
   public :: beam_get_int_ptr
 <<Beams: sub interfaces>>=
     module function beam_get_int_ptr (beam) result (int)
       type(interaction_t), pointer :: int
       type(beam_t), intent(in), target :: beam
     end function beam_get_int_ptr
 <<Beams: procedures>>=
   module function beam_get_int_ptr (beam) result (int)
     type(interaction_t), pointer :: int
     type(beam_t), intent(in), target :: beam
     int => beam%int
   end function beam_get_int_ptr
 
 @ %def beam_get_int_ptr
 @ Set beam momenta directly.  (Used for cascade decays.)
 <<Beams: public>>=
   public :: beam_set_momenta
 <<Beams: sub interfaces>>=
     module subroutine beam_set_momenta (beam, p)
       type(beam_t), intent(inout) :: beam
       type(vector4_t), dimension(:), intent(in) :: p
     end subroutine beam_set_momenta
 <<Beams: procedures>>=
   module subroutine beam_set_momenta (beam, p)
     type(beam_t), intent(inout) :: beam
     type(vector4_t), dimension(:), intent(in) :: p
     call beam%int%set_momenta (p)
   end subroutine beam_set_momenta
 
 @ %def beam_set_momenta
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[beams_ut.f90]]>>=
 <<File header>>
 
 module beams_ut
   use unit_tests
   use beams_uti
 
 <<Standard module head>>
 
 <<Beams: public test>>
 
 contains
 
 <<Beams: test driver>>
 
 end module beams_ut
 @ %def beams_ut
 @
 <<[[beams_uti.f90]]>>=
 <<File header>>
 
 module beams_uti
 
 <<Use kinds>>
   use lorentz
   use flavors
   use interactions, only: reset_interaction_counter
   use polarizations, only: smatrix_t
   use model_data
   use beam_structures
 
   use beams
 
 <<Standard module head>>
 
 <<Beams: test declarations>>
 
 contains
 
 <<Beams: tests>>
 
 end module beams_uti
 @ %def beams_ut
 @ API: driver for the unit tests below.
 <<Beams: public test>>=
   public :: beams_test
 <<Beams: test driver>>=
   subroutine beams_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<Beams: execute tests>>
   end subroutine beams_test
 
 @  %def beams_test
 @ Test the basic beam setup.
 <<Beams: execute tests>>=
   call test (beam_1, "beam_1", &
        "check basic beam setup", &
        u, results)
 <<Beams: test declarations>>=
   public :: beam_1
 <<Beams: tests>>=
   subroutine beam_1 (u)
     integer, intent(in) :: u
     type(beam_data_t), target :: beam_data
     type(beam_t) :: beam
     real(default) :: sqrts
     type(flavor_t), dimension(2) :: flv
     type(smatrix_t), dimension(2) :: smatrix
     real(default), dimension(2) :: pol_f
     type(model_data_t), target :: model
 
     write (u, "(A)")  "* Test output: beam_1"
     write (u, "(A)")  "*   Purpose: test basic beam setup"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call model%init_sm_test ()
 
     write (u, "(A)")  "* Unpolarized scattering, massless fermions"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([1,-1], model)
 
     call beam_data%init_sqrts (sqrts, flv)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized scattering, massless bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([22,22], model)
 
     call beam_data%init_sqrts (sqrts, flv)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized scattering, massive bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([24,-24], model)
 
     call beam_data%init_sqrts (sqrts, flv)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Polarized scattering, massless fermions"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([1,-1], model)
 
     call smatrix(1)%init (2, 1)
     call smatrix(1)%set_entry (1, [1,1], (1._default, 0._default))
     pol_f(1) = 0.5_default
 
     call smatrix(2)%init (2, 3)
     call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default))
     call smatrix(2)%set_entry (2, [-1,-1], (1._default, 0._default))
     call smatrix(2)%set_entry (3, [-1,1], (1._default, 0._default))
     pol_f(2) = 1._default
 
     call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Semi-polarized scattering, massless bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([22,22], model)
 
     call smatrix(1)%init (2, 0)
     pol_f(1) = 0._default
 
     call smatrix(2)%init (2, 1)
     call smatrix(2)%set_entry (1, [1,1], (1._default, 0._default))
     pol_f(2) = 1._default
 
     call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Semi-polarized scattering, massive bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([24,-24], model)
 
     call smatrix(1)%init (2, 0)
     pol_f(1) = 0._default
 
     call smatrix(2)%init (2, 1)
     call smatrix(2)%set_entry (1, [0,0], (1._default, 0._default))
     pol_f(2) = 1._default
 
     call beam_data%init_sqrts (sqrts, flv, smatrix, pol_f)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized decay, massive boson"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call flv(1)%init (23, model)
 
     call beam_data%init_decay (flv(1:1))
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Polarized decay, massive boson"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call flv(1)%init (23, model)
     call smatrix(1)%init (2, 1)
     call smatrix(1)%set_entry (1, [0,0], (1._default, 0._default))
     pol_f(1) = 0.4_default
 
     call beam_data%init_decay (flv(1:1), smatrix(1:1), pol_f(1:1))
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call beam_final (beam)
     call beam_data%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_1"
 
   end subroutine beam_1
 
 @ %def beam_1
 @ Test advanced beam setup.
 <<Beams: execute tests>>=
   call test (beam_2, "beam_2", &
        "beam initialization", &
        u, results)
 <<Beams: test declarations>>=
   public :: beam_2
 <<Beams: tests>>=
   subroutine beam_2 (u)
     integer, intent(in) :: u
     type(beam_data_t), target :: beam_data
     type(beam_t) :: beam
     real(default) :: sqrts
     type(flavor_t), dimension(2) :: flv
     integer, dimension(0) :: no_records
     type(beam_structure_t) :: beam_structure
     type(model_data_t), target :: model
 
     write (u, "(A)")  "* Test output: beam_2"
     write (u, "(A)")  "*   Purpose: transfer beam polarization using &
          &beam structure"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
     write (u, "(A)")
 
     call model%init_sm_test ()
 
     write (u, "(A)")  "* Unpolarized scattering, massless fermions"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([1,-1], model)
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%final_pol ()
 
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized scattering, massless bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([22,22], model)
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%final_pol ()
 
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized scattering, massive bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([24,-24], model)
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%final_pol ()
 
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Polarized scattering, massless fermions"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([1,-1], model)
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%init_pol (2)
 
     call beam_structure%init_smatrix (1, 1)
     call beam_structure%set_sentry (1, 1, [1,1], (1._default, 0._default))
 
     call beam_structure%init_smatrix (2, 3)
     call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default))
     call beam_structure%set_sentry (2, 2, [-1,-1], (1._default, 0._default))
     call beam_structure%set_sentry (2, 3, [-1,1], (1._default, 0._default))
 
     call beam_structure%set_pol_f ([0.5_default, 1._default])
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
     write (u, *)
 
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     call beam_final (beam)
     call beam_data%final ()
     call beam_structure%final_pol ()
     call beam_structure%final_sf ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Semi-polarized scattering, massless bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([22,22], model)
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%init_pol (2)
 
     call beam_structure%init_smatrix (1, 0)
 
     call beam_structure%init_smatrix (2, 1)
     call beam_structure%set_sentry (2, 1, [1,1], (1._default, 0._default))
 
     call beam_structure%set_pol_f ([0._default, 1._default])
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Semi-polarized scattering, massive bosons"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     sqrts = 500
     call flv%init ([24,-24], model)
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%init_pol (2)
 
     call beam_structure%init_smatrix (1, 0)
 
     call beam_structure%init_smatrix (2, 1)
     call beam_structure%set_sentry (2, 1, [0,0], (1._default, 0._default))
     call beam_structure%write (u)
 
     write (u, "(A)")
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
     call beam_final (beam)
     call beam_data%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Unpolarized decay, massive boson"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call flv(1)%init (23, model)
 
     call beam_structure%init_sf ([flv(1)%get_name ()], no_records)
     call beam_structure%final_pol ()
     call beam_structure%write (u)
 
     write (u, "(A)")
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
 
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Polarized decay, massive boson"
     write (u, "(A)")
 
     call reset_interaction_counter ()
     call flv(1)%init (23, model)
     call beam_structure%init_sf ([flv(1)%get_name ()], no_records)
 
     call beam_structure%init_pol (1)
 
     call beam_structure%init_smatrix (1, 1)
     call beam_structure%set_sentry (1, 1, [0,0], (1._default, 0._default))
     call beam_structure%set_pol_f ([0.4_default])
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, sqrts, model)
     call beam_data%write (u)
     write (u, "(A)")
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call beam_final (beam)
     call beam_data%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_2"
 
   end subroutine beam_2
 
 @ %def beam_2
 @ Test advanced beam setup, completely arbitrary momenta.
 <<Beams: execute tests>>=
   call test (beam_3, "beam_3", &
        "generic beam momenta", &
        u, results)
 <<Beams: test declarations>>=
   public :: beam_3
 <<Beams: tests>>=
   subroutine beam_3 (u)
     integer, intent(in) :: u
     type(beam_data_t), target :: beam_data
     type(beam_t) :: beam
     type(flavor_t), dimension(2) :: flv
     integer, dimension(0) :: no_records
     type(model_data_t), target :: model
     type(beam_structure_t) :: beam_structure
     type(vector3_t), dimension(2) :: p3
     type(vector4_t), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: beam_3"
     write (u, "(A)")  "*   Purpose: set up beams with generic momenta"
     write (u, "(A)")
 
     write (u, "(A)")  "* Reading model file"
     write (u, "(A)")
 
     call reset_interaction_counter ()
 
     call model%init_sm_test ()
 
     write (u, "(A)")  "* 1: Scattering process"
     write (u, "(A)")
 
     call flv%init ([2212,2212], model)
 
     p3(1) = vector3_moving ([5._default, 0._default, 10._default])
     p3(2) = -vector3_moving ([1._default, 1._default, -10._default])
 
     call beam_structure%init_sf (flv%get_name (), no_records)
     call beam_structure%set_momentum (p3 ** 1)
     call beam_structure%set_theta (polar_angle (p3))
     call beam_structure%set_phi (azimuthal_angle (p3))
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, 0._default, model)
     call pacify (beam_data%l_cm_to_lab, 1e-20_default)
     call beam_data%compute_md5sum ()
     call beam_data%write (u, verbose = .true.)
     write (u, *)
 
     write (u, "(1x,A)")  "Beam momenta reconstructed from LT:"
     p = beam_data%L_cm_to_lab * beam_data%p_cm
     call pacify (p, 1e-12_default)
     call vector4_write (p(1), u)
     call vector4_write (p(2), u)
     write (u, "(A)")
 
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     call beam_final (beam)
     call beam_data%final ()
     call beam_structure%final_sf ()
     call beam_structure%final_mom ()
 
     write (u, "(A)")
     write (u, "(A)")  "* 2: Decay"
     write (u, "(A)")
 
     call flv(1)%init (23, model)
     p3(1) = vector3_moving ([10._default, 5._default, 50._default])
 
     call beam_structure%init_sf ([flv(1)%get_name ()], no_records)
     call beam_structure%set_momentum ([p3(1) ** 1])
     call beam_structure%set_theta ([polar_angle (p3(1))])
     call beam_structure%set_phi ([azimuthal_angle (p3(1))])
     call beam_structure%write (u)
     write (u, *)
 
     call beam_data%init_structure (beam_structure, 0._default, model)
     call beam_data%write (u, verbose = .true.)
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Beam momentum reconstructed from LT:"
     p(1) = beam_data%L_cm_to_lab * beam_data%p_cm(1)
     call pacify (p(1), 1e-12_default)
     call vector4_write (p(1), u)
     write (u, "(A)")
 
     call beam_init (beam, beam_data)
     call beam_write (beam, u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call beam_final (beam)
     call beam_data%final ()
     call beam_structure%final_sf ()
     call beam_structure%final_mom ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: beam_3"
 
   end subroutine beam_3
 
 @ %def beam_3
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Tools}
 
 This module contains auxiliary procedures that can be accessed by the
 structure function code.
 
 <<[[sf_aux.f90]]>>=
 <<File header>>
 
 module sf_aux
 
 <<Use kinds>>
   use constants, only: twopi
   use lorentz
 
 <<Standard module head>>
 
 <<SF aux: public>>
 
 <<SF aux: parameters>>
 
 <<SF aux: types>>
 
   interface
 <<SF aux: sub interfaces>>
   end interface
 
 end module sf_aux
 
 @ %def sf_aux
 @
 <<[[sf_aux_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_aux) sf_aux_s
 
   use io_units
   use numeric_utils
 
   implicit none
 
 contains
 
 <<SF aux: procedures>>
 
 end submodule sf_aux_s
 
 @ %def sf_aux_s
 @
 \subsection{Momentum splitting}
 Let us consider first an incoming parton with momentum $k$ and
 invariant mass squared $s=k^2$ that splits into two partons with
 momenta $q,p$ and invariant masses $t=q^2$ and $u=p^2$.  (This is an
 abuse of the Mandelstam notation.  $t$ is actually the momentum
 transfer, assuming that $p$ is radiated and $q$ initiates the hard
 process.) The energy is split among the partons such that if $E=k^0$,
 we have $q^0 = xE$ and $p^0=\bar x E$, where $\bar x\equiv 1-x$.
 
 We define the angle $\theta$ as the polar angle of $p$ w.r.t.\ the
 momentum axis of the incoming momentum $k$.  Ignoring azimuthal angle,
 we can write the four-momenta in the basis $(E,p_T,p_L)$ as
 \begin{equation}
   k =
   \begin{pmatrix}
     E \\ 0 \\ p
   \end{pmatrix},
   \qquad
   p =
   \begin{pmatrix}
     \bar x E \\ \bar x\bar p\sin\theta \\ \bar x\bar p\cos\theta
   \end{pmatrix},
   \qquad
   q =
   \begin{pmatrix}
     x E \\ -\bar x\bar p\sin\theta \\ p - \bar x\bar p\cos\theta
   \end{pmatrix},
 \end{equation}
 where the first two mass-shell conditions are
 \begin{equation}
   p^2 = E^2 - s,
   \qquad
   \bar p^2 = E^2 - \frac{u}{\bar x^2}.
 \end{equation}
 The second condition implies that, for positive $u$, $\bar x^2 >
 u/E^2$, or equivalently
 \begin{equation}
   x < 1 - \sqrt{u} / E.
 \end{equation}
 
 We are interested in the third mass-shell conditions: $s$ and $u$ are
 fixed, so we need $t$ as a function of $\cos\theta$:
 \begin{equation}
   t = -2\bar x \left(E^2 - p\bar p\cos\theta\right) + s + u.
 \end{equation}
 Solving for $\cos\theta$, we get
 \begin{equation}
   \cos\theta = \frac{2\bar x E^2 + t - s - u}{2\bar x p\bar p}.
 \end{equation}
 We can compute $\sin\theta$ numerically as
 $\sin^2\theta=1-\cos^2\theta$, but it is important to reexpress this
 in view of numerical stability.  To this end, we first determine the
 bounds for $t$.  The cosine must be between $-1$ and $1$, so the
 bounds are
 \begin{align}
   t_0 &= -2\bar x\left(E^2 + p\bar p\right) + s + u,
 \\
   t_1 &= -2\bar x\left(E^2 - p\bar p\right) + s + u.
 \end{align}
 Computing $\sin^2\theta$ from $\cos\theta$ above, we observe that the
 numerator is a quadratic polynomial in $t$ which has the zeros $t_0$
 and $t_1$, while the common denominator is given by $(2\bar x p\bar
 p)^2$.  Hence, we can write
 \begin{equation}
   \sin^2\theta = -\frac{(t - t_0)(t - t_1)}{(2\bar x p\bar p)^2}
   \qquad\text{and}\qquad
   \cos\theta = \frac{(t-t_0) + (t-t_1)}{4\bar x p\bar p},
 \end{equation}
 which is free of large cancellations near $t=t_0$ or $t=t_1$.
 
 If all is massless, i.e., $s=u=0$, this simplifies to
 \begin{align}
   t_0 &= -4\bar x E^2,
 &
   t_1 &= 0,
 \\
   \sin^2\theta &= -\frac{t}{\bar x E^2}
                    \left(1 + \frac{t}{4\bar x E^2}\right),
 &
   \cos\theta &= 1 + \frac{t}{2\bar x E^2}.
 \end{align}
 
 Here is the implementation.  First, we define a container for the
 kinematical integration limits and some further data.
 
 Note: contents are public only for easy access in unit test.
 <<SF aux: public>>=
   public :: splitting_data_t
 <<SF aux: types>>=
   type :: splitting_data_t
 !     private
      logical :: collinear = .false.
      real(default) :: x0 = 0
      real(default) :: x1
      real(default) :: t0
      real(default) :: t1
      real(default) :: phi0 = 0
      real(default) :: phi1 = twopi
      real(default) :: E, p, s, u, m2
      real(default) :: x, xb, pb
      real(default) :: t = 0
      real(default) :: phi = 0
    contains
    <<SF aux: splitting data: TBP>>
   end type splitting_data_t
 
 @ %def splitting_data_t
 @ I/O for debugging:
 <<SF aux: splitting data: TBP>>=
   procedure :: write => splitting_data_write
 <<SF aux: sub interfaces>>=
     module subroutine splitting_data_write (d, unit)
       class(splitting_data_t), intent(in) :: d
       integer, intent(in), optional :: unit
     end subroutine splitting_data_write
 <<SF aux: procedures>>=
   module subroutine splitting_data_write (d, unit)
     class(splitting_data_t), intent(in) :: d
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(A)") "Splitting data:"
     write (u, "(2x,A,L1)")  "collinear = ", d%collinear
 1   format (2x,A,1x,ES15.8)
     write (u, 1) "x0   =", d%x0
     write (u, 1) "x    =", d%x
     write (u, 1) "xb   =", d%xb
     write (u, 1) "x1   =", d%x1
     write (u, 1) "t0   =", d%t0
     write (u, 1) "t    =", d%t
     write (u, 1) "t1   =", d%t1
     write (u, 1) "phi0 =", d%phi0
     write (u, 1) "phi  =", d%phi
     write (u, 1) "phi1 =", d%phi1
     write (u, 1) "E    =", d%E
     write (u, 1) "p    =", d%p
     write (u, 1) "pb   =", d%pb
     write (u, 1) "s    =", d%s
     write (u, 1) "u    =", d%u
     write (u, 1) "m2   =", d%m2
   end subroutine splitting_data_write
 
 @ %def splitting_data_write
 @
 \subsection{Constant data}
 This is the initializer for the data.  The input consists of the
 incoming momentum, its invariant mass squared, and the invariant mass
 squared of the radiated particle.  $m2$ is the \emph{physical} mass
 squared of the outgoing particle.  The $t$ bounds depend on the chosen $x$
 value and cannot be determined yet.
 <<SF aux: splitting data: TBP>>=
   procedure :: init => splitting_data_init
 <<SF aux: sub interfaces>>=
     module subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear)
       class(splitting_data_t), intent(out) :: d
       type(vector4_t), intent(in) :: k
       real(default), intent(in) :: mk2, mr2, mo2
       logical, intent(in), optional :: collinear
     end subroutine splitting_data_init
 <<SF aux: procedures>>=
   module subroutine splitting_data_init (d, k, mk2, mr2, mo2, collinear)
     class(splitting_data_t), intent(out) :: d
     type(vector4_t), intent(in) :: k
     real(default), intent(in) :: mk2, mr2, mo2
     logical, intent(in), optional :: collinear
     if (present (collinear))  d%collinear = collinear
     d%E = energy (k)
     d%x1 = 1 - sqrt (max (mr2, 0._default)) / d%E
     d%p = sqrt (d%E**2 - mk2)
     d%s = mk2
     d%u = mr2
     d%m2 = mo2
   end subroutine splitting_data_init
 
 @ %def splitting_data_init
 @ Retrieve the $x$ bounds, if needed for $x$ sampling.  Generating an
 $x$ value is done by the caller, since this is the part that depends
 on the nature of the structure function.
 <<SF aux: splitting data: TBP>>=
   procedure :: get_x_bounds => splitting_get_x_bounds
 <<SF aux: sub interfaces>>=
     module function splitting_get_x_bounds (d) result (x)
       class(splitting_data_t), intent(in) :: d
       real(default), dimension(2) :: x
     end function splitting_get_x_bounds
 <<SF aux: procedures>>=
   module function splitting_get_x_bounds (d) result (x)
     class(splitting_data_t), intent(in) :: d
     real(default), dimension(2) :: x
     x = [ d%x0, d%x1 ]
   end function splitting_get_x_bounds
 
 @ %def splitting_get_x_bounds
 @ Now set the momentum fraction and compute $t_0$ and $t_1$.
 
 [The calculation of $t_1$ is subject to numerical problems.  The exact
 formula is ($s=m_i^2$, $u=m_r^2$)
 \begin{equation}
   t_1 = -2\bar x E^2 + m_i^2 + m_r^2
   + 2\bar x \sqrt{E^2-m_i^2}\,\sqrt{E^2 - m_r^2/\bar x^2}.
 \end{equation}
 The structure-function paradigm is useful only if $E\gg m_i,m_r$.  In
 a Taylor expansion for large $E$, the leading term cancels.  The
 expansion of the square roots (to subleading order) yields
 \begin{equation}
   t_1 = xm_i^2 - \frac{x}{\bar x}m_r^2.
 \end{equation}
 There are two cases of interest: $m_i=m_o$ and $m_r=0$,
 \begin{equation}
   t_1 = xm_o^2
 \end{equation}
 and $m_i=m_r$ and $m_o=0$,
 \begin{equation}
   t_1 = -\frac{x^2}{\bar x}m_i^2.
 \end{equation}
 In both cases, $t_1\leq m_o^2$.]
 
 That said, it turns out that taking the $t_1$ evaluation at face value
 leads to less problems than the approximation.  We express the angles
 in terms of $t-t_0$ and $t-t_1$.  Numerical noise in $t_1$ can then be
 tolerated.
 <<SF aux: splitting data: TBP>>=
   procedure :: set_t_bounds => splitting_set_t_bounds
 <<SF aux: sub interfaces>>=
     elemental module subroutine splitting_set_t_bounds (d, x, xb)
       class(splitting_data_t), intent(inout) :: d
       real(default), intent(in), optional :: x, xb
     end subroutine splitting_set_t_bounds
 <<SF aux: procedures>>=
   elemental module subroutine splitting_set_t_bounds (d, x, xb)
     class(splitting_data_t), intent(inout) :: d
     real(default), intent(in), optional :: x, xb
     real(default) :: tp, tm
     if (present (x))  d%x = x
     if (present (xb)) d%xb = xb
     if (vanishes (d%u)) then
        d%pb = d%E
     else
        if (.not. vanishes (d%xb)) then
           d%pb = sqrt (max (d%E**2 - d%u / d%xb**2, 0._default))
        else
           d%pb = 0
        end if
     end if
     tp = -2 * d%xb * d%E**2 + d%s + d%u
     tm = -2 * d%xb * d%p * d%pb
     d%t0 = tp + tm
     d%t1 = tp - tm
     d%t = d%t1
   end subroutine splitting_set_t_bounds
 
 @ %def splitting_set_t_bounds
 @
 \subsection{Sampling recoil}
 Compute a value for the momentum transfer $t$, using a random number
 $r$.  We assume a logarithmic distribution for $t-m^2$, corresponding
 to the propagator $1/(t-m^2)$ with the physical mass $m$ for the
 outgoing particle.  Optionally, we can narrow the kinematical bounds.
 
 If all three masses in the splitting vanish, the upper limit for $t$
 is zero.  In that case, the $t$ value is set to zero and the splitting
 will be collinear.
 <<SF aux: splitting data: TBP>>=
   procedure :: sample_t => splitting_sample_t
 <<SF aux: sub interfaces>>=
     module subroutine splitting_sample_t (d, r, t0, t1)
       class(splitting_data_t), intent(inout) :: d
       real(default), intent(in) :: r
       real(default), intent(in), optional :: t0, t1
     end subroutine splitting_sample_t
 <<SF aux: procedures>>=
   module subroutine splitting_sample_t (d, r, t0, t1)
     class(splitting_data_t), intent(inout) :: d
     real(default), intent(in) :: r
     real(default), intent(in), optional :: t0, t1
     real(default) :: tt0, tt1, tt0m, tt1m
     if (d%collinear) then
        d%t = d%t1
     else
        tt0 = d%t0;  if (present (t0))  tt0 = max (t0, tt0)
        tt1 = d%t1;  if (present (t1))  tt1 = min (t1, tt1)
        tt0m = tt0 - d%m2
        tt1m = tt1 - d%m2
        if (tt0m < 0 .and. tt1m < 0 .and. abs(tt0m) > &
             epsilon(tt0m) .and. abs(tt1m) > epsilon(tt0m)) then
           d%t = d%m2 + tt0m * exp (r * log (tt1m / tt0m))
        else
           d%t = tt1
        end if
     end if
   end subroutine splitting_sample_t
 
 @ %def splitting_sample_t
 @ The inverse operation: Given $t$, we recover the value of $r$ that
 would have produced this value.
 <<SF aux: splitting data: TBP>>=
   procedure :: inverse_t => splitting_inverse_t
 <<SF aux: sub interfaces>>=
     module subroutine splitting_inverse_t (d, r, t0, t1)
       class(splitting_data_t), intent(in) :: d
       real(default), intent(out) :: r
       real(default), intent(in), optional :: t0, t1
     end subroutine splitting_inverse_t
 <<SF aux: procedures>>=
   module subroutine splitting_inverse_t (d, r, t0, t1)
     class(splitting_data_t), intent(in) :: d
     real(default), intent(out) :: r
     real(default), intent(in), optional :: t0, t1
     real(default) :: tt0, tt1, tt0m, tt1m
     if (d%collinear) then
        r = 0
     else
        tt0 = d%t0;  if (present (t0))  tt0 = max (t0, tt0)
        tt1 = d%t1;  if (present (t1))  tt1 = min (t1, tt1)
        tt0m = tt0 - d%m2
        tt1m = tt1 - d%m2
        if (tt0m < 0 .and. tt1m < 0) then
           r = log ((d%t - d%m2) / tt0m) / log (tt1m / tt0m)
        else
           r = 0
        end if
     end if
   end subroutine splitting_inverse_t
 
 @ %def splitting_inverse_t
 @ This is trivial, but provided for convenience:
 <<SF aux: splitting data: TBP>>=
   procedure :: sample_phi => splitting_sample_phi
 <<SF aux: sub interfaces>>=
     module subroutine splitting_sample_phi (d, r)
       class(splitting_data_t), intent(inout) :: d
       real(default), intent(in) :: r
     end subroutine splitting_sample_phi
 <<SF aux: procedures>>=
   module subroutine splitting_sample_phi (d, r)
     class(splitting_data_t), intent(inout) :: d
     real(default), intent(in) :: r
     if (d%collinear) then
        d%phi = 0
     else
        d%phi = (1-r) * d%phi0 + r * d%phi1
     end if
   end subroutine splitting_sample_phi
 
 @ %def splitting_sample_phi
 @ Inverse:
 <<SF aux: splitting data: TBP>>=
   procedure :: inverse_phi => splitting_inverse_phi
 <<SF aux: sub interfaces>>=
     module subroutine splitting_inverse_phi (d, r)
       class(splitting_data_t), intent(in) :: d
       real(default), intent(out) :: r
     end subroutine splitting_inverse_phi
 <<SF aux: procedures>>=
   module subroutine splitting_inverse_phi (d, r)
     class(splitting_data_t), intent(in) :: d
     real(default), intent(out) :: r
     if (d%collinear) then
        r = 0
     else
        r = (d%phi - d%phi0) / (d%phi1 - d%phi0)
     end if
   end subroutine splitting_inverse_phi
 
 @ %def splitting_inverse_phi
 @
 \subsection{Splitting}
 In this function, we actually perform the splitting.  The incoming momentum
 $k$ is split into (if no recoil) $q_1=(1-x)k$ and $q_2=xk$.
 
 Apart from the splitting data, we need the incoming momentum $k$, the momentum
 transfer $t$, and the azimuthal angle $\phi$.  The momentum fraction $x$ is
 already known here.
 
 Alternatively, we can split without recoil.  The azimuthal angle is
 irrelevant, and the momentum transfer is always equal to the upper
 limit $t_1$, so the polar angle is zero.  Obviously, if there are
 nonzero masses it is not possible to keep both energy-momentum
 conservation and at the same time all particles on shell.  We choose
 for dropping the on-shell condition here.
 <<SF aux: splitting data: TBP>>=
   procedure :: split_momentum => splitting_split_momentum
 <<SF aux: sub interfaces>>=
     module function splitting_split_momentum (d, k) result (q)
       class(splitting_data_t), intent(in) :: d
       type(vector4_t), dimension(2) :: q
       type(vector4_t), intent(in) :: k
     end function splitting_split_momentum
 <<SF aux: procedures>>=
   module function splitting_split_momentum (d, k) result (q)
     class(splitting_data_t), intent(in) :: d
     type(vector4_t), dimension(2) :: q
     type(vector4_t), intent(in) :: k
     real(default) :: st2, ct2, st, ct, cp, sp
     type(lorentz_transformation_t) :: rot
     real(default) :: tt0, tt1, den
     type(vector3_t) :: kk, q1, q2
     if (d%collinear) then
        if (vanishes (d%s) .and. vanishes(d%u)) then
           q(1) = d%xb * k
           q(2) = d%x * k
        else
           kk = space_part (k)
           q1 = d%xb * (d%pb / d%p) * kk
           q2 = kk - q1
           q(1) = vector4_moving (d%xb * d%E, q1)
           q(2) = vector4_moving (d%x * d%E, q2)
        end if
     else
        den = 2 * d%xb * d%p * d%pb
        tt0 = max (d%t - d%t0, 0._default)
        tt1 = min (d%t - d%t1, 0._default)
        if (den**2 <= epsilon(den)) then
           st2 = 0
        else
           st2 = - (tt0 * tt1) / den ** 2
        end if
        if (st2 > 1) then
           st2 = 1
        end if
        ct2 = 1 - st2
        st = sqrt (max (st2, 0._default))
        ct = sqrt (max (ct2, 0._default))
        if ((d%t - d%t0 + d%t - d%t1) < 0) then
           ct = - ct
        end if
        sp = sin (d%phi)
        cp = cos (d%phi)
        rot = rotation_to_2nd (3, space_part (k))
        q1 = vector3_moving (d%xb * d%pb * [st * cp, st * sp, ct])
        q2 = vector3_moving (d%p, 3) - q1
        q(1) = rot * vector4_moving (d%xb * d%E, q1)
        q(2) = rot * vector4_moving (d%x * d%E, q2)
     end if
   end function splitting_split_momentum
 
 @ %def splitting_split_momentum
 @
 Momenta generated by splitting will in general be off-shell.  They are
 on-shell only if they are collinear and massless.  This subroutine
 puts them on shell by brute force, violating either momentum or energy
 conservation.  The direction of three-momentum is always retained.
 
 If the energy is below mass shell, we return a zero momentum.
 <<SF aux: parameters>>=
   integer, parameter, public :: KEEP_ENERGY = 0, KEEP_MOMENTUM = 1
 @ %def KEEP_ENERGY KEEP_MOMENTUM
 <<SF aux: public>>=
   public :: on_shell
 <<SF aux: sub interfaces>>=
     elemental module subroutine on_shell (p, m2, keep)
       type(vector4_t), intent(inout) :: p
       real(default), intent(in) :: m2
       integer, intent(in) :: keep
     end subroutine on_shell
 <<SF aux: procedures>>=
   elemental module subroutine on_shell (p, m2, keep)
     type(vector4_t), intent(inout) :: p
     real(default), intent(in) :: m2
     integer, intent(in) :: keep
     real(default) :: E, E2, pn
     select case (keep)
     case (KEEP_ENERGY)
        E = energy (p)
        E2 = E ** 2
        if (E2 >= m2) then
           pn = sqrt (E2 - m2)
           p = vector4_moving (E, pn * direction (space_part (p)))
        else
           p = vector4_null
        end if
     case (KEEP_MOMENTUM)
        E = sqrt (space_part (p) ** 2 + m2)
        p = vector4_moving (E, space_part (p))
     end select
   end subroutine on_shell
 
 @ %def on_shell
 @
 \subsection{Recovering the splitting}
 This is the inverse problem.  We have on-shell momenta and want to
 deduce the splitting parameters $x$, $t$, and $\phi$.
 
 Update 2018-08-22: As a true inverse to [[splitting_split_momentum]], we now use
 not just a single momentum [[q2]] as before, but the momentum pair [[q1]], [[q2]]
 for recovering $x$ and $\bar x$ separately.  If $x$ happens to be
 close to $1$, we would completely lose the tiny $\bar x$ value,
 otherwise, and thus get a meaningless result.
 <<SF aux: splitting data: TBP>>=
   procedure :: recover => splitting_recover
 <<SF aux: sub interfaces>>=
     module subroutine splitting_recover (d, k, q, keep)
       class(splitting_data_t), intent(inout) :: d
       type(vector4_t), intent(in) :: k
       type(vector4_t), dimension(2), intent(in) :: q
       integer, intent(in) :: keep
     end subroutine splitting_recover
 <<SF aux: procedures>>=
   module subroutine splitting_recover (d, k, q, keep)
     class(splitting_data_t), intent(inout) :: d
     type(vector4_t), intent(in) :: k
     type(vector4_t), dimension(2), intent(in) :: q
     integer, intent(in) :: keep
     type(lorentz_transformation_t) :: rot
     type(vector4_t) :: k0
     type(vector4_t), dimension(2) :: q0
     real(default) :: p1, p2, p3, pt2, pp2, pl
     real(default) :: aux, den, norm
     real(default) :: st2, ct2, ct
     rot = inverse (rotation_to_2nd (3, space_part (k)))
     q0 = rot * q
     p1 = vector4_get_component (q0(2), 1)
     p2 = vector4_get_component (q0(2), 2)
     p3 = vector4_get_component (q0(2), 3)
     pt2 = p1 ** 2 + p2 ** 2
     pp2 = p1 ** 2 + p2 ** 2 + p3 ** 2
     pl = abs (p3)
     k0 = vector4_moving (d%E, d%p, 3)
     select case (keep)
     case (KEEP_ENERGY)
        d%x = energy (q0(2)) / d%E
        d%xb = energy (q0(1)) / d%E
        call d%set_t_bounds ()
        if (.not. d%collinear) then
           aux = (d%xb * d%pb) ** 2 * pp2 - d%p ** 2 * pt2
           den = d%p ** 2 - (d%xb * d%pb) ** 2
           if (aux >= 0 .and. den > 0) then
              norm = (d%p * pl + sqrt (aux)) / den
           else
              norm = 1
           end if
        end if
     case (KEEP_MOMENTUM)
        d%xb = sqrt (space_part (q0(1)) ** 2 + d%u) / d%E
        d%x = 1 - d%xb
        call d%set_t_bounds ()
        norm = 1
     end select
     if (d%collinear) then
        d%t = d%t1
        d%phi = 0
     else
        if ((d%xb * d%pb * norm)**2 < epsilon(d%xb)) then
           st2 = 1
        else
           st2 = pt2 / (d%xb * d%pb * norm ) ** 2
        end if
        if (st2 > 1) then
           st2 = 1
        end if
        ct2 = 1 - st2
        ct = sqrt (max (ct2, 0._default))
        if (.not. vanishes (1 + ct)) then
           d%t = d%t1 - 2 * d%xb * d%p * d%pb * st2 / (1 + ct)
        else
           d%t = d%t0
        end if
        if (.not. vanishes (p1) .or. .not. vanishes (p2)) then
           d%phi = atan2 (-p2, -p1)
        else
           d%phi = 0
        end if
     end if
   end subroutine splitting_recover
 
 @ %def splitting_recover
 @
 \subsection{Extract data}
 <<SF aux: splitting data: TBP>>=
   procedure :: get_x => splitting_get_x
   procedure :: get_xb => splitting_get_xb
 <<SF aux: sub interfaces>>=
     module function splitting_get_x (sd) result (x)
       class(splitting_data_t), intent(in) :: sd
       real(default) :: x
     end function splitting_get_x
     module function splitting_get_xb (sd) result (xb)
       class(splitting_data_t), intent(in) :: sd
       real(default) :: xb
     end function splitting_get_xb
 <<SF aux: procedures>>=
   module function splitting_get_x (sd) result (x)
     class(splitting_data_t), intent(in) :: sd
     real(default) :: x
     x = sd%x
   end function splitting_get_x
 
   module function splitting_get_xb (sd) result (xb)
     class(splitting_data_t), intent(in) :: sd
     real(default) :: xb
     xb = sd%xb
   end function splitting_get_xb
 
 @ %def splitting_get_x
 @ %def splitting_get_xb
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_aux_ut.f90]]>>=
 <<File header>>
 
 module sf_aux_ut
   use unit_tests
   use sf_aux_uti
 
 <<Standard module head>>
 
 <<SF aux: public test>>
 
 contains
 
 <<SF aux: test driver>>
 
 end module sf_aux_ut
 @ %def sf_aux_ut
 @
 <<[[sf_aux_uti.f90]]>>=
 <<File header>>
 
 module sf_aux_uti
 
 <<Use kinds>>
   use numeric_utils, only: pacify
   use lorentz
 
   use sf_aux
 
 <<Standard module head>>
 
 <<SF aux: test declarations>>
 
 contains
 
 <<SF aux: tests>>
 
 end module sf_aux_uti
 @ %def sf_aux_ut
 @ API: driver for the unit tests below.
 <<SF aux: public test>>=
   public :: sf_aux_test
 <<SF aux: test driver>>=
   subroutine sf_aux_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF aux: execute tests>>
   end subroutine sf_aux_test
 
 @ %def sf_aux_test
 @
 \subsubsection{Momentum splitting: massless radiation}
 Compute momentum splitting for generic kinematics.  It turns out that
 for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and
 lower bounds (this can be directly seen from the logarithmic
 distribution in the function [[sample_t]] for $r \equiv x = 1 - x =
 0.5$), we arrive at an exact number $t=-0.15$ for the given
 input values.
 <<SF aux: execute tests>>=
   call test (sf_aux_1, "sf_aux_1", &
        "massless radiation", &
        u, results)
 <<SF aux: test declarations>>=
   public :: sf_aux_1
 <<SF aux: tests>>=
   subroutine sf_aux_1 (u)
     integer, intent(in) :: u
     type(splitting_data_t) :: sd
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q, q0
     real(default) :: E, mk, mp, mq
     real(default) :: x, r1, r2, r1o, r2o
     real(default) :: k2, q0_2, q1_2, q2_2
 
     write (u, "(A)")  "* Test output: sf_aux_1"
     write (u, "(A)")  "*   Purpose: compute momentum splitting"
     write (u, "(A)")  "             (massless radiated particle)"
     write (u, "(A)")
 
     E = 1
     mk = 0.3_default
     mp = 0
     mq = mk
 
     k = vector4_moving (E, sqrt (E**2 - mk**2), 3)
     k2 = k ** 2;  call pacify (k2, 1e-10_default)
 
     x = 0.6_default
     r1 = 0.5_default
     r2 = 0.125_default
 
     write (u, "(A)")  "* (1) Non-collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%sample_t (r1)
     call sd%sample_phi (r2)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "Extract: x, 1-x"
     write (u, "(2(1x,F11.8))")  sd%get_x (), sd%get_xb ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q0_2 = q0(2) ** 2;  call pacify (q0_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q0_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
 
     call sd%inverse_t (r1o)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q0_2 = q0(2) ** 2;  call pacify (q0_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q0_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     call sd%inverse_t (r1o)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (2) Collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, 1 - x)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q0_2 = q0(2) ** 2;  call pacify (q0_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q0_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q0_2 = q0(2) ** 2;  call pacify (q0_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q0_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_aux_1"
 
   end subroutine sf_aux_1
 
 @ %def sf_aux_1
 @
 \subsubsection{Momentum splitting: massless parton}
 Compute momentum splitting for generic kinematics.  It turns out that
 for $x=0.5$, where $t-m^2$ is the geometric mean between its upper and
 lower bounds, we arrive at an exact number $t=-0.36$ for the given
 input values.
 <<SF aux: execute tests>>=
   call test (sf_aux_2, "sf_aux_2", &
        "massless parton", &
        u, results)
 <<SF aux: test declarations>>=
   public :: sf_aux_2
 <<SF aux: tests>>=
   subroutine sf_aux_2 (u)
     integer, intent(in) :: u
     type(splitting_data_t) :: sd
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q, q0
     real(default) :: E, mk, mp, mq
     real(default) :: x, r1, r2, r1o, r2o
     real(default) :: k2, q02_2, q1_2, q2_2
 
     write (u, "(A)")  "* Test output: sf_aux_2"
     write (u, "(A)")  "*   Purpose: compute momentum splitting"
     write (u, "(A)")  "             (massless outgoing particle)"
     write (u, "(A)")
 
     E = 1
     mk = 0.3_default
     mp = mk
     mq = 0
 
     k = vector4_moving (E, sqrt (E**2 - mk**2), 3)
     k2 = k ** 2;  call pacify (k2, 1e-10_default)
 
     x = 0.6_default
     r1 = 0.5_default
     r2 = 0.125_default
 
     write (u, "(A)")  "* (1) Non-collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%sample_t (r1)
     call sd%sample_phi (r2)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
 
     call sd%inverse_t (r1o)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     call sd%inverse_t (r1o)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (2) Collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, 1 - x)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_aux_2"
 
   end subroutine sf_aux_2
 
 @ %def sf_aux_2
 @
 \subsubsection{Momentum splitting: all massless}
 Compute momentum splitting for massless kinematics.  In the non-collinear
 case, we need a lower cutoff for $|t|$, otherwise a logarithmic distribution
 is not possible.
 <<SF aux: execute tests>>=
   call test (sf_aux_3, "sf_aux_3", &
        "massless parton", &
        u, results)
 <<SF aux: test declarations>>=
   public :: sf_aux_3
 <<SF aux: tests>>=
   subroutine sf_aux_3 (u)
     integer, intent(in) :: u
     type(splitting_data_t) :: sd
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q, q0
     real(default) :: E, mk, mp, mq, qmin, qmax
     real(default) :: x, r1, r2, r1o, r2o
     real(default) :: k2, q02_2, q1_2, q2_2
 
     write (u, "(A)")  "* Test output: sf_aux_3"
     write (u, "(A)")  "*   Purpose: compute momentum splitting"
     write (u, "(A)")  "             (all massless, q cuts)"
     write (u, "(A)")
 
     E = 1
     mk = 0
     mp = 0
     mq = 0
     qmin = 1e-2_default
     qmax = 1e0_default
 
     k = vector4_moving (E, sqrt (E**2 - mk**2), 3)
     k2 = k ** 2;  call pacify (k2, 1e-10_default)
 
     x = 0.6_default
     r1 = 0.5_default
     r2 = 0.125_default
 
     write (u, "(A)")  "* (1) Non-collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%sample_t (r1, t1 = - qmin ** 2, t0 = - qmax **2)
     call sd%sample_phi (r2)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
 
     call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     call sd%inverse_t (r1o, t1 = - qmin ** 2, t0 = - qmax **2)
 
     write (u, "(A)")  "Compare: r1"
     write (u, "(2(1x,F11.8))")  r1, r1o
 
     call sd%inverse_phi (r2o)
 
     write (u, "(A)")  "Compare: r2"
     write (u, "(2(1x,F11.8))")  r2, r2o
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (2) Collinear setup"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, 1 - x)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
     q1_2 = q(1) ** 2;  call pacify (q1_2, 1e-10_default)
     q2_2 = q(2) ** 2;  call pacify (q2_2, 1e-10_default)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: s"
     write (u, "(2(1x,F11.8))")  sd%s, k2
 
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  sd%t, q2_2
 
     write (u, "(A)")  "Compare: u"
     write (u, "(2(1x,F11.8))")  sd%u, q1_2
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  sd%x, energy (q(2)) / energy (k)
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  sd%xb, energy (q(1)) / energy (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep energy)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_ENERGY)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Project on-shell (keep momentum)"
 
     q0 = q
     call on_shell (q0, [mp**2, mq**2], KEEP_MOMENTUM)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q0), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q0(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q0(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "Compare: mo^2"
     q02_2 = q0(2) ** 2;  call pacify (q02_2, 1e-10_default)
     write (u, "(2(1x,F11.8))")  sd%m2, q02_2
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momentum"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2)
     call sd%set_t_bounds (x, 1 - x)
     call sd%recover (k, q0, KEEP_MOMENTUM)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
     write (u, "(A)")  "Compare: t"
     write (u, "(2(1x,F11.8))")  q2_2, sd%t
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_aux_3"
 
   end subroutine sf_aux_3
 
 @ %def sf_aux_3
 @
 \subsubsection{Endpoint stability}
 Compute momentum splitting for collinear kinematics close to both
 endpoints.  In particular, check both directions $x\to$ momenta and
 momenta $\to x$.
 
 For purely massless collinear splitting, the [[KEEP_XXX]] flag is
 irrelevant.  We choose [[KEEP_ENERGY]] here.
 <<SF aux: execute tests>>=
   call test (sf_aux_4, "sf_aux_4", &
        "endpoint numerics", &
        u, results)
 <<SF aux: test declarations>>=
   public :: sf_aux_4
 <<SF aux: tests>>=
   subroutine sf_aux_4 (u)
     integer, intent(in) :: u
     type(splitting_data_t) :: sd
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E, mk, mp, mq, qmin, qmax
     real(default) :: x, xb
 
     write (u, "(A)")  "* Test output: sf_aux_4"
     write (u, "(A)")  "*   Purpose: compute massless collinear splitting near endpoint"
 
     E = 1
     mk = 0
     mp = 0
     mq = 0
     qmin = 1e-2_default
     qmax = 1e0_default
 
     k = vector4_moving (E, sqrt (E**2 - mk**2), 3)
 
     x = 0.1_default
     xb = 1 - x
 
     write (u, "(A)")
     write (u, "(A)")  "* (1) Collinear setup, moderate kinematics"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momenta"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
     call sd%recover (k, q, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  xb, sd%xb
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (2) Close to x=0"
     write (u, "(A)")
 
     x = 1e-9_default
     xb = 1 - x
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momenta"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
     call sd%recover (k, q, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  xb, sd%xb
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* (3) Close to x=1"
     write (u, "(A)")
 
     xb = 1e-9_default
     x = 1 - xb
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
 
     call sd%write (u)
 
     q = sd%split_momentum (k)
 
     write (u, "(A)")
     write (u, "(A)")  "Incoming momentum k ="
     call vector4_write (k, u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum sum p + q ="
     call vector4_write (sum (q), u)
     write (u, "(A)")
     write (u, "(A)")  "Radiated momentum p ="
     call vector4_write (q(1), u)
     write (u, "(A)")
     write (u, "(A)")  "Outgoing momentum q ="
     call vector4_write (q(2), u)
     write (u, "(A)")
 
     write (u, "(A)")  "* Recover parameters from outgoing momenta"
     write (u, "(A)")
 
     call sd%init (k, mk**2, mp**2, mq**2, collinear = .true.)
     call sd%set_t_bounds (x, xb)
     call sd%recover (k, q, KEEP_ENERGY)
 
     write (u, "(A)")  "Compare: x"
     write (u, "(2(1x,F11.8))")  x, sd%x
 
     write (u, "(A)")  "Compare: 1-x"
     write (u, "(2(1x,F11.8))")  xb, sd%xb
 
     write (u, "(A)")
     call sd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_aux_4"
 
   end subroutine sf_aux_4
 
 @ %def sf_aux_4
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Mappings for structure functions}
 In this module, we provide a wrapper for useful mappings of the unit
 (hyper-)square that we can apply to a set of structure functions.
 
 In some cases it is useful, or even mandatory, to map the MC input
 parameters nontrivially onto a set of structure functions for the two
 beams.  In all cases considered here, instead of $x_1,x_2,\ldots$ as
 parameters for the beams, we generate one parameter that is equal, or
 related to, the product $x_1x_2\cdots$ (so it directly corresponds to
 $\sqrt{s}$).  The other parameters describe the distribution of energy
 (loss) between beams and radiations.
 <<[[sf_mappings.f90]]>>=
 <<File header>>
 
 module sf_mappings
 
 <<Use kinds>>
   use kinds, only: double
 
 <<Standard module head>>
 
 <<SF mappings: public>>
 
 <<SF mappings: parameters>>
 
 <<SF mappings: types>>
 
 <<SF mappings: interfaces>>
 
   interface
 <<SF mappings: sub interfaces>>
   end interface
 
 contains
 
 <<SF mappings: main procedures>>
 
 end module sf_mappings
 @ %def sf_mappings
 @
 <<[[sf_mappings_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_mappings) sf_mappings_s
 
   use io_units
   use constants, only: pi, zero, one
   use numeric_utils
   use diagnostics
 
   implicit none
 
 contains
 
 <<SF mappings: procedures>>
 
 end submodule sf_mappings_s
 
 @ %def sf_mappings_s
 @
 \subsection{Base type}
 First, we define an abstract base type for the mapping.  In all cases
 we need to store the indices of the parameters on which the mapping
 applies.   Additional parameters can be stored in the extensions of
 this type.
 <<SF mappings: public>>=
   public :: sf_mapping_t
 <<SF mappings: types>>=
   type, abstract :: sf_mapping_t
      integer, dimension(:), allocatable :: i
    contains
    <<SF mappings: sf mapping: TBP>>
   end type sf_mapping_t
 
 @ %def sf_mapping_t
 @ The output routine is deferred:
 <<SF mappings: sf mapping: TBP>>=
   procedure (sf_mapping_write), deferred :: write
 <<SF mappings: interfaces>>=
   abstract interface
      subroutine sf_mapping_write (object, unit)
        import
        class(sf_mapping_t), intent(in) :: object
        integer, intent(in), optional :: unit
      end subroutine sf_mapping_write
   end interface
 
 @ %def sf_mapping_write
 @ Initializer for the base type.  The array of parameter indices is
 allocated but initialized to zero.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: base_init => sf_mapping_base_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_mapping_base_init (mapping, n_par)
       class(sf_mapping_t), intent(out) :: mapping
       integer, intent(in) :: n_par
     end subroutine sf_mapping_base_init
 <<SF mappings: procedures>>=
   module subroutine sf_mapping_base_init (mapping, n_par)
     class(sf_mapping_t), intent(out) :: mapping
     integer, intent(in) :: n_par
     allocate (mapping%i (n_par))
     mapping%i = 0
   end subroutine sf_mapping_base_init
 
 @ %def sf_mapping_base_init
 @ Set an index value.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: set_index => sf_mapping_set_index
 <<SF mappings: sub interfaces>>=
     module subroutine sf_mapping_set_index (mapping, j, i)
       class(sf_mapping_t), intent(inout) :: mapping
       integer, intent(in) :: j, i
     end subroutine sf_mapping_set_index
 <<SF mappings: procedures>>=
   module subroutine sf_mapping_set_index (mapping, j, i)
     class(sf_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j, i
     mapping%i(j) = i
   end subroutine sf_mapping_set_index
 
 @ %def sf_mapping_set_index
 @ Retrieve an index value.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: get_index => sf_mapping_get_index
 <<SF mappings: sub interfaces>>=
     module function sf_mapping_get_index (mapping, j) result (i)
       class(sf_mapping_t), intent(inout) :: mapping
       integer, intent(in) :: j
       integer :: i
     end function sf_mapping_get_index
 <<SF mappings: procedures>>=
   module function sf_mapping_get_index (mapping, j) result (i)
     class(sf_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j
     integer :: i
     i = mapping%i(j)
   end function sf_mapping_get_index
 
 @ %def sf_mapping_get_index
 @ Return the dimensionality, i.e., the number of parameters.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: get_n_dim => sf_mapping_get_n_dim
 <<SF mappings: sub interfaces>>=
     module function sf_mapping_get_n_dim (mapping) result (n)
       class(sf_mapping_t), intent(in) :: mapping
       integer :: n
     end function sf_mapping_get_n_dim
 <<SF mappings: procedures>>=
   module function sf_mapping_get_n_dim (mapping) result (n)
     class(sf_mapping_t), intent(in) :: mapping
     integer :: n
     n = size (mapping%i)
   end function sf_mapping_get_n_dim
 
 @ %def sf_mapping_get_n_dim
 @ Computation: the values [[p]] are the input parameters, the values
 [[r]] are the output parameters.  The values [[rb]] are defined as
 $\bar r = 1 - r$, but provided explicitly.  They allow us to avoid
 numerical problems near $r=1$.
 
 The extra parameter [[x_free]]
 indicates that the total energy has already been renormalized by this
 factor.  We have to take such a factor into account in a resonance or
 on-shell mapping.
 
 The Jacobian is [[f]].  We modify only
 the two parameters indicated by the indices [[i]].
 <<SF mappings: sf mapping: TBP>>=
   procedure (sf_mapping_compute), deferred :: compute
 <<SF mappings: interfaces>>=
   abstract interface
      subroutine sf_mapping_compute (mapping, r, rb, f, p, pb, x_free)
        import
        class(sf_mapping_t), intent(inout) :: mapping
        real(default), dimension(:), intent(out) :: r, rb
        real(default), intent(out) :: f
        real(default), dimension(:), intent(in) :: p, pb
        real(default), intent(inout), optional :: x_free
      end subroutine sf_mapping_compute
   end interface
 
 @ %def sf_mapping_compute
 @ The inverse mapping.  Use [[r]] and/or [[rb]] to reconstruct [[p]]
 and also compute [[f]].
 <<SF mappings: sf mapping: TBP>>=
   procedure (sf_mapping_inverse), deferred :: inverse
 <<SF mappings: interfaces>>=
   abstract interface
      subroutine sf_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
        import
        class(sf_mapping_t), intent(inout) :: mapping
        real(default), dimension(:), intent(in) :: r, rb
        real(default), intent(out) :: f
        real(default), dimension(:), intent(out) :: p, pb
        real(default), intent(inout), optional :: x_free
      end subroutine sf_mapping_inverse
   end interface
 
 @ %def sf_mapping_inverse
 @
 \subsection{Methods for self-tests}
 This is a shorthand for: inject parameters, compute the mapping,
 display results, compute the inverse, display again.  We provide an
 output format for the parameters and, optionally, a different output
 format for the Jacobians.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: check => sf_mapping_check
 <<SF mappings: sub interfaces>>=
     module subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f)
       class(sf_mapping_t), intent(inout) :: mapping
       integer, intent(in) :: u
       real(default), dimension(:), intent(in) :: p_in, pb_in
       character(*), intent(in) :: fmt_p
       character(*), intent(in), optional :: fmt_f
     end subroutine sf_mapping_check
 <<SF mappings: procedures>>=
   module subroutine sf_mapping_check (mapping, u, p_in, pb_in, fmt_p, fmt_f)
     class(sf_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: u
     real(default), dimension(:), intent(in) :: p_in, pb_in
     character(*), intent(in) :: fmt_p
     character(*), intent(in), optional :: fmt_f
     real(default), dimension(size(p_in)) :: p, pb, r, rb
+    real(default), dimension(size(p_in)) :: p_orig, pb_orig, r_orig, rb_orig
     real(default) :: f, tolerance
     tolerance = 1.5E-17_default
     p = p_in
     pb= pb_in
     call mapping%compute (r, rb, f, p, pb)
+    p_orig = p
+    pb_orig = pb
+    r_orig = r
+    rb_orig = rb
     call pacify (p, tolerance)
     call pacify (pb, tolerance)
     call pacify (r, tolerance)
     call pacify (rb, tolerance)
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "p =", p
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "pb=", pb
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "r =", r
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "rb=", rb
     if (present (fmt_f)) then
        write (u, "(3x,A,9(1x," // fmt_f // "))")  "f =", f
     else
        write (u, "(3x,A,9(1x," // fmt_p // "))")  "f =", f
     end if
     write (u, *)
-    call mapping%inverse (r, rb, f, p, pb)
+    call mapping%inverse (r_orig, rb_orig, f, p_orig, pb_orig)
+    p = p_orig
+    pb = pb_orig
+    r = r_orig
+    rb = rb_orig
     call pacify (p, tolerance)
     call pacify (pb, tolerance)
     call pacify (r, tolerance)
     call pacify (rb, tolerance)
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "p =", p
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "pb=", pb
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "r =", r
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "rb=", rb
     if (present (fmt_f)) then
        write (u, "(3x,A,9(1x," // fmt_f // "))")  "f =", f
     else
        write (u, "(3x,A,9(1x," // fmt_p // "))")  "f =", f
     end if
     write (u, *)
     write (u, "(3x,A,9(1x," // fmt_p // "))")  "*r=", product (r)
   end subroutine sf_mapping_check
 
 @ %def sf_mapping_check
 @ This is a consistency check for the self-tests: the integral over the unit
 square should be unity.  We estimate this by a simple binning and adding up
 the values; this should be sufficient for a self-test.
 
 The argument is the requested number of sampling points.  We take the square
 root for binning in both dimensions, so the precise number might be
 different.
 <<SF mappings: sf mapping: TBP>>=
   procedure :: integral => sf_mapping_integral
 <<SF mappings: sub interfaces>>=
     module function sf_mapping_integral (mapping, n_calls) result (integral)
       class(sf_mapping_t), intent(inout) :: mapping
       integer, intent(in) :: n_calls
       real(default) :: integral
     end function sf_mapping_integral
 <<SF mappings: procedures>>=
   module function sf_mapping_integral (mapping, n_calls) result (integral)
     class(sf_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: n_calls
     real(default) :: integral
     integer :: n_dim, n_bin, k
     real(default), dimension(:), allocatable :: p, pb, r, rb
     integer, dimension(:), allocatable :: ii
     real(default) :: dx, f, s
 
     n_dim = mapping%get_n_dim ()
     allocate (p (n_dim))
     allocate (pb(n_dim))
     allocate (r (n_dim))
     allocate (rb(n_dim))
     allocate (ii(n_dim))
     n_bin = nint (real (n_calls, default) ** (1._default / n_dim))
     dx = 1._default / n_bin
     s = 0
     ii = 1
 
     SAMPLE: do
        do k = 1, n_dim
           p(k)  = ii(k) * dx - dx/2
           pb(k) = (n_bin - ii(k)) * dx + dx/2
        end do
        call mapping%compute (r, rb, f, p, pb)
        s = s + f
        INCR: do k = 1, n_dim
           ii(k) = ii(k) + 1
           if (ii(k) <= n_bin) then
              exit INCR
           else if (k < n_dim) then
              ii(k) = 1
           else
              exit SAMPLE
           end if
        end do INCR
     end do SAMPLE
 
     integral = s / real (n_bin, default) ** n_dim
 
   end function sf_mapping_integral
 
 @ %def sf_mapping_integral
 @
 \subsection{Implementation: standard mapping}
 This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
 while $p_2$ is related to the ratio.
 <<SF mappings: public>>=
   public :: sf_s_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_s_mapping_t
      logical :: power_set = .false.
      real(default) :: power = 1
    contains
    <<SF mappings: sf standard mapping: TBP>>
   end type sf_s_mapping_t
 
 @ %def sf_s_mapping_t
 @ Output.
 <<SF mappings: sf standard mapping: TBP>>=
   procedure :: write => sf_s_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_s_mapping_write (object, unit)
       class(sf_s_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_s_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_s_mapping_write (object, unit)
     class(sf_s_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A)")  ": standard (", object%power, ")"
   end subroutine sf_s_mapping_write
 
 @ %def sf_s_mapping_write
 @ Initialize: index pair and power parameter.
 <<SF mappings: sf standard mapping: TBP>>=
   procedure :: init => sf_s_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_s_mapping_init (mapping, power)
       class(sf_s_mapping_t), intent(out) :: mapping
       real(default), intent(in), optional :: power
     end subroutine sf_s_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_s_mapping_init (mapping, power)
     class(sf_s_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: power
     call mapping%base_init (2)
     if (present (power)) then
        mapping%power_set = .true.
        mapping%power = power
     end if
   end subroutine sf_s_mapping_init
 
 @ %def sf_s_mapping_init
 @ Apply mapping.
 <<SF mappings: sf standard mapping: TBP>>=
   procedure :: compute => sf_s_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_s_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_s_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_s_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_s_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2
     integer :: j
     if (mapping%power_set) then
        call map_unit_square (r2, f, p(mapping%i), mapping%power)
     else
        call map_unit_square (r2, f, p(mapping%i))
     end if
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_s_mapping_compute
 
 @ %def sf_s_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf standard mapping: TBP>>=
   procedure :: inverse => sf_s_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_s_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_s_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_s_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_s_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: p2
     integer :: j
     if (mapping%power_set) then
        call map_unit_square_inverse (r(mapping%i), f, p2, mapping%power)
     else
        call map_unit_square_inverse (r(mapping%i), f, p2)
     end if
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = 1 - p2(j)
     end do
   end subroutine sf_s_mapping_inverse
 
 @ %def sf_s_mapping_inverse
 @
 \subsection{Implementation: resonance pair mapping}
 This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
 while $p_2$ is related to the ratio, then it maps $p_1$ to itself
 according to a Breit-Wigner shape, i.e., a flat prior distribution in $p_1$
 results in a Breit-Wigner distribution.  Mass and width of the BW are
 rescaled by the energy, thus dimensionless fractions.
 <<SF mappings: public>>=
   public :: sf_res_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_res_mapping_t
      real(default) :: m = 0
      real(default) :: w = 0
    contains
    <<SF mappings: sf resonance mapping: TBP>>
   end type sf_res_mapping_t
 
 @ %def sf_res_mapping_t
 @ Output.
 <<SF mappings: sf resonance mapping: TBP>>=
   procedure :: write => sf_res_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_res_mapping_write (object, unit)
       class(sf_res_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_res_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_res_mapping_write (object, unit)
     class(sf_res_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,', ',F7.5,A)")  ": resonance (", object%m, object%w, ")"
   end subroutine sf_res_mapping_write
 
 @ %def sf_res_mapping_write
 @ Initialize: index pair and dimensionless mass and width parameters.
 <<SF mappings: sf resonance mapping: TBP>>=
   procedure :: init => sf_res_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_res_mapping_init (mapping, m, w)
       class(sf_res_mapping_t), intent(out) :: mapping
       real(default), intent(in) :: m, w
     end subroutine sf_res_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_res_mapping_init (mapping, m, w)
     class(sf_res_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: m, w
     call mapping%base_init (2)
     mapping%m = m
     mapping%w = w
   end subroutine sf_res_mapping_init
 
 @ %def sf_res_mapping_init
 @ Apply mapping.
 <<SF mappings: sf resonance mapping: TBP>>=
   procedure :: compute => sf_res_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_res_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_res_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_res_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_res_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, p2
     real(default) :: fbw, f2, p1m
     integer :: j
     p2 = p(mapping%i)
     call map_breit_wigner &
          (p1m, fbw, p2(1), mapping%m, mapping%w, x_free)
     call map_unit_square (r2, f2, [p1m, p2(2)])
     f = fbw * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_res_mapping_compute
 
 @ %def sf_res_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf resonance mapping: TBP>>=
   procedure :: inverse => sf_res_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_res_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_res_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_res_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_res_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: p2
     real(default) :: fbw, f2, p1m
     call map_unit_square_inverse (r(mapping%i), f2, p2)
     call map_breit_wigner_inverse &
          (p2(1), fbw, p1m, mapping%m, mapping%w, x_free)
     p = r
     pb= rb
     p (mapping%i(1)) = p1m
     pb(mapping%i(1)) = 1 - p1m
     p (mapping%i(2)) = p2(2)
     pb(mapping%i(2)) = 1 - p2(2)
     f = fbw * f2
   end subroutine sf_res_mapping_inverse
 
 @ %def sf_res_mapping_inverse
 @
 \subsection{Implementation: resonance single mapping}
 While simpler, this is needed for structure-function setups only in
 exceptional cases.
 
 This maps the unit interval ($r_1$) to itself
 according to a Breit-Wigner shape, i.e., a flat prior distribution in $r_1$
 results in a Breit-Wigner distribution.  Mass and width of the BW are
 rescaled by the energy, thus dimensionless fractions.
 <<SF mappings: public>>=
   public :: sf_res_mapping_single_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_res_mapping_single_t
      real(default) :: m = 0
      real(default) :: w = 0
    contains
    <<SF mappings: sf resonance single mapping: TBP>>
   end type sf_res_mapping_single_t
 
 @ %def sf_res_mapping_single_t
 @ Output.
 <<SF mappings: sf resonance single mapping: TBP>>=
   procedure :: write => sf_res_mapping_single_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_res_mapping_single_write (object, unit)
       class(sf_res_mapping_single_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_res_mapping_single_write
 <<SF mappings: procedures>>=
   module subroutine sf_res_mapping_single_write (object, unit)
     class(sf_res_mapping_single_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,', ',F7.5,A)")  ": resonance (", object%m, object%w, ")"
   end subroutine sf_res_mapping_single_write
 
 @ %def sf_res_mapping_single_write
 @ Initialize: single index (!) and dimensionless mass and width parameters.
 <<SF mappings: sf resonance single mapping: TBP>>=
   procedure :: init => sf_res_mapping_single_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_res_mapping_single_init (mapping, m, w)
       class(sf_res_mapping_single_t), intent(out) :: mapping
       real(default), intent(in) :: m, w
     end subroutine sf_res_mapping_single_init
 <<SF mappings: procedures>>=
   module subroutine sf_res_mapping_single_init (mapping, m, w)
     class(sf_res_mapping_single_t), intent(out) :: mapping
     real(default), intent(in) :: m, w
     call mapping%base_init (1)
     mapping%m = m
     mapping%w = w
   end subroutine sf_res_mapping_single_init
 
 @ %def sf_res_mapping_single_init
 @ Apply mapping.
 <<SF mappings: sf resonance single mapping: TBP>>=
   procedure :: compute => sf_res_mapping_single_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_res_mapping_single_compute &
          (mapping, r, rb, f, p, pb, x_free)
       class(sf_res_mapping_single_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_res_mapping_single_compute
 <<SF mappings: procedures>>=
   module subroutine sf_res_mapping_single_compute &
        (mapping, r, rb, f, p, pb, x_free)
     class(sf_res_mapping_single_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(1) :: r2, p2
     real(default) :: fbw
     integer :: j
     p2 = p(mapping%i)
     call map_breit_wigner &
          (r2(1), fbw, p2(1), mapping%m, mapping%w, x_free)
     f = fbw
     r = p
     rb= pb
     r (mapping%i(1)) = r2(1)
     rb(mapping%i(1)) = 1 - r2(1)
   end subroutine sf_res_mapping_single_compute
 
 @ %def sf_res_mapping_single_compute
 @ Apply inverse.
 <<SF mappings: sf resonance single mapping: TBP>>=
   procedure :: inverse => sf_res_mapping_single_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_res_mapping_single_inverse &
          (mapping, r, rb, f, p, pb, x_free)
       class(sf_res_mapping_single_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_res_mapping_single_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_res_mapping_single_inverse &
        (mapping, r, rb, f, p, pb, x_free)
     class(sf_res_mapping_single_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(1) :: p2
     real(default) :: fbw
     call map_breit_wigner_inverse &
          (r(mapping%i(1)), fbw, p2(1), mapping%m, mapping%w, x_free)
     p = r
     pb= rb
     p (mapping%i(1)) = p2(1)
     pb(mapping%i(1)) = 1 - p2(1)
     f = fbw
   end subroutine sf_res_mapping_single_inverse
 
 @ %def sf_res_mapping_single_inverse
 @
 \subsection{Implementation: on-shell mapping}
 This is a degenerate version of the unit-square mapping where the
 product $r_1r_2$ is constant.  This product is given by the rescaled
 squared mass.  We introduce an artificial first parameter $p_1$ to
 keep the counting, but nothing depends on it.  The second parameter is
 the same $p_2$ as for the standard unit-square mapping for $\alpha=1$,
 it parameterizes the ratio of $r_1$ and $r_2$.
 <<SF mappings: public>>=
   public :: sf_os_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_os_mapping_t
      real(default) :: m = 0
      real(default) :: lm2 = 0
    contains
    <<SF mappings: sf on-shell mapping: TBP>>
   end type sf_os_mapping_t
 
 @ %def sf_os_mapping_t
 @ Output.
 <<SF mappings: sf on-shell mapping: TBP>>=
   procedure :: write => sf_os_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_os_mapping_write (object, unit)
       class(sf_os_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_os_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_os_mapping_write (object, unit)
     class(sf_os_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A)")  ": on-shell (", object%m, ")"
   end subroutine sf_os_mapping_write
 
 @ %def sf_os_mapping_write
 @ Initialize: index pair and dimensionless mass parameter.
 <<SF mappings: sf on-shell mapping: TBP>>=
   procedure :: init => sf_os_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_os_mapping_init (mapping, m)
       class(sf_os_mapping_t), intent(out) :: mapping
       real(default), intent(in) :: m
     end subroutine sf_os_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_os_mapping_init (mapping, m)
     class(sf_os_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: m
     call mapping%base_init (2)
     mapping%m = m
     mapping%lm2 = abs (2 * log (mapping%m))
   end subroutine sf_os_mapping_init
 
 @ %def sf_os_mapping_init
 @ Apply mapping.  The [[x_free]] parameter rescales the total energy,
 which must be accounted for in the enclosed mapping.
 <<SF mappings: sf on-shell mapping: TBP>>=
   procedure :: compute => sf_os_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_os_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_os_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_os_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_os_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, p2
     integer :: j
     p2 = p(mapping%i)
     call map_on_shell (r2, f, p2, mapping%lm2, x_free)
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_os_mapping_compute
 
 @ %def sf_os_mapping_compute
 @ Apply inverse.  The irrelevant parameter $p_1$ is always set zero.
 <<SF mappings: sf on-shell mapping: TBP>>=
   procedure :: inverse => sf_os_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_os_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_os_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_os_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_os_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: p2, r2
     r2 = r(mapping%i)
     call map_on_shell_inverse (r2, f, p2, mapping%lm2, x_free)
     p = r
     pb= rb
     p (mapping%i(1)) = p2(1)
     pb(mapping%i(1)) = 1 - p2(1)
     p (mapping%i(2)) = p2(2)
     pb(mapping%i(2)) = 1 - p2(2)
   end subroutine sf_os_mapping_inverse
 
 @ %def sf_os_mapping_inverse
 @
 \subsection{Implementation: on-shell single mapping}
 This is a degenerate version of the unit-interval mapping where the
 result $r$ is constant.  The value is given by the rescaled squared
 mass.  The input parameter $p_1$ is actually ignored, nothing depends
 on it.
 <<SF mappings: public>>=
   public :: sf_os_mapping_single_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_os_mapping_single_t
      real(default) :: m = 0
      real(default) :: lm2 = 0
    contains
    <<SF mappings: sf on-shell mapping single: TBP>>
   end type sf_os_mapping_single_t
 
 @ %def sf_os_mapping_single_t
 @ Output.
 <<SF mappings: sf on-shell mapping single: TBP>>=
   procedure :: write => sf_os_mapping_single_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_os_mapping_single_write (object, unit)
       class(sf_os_mapping_single_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_os_mapping_single_write
 <<SF mappings: procedures>>=
   module subroutine sf_os_mapping_single_write (object, unit)
     class(sf_os_mapping_single_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A)")  ": on-shell (", object%m, ")"
   end subroutine sf_os_mapping_single_write
 
 @ %def sf_os_mapping_single_write
 @ Initialize: index pair and dimensionless mass parameter.
 <<SF mappings: sf on-shell mapping single: TBP>>=
   procedure :: init => sf_os_mapping_single_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_os_mapping_single_init (mapping, m)
       class(sf_os_mapping_single_t), intent(out) :: mapping
       real(default), intent(in) :: m
     end subroutine sf_os_mapping_single_init
 <<SF mappings: procedures>>=
   module subroutine sf_os_mapping_single_init (mapping, m)
     class(sf_os_mapping_single_t), intent(out) :: mapping
     real(default), intent(in) :: m
     call mapping%base_init (1)
     mapping%m = m
     mapping%lm2 = abs (2 * log (mapping%m))
   end subroutine sf_os_mapping_single_init
 
 @ %def sf_os_mapping_single_init
 @ Apply mapping.  The [[x_free]] parameter rescales the total energy,
 which must be accounted for in the enclosed mapping.
 <<SF mappings: sf on-shell mapping single: TBP>>=
   procedure :: compute => sf_os_mapping_single_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_os_mapping_single_compute &
          (mapping, r, rb, f, p, pb, x_free)
       class(sf_os_mapping_single_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_os_mapping_single_compute
 <<SF mappings: procedures>>=
   module subroutine sf_os_mapping_single_compute &
        (mapping, r, rb, f, p, pb, x_free)
     class(sf_os_mapping_single_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(1) :: r2, p2
     integer :: j
     p2 = p(mapping%i)
     call map_on_shell_single (r2, f, p2, mapping%lm2, x_free)
     r = p
     rb= pb
     r (mapping%i(1)) = r2(1)
     rb(mapping%i(1)) = 1 - r2(1)
   end subroutine sf_os_mapping_single_compute
 
 @ %def sf_os_mapping_single_compute
 @ Apply inverse.  The irrelevant parameter $p_1$ is always set zero.
 <<SF mappings: sf on-shell mapping single: TBP>>=
   procedure :: inverse => sf_os_mapping_single_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_os_mapping_single_inverse &
          (mapping, r, rb, f, p, pb, x_free)
       class(sf_os_mapping_single_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_os_mapping_single_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_os_mapping_single_inverse &
        (mapping, r, rb, f, p, pb, x_free)
     class(sf_os_mapping_single_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(1) :: p2, r2
     r2 = r(mapping%i)
     call map_on_shell_single_inverse (r2, f, p2, mapping%lm2, x_free)
     p = r
     pb= rb
     p (mapping%i(1)) = p2(1)
     pb(mapping%i(1)) = 1 - p2(1)
   end subroutine sf_os_mapping_single_inverse
 
 @ %def sf_os_mapping_single_inverse
 @
 \subsection{Implementation: endpoint mapping}
 This maps the unit square ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$,
 while $p_2$ is related to the ratio.  Furthermore, we enhance the
 region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and
 $p_2=0,1$.  The enhancement is such that any power-like singularity is
 caught.  This is useful for beamstrahlung spectra.
 
 In addition, we allow for a delta-function singularity in $r_1$ and/or
 $r_2$.  The singularity is smeared to an interval of width
 $\epsilon$.  If nonzero, we distinguish the kinematical momentum
 fractions $r_i$ from effective values $x_i$, which should go into the
 structure-function evaluation.  A bin of width $\epsilon$ in $r$ is
 mapped to $x=1$ exactly, while the interval $(0,1-\epsilon)$ is mapped
 to $(0,1)$ in $x$.  The Jacobian reflects this distinction, and the
 logical [[in_peak]] allows for an unambiguous distinction.
 
 The delta-peak fraction is used only for the integration self-test.
 <<SF mappings: public>>=
   public :: sf_ep_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ep_mapping_t
      real(default) :: a = 1
    contains
    <<SF mappings: sf endpoint mapping: TBP>>
   end type sf_ep_mapping_t
 
 @ %def sf_ep_mapping_t
 @ Output.
 <<SF mappings: sf endpoint mapping: TBP>>=
   procedure :: write => sf_ep_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ep_mapping_write (object, unit)
       class(sf_ep_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_ep_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_ep_mapping_write (object, unit)
     class(sf_ep_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,ES12.5,A)")  ": endpoint (a =", object%a, ")"
   end subroutine sf_ep_mapping_write
 
 @ %def sf_ep_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf endpoint mapping: TBP>>=
   procedure :: init => sf_ep_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ep_mapping_init (mapping, a)
       class(sf_ep_mapping_t), intent(out) :: mapping
       real(default), intent(in), optional :: a
     end subroutine sf_ep_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_ep_mapping_init (mapping, a)
     class(sf_ep_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: a
     call mapping%base_init (2)
     if (present (a))  mapping%a = a
   end subroutine sf_ep_mapping_init
 
 @ %def sf_ep_mapping_init
 @ Apply mapping.
 <<SF mappings: sf endpoint mapping: TBP>>=
   procedure :: compute => sf_ep_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_ep_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ep_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_ep_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ep_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, r2
     real(default) :: f1, f2
     integer :: j
     call map_endpoint_1 (px(1), f1, p(mapping%i(1)), mapping%a)
     call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
     call map_unit_square (r2, f, px)
     f = f * f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_ep_mapping_compute
 
 @ %def sf_ep_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf endpoint mapping: TBP>>=
   procedure :: inverse => sf_ep_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_ep_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ep_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_ep_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ep_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, px, p2
     real(default) :: f1, f2
     integer :: j
     do j = 1, 2
        r2(j) = r(mapping%i(j))
     end do
     call map_unit_square_inverse (r2, f, px)
     call map_endpoint_inverse_1 (px(1), f1, p2(1), mapping%a)
     call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
     f = f * f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = 1 - p2(j)
     end do
   end subroutine sf_ep_mapping_inverse
 
 @ %def sf_ep_mapping_inverse
 @
 \subsection{Implementation: endpoint mapping with resonance}
 Like the endpoint mapping for $p_2$, but replace the endpoint mapping
 by a Breit-Wigner mapping for $p_1$.  This covers resonance production
 in the presence of beamstrahlung.
 
 If the flag [[resonance]] is unset, we skip the resonance mapping, so
 the parameter $p_1$ remains equal to $r_1r_2$, as in the standard
 s-channel mapping.
 <<SF mappings: public>>=
   public :: sf_epr_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_epr_mapping_t
      real(default) :: a = 1
      real(default) :: m = 0
      real(default) :: w = 0
      logical :: resonance = .true.
    contains
    <<SF mappings: sf endpoint/res mapping: TBP>>
   end type sf_epr_mapping_t
 
 @ %def sf_epr_mapping_t
 @ Output.
 <<SF mappings: sf endpoint/res mapping: TBP>>=
   procedure :: write => sf_epr_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_epr_mapping_write (object, unit)
       class(sf_epr_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_epr_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_epr_mapping_write (object, unit)
     class(sf_epr_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     if (object%resonance) then
        write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)")  ": ep/res (a = ", object%a, &
             " | ", object%m, object%w, ")"
     else
        write (u, "(A,F7.5,A)")  ": ep/nores (a = ", object%a, ")"
     end if
   end subroutine sf_epr_mapping_write
 
 @ %def sf_epr_mapping_write
 @ Initialize: if mass and width are not given, we initialize a
 non-resonant version of the mapping.
 <<SF mappings: sf endpoint/res mapping: TBP>>=
   procedure :: init => sf_epr_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_epr_mapping_init (mapping, a, m, w)
       class(sf_epr_mapping_t), intent(out) :: mapping
       real(default), intent(in) :: a
       real(default), intent(in), optional :: m, w
     end subroutine sf_epr_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_epr_mapping_init (mapping, a, m, w)
     class(sf_epr_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: a
     real(default), intent(in), optional :: m, w
     call mapping%base_init (2)
     mapping%a = a
     if (present (m) .and. present (w)) then
        mapping%m = m
        mapping%w = w
     else
        mapping%resonance = .false.
     end if
   end subroutine sf_epr_mapping_init
 
 @ %def sf_epr_mapping_init
 @ Apply mapping.
 <<SF mappings: sf endpoint/res mapping: TBP>>=
   procedure :: compute => sf_epr_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_epr_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_epr_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_epr_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_epr_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, r2
     real(default) :: f1, f2
     integer :: j
     if (mapping%resonance) then
        call map_breit_wigner &
             (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free)
     else
        px(1) = p(mapping%i(1))
        f1 = 1
     end if
     call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
     call map_unit_square (r2, f, px)
     f = f * f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_epr_mapping_compute
 
 @ %def sf_epr_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf endpoint/res mapping: TBP>>=
   procedure :: inverse => sf_epr_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_epr_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_epr_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_epr_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_epr_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, p2
     real(default) :: f1, f2
     integer :: j
     call map_unit_square_inverse (r(mapping%i), f, px)
     if (mapping%resonance) then
        call map_breit_wigner_inverse &
             (px(1), f1, p2(1), mapping%m, mapping%w, x_free)
     else
        p2(1) = px(1)
        f1 = 1
     end if
     call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
     f = f * f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = 1 - p2(j)
     end do
   end subroutine sf_epr_mapping_inverse
 
 @ %def sf_epr_mapping_inverse
 @
 \subsection{Implementation: endpoint mapping for on-shell particle}
 Analogous to the resonance mapping, but the $p_1$ input is ignored
 altogether.  This covers on-shell particle production
 in the presence of beamstrahlung.
 <<SF mappings: public>>=
   public :: sf_epo_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_epo_mapping_t
      real(default) :: a = 1
      real(default) :: m = 0
      real(default) :: lm2 = 0
    contains
    <<SF mappings: sf endpoint/os mapping: TBP>>
   end type sf_epo_mapping_t
 
 @ %def sf_epo_mapping_t
 @ Output.
 <<SF mappings: sf endpoint/os mapping: TBP>>=
   procedure :: write => sf_epo_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_epo_mapping_write (object, unit)
       class(sf_epo_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_epo_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_epo_mapping_write (object, unit)
     class(sf_epo_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A,F7.5,A)")  ": ep/on-shell (a = ", object%a, &
          " | ", object%m, ")"
   end subroutine sf_epo_mapping_write
 
 @ %def sf_epo_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf endpoint/os mapping: TBP>>=
   procedure :: init => sf_epo_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_epo_mapping_init (mapping, a, m)
       class(sf_epo_mapping_t), intent(out) :: mapping
       real(default), intent(in) :: a, m
     end subroutine sf_epo_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_epo_mapping_init (mapping, a, m)
     class(sf_epo_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: a, m
     call mapping%base_init (2)
     mapping%a = a
     mapping%m = m
     mapping%lm2 = abs (2 * log (mapping%m))
   end subroutine sf_epo_mapping_init
 
 @ %def sf_epo_mapping_init
 @ Apply mapping.
 <<SF mappings: sf endpoint/os mapping: TBP>>=
   procedure :: compute => sf_epo_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_epo_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_epo_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_epo_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_epo_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, r2
     real(default) :: f2
     integer :: j
     px(1) = 0
     call map_endpoint_01 (px(2), f2, p(mapping%i(2)), mapping%a)
     call map_on_shell (r2, f, px, mapping%lm2)
     f = f * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2(j)
        rb(mapping%i(j)) = 1 - r2(j)
     end do
   end subroutine sf_epo_mapping_compute
 
 @ %def sf_epo_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf endpoint/os mapping: TBP>>=
   procedure :: inverse => sf_epo_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_epo_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end  subroutine sf_epo_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_epo_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_epo_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, p2
     real(default) :: f2
     integer :: j
     call map_on_shell_inverse (r(mapping%i), f, px, mapping%lm2)
     p2(1) = 0
     call map_endpoint_inverse_01 (px(2), f2, p2(2), mapping%a)
     f = f * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = 1 - p2(j)
     end do
   end subroutine sf_epo_mapping_inverse
 
 @ %def sf_epo_mapping_inverse
 @
 \subsection{Implementation: ISR endpoint mapping}
 Similar to the endpoint mapping above: This maps the unit square
 ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is
 related to the ratio.  Furthermore, we enhance the region at $r_1=1$
 and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$.
 
 The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
 flattened.  This would be easy in one dimension, but becomes
 nontrivial in two dimensions.
 <<SF mappings: public>>=
   public :: sf_ip_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ip_mapping_t
      real(default) :: eps = 0
    contains
    <<SF mappings: sf power mapping: TBP>>
   end type sf_ip_mapping_t
 
 @ %def sf_ip_mapping_t
 @ Output.
 <<SF mappings: sf power mapping: TBP>>=
   procedure :: write => sf_ip_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ip_mapping_write (object, unit)
       class(sf_ip_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_ip_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_ip_mapping_write (object, unit)
     class(sf_ip_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,ES12.5,A)")  ": isr (eps =", object%eps, ")"
   end subroutine sf_ip_mapping_write
 
 @ %def sf_ip_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf power mapping: TBP>>=
   procedure :: init => sf_ip_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ip_mapping_init (mapping, eps)
       class(sf_ip_mapping_t), intent(out) :: mapping
       real(default), intent(in), optional :: eps
     end subroutine sf_ip_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_ip_mapping_init (mapping, eps)
     class(sf_ip_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: eps
     call mapping%base_init (2)
     if (present (eps))  mapping%eps = eps
     if (mapping%eps <= 0) &
          call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
   end subroutine sf_ip_mapping_init
 
 @ %def sf_ip_mapping_init
 @ Apply mapping.
 <<SF mappings: sf power mapping: TBP>>=
   procedure :: compute => sf_ip_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_ip_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ip_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_ip_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ip_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, pxb, r2, r2b
     real(default) :: f1, f2, xb, y, yb
     integer :: j
     call map_power_1 (xb, f1, pb(mapping%i(1)), 2 * mapping%eps)
     call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
     px(1)  = 1 - xb
     pxb(1) = xb
     px(2)  = y
     pxb(2) = yb
     call map_unit_square_prec (r2, r2b, f, px, pxb)
     f = f * f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2 (j)
        rb(mapping%i(j)) = r2b(j)
     end do
   end subroutine sf_ip_mapping_compute
 
 @ %def sf_ip_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf power mapping: TBP>>=
   procedure :: inverse => sf_ip_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_ip_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ip_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_ip_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ip_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
     real(default) :: f1, f2, xb, y, yb
     integer :: j
     do j = 1, 2
        r2 (j) = r (mapping%i(j))
        r2b(j) = rb(mapping%i(j))
     end do
     call map_unit_square_inverse_prec (r2, r2b, f, px, pxb)
     xb = pxb(1)
     if (px(1) > 0) then
        y  = px(2)
        yb = pxb(2)
     else
        y  = 0.5_default
        yb = 0.5_default
     end if
     call map_power_inverse_1 (xb, f1, p2b(1), 2 * mapping%eps)
     call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
     p2 = 1 - p2b
     f = f * f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = p2b(j)
     end do
   end subroutine sf_ip_mapping_inverse
 
 @ %def sf_ip_mapping_inverse
 @
 \subsection{Implementation: ISR endpoint mapping, resonant}
 Similar to the endpoint mapping above: This maps the unit square
 ($r_1,r_2$) such that $p_1$ is the product $r_1r_2$, while $p_2$ is
 related to the ratio.  Furthermore, we enhance the region at $r_1=1$
 and $r_2=1$, which translates into $p_1=1$ and $p_2=0,1$.
 
 The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
 flattened.  This would be easy in one dimension, but becomes
 nontrivial in two dimensions.
 
 The resonance can be turned off by the flag [[resonance]].
 <<SF mappings: public>>=
   public :: sf_ipr_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ipr_mapping_t
      real(default) :: eps = 0
      real(default) :: m = 0
      real(default) :: w = 0
      logical :: resonance = .true.
    contains
    <<SF mappings: sf power/res mapping: TBP>>
   end type sf_ipr_mapping_t
 
 @ %def sf_ipr_mapping_t
 @ Output.
 <<SF mappings: sf power/res mapping: TBP>>=
   procedure :: write => sf_ipr_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ipr_mapping_write (object, unit)
       class(sf_ipr_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_ipr_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_ipr_mapping_write (object, unit)
     class(sf_ipr_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     if (object%resonance) then
        write (u, "(A,F7.5,A,F7.5,', ',F7.5,A)")  ": isr/res (eps = ", &
             object%eps, " | ", object%m, object%w, ")"
     else
        write (u, "(A,F7.5,A)")  ": isr/res (eps = ", object%eps, ")"
     end if
   end subroutine sf_ipr_mapping_write
 
 @ %def sf_ipr_mapping_write
 @ Initialize:
 <<SF mappings: sf power/res mapping: TBP>>=
   procedure :: init => sf_ipr_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ipr_mapping_init (mapping, eps, m, w)
       class(sf_ipr_mapping_t), intent(out) :: mapping
       real(default), intent(in), optional :: eps, m, w
     end subroutine sf_ipr_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_ipr_mapping_init (mapping, eps, m, w)
     class(sf_ipr_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: eps, m, w
     call mapping%base_init (2)
     if (present (eps))  mapping%eps = eps
     if (mapping%eps <= 0) &
          call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
     if (present (m) .and. present (w)) then
        mapping%m = m
        mapping%w = w
     else
        mapping%resonance = .false.
     end if
   end subroutine sf_ipr_mapping_init
 
 @ %def sf_ipr_mapping_init
 @ Apply mapping.
 <<SF mappings: sf power/res mapping: TBP>>=
   procedure :: compute => sf_ipr_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_ipr_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ipr_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_ipr_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ipr_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, pxb, r2, r2b
     real(default) :: f1, f2, y, yb
     integer :: j
     if (mapping%resonance) then
        call map_breit_wigner &
             (px(1), f1, p(mapping%i(1)), mapping%m, mapping%w, x_free)
     else
        px(1) = p(mapping%i(1))
        f1 = 1
     end if
     call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
     pxb(1) = 1 - px(1)
     px(2)  = y
     pxb(2) = yb
     call map_unit_square_prec (r2, r2b, f, px, pxb)
     f = f * f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2 (j)
        rb(mapping%i(j)) = r2b(j)
     end do
   end subroutine sf_ipr_mapping_compute
 
 @ %def sf_ipr_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf power/res mapping: TBP>>=
   procedure :: inverse => sf_ipr_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_ipr_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ipr_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_ipr_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ipr_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
     real(default) :: f1, f2, y, yb
     integer :: j
     do j = 1, 2
        r2 (j) = r (mapping%i(j))
        r2b(j) = rb(mapping%i(j))
     end do
     call map_unit_square_inverse_prec (r2, r2b, f, px, pxb)
     if (px(1) > 0) then
        y  = px(2)
        yb = pxb(2)
     else
        y  = 0.5_default
        yb = 0.5_default
     end if
     if (mapping%resonance) then
        call map_breit_wigner_inverse &
             (px(1), f1, p2(1), mapping%m, mapping%w, x_free)
     else
        p2(1) = px(1)
        f1 = 1
     end if
     call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
     p2b(1) = 1 - p2(1)
     p2 (2) = 1 - p2b(2)
     f = f * f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = p2b(j)
     end do
   end subroutine sf_ipr_mapping_inverse
 
 @ %def sf_ipr_mapping_inverse
 @
 \subsection{Implementation: ISR on-shell mapping}
 Similar to the endpoint mapping above: This maps the unit square
 ($r_1,r_2$) such that $p_1$ is ignored while the product $r_1r_2$ is
 constant.  $p_2$ is related to the ratio.  Furthermore, we enhance the
 region at $r_1=1$ and $r_2=1$, which translates into $p_1=1$ and
 $p_2=0,1$.
 
 The enhancement is such that ISR singularity $(1-x)^{-1+\epsilon}$ is
 flattened.  This would be easy in one dimension, but becomes
 nontrivial in two dimensions.
 <<SF mappings: public>>=
   public :: sf_ipo_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ipo_mapping_t
      real(default) :: eps = 0
      real(default) :: m = 0
    contains
    <<SF mappings: sf power/os mapping: TBP>>
   end type sf_ipo_mapping_t
 
 @ %def sf_ipo_mapping_t
 @ Output.
 <<SF mappings: sf power/os mapping: TBP>>=
   procedure :: write => sf_ipo_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ipo_mapping_write (object, unit)
       class(sf_ipo_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_ipo_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_ipo_mapping_write (object, unit)
     class(sf_ipo_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,',',I0,')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A,F7.5,A)")  ": isr/os (eps = ", object%eps, &
          " | ", object%m, ")"
   end subroutine sf_ipo_mapping_write
 
 @ %def sf_ipo_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf power/os mapping: TBP>>=
   procedure :: init => sf_ipo_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ipo_mapping_init (mapping, eps, m)
       class(sf_ipo_mapping_t), intent(out) :: mapping
       real(default), intent(in), optional :: eps, m
     end subroutine sf_ipo_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_ipo_mapping_init (mapping, eps, m)
     class(sf_ipo_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: eps, m
     call mapping%base_init (2)
     if (present (eps))  mapping%eps = eps
     if (mapping%eps <= 0) &
          call msg_fatal ("ISR mapping: regulator epsilon must not be zero")
     mapping%m = m
   end subroutine sf_ipo_mapping_init
 
 @ %def sf_ipo_mapping_init
 @ Apply mapping.
 <<SF mappings: sf power/os mapping: TBP>>=
   procedure :: compute => sf_ipo_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_ipo_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ipo_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_ipo_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ipo_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: px, pxb, r2, r2b
     real(default) :: f1, f2, y, yb
     integer :: j
     call map_power_01 (y, yb, f2, pb(mapping%i(2)), mapping%eps)
     px(1)  = mapping%m ** 2
     if (present (x_free))  px(1) = px(1) / x_free
     pxb(1) = 1 - px(1)
     px(2)  = y
     pxb(2) = yb
     call map_unit_square_prec (r2, r2b, f1, px, pxb)
     f = f1 * f2
     r = p
     rb= pb
     do j = 1, 2
        r (mapping%i(j)) = r2 (j)
        rb(mapping%i(j)) = r2b(j)
     end do
   end subroutine sf_ipo_mapping_compute
 
 @ %def sf_ipo_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf power/os mapping: TBP>>=
   procedure :: inverse => sf_ipo_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_ipo_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ipo_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_ipo_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ipo_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: r2, r2b, px, pxb, p2, p2b
     real(default) :: f1, f2, y, yb
     integer :: j
     do j = 1, 2
        r2 (j) = r (mapping%i(j))
        r2b(j) = rb(mapping%i(j))
     end do
     call map_unit_square_inverse_prec (r2, r2b, f1, px, pxb)
     y  = px(2)
     yb = pxb(2)
     call map_power_inverse_01 (y, yb, f2, p2b(2), mapping%eps)
     p2(1) = 0
     p2b(1)= 1
     p2(2) = 1 - p2b(2)
     f = f1 * f2
     p = r
     pb= rb
     do j = 1, 2
        p (mapping%i(j)) = p2(j)
        pb(mapping%i(j)) = p2b(j)
     end do
   end subroutine sf_ipo_mapping_inverse
 
 @ %def sf_ipo_mapping_inverse
 @
 \subsection{Implementation: Endpoint + ISR power mapping}
 This is a combination of endpoint (i.e., beamstrahlung) and ISR power
 mapping.  The first two parameters apply to the beamstrahlung
 spectrum, the last two to the ISR function for the first and second
 beam, respectively.
 <<SF mappings: public>>=
   public :: sf_ei_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_ei_mapping_t
      type(sf_ep_mapping_t) :: ep
      type(sf_ip_mapping_t) :: ip
    contains
    <<SF mappings: sf ep-ip mapping: TBP>>
   end type sf_ei_mapping_t
 
 @ %def sf_ei_mapping_t
 @ Output.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: write => sf_ei_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ei_mapping_write (object, unit)
       class(sf_ei_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_ei_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_ei_mapping_write (object, unit)
     class(sf_ei_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,3(',',I0),')')", advance="no")  object%i
     end if
     write (u, "(A,ES12.5,A,ES12.5,A)")  ": ep/isr (a =", object%ep%a, &
          ", eps =", object%ip%eps, ")"
   end subroutine sf_ei_mapping_write
 
 @ %def sf_ei_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: init => sf_ei_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ei_mapping_init (mapping, a, eps)
       class(sf_ei_mapping_t), intent(out) :: mapping
       real(default), intent(in), optional :: a, eps
     end subroutine sf_ei_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_ei_mapping_init (mapping, a, eps)
     class(sf_ei_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: a, eps
     call mapping%base_init (4)
     call mapping%ep%init (a)
     call mapping%ip%init (eps)
   end subroutine sf_ei_mapping_init
 
 @ %def sf_ei_mapping_init
 @ Set an index value.  We should communicate the appropriate indices to the
 enclosed sub-mappings, therefore override the method.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: set_index => sf_ei_mapping_set_index
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ei_mapping_set_index (mapping, j, i)
       class(sf_ei_mapping_t), intent(inout) :: mapping
       integer, intent(in) :: j, i
     end subroutine sf_ei_mapping_set_index
 <<SF mappings: procedures>>=
   module subroutine sf_ei_mapping_set_index (mapping, j, i)
     class(sf_ei_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j, i
     mapping%i(j) = i
     select case (j)
     case (1:2);  call mapping%ep%set_index (j, i)
     case (3:4);  call mapping%ip%set_index (j-2, i)
     end select
   end subroutine sf_ei_mapping_set_index
 
 @ %def sf_mapping_set_index
 @ Apply mapping.  Now, the beamstrahlung and ISR mappings are
 independent of each other.  The parameter subsets that are actually
 used should not overlap.  The Jacobians are multiplied.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: compute => sf_ei_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_ei_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ei_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_ei_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_ei_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: q, qb
     real(default) :: f1, f2
     call mapping%ep%compute (q, qb, f1, p, pb, x_free)
     call mapping%ip%compute (r, rb, f2, q, qb, x_free)
     f = f1 * f2
   end subroutine sf_ei_mapping_compute
 
 @ %def sf_ei_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf ep-ip mapping: TBP>>=
   procedure :: inverse => sf_ei_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_ei_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ei_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_ei_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_ei_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: q, qb
     real(default) :: f1, f2
     call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
     call mapping%ep%inverse (q, qb, f1, p, pb, x_free)
     f = f1 * f2
   end subroutine sf_ei_mapping_inverse
 
 @ %def sf_ei_mapping_inverse
 @
 \subsection{Implementation: Endpoint + ISR + resonance}
 This is a combination of endpoint (i.e., beamstrahlung) and ISR power
 mapping, adapted for an s-channel resonance.  The first two internal
 parameters apply to the beamstrahlung spectrum, the last two to the
 ISR function for the first and second beam, respectively.  The first
 and third parameters are the result of an overall resonance mapping,
 so on the outside, the first parameter is the total momentum fraction,
 the third one describes the distribution between beamstrahlung and ISR.
 <<SF mappings: public>>=
   public :: sf_eir_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_eir_mapping_t
      type(sf_res_mapping_t) :: res
      type(sf_epr_mapping_t) :: ep
      type(sf_ipr_mapping_t) :: ip
    contains
    <<SF mappings: sf ep-ip-res mapping: TBP>>
   end type sf_eir_mapping_t
 
 @ %def sf_eir_mapping_t
 @ Output.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: write => sf_eir_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eir_mapping_write (object, unit)
       class(sf_eir_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_eir_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_eir_mapping_write (object, unit)
     class(sf_eir_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,3(',',I0),')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A,F7.5,A,F7.5,', ',F7.5,A)")  &
          ": ep/isr/res (a =", object%ep%a, &
          ", eps =", object%ip%eps, " | ", object%res%m, object%res%w, ")"
   end subroutine sf_eir_mapping_write
 
 @ %def sf_eir_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: init => sf_eir_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eir_mapping_init (mapping, a, eps, m, w)
       class(sf_eir_mapping_t), intent(out) :: mapping
       real(default), intent(in) :: a, eps, m, w
     end subroutine sf_eir_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_eir_mapping_init (mapping, a, eps, m, w)
     class(sf_eir_mapping_t), intent(out) :: mapping
     real(default), intent(in) :: a, eps, m, w
     call mapping%base_init (4)
     call mapping%res%init (m, w)
     call mapping%ep%init (a)
     call mapping%ip%init (eps)
   end subroutine sf_eir_mapping_init
 
 @ %def sf_eir_mapping_init
 @ Set an index value.  We should communicate the appropriate indices to the
 enclosed sub-mappings, therefore override the method.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: set_index => sf_eir_mapping_set_index
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eir_mapping_set_index (mapping, j, i)
       class(sf_eir_mapping_t), intent(inout) :: mapping
       integer, intent(in) :: j, i
     end subroutine sf_eir_mapping_set_index
 <<SF mappings: procedures>>=
   module subroutine sf_eir_mapping_set_index (mapping, j, i)
     class(sf_eir_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j, i
     mapping%i(j) = i
     select case (j)
     case (1);  call mapping%res%set_index (1, i)
     case (3);  call mapping%res%set_index (2, i)
     end select
     select case (j)
     case (1:2);  call mapping%ep%set_index (j, i)
     case (3:4);  call mapping%ip%set_index (j-2, i)
     end select
   end subroutine sf_eir_mapping_set_index
 
 @ %def sf_mapping_set_index
 @ Apply mapping.  Now, the beamstrahlung and ISR mappings are
 independent of each other.  The parameter subsets that are actually
 used should not overlap.  The Jacobians are multiplied.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: compute => sf_eir_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_eir_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_eir_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_eir_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_eir_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: px, pxb, q, qb
     real(default) :: f0, f1, f2
     call mapping%res%compute (px, pxb, f0, p, pb, x_free)
     call mapping%ep%compute (q, qb, f1, px, pxb, x_free)
     call mapping%ip%compute (r, rb, f2, q, qb, x_free)
     f = f0 * f1 * f2
   end subroutine sf_eir_mapping_compute
 
 @ %def sf_eir_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf ep-ip-res mapping: TBP>>=
   procedure :: inverse => sf_eir_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_eir_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_eir_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_eir_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_eir_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: px, pxb, q, qb
     real(default) :: f0, f1, f2
     call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
     call mapping%ep%inverse (q, qb, f1, px, pxb, x_free)
     call mapping%res%inverse (px, pxb, f0, p, pb, x_free)
     f = f0 * f1 * f2
   end subroutine sf_eir_mapping_inverse
 
 @ %def sf_eir_mapping_inverse
 @
 \subsection{Implementation: Endpoint + ISR power mapping, on-shell}
 This is a combination of endpoint (i.e., beamstrahlung) and ISR power
 mapping.  The first two parameters apply to the beamstrahlung
 spectrum, the last two to the ISR function for the first and second
 beam, respectively.  On top of that, we map the first and third parameter
 such that the product is constant.  From the outside, the first
 parameter is irrelevant while the third parameter describes the
 distribution of energy (loss) among beamstrahlung and ISR.
 <<SF mappings: public>>=
   public :: sf_eio_mapping_t
 <<SF mappings: types>>=
   type, extends (sf_mapping_t) :: sf_eio_mapping_t
      type(sf_os_mapping_t) :: os
      type(sf_epr_mapping_t) :: ep
      type(sf_ipr_mapping_t) :: ip
    contains
    <<SF mappings: sf ep-ip-os mapping: TBP>>
   end type sf_eio_mapping_t
 
 @ %def sf_eio_mapping_t
 @ Output.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: write => sf_eio_mapping_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eio_mapping_write (object, unit)
       class(sf_eio_mapping_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_eio_mapping_write
 <<SF mappings: procedures>>=
   module subroutine sf_eio_mapping_write (object, unit)
     class(sf_eio_mapping_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "map"
     if (any (object%i /= 0)) then
        write (u, "('(',I0,3(',',I0),')')", advance="no")  object%i
     end if
     write (u, "(A,F7.5,A,F7.5,A,F7.5,A)")  ": ep/isr/os (a =", object%ep%a, &
          ", eps =", object%ip%eps, " | ", object%os%m, ")"
   end subroutine sf_eio_mapping_write
 
 @ %def sf_eio_mapping_write
 @ Initialize: no extra parameters.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: init => sf_eio_mapping_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eio_mapping_init (mapping, a, eps, m)
       class(sf_eio_mapping_t), intent(out) :: mapping
       real(default), intent(in), optional :: a, eps, m
     end subroutine sf_eio_mapping_init
 <<SF mappings: procedures>>=
   module subroutine sf_eio_mapping_init (mapping, a, eps, m)
     class(sf_eio_mapping_t), intent(out) :: mapping
     real(default), intent(in), optional :: a, eps, m
     call mapping%base_init (4)
     call mapping%os%init (m)
     call mapping%ep%init (a)
     call mapping%ip%init (eps)
   end subroutine sf_eio_mapping_init
 
 @ %def sf_eio_mapping_init
 @ Set an index value.  We should communicate the appropriate indices to the
 enclosed sub-mappings, therefore override the method.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: set_index => sf_eio_mapping_set_index
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eio_mapping_set_index (mapping, j, i)
       class(sf_eio_mapping_t), intent(inout) :: mapping
       integer, intent(in) :: j, i
     end subroutine sf_eio_mapping_set_index
 <<SF mappings: procedures>>=
   module subroutine sf_eio_mapping_set_index (mapping, j, i)
     class(sf_eio_mapping_t), intent(inout) :: mapping
     integer, intent(in) :: j, i
     mapping%i(j) = i
     select case (j)
     case (1);  call mapping%os%set_index (1, i)
     case (3);  call mapping%os%set_index (2, i)
     end select
     select case (j)
     case (1:2);  call mapping%ep%set_index (j, i)
     case (3:4);  call mapping%ip%set_index (j-2, i)
     end select
   end subroutine sf_eio_mapping_set_index
 
 @ %def sf_mapping_set_index
 @ Apply mapping.  Now, the beamstrahlung and ISR mappings are
 independent of each other.  The parameter subsets that are actually
 used should not overlap.  The Jacobians are multiplied.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: compute => sf_eio_mapping_compute
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free)
       class(sf_eio_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_eio_mapping_compute
 <<SF mappings: procedures>>=
   module subroutine sf_eio_mapping_compute (mapping, r, rb, f, p, pb, x_free)
     class(sf_eio_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: px, pxb, q, qb
     real(default) :: f0, f1, f2
     call mapping%os%compute (px, pxb, f0, p, pb, x_free)
     call mapping%ep%compute (q, qb, f1, px, pxb, x_free)
     call mapping%ip%compute (r, rb, f2, q, qb, x_free)
     f = f0 * f1 * f2
   end subroutine sf_eio_mapping_compute
 
 @ %def sf_eio_mapping_compute
 @ Apply inverse.
 <<SF mappings: sf ep-ip-os mapping: TBP>>=
   procedure :: inverse => sf_eio_mapping_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
       class(sf_eio_mapping_t), intent(inout) :: mapping
       real(default), dimension(:), intent(in) :: r, rb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: p, pb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_eio_mapping_inverse
 <<SF mappings: procedures>>=
   module subroutine sf_eio_mapping_inverse (mapping, r, rb, f, p, pb, x_free)
     class(sf_eio_mapping_t), intent(inout) :: mapping
     real(default), dimension(:), intent(in) :: r, rb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: p, pb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(size(p)) :: px, pxb, q, qb
     real(default) :: f0, f1, f2
     call mapping%ip%inverse (r, rb, f2, q, qb, x_free)
     call mapping%ep%inverse (q, qb, f1, px, pxb, x_free)
     call mapping%os%inverse (px, pxb, f0, p, pb, x_free)
     f = f0 * f1 * f2
   end subroutine sf_eio_mapping_inverse
 
 @ %def sf_eio_mapping_inverse
 @
 \subsection{Basic formulas}
 \subsubsection{Standard mapping of the unit square}
 This mapping of the unit square is appropriate in particular for
 structure functions which are concentrated at the lower end.  Instead
 of a rectangular grid, one set of grid lines corresponds to constant
 parton c.m. energy.  The other set is chosen such that the jacobian is
 only mildly singular ($\ln x$ which is zero at $x=1$), corresponding
 to an initial concentration of sampling points at the maximum energy.
 If [[power]] is greater than one (the default), points are also
 concentrated at the lower end.
 
 The formula is ([[power]]=$\alpha$):
 \begin{align}
   r_1 &= (p_1 ^ {p_2})^\alpha \\
   r_2 &= (p_1 ^ {1 - p_2})^\alpha\\
   f   &= \alpha^2 p_1 ^ {\alpha - 1} |\log p_1|
 \end{align}
 and for the default case $\alpha=1$:
 \begin{align}
   r_1 &= p_1 ^ {p_2} \\
   r_2 &= p_1 ^ {1 - p_2} \\
   f   &= |\log p_1|
 \end{align}
 <<SF mappings: procedures>>=
   subroutine map_unit_square (r, factor, p, power)
     real(default), dimension(2), intent(out) :: r
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(in) :: p
     real(default), intent(in), optional :: power
     real(default) :: xx, yy
     factor = 1
     xx = p(1)
     yy = p(2)
     if (present(power)) then
        if (p(1) > 0 .and. power > 1) then
           xx = p(1)**power
           factor = factor * power * xx / p(1)
        end if
     end if
     if (.not. vanishes (xx)) then
        r(1) = xx ** yy
        r(2) = xx / r(1)
        factor = factor * abs (log (xx))
     else
        r = 0
     end if
   end subroutine map_unit_square
 
 @ %def map_unit_square
 @ This is the inverse mapping.
 <<SF mappings: procedures>>=
   subroutine map_unit_square_inverse (r, factor, p, power)
     real(kind=default), dimension(2), intent(in) :: r
     real(kind=default), intent(out) :: factor
     real(kind=default), dimension(2), intent(out) :: p
     real(kind=default), intent(in), optional :: power
     real(kind=default) :: lg, xx, yy
     factor = 1
     xx = r(1) * r(2)
     if (.not. vanishes (xx)) then
        lg = log (xx)
        if (.not. vanishes (lg)) then
           yy = log (r(1)) / lg
        else
           yy = 0
        end if
        p(2) = yy
        factor = factor * abs (lg)
        if (present(power)) then
           p(1) = xx**(1._default/power)
           factor = factor * power * xx / p(1)
        else
           p(1) = xx
        end if
     else
        p = 0
     end if
   end subroutine map_unit_square_inverse
 
 @ %def map_unit_square_inverse
 @
 \subsubsection{Precise mapping of the unit square}
 A more precise version (with unit power parameter).  This version
 should be numerically stable near $x=1$ and $y=0,1$.  The formulas are again
 \begin{equation}
   r_1 = p_1^{p_2}, \qquad
   r_2 = p_1^{\bar p_2}, \qquad
   f = - \log p_1
 \end{equation}
 but we compute both $r_i$ and $\bar r_i$ simultaneously and make
 direct use of both $p_i$ and $\bar p_i$ as appropriate.
 <<SF mappings: procedures>>=
   subroutine map_unit_square_prec (r, rb, factor, p, pb)
     real(default), dimension(2), intent(out) :: r
     real(default), dimension(2), intent(out) :: rb
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(in) :: p
     real(default), dimension(2), intent(in) :: pb
     if (p(1) > 0.5_default) then
        call compute_prec_xy_1 (r(1), rb(1), p(1), pb(1), p (2))
        call compute_prec_xy_1 (r(2), rb(2), p(1), pb(1), pb(2))
        factor = - log_prec (p(1), pb(1))
     else if (.not. vanishes (p(1))) then
        call compute_prec_xy_0 (r(1), rb(1), p(1), pb(1), p (2))
        call compute_prec_xy_0 (r(2), rb(2), p(1), pb(1), pb(2))
        factor = - log_prec (p(1), pb(1))
     else
        r  = 0
        rb = 1
        factor = 0
     end if
   end subroutine map_unit_square_prec
 
 @ %def map_unit_square_prec
 @ This is the inverse mapping.
 <<SF mappings: procedures>>=
   subroutine map_unit_square_inverse_prec (r, rb, factor, p, pb)
     real(default), dimension(2), intent(in) :: r
     real(default), dimension(2), intent(in) :: rb
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(out) :: p
     real(default), dimension(2), intent(out) :: pb
     call inverse_prec_x (r, rb, p(1), pb(1))
     if (all (r > 0)) then
        if (rb(1) < rb(2)) then
           call inverse_prec_y (r, rb, p(2), pb(2))
        else
           call inverse_prec_y ([r(2),r(1)], [rb(2),rb(1)], pb(2), p(2))
        end if
        factor = - log_prec (p(1), pb(1))
     else
        p(1)  = 0
        pb(1) = 1
        p(2)  = 0.5_default
        pb(2) = 0.5_default
        factor = 0
     end if
   end subroutine map_unit_square_inverse_prec
 
 @ %def map_unit_square_prec_inverse
 @ This is an auxiliary function: evaluate the expression $\bar z = 1 -
 x^y$ in a numerically stable way.  Instabilities occur for $y=0$ and
 $x=1$.  The idea is to replace the bracket by the first terms of its
 Taylor expansion around $x=1$ (read $\bar x\equiv 1 -x$)
 \begin{equation}
   1 - x^y = y\bar x\left(1 + \frac12(1-y)\bar x +
     \frac16(2-y)(1-y)\bar x^2\right)
 \end{equation}
 whenever this is the better approximation.  Actually, the relative
 numerical error of the exact formula is about $\eta/(y\bar x)$ where
 $\eta$ is given by [[epsilon(KIND)]] in Fortran.  The relative error
 of the approximation is better than the last included term divided by
 $(y\bar x)$.
 
 The first subroutine computes $z$ and $\bar z$ near $x=1$ where $\log
 x$ should be expanded, the second one near $x=0$ where $\log x$ can be
 kept.
 <<SF mappings: procedures>>=
   subroutine compute_prec_xy_1 (z, zb, x, xb, y)
     real(default), intent(out) :: z, zb
     real(default), intent(in) :: x, xb, y
     real(default) :: a1, a2, a3
     a1 = y * xb
     a2 = a1 * (1 - y) * xb / 2
     a3 = a2 * (2 - y) * xb / 3
     if (abs (a3) < epsilon (a3)) then
        zb = a1 + a2 + a3
        z = 1 - zb
     else
        z = x ** y
        zb = 1 - z
     end if
   end subroutine compute_prec_xy_1
 
   subroutine compute_prec_xy_0 (z, zb, x, xb, y)
     real(default), intent(out) :: z, zb
     real(default), intent(in) :: x, xb, y
     real(default) :: a1, a2, a3, lx
     lx = -log (x)
     a1 = y * lx
     a2 = a1 * y * lx / 2
     a3 = a2 * y * lx / 3
     if (abs (a3) < epsilon (a3)) then
        zb = a1 + a2 + a3
        z = 1 - zb
     else
        z = x ** y
        zb = 1 - z
     end if
   end subroutine compute_prec_xy_0
 
 @ %def compute_prec_xy_1
 @ %def compute_prec_xy_0
 @ For the inverse calculation, we evaluate $x=r_1r_2$ in a stable way.
 Since it is just a polynomial, the expansion near $x=1$ is
 analytically exact, and we don't need to choose based on precision.
+
+Fixed WK 2023-02-21: case selection ([[a0]] check) was flipped.  Note
+that the first case applies to small [[rb]], i.e., to [[x]] near 1.
 <<SF mappings: procedures>>=
   subroutine inverse_prec_x (r, rb, x, xb)
     real(default), dimension(2), intent(in) :: r, rb
     real(default), intent(out) :: x, xb
     real(default) :: a0, a1
     a0 = rb(1) + rb(2)
     a1 = rb(1) * rb(2)
-    if (a0 > 0.5_default) then
+    if (a0 < 0.5_default) then
        xb = a0 - a1
        x = 1 - xb
     else
        x = r(1) * r(2)
        xb = 1 - x
     end if
   end subroutine inverse_prec_x
 
 @ %def inverse_prec_x
 @ The inverse calculation for the relative momentum fraction
 \begin{equation}
   y = \frac{1}{1 + \frac{\log{r_2}}{\log{r_1}}}
 \end{equation}
 is slightly more complicated.  We should take the precise form of the
 logarithm, so we are safe near $r_i=1$.  A series expansion is
 required if $r_1\ll r_2$, since then $y$ becomes small.  (We assume
 $r_1<r_2$ here; for the opposite case, the arguments can be
 exchanged.)
+
+Fixed WK 2023-02-21: removed special casing for either log near zero
+within the first branch.  ([[y]] or [[yb]] was set to zero.)
+In some application (ISR peak mapping with resonance nearby) that
+apparent safeguard turned out to be fatal.
 <<SF mappings: procedures>>=
   subroutine inverse_prec_y (r, rb, y, yb)
     real(default), dimension(2), intent(in) :: r, rb
     real(default), intent(out) :: y, yb
     real(default) :: log1, log2, a1, a2, a3
     log1 = log_prec (r(1), rb(1))
     log2 = log_prec (r(2), rb(2))
     if (abs (log2**3) < epsilon (one)) then
-       if (abs(log1) < epsilon (one)) then
-          y = zero
-       else
-          y = one / (one + log2 / log1)
-       end if
-       if (abs(log2) < epsilon (one)) then
-          yb = zero
+       y = one / (one + log2 / log1)
+       yb = one / (one + log1 / log2)
+    else
+       a1 = - rb(1) / log2
+       a2 = - rb(1) ** 2 * (one / log2**2 + one / (2 * log2))
+       a3 = - rb(1) ** 3 * (one / log2**3 + one / log2**2 + one/(3 * log2))
+       if (abs (a3) < epsilon (a3)) then
+          y  = a1 + a2 + a3
+          yb = one - y
        else
+          y  = one / (one + log2 / log1)
           yb = one / (one + log1 / log2)
        end if
-       return
-    end if
-    a1 = - rb(1) / log2
-    a2 = - rb(1) ** 2 * (one / log2**2 + one / (2 * log2))
-    a3 = - rb(1) ** 3 * (one / log2**3 + one / log2**2 + one/(3 * log2))
-    if (abs (a3) < epsilon (a3)) then
-       y  = a1 + a2 + a3
-       yb = one - y
-    else
-       y  = one / (one + log2 / log1)
-       yb = one / (one + log1 / log2)
     end if
   end subroutine inverse_prec_y
 
 @ %def inverse_prec_y
 @
 \subsubsection{Mapping for on-shell s-channel}
 The limiting case, if the product $r_1r_2$ is fixed for on-shell
 production.  The parameter $p_1$ is ignored.  In the inverse mapping,
 it is returned zero.
 
 The parameter [[x_free]], if present, rescales the total energy.  If
 it is less than one, the rescaled mass parameter $m^2$ should be increased
 accordingly.
 
 Public for access in unit test.
 <<SF mappings: public>>=
   public :: map_on_shell
   public :: map_on_shell_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine map_on_shell (r, factor, p, lm2, x_free)
       real(default), dimension(2), intent(out) :: r
       real(default), intent(out) :: factor
       real(default), dimension(2), intent(in) :: p
       real(default), intent(in) :: lm2
       real(default), intent(in), optional :: x_free
     end subroutine map_on_shell
     module subroutine map_on_shell_inverse (r, factor, p, lm2, x_free)
       real(default), dimension(2), intent(in) :: r
       real(default), intent(out) :: factor
       real(default), dimension(2), intent(out) :: p
       real(default), intent(in) :: lm2
       real(default), intent(in), optional :: x_free
     end subroutine map_on_shell_inverse
 <<SF mappings: procedures>>=
   module subroutine map_on_shell (r, factor, p, lm2, x_free)
     real(default), dimension(2), intent(out) :: r
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(in) :: p
     real(default), intent(in) :: lm2
     real(default), intent(in), optional :: x_free
     real(default) :: lx
     lx = lm2;  if (present (x_free))  lx = lx + log (x_free)
     r(1) = exp (- p(2) * lx)
     r(2) = exp (- (1 - p(2)) * lx)
     factor = lx
   end subroutine map_on_shell
 
   module subroutine map_on_shell_inverse (r, factor, p, lm2, x_free)
     real(default), dimension(2), intent(in) :: r
     real(default), intent(out) :: factor
     real(default), dimension(2), intent(out) :: p
     real(default), intent(in) :: lm2
     real(default), intent(in), optional :: x_free
     real(default) :: lx
     lx = lm2;  if (present (x_free))  lx = lx + log (x_free)
     p(1) = 0
     p(2) = abs (log (r(1))) / lx
     factor = lx
   end subroutine map_on_shell_inverse
 
 @ %def map_on_shell
 @ %def map_on_shell_inverse
 @
 \subsubsection{Mapping for on-shell s-channel, single parameter}
 This is a pseudo-mapping which applies if there is actually just one
 parameter [[p]].  The output parameter [[r]] is fixed for on-shell
 production.  The lone parameter $p_1$ is ignored.  In the inverse mapping,
 it is returned zero.
 
 The parameter [[x_free]], if present, rescales the total energy.  If
 it is less than one, the rescaled mass parameter $m^2$ should be increased
 accordingly.
 
 Public for access in unit test.
 <<SF mappings: public>>=
   public :: map_on_shell_single
   public :: map_on_shell_single_inverse
 <<SF mappings: sub interfaces>>=
     module subroutine map_on_shell_single (r, factor, p, lm2, x_free)
       real(default), dimension(1), intent(out) :: r
       real(default), intent(out) :: factor
       real(default), dimension(1), intent(in) :: p
       real(default), intent(in) :: lm2
       real(default), intent(in), optional :: x_free
     end subroutine map_on_shell_single
     module subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free)
       real(default), dimension(1), intent(in) :: r
       real(default), intent(out) :: factor
       real(default), dimension(1), intent(out) :: p
       real(default), intent(in) :: lm2
       real(default), intent(in), optional :: x_free
     end subroutine map_on_shell_single_inverse
 <<SF mappings: procedures>>=
   module subroutine map_on_shell_single (r, factor, p, lm2, x_free)
     real(default), dimension(1), intent(out) :: r
     real(default), intent(out) :: factor
     real(default), dimension(1), intent(in) :: p
     real(default), intent(in) :: lm2
     real(default), intent(in), optional :: x_free
     real(default) :: lx
     lx = lm2;  if (present (x_free))  lx = lx + log (x_free)
     r(1) = exp (- lx)
     factor = 1
   end subroutine map_on_shell_single
 
   module subroutine map_on_shell_single_inverse (r, factor, p, lm2, x_free)
     real(default), dimension(1), intent(in) :: r
     real(default), intent(out) :: factor
     real(default), dimension(1), intent(out) :: p
     real(default), intent(in) :: lm2
     real(default), intent(in), optional :: x_free
     real(default) :: lx
     lx = lm2;  if (present (x_free))  lx = lx + log (x_free)
     p(1) = 0
     factor = 1
   end subroutine map_on_shell_single_inverse
 
 @ %def map_on_shell_single
 @ %def map_on_shell_single_inverse
 @
 \subsubsection{Mapping for a Breit-Wigner resonance}
 This is the standard Breit-Wigner mapping.  We apply it to a single
 variable, independently of or in addition to a unit-square mapping.  We
 assume here that the limits for the variable are 0 and 1, and that the
 mass $m$ and width $w$ are rescaled appropriately, so they are
 dimensionless and usually between 0 and 1.
 
 If [[x_free]] is set, it rescales the total energy and thus mass and
 width, since these are defined with respect to the total energy.
 <<SF mappings: procedures>>=
   subroutine map_breit_wigner (r, factor, p, m, w, x_free)
     real(default), intent(out) :: r
     real(default), intent(out) :: factor
     real(default), intent(in) :: p
     real(default), intent(in) :: m
     real(default), intent(in) :: w
     real(default), intent(in), optional :: x_free
     real(default) :: m2, mw, a1, a2, a3, z, tmp
     m2 = m ** 2
     mw = m * w
     if (present (x_free)) then
        m2 = m2 / x_free
        mw = mw / x_free
     end if
     a1 = atan (- m2 / mw)
     a2 = atan ((1 - m2) / mw)
     a3 = (a2 - a1) * mw
     z = (1-p) * a1 + p * a2
     if (-pi/2 < z .and. z < pi/2) then
        tmp = tan (z)
        r = max (m2 + mw * tmp, 0._default)
        factor = a3 * (1 + tmp ** 2)
     else
        r = 0
        factor = 0
     end if
   end subroutine map_breit_wigner
 
   subroutine map_breit_wigner_inverse (r, factor, p, m, w, x_free)
     real(default), intent(in) :: r
     real(default), intent(out) :: factor
     real(default), intent(out) :: p
     real(default), intent(in) :: m
     real(default), intent(in) :: w
     real(default) :: m2, mw, a1, a2, a3, tmp
     real(default), intent(in), optional :: x_free
     m2 = m ** 2
     mw = m * w
     if (present (x_free)) then
        m2 = m2 / x_free
        mw = mw / x_free
     end if
     a1 = atan (- m2 / mw)
     a2 = atan ((1 - m2) / mw)
     a3 = (a2 - a1) * mw
     tmp = (r - m2) / mw
     p = (atan (tmp) - a1) / (a2 - a1)
     factor = a3 * (1 + tmp ** 2)
   end subroutine map_breit_wigner_inverse
 
 @ %def map_breit_wigner
 @ %def map_breit_wigner_inverse
 @
 \subsubsection{Mapping with endpoint enhancement}
 This is a mapping which is close to the unit mapping, except that at
 the endpoint(s), the output values are exponentially enhanced.
 \begin{equation}
   y = \tanh (a \tan (\frac{\pi}{2}x))
 \end{equation}
 We have two variants: one covers endpoints at $0$ and $1$
 symmetrically, while the other one (which essentially maps one-half of
 the range), covers only the endpoint at $1$.
 <<SF mappings: procedures>>=
   subroutine map_endpoint_1 (x3, factor, x1, a)
     real(default), intent(out) :: x3, factor
     real(default), intent(in) :: x1
     real(default), intent(in) :: a
     real(default) :: x2
     if (abs (x1) < 1) then
        x2 = tan (x1 * pi / 2)
        x3 = tanh (a * x2)
        factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2)
     else
        x3 = x1
        factor = 0
     end if
   end subroutine map_endpoint_1
 
   subroutine map_endpoint_inverse_1 (x3, factor, x1, a)
     real(default), intent(in) :: x3
     real(default), intent(out) :: x1, factor
     real(default), intent(in) :: a
     real(default) :: x2
     if (abs (x3) < 1) then
        x2 = atanh (x3) / a
        x1 = 2 / pi * atan (x2)
        factor = a * pi/2 * (1 + x2 ** 2) * (1 - x3 ** 2)
     else
        x1 = x3
        factor = 0
     end if
   end subroutine map_endpoint_inverse_1
 
   subroutine map_endpoint_01 (x4, factor, x0, a)
     real(default), intent(out) :: x4, factor
     real(default), intent(in) :: x0
     real(default), intent(in) :: a
     real(default) :: x1, x3
     x1 = 2 * x0 - 1
     call map_endpoint_1 (x3, factor, x1, a)
     x4 = (x3 + 1) / 2
   end subroutine map_endpoint_01
 
   subroutine map_endpoint_inverse_01 (x4, factor, x0, a)
     real(default), intent(in) :: x4
     real(default), intent(out) :: x0, factor
     real(default), intent(in) :: a
     real(default) :: x1, x3
     x3 = 2 * x4 - 1
     call map_endpoint_inverse_1 (x3, factor, x1, a)
     x0 = (x1 + 1) / 2
   end subroutine map_endpoint_inverse_01
 
 @ %def map_endpoint_1
 @ %def map_endpoint_inverse_1
 @ %def map_endpoint_01
 @ %def map_endpoint_inverse_01
 @
 \subsubsection{Mapping with endpoint enhancement (ISR)}
 This is another endpoint mapping.  It is designed to flatten the ISR
 singularity which is of power type at $x=1$, i.e., if
 \begin{equation}
   \sigma = \int_0^1 dx\,f(x)\,G(x)
   = \int_0^1 dx\,\epsilon(1-x)^{-1+\epsilon} G(x),
 \end{equation}
 we replace this by
 \begin{equation}
   r = x^\epsilon \quad\Longrightarrow\quad
   \sigma = \int_0^1 dr\,G(1- (1-r)^{1/\epsilon}).
 \end{equation}
 We expect that $\epsilon$ is small.
 
 The actual mapping is $r\to x$ (so $x$ emerges closer to $1$).  The
 Jacobian that we return is thus $1/f(x)$.  We compute the mapping in
 terms of $\bar x\equiv 1 - x$, so we can achieve the required precision.
 Because some compilers show quite wild numeric fluctuations, we
 internally convert numeric types to explicit [[double]] precision.
 <<SF mappings: public>>=
   public :: map_power_1
   public :: map_power_inverse_1
 <<SF mappings: sub interfaces>>=
     module subroutine map_power_1 (xb, factor, rb, eps)
       real(default), intent(out) :: xb, factor
       real(default), intent(in) :: rb
       real(default), intent(in) :: eps
     end subroutine map_power_1
     module subroutine map_power_inverse_1 (xb, factor, rb, eps)
       real(default), intent(in) :: xb
       real(default), intent(out) :: rb, factor
       real(default), intent(in) :: eps
     end subroutine map_power_inverse_1
 <<SF mappings: procedures>>=
   module subroutine map_power_1 (xb, factor, rb, eps)
     real(default), intent(out) :: xb, factor
     real(default), intent(in) :: rb
     real(double) :: rb_db, factor_db, eps_db, xb_db
     real(default), intent(in) :: eps
     rb_db = real (rb, kind=double)
     eps_db = real (eps, kind=double)
     xb_db = rb_db ** (1 / eps_db)
     if (rb_db > 0) then
        factor_db = xb_db / rb_db / eps_db
        factor = real (factor_db, kind=default)
     else
        factor = 0
     end if
     xb = real (xb_db, kind=default)
   end subroutine map_power_1
 
   module subroutine map_power_inverse_1 (xb, factor, rb, eps)
     real(default), intent(in) :: xb
     real(default), intent(out) :: rb, factor
     real(double) :: xb_db, factor_db, eps_db, rb_db
     real(default), intent(in) :: eps
     xb_db = real (xb, kind=double)
     eps_db = real (eps, kind=double)
     rb_db = xb_db ** eps_db
     if (xb_db > 0) then
        factor_db = xb_db / rb_db / eps_db
        factor = real (factor_db, kind=default)
     else
        factor = 0
     end if
     rb = real (rb_db, kind=default)
   end subroutine map_power_inverse_1
 
 @ %def map_power_1
 @ %def map_power_inverse_1
 @ Here we apply a power mapping to both endpoints.  We divide the
 interval in two equal halves and apply the power mapping for the
 nearest endpoint, either $0$ or $1$.
 <<SF mappings: procedures>>=
   subroutine map_power_01 (y, yb, factor, r, eps)
     real(default), intent(out) :: y, yb, factor
     real(default), intent(in) :: r
     real(default), intent(in) :: eps
     real(default) :: u, ub, zp, zm
     u = 2 * r - 1
     if (u > 0) then
        ub = 2 * (1 - r)
        call map_power_1 (zm, factor, ub, eps)
        zp = 2 - zm
     else if (u < 0) then
        ub = 2 * r
        call map_power_1 (zp, factor, ub, eps)
        zm = 2 - zp
     else
        factor = 1 / eps
        zp = 1
        zm = 1
     end if
     y  = zp / 2
     yb = zm / 2
   end subroutine map_power_01
 
   subroutine map_power_inverse_01 (y, yb, factor, r, eps)
     real(default), intent(in) :: y, yb
     real(default), intent(out) :: r, factor
     real(default), intent(in) :: eps
     real(default) :: ub, zp, zm
     zp = 2 * y
     zm = 2 * yb
     if (zm < zp) then
        call map_power_inverse_1 (zm, factor, ub, eps)
        r = 1 - ub / 2
     else if (zp < zm) then
        call map_power_inverse_1 (zp, factor, ub, eps)
        r = ub / 2
     else
        factor = 1 / eps
        ub = 1
        r = ub / 2
     end if
   end subroutine map_power_inverse_01
 
 @ %def map_power_01
 @ %def map_power_inverse_01
 @
 \subsubsection{Structure-function channels}
 A structure-function chain parameterization (channel) may contain a
 mapping that applies to multiple structure functions.  This is
 described by an extension of the [[sf_mapping_t]] type.  In addition,
 it may contain mappings that apply to (other) individual structure
 functions.  The details of these mappings are implementation-specific.
 
 The [[sf_channel_t]] type combines this information.  It contains an
 array of map codes, one for each structure-function entry.  The code
 values are:
 \begin{description}
 \item[none] MC input parameters $r$ directly become energy fractions $x$
 \item[single] default mapping for a single structure-function entry
 \item[multi/s] map $r\to x$ such that one MC input parameter is $\hat s/s$
 \item[multi/resonance] as before, adapted to s-channel resonance
 \item[multi/on-shell] as before, adapted to an on-shell particle in
   the s channel
 \item[multi/endpoint] like multi/s, but enhance the region near $r_i=1$
 \item[multi/endpoint/res] endpoint mapping with resonance
 \item[multi/endpoint/os] endpoint mapping for on-shell
 \item[multi/power/os] like multi/endpoint, regulating a power singularity
 \end{description}
 <<SF mappings: parameters>>=
   integer, parameter :: SFMAP_NONE = 0
   integer, parameter :: SFMAP_SINGLE = 1
   integer, parameter :: SFMAP_MULTI_S = 2
   integer, parameter :: SFMAP_MULTI_RES = 3
   integer, parameter :: SFMAP_MULTI_ONS = 4
   integer, parameter :: SFMAP_MULTI_EP = 5
   integer, parameter :: SFMAP_MULTI_EPR = 6
   integer, parameter :: SFMAP_MULTI_EPO = 7
   integer, parameter :: SFMAP_MULTI_IP = 8
   integer, parameter :: SFMAP_MULTI_IPR = 9
   integer, parameter :: SFMAP_MULTI_IPO = 10
   integer, parameter :: SFMAP_MULTI_EI = 11
   integer, parameter :: SFMAP_MULTI_SRS = 13
   integer, parameter :: SFMAP_MULTI_SON = 14
 
 @ %def SFMAP_NONE SFMAP_SINGLE
 @ %def SFMAP_MULTI_S SFMAP_MULTI_RES SFMAP_MULTI_ONS
 @ %def SFMAP_MULTI_EP SFMAP_MULTI_EPR SFMAP_MULTI_EPO
 @ %def SFMAP_MULTI_IP SFMAP_MULTI_IPR SFMAP_MULTI_IPO
 @ %def SFMAP_MULTI_EI
 @ %def SFMAP_MULTI_SRS SFMAP_MULTI_SON
 @ Then, it contains an allocatable entry for the multi mapping.  This
 entry holds the MC-parameter indices on which the mapping applies
 (there may be more than one MC parameter per structure-function entry)
 and any parameters associated with the mapping.
 
 There can be only one multi-mapping per channel.
 <<SF mappings: public>>=
   public :: sf_channel_t
 <<SF mappings: types>>=
   type :: sf_channel_t
      integer, dimension(:), allocatable :: map_code
      class(sf_mapping_t), allocatable :: multi_mapping
    contains
    <<SF mappings: sf channel: TBP>>
   end type sf_channel_t
 
 @ %def sf_channel_t
 @ The output format prints a single character for each
 structure-function entry and, if applicable, an account of the mapping
 parameters.
 <<SF mappings: sf channel: TBP>>=
   procedure :: write => sf_channel_write
 <<SF mappings: sub interfaces>>=
     module subroutine sf_channel_write (object, unit)
       class(sf_channel_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_channel_write
 <<SF mappings: procedures>>=
   module subroutine sf_channel_write (object, unit)
     class(sf_channel_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     if (allocated (object%map_code)) then
        do i = 1, size (object%map_code)
           select case (object%map_code (i))
           case (SFMAP_NONE)
              write (u, "(1x,A)", advance="no") "-"
           case (SFMAP_SINGLE)
              write (u, "(1x,A)", advance="no") "+"
           case (SFMAP_MULTI_S)
              write (u, "(1x,A)", advance="no") "s"
           case (SFMAP_MULTI_RES, SFMAP_MULTI_SRS)
              write (u, "(1x,A)", advance="no") "r"
           case (SFMAP_MULTI_ONS, SFMAP_MULTI_SON)
              write (u, "(1x,A)", advance="no") "o"
           case (SFMAP_MULTI_EP)
              write (u, "(1x,A)", advance="no") "e"
           case (SFMAP_MULTI_EPR)
              write (u, "(1x,A)", advance="no") "p"
           case (SFMAP_MULTI_EPO)
              write (u, "(1x,A)", advance="no") "q"
           case (SFMAP_MULTI_IP)
              write (u, "(1x,A)", advance="no") "i"
           case (SFMAP_MULTI_IPR)
              write (u, "(1x,A)", advance="no") "i"
           case (SFMAP_MULTI_IPO)
              write (u, "(1x,A)", advance="no") "i"
           case (SFMAP_MULTI_EI)
              write (u, "(1x,A)", advance="no") "i"
           case default
              write (u, "(1x,A)", advance="no") "?"
           end select
        end do
     else
        write (u, "(1x,A)", advance="no") "-"
     end if
     if (allocated (object%multi_mapping)) then
        write (u, "(1x,'/')", advance="no")
        call object%multi_mapping%write (u)
     else
        write (u, *)
     end if
   end subroutine sf_channel_write
 
 @ %def sf_channel_write
 @ Initializer for a single [[sf_channel]] object.
 <<SF mappings: sf channel: TBP>>=
   procedure :: init => sf_channel_init
 <<SF mappings: sub interfaces>>=
     module subroutine sf_channel_init (channel, n_strfun)
       class(sf_channel_t), intent(out) :: channel
       integer, intent(in) :: n_strfun
     end subroutine sf_channel_init
 <<SF mappings: procedures>>=
   module subroutine sf_channel_init (channel, n_strfun)
     class(sf_channel_t), intent(out) :: channel
     integer, intent(in) :: n_strfun
     allocate (channel%map_code (n_strfun))
     channel%map_code = SFMAP_NONE
   end subroutine sf_channel_init
 
 @ %def sf_channel_init
 @ Assignment.  This merely copies intrinsic assignment.
 <<SF mappings: sf channel: TBP>>=
   generic :: assignment (=) => sf_channel_assign
   procedure :: sf_channel_assign
 <<SF mappings: sub interfaces>>=
     module subroutine sf_channel_assign (copy, original)
       class(sf_channel_t), intent(out) :: copy
       type(sf_channel_t), intent(in) :: original
     end subroutine sf_channel_assign
 <<SF mappings: procedures>>=
   module subroutine sf_channel_assign (copy, original)
     class(sf_channel_t), intent(out) :: copy
     type(sf_channel_t), intent(in) :: original
     allocate (copy%map_code (size (original%map_code)))
     copy%map_code = original%map_code
     if (allocated (original%multi_mapping)) then
          allocate (copy%multi_mapping, source = original%multi_mapping)
     end if
   end subroutine sf_channel_assign
 
 @ %def sf_channel_assign
 @ This initializer allocates an array of channels with common number of
 structure-function entries, therefore it is not a type-bound procedure.
 <<SF mappings: public>>=
   public :: allocate_sf_channels
 <<SF mappings: sub interfaces>>=
     module subroutine allocate_sf_channels (channel, n_channel, n_strfun)
       type(sf_channel_t), dimension(:), intent(out), allocatable :: channel
       integer, intent(in) :: n_channel
       integer, intent(in) :: n_strfun
     end subroutine allocate_sf_channels
 <<SF mappings: procedures>>=
   module subroutine allocate_sf_channels (channel, n_channel, n_strfun)
     type(sf_channel_t), dimension(:), intent(out), allocatable :: channel
     integer, intent(in) :: n_channel
     integer, intent(in) :: n_strfun
     integer :: c
     allocate (channel (n_channel))
     do c = 1, n_channel
        call channel(c)%init (n_strfun)
     end do
   end subroutine allocate_sf_channels
 
 @ %def allocate_sf_channels
 @ This marks a given subset of indices as single-mapping.
 <<SF mappings: sf channel: TBP>>=
   procedure :: activate_mapping => sf_channel_activate_mapping
 <<SF mappings: sub interfaces>>=
     module subroutine sf_channel_activate_mapping (channel, i_sf)
       class(sf_channel_t), intent(inout) :: channel
       integer, dimension(:), intent(in) :: i_sf
     end subroutine sf_channel_activate_mapping
 <<SF mappings: procedures>>=
   module subroutine sf_channel_activate_mapping (channel, i_sf)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     channel%map_code(i_sf) = SFMAP_SINGLE
   end subroutine sf_channel_activate_mapping
 
 @ %def sf_channel_activate_mapping
 @ This sets an s-channel multichannel mapping.  The parameter indices
 are not yet set. Gfortran 7/8/9 bug, has to remain in module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_s_mapping => sf_channel_set_s_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_s_mapping (channel, i_sf, power)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: power
     channel%map_code(i_sf) = SFMAP_MULTI_S
     allocate (sf_s_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_s_mapping_t)
        call mapping%init (power)
     end select
   end subroutine sf_channel_set_s_mapping
 
 @ %def sf_channel_set_s_mapping
 @ This sets an s-channel resonance multichannel mapping. Gfortran 7/8/9
 bug, has to remain in module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_res_mapping => sf_channel_set_res_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_res_mapping (channel, i_sf, m, w, single)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in) :: m, w
     logical, intent(in) :: single
     if (single) then
        channel%map_code(i_sf) = SFMAP_MULTI_SRS
        allocate (sf_res_mapping_single_t :: channel%multi_mapping)
        select type (mapping => channel%multi_mapping)
        type is (sf_res_mapping_single_t)
           call mapping%init (m, w)
        end select
     else
        channel%map_code(i_sf) = SFMAP_MULTI_RES
        allocate (sf_res_mapping_t :: channel%multi_mapping)
        select type (mapping => channel%multi_mapping)
        type is (sf_res_mapping_t)
           call mapping%init (m, w)
        end select
     end if
   end subroutine sf_channel_set_res_mapping
 
 @ %def sf_channel_set_res_mapping
 @ This sets an s-channel on-shell multichannel mapping.  The length of the
 [[i_sf]] array must be 2.  (The first parameter actually becomes an
 irrelevant dummy.) Gfortran 7/8/9 bug, has to remain in module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_os_mapping => sf_channel_set_os_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_os_mapping (channel, i_sf, m, single)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in) :: m
     logical, intent(in) :: single
     if (single) then
        channel%map_code(i_sf) = SFMAP_MULTI_SON
        allocate (sf_os_mapping_single_t :: channel%multi_mapping)
        select type (mapping => channel%multi_mapping)
        type is (sf_os_mapping_single_t)
           call mapping%init (m)
        end select
     else
        channel%map_code(i_sf) = SFMAP_MULTI_ONS
        allocate (sf_os_mapping_t :: channel%multi_mapping)
        select type (mapping => channel%multi_mapping)
        type is (sf_os_mapping_t)
           call mapping%init (m)
        end select
     end if
   end subroutine sf_channel_set_os_mapping
 
 @ %def sf_channel_set_os_mapping
 @ This sets an s-channel endpoint mapping.  The parameter $a$ is the
 slope parameter (default 1); increasing it moves the endpoint region
 (at $x=1$ to lower values in the input parameter) even more. Gfortran
 7/8/9 bug, has to remain in the module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ep_mapping => sf_channel_set_ep_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_ep_mapping (channel, i_sf, a)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: a
     channel%map_code(i_sf) = SFMAP_MULTI_EP
     allocate (sf_ep_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ep_mapping_t)
        call mapping%init (a = a)
     end select
   end subroutine sf_channel_set_ep_mapping
 
 @ %def sf_channel_set_ep_mapping
 @ This sets a resonant endpoint mapping. Gfortran
 7/8/9 bug, has to remain in the module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_epr_mapping => sf_channel_set_epr_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_epr_mapping (channel, i_sf, a, m, w)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in) :: a, m, w
     channel%map_code(i_sf) = SFMAP_MULTI_EPR
     allocate (sf_epr_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_epr_mapping_t)
        call mapping%init (a, m, w)
     end select
   end subroutine sf_channel_set_epr_mapping
 
 @ %def sf_channel_set_epr_mapping
 @ This sets an on-shell endpoint mapping. Gfortran
 7/8/9 bug, has to remain in the module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_epo_mapping => sf_channel_set_epo_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_epo_mapping (channel, i_sf, a, m)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in) :: a, m
     channel%map_code(i_sf) = SFMAP_MULTI_EPO
     allocate (sf_epo_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_epo_mapping_t)
        call mapping%init (a, m)
     end select
   end subroutine sf_channel_set_epo_mapping
 
 @ %def sf_channel_set_epo_mapping
 @ This sets an s-channel power mapping, regulating a singularity of
 type $(1-x)^{-1+\epsilon}$.  The parameter $\epsilon$ depends on the
 structure function. Gfortran 7/8/9 bug, has to remain in the module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ip_mapping => sf_channel_set_ip_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_ip_mapping (channel, i_sf, eps)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: eps
     channel%map_code(i_sf) = SFMAP_MULTI_IP
     allocate (sf_ip_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ip_mapping_t)
        call mapping%init (eps)
     end select
   end subroutine sf_channel_set_ip_mapping
 
 @ %def sf_channel_set_ip_mapping
 @ This sets an s-channel resonant power mapping, regulating a
 singularity of type $(1-x)^{-1+\epsilon}$ in the presence of an
 s-channel resonance.  The parameter $\epsilon$ depends on the
 structure function. Gfortran 7/8/9 bug, has to remain in the module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ipr_mapping => sf_channel_set_ipr_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_ipr_mapping (channel, i_sf, eps, m, w)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: eps, m, w
     channel%map_code(i_sf) = SFMAP_MULTI_IPR
     allocate (sf_ipr_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ipr_mapping_t)
        call mapping%init (eps, m, w)
     end select
   end subroutine sf_channel_set_ipr_mapping
 
 @ %def sf_channel_set_ipr_mapping
 @ This sets an on-shell power mapping, regulating a
 singularity of type $(1-x)^{-1+\epsilon}$ for the production of a
 single on-shell particle..  The parameter $\epsilon$ depends on the
 structure function. Gfortran 7/8/9 bug: has to remain in module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ipo_mapping => sf_channel_set_ipo_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_ipo_mapping (channel, i_sf, eps, m)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: eps, m
     channel%map_code(i_sf) = SFMAP_MULTI_IPO
     allocate (sf_ipo_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ipo_mapping_t)
        call mapping%init (eps, m)
     end select
   end subroutine sf_channel_set_ipo_mapping
 
 @ %def sf_channel_set_ipo_mapping
 @ This sets a combined endpoint/ISR mapping. Gfortran 7/8/9 bug, remains
 in module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_ei_mapping => sf_channel_set_ei_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_ei_mapping (channel, i_sf, a, eps)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: a, eps
     channel%map_code(i_sf) = SFMAP_MULTI_EI
     allocate (sf_ei_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_ei_mapping_t)
        call mapping%init (a, eps)
     end select
   end subroutine sf_channel_set_ei_mapping
 
 @ %def sf_channel_set_ei_mapping
 @ This sets a combined endpoint/ISR mapping with resonance. Gfortran
 7/8/9 bug, remains in module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_eir_mapping => sf_channel_set_eir_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_eir_mapping (channel, i_sf, a, eps, m, w)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: a, eps, m, w
     channel%map_code(i_sf) = SFMAP_MULTI_EI
     allocate (sf_eir_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_eir_mapping_t)
        call mapping%init (a, eps, m, w)
     end select
   end subroutine sf_channel_set_eir_mapping
 
 @ %def sf_channel_set_eir_mapping
 @ This sets a combined endpoint/ISR mapping, on-shell. Gfortran 7/8/9 bug,
 remains in module.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_eio_mapping => sf_channel_set_eio_mapping
 <<SF mappings: main procedures>>=
   subroutine sf_channel_set_eio_mapping (channel, i_sf, a, eps, m)
     class(sf_channel_t), intent(inout) :: channel
     integer, dimension(:), intent(in) :: i_sf
     real(default), intent(in), optional :: a, eps, m
     channel%map_code(i_sf) = SFMAP_MULTI_EI
     allocate (sf_eio_mapping_t :: channel%multi_mapping)
     select type (mapping => channel%multi_mapping)
     type is (sf_eio_mapping_t)
        call mapping%init (a, eps, m)
     end select
   end subroutine sf_channel_set_eio_mapping
 
 @ %def sf_channel_set_eio_mapping
 @ Return true if the mapping code at position [[i_sf]] is [[SFMAP_SINGLE]].
 <<SF mappings: sf channel: TBP>>=
   procedure :: is_single_mapping => sf_channel_is_single_mapping
 <<SF mappings: sub interfaces>>=
     module function sf_channel_is_single_mapping (channel, i_sf) result (flag)
       class(sf_channel_t), intent(in) :: channel
       integer, intent(in) :: i_sf
       logical :: flag
     end function sf_channel_is_single_mapping
 <<SF mappings: procedures>>=
   module function sf_channel_is_single_mapping (channel, i_sf) result (flag)
     class(sf_channel_t), intent(in) :: channel
     integer, intent(in) :: i_sf
     logical :: flag
     flag = channel%map_code(i_sf) == SFMAP_SINGLE
   end function sf_channel_is_single_mapping
 
 @ %def sf_channel_is_single_mapping
 @ Return true if the mapping code at position [[i_sf]] is any of the
 [[SFMAP_MULTI]] mappings.
 <<SF mappings: sf channel: TBP>>=
   procedure :: is_multi_mapping => sf_channel_is_multi_mapping
 <<SF mappings: sub interfaces>>=
     module function sf_channel_is_multi_mapping (channel, i_sf) result (flag)
       class(sf_channel_t), intent(in) :: channel
       integer, intent(in) :: i_sf
       logical :: flag
     end function sf_channel_is_multi_mapping
 <<SF mappings: procedures>>=
   module function sf_channel_is_multi_mapping (channel, i_sf) result (flag)
     class(sf_channel_t), intent(in) :: channel
     integer, intent(in) :: i_sf
     logical :: flag
     select case (channel%map_code(i_sf))
     case (SFMAP_NONE, SFMAP_SINGLE)
        flag = .false.
     case default
        flag = .true.
     end select
   end function sf_channel_is_multi_mapping
 
 @ %def sf_channel_is_multi_mapping
 @ Return the number of parameters that the multi-mapping requires.  The
 mapping object must be allocated.
 <<SF mappings: sf channel: TBP>>=
   procedure :: get_multi_mapping_n_par => sf_channel_get_multi_mapping_n_par
 <<SF mappings: sub interfaces>>=
     module function sf_channel_get_multi_mapping_n_par (channel) result (n_par)
       class(sf_channel_t), intent(in) :: channel
       integer :: n_par
     end function sf_channel_get_multi_mapping_n_par
 <<SF mappings: procedures>>=
   module function sf_channel_get_multi_mapping_n_par (channel) result (n_par)
     class(sf_channel_t), intent(in) :: channel
     integer :: n_par
     if (allocated (channel%multi_mapping)) then
        n_par = channel%multi_mapping%get_n_dim ()
     else
        n_par = 0
     end if
   end function sf_channel_get_multi_mapping_n_par
 
 @ %def sf_channel_get_multi_mapping_n_par
 @ Return true if there is any nontrivial mapping in any of the channels.
 <<SF mappings: public>>=
   public :: any_sf_channel_has_mapping
 <<SF mappings: sub interfaces>>=
     module function any_sf_channel_has_mapping (channel) result (flag)
       type(sf_channel_t), dimension(:), intent(in) :: channel
       logical :: flag
     end function any_sf_channel_has_mapping
 <<SF mappings: procedures>>=
   module function any_sf_channel_has_mapping (channel) result (flag)
     type(sf_channel_t), dimension(:), intent(in) :: channel
     logical :: flag
     integer :: c
     flag = .false.
     do c = 1, size (channel)
        flag = flag .or. any (channel(c)%map_code /= SFMAP_NONE)
     end do
   end function any_sf_channel_has_mapping
 
 @ %def any_sf_channel_has_mapping
 @ Set a parameter index for an active multi mapping.  We assume that
 the index array is allocated properly.
 <<SF mappings: sf channel: TBP>>=
   procedure :: set_par_index => sf_channel_set_par_index
 <<SF mappings: sub interfaces>>=
     module subroutine sf_channel_set_par_index (channel, j, i_par)
       class(sf_channel_t), intent(inout) :: channel
       integer, intent(in) :: j
       integer, intent(in) :: i_par
     end subroutine sf_channel_set_par_index
 <<SF mappings: procedures>>=
   module subroutine sf_channel_set_par_index (channel, j, i_par)
     class(sf_channel_t), intent(inout) :: channel
     integer, intent(in) :: j
     integer, intent(in) :: i_par
     associate (mapping => channel%multi_mapping)
       if (j >= 1 .and. j <= mapping%get_n_dim ()) then
          if (mapping%get_index (j) == 0) then
             call channel%multi_mapping%set_index (j, i_par)
          else
             call msg_bug ("Structure-function setup: mapping index set twice")
          end if
       else
          call msg_bug ("Structure-function setup: mapping index out of range")
       end if
     end associate
   end subroutine sf_channel_set_par_index
 
 @ %def sf_channel_set_par_index
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_mappings_ut.f90]]>>=
 <<File header>>
 
 module sf_mappings_ut
   use unit_tests
   use sf_mappings_uti
 
 <<Standard module head>>
 
 <<SF mappings: public test>>
 
 contains
 
 <<SF mappings: test driver>>
 
 end module sf_mappings_ut
 @ %def sf_mappings_ut
 @
 <<[[sf_mappings_uti.f90]]>>=
 <<File header>>
 
 module sf_mappings_uti
 
 <<Use kinds>>
   use format_defs, only: FMT_11, FMT_12, FMT_13, FMT_14, FMT_15, FMT_16
 
   use sf_mappings
 
 <<Standard module head>>
 
 <<SF mappings: test declarations>>
 
 contains
 
 <<SF mappings: tests>>
 
 end module sf_mappings_uti
 @ %def sf_mappings_ut
 @ API: driver for the unit tests below.
 <<SF mappings: public test>>=
   public :: sf_mappings_test
 <<SF mappings: test driver>>=
   subroutine sf_mappings_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF mappings: execute tests>>
   end subroutine sf_mappings_test
 
 @ %def sf_mappings_test
 @
 \subsubsection{Check standard mapping}
 Probe the standard mapping of the unit square for different parameter
 values.  Also calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not using
 random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_1, "sf_mappings_1", &
        "standard pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_1
 <<SF mappings: tests>>=
   subroutine sf_mappings_1 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_1"
     write (u, "(A)")  "*   Purpose: probe standard mapping"
     write (u, "(A)")
 
     allocate (sf_s_mapping_t :: mapping)
     select type (mapping)
     type is (sf_s_mapping_t)
        call mapping%init ()
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.1):"
     p = [0.1_default, 0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
     allocate (sf_s_mapping_t :: mapping)
     select type (mapping)
     type is (sf_s_mapping_t)
        call mapping%init (power=2._default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     write (u, *)
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.1):"
     p = [0.1_default, 0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)")  "I =", mapping%integral (100000)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_1"
 
   end subroutine sf_mappings_1
 
 @ %def sf_mappings_1
 @
 \subsubsection{Channel entries}
 Construct channel entries and print them.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_2, "sf_mappings_2", &
        "structure-function mapping channels", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_2
 <<SF mappings: tests>>=
   subroutine sf_mappings_2 (u)
     integer, intent(in) :: u
     type(sf_channel_t), dimension(:), allocatable :: channel
     integer :: c
 
     write (u, "(A)")  "* Test output: sf_mappings_2"
     write (u, "(A)")  "*   Purpose: construct and display &
          &mapping-channel objects"
     write (u, "(A)")
 
     call allocate_sf_channels (channel, n_channel = 8, n_strfun = 2)
     call channel(2)%activate_mapping ([1])
     call channel(3)%set_s_mapping ([1,2])
     call channel(4)%set_s_mapping ([1,2], power=2._default)
     call channel(5)%set_res_mapping ([1,2], m = 0.5_default, w = 0.1_default, single = .false.)
     call channel(6)%set_os_mapping ([1,2], m = 0.5_default, single = .false.)
     call channel(7)%set_res_mapping ([1], m = 0.5_default, w = 0.1_default, single = .true.)
     call channel(8)%set_os_mapping ([1], m = 0.5_default, single = .true.)
 
     call channel(3)%set_par_index (1, 1)
     call channel(3)%set_par_index (2, 4)
 
     call channel(4)%set_par_index (1, 1)
     call channel(4)%set_par_index (2, 4)
 
     call channel(5)%set_par_index (1, 1)
     call channel(5)%set_par_index (2, 3)
 
     call channel(6)%set_par_index (1, 1)
     call channel(6)%set_par_index (2, 2)
 
     call channel(7)%set_par_index (1, 1)
 
     call channel(8)%set_par_index (1, 1)
 
     do c = 1, size (channel)
        write (u, "(I0,':')", advance="no")  c
        call channel(c)%write (u)
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_2"
 
   end subroutine sf_mappings_2
 
 @ %def sf_mappings_2
 @
 \subsubsection{Check resonance mapping}
 Probe the resonance mapping of the unit square for different parameter
 values.  Also calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not using
 random points.
 
 The resonance mass is at $1/2$ the energy, the width is $1/10$.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_3, "sf_mappings_3", &
        "resonant pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_3
 <<SF mappings: tests>>=
   subroutine sf_mappings_3 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_3"
     write (u, "(A)")  "*   Purpose: probe resonance pair mapping"
     write (u, "(A)")
 
     allocate (sf_res_mapping_t :: mapping)
     select type (mapping)
     type is (sf_res_mapping_t)
        call mapping%init (0.5_default, 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.1):"
     p = [0.1_default, 0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_3"
 
   end subroutine sf_mappings_3
 
 @ %def sf_mappings_3
 @
 \subsubsection{Check on-shell mapping}
 Probe the on-shell mapping of the unit square for different parameter
 values.  Also calculates integrals.  In this case, the Jacobian is
 constant and given by $|\log m^2|$, so this is also the value of the
 integral.  The factor results from the variable change in the $\delta$
 function $\delta (m^2 - x_1x_2)$ which multiplies the cross section
 for the case at hand.
 
 For the test, the (rescaled) resonance mass is set at $1/2$ the
 energy.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_4, "sf_mappings_4", &
        "on-shell pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_4
 <<SF mappings: tests>>=
   subroutine sf_mappings_4 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_4"
     write (u, "(A)")  "*   Purpose: probe on-shell pair mapping"
     write (u, "(A)")
 
     allocate (sf_os_mapping_t :: mapping)
     select type (mapping)
     type is (sf_os_mapping_t)
        call mapping%init (0.5_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.1):"
     p = [0._default, 0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,1.0):"
     p = [0._default, 1.0_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_4"
 
   end subroutine sf_mappings_4
 
 @ %def sf_mappings_4
 @
 \subsubsection{Check endpoint mapping}
 Probe the endpoint mapping of the unit square for different parameter
 values.  Also calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not using
 random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_5, "sf_mappings_5", &
        "endpoint pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_5
 <<SF mappings: tests>>=
   subroutine sf_mappings_5 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_5"
     write (u, "(A)")  "*   Purpose: probe endpoint pair mapping"
     write (u, "(A)")
 
     allocate (sf_ep_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ep_mapping_t)
        call mapping%init ()
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_5"
 
   end subroutine sf_mappings_5
 
 @ %def sf_mappings_5
 @
 \subsubsection{Check endpoint resonant mapping}
 Probe the endpoint mapping with resonance.  Also calculates integrals.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_6, "sf_mappings_6", &
        "endpoint resonant mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_6
 <<SF mappings: tests>>=
   subroutine sf_mappings_6 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_6"
     write (u, "(A)")  "*   Purpose: probe endpoint resonant mapping"
     write (u, "(A)")
 
     allocate (sf_epr_mapping_t :: mapping)
     select type (mapping)
     type is (sf_epr_mapping_t)
        call mapping%init (a = 1._default, m = 0.5_default, w = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Same mapping without resonance:"
     write (u, "(A)")
 
     allocate (sf_epr_mapping_t :: mapping)
     select type (mapping)
     type is (sf_epr_mapping_t)
        call mapping%init (a = 1._default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_6"
 
   end subroutine sf_mappings_6
 
 @ %def sf_mappings_6
 @
 \subsubsection{Check endpoint on-shell mapping}
 Probe the endpoint mapping with an on-shell particle.  Also calculates
 integrals.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_7, "sf_mappings_7", &
        "endpoint on-shell mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_7
 <<SF mappings: tests>>=
   subroutine sf_mappings_7 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_7"
     write (u, "(A)")  "*   Purpose: probe endpoint on-shell mapping"
     write (u, "(A)")
 
     allocate (sf_epo_mapping_t :: mapping)
     select type (mapping)
     type is (sf_epo_mapping_t)
        call mapping%init (a = 1._default, m = 0.5_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0):"
     p = [0._default, 0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1,0.5):"
     p = [0.1_default, 0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_7"
 
   end subroutine sf_mappings_7
 
 @ %def sf_mappings_7
 @
 \subsubsection{Check power mapping}
 Probe the power mapping of the unit square for different parameter
 values.  Also calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not using
 random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_8, "sf_mappings_8", &
        "power pair mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_8
 <<SF mappings: tests>>=
   subroutine sf_mappings_8 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_8"
     write (u, "(A)")  "*   Purpose: probe power pair mapping"
     write (u, "(A)")
 
     allocate (sf_ip_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ip_mapping_t)
        call mapping%init (eps = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.5):"
     p = [0._default, 0.5_default]
     pb= [1._default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9,0.5):"
     p = [0.9_default, 0.5_default]
     pb= [0.1_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     pb= [0.3_default, 0.8_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.8):"
     p = [0.7_default, 0.8_default]
     pb= [0.3_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.99,0.02):"
     p = [0.99_default, 0.02_default]
     pb= [0.01_default, 0.98_default]
     call mapping%check (u, p, pb, FMT_14, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.99,0.98):"
     p = [0.99_default, 0.98_default]
     pb= [0.01_default, 0.02_default]
     call mapping%check (u, p, pb, FMT_14, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_8"
 
   end subroutine sf_mappings_8
 
 @ %def sf_mappings_8
 @
 \subsubsection{Check resonant power mapping}
 Probe the power mapping of the unit square, adapted for an s-channel
 resonance, for different parameter values.  Also calculates integrals.
 For a finite number of bins, they differ slightly from $1$, but the
 result is well-defined because we are not using random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_9, "sf_mappings_9", &
        "power resonance mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_9
 <<SF mappings: tests>>=
   subroutine sf_mappings_9 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_9"
     write (u, "(A)")  "*   Purpose: probe power resonant pair mapping"
     write (u, "(A)")
 
     allocate (sf_ipr_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ipr_mapping_t)
        call mapping%init (eps = 0.1_default, m = 0.5_default, w = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.5):"
     p = [0._default, 0.5_default]
     pb= [1._default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9,0.5):"
     p = [0.9_default, 0.5_default]
     pb= [0.1_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     pb= [0.3_default, 0.8_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.8):"
     p = [0.7_default, 0.8_default]
     pb= [0.3_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9999,0.02):"
     p = [0.9999_default, 0.02_default]
     pb= [0.0001_default, 0.98_default]
     call mapping%check (u, p, pb, FMT_11, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9999,0.98):"
     p = [0.9999_default, 0.98_default]
     pb= [0.0001_default, 0.02_default]
     call mapping%check (u, p, pb, FMT_11, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Same mapping without resonance:"
     write (u, "(A)")
 
     allocate (sf_ipr_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ipr_mapping_t)
        call mapping%init (eps = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.5):"
     p = [0._default, 0.5_default]
     pb= [1._default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5,0.5):"
     p = [0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9,0.5):"
     p = [0.9_default, 0.5_default]
     pb= [0.1_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.2):"
     p = [0.7_default, 0.2_default]
     pb= [0.3_default, 0.8_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7,0.8):"
     p = [0.7_default, 0.8_default]
     pb= [0.3_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_9"
 
   end subroutine sf_mappings_9
 
 @ %def sf_mappings_9
 @
 \subsubsection{Check on-shell power mapping}
 Probe the power mapping of the unit square, adapted for
 single-particle production, for different parameter values.  Also
 calculates integrals.  For a finite number of bins, they differ
 slightly from $1$, but the result is well-defined because we are not
 using random points.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_10, "sf_mappings_10", &
        "power on-shell mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_10
 <<SF mappings: tests>>=
   subroutine sf_mappings_10 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(2) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_10"
     write (u, "(A)")  "*   Purpose: probe power on-shell mapping"
     write (u, "(A)")
 
     allocate (sf_ipo_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ipo_mapping_t)
        call mapping%init (eps = 0.1_default, m = 0.5_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.5):"
     p = [0._default, 0.5_default]
     pb= [1._default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.02):"
     p = [0._default, 0.02_default]
     pb= [1._default, 0.98_default]
     call mapping%check (u, p, pb, FMT_15, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0,0.98):"
     p = [0._default, 0.98_default]
     pb= [1._default, 0.02_default]
     call mapping%check (u, p, pb, FMT_15, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_10"
 
   end subroutine sf_mappings_10
 
 @ %def sf_mappings_10
 @
 \subsubsection{Check combined endpoint-power mapping}
 Probe the mapping for the beamstrahlung/ISR combination.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_11, "sf_mappings_11", &
        "endpoint/power combined mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_11
 <<SF mappings: tests>>=
   subroutine sf_mappings_11 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(4) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_11"
     write (u, "(A)")  "*   Purpose: probe power pair mapping"
     write (u, "(A)")
 
     allocate (sf_ei_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ei_mapping_t)
        call mapping%init (eps = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
        call mapping%set_index (3, 3)
        call mapping%set_index (4, 4)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5, 0.5, 0.5, 0.5):"
     p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7, 0.2, 0.4, 0.8):"
     p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
     pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9, 0.06, 0.95, 0.1):"
     p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
     pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
     call mapping%check (u, p, pb, FMT_13, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_11"
 
   end subroutine sf_mappings_11
 
 @ %def sf_mappings_11
 @
 \subsubsection{Check resonant endpoint-power mapping}
 Probe the mapping for the beamstrahlung/ISR combination.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_12, "sf_mappings_12", &
        "endpoint/power resonant combined mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_12
 <<SF mappings: tests>>=
   subroutine sf_mappings_12 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(4) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_12"
     write (u, "(A)")  "*   Purpose: probe resonant combined mapping"
     write (u, "(A)")
 
     allocate (sf_eir_mapping_t :: mapping)
     select type (mapping)
     type is (sf_eir_mapping_t)
        call mapping%init (a = 1._default, &
             eps = 0.1_default, m = 0.5_default, w = 0.1_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
        call mapping%set_index (3, 3)
        call mapping%set_index (4, 4)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5, 0.5, 0.5, 0.5):"
     p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7, 0.2, 0.4, 0.8):"
     p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
     pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9, 0.06, 0.95, 0.1):"
     p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
     pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
     call mapping%check (u, p, pb, FMT_15, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_12"
 
   end subroutine sf_mappings_12
 
 @ %def sf_mappings_12
 @
 \subsubsection{Check on-shell endpoint-power mapping}
 Probe the mapping for the beamstrahlung/ISR combination.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_13, "sf_mappings_13", &
        "endpoint/power on-shell combined mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_13
 <<SF mappings: tests>>=
   subroutine sf_mappings_13 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(4) :: p, pb
 
     write (u, "(A)")  "* Test output: sf_mappings_13"
     write (u, "(A)")  "*   Purpose: probe on-shell combined mapping"
     write (u, "(A)")
 
     allocate (sf_eio_mapping_t :: mapping)
     select type (mapping)
     type is (sf_eio_mapping_t)
        call mapping%init (a = 1._default, eps = 0.1_default, m = 0.5_default)
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
        call mapping%set_index (3, 3)
        call mapping%set_index (4, 4)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5, 0.5, 0.5, 0.5):"
     p = [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     pb= [0.5_default, 0.5_default, 0.5_default, 0.5_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.7, 0.2, 0.4, 0.8):"
     p = [0.7_default, 0.2_default, 0.4_default, 0.8_default]
     pb= [0.3_default, 0.8_default, 0.6_default, 0.2_default]
     call mapping%check (u, p, pb, FMT_16)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.9, 0.06, 0.95, 0.1):"
     p = [0.9_default, 0.06_default, 0.95_default, 0.1_default]
     pb= [0.1_default, 0.94_default, 0.05_default, 0.9_default]
     call mapping%check (u, p, pb, FMT_14, FMT_12)
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_13"
 
   end subroutine sf_mappings_13
 
 @ %def sf_mappings_13
 @
 \subsubsection{Check rescaling}
 Check the rescaling factor in on-shell basic mapping.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_14, "sf_mappings_14", &
        "rescaled on-shell mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_14
 <<SF mappings: tests>>=
   subroutine sf_mappings_14 (u)
     integer, intent(in) :: u
     real(default), dimension(2) :: p2, r2
     real(default), dimension(1) :: p1, r1
     real(default) :: f, x_free, m2
 
     write (u, "(A)")  "* Test output: sf_mappings_14"
     write (u, "(A)")  "*   Purpose: probe rescaling in os mapping"
     write (u, "(A)")
 
     x_free = 0.9_default
     m2 = 0.5_default
 
     write (u, "(A)")  "* Two parameters"
     write (u, "(A)")
 
     p2 = [0.1_default, 0.2_default]
 
     call map_on_shell (r2, f, p2, -log (m2), x_free)
 
     write (u, "(A,9(1x," // FMT_14 // "))")  "p =", p2
     write (u, "(A,9(1x," // FMT_14 // "))")  "r =", r2
     write (u, "(A,9(1x," // FMT_14 // "))")  "f =", f
     write (u, "(A,9(1x," // FMT_14 // "))")  "*r=", x_free * product (r2)
 
     write (u, *)
 
     call map_on_shell_inverse (r2, f, p2, -log (m2), x_free)
 
     write (u, "(A,9(1x," // FMT_14 // "))")  "p =", p2
     write (u, "(A,9(1x," // FMT_14 // "))")  "r =", r2
     write (u, "(A,9(1x," // FMT_14 // "))")  "f =", f
     write (u, "(A,9(1x," // FMT_14 // "))")  "*r=", x_free * product (r2)
 
     write (u, "(A)")
     write (u, "(A)")  "* One parameter"
     write (u, "(A)")
 
     p1 = [0.1_default]
 
     call map_on_shell_single (r1, f, p1, -log (m2), x_free)
 
     write (u, "(A,9(1x," // FMT_14 // "))")  "p =", p1
     write (u, "(A,9(1x," // FMT_14 // "))")  "r =", r1
     write (u, "(A,9(1x," // FMT_14 // "))")  "f =", f
     write (u, "(A,9(1x," // FMT_14 // "))")  "*r=", x_free * product (r1)
 
     write (u, *)
 
     call map_on_shell_single_inverse (r1, f, p1, -log (m2), x_free)
 
     write (u, "(A,9(1x," // FMT_14 // "))")  "p =", p1
     write (u, "(A,9(1x," // FMT_14 // "))")  "r =", r1
     write (u, "(A,9(1x," // FMT_14 // "))")  "f =", f
     write (u, "(A,9(1x," // FMT_14 // "))")  "*r=", x_free * product (r1)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_14"
 
   end subroutine sf_mappings_14
 
 @ %def sf_mappings_14
 @
 \subsubsection{Check single parameter resonance mapping}
 Probe the resonance mapping of the unit interval for different parameter
 values.  Also calculates integrals.
 
 The resonance mass is at $1/2$ the energy, the width is $1/10$.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_15, "sf_mappings_15", &
        "resonant single mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_15
 <<SF mappings: tests>>=
   subroutine sf_mappings_15 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(1) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_15"
     write (u, "(A)")  "*   Purpose: probe resonance single mapping"
     write (u, "(A)")
 
     allocate (sf_res_mapping_single_t :: mapping)
     select type (mapping)
     type is (sf_res_mapping_single_t)
        call mapping%init (0.5_default, 0.1_default)
        call mapping%set_index (1, 1)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0):"
     p = [0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5):"
     p = [0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.1):"
     p = [0.1_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_15"
 
   end subroutine sf_mappings_15
 
 @ %def sf_mappings_15
 @
 \subsubsection{Check single parameter on-shell mapping}
 Probe the on-shell (pseudo) mapping of the unit interval for different parameter
 values.  Also calculates integrals.
 
 The resonance mass is at $1/2$ the energy.
 <<SF mappings: execute tests>>=
   call test (sf_mappings_16, "sf_mappings_16", &
        "on-shell single mapping", &
        u, results)
 <<SF mappings: test declarations>>=
   public :: sf_mappings_16
 <<SF mappings: tests>>=
   subroutine sf_mappings_16 (u)
     integer, intent(in) :: u
     class(sf_mapping_t), allocatable :: mapping
     real(default), dimension(1) :: p
 
     write (u, "(A)")  "* Test output: sf_mappings_16"
     write (u, "(A)")  "*   Purpose: probe on-shell single mapping"
     write (u, "(A)")
 
     allocate (sf_os_mapping_single_t :: mapping)
     select type (mapping)
     type is (sf_os_mapping_single_t)
        call mapping%init (0.5_default)
        call mapping%set_index (1, 1)
     end select
 
     call mapping%write (u)
 
     write (u, *)
     write (u, "(A)")  "Probe at (0):"
     p = [0._default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Probe at (0.5):"
     p = [0.5_default]
     call mapping%check (u, p, 1-p, "F7.5")
 
     write (u, *)
     write (u, "(A)")  "Compute integral:"
     write (u, "(3x,A,1x,F7.5)") "I =", mapping%integral (100000)
 
     deallocate (mapping)
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_mappings_16"
 
   end subroutine sf_mappings_16
 
 @ %def sf_mappings_16
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Structure function base}
 
 <<[[sf_base.f90]]>>=
 <<File header>>
 
 module sf_base
 
 <<Use kinds>>
 <<Use strings>>
   use numeric_utils, only: pacify
   use lorentz
   use quantum_numbers
   use pdg_arrays
   use interactions
   use evaluators
   use beams
   use sf_aux
   use sf_mappings
 
 <<Standard module head>>
 
 <<SF base: public>>
 
 <<SF base: parameters>>
 
 <<SF base: types>>
 
 <<SF base: interfaces>>
 
   interface
 <<SF base: sub interfaces>>
   end interface
 
 end module sf_base
 @ %def sf_base
 @
 <<[[sf_base_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_base) sf_base_s
 
   use io_units
   use format_utils, only: write_separator
   use format_defs, only: FMT_17, FMT_19
   use constants, only: one, two
   use diagnostics
   use physics_defs, only: n_beams_rescaled
 
   implicit none
 
 contains
 
 <<SF base: procedures>>
 
 end submodule sf_base_s
 
 @ %def sf_base_s
 @
 \subsection{Abstract rescale data-type}
 
 NLO calculations require the treatment of initial state parton radiation.
 The radiation of a parton rescales the energy fraction which enters the hard process.
 We allow for different rescale settings by extending the abstract.
 [[sf_rescale_t]] data type.
 <<SF base: public>>=
   public :: sf_rescale_t
 <<SF base: types>>=
   type, abstract :: sf_rescale_t
     integer :: i_beam = 0
   contains
   <<SF base: rescaling function: TBP>>
   end type sf_rescale_t
 
 @ %def sf_rescale_t
 @
 <<SF base: rescaling function: TBP>>=
   procedure (sf_rescale_apply), deferred :: apply
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_rescale_apply (func, x)
        import
        class(sf_rescale_t), intent(in) :: func
        real(default), intent(inout) :: x
      end subroutine sf_rescale_apply
   end interface
 
 @ %def rescale_apply
 @
 <<SF base: rescaling function: TBP>>=
   procedure :: set_i_beam => sf_rescale_set_i_beam
 <<SF base: sub interfaces>>=
     module subroutine sf_rescale_set_i_beam (func, i_beam)
       class(sf_rescale_t), intent(inout) :: func
       integer, intent(in) :: i_beam
     end subroutine sf_rescale_set_i_beam
 <<SF base: procedures>>=
   module subroutine sf_rescale_set_i_beam (func, i_beam)
     class(sf_rescale_t), intent(inout) :: func
     integer, intent(in) :: i_beam
     func%i_beam = i_beam
   end subroutine sf_rescale_set_i_beam
 
 @ %def rescale_set_i_beam
 @
 <<SF base: public>>=
   public :: sf_rescale_collinear_t
 <<SF base: types>>=
   type, extends (sf_rescale_t) :: sf_rescale_collinear_t
      real(default) :: xi_tilde
   contains
   <<SF base: rescale collinear: TBP>>
   end type sf_rescale_collinear_t
 
 @ %def sf_rescale_collinear_t
 @ For the subtraction terms we need to rescale the Born $x$ of both beams in the
 collinear limit. This leaves one beam unaffected and rescales the other according to
 \begin{equation}
   x = \frac{\overline{x}}{1-\xi}
 \end{equation}
 which is the collinear limit of [[sf_rescale_real_apply]].
 <<SF base: rescale collinear: TBP>>=
   procedure :: apply => sf_rescale_collinear_apply
 <<SF base: sub interfaces>>=
     module subroutine sf_rescale_collinear_apply (func, x)
       class(sf_rescale_collinear_t), intent(in) :: func
       real(default), intent(inout) :: x
     end subroutine sf_rescale_collinear_apply
 <<SF base: procedures>>=
   module subroutine sf_rescale_collinear_apply (func, x)
     class(sf_rescale_collinear_t), intent(in) :: func
     real(default), intent(inout) :: x
     real(default) :: xi
     if (debug2_active (D_BEAMS)) then
        print *, 'Rescaling function - Collinear: '
        print *, 'Input, unscaled x: ', x
        print *, 'xi_tilde: ', func%xi_tilde
     end if
     xi = func%xi_tilde * (one - x)
     x = x / (one - xi)
     if (debug2_active (D_BEAMS))  print *, 'rescaled x: ', x
   end subroutine sf_rescale_collinear_apply
 
 @ %def sf_rescale_collinear_apply
 @
 <<SF base: rescale collinear: TBP>>=
   procedure :: set => sf_rescale_collinear_set
 <<SF base: sub interfaces>>=
     module subroutine sf_rescale_collinear_set (func, xi_tilde)
       class(sf_rescale_collinear_t), intent(inout) :: func
       real(default), intent(in) :: xi_tilde
     end subroutine sf_rescale_collinear_set
 <<SF base: procedures>>=
   module subroutine sf_rescale_collinear_set (func, xi_tilde)
     class(sf_rescale_collinear_t), intent(inout) :: func
     real(default), intent(in) :: xi_tilde
     func%xi_tilde = xi_tilde
   end subroutine sf_rescale_collinear_set
 
 @ %def sf_rescale_collinear_set
 @
 <<SF base: public>>=
   public :: sf_rescale_real_t
 <<SF base: types>>=
   type, extends (sf_rescale_t) :: sf_rescale_real_t
      real(default) :: xi, y
   contains
   <<SF base: rescale real: TBP>>
   end type sf_rescale_real_t
 
 @ %def sf_rescale_real_t
 @ In case of IS Splittings, the beam $x$ changes from Born to real and thus needs to be rescaled according to
 \begin{equation}
   x_\oplus = \frac{\overline{x}_\oplus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1-y)}{2-\xi(1+y)}}
   , \qquad
   x_\ominus = \frac{\overline{x}_\ominus}{\sqrt{1-\xi}} \sqrt{\frac{2-\xi(1+y)}{2-\xi(1-y)}}
 \end{equation}
 Refs:
 \begin{itemize}
   \item[\textbullet] [0709.2092] Eq. (5.7).
   \item[\textbullet] [0907.4076] Eq. (2.21).
   \item Christian Weiss' PhD Thesis (DESY-THESIS-2017-025), Eq. (A.2.3).
 \end{itemize}
 <<SF base: rescale real: TBP>>=
   procedure :: apply => sf_rescale_real_apply
 <<SF base: sub interfaces>>=
     module subroutine sf_rescale_real_apply (func, x)
       class(sf_rescale_real_t), intent(in) :: func
       real(default), intent(inout) :: x
     end subroutine sf_rescale_real_apply
 <<SF base: procedures>>=
   module subroutine sf_rescale_real_apply (func, x)
     class(sf_rescale_real_t), intent(in) :: func
     real(default), intent(inout) :: x
     real(default) :: onepy, onemy
     if (debug2_active (D_BEAMS)) then
        print *, 'Rescaling function - Real: '
        print *, 'Input, unscaled: ', x
        print *, 'Beam index: ', func%i_beam
        print *, 'xi: ', func%xi, 'y: ', func%y
     end if
     x = x / sqrt (one - func%xi)
     onepy = one + func%y; onemy = one - func%y
     if (func%i_beam == 1) then
        x = x * sqrt ((two - func%xi * onemy) / (two - func%xi * onepy))
     else if (func%i_beam == 2) then
        x = x * sqrt ((two - func%xi * onepy) / (two - func%xi * onemy))
     else
        call msg_fatal ("sf_rescale_real_apply - invalid beam index")
     end if
     if (debug2_active (D_BEAMS))  print *, 'rescaled x: ', x
   end subroutine sf_rescale_real_apply
 
 @ %def sf_rescale_real_apply
 @
 <<SF base: rescale real: TBP>>=
   procedure :: set => sf_rescale_real_set
 <<SF base: sub interfaces>>=
     module subroutine sf_rescale_real_set (func, xi, y)
       class(sf_rescale_real_t), intent(inout) :: func
       real(default), intent(in) :: xi, y
     end subroutine sf_rescale_real_set
 <<SF base: procedures>>=
   module subroutine sf_rescale_real_set (func, xi, y)
     class(sf_rescale_real_t), intent(inout) :: func
     real(default), intent(in) :: xi, y
     func%xi = xi; func%y = y
   end subroutine sf_rescale_real_set
 
 @ %def sf_rescale_real_set
 <<SF base: public>>=
   public :: sf_rescale_dglap_t
 <<SF base: types>>=
   type, extends(sf_rescale_t) :: sf_rescale_dglap_t
      real(default), dimension(:), allocatable :: z
    contains
    <<SF base: rescale dglap: TBP>>
   end type sf_rescale_dglap_t
 
 @ %def sf_rescale_dglap_t
 @
 <<SF base: rescale dglap: TBP>>=
   procedure :: apply => sf_rescale_dglap_apply
 <<SF base: sub interfaces>>=
     module subroutine sf_rescale_dglap_apply (func, x)
       class(sf_rescale_dglap_t), intent(in) :: func
       real(default), intent(inout) :: x
     end subroutine sf_rescale_dglap_apply
 <<SF base: procedures>>=
   module subroutine sf_rescale_dglap_apply (func, x)
     class(sf_rescale_dglap_t), intent(in) :: func
     real(default), intent(inout) :: x
     if (debug2_active (D_BEAMS))  then
        print *, "Rescaling function - DGLAP:"
        print *, "Input: ", x
        print *, "Beam index: ", func%i_beam
        print *, "z: ", func%z
     end if
     x = x / func%z(func%i_beam)
     if (debug2_active (D_BEAMS)) print *, "scaled x: ", x
   end subroutine sf_rescale_dglap_apply
 
 @ %def sf_rescale_dglap_apply
 @
 <<SF base: rescale dglap: TBP>>=
   procedure :: set => sf_rescale_dglap_set
 <<SF base: sub interfaces>>=
     module subroutine sf_rescale_dglap_set (func, z)
       class(sf_rescale_dglap_t), intent(inout) :: func
       real(default), dimension(:), intent(in) :: z
     end subroutine sf_rescale_dglap_set
 <<SF base: procedures>>=
   module subroutine sf_rescale_dglap_set (func, z)
     class(sf_rescale_dglap_t), intent(inout) :: func
     real(default), dimension(:), intent(in) :: z
     func%z = z
   end subroutine sf_rescale_dglap_set
 
 @  %def sf_rescale_dglap_set
 @
 \subsection{Abstract structure-function data type}
 This type should hold all configuration data for a specific type of
 structure function.  The base object is empty; the implementations
 will fill it.
 <<SF base: public>>=
   public :: sf_data_t
 <<SF base: types>>=
   type, abstract :: sf_data_t
    contains
    <<SF base: sf data: TBP>>
   end type sf_data_t
 
 @ %def sf_data_t
 @ Output.
 <<SF base: sf data: TBP>>=
   procedure (sf_data_write), deferred :: write
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_data_write (data, unit, verbose)
        import
        class(sf_data_t), intent(in) :: data
        integer, intent(in), optional :: unit
        logical, intent(in), optional :: verbose
      end subroutine sf_data_write
   end interface
 
 @ %def sf_data_write
 @ Return true if this structure function is in generator mode.  In
 that case, all parameters are free, otherwise bound.  (We do not
 support mixed cases.)  Default is: no generator.
 <<SF base: sf data: TBP>>=
   procedure :: is_generator => sf_data_is_generator
 <<SF base: sub interfaces>>=
     module function sf_data_is_generator (data) result (flag)
       class(sf_data_t), intent(in) :: data
       logical :: flag
     end function sf_data_is_generator
 <<SF base: procedures>>=
   module function sf_data_is_generator (data) result (flag)
     class(sf_data_t), intent(in) :: data
     logical :: flag
     flag = .false.
   end function sf_data_is_generator
 
 @ %def sf_data_is_generator
 @ Return the number of input parameters that determine the
 structure function.
 <<SF base: sf data: TBP>>=
   procedure (sf_data_get_int), deferred :: get_n_par
 <<SF base: interfaces>>=
   abstract interface
      function sf_data_get_int (data) result (n)
        import
        class(sf_data_t), intent(in) :: data
        integer :: n
      end function sf_data_get_int
   end interface
 
 @ %def sf_data_get_int
 @ Return the outgoing particle PDG codes for the current setup.  The codes can
 be an array of particles, for each beam.
 <<SF base: sf data: TBP>>=
   procedure (sf_data_get_pdg_out), deferred :: get_pdg_out
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_data_get_pdg_out (data, pdg_out)
        import
        class(sf_data_t), intent(in) :: data
        type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
      end subroutine sf_data_get_pdg_out
   end interface
 
 @ %def sf_data_get_pdg_out
 @ Allocate a matching structure function interaction object and
 properly initialize it.
 
 <<SF base: sf data: TBP>>=
   procedure (sf_data_allocate_sf_int), deferred :: allocate_sf_int
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_data_allocate_sf_int (data, sf_int)
        import
        class(sf_data_t), intent(in) :: data
        class(sf_int_t), intent(inout), allocatable :: sf_int
      end subroutine sf_data_allocate_sf_int
   end interface
 
 @ %def sf_data_allocate_sf_int
 @ Return the PDF set index, if applicable.  We implement a default
 method which returns zero.  The PDF (builtin and LHA) implementations
 will override this.
 <<SF base: sf data: TBP>>=
   procedure :: get_pdf_set => sf_data_get_pdf_set
 <<SF base: sub interfaces>>=
     elemental module function sf_data_get_pdf_set (data) result (pdf_set)
       class(sf_data_t), intent(in) :: data
       integer :: pdf_set
     end function sf_data_get_pdf_set
 <<SF base: procedures>>=
   elemental module function sf_data_get_pdf_set (data) result (pdf_set)
     class(sf_data_t), intent(in) :: data
     integer :: pdf_set
     pdf_set = 0
   end function sf_data_get_pdf_set
 
 @ %def sf_data_get_pdf_set
 @ Return the spectrum file, if applicable. We implement a default
 method which returns zero. CIRCE1, CIRCE2 and the beam spectrum will
 override this.
 <<SF base: sf data: TBP>>=
   procedure :: get_beam_file => sf_data_get_beam_file
 <<SF base: sub interfaces>>=
     module function sf_data_get_beam_file (data) result (file)
       class(sf_data_t), intent(in) :: data
       type(string_t) :: file
     end function sf_data_get_beam_file
 <<SF base: procedures>>=
   module function sf_data_get_beam_file (data) result (file)
     class(sf_data_t), intent(in) :: data
     type(string_t) :: file
     file = ""
   end function sf_data_get_beam_file
 
 @ %def sf_data_get_beam_file
 @
 \subsection{Structure-function chain configuration}
 This is the data type that the [[process]] module uses for setting
 up its structure-function chain.  For each structure function described
 by the beam data, there is an entry.  The [[i]] array indicates the
 beam(s) to which this structure function applies, and the [[data]]
 object contains the actual configuration data.
 <<SF base: public>>=
   public :: sf_config_t
 <<SF base: types>>=
   type :: sf_config_t
      integer, dimension(:), allocatable :: i
      class(sf_data_t), allocatable :: data
    contains
    <<SF base: sf config: TBP>>
   end type sf_config_t
 
 @ %def sf_config_t
 @ Output:
 <<SF base: sf config: TBP>>=
   procedure :: write => sf_config_write
 <<SF base: sub interfaces>>=
     module subroutine sf_config_write (object, unit, verbose)
       class(sf_config_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine sf_config_write
 <<SF base: procedures>>=
   module subroutine sf_config_write (object, unit, verbose)
     class(sf_config_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     if (allocated (object%i)) then
        write (u, "(1x,A,2(1x,I0))")  "Structure-function configuration: &
             &beam(s)", object%i
        if (allocated (object%data)) &
             call object%data%write (u, verbose = verbose)
     else
        write (u, "(1x,A)")  "Structure-function configuration: [undefined]"
     end if
   end subroutine sf_config_write
 
 @ %def sf_config_write
 @ Initialize.
 <<SF base: sf config: TBP>>=
   procedure :: init => sf_config_init
 <<SF base: sub interfaces>>=
     module subroutine sf_config_init (sf_config, i_beam, sf_data)
       class(sf_config_t), intent(out) :: sf_config
       integer, dimension(:), intent(in) :: i_beam
       class(sf_data_t), intent(in) :: sf_data
     end subroutine sf_config_init
 <<SF base: procedures>>=
   module subroutine sf_config_init (sf_config, i_beam, sf_data)
     class(sf_config_t), intent(out) :: sf_config
     integer, dimension(:), intent(in) :: i_beam
     class(sf_data_t), intent(in) :: sf_data
     allocate (sf_config%i (size (i_beam)), source = i_beam)
     allocate (sf_config%data, source = sf_data)
   end subroutine sf_config_init
 
 @ %def sf_config_init
 @ Return the PDF set, if any.
 <<SF base: sf config: TBP>>=
   procedure :: get_pdf_set => sf_config_get_pdf_set
 <<SF base: sub interfaces>>=
     elemental module function sf_config_get_pdf_set (sf_config) result (pdf_set)
       class(sf_config_t), intent(in) :: sf_config
       integer :: pdf_set
     end function sf_config_get_pdf_set
 <<SF base: procedures>>=
   elemental module function sf_config_get_pdf_set (sf_config) result (pdf_set)
     class(sf_config_t), intent(in) :: sf_config
     integer :: pdf_set
     pdf_set = sf_config%data%get_pdf_set ()
   end function sf_config_get_pdf_set
 
 @ %def sf_config_get_pdf_set
 @ Return the beam spectrum file, if any.
 <<SF base: sf config: TBP>>=
   procedure :: get_beam_file => sf_config_get_beam_file
 <<SF base: sub interfaces>>=
     module function sf_config_get_beam_file (sf_config) result (file)
       class(sf_config_t), intent(in) :: sf_config
       type(string_t) :: file
     end function sf_config_get_beam_file
 <<SF base: procedures>>=
   module function sf_config_get_beam_file (sf_config) result (file)
     class(sf_config_t), intent(in) :: sf_config
     type(string_t) :: file
     file = sf_config%data%get_beam_file ()
   end function sf_config_get_beam_file
 
 @ %def sf_config_get_beam_file
 @
 \subsection{Structure-function instance}
 The [[sf_int_t]] data type contains an [[interaction_t]] object (it is
 an extension of this type) and a pointer to the [[sf_data_t]]
 configuration data.  This interaction, or copies of it, is used to
 implement structure-function kinematics and dynamics in the context of
 process evaluation.
 
 The status code [[status]] tells whether the interaction is undefined,
 has defined kinematics (but matrix elements invalid), or is completely
 defined.  There is also a status code for failure.  The implementation
 is responsible for updating the status.
 
 The entries [[mi2]], [[mr2]], and [[mo2]] hold the squared
 invariant masses of the incoming, radiated, and outgoing particle,
 respectively.  They are supposed to be set upon initialization, but
 could also be varied event by event.
 
 If the radiated or outgoing mass is nonzero, we may need to apply an
 on-shell projection.  The projection mode is stored as
 [[on_shell_mode]].
 
 The array [[beam_index]] is the list of beams on which this structure
 function applies ($1$, $2$, or both).  The arrays [[incoming]],
 [[radiated]], and [[outgoing]] contain the indices of the respective
 particle sets within the interaction, for convenient lookup.  The
 array [[par_index]] indicates the MC input parameters that this entry
 will use up in the structure-function chain.  The first parameter (or
 the first two, for a spectrum) in this array determines the momentum
 fraction and is thus subject to global mappings.
 
 In the abstract base type, we do not implement the data pointer.  This
 allows us to restrict its type in the implementations.
 <<SF base: public>>=
   public :: sf_int_t
 <<SF base: types>>=
   type, abstract, extends (interaction_t) :: sf_int_t
      integer :: status = SF_UNDEFINED
      real(default), dimension(:), allocatable :: mi2
      real(default), dimension(:), allocatable :: mr2
      real(default), dimension(:), allocatable :: mo2
      integer :: on_shell_mode = KEEP_ENERGY
      logical :: qmin_defined = .false.
      logical :: qmax_defined = .false.
      real(default), dimension(:), allocatable :: qmin
      real(default), dimension(:), allocatable :: qmax
      integer, dimension(:), allocatable :: beam_index
      integer, dimension(:), allocatable :: incoming
      integer, dimension(:), allocatable :: radiated
      integer, dimension(:), allocatable :: outgoing
      integer, dimension(:), allocatable :: par_index
      integer, dimension(:), allocatable :: par_primary
    contains
    <<SF base: sf int: TBP>>
   end type sf_int_t
 
 @ %def sf_int_t
 @ Status codes.  The codes that refer to links, masks, and
 connections, apply to structure-function chains only.
 
 The status codes are public.
 <<SF base: parameters>>=
   integer, parameter, public :: SF_UNDEFINED = 0
   integer, parameter, public :: SF_INITIAL = 1
   integer, parameter, public :: SF_DONE_LINKS = 2
   integer, parameter, public :: SF_FAILED_MASK = 3
   integer, parameter, public :: SF_DONE_MASK = 4
   integer, parameter, public :: SF_FAILED_CONNECTIONS = 5
   integer, parameter, public :: SF_DONE_CONNECTIONS = 6
   integer, parameter, public :: SF_SEED_KINEMATICS = 10
   integer, parameter, public :: SF_FAILED_KINEMATICS = 11
   integer, parameter, public :: SF_DONE_KINEMATICS = 12
   integer, parameter, public :: SF_FAILED_EVALUATION = 13
   integer, parameter, public :: SF_EVALUATED = 20
 
 @ %def SF_UNDEFINED SF_INITIAL
 @ %def SF_DONE_LINKS SF_DONE_MASK SF_DONE_CONNECTIONS
 @ %def SF_DONE_KINEMATICS SF_EVALUATED
 @ %def SF_FAILED_MASK SF_FAILED_CONNECTIONS
 @ %def SF_FAILED_KINEMATICS SF_FAILED_EVALUATION
 @ Write a string version of the status code:
 <<SF base: procedures>>=
   subroutine write_sf_status (status, u)
     integer, intent(in) :: status
     integer, intent(in) :: u
     select case (status)
     case (SF_UNDEFINED)
        write (u, "(1x,'[',A,']')")  "undefined"
     case (SF_INITIAL)
        write (u, "(1x,'[',A,']')")  "initialized"
     case (SF_DONE_LINKS)
        write (u, "(1x,'[',A,']')")  "links set"
     case (SF_FAILED_MASK)
        write (u, "(1x,'[',A,']')")  "mask mismatch"
     case (SF_DONE_MASK)
        write (u, "(1x,'[',A,']')")  "mask set"
     case (SF_FAILED_CONNECTIONS)
        write (u, "(1x,'[',A,']')")  "connections failed"
     case (SF_DONE_CONNECTIONS)
        write (u, "(1x,'[',A,']')")  "connections set"
     case (SF_SEED_KINEMATICS)
        write (u, "(1x,'[',A,']')")  "incoming momenta set"
     case (SF_FAILED_KINEMATICS)
        write (u, "(1x,'[',A,']')")  "kinematics failed"
     case (SF_DONE_KINEMATICS)
        write (u, "(1x,'[',A,']')")  "kinematics set"
     case (SF_FAILED_EVALUATION)
        write (u, "(1x,'[',A,']')")  "evaluation failed"
     case (SF_EVALUATED)
        write (u, "(1x,'[',A,']')")  "evaluated"
     end select
   end subroutine write_sf_status
 
 @ %def write_sf_status
 @ This is the basic output routine.  Display status and interaction.
 <<SF base: sf int: TBP>>=
   procedure :: base_write => sf_int_base_write
 <<SF base: sub interfaces>>=
     module subroutine sf_int_base_write (object, unit, testflag)
       class(sf_int_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine sf_int_base_write
 <<SF base: procedures>>=
   module subroutine sf_int_base_write (object, unit, testflag)
     class(sf_int_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "SF instance:"
     call write_sf_status (object%status, u)
     if (allocated (object%beam_index)) &
          write (u, "(3x,A,2(1x,I0))")  "beam      =", object%beam_index
     if (allocated (object%incoming)) &
          write (u, "(3x,A,2(1x,I0))")  "incoming  =", object%incoming
     if (allocated (object%radiated)) &
          write (u, "(3x,A,2(1x,I0))")  "radiated  =", object%radiated
     if (allocated (object%outgoing)) &
          write (u, "(3x,A,2(1x,I0))")  "outgoing  =", object%outgoing
     if (allocated (object%par_index)) &
          write (u, "(3x,A,2(1x,I0))")  "parameter =", object%par_index
     if (object%qmin_defined) &
          write (u, "(3x,A,1x," // FMT_19 // ")")  "q_min     =", object%qmin
     if (object%qmax_defined) &
          write (u, "(3x,A,1x," // FMT_19 // ")")  "q_max     =", object%qmax
     call object%interaction_t%basic_write (u, testflag = testflag)
   end subroutine sf_int_base_write
 
 @ %def sf_int_base_write
 @ The type string identifies the structure function class, and possibly more
 details about the structure function.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_type_string), deferred :: type_string
 <<SF base: interfaces>>=
   abstract interface
      function sf_int_type_string (object) result (string)
        import
        class(sf_int_t), intent(in) :: object
        type(string_t) :: string
      end function sf_int_type_string
   end interface
 
 @ %def sf_int_type_string
 @ Output of the concrete object.  We should not forget to call the
 output routine for the base type.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_write), deferred :: write
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_int_write (object, unit, testflag)
        import
        class(sf_int_t), intent(in) :: object
        integer, intent(in), optional :: unit
        logical, intent(in), optional :: testflag
      end subroutine sf_int_write
   end interface
 
 @ %def sf_int_write
 @ Basic initialization: set the invariant masses for the particles and
 initialize the interaction.  The caller should then add states to the
 interaction and freeze it.
 
 The dimension of the mask should be equal to the sum of the dimensions
 of the mass-squared arrays, which determine incoming, radiated, and
 outgoing particles, respectively.
 
 Optionally, we can define minimum and maximum values for the momentum
 transfer to the outgoing particle(s).  If all masses are zero, this is
 actually required for non-collinear splitting.
 <<SF base: sf int: TBP>>=
   procedure :: base_init => sf_int_base_init
 <<SF base: sub interfaces>>=
     module subroutine sf_int_base_init &
          (sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock)
       class(sf_int_t), intent(out) :: sf_int
       type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask
       real(default), dimension(:), intent(in) :: mi2, mr2, mo2
       real(default), dimension(:), intent(in), optional :: qmin, qmax
       integer, dimension(:), intent(in), optional :: hel_lock
     end subroutine sf_int_base_init
 <<SF base: procedures>>=
   module subroutine sf_int_base_init &
        (sf_int, mask, mi2, mr2, mo2, qmin, qmax, hel_lock)
     class(sf_int_t), intent(out) :: sf_int
     type (quantum_numbers_mask_t), dimension(:), intent(in) :: mask
     real(default), dimension(:), intent(in) :: mi2, mr2, mo2
     real(default), dimension(:), intent(in), optional :: qmin, qmax
     integer, dimension(:), intent(in), optional :: hel_lock
     allocate (sf_int%mi2 (size (mi2)))
     sf_int%mi2 = mi2
     allocate (sf_int%mr2 (size (mr2)))
     sf_int%mr2 = mr2
     allocate (sf_int%mo2 (size (mo2)))
     sf_int%mo2 = mo2
     if (present (qmin)) then
        sf_int%qmin_defined = .true.
        allocate (sf_int%qmin (size (qmin)))
        sf_int%qmin = qmin
     end if
     if (present (qmax)) then
        sf_int%qmax_defined = .true.
        allocate (sf_int%qmax (size (qmax)))
        sf_int%qmax = qmax
     end if
     call sf_int%interaction_t%basic_init &
          (size (mi2), 0, size (mr2) + size (mo2), &
          mask = mask, hel_lock = hel_lock, set_relations = .true.)
   end subroutine sf_int_base_init
 
 @ %def sf_int_base_init
 @ Set the indices of the incoming, radiated, and outgoing particles,
 respectively.
 <<SF base: sf int: TBP>>=
   procedure :: set_incoming => sf_int_set_incoming
   procedure :: set_radiated => sf_int_set_radiated
   procedure :: set_outgoing => sf_int_set_outgoing
 <<SF base: sub interfaces>>=
     module subroutine sf_int_set_incoming (sf_int, incoming)
       class(sf_int_t), intent(inout) :: sf_int
       integer, dimension(:), intent(in) :: incoming
     end subroutine sf_int_set_incoming
     module subroutine sf_int_set_radiated (sf_int, radiated)
       class(sf_int_t), intent(inout) :: sf_int
       integer, dimension(:), intent(in) :: radiated
     end subroutine sf_int_set_radiated
     module subroutine sf_int_set_outgoing (sf_int, outgoing)
       class(sf_int_t), intent(inout) :: sf_int
       integer, dimension(:), intent(in) :: outgoing
     end subroutine sf_int_set_outgoing
 <<SF base: procedures>>=
   module subroutine sf_int_set_incoming (sf_int, incoming)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: incoming
     allocate (sf_int%incoming (size (incoming)))
     sf_int%incoming = incoming
   end subroutine sf_int_set_incoming
 
   module subroutine sf_int_set_radiated (sf_int, radiated)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: radiated
     allocate (sf_int%radiated (size (radiated)))
     sf_int%radiated = radiated
   end subroutine sf_int_set_radiated
 
   module subroutine sf_int_set_outgoing (sf_int, outgoing)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: outgoing
     allocate (sf_int%outgoing (size (outgoing)))
     sf_int%outgoing = outgoing
   end subroutine sf_int_set_outgoing
 
 @ %def sf_int_set_incoming
 @ %def sf_int_set_radiated
 @ %def sf_int_set_outgoing
 @ Initialization.  This proceeds via an abstract data object, which
 for the actual implementation should have the matching concrete type.
 Since all implementations have the same signature, we can prepare a
 deferred procedure.  The data object will become the target of a
 corresponding pointer within the [[sf_int_t]] implementation.
 
 This should call the previous procedure.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_init), deferred :: init
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_int_init (sf_int, data)
        import
        class(sf_int_t), intent(out) :: sf_int
        class(sf_data_t), intent(in), target :: data
      end subroutine sf_int_init
   end interface
 
 @ %def sf_int_init
 @ Complete initialization.  This routine contains initializations that can
 only be performed after the interaction object got its final shape, i.e.,
 redundant helicities have been eliminated by matching with beams and process.
 
 The default implementation does nothing.
 
 The [[target]] attribute is formally required since some overriding
 implementations use a temporary pointer (iterator) to the state-matrix
 component.  It doesn't appear to make a real difference, though.
 <<SF base: sf int: TBP>>=
   procedure :: setup_constants => sf_int_setup_constants
 <<SF base: sub interfaces>>=
     module subroutine sf_int_setup_constants (sf_int)
       class(sf_int_t), intent(inout), target :: sf_int
     end subroutine sf_int_setup_constants
 <<SF base: procedures>>=
   module subroutine sf_int_setup_constants (sf_int)
     class(sf_int_t), intent(inout), target :: sf_int
   end subroutine sf_int_setup_constants
 
 @ %def sf_int_setup_constants
 @ Set beam indices, i.e., the beam(s) on which
 this structure function applies.
 <<SF base: sf int: TBP>>=
   procedure :: set_beam_index => sf_int_set_beam_index
 <<SF base: sub interfaces>>=
     module subroutine sf_int_set_beam_index (sf_int, beam_index)
       class(sf_int_t), intent(inout) :: sf_int
       integer, dimension(:), intent(in) :: beam_index
     end subroutine sf_int_set_beam_index
 <<SF base: procedures>>=
   module subroutine sf_int_set_beam_index (sf_int, beam_index)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: beam_index
     allocate (sf_int%beam_index (size (beam_index)))
     sf_int%beam_index = beam_index
   end subroutine sf_int_set_beam_index
 
 @ %def sf_int_set_beam_index
 @ Set parameter indices, indicating which MC input parameters are to
 be used for evaluating this structure function.
 <<SF base: sf int: TBP>>=
   procedure :: set_par_index => sf_int_set_par_index
 <<SF base: sub interfaces>>=
     module subroutine sf_int_set_par_index (sf_int, par_index)
       class(sf_int_t), intent(inout) :: sf_int
       integer, dimension(:), intent(in) :: par_index
     end subroutine sf_int_set_par_index
 <<SF base: procedures>>=
   module subroutine sf_int_set_par_index (sf_int, par_index)
     class(sf_int_t), intent(inout) :: sf_int
     integer, dimension(:), intent(in) :: par_index
     allocate (sf_int%par_index (size (par_index)))
     sf_int%par_index = par_index
   end subroutine sf_int_set_par_index
 
 @ %def sf_int_set_par_index
 @ Initialize the structure-function kinematics, setting incoming
 momenta.  We assume that array shapes match.
 
 Three versions.  The first version relies on the momenta being linked
 to another interaction.  The second version sets the momenta
 explicitly.  In the third version, we first compute momenta for the
 specified energies and store those.
 <<SF base: sf int: TBP>>=
   generic :: seed_kinematics => sf_int_receive_momenta
   generic :: seed_kinematics => sf_int_seed_momenta
   generic :: seed_kinematics => sf_int_seed_energies
   procedure :: sf_int_receive_momenta
   procedure :: sf_int_seed_momenta
   procedure :: sf_int_seed_energies
 <<SF base: sub interfaces>>=
     module subroutine sf_int_receive_momenta (sf_int)
       class(sf_int_t), intent(inout) :: sf_int
     end subroutine sf_int_receive_momenta
     module subroutine sf_int_seed_momenta (sf_int, k)
       class(sf_int_t), intent(inout) :: sf_int
       type(vector4_t), dimension(:), intent(in) :: k
     end subroutine sf_int_seed_momenta
     module subroutine sf_int_seed_energies (sf_int, E)
       class(sf_int_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: E
       type(vector4_t), dimension(:), allocatable :: k
     end subroutine sf_int_seed_energies
 <<SF base: procedures>>=
   module subroutine sf_int_receive_momenta (sf_int)
     class(sf_int_t), intent(inout) :: sf_int
     if (sf_int%status >= SF_INITIAL) then
        call sf_int%receive_momenta ()
        sf_int%status = SF_SEED_KINEMATICS
     end if
   end subroutine sf_int_receive_momenta
 
   module subroutine sf_int_seed_momenta (sf_int, k)
     class(sf_int_t), intent(inout) :: sf_int
     type(vector4_t), dimension(:), intent(in) :: k
     if (sf_int%status >= SF_INITIAL) then
        call sf_int%set_momenta (k, outgoing=.false.)
        sf_int%status = SF_SEED_KINEMATICS
     end if
   end subroutine sf_int_seed_momenta
 
   module subroutine sf_int_seed_energies (sf_int, E)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: E
     type(vector4_t), dimension(:), allocatable :: k
     integer :: j
     if (sf_int%status >= SF_INITIAL) then
        allocate (k (size (E)))
        if (all (E**2 >= sf_int%mi2)) then
           do j = 1, size (E)
              k(j) = vector4_moving (E(j), &
                   (3-2*j) * sqrt (E(j)**2 - sf_int%mi2(j)), 3)
           end do
           call sf_int%seed_kinematics (k)
        end if
     end if
   end subroutine sf_int_seed_energies
 
 @ %def sf_int_seed_momenta
 @ %def sf_int_seed_energies
 @ Tell if in generator mode.  By default, this is false.  To be
 overridden where appropriate; we may refer to the [[is_generator]]
 method of the [[data]] component in the concrete type.
 <<SF base: sf int: TBP>>=
   procedure :: is_generator => sf_int_is_generator
 <<SF base: sub interfaces>>=
     module function sf_int_is_generator (sf_int) result (flag)
       class(sf_int_t), intent(in) :: sf_int
       logical :: flag
     end function sf_int_is_generator
 <<SF base: procedures>>=
   module function sf_int_is_generator (sf_int) result (flag)
     class(sf_int_t), intent(in) :: sf_int
     logical :: flag
     flag = .false.
   end function sf_int_is_generator
 
 @ %def sf_int_is_generator
 @ Generate free parameters [[r]].  Parameters are free if they do not
 correspond to integration parameters (i.e., are bound), but are
 generated by the structure function object itself.  By default, all
 parameters are bound, and the output values of this procedure will be
 discarded.  With free parameters, we have to override this procedure.
 
 The value [[x_free]] is the renormalization factor of the total energy
 that corresponds to the free parameters.  If there are no free
 parameters, the procedure will not change its value, which starts as
 unity.  Otherwise, the fraction is typically decreased, but may also
 be increased in some cases.
 <<SF base: sf int: TBP>>=
   procedure :: generate_free => sf_int_generate_free
 <<SF base: sub interfaces>>=
     module subroutine sf_int_generate_free (sf_int, r, rb,  x_free)
       class(sf_int_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(inout) :: x_free
     end subroutine sf_int_generate_free
 <<SF base: procedures>>=
   module subroutine sf_int_generate_free (sf_int, r, rb,  x_free)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     r = 0
     rb= 1
   end subroutine sf_int_generate_free
 
 @ %def sf_int_generate_free
 @ Complete the structure-function kinematics, derived from an input
 parameter (array) $r$ between 0 and 1.  The interaction momenta are
 calculated, and we return $x$ (the momentum fraction), and $f$ (the
 Jacobian factor for the map $r\to x$), if [[map]] is set.
 
 If the [[map]] flag is unset, $r$ and $x$ values will coincide, and $f$ will
 become unity.  If it is set, the structure-function implementation chooses a
 convenient mapping from $r$ to $x$ with Jacobian $f$.
 
 In the [[inverse_kinematics]] variant, we exchange the intent of [[x]]
 and [[r]].  The momenta are calculated only if the optional flag
 [[set_momenta]] is present and set.  Internal parameters of [[sf_int]]
 are calculated only if the optional flag [[set_x]] is present and set.
 
 Update 2018-08-22: Throughout this algorithm, we now carry
 [[xb]]=$1-x$ together with [[x]] values, as we did for [[r]] before.
 This allows us to handle unstable endpoint numerics wherever
 necessary.  The only place where the changes actually did matter was
 for inverse kinematics in the ISR setup, with a very soft photon, but
 it might be most sensible to apply the extension with [[xb]] everywhere.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_complete_kinematics), deferred :: complete_kinematics
   procedure (sf_int_inverse_kinematics), deferred :: inverse_kinematics
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_int_complete_kinematics (sf_int, x, xb, f, r, rb, map)
        import
        class(sf_int_t), intent(inout) :: sf_int
        real(default), dimension(:), intent(out) :: x
        real(default), dimension(:), intent(out) :: xb
        real(default), intent(out) :: f
        real(default), dimension(:), intent(in) :: r
        real(default), dimension(:), intent(in) :: rb
        logical, intent(in) :: map
      end subroutine sf_int_complete_kinematics
   end interface
 
   abstract interface
      subroutine sf_int_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
        import
        class(sf_int_t), intent(inout) :: sf_int
        real(default), dimension(:), intent(in) :: x
        real(default), dimension(:), intent(in) :: xb
        real(default), intent(out) :: f
        real(default), dimension(:), intent(out) :: r
        real(default), dimension(:), intent(out) :: rb
        logical, intent(in) :: map
        logical, intent(in), optional :: set_momenta
      end subroutine sf_int_inverse_kinematics
   end interface
 
 @ %def sf_int_complete_kinematics
 @ %def sf_int_inverse_kinematics
 @ Single splitting: compute momenta, given $x$ input parameters.  We
 assume that the incoming momentum is set.  The status code is set to
 [[SF_FAILED_KINEMATICS]] if
 the $x$ array does not correspond to a valid momentum configuration.
 Otherwise, it is updated to [[SF_DONE_KINEMATICS]].
 
 We force the outgoing particle on-shell.  The on-shell projection is
 determined by the [[on_shell_mode]].  The radiated particle should already be
 on shell.
 <<SF base: sf int: TBP>>=
   procedure :: split_momentum => sf_int_split_momentum
 <<SF base: sub interfaces>>=
     module subroutine sf_int_split_momentum (sf_int, x, xb)
       class(sf_int_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
     end subroutine sf_int_split_momentum
 <<SF base: procedures>>=
   module subroutine sf_int_split_momentum (sf_int, x, xb)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     type(splitting_data_t) :: sd
     real(default) :: E1, E2
     logical :: fail
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        k = sf_int%get_momentum (1)
        call sd%init (k, &
             sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), &
             collinear = size (x) == 1)
        call sd%set_t_bounds (x(1), xb(1))
        select case (size (x))
        case (1)
        case (3)
           if (sf_int%qmax_defined) then
              if (sf_int%qmin_defined) then
                 call sd%sample_t (x(2), &
                      t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2)
              else
                 call sd%sample_t (x(2), &
                      t0 = - sf_int%qmax(1) ** 2)
              end if
           else
              if (sf_int%qmin_defined) then
                 call sd%sample_t (x(2), t1 = - sf_int%qmin(1) ** 2)
              else
                 call sd%sample_t (x(2))
              end if
           end if
           call sd%sample_phi (x(3))
        case default
           call msg_bug ("Structure function: impossible number of parameters")
        end select
        q = sd%split_momentum (k)
        call on_shell (q, [sf_int%mr2, sf_int%mo2], &
             sf_int%on_shell_mode)
        call sf_int%set_momenta (q, outgoing=.true.)
        E1 = energy (q(1))
        E2 = energy (q(2))
        fail = E1 < 0 .or. E2 < 0 &
             .or. E1 ** 2 < sf_int%mr2(1) &
             .or. E2 ** 2 < sf_int%mo2(1)
        if (fail) then
           sf_int%status = SF_FAILED_KINEMATICS
        else
           sf_int%status = SF_DONE_KINEMATICS
        end if
     end if
   end subroutine sf_int_split_momentum
 
 @ %def sf_test_split_momentum
 @ Pair splitting: two incoming momenta, two radiated, two outgoing.
 This is simple because we insist on all momenta being collinear.
 <<SF base: sf int: TBP>>=
   procedure :: split_momenta => sf_int_split_momenta
 <<SF base: sub interfaces>>=
     module subroutine sf_int_split_momenta (sf_int, x, xb)
       class(sf_int_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
     end subroutine sf_int_split_momenta
 <<SF base: procedures>>=
   module subroutine sf_int_split_momenta (sf_int, x, xb)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(4) :: q
     real(default), dimension(4) :: E
     logical :: fail
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        select case (size (x))
        case (2)
        case default
           call msg_bug ("Pair structure function: recoil requested &
                &but not implemented yet")
        end select
        k(1) = sf_int%get_momentum (1)
        k(2) = sf_int%get_momentum (2)
        q(1:2) = xb * k
        q(3:4) = x * k
        select case (size (sf_int%mr2))
        case (2)
           call on_shell (q, &
                [sf_int%mr2(1), sf_int%mr2(2), &
                sf_int%mo2(1), sf_int%mo2(2)], &
                sf_int%on_shell_mode)
           call sf_int%set_momenta (q, outgoing=.true.)
           E = energy (q)
           fail = any (E < 0) &
                .or. any (E(1:2) ** 2 < sf_int%mr2) &
                .or. any (E(3:4) ** 2 < sf_int%mo2)
        case default;  call msg_bug ("split momenta: incorrect use")
        end select
        if (fail) then
           sf_int%status = SF_FAILED_KINEMATICS
        else
           sf_int%status = SF_DONE_KINEMATICS
        end if
     end if
   end subroutine sf_int_split_momenta
 
 @ %def sf_int_split_momenta
 @ Pair spectrum: the reduced version of the previous splitting,
 without radiated momenta.
 <<SF base: sf int: TBP>>=
   procedure :: reduce_momenta => sf_int_reduce_momenta
 <<SF base: sub interfaces>>=
     module subroutine sf_int_reduce_momenta (sf_int, x)
       class(sf_int_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
     end subroutine sf_int_reduce_momenta
 <<SF base: procedures>>=
   module subroutine sf_int_reduce_momenta (sf_int, x)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(2) :: q
     real(default), dimension(2) :: E
     logical :: fail
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        select case (size (x))
        case (2)
        case default
           call msg_bug ("Pair spectrum: recoil requested &
                &but not implemented yet")
        end select
        k(1) = sf_int%get_momentum (1)
        k(2) = sf_int%get_momentum (2)
        q = x * k
        call on_shell (q, &
             [sf_int%mo2(1), sf_int%mo2(2)], &
             sf_int%on_shell_mode)
        call sf_int%set_momenta (q, outgoing=.true.)
        E = energy (q)
        fail = any (E < 0) &
             .or. any (E ** 2 < sf_int%mo2)
        if (fail) then
           sf_int%status = SF_FAILED_KINEMATICS
        else
           sf_int%status = SF_DONE_KINEMATICS
        end if
     end if
   end subroutine sf_int_reduce_momenta
 
 @ %def sf_int_reduce_momenta
 @ The inverse procedure: we compute the [[x]] array from the momentum
 configuration.  In an overriding TBP, we may also set internal data
 that depend on this, for convenience.
 
 NOTE: Here and above, the single-particle case is treated in detail,
 allowing for non-collinearity and non-vanishing masses and nontrivial
 momentum-transfer bounds.  For the pair case, we currently implement
 only collinear splitting and assume massless particles.  This should
 be improved.
 
 Update 2017-08-22: recover also [[xb]], using the updated [[recover]]
 method of the splitting-data object.  Th
 <<SF base: sf int: TBP>>=
   procedure :: recover_x => sf_int_recover_x
   procedure :: base_recover_x => sf_int_recover_x
 <<SF base: sub interfaces>>=
     module subroutine sf_int_recover_x (sf_int, x, xb, x_free)
       class(sf_int_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_int_recover_x
 <<SF base: procedures>>=
   module subroutine sf_int_recover_x (sf_int, x, xb, x_free)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     type(vector4_t), dimension(:), allocatable :: k
     type(vector4_t), dimension(:), allocatable :: q
     type(splitting_data_t) :: sd
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        allocate (k (sf_int%interaction_t%get_n_in ()))
        allocate (q (sf_int%interaction_t%get_n_out ()))
        k = sf_int%get_momenta (outgoing=.false.)
        q = sf_int%get_momenta (outgoing=.true.)
        select case (size (k))
        case (1)
           call sd%init (k(1), &
                sf_int%mi2(1), sf_int%mr2(1), sf_int%mo2(1), &
                collinear = size (x) == 1)
           call sd%recover (k(1), q, sf_int%on_shell_mode)
           x(1)  = sd%get_x ()
           xb(1) = sd%get_xb ()
           select case (size (x))
           case (1)
           case (3)
              if (sf_int%qmax_defined) then
                 if (sf_int%qmin_defined) then
                    call sd%inverse_t (x(2), &
                         t0 = - sf_int%qmax(1) ** 2, t1 = - sf_int%qmin(1) ** 2)
                 else
                    call sd%inverse_t (x(2), &
                         t0 = - sf_int%qmax(1) ** 2)
                 end if
              else
                 if (sf_int%qmin_defined) then
                    call sd%inverse_t (x(2), t1 = - sf_int%qmin(1) ** 2)
                 else
                    call sd%inverse_t (x(2))
                 end if
              end if
              call sd%inverse_phi (x(3))
              xb(2:3) = 1 - x(2:3)
           case default
              call msg_bug ("Structure function: impossible number &
                   &of parameters")
           end select
        case (2)
           select case (size (x))
           case (2)
           case default
              call msg_bug ("Pair structure function: recoil requested &
                   &but not implemented yet")
           end select
           select case (sf_int%on_shell_mode)
           case (KEEP_ENERGY)
              select case (size (q))
              case (4)
                 x = energy (q(3:4)) / energy (k)
                 xb= energy (q(1:2)) / energy (k)
              case (2)
                 x = energy (q) / energy (k)
                 xb= 1 - x
              end select
           case (KEEP_MOMENTUM)
              select case (size (q))
              case (4)
                 x = longitudinal_part (q(3:4)) / longitudinal_part (k)
                 xb= longitudinal_part (q(1:2)) / longitudinal_part (k)
              case (2)
                 x = longitudinal_part (q) / longitudinal_part (k)
                 xb= 1 - x
              end select
           end select
        end select
     end if
   end subroutine sf_int_recover_x
 
 @ %def sf_int_recover_x
 @ Apply the structure function, i.e., evaluate the interaction.  For
 the calculation, we may use the stored momenta, any further
 information stored inside the [[sf_int]] implementation during
 kinematics setup, and the given energy scale.  It may happen that for
 the given kinematics the value is not defined.  This should be
 indicated by the status code.
 <<SF base: sf int: TBP>>=
   procedure (sf_int_apply), deferred :: apply
 <<SF base: interfaces>>=
   abstract interface
      subroutine sf_int_apply (sf_int, scale, negative_sf, rescale, i_sub)
        import
        class(sf_int_t), intent(inout) :: sf_int
        real(default), intent(in) :: scale
        logical, intent(in), optional :: negative_sf
        class(sf_rescale_t), intent(in), optional :: rescale
        integer, intent(in), optional :: i_sub
      end subroutine sf_int_apply
   end interface
 
 @ %def sf_int_apply
 @
 \subsection{Accessing the structure function}
 Return metadata.  Once [[interaction_t]] is rewritten in OO, some of this will
 be inherited.
 
 The number of outgoing particles is equal to the number of incoming particles.
 The radiated particles are the difference.
 <<SF base: sf int: TBP>>=
   procedure :: get_n_in => sf_int_get_n_in
   procedure :: get_n_rad => sf_int_get_n_rad
   procedure :: get_n_out => sf_int_get_n_out
 <<SF base: sub interfaces>>=
     pure module function sf_int_get_n_in (object) result (n_in)
       class(sf_int_t), intent(in) :: object
       integer :: n_in
     end function sf_int_get_n_in
     pure module function sf_int_get_n_rad (object) result (n_rad)
       class(sf_int_t), intent(in) :: object
       integer :: n_rad
     end function sf_int_get_n_rad
     pure module function sf_int_get_n_out (object) result (n_out)
       class(sf_int_t), intent(in) :: object
       integer :: n_out
     end function sf_int_get_n_out
 <<SF base: procedures>>=
   pure module function sf_int_get_n_in (object) result (n_in)
     class(sf_int_t), intent(in) :: object
     integer :: n_in
     n_in = object%interaction_t%get_n_in ()
   end function sf_int_get_n_in
 
   pure module function sf_int_get_n_rad (object) result (n_rad)
     class(sf_int_t), intent(in) :: object
     integer :: n_rad
     n_rad = object%interaction_t%get_n_out () &
          - object%interaction_t%get_n_in ()
   end function sf_int_get_n_rad
 
   pure module function sf_int_get_n_out (object) result (n_out)
     class(sf_int_t), intent(in) :: object
     integer :: n_out
     n_out = object%interaction_t%get_n_in ()
   end function sf_int_get_n_out
 
 @ %def sf_int_get_n_in
 @ %def sf_int_get_n_rad
 @ %def sf_int_get_n_out
 @ Number of matrix element entries in the interaction:
 <<SF base: sf int: TBP>>=
   procedure :: get_n_states => sf_int_get_n_states
 <<SF base: sub interfaces>>=
     module function sf_int_get_n_states (sf_int) result (n_states)
       class(sf_int_t), intent(in) :: sf_int
       integer :: n_states
     end function sf_int_get_n_states
 <<SF base: procedures>>=
   module function sf_int_get_n_states (sf_int) result (n_states)
     class(sf_int_t), intent(in) :: sf_int
     integer :: n_states
     n_states = sf_int%get_n_matrix_elements ()
   end function sf_int_get_n_states
 
 @ %def sf_int_get_n_states
 @ Return a specific state as a quantum-number array.
 <<SF base: sf int: TBP>>=
   procedure :: get_state => sf_int_get_state
 <<SF base: sub interfaces>>=
     module function sf_int_get_state (sf_int, i) result (qn)
       class(sf_int_t), intent(in) :: sf_int
       type(quantum_numbers_t), dimension(:), allocatable :: qn
       integer, intent(in) :: i
     end function sf_int_get_state
 <<SF base: procedures>>=
   module function sf_int_get_state (sf_int, i) result (qn)
     class(sf_int_t), intent(in) :: sf_int
     type(quantum_numbers_t), dimension(:), allocatable :: qn
     integer, intent(in) :: i
     allocate (qn (sf_int%get_n_tot ()))
     qn = sf_int%get_quantum_numbers (i)
   end function sf_int_get_state
 
 @ %def sf_int_get_state
 @ Return the matrix-element values for all states.  We can assume that
 the matrix elements are real, so we take the real part.
 <<SF base: sf int: TBP>>=
   procedure :: get_values => sf_int_get_values
 <<SF base: sub interfaces>>=
     module subroutine sf_int_get_values (sf_int, value)
       class(sf_int_t), intent(in) :: sf_int
       real(default), dimension(:), intent(out) :: value
     end subroutine sf_int_get_values
 <<SF base: procedures>>=
   module subroutine sf_int_get_values (sf_int, value)
     class(sf_int_t), intent(in) :: sf_int
     real(default), dimension(:), intent(out) :: value
     integer :: i
     if (sf_int%status >= SF_EVALUATED) then
        do i = 1, size (value)
           value(i) = real (sf_int%get_matrix_element (i))
        end do
     else
        value = 0
     end if
   end subroutine sf_int_get_values
 
 @ %def sf_int_get_values
 @
 \subsection{Direct calculations}
 Compute a structure function value (array) directly, given an array of $x$
 values and a scale.  If the energy is also given, we initialize the
 kinematics for that energy, otherwise take it from a previous run.
 
 We assume that the [[E]] array has dimension [[n_in]], and the [[x]]
 array has [[n_par]].
 
 Note: the output x values ([[xx]] and [[xxb]]) are unused in this use case.
 <<SF base: sf int: TBP>>=
   procedure :: compute_values => sf_int_compute_values
 <<SF base: sub interfaces>>=
     module subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E)
       class(sf_int_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: value
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(in) :: scale
       real(default), dimension(:), intent(in), optional :: E
     end subroutine sf_int_compute_values
 <<SF base: procedures>>=
   module subroutine sf_int_compute_values (sf_int, value, x, xb, scale, E)
     class(sf_int_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: value
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(in) :: scale
     real(default), dimension(:), intent(in), optional :: E
     real(default), dimension(size (x)) :: xx, xxb
     real(default) :: f
     if (present (E))  call sf_int%seed_kinematics (E)
     if (sf_int%status >= SF_SEED_KINEMATICS) then
        call sf_int%complete_kinematics (xx, xxb, f, x, xb, map=.false.)
        call sf_int%apply (scale)
        call sf_int%get_values (value)
        value = value * f
     else
        value = 0
     end if
   end subroutine sf_int_compute_values
 
 @ %def sf_int_compute_values
 @ Compute just a single value for one of the states, i.e., throw the
 others away.
 <<SF base: sf int: TBP>>=
   procedure :: compute_value => sf_int_compute_value
 <<SF base: sub interfaces>>=
     module subroutine sf_int_compute_value &
          (sf_int, i_state, value, x, xb, scale, E)
       class(sf_int_t), intent(inout) :: sf_int
       integer, intent(in) :: i_state
       real(default), intent(out) :: value
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(in) :: scale
       real(default), dimension(:), intent(in), optional :: E
     end subroutine sf_int_compute_value
 <<SF base: procedures>>=
   module subroutine sf_int_compute_value &
        (sf_int, i_state, value, x, xb, scale, E)
     class(sf_int_t), intent(inout) :: sf_int
     integer, intent(in) :: i_state
     real(default), intent(out) :: value
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(in) :: scale
     real(default), dimension(:), intent(in), optional :: E
     real(default), dimension(:), allocatable :: value_array
     if (sf_int%status >= SF_INITIAL) then
        allocate (value_array (sf_int%get_n_states ()))
        call sf_int%compute_values (value_array, x, xb, scale, E)
        value = value_array(i_state)
     else
        value = 0
     end if
   end subroutine sf_int_compute_value
 
 @ %def sf_int_compute_value
 @
 \subsection{Structure-function instance}
 This is a wrapper for [[sf_int_t]] objects, such that we can
 build an array with different structure-function types.  The
 structure-function contains an array (a sequence) of [[sf_int_t]]
 objects.
 
 The object, it holds the evaluator that connects the preceding part of the
 structure-function chain to the current interaction.
 
 It also stores the input and output parameter values for the
 contained structure function.  The [[r]] array has a second dimension,
 corresponding to the mapping channels in a multi-channel
 configuration.  There is a Jacobian entry [[f]] for each channel.  The
 corresponding logical array [[mapping]] tells whether we apply the
 mapping appropriate for the current structure function in this channel.
 The [[x]] parameter values (energy fractions) are common to all
 channels.
 <<SF base: types>>=
   type :: sf_instance_t
      class(sf_int_t), allocatable :: int
      type(evaluator_t) :: eval
      real(default), dimension(:,:), allocatable :: r
      real(default), dimension(:,:), allocatable :: rb
      real(default), dimension(:), allocatable :: f
      logical, dimension(:), allocatable :: m
      real(default), dimension(:), allocatable :: x
      real(default), dimension(:), allocatable :: xb
   end type sf_instance_t
 
 @ %def sf_instance_t
 @
 \subsection{Structure-function chain}
 A chain is an array of structure functions [[sf]], initiated by a beam setup.
 We do not use this directly for evaluation, but create instances with
 copies of the contained interactions.
 
 [[n_par]] is the total number of parameters that is necessary for
 completely determining the structure-function chain.  [[n_bound]] is
 the number of MC input parameters that are requested from the
 integrator.  The difference of [[n_par]] and [[n_bound]] is the number
 of free parameters, which are generated by a structure-function
 object in generator mode.
 <<SF base: public>>=
   public :: sf_chain_t
 <<SF base: types>>=
   type, extends (beam_t) :: sf_chain_t
      type(beam_data_t), pointer :: beam_data => null ()
      integer :: n_in = 0
      integer :: n_strfun = 0
      integer :: n_par = 0
      integer :: n_bound = 0
      type(sf_instance_t), dimension(:), allocatable :: sf
      logical :: trace_enable = .false.
      integer :: trace_unit = 0
    contains
    <<SF base: sf chain: TBP>>
   end type sf_chain_t
 
 @ %def sf_chain_t
 @ Finalizer.
 <<SF base: sf chain: TBP>>=
   procedure :: final => sf_chain_final
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_final (object)
       class(sf_chain_t), intent(inout) :: object
     end subroutine sf_chain_final
 <<SF base: procedures>>=
   module subroutine sf_chain_final (object)
     class(sf_chain_t), intent(inout) :: object
     integer :: i
     call object%final_tracing ()
     if (allocated (object%sf)) then
        do i = 1, size (object%sf, 1)
           associate (sf => object%sf(i))
             if (allocated (sf%int)) then
                call sf%int%final ()
             end if
           end associate
        end do
     end if
     call beam_final (object%beam_t)
   end subroutine sf_chain_final
 
 @ %def sf_chain_final
 @ Output.
 <<SF base: sf chain: TBP>>=
   procedure :: write => sf_chain_write
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_write (object, unit)
       class(sf_chain_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine sf_chain_write
 <<SF base: procedures>>=
   module subroutine sf_chain_write (object, unit)
     class(sf_chain_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "Incoming particles / structure-function chain:"
     if (associated (object%beam_data)) then
        write (u, "(3x,A,I0)")  "n_in      = ", object%n_in
        write (u, "(3x,A,I0)")  "n_strfun  = ", object%n_strfun
        write (u, "(3x,A,I0)")  "n_par     = ", object%n_par
        if (object%n_par /= object%n_bound) then
           write (u, "(3x,A,I0)")  "n_bound   = ", object%n_bound
        end if
        call object%beam_data%write (u)
        call write_separator (u)
        call beam_write (object%beam_t, u)
        if (allocated (object%sf)) then
           do i = 1, object%n_strfun
              associate (sf => object%sf(i))
                call write_separator (u)
                if (allocated (sf%int)) then
                   call sf%int%write (u)
                else
                   write (u, "(1x,A)")  "SF instance: [undefined]"
                end if
              end associate
           end do
        end if
     else
        write (u, "(3x,A)")  "[undefined]"
     end if
   end subroutine sf_chain_write
 
 @ %def sf_chain_write
 @ Initialize: setup beams.  The [[beam_data]] target must remain valid
 for the lifetime of the chain, since we just establish a pointer.  The
 structure-function configuration array is used to initialize the
 individual structure-function entries.  The target attribute is needed
 because the [[sf_int]] entries establish pointers to the configuration data.
 <<SF base: sf chain: TBP>>=
   procedure :: init => sf_chain_init
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_init (sf_chain, beam_data, sf_config)
       class(sf_chain_t), intent(out) :: sf_chain
       type(beam_data_t), intent(in), target :: beam_data
       type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config
     end subroutine sf_chain_init
 <<SF base: procedures>>=
   module subroutine sf_chain_init (sf_chain, beam_data, sf_config)
     class(sf_chain_t), intent(out) :: sf_chain
     type(beam_data_t), intent(in), target :: beam_data
     type(sf_config_t), dimension(:), intent(in), optional, target :: sf_config
     integer :: i
     sf_chain%beam_data => beam_data
     sf_chain%n_in = beam_data%get_n_in ()
     call beam_init (sf_chain%beam_t, beam_data)
     if (present (sf_config)) then
        sf_chain%n_strfun = size (sf_config)
        allocate (sf_chain%sf (sf_chain%n_strfun))
        do i = 1, sf_chain%n_strfun
           call sf_chain%set_strfun (i, sf_config(i)%i, sf_config(i)%data)
        end do
     end if
   end subroutine sf_chain_init
 
 @ %def sf_chain_init
 @ Receive the beam momenta from a source to which the beam interaction
 is linked.
 <<SF base: sf chain: TBP>>=
   procedure :: receive_beam_momenta => sf_chain_receive_beam_momenta
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_receive_beam_momenta (sf_chain)
       class(sf_chain_t), intent(inout), target :: sf_chain
       type(interaction_t), pointer :: beam_int
     end subroutine sf_chain_receive_beam_momenta
 <<SF base: procedures>>=
   module subroutine sf_chain_receive_beam_momenta (sf_chain)
     class(sf_chain_t), intent(inout), target :: sf_chain
     type(interaction_t), pointer :: beam_int
     beam_int => sf_chain%get_beam_int_ptr ()
     call beam_int%receive_momenta ()
   end subroutine sf_chain_receive_beam_momenta
 
 @ %def sf_chain_receive_beam_momenta
 @ Explicitly set the beam momenta.
 <<SF base: sf chain: TBP>>=
   procedure :: set_beam_momenta => sf_chain_set_beam_momenta
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_set_beam_momenta (sf_chain, p)
       class(sf_chain_t), intent(inout) :: sf_chain
       type(vector4_t), dimension(:), intent(in) :: p
     end subroutine sf_chain_set_beam_momenta
 <<SF base: procedures>>=
   module subroutine sf_chain_set_beam_momenta (sf_chain, p)
     class(sf_chain_t), intent(inout) :: sf_chain
     type(vector4_t), dimension(:), intent(in) :: p
     call beam_set_momenta (sf_chain%beam_t, p)
   end subroutine sf_chain_set_beam_momenta
 
 @ %def sf_chain_set_beam_momenta
 @ Set a structure-function entry.  We use the [[data]] input to
 allocate the [[int]] structure-function instance with appropriate
 type, then initialize the entry.  The entry establishes a pointer to
 [[data]].
 
 The index [[i]] is the structure-function index in the chain.
 <<SF base: sf chain: TBP>>=
   procedure :: set_strfun => sf_chain_set_strfun
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data)
       class(sf_chain_t), intent(inout) :: sf_chain
       integer, intent(in) :: i
       integer, dimension(:), intent(in) :: beam_index
       class(sf_data_t), intent(in), target :: data
     end subroutine sf_chain_set_strfun
 <<SF base: procedures>>=
   module subroutine sf_chain_set_strfun (sf_chain, i, beam_index, data)
     class(sf_chain_t), intent(inout) :: sf_chain
     integer, intent(in) :: i
     integer, dimension(:), intent(in) :: beam_index
     class(sf_data_t), intent(in), target :: data
     integer :: n_par, j
     n_par = data%get_n_par ()
     call data%allocate_sf_int (sf_chain%sf(i)%int)
     associate (sf_int => sf_chain%sf(i)%int)
       call sf_int%init (data)
       call sf_int%set_beam_index (beam_index)
       call sf_int%set_par_index &
            ([(j, j = sf_chain%n_par + 1, sf_chain%n_par + n_par)])
       sf_chain%n_par = sf_chain%n_par + n_par
       if (.not. data%is_generator ()) then
          sf_chain%n_bound = sf_chain%n_bound + n_par
       end if
     end associate
   end subroutine sf_chain_set_strfun
 
 @ %def sf_chain_set_strfun
 @ Return the number of structure-function parameters.
 <<SF base: sf chain: TBP>>=
   procedure :: get_n_par => sf_chain_get_n_par
   procedure :: get_n_bound => sf_chain_get_n_bound
 <<SF base: sub interfaces>>=
     module function sf_chain_get_n_par (sf_chain) result (n)
       class(sf_chain_t), intent(in) :: sf_chain
       integer :: n
     end function sf_chain_get_n_par
     module function sf_chain_get_n_bound (sf_chain) result (n)
       class(sf_chain_t), intent(in) :: sf_chain
       integer :: n
     end function sf_chain_get_n_bound
 <<SF base: procedures>>=
   module function sf_chain_get_n_par (sf_chain) result (n)
     class(sf_chain_t), intent(in) :: sf_chain
     integer :: n
     n = sf_chain%n_par
   end function sf_chain_get_n_par
 
   module function sf_chain_get_n_bound (sf_chain) result (n)
     class(sf_chain_t), intent(in) :: sf_chain
     integer :: n
     n = sf_chain%n_bound
   end function sf_chain_get_n_bound
 
 @ %def sf_chain_get_n_par
 @ %def sf_chain_get_n_bound
 @ Return a pointer to the beam interaction.
 <<SF base: sf chain: TBP>>=
   procedure :: get_beam_int_ptr => sf_chain_get_beam_int_ptr
 <<SF base: sub interfaces>>=
     module function sf_chain_get_beam_int_ptr (sf_chain) result (int)
       type(interaction_t), pointer :: int
       class(sf_chain_t), intent(in), target :: sf_chain
     end function sf_chain_get_beam_int_ptr
 <<SF base: procedures>>=
   module function sf_chain_get_beam_int_ptr (sf_chain) result (int)
     type(interaction_t), pointer :: int
     class(sf_chain_t), intent(in), target :: sf_chain
     int => beam_get_int_ptr (sf_chain%beam_t)
   end function sf_chain_get_beam_int_ptr
 
 @ %def sf_chain_get_beam_int_ptr
 @ Enable the trace feature: record structure function data (input
 parameters, $x$ values, evaluation result) to an external file.
 <<SF base: sf chain: TBP>>=
   procedure :: setup_tracing => sf_chain_setup_tracing
   procedure :: final_tracing => sf_chain_final_tracing
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_setup_tracing (sf_chain, file)
       class(sf_chain_t), intent(inout) :: sf_chain
       type(string_t), intent(in) :: file
     end subroutine sf_chain_setup_tracing
     module subroutine sf_chain_final_tracing (sf_chain)
       class(sf_chain_t), intent(inout) :: sf_chain
     end subroutine sf_chain_final_tracing
 <<SF base: procedures>>=
   module subroutine sf_chain_setup_tracing (sf_chain, file)
     class(sf_chain_t), intent(inout) :: sf_chain
     type(string_t), intent(in) :: file
     if (sf_chain%n_strfun > 0) then
        sf_chain%trace_enable = .true.
        sf_chain%trace_unit = free_unit ()
        open (sf_chain%trace_unit, file = char (file), action = "write", &
             status = "replace")
        call sf_chain%write_trace_header ()
     else
        call msg_error ("Beam structure: no structure functions, tracing &
             &disabled")
     end if
   end subroutine sf_chain_setup_tracing
 
   module subroutine sf_chain_final_tracing (sf_chain)
     class(sf_chain_t), intent(inout) :: sf_chain
     if (sf_chain%trace_enable) then
        close (sf_chain%trace_unit)
        sf_chain%trace_enable = .false.
     end if
   end subroutine sf_chain_final_tracing
 
 @ %def sf_chain_setup_tracing
 @ %def sf_chain_final_tracing
 @ Write the header for the tracing file.
 <<SF base: sf chain: TBP>>=
   procedure :: write_trace_header => sf_chain_write_trace_header
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_write_trace_header (sf_chain)
       class(sf_chain_t), intent(in) :: sf_chain
     end subroutine sf_chain_write_trace_header
 <<SF base: procedures>>=
   module subroutine sf_chain_write_trace_header (sf_chain)
     class(sf_chain_t), intent(in) :: sf_chain
     integer :: u
     if (sf_chain%trace_enable) then
        u = sf_chain%trace_unit
        write (u, "('# ',A)")  "WHIZARD output: &
             &structure-function sampling data"
        write (u, "('# ',A,1x,I0)")  "Number of sf records:", sf_chain%n_strfun
        write (u, "('# ',A,1x,I0)")  "Number of parameters:", sf_chain%n_par
        write (u, "('# ',A)")  "Columns: channel, p(n_par), x(n_par), f, Jac * f"
     end if
   end subroutine sf_chain_write_trace_header
 
 @ %def sf_chain_write_trace_header
 @ Write a record which collects the structure function data for the
 current data point.  For the selected channel, we print first the
 input integration parameters, then the $x$ values, then the
 structure-function value summed over all quantum numbers, then the
 structure function value times the mapping Jacobian.
 <<SF base: sf chain: TBP>>=
   procedure :: trace => sf_chain_trace
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum)
       class(sf_chain_t), intent(in) :: sf_chain
       integer, intent(in) :: c_sel
       real(default), dimension(:,:), intent(in) :: p
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: f
       real(default), intent(in) :: sf_sum
     end subroutine sf_chain_trace
 <<SF base: procedures>>=
   module subroutine sf_chain_trace (sf_chain, c_sel, p, x, f, sf_sum)
     class(sf_chain_t), intent(in) :: sf_chain
     integer, intent(in) :: c_sel
     real(default), dimension(:,:), intent(in) :: p
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: f
     real(default), intent(in) :: sf_sum
     real(default) :: sf_sum_pac, f_sf_sum_pac
     integer :: u, i
     if (sf_chain%trace_enable) then
        u = sf_chain%trace_unit
        write (u, "(1x,I0)", advance="no")  c_sel
        write (u, "(2x)", advance="no")
        do i = 1, sf_chain%n_par
           write (u, "(1x," // FMT_17 // ")", advance="no")  p(i,c_sel)
        end do
        write (u, "(2x)", advance="no")
        do i = 1, sf_chain%n_par
           write (u, "(1x," // FMT_17 // ")", advance="no")  x(i)
        end do
        write (u, "(2x)", advance="no")
        sf_sum_pac = sf_sum
        f_sf_sum_pac = f(c_sel) * sf_sum
        call pacify (sf_sum_pac, 1.E-28_default)
        call pacify (f_sf_sum_pac, 1.E-28_default)
        write (u, "(2(1x," // FMT_17 // "))")  sf_sum_pac, f_sf_sum_pac
     end if
   end subroutine sf_chain_trace
 
 @ %def sf_chain_trace
 @
 \subsection{Chain instances}
 A structure-function chain instance contains copies of the
 interactions in the configuration chain, suitably linked to each other
 and connected by evaluators.
 
 After initialization, [[out_sf]] should point, for each beam, to the
 last structure function that affects this beam.  [[out_sf_i]] should
 indicate the index of the corresponding outgoing particle within that
 structure-function interaction.
 
 Analogously, [[out_eval]] is the last evaluator in the
 structure-function chain, which contains the complete set of outgoing
 particles. [[out_eval_i]] should indicate the index of the outgoing
 particles, within that evaluator, which will initiate the collision.
 
 When calculating actual kinematics, we fill the [[p]], [[r]], and
 [[x]] arrays and the [[f]] factor.  The [[p]] array denotes the MC
 input parameters as they come from the random-number generator.  The
 [[r]] array results from applying global mappings.  The [[x]] array
 results from applying structure-function local mappings.  The $x$
 values can be interpreted directly as momentum fractions (or angle
 fractions, where recoil is involved).  The [[f]] factor is the
 Jacobian that results from applying all mappings.
 
 Update 2017-08-22: carry and output all complements ([[pb]], [[rb]],
 [[xb]]).  Previously, [[xb]] was not included in the record, and the
 output did not contain either.  It does become more verbose, however.
 
 The [[mapping]] entry may store a global mapping that is applied to a
 combination of $x$ values and structure functions, as opposed to mappings that
 affect only a single structure function.  It is applied before the latter
 mappings, in the transformation from the [[p]] array to the [[r]] array.  For
 parameters affected by this mapping, we should ensure that they are not
 involved in a local mapping.
 <<SF base: public>>=
   public :: sf_chain_instance_t
 <<SF base: types>>=
   type, extends (beam_t) :: sf_chain_instance_t
      type(sf_chain_t), pointer :: config => null ()
      integer :: status = SF_UNDEFINED
      type(sf_instance_t), dimension(:), allocatable :: sf
      integer, dimension(:), allocatable :: out_sf
      integer, dimension(:), allocatable :: out_sf_i
      integer :: out_eval = 0
      integer, dimension(:), allocatable :: out_eval_i
      integer :: selected_channel = 0
      real(default), dimension(:,:), allocatable :: p, pb
      real(default), dimension(:,:), allocatable :: r, rb
      real(default), dimension(:), allocatable :: f
      real(default), dimension(:), allocatable :: x, xb
      logical, dimension(:), allocatable :: bound
      real(default) :: x_free = 1
      type(sf_channel_t), dimension(:), allocatable :: channel
    contains
    <<SF base: sf chain instance: TBP>>
   end type sf_chain_instance_t
 
 @ %def sf_chain_instance_t
 @ Finalizer.
 <<SF base: sf chain instance: TBP>>=
   procedure :: final => sf_chain_instance_final
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_final (object)
       class(sf_chain_instance_t), intent(inout) :: object
     end subroutine sf_chain_instance_final
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_final (object)
     class(sf_chain_instance_t), intent(inout) :: object
     integer :: i
     if (allocated (object%sf)) then
        do i = 1, size (object%sf, 1)
           associate (sf => object%sf(i))
             if (allocated (sf%int)) then
                call sf%eval%final ()
                call sf%int%final ()
             end if
           end associate
        end do
     end if
     call beam_final (object%beam_t)
   end subroutine sf_chain_instance_final
 
 @ %def sf_chain_instance_final
 @ Output.
 <<SF base: sf chain instance: TBP>>=
   procedure :: write => sf_chain_instance_write
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_write (object, unit, col_verbose)
       class(sf_chain_instance_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: col_verbose
     end subroutine sf_chain_instance_write
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_write (object, unit, col_verbose)
     class(sf_chain_instance_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: col_verbose
     integer :: u, i, c
     u = given_output_unit (unit)
     write (u, "(1x,A)", advance="no")  "Structure-function chain instance:"
     call write_sf_status (object%status, u)
     if (allocated (object%out_sf)) then
        write (u, "(3x,A)", advance="no")  "outgoing (interactions) ="
        do i = 1, size (object%out_sf)
           write (u, "(1x,I0,':',I0)", advance="no") &
                object%out_sf(i), object%out_sf_i(i)
        end do
        write (u, *)
     end if
     if (object%out_eval /= 0) then
        write (u, "(3x,A)", advance="no")  "outgoing (evaluators)   ="
        do i = 1, size (object%out_sf)
           write (u, "(1x,I0,':',I0)", advance="no") &
                object%out_eval, object%out_eval_i(i)
        end do
        write (u, *)
     end if
     if (allocated (object%sf)) then
        if (size (object%sf) /= 0) then
           write (u, "(1x,A)")  "Structure-function parameters:"
           do c = 1, size (object%f)
              write (u, "(1x,A,I0,A)", advance="no")  "Channel #", c, ":"
              if (c == object%selected_channel) then
                 write (u, "(1x,A)")  "[selected]"
              else
                 write (u, *)
              end if
              write (u, "(3x,A,9(1x,F9.7))")  "p =", object%p(:,c)
              write (u, "(3x,A,9(1x,F9.7))")  "pb=", object%pb(:,c)
              write (u, "(3x,A,9(1x,F9.7))")  "r =", object%r(:,c)
              write (u, "(3x,A,9(1x,F9.7))")  "rb=", object%rb(:,c)
              write (u, "(3x,A,9(1x,ES13.7))")  "f =", object%f(c)
              write (u, "(3x,A)", advance="no") "m ="
              call object%channel(c)%write (u)
           end do
           write (u, "(3x,A,9(1x,F9.7))")  "x =", object%x
           write (u, "(3x,A,9(1x,F9.7))")  "xb=", object%xb
           if (.not. all (object%bound)) then
              write (u, "(3x,A,9(1x,L1))")  "bound =", object%bound
           end if
        end if
     end if
     call write_separator (u)
     call beam_write (object%beam_t, u, col_verbose = col_verbose)
     if (allocated (object%sf)) then
        do i = 1, size (object%sf)
           associate (sf => object%sf(i))
             call write_separator (u)
             if (allocated (sf%int)) then
                if (allocated (sf%r)) then
                   write (u, "(1x,A)")  "Structure-function parameters:"
                   do c = 1, size (sf%f)
                      write (u, "(1x,A,I0,A)", advance="no")  "Channel #", c, ":"
                      if (c == object%selected_channel) then
                         write (u, "(1x,A)")  "[selected]"
                      else
                         write (u, *)
                      end if
                      write (u, "(3x,A,9(1x,F9.7))")  "r =", sf%r(:,c)
                      write (u, "(3x,A,9(1x,F9.7))")  "rb=", sf%rb(:,c)
                      write (u, "(3x,A,9(1x,ES13.7))")  "f =", sf%f(c)
                      write (u, "(3x,A,9(1x,L1,7x))") "m =", sf%m(c)
                   end do
                   write (u, "(3x,A,9(1x,F9.7))")  "x =", sf%x
                   write (u, "(3x,A,9(1x,F9.7))")  "xb=", sf%xb
                end if
                call sf%int%write(u)
                if (.not. sf%eval%is_empty ()) then
                      call sf%eval%write (u, col_verbose = col_verbose)
                end if
             end if
           end associate
        end do
     end if
   end subroutine sf_chain_instance_write
 
 @ %def sf_chain_instance_write
 @ Initialize.  This creates a copy of the interactions in the
 configuration chain, assumed to be properly initialized.  In the copy,
 we allocate the [[p]] etc.\ arrays.
 
 The brute-force assignment of the [[sf]] component would be
 straightforward, but we provide a more fine-grained copy.
 In any case, the copy is deep as far as allocatables are concerned,
 but for the contained [[interaction_t]] objects the copy is shallow,
 as long as we do not bind defined assignment to the type.  Therefore,
 we have to re-assign the [[interaction_t]] components explicitly, this
 time calling the proper defined assignment.  Furthermore, we allocate
 the parameter arrays for each structure function.
 <<SF base: sf chain instance: TBP>>=
   procedure :: init => sf_chain_instance_init
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_init (chain, config, n_channel)
       class(sf_chain_instance_t), intent(out), target :: chain
       type(sf_chain_t), intent(in), target :: config
       integer, intent(in) :: n_channel
     end subroutine sf_chain_instance_init
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_init (chain, config, n_channel)
     class(sf_chain_instance_t), intent(out), target :: chain
     type(sf_chain_t), intent(in), target :: config
     integer, intent(in) :: n_channel
     integer :: i, j
     integer :: n_par_tot, n_par, n_strfun
     chain%config => config
     n_strfun = config%n_strfun
     chain%beam_t = config%beam_t
     allocate (chain%out_sf (config%n_in), chain%out_sf_i (config%n_in))
     allocate (chain%out_eval_i (config%n_in))
     chain%out_sf = 0
     chain%out_sf_i = [(i, i = 1, config%n_in)]
     chain%out_eval_i = chain%out_sf_i
     n_par_tot = 0
     if (n_strfun /= 0) then
        allocate (chain%sf (n_strfun))
        do i = 1, n_strfun
           associate (sf => chain%sf(i))
             allocate (sf%int, source=config%sf(i)%int)
             sf%int%interaction_t = config%sf(i)%int%interaction_t
             n_par = size (sf%int%par_index)
             allocate (sf%r (n_par, n_channel));  sf%r = 0
             allocate (sf%rb(n_par, n_channel));  sf%rb= 0
             allocate (sf%f (n_channel));         sf%f = 0
             allocate (sf%m (n_channel));         sf%m = .false.
             allocate (sf%x (n_par));             sf%x = 0
             allocate (sf%xb(n_par));             sf%xb= 0
             n_par_tot = n_par_tot + n_par
           end associate
        end do
        allocate (chain%p (n_par_tot, n_channel));  chain%p = 0
        allocate (chain%pb(n_par_tot, n_channel));  chain%pb= 0
        allocate (chain%r (n_par_tot, n_channel));  chain%r = 0
        allocate (chain%rb(n_par_tot, n_channel));  chain%rb= 0
        allocate (chain%f (n_channel));             chain%f = 0
        allocate (chain%x (n_par_tot));             chain%x = 0
        allocate (chain%xb(n_par_tot));             chain%xb= 0
        call allocate_sf_channels &
             (chain%channel, n_channel=n_channel, n_strfun=n_strfun)
     end if
     allocate (chain%bound (n_par_tot), source = .true.)
     do i = 1, n_strfun
        associate (sf => chain%sf(i))
          if (sf%int%is_generator ()) then
             do j = 1, size (sf%int%par_index)
                chain%bound(sf%int%par_index(j)) = .false.
             end do
          end if
        end associate
     end do
     chain%status = SF_INITIAL
   end subroutine sf_chain_instance_init
 
 @ %def sf_chain_instance_init
 @ Manually select a channel.
 <<SF base: sf chain instance: TBP>>=
   procedure :: select_channel => sf_chain_instance_select_channel
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_select_channel (chain, channel)
       class(sf_chain_instance_t), intent(inout) :: chain
       integer, intent(in), optional :: channel
     end subroutine sf_chain_instance_select_channel
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_select_channel (chain, channel)
     class(sf_chain_instance_t), intent(inout) :: chain
     integer, intent(in), optional :: channel
     if (present (channel)) then
        chain%selected_channel = channel
     else
        chain%selected_channel = 0
     end if
   end subroutine sf_chain_instance_select_channel
 
 @ %def sf_chain_instance_select_channel
 @ Copy a channel-mapping object to the structure-function
 chain instance.  We assume that assignment is sufficient, i.e., any
 non-static components of the [[channel]] object are allocatable und
 thus recursively copied.
 
 After the copy, we extract the single-entry mappings and activate them
 for the individual structure functions.  If there is a multi-entry
 mapping, we obtain the corresponding MC parameter indices and set them
 in the copy of the channel object.
 <<SF base: sf chain instance: TBP>>=
   procedure :: set_channel => sf_chain_instance_set_channel
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_set_channel (chain, c, channel)
       class(sf_chain_instance_t), intent(inout) :: chain
       integer, intent(in) :: c
       type(sf_channel_t), intent(in) :: channel
     end subroutine sf_chain_instance_set_channel
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_set_channel (chain, c, channel)
     class(sf_chain_instance_t), intent(inout) :: chain
     integer, intent(in) :: c
     type(sf_channel_t), intent(in) :: channel
     integer :: i, j, k
     if (chain%status >= SF_INITIAL) then
        chain%channel(c) = channel
        j = 0
        do i = 1, chain%config%n_strfun
           associate (sf => chain%sf(i))
             sf%m(c) = channel%is_single_mapping (i)
             if (channel%is_multi_mapping (i)) then
                do k = 1, size (sf%int%beam_index)
                   j = j + 1
                   call chain%channel(c)%set_par_index &
                        (j, sf%int%par_index(k))
                end do
             end if
           end associate
        end do
        if (j /= chain%channel(c)%get_multi_mapping_n_par ()) then
           print *, "index last filled    = ", j
           print *, "number of parameters = ", &
                chain%channel(c)%get_multi_mapping_n_par ()
           call msg_bug ("Structure-function setup: mapping index mismatch")
        end if
        chain%status = SF_INITIAL
     end if
   end subroutine sf_chain_instance_set_channel
 
 @ %def sf_chain_instance_set_channel
 @ Link the interactions in the chain.  First, link the beam instance
 to its template in the configuration chain, which should have the
 appropriate momenta fixed.
 
 Then, we follow the chain via the
 arrays [[out_sf]] and [[out_sf_i]].  The arrays are (up to)
 two-dimensional, the entries correspond to the beam particle(s).
 For each beam, the entry [[out_sf]] points to the last interaction
 that affected this beam, and [[out_sf_i]] is the
 out-particle index within that interaction.  For the initial beam,
 [[out_sf]] is zero by definition.
 
 For each entry in the chain, we scan the affected beams (one or two).
 We look for [[out_sf]] and link the out-particle there to the
 corresponding in-particle in the current interaction.  Then, we update
 the entry in [[out_sf]] and [[out_sf_i]] to point to the current
 interaction.
 <<SF base: sf chain instance: TBP>>=
   procedure :: link_interactions => sf_chain_instance_link_interactions
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_link_interactions (chain)
       class(sf_chain_instance_t), intent(inout), target :: chain
     end subroutine sf_chain_instance_link_interactions
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_link_interactions (chain)
     class(sf_chain_instance_t), intent(inout), target :: chain
     type(interaction_t), pointer :: int
     integer :: i, j, b
     if (chain%status >= SF_INITIAL) then
        do b = 1, chain%config%n_in
           int => beam_get_int_ptr (chain%beam_t)
           call interaction_set_source_link_beam (int, b, &
                chain%config%beam_t, b)
        end do
        if (allocated (chain%sf)) then
           do i = 1, size (chain%sf)
              associate (sf_int => chain%sf(i)%int)
                do j = 1, size (sf_int%beam_index)
                   b = sf_int%beam_index(j)
                   call link (sf_int%interaction_t, b, sf_int%incoming(j))
                   chain%out_sf(b) = i
                   chain%out_sf_i(b) = sf_int%outgoing(j)
                end do
              end associate
           end do
        end if
        chain%status = SF_DONE_LINKS
     end if
   contains
     subroutine link (int, b, in_index)
       type(interaction_t), intent(inout) :: int
       integer, intent(in) :: b, in_index
       integer :: i
       i = chain%out_sf(b)
       select case (i)
       case (0)
          call interaction_set_source_link_beam (int, in_index, &
               chain%beam_t, chain%out_sf_i(b))
       case default
          call int%set_source_link (in_index, &
               chain%sf(i)%int, chain%out_sf_i(b))
       end select
     end subroutine link
   end subroutine sf_chain_instance_link_interactions
 
 @ %def sf_chain_instance_link_interactions
 @ Exchange the quantum-number masks between the interactions in the
 chain, so we can combine redundant entries and detect any obvious mismatch.
 
 We proceed first in the forward direction and then backwards again.
 
 After this is finished, we finalize initialization by calling the
 [[setup_constants]] method, which prepares constant data that depend on the
 matrix element structure.
 <<SF base: sf chain instance: TBP>>=
   procedure :: exchange_mask => sf_chain_exchange_mask
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_exchange_mask (chain)
       class(sf_chain_instance_t), intent(inout), target :: chain
     end subroutine sf_chain_exchange_mask
 <<SF base: procedures>>=
   module subroutine sf_chain_exchange_mask (chain)
     class(sf_chain_instance_t), intent(inout), target :: chain
     type(interaction_t), pointer :: int
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
     integer :: i
     if (chain%status >= SF_DONE_LINKS) then
        if (allocated (chain%sf)) then
           int => beam_get_int_ptr (chain%beam_t)
           allocate (mask (int%get_n_out ()))
           mask = int%get_mask ()
           if (size (chain%sf) /= 0) then
              do i = 1, size (chain%sf) - 1
                 call chain%sf(i)%int%exchange_mask ()
              end do
              do i = size (chain%sf), 1, -1
                 call chain%sf(i)%int%exchange_mask ()
              end do
              if (any (mask .neqv. int%get_mask ())) then
                 chain%status = SF_FAILED_MASK
                 return
              end if
              do i = 1, size (chain%sf)
                 call chain%sf(i)%int%setup_constants ()
              end do
           end if
        end if
        chain%status = SF_DONE_MASK
     end if
   end subroutine sf_chain_exchange_mask
 
 @ %def sf_chain_exchange_mask
 @ Initialize the evaluators that connect the interactions in the
 chain.
 <<SF base: sf chain instance: TBP>>=
   procedure :: init_evaluators => sf_chain_instance_init_evaluators
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_init_evaluators (chain, extended_sf)
       class(sf_chain_instance_t), intent(inout), target :: chain
       logical, intent(in), optional :: extended_sf
     end subroutine sf_chain_instance_init_evaluators
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_init_evaluators (chain, extended_sf)
     class(sf_chain_instance_t), intent(inout), target :: chain
     logical, intent(in), optional :: extended_sf
     type(interaction_t), pointer :: int
     type(quantum_numbers_mask_t) :: mask
     integer :: i
     logical :: yorn
     yorn = .false.; if (present (extended_sf)) yorn = extended_sf
     if (chain%status >= SF_DONE_MASK) then
        if (allocated (chain%sf)) then
           if (size (chain%sf) /= 0) then
              mask = quantum_numbers_mask (.false., .false., .true.)
              int => beam_get_int_ptr (chain%beam_t)
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                    if (yorn) then
                       if (int%get_n_sub () == 0) then
                          call int%declare_subtraction (n_beams_rescaled)
                       end if
                       if (sf%int%interaction_t%get_n_sub () == 0) then
                          call sf%int%interaction_t%declare_subtraction (n_beams_rescaled)
                       end if
                    end if
                    call sf%eval%init_product (int, sf%int%interaction_t, mask,&
                         & ignore_sub_for_qn = .true.)
                    if (sf%eval%is_empty ()) then
                       chain%status = SF_FAILED_CONNECTIONS
                       return
                    end if
                    int => sf%eval%interaction_t
                 end associate
              end do
              call find_outgoing_particles ()
           end if
        else if (chain%out_eval == 0) then
           int => beam_get_int_ptr (chain%beam_t)
           call int%tag_hard_process ()
        end if
        chain%status = SF_DONE_CONNECTIONS
     end if
   contains
   <<SF base: init evaluators: find outgoing particles>>
   end subroutine sf_chain_instance_init_evaluators
 
 @ %def sf_chain_instance_init_evaluators
 @ For debug purposes
 <<SF base: sf chain instance: TBP>>=
   procedure :: write_interaction => sf_chain_instance_write_interaction
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_write_interaction &
          (chain, i_sf, i_int, unit)
       class(sf_chain_instance_t), intent(in) :: chain
       integer, intent(in) :: i_sf, i_int
       integer, intent(in) :: unit
     end subroutine sf_chain_instance_write_interaction
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_write_interaction &
        (chain, i_sf, i_int, unit)
     class(sf_chain_instance_t), intent(in) :: chain
     integer, intent(in) :: i_sf, i_int
     integer, intent(in) :: unit
     class(interaction_t), pointer :: int_in1 => null ()
     class(interaction_t), pointer :: int_in2 => null ()
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     if (chain%status >= SF_DONE_MASK) then
        if (allocated (chain%sf)) then
           int_in1 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 1)
           int_in2 => evaluator_get_int_in_ptr (chain%sf(i_sf)%eval, 2)
           if (int_in1%get_tag () == i_int) then
              call int_in1%basic_write (u)
           else if (int_in2%get_tag () == i_int) then
              call int_in2%basic_write (u)
           else
              write (u, "(A,1x,I0,1x,A,1x,I0)") 'No tag of sf', i_sf, 'matches' , i_int
           end if
        else
           write (u, "(A)") 'No sf_chain allocated!'
        end if
     else
        write (u, "(A)") 'sf_chain not ready!'
     end if
   end subroutine sf_chain_instance_write_interaction
 
 @ %def sf_chain_instance_write_interaction
 @ This is an internal subroutine of the previous one: After evaluators
 are set, trace the outgoing particles to the last evaluator.  We only
 need the first channel, all channels are equivalent for this purpose.
 
 For each beam, the outgoing particle is located by [[out_sf]] (the
 structure-function object where it originates) and [[out_sf_i]] (the
 index within that object).  This particle is referenced by the
 corresponding evaluator, which in turn is referenced by the next
 evaluator, until we are at the end of the chain.  We can trace back
 references by [[interaction_find_link]].  Knowing that [[out_eval]] is
 the index of the last evaluator, we thus determine [[out_eval_i]], the
 index of the outgoing particle within that evaluator.
 <<SF base: init evaluators: find outgoing particles>>=
   subroutine find_outgoing_particles ()
     type(interaction_t), pointer :: int, int_next
     integer :: i, j, out_sf, out_i
     chain%out_eval = size (chain%sf)
     do j = 1, size (chain%out_eval_i)
        out_sf = chain%out_sf(j)
        out_i = chain%out_sf_i(j)
        if (out_sf == 0) then
           int => beam_get_int_ptr (chain%beam_t)
           out_sf = 1
        else
           int => chain%sf(out_sf)%int%interaction_t
        end if
        do i = out_sf, chain%out_eval
           int_next => chain%sf(i)%eval%interaction_t
           out_i = interaction_find_link (int_next, int, out_i)
           int => int_next
        end do
        chain%out_eval_i(j) = out_i
     end do
     call int%tag_hard_process (chain%out_eval_i)
   end subroutine find_outgoing_particles
 
 @ %def find_outgoing_particles
 @ Compute the kinematics in the chain instance.  We can assume that
 the seed momenta are set in the configuration beams.  Scanning the
 chain, we first transfer the incoming momenta.  Then, the use up the MC input
 parameter array [[p]] to compute the radiated and outgoing momenta.
 
 In the multi-channel case, [[c_sel]] is the channel which we use for
 computing the kinematics and the [[x]] values.  In the other channels,
 we invert the kinematics in order to recover the corresponding rows in
 the [[r]] array, and the Jacobian [[f]].
 
 We first apply any global mapping to transform the input [[p]] into
 the array [[r]].  This is then given to the structure functions which
 compute the final array [[x]] and Jacobian factors [[f]], which we
 multiply to obtain the overall Jacobian.
 <<SF base: sf chain instance: TBP>>=
   procedure :: compute_kinematics => sf_chain_instance_compute_kinematics
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in)
       class(sf_chain_instance_t), intent(inout), target :: chain
       integer, intent(in) :: c_sel
       real(default), dimension(:), intent(in) :: p_in
     end subroutine sf_chain_instance_compute_kinematics
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_compute_kinematics (chain, c_sel, p_in)
     class(sf_chain_instance_t), intent(inout), target :: chain
     integer, intent(in) :: c_sel
     real(default), dimension(:), intent(in) :: p_in
     type(interaction_t), pointer :: int
     real(default) :: f_mapping
     integer :: i, j, c
     if (chain%status >= SF_DONE_CONNECTIONS) then
        call chain%select_channel (c_sel)
        int => beam_get_int_ptr (chain%beam_t)
        call int%receive_momenta ()
        if (allocated (chain%sf)) then
           if (size (chain%sf) /= 0) then
              forall (i = 1:size (chain%sf))  chain%sf(i)%int%status = SF_INITIAL
              chain%p (:,c_sel) = unpack (p_in, chain%bound, 0._default)
              chain%pb(:,c_sel) = 1 - chain%p(:,c_sel)
              chain%f = 1
              chain%x_free = 1
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                   call sf%int%generate_free (sf%r(:,c_sel), sf%rb(:,c_sel), &
                        chain%x_free)
                   do j = 1, size (sf%x)
                      if (.not. chain%bound(sf%int%par_index(j))) then
                         chain%p (sf%int%par_index(j),c_sel) = sf%r (j,c_sel)
                         chain%pb(sf%int%par_index(j),c_sel) = sf%rb(j,c_sel)
                      end if
                   end do
                 end associate
              end do
              if (allocated (chain%channel(c_sel)%multi_mapping)) then
                 call chain%channel(c_sel)%multi_mapping%compute &
                      (chain%r(:,c_sel), chain%rb(:,c_sel), &
                       f_mapping, &
                       chain%p(:,c_sel), chain%pb(:,c_sel), &
                       chain%x_free)
                 chain%f(c_sel) = f_mapping
              else
                 chain%r (:,c_sel) = chain%p (:,c_sel)
                 chain%rb(:,c_sel) = chain%pb(:,c_sel)
                 chain%f(c_sel) = 1
              end if
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                   call sf%int%seed_kinematics ()
                   do j = 1, size (sf%x)
                      sf%r (j,c_sel) = chain%r (sf%int%par_index(j),c_sel)
                      sf%rb(j,c_sel) = chain%rb(sf%int%par_index(j),c_sel)
                   end do
                   call sf%int%complete_kinematics &
                        (sf%x, sf%xb, sf%f(c_sel), sf%r(:,c_sel), sf%rb(:,c_sel), &
                         sf%m(c_sel))
                   do j = 1, size (sf%x)
                      chain%x(sf%int%par_index(j)) = sf%x(j)
                      chain%xb(sf%int%par_index(j)) = sf%xb(j)
                   end do
                   if (sf%int%status <= SF_FAILED_KINEMATICS) then
                      chain%status = SF_FAILED_KINEMATICS
                      return
                   end if
                   do c = 1, size (sf%f)
                      if (c /= c_sel) then
                         call sf%int%inverse_kinematics &
                              (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c))
                         do j = 1, size (sf%x)
                            chain%r (sf%int%par_index(j),c) = sf%r (j,c)
                            chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
                         end do
                      end if
                      chain%f(c) = chain%f(c) * sf%f(c)
                   end do
                   if (.not. sf%eval%is_empty ()) then
                      call sf%eval%receive_momenta ()
                   end if
                 end associate
              end do
              do c = 1, size (chain%f)
                 if (c /= c_sel) then
                    if (allocated (chain%channel(c)%multi_mapping)) then
                       call chain%channel(c)%multi_mapping%inverse &
                            (chain%r(:,c), chain%rb(:,c), &
                             f_mapping, &
                             chain%p(:,c), chain%pb(:,c), &
                             chain%x_free)
                       chain%f(c) = chain%f(c) * f_mapping
                    else
                       chain%p (:,c) = chain%r (:,c)
                       chain%pb(:,c) = chain%rb(:,c)
                    end if
                 end if
              end do
           end if
        end if
        chain%status = SF_DONE_KINEMATICS
     end if
   end subroutine sf_chain_instance_compute_kinematics
 
 @ %def sf_chain_instance_compute_kinematics
 @ This is a variant of the previous procedure.  We know the $x$ parameters and
 reconstruct the momenta and the MC input parameters [[p]].  We do not need to
 select a channel.
 
 Note: this is probably redundant, since the method we actually want
 starts from the momenta, recovers all $x$ parameters, and then
 inverts mappings.  See below [[recover_kinematics]].
 <<SF base: sf chain instance: TBP>>=
   procedure :: inverse_kinematics => sf_chain_instance_inverse_kinematics
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_inverse_kinematics (chain, x, xb)
       class(sf_chain_instance_t), intent(inout), target :: chain
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
     end subroutine sf_chain_instance_inverse_kinematics
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_inverse_kinematics (chain, x, xb)
     class(sf_chain_instance_t), intent(inout), target :: chain
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     type(interaction_t), pointer :: int
     real(default) :: f_mapping
     integer :: i, j, c
     if (chain%status >= SF_DONE_CONNECTIONS) then
        call chain%select_channel ()
        int => beam_get_int_ptr (chain%beam_t)
        call int%receive_momenta ()
        if (allocated (chain%sf)) then
           chain%f = 1
           if (size (chain%sf) /= 0) then
              forall (i = 1:size (chain%sf))  chain%sf(i)%int%status = SF_INITIAL
              chain%x = x
              chain%xb= xb
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                   call sf%int%seed_kinematics ()
                   do j = 1, size (sf%x)
                      sf%x(j)  = chain%x(sf%int%par_index(j))
                      sf%xb(j) = chain%xb(sf%int%par_index(j))
                   end do
                   do c = 1, size (sf%f)
                      call sf%int%inverse_kinematics &
                           (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), &
                           set_momenta = c==1)
                      chain%f(c) = chain%f(c) * sf%f(c)
                      do j = 1, size (sf%x)
                         chain%r (sf%int%par_index(j),c) = sf%r (j,c)
                         chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
                      end do
                   end do
                   if (.not. sf%eval%is_empty ()) then
                      call sf%eval%receive_momenta ()
                   end if
                 end associate
              end do
              do c = 1, size (chain%f)
                 if (allocated (chain%channel(c)%multi_mapping)) then
                    call chain%channel(c)%multi_mapping%inverse &
                         (chain%r(:,c), chain%rb(:,c), &
                         f_mapping, &
                         chain%p(:,c), chain%pb(:,c), &
                         chain%x_free)
                    chain%f(c) = chain%f(c) * f_mapping
                 else
                    chain%p (:,c) = chain%r (:,c)
                    chain%pb(:,c) = chain%rb(:,c)
                 end if
              end do
           end if
        end if
        chain%status = SF_DONE_KINEMATICS
     end if
   end subroutine sf_chain_instance_inverse_kinematics
 
 @ %def sf_chain_instance_inverse_kinematics
 @ Recover the kinematics: assuming that the last evaluator has
 been filled with a valid set of momenta, we travel the momentum links
 backwards and fill the preceding evaluators and, as a side effect,
 interactions.  We stop at the beam interaction.
 
 After all momenta are set, apply the [[inverse_kinematics]] procedure
 above, suitably modified, to recover the $x$ and $p$ parameters and
 the Jacobian factors.
 
 The [[c_sel]] (channel) argument is just used to mark a selected
 channel for the records, otherwise the recovery procedure is
 independent of this.
 <<SF base: sf chain instance: TBP>>=
   procedure :: recover_kinematics => sf_chain_instance_recover_kinematics
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_recover_kinematics (chain, c_sel)
       class(sf_chain_instance_t), intent(inout), target :: chain
       integer, intent(in) :: c_sel
     end subroutine sf_chain_instance_recover_kinematics
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_recover_kinematics (chain, c_sel)
     class(sf_chain_instance_t), intent(inout), target :: chain
     integer, intent(in) :: c_sel
     real(default) :: f_mapping
     integer :: i, j, c
     if (chain%status >= SF_DONE_CONNECTIONS) then
        call chain%select_channel (c_sel)
        if (allocated (chain%sf)) then
           do i = size (chain%sf), 1, -1
              associate (sf => chain%sf(i))
                if (.not. sf%eval%is_empty ()) then
                   call sf%eval%send_momenta ()
                end if
              end associate
           end do
           chain%f = 1
           if (size (chain%sf) /= 0) then
              forall (i = 1:size (chain%sf))  chain%sf(i)%int%status = SF_INITIAL
              chain%x_free = 1
              do i = 1, size (chain%sf)
                 associate (sf => chain%sf(i))
                   call sf%int%seed_kinematics ()
                   call sf%int%recover_x (sf%x, sf%xb, chain%x_free)
                   do j = 1, size (sf%x)
                      chain%x(sf%int%par_index(j))  = sf%x(j)
                      chain%xb(sf%int%par_index(j)) = sf%xb(j)
                   end do
                   do c = 1, size (sf%f)
                      call sf%int%inverse_kinematics &
                           (sf%x, sf%xb, sf%f(c), sf%r(:,c), sf%rb(:,c), sf%m(c), &
                           set_momenta = .false.)
                      chain%f(c) = chain%f(c) * sf%f(c)
                      do j = 1, size (sf%x)
                         chain%r (sf%int%par_index(j),c) = sf%r (j,c)
                         chain%rb(sf%int%par_index(j),c) = sf%rb(j,c)
                      end do
                   end do
                 end associate
              end do
              do c = 1, size (chain%f)
                 if (allocated (chain%channel(c)%multi_mapping)) then
                    call chain%channel(c)%multi_mapping%inverse &
                         (chain%r(:,c), chain%rb(:,c), &
                         f_mapping, &
                         chain%p(:,c), chain%pb(:,c), &
                         chain%x_free)
                    chain%f(c) = chain%f(c) * f_mapping
                 else
                    chain%p (:,c) = chain%r (:,c)
                    chain%pb(:,c) = chain%rb(:,c)
                 end if
              end do
           end if
        end if
        chain%status = SF_DONE_KINEMATICS
     end if
   end subroutine sf_chain_instance_recover_kinematics
 
 @ %def sf_chain_instance_recover_kinematics
 @ Return the initial beam momenta to their source, thus completing
 kinematics recovery.  Obviously, this works as a side effect.
 <<SF base: sf chain instance: TBP>>=
   procedure :: return_beam_momenta => sf_chain_instance_return_beam_momenta
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_return_beam_momenta (chain)
       class(sf_chain_instance_t), intent(in), target :: chain
       type(interaction_t), pointer :: int
     end subroutine sf_chain_instance_return_beam_momenta
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_return_beam_momenta (chain)
     class(sf_chain_instance_t), intent(in), target :: chain
     type(interaction_t), pointer :: int
     if (chain%status >= SF_DONE_KINEMATICS) then
        int => beam_get_int_ptr (chain%beam_t)
        call int%send_momenta ()
     end if
   end subroutine sf_chain_instance_return_beam_momenta
 
 @ %def sf_chain_instance_return_beam_momenta
 @ Evaluate all interactions in the chain and the product evaluators.
 We provide a [[scale]] argument that is given to all structure
 functions in the chain.
 
 Hadronic NLO calculations involve rescaled fractions of the original beam
 momentum. In particular, we have to handle the following cases:
 \begin{itemize}
   \item normal evaluation (where [[i_sub = 0]]) for all terms except the
     real non-subtracted,
   \item rescaled momentum fraction for both beams in the case of the
     real non-subtracted term ([[i_sub = 0]]),
   \item and rescaled momentum fraction for one of both beams in the case of the
     subtraction and DGLAP component ([[i_sub = 1,2]]).
 \end{itemize}
 For the collinear final or initial state counter terms, we apply a rescaling to
 one beam, and keep the other beam as is. We redo it then vice versa having now two subtractions.
 <<SF base: sf chain instance: TBP>>=
   procedure :: evaluate => sf_chain_instance_evaluate
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_evaluate &
          (chain, scale, negative_sf, sf_rescale)
       class(sf_chain_instance_t), intent(inout), target :: chain
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(inout), optional :: sf_rescale
     end subroutine sf_chain_instance_evaluate
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_evaluate &
        (chain, scale, negative_sf, sf_rescale)
     class(sf_chain_instance_t), intent(inout), target :: chain
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(inout), optional :: sf_rescale
     type(interaction_t), pointer :: out_int
     real(default) :: sf_sum
     integer :: i_beam, i_sub, n_sub
     logical :: rescale
     n_sub = 0
     rescale = .false.; if (present (sf_rescale)) rescale = .true.
     if (rescale) then
        n_sub = chain%get_n_sub ()
     end if
     if (chain%status >= SF_DONE_KINEMATICS) then
        if (allocated (chain%sf)) then
           if (size (chain%sf) /= 0) then
              do i_beam = 1, size (chain%sf)
                 associate (sf => chain%sf(i_beam))
                    if (rescale) then
                       call sf_rescale%set_i_beam (i_beam)
                       do i_sub = 0, n_sub
                          select case (i_sub)
                          case (0)
                             if (n_sub == 0) then
                                call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub)
                             else
                                call sf%int%apply (scale, negative_sf, i_sub = i_sub)
                             end if
                          case default
                             if (i_beam == i_sub) then
                                call sf%int%apply (scale, negative_sf, sf_rescale, i_sub = i_sub)
                             else
                                call sf%int%apply (scale, negative_sf, i_sub = i_sub)
                             end if
                          end select
                       end do
                    else
                       call sf%int%apply (scale, negative_sf, i_sub = n_sub)
                    end if
                    if (sf%int%status <= SF_FAILED_EVALUATION) then
                       chain%status = SF_FAILED_EVALUATION
                       return
                    end if
                    if (.not. sf%eval%is_empty ())  call sf%eval%evaluate ()
                 end associate
              end do
              out_int => chain%get_out_int_ptr ()
              sf_sum = real (out_int%sum ())
              call chain%config%trace &
                   (chain%selected_channel, chain%p, chain%x, chain%f, sf_sum)
           end if
        end if
        chain%status = SF_EVALUATED
     end if
   end subroutine sf_chain_instance_evaluate
 
 @ %def sf_chain_instance_evaluate
 @
 \subsection{Access to the chain instance}
 Transfer the outgoing momenta to the array [[p]].  We assume that
 array sizes match.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_out_momenta => sf_chain_instance_get_out_momenta
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_get_out_momenta (chain, p)
       class(sf_chain_instance_t), intent(in), target :: chain
       type(vector4_t), dimension(:), intent(out) :: p
     end subroutine sf_chain_instance_get_out_momenta
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_get_out_momenta (chain, p)
     class(sf_chain_instance_t), intent(in), target :: chain
     type(vector4_t), dimension(:), intent(out) :: p
     type(interaction_t), pointer :: int
     integer :: i, j
     if (chain%status >= SF_DONE_KINEMATICS) then
        do j = 1, size (chain%out_sf)
           i = chain%out_sf(j)
           select case (i)
           case (0)
              int => beam_get_int_ptr (chain%beam_t)
           case default
              int => chain%sf(i)%int%interaction_t
           end select
           p(j) = int%get_momentum (chain%out_sf_i(j))
        end do
     end if
   end subroutine sf_chain_instance_get_out_momenta
 
 @ %def sf_chain_instance_get_out_momenta
 @ Return a pointer to the last evaluator in the chain (to the interaction).
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_out_int_ptr => sf_chain_instance_get_out_int_ptr
 <<SF base: sub interfaces>>=
     module function sf_chain_instance_get_out_int_ptr (chain) result (int)
       class(sf_chain_instance_t), intent(in), target :: chain
       type(interaction_t), pointer :: int
     end function sf_chain_instance_get_out_int_ptr
 <<SF base: procedures>>=
   module function sf_chain_instance_get_out_int_ptr (chain) result (int)
     class(sf_chain_instance_t), intent(in), target :: chain
     type(interaction_t), pointer :: int
     if (chain%out_eval == 0) then
        int => beam_get_int_ptr (chain%beam_t)
     else
        int => chain%sf(chain%out_eval)%eval%interaction_t
     end if
   end function sf_chain_instance_get_out_int_ptr
 
 @ %def sf_chain_instance_get_out_int_ptr
 @ Return the index of the [[j]]-th outgoing particle, within the last
 evaluator.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_out_i => sf_chain_instance_get_out_i
 <<SF base: sub interfaces>>=
     module function sf_chain_instance_get_out_i (chain, j) result (i)
       class(sf_chain_instance_t), intent(in) :: chain
       integer, intent(in) :: j
       integer :: i
     end function sf_chain_instance_get_out_i
 <<SF base: procedures>>=
   module function sf_chain_instance_get_out_i (chain, j) result (i)
     class(sf_chain_instance_t), intent(in) :: chain
     integer, intent(in) :: j
     integer :: i
     i = chain%out_eval_i(j)
   end function sf_chain_instance_get_out_i
 
 @ %def sf_chain_instance_get_out_i
 @ Return the mask for the outgoing particle(s), within the last evaluator.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_out_mask => sf_chain_instance_get_out_mask
 <<SF base: sub interfaces>>=
     module function sf_chain_instance_get_out_mask (chain) result (mask)
       class(sf_chain_instance_t), intent(in), target :: chain
       type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
     end function sf_chain_instance_get_out_mask
 <<SF base: procedures>>=
   module function sf_chain_instance_get_out_mask (chain) result (mask)
     class(sf_chain_instance_t), intent(in), target :: chain
     type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
     type(interaction_t), pointer :: int
     allocate (mask (chain%config%n_in))
     int => chain%get_out_int_ptr ()
     mask = int%get_mask (chain%out_eval_i)
   end function sf_chain_instance_get_out_mask
 
 @ %def sf_chain_instance_get_out_mask
 @ Return the array of MC input parameters that corresponds to channel [[c]].
 This is the [[p]] array, the parameters before all mappings.
 
 The [[p]] array may be deallocated.  This should correspond to a
 zero-size [[r]] argument, so nothing to do then.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_mcpar => sf_chain_instance_get_mcpar
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_get_mcpar (chain, c, r)
       class(sf_chain_instance_t), intent(in) :: chain
       integer, intent(in) :: c
       real(default), dimension(:), intent(out) :: r
     end subroutine sf_chain_instance_get_mcpar
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_get_mcpar (chain, c, r)
     class(sf_chain_instance_t), intent(in) :: chain
     integer, intent(in) :: c
     real(default), dimension(:), intent(out) :: r
     if (allocated (chain%p))  r = pack (chain%p(:,c), chain%bound)
   end subroutine sf_chain_instance_get_mcpar
 
 @ %def sf_chain_instance_get_mcpar
 @ Return the Jacobian factor that corresponds to channel [[c]].
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_f => sf_chain_instance_get_f
 <<SF base: sub interfaces>>=
     module function sf_chain_instance_get_f (chain, c) result (f)
       class(sf_chain_instance_t), intent(in) :: chain
       integer, intent(in) :: c
       real(default) :: f
     end function sf_chain_instance_get_f
 <<SF base: procedures>>=
   module function sf_chain_instance_get_f (chain, c) result (f)
     class(sf_chain_instance_t), intent(in) :: chain
     integer, intent(in) :: c
     real(default) :: f
     if (allocated (chain%f)) then
        f = chain%f(c)
     else
        f = 1
     end if
   end function sf_chain_instance_get_f
 
 @ %def sf_chain_instance_get_f
 @ Return the evaluation status.
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_status => sf_chain_instance_get_status
 <<SF base: sub interfaces>>=
     module function sf_chain_instance_get_status (chain) result (status)
       class(sf_chain_instance_t), intent(in) :: chain
       integer :: status
     end function sf_chain_instance_get_status
 <<SF base: procedures>>=
   module function sf_chain_instance_get_status (chain) result (status)
     class(sf_chain_instance_t), intent(in) :: chain
     integer :: status
     status = chain%status
   end function sf_chain_instance_get_status
 
 @ %def sf_chain_instance_get_status
 @
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_matrix_elements => sf_chain_instance_get_matrix_elements
 <<SF base: sub interfaces>>=
     module subroutine sf_chain_instance_get_matrix_elements (chain, i, ff)
        class(sf_chain_instance_t), intent(in) :: chain
        integer, intent(in) :: i
        real(default), intent(out), dimension(:), allocatable :: ff
     end subroutine sf_chain_instance_get_matrix_elements
 <<SF base: procedures>>=
   module subroutine sf_chain_instance_get_matrix_elements (chain, i, ff)
      class(sf_chain_instance_t), intent(in) :: chain
      integer, intent(in) :: i
      real(default), intent(out), dimension(:), allocatable :: ff
 
      associate (sf => chain%sf(i))
         ff = real (sf%int%get_matrix_element ())
      end associate
   end subroutine sf_chain_instance_get_matrix_elements
 
 @ %def sf_chain_instance_get_matrix_elements
 @
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_beam_int_ptr => sf_chain_instance_get_beam_int_ptr
 <<SF base: sub interfaces>>=
     module function sf_chain_instance_get_beam_int_ptr (chain) result (int)
       type(interaction_t), pointer :: int
       class(sf_chain_instance_t), intent(in), target :: chain
     end function sf_chain_instance_get_beam_int_ptr
 <<SF base: procedures>>=
   module function sf_chain_instance_get_beam_int_ptr (chain) result (int)
     type(interaction_t), pointer :: int
     class(sf_chain_instance_t), intent(in), target :: chain
     int => beam_get_int_ptr (chain%beam_t)
   end function sf_chain_instance_get_beam_int_ptr
 
 @ %def sf_chain_instance_get_beam_ptr
 @
 <<SF base: sf chain instance: TBP>>=
   procedure :: get_n_sub => sf_chain_instance_get_n_sub
 <<SF base: sub interfaces>>=
     module function sf_chain_instance_get_n_sub (chain) result (n_sub)
       type(interaction_t), pointer :: int
       class(sf_chain_instance_t), intent(in), target :: chain
       integer :: n_sub
     end function sf_chain_instance_get_n_sub
 <<SF base: procedures>>=
   module function sf_chain_instance_get_n_sub (chain) result (n_sub)
     type(interaction_t), pointer :: int
     class(sf_chain_instance_t), intent(in), target :: chain
     integer :: n_sub
     int => beam_get_int_ptr (chain%beam_t)
     n_sub = int%get_n_sub ()
   end function sf_chain_instance_get_n_sub
 
 @ %def sf_chain_instance_get_n_sub
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_base_ut.f90]]>>=
 <<File header>>
 
 module sf_base_ut
   use unit_tests
   use sf_base_uti
 
 <<Standard module head>>
 
 <<SF base: public test auxiliary>>
 
 <<SF base: public test>>
 
 contains
 
 <<SF base: test driver>>
 
 end module sf_base_ut
 @ %def sf_base_ut
 @
 <<[[sf_base_uti.f90]]>>=
 <<File header>>
 
 module sf_base_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_19
   use format_utils, only: write_separator
   use diagnostics
   use lorentz
   use pdg_arrays
   use flavors
   use colors
   use helicities
   use quantum_numbers
   use state_matrices, only: FM_IGNORE_HELICITY
   use interactions
   use particles
   use model_data
   use beams
   use sf_aux
   use sf_mappings
 
   use sf_base
 
 <<Standard module head>>
 
 <<SF base: test declarations>>
 
 <<SF base: public test auxiliary>>
 
 <<SF base: test types>>
 
 contains
 
 <<SF base: tests>>
 
 <<SF base: test auxiliary>>
 
 end module sf_base_uti
 @ %def sf_base_ut
 @ API: driver for the unit tests below.
 <<SF base: public test>>=
   public :: sf_base_test
 <<SF base: test driver>>=
   subroutine sf_base_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF base: execute tests>>
   end subroutine sf_base_test
 
 @ %def sf_base_test
 @
 \subsection{Test implementation: structure function}
 This is a template for the actual structure-function implementation
 which will be defined in separate modules.
 
 \subsubsection{Configuration data}
 The test structure function uses the [[Test]] model.  It describes a
 scalar within an arbitrary initial particle, which is given in the
 initialization.  The radiated particle is also a scalar, the same one,
 but we set its mass artificially to zero.
 <<SF base: public test auxiliary>>=
   public :: sf_test_data_t
 <<SF base: test types>>=
   type, extends (sf_data_t) :: sf_test_data_t
      class(model_data_t), pointer :: model => null ()
      integer :: mode = 0
      type(flavor_t) :: flv_in
      type(flavor_t) :: flv_out
      type(flavor_t) :: flv_rad
      real(default) :: m = 0
      logical :: collinear = .true.
      real(default), dimension(:), allocatable :: qbounds
    contains
    <<SF base: sf test data: TBP>>
   end type sf_test_data_t
 
 @ %def sf_test_data_t
 @ Output.
 <<SF base: sf test data: TBP>>=
   procedure :: write => sf_test_data_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_data_write (data, unit, verbose)
     class(sf_test_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "SF test data:"
     write (u, "(3x,A,A)") "model     = ", char (data%model%get_name ())
     write (u, "(3x,A)", advance="no") "incoming  = "
     call data%flv_in%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "outgoing  = "
     call data%flv_out%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "radiated  = "
     call data%flv_rad%write (u);  write (u, *)
     write (u, "(3x,A," // FMT_19 // ")")  "mass      = ", data%m
     write (u, "(3x,A,L1)")  "collinear = ", data%collinear
     if (.not. data%collinear .and. allocated (data%qbounds)) then
        write (u, "(3x,A," // FMT_19 // ")")  "qmin      = ", data%qbounds(1)
        write (u, "(3x,A," // FMT_19 // ")")  "qmax      = ", data%qbounds(2)
     end if
   end subroutine sf_test_data_write
 
 @ %def sf_test_data_write
 @ Initialization.
 <<SF base: sf test data: TBP>>=
   procedure :: init => sf_test_data_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_data_init (data, model, pdg_in, collinear, qbounds, mode)
     class(sf_test_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     logical, intent(in), optional :: collinear
     real(default), dimension(2), intent(in), optional :: qbounds
     integer, intent(in), optional :: mode
     data%model => model
     if (present (mode))  data%mode = mode
     if (pdg_in%get (1) /= 25) then
        call msg_fatal ("Test spectrum function: input flavor must be 's'")
     end if
     call data%flv_in%init (25, model)
     data%m = data%flv_in%get_mass ()
     if (present (collinear))  data%collinear = collinear
     call data%flv_out%init (25, model)
     call data%flv_rad%init (25, model)
     if (present (qbounds)) then
        allocate (data%qbounds (2))
        data%qbounds = qbounds
     end if
   end subroutine sf_test_data_init
 
 @ %def sf_test_data_init
 @ Return the number of parameters: 1 if only consider collinear
 splitting, 3 otherwise.
 <<SF base: sf test data: TBP>>=
   procedure :: get_n_par => sf_test_data_get_n_par
 <<SF base: test auxiliary>>=
   function sf_test_data_get_n_par (data) result (n)
     class(sf_test_data_t), intent(in) :: data
     integer :: n
     if (data%collinear) then
        n = 1
     else
        n = 3
     end if
   end function sf_test_data_get_n_par
 
 @ %def sf_test_data_get_n_par
 @ Return the outgoing particle PDG code: 25
 <<SF base: sf test data: TBP>>=
   procedure :: get_pdg_out => sf_test_data_get_pdg_out
 <<SF base: test auxiliary>>=
   subroutine sf_test_data_get_pdg_out (data, pdg_out)
     class(sf_test_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = 25
   end subroutine sf_test_data_get_pdg_out
 
 @ %def sf_test_data_get_pdg_out
 @ Allocate the matching interaction.
 <<SF base: sf test data: TBP>>=
   procedure :: allocate_sf_int => sf_test_data_allocate_sf_int
 <<SF base: test auxiliary>>=
   subroutine sf_test_data_allocate_sf_int (data, sf_int)
     class(sf_test_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     if (allocated (sf_int)) deallocate (sf_int)
     allocate (sf_test_t :: sf_int)
   end subroutine sf_test_data_allocate_sf_int
 
 @ %def sf_test_data_allocate_sf_int
 @
 \subsubsection{Interaction}
 <<SF base: test types>>=
   type, extends (sf_int_t) :: sf_test_t
      type(sf_test_data_t), pointer :: data => null ()
      real(default) :: x = 0
    contains
    <<SF base: sf test int: TBP>>
   end type sf_test_t
 
 @ %def sf_test_t
 @ Type string: constant
 <<SF base: sf test int: TBP>>=
   procedure :: type_string => sf_test_type_string
 <<SF base: test auxiliary>>=
   function sf_test_type_string (object) result (string)
     class(sf_test_t), intent(in) :: object
     type(string_t) :: string
     string = "Test"
   end function sf_test_type_string
 
 @ %def sf_test_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF base: sf test int: TBP>>=
   procedure :: write => sf_test_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_write (object, unit, testflag)
     class(sf_test_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "SF test data: [undefined]"
     end if
   end subroutine sf_test_write
 
 @ %def sf_test_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_test_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass, but keep the radiated mass zero.
 
 Optionally, we can provide minimum and maximum values for the momentum
 transfer.
 <<SF base: sf test int: TBP>>=
   procedure :: init => sf_test_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_init (sf_int, data)
     class(sf_test_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     type(helicity_t) :: hel0
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(3) :: qn
     mask = quantum_numbers_mask (.false., .false., .false.)
     select type (data)
     type is (sf_test_data_t)
        if (allocated (data%qbounds)) then
           call sf_int%base_init (mask, &
                [data%m**2], [0._default], [data%m**2], &
                [data%qbounds(1)], [data%qbounds(2)])
        else
           call sf_int%base_init (mask, &
                [data%m**2], [0._default], [data%m**2])
        end if
        sf_int%data => data
        call hel0%init (0)
        call col0%init ()
        call qn(1)%init (data%flv_in,  col0, hel0)
        call qn(2)%init (data%flv_rad, col0, hel0)
        call qn(3)%init (data%flv_out, col0, hel0)
        call sf_int%add_state (qn)
        call sf_int%freeze ()
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
     end select
     sf_int%status = SF_INITIAL
   end subroutine sf_test_init
 
 @ %def sf_test_init
 @ Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 If [[map]] is set, we are asked to provide an efficient mapping.
 For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
 <<SF base: sf test int: TBP>>=
   procedure :: complete_kinematics => sf_test_complete_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(sf_test_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        x(1) = r(1)**2
        f = 2 * r(1)
     else
        x(1) = r(1)
        f = 1
     end if
     xb(1) = 1 - x(1)
     if (size (x) == 3) then
        x(2:3)  = r(2:3)
        xb(2:3) = rb(2:3)
     end if
     call sf_int%split_momentum (x, xb)
     sf_int%x = x(1)
     select case (sf_int%status)
     case (SF_FAILED_KINEMATICS);  f = 0
     end select
   end subroutine sf_test_complete_kinematics
 
 @ %def sf_test_complete_kinematics
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF base: sf test int: TBP>>=
   procedure :: inverse_kinematics => sf_test_inverse_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_inverse_kinematics (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(sf_test_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        r(1) = sqrt (x(1))
        f = 2 * r(1)
     else
        r(1) = x(1)
        f = 1
     end if
     if (size (x) == 3)  r(2:3) = x(2:3)
     rb = 1 - r
     sf_int%x = x(1)
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine sf_test_inverse_kinematics
 
 @ %def sf_test_inverse_kinematics
 @ Apply the structure function.  The matrix element becomes unity and
 the application always succeeds.
 
 If the [[mode]] indicator is one, the matrix element is equal to the
 parameter~$x$.
 <<SF base: sf test int: TBP>>=
   procedure :: apply => sf_test_apply
 <<SF base: test auxiliary>>=
   subroutine sf_test_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(sf_test_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     select case (sf_int%data%mode)
     case (0)
        call sf_int%set_matrix_element &
             (cmplx (1._default, kind=default))
     case (1)
        call sf_int%set_matrix_element &
             (cmplx (sf_int%x, kind=default))
     end select
     sf_int%status = SF_EVALUATED
   end subroutine sf_test_apply
 
 @ %def sf_test_apply
 @
 \subsection{Test implementation: pair spectrum}
 Another template, this time for a incoming particle pair, splitting
 into two radiated and two outgoing particles.
 
 \subsubsection{Configuration data}
 For simplicity, the spectrum contains two mirror images of the
 previous structure-function configuration: the incoming and all
 outgoing particles are test scalars.
 
 We have two versions, one with radiated particles, one without.
 <<SF base: test types>>=
   type, extends (sf_data_t) :: sf_test_spectrum_data_t
      class(model_data_t), pointer :: model => null ()
      type(flavor_t) :: flv_in
      type(flavor_t) :: flv_out
      type(flavor_t) :: flv_rad
      logical :: with_radiation = .true.
      real(default) :: m = 0
    contains
    <<SF base: sf test spectrum data: TBP>>
   end type sf_test_spectrum_data_t
 
 @ %def sf_test_spectrum_data_t
 @ Output.
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: write => sf_test_spectrum_data_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_data_write (data, unit, verbose)
     class(sf_test_spectrum_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "SF test spectrum data:"
     write (u, "(3x,A,A)") "model     = ", char (data%model%get_name ())
     write (u, "(3x,A)", advance="no") "incoming  = "
     call data%flv_in%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "outgoing  = "
     call data%flv_out%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "radiated  = "
     call data%flv_rad%write (u);  write (u, *)
     write (u, "(3x,A," // FMT_19 // ")")  "mass      = ", data%m
   end subroutine sf_test_spectrum_data_write
 
 @ %def sf_test_spectrum_data_write
 @ Initialization.
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: init => sf_test_spectrum_data_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_data_init (data, model, pdg_in, with_radiation)
     class(sf_test_spectrum_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     logical, intent(in) :: with_radiation
     data%model => model
     data%with_radiation = with_radiation
     if (pdg_in%get (1) /= 25) then
        call msg_fatal ("Test structure function: input flavor must be 's'")
     end if
     call data%flv_in%init (25, model)
     data%m = data%flv_in%get_mass ()
     call data%flv_out%init (25, model)
     if (with_radiation) then
        call data%flv_rad%init (25, model)
     end if
   end subroutine sf_test_spectrum_data_init
 
 @ %def sf_test_spectrum_data_init
 @ Return the number of parameters: 2, since we have only collinear
 splitting here.
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: get_n_par => sf_test_spectrum_data_get_n_par
 <<SF base: test auxiliary>>=
   function sf_test_spectrum_data_get_n_par (data) result (n)
     class(sf_test_spectrum_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function sf_test_spectrum_data_get_n_par
 
 @ %def sf_test_spectrum_data_get_n_par
 @ Return the outgoing particle PDG codes: 25
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: get_pdg_out => sf_test_spectrum_data_get_pdg_out
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_data_get_pdg_out (data, pdg_out)
     class(sf_test_spectrum_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = 25
     pdg_out(2) = 25
   end subroutine sf_test_spectrum_data_get_pdg_out
 
 @ %def sf_test_spectrum_data_get_pdg_out
 @ Allocate the matching interaction.
 <<SF base: sf test spectrum data: TBP>>=
   procedure :: allocate_sf_int => &
        sf_test_spectrum_data_allocate_sf_int
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_data_allocate_sf_int (data, sf_int)
     class(sf_test_spectrum_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (sf_test_spectrum_t :: sf_int)
   end subroutine sf_test_spectrum_data_allocate_sf_int
 
 @ %def sf_test_spectrum_data_allocate_sf_int
 @
 \subsubsection{Interaction}
 <<SF base: test types>>=
   type, extends (sf_int_t) :: sf_test_spectrum_t
      type(sf_test_spectrum_data_t), pointer :: data => null ()
    contains
    <<SF base: sf test spectrum: TBP>>
   end type sf_test_spectrum_t
 
 @ %def sf_test_spectrum_t
 <<SF base: sf test spectrum: TBP>>=
   procedure :: type_string => sf_test_spectrum_type_string
 <<SF base: test auxiliary>>=
   function sf_test_spectrum_type_string (object) result (string)
     class(sf_test_spectrum_t), intent(in) :: object
     type(string_t) :: string
     string = "Test Spectrum"
   end function sf_test_spectrum_type_string
 
 @ %def sf_test_spectrum_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF base: sf test spectrum: TBP>>=
   procedure :: write => sf_test_spectrum_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_write (object, unit, testflag)
     class(sf_test_spectrum_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "SF test spectrum data: [undefined]"
     end if
   end subroutine sf_test_spectrum_write
 
 @ %def sf_test_spectrum_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_test_spectrum_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass, but keep the radiated mass zero.
 
 Optionally, we can provide minimum and maximum values for the momentum
 transfer.
 <<SF base: sf test spectrum: TBP>>=
   procedure :: init => sf_test_spectrum_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_init (sf_int, data)
     class(sf_test_spectrum_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(6) :: mask
     type(helicity_t) :: hel0
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(6) :: qn
     mask = quantum_numbers_mask (.false., .false., .false.)
     select type (data)
     type is (sf_test_spectrum_data_t)
        if (data%with_radiation) then
           call sf_int%base_init (mask(1:6), &
                [data%m**2, data%m**2], &
                [0._default, 0._default], &
                [data%m**2, data%m**2])
           sf_int%data => data
           call hel0%init (0)
           call col0%init ()
           call qn(1)%init (data%flv_in,  col0, hel0)
           call qn(2)%init (data%flv_in,  col0, hel0)
           call qn(3)%init (data%flv_rad, col0, hel0)
           call qn(4)%init (data%flv_rad, col0, hel0)
           call qn(5)%init (data%flv_out, col0, hel0)
           call qn(6)%init (data%flv_out, col0, hel0)
           call sf_int%add_state (qn(1:6))
           call sf_int%set_incoming ([1,2])
           call sf_int%set_radiated ([3,4])
           call sf_int%set_outgoing ([5,6])
        else
           call sf_int%base_init (mask(1:4), &
                [data%m**2, data%m**2], &
                [real(default) :: ], &
                [data%m**2, data%m**2])
           sf_int%data => data
           call hel0%init (0)
           call col0%init ()
           call qn(1)%init (data%flv_in,  col0, hel0)
           call qn(2)%init (data%flv_in,  col0, hel0)
           call qn(3)%init (data%flv_out, col0, hel0)
           call qn(4)%init (data%flv_out, col0, hel0)
           call sf_int%add_state (qn(1:4))
           call sf_int%set_incoming ([1,2])
           call sf_int%set_outgoing ([3,4])
        end if
        call sf_int%freeze ()
     end select
     sf_int%status = SF_INITIAL
   end subroutine sf_test_spectrum_init
 
 @ %def sf_test_spectrum_init
 @ Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 If [[map]] is set, we are asked to provide an efficient mapping.
 For the test case, we set $x=r^2$ (as above) for both $x$ parameters
 and consequently $f(r)=4r_1r_2$.
 
 <<SF base: sf test spectrum: TBP>>=
   procedure :: complete_kinematics => sf_test_spectrum_complete_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(sf_test_spectrum_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     real(default), dimension(2) :: xb1
     if (map) then
        x = r**2
        f = 4 * r(1) * r(2)
     else
        x = r
        f = 1
     end if
     xb = 1 - x
     if (sf_int%data%with_radiation) then
        call sf_int%split_momenta (x, xb)
     else
        call sf_int%reduce_momenta (x)
     end if
     select case (sf_int%status)
     case (SF_FAILED_KINEMATICS);  f = 0
     end select
   end subroutine sf_test_spectrum_complete_kinematics
 
 @ %def sf_test_spectrum_complete_kinematics
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF base: sf test spectrum: TBP>>=
   procedure :: inverse_kinematics => sf_test_spectrum_inverse_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(sf_test_spectrum_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
      real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default), dimension(2) :: xb1
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        r = sqrt (x)
        f = 4 * r(1) * r(2)
     else
        r = x
        f = 1
     end if
     rb = 1 - r
     if (set_mom)  then
        if (sf_int%data%with_radiation) then
           call sf_int%split_momenta (x, xb)
        else
           call sf_int%reduce_momenta (x)
        end if
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine sf_test_spectrum_inverse_kinematics
 
 @ %def sf_test_spectrum_inverse_kinematics
 @ Apply the structure function.  The matrix element becomes unity and
 the application always succeeds.
 <<SF base: sf test spectrum: TBP>>=
   procedure :: apply => sf_test_spectrum_apply
 <<SF base: test auxiliary>>=
   subroutine sf_test_spectrum_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(sf_test_spectrum_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     call sf_int%set_matrix_element &
          (cmplx (1._default, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine sf_test_spectrum_apply
 
 @ %def sf_test_spectrum_apply
 @
 \subsection{Test implementation: generator spectrum}
 A generator for two beams, no radiation (for simplicity).
 
 \subsubsection{Configuration data}
 For simplicity, the spectrum contains two mirror images of the
 previous structure-function configuration: the incoming and all
 outgoing particles are test scalars.
 
 We have two versions, one with radiated particles, one without.
 <<SF base: test types>>=
   type, extends (sf_data_t) :: sf_test_generator_data_t
      class(model_data_t), pointer :: model => null ()
      type(flavor_t) :: flv_in
      type(flavor_t) :: flv_out
      type(flavor_t) :: flv_rad
      real(default) :: m = 0
    contains
    <<SF base: sf test generator data: TBP>>
   end type sf_test_generator_data_t
 
 @ %def sf_test_generator_data_t
 @ Output.
 <<SF base: sf test generator data: TBP>>=
   procedure :: write => sf_test_generator_data_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_data_write (data, unit, verbose)
     class(sf_test_generator_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit)
     write (u, "(1x,A)")  "SF test generator data:"
     write (u, "(3x,A,A)") "model     = ", char (data%model%get_name ())
     write (u, "(3x,A)", advance="no") "incoming  = "
     call data%flv_in%write (u);  write (u, *)
     write (u, "(3x,A)", advance="no") "outgoing  = "
     call data%flv_out%write (u);  write (u, *)
     write (u, "(3x,A," // FMT_19 // ")")  "mass      = ", data%m
   end subroutine sf_test_generator_data_write
 
 @ %def sf_test_generator_data_write
 @ Initialization.
 <<SF base: sf test generator data: TBP>>=
   procedure :: init => sf_test_generator_data_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_data_init (data, model, pdg_in)
     class(sf_test_generator_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     data%model => model
     if (pdg_in%get (1) /= 25) then
        call msg_fatal ("Test generator: input flavor must be 's'")
     end if
     call data%flv_in%init (25, model)
     data%m = data%flv_in%get_mass ()
     call data%flv_out%init (25, model)
   end subroutine sf_test_generator_data_init
 
 @ %def sf_test_generator_data_init
 @ This structure function is a generator.
 <<SF base: sf test generator data: TBP>>=
   procedure :: is_generator => sf_test_generator_data_is_generator
 <<SF base: test auxiliary>>=
   function sf_test_generator_data_is_generator (data) result (flag)
     class(sf_test_generator_data_t), intent(in) :: data
     logical :: flag
     flag = .true.
   end function sf_test_generator_data_is_generator
 
 @ %def sf_test_generator_data_is_generator
 @ Return the number of parameters: 2, since we have only collinear
 splitting here.
 <<SF base: sf test generator data: TBP>>=
   procedure :: get_n_par => sf_test_generator_data_get_n_par
 <<SF base: test auxiliary>>=
   function sf_test_generator_data_get_n_par (data) result (n)
     class(sf_test_generator_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function sf_test_generator_data_get_n_par
 
 @ %def sf_test_generator_data_get_n_par
 @ Return the outgoing particle PDG codes: 25
 <<SF base: sf test generator data: TBP>>=
   procedure :: get_pdg_out => sf_test_generator_data_get_pdg_out
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_data_get_pdg_out (data, pdg_out)
     class(sf_test_generator_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = 25
     pdg_out(2) = 25
   end subroutine sf_test_generator_data_get_pdg_out
 
 @ %def sf_test_generator_data_get_pdg_out
 @ Allocate the matching interaction.
 <<SF base: sf test generator data: TBP>>=
   procedure :: allocate_sf_int => &
        sf_test_generator_data_allocate_sf_int
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_data_allocate_sf_int (data, sf_int)
     class(sf_test_generator_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (sf_test_generator_t :: sf_int)
   end subroutine sf_test_generator_data_allocate_sf_int
 
 @ %def sf_test_generator_data_allocate_sf_int
 @
 \subsubsection{Interaction}
 <<SF base: test types>>=
   type, extends (sf_int_t) :: sf_test_generator_t
      type(sf_test_generator_data_t), pointer :: data => null ()
    contains
    <<SF base: sf test generator: TBP>>
   end type sf_test_generator_t
 
 @ %def sf_test_generator_t
 <<SF base: sf test generator: TBP>>=
   procedure :: type_string => sf_test_generator_type_string
 <<SF base: test auxiliary>>=
   function sf_test_generator_type_string (object) result (string)
     class(sf_test_generator_t), intent(in) :: object
     type(string_t) :: string
     string = "Test Generator"
   end function sf_test_generator_type_string
 
 @ %def sf_test_generator_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF base: sf test generator: TBP>>=
   procedure :: write => sf_test_generator_write
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_write (object, unit, testflag)
     class(sf_test_generator_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "SF test generator data: [undefined]"
     end if
   end subroutine sf_test_generator_write
 
 @ %def sf_test_generator_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_test_generator_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass.  No radiation.
 <<SF base: sf test generator: TBP>>=
   procedure :: init => sf_test_generator_init
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_init (sf_int, data)
     class(sf_test_generator_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(4) :: mask
     type(helicity_t) :: hel0
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(4) :: qn
     mask = quantum_numbers_mask (.false., .false., .false.)
     select type (data)
     type is (sf_test_generator_data_t)
        call sf_int%base_init (mask(1:4), &
             [data%m**2, data%m**2], &
             [real(default) :: ], &
             [data%m**2, data%m**2])
        sf_int%data => data
        call hel0%init (0)
        call col0%init ()
        call qn(1)%init (data%flv_in,  col0, hel0)
        call qn(2)%init (data%flv_in,  col0, hel0)
        call qn(3)%init (data%flv_out, col0, hel0)
        call qn(4)%init (data%flv_out, col0, hel0)
        call sf_int%add_state (qn(1:4))
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        call sf_int%freeze ()
     end select
     sf_int%status = SF_INITIAL
   end subroutine sf_test_generator_init
 
 @ %def sf_test_generator_init
 @ This structure function is a generator.
 <<SF base: sf test generator: TBP>>=
   procedure :: is_generator => sf_test_generator_is_generator
 <<SF base: test auxiliary>>=
   function sf_test_generator_is_generator (sf_int) result (flag)
     class(sf_test_generator_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function sf_test_generator_is_generator
 
 @ %def sf_test_generator_is_generator
 @ Generate free parameters.  This mock generator always produces the
 nubmers 0.8 and 0.5.
 <<SF base: sf test generator: TBP>>=
   procedure :: generate_free => sf_test_generator_generate_free
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_generate_free (sf_int, r, rb,  x_free)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     r = [0.8, 0.5]
     rb= 1 - r
     x_free = x_free * product (r)
   end subroutine sf_test_generator_generate_free
 
 @ %def sf_test_generator_generate_free
 @ Recover momentum fractions.  Since the x values are free, we also set the [[x_free]] parameter.
 <<SF base: sf test generator: TBP>>=
   procedure :: recover_x => sf_test_generator_recover_x
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_recover_x (sf_int, x, xb, x_free)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb)
     if (present (x_free))  x_free = x_free * product (x)
   end subroutine sf_test_generator_recover_x
 
 @ %def sf_test_generator_recover_x
 @ Set kinematics.  Since this is a generator, just transfer input to output.
 <<SF base: sf test generator: TBP>>=
   procedure :: complete_kinematics => sf_test_generator_complete_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     x = r
     xb= rb
     f = 1
     call sf_int%reduce_momenta (x)
   end subroutine sf_test_generator_complete_kinematics
 
 @ %def sf_test_generator_complete_kinematics
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF base: sf test generator: TBP>>=
   procedure :: inverse_kinematics => sf_test_generator_inverse_kinematics
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     r = x
     rb= xb
     f = 1
     if (set_mom)  call sf_int%reduce_momenta (x)
   end subroutine sf_test_generator_inverse_kinematics
 
 @ %def sf_test_generator_inverse_kinematics
 @ Apply the structure function.  The matrix element becomes unity and
 the application always succeeds.
 <<SF base: sf test generator: TBP>>=
   procedure :: apply => sf_test_generator_apply
 <<SF base: test auxiliary>>=
   subroutine sf_test_generator_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(sf_test_generator_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     call sf_int%set_matrix_element &
          (cmplx (1._default, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine sf_test_generator_apply
 
 @ %def sf_test_generator_apply
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF base: execute tests>>=
   call test (sf_base_1, "sf_base_1", &
        "structure function configuration", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_1
 <<SF base: tests>>=
   subroutine sf_base_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_base_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     call model%init_test ()
     pdg_in = 25
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle code:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_1"
 
   end subroutine sf_base_1
 
 @ %def sf_base_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the test
 structure function.
 <<SF base: execute tests>>=
   call test (sf_base_2, "sf_base_2", &
        "structure function instance", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_2
 <<SF base: tests>>=
   subroutine sf_base_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     pdg_in = 25
     call flv%init (25, model)
 
     call reset_interaction_counter ()
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=1"
     write (u, "(A)")
 
     r = 1
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics with mapping for r=0.8"
     write (u, "(A)")
 
     r = 0.8_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute inverse kinematics for x=0.64 and evaluate"
     write (u, "(A)")
 
     x = 0.64_default
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%apply (scale=0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_2"
 
   end subroutine sf_base_2
 
 @ %def sf_base_2
 @
 \subsubsection{Collinear kinematics}
 Scan over the possibilities for mass assignment and on-shell
 projections, collinear case.
 <<SF base: execute tests>>=
   call test (sf_base_3, "sf_base_3", &
        "alternatives for collinear kinematics", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_3
 <<SF base: tests>>=
   subroutine sf_base_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_3"
     write (u, "(A)")  "*   Purpose: check various kinematical setups"
     write (u, "(A)")  "*            for collinear structure-function splitting."
     write (u, "(A)")  "             (two masses equal, one zero)"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     pdg_in = 25
     call flv%init (25, model)
 
     call reset_interaction_counter ()
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%write (u)
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
 
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set radiated mass to zero"
 
     sf_int%mr2 = 0
     sf_int%mo2 = sf_int%mi2
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping energy"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping momentum"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set outgoing mass to zero"
 
     sf_int%mr2 = sf_int%mi2
     sf_int%mo2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping energy"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping momentum"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming mass to zero"
 
     k = vector4_moving (E, E, 3)
     call sf_int%seed_kinematics ([k])
 
     sf_int%mr2 = sf_int%mi2
     sf_int%mo2 = sf_int%mi2
     sf_int%mi2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping energy"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping momentum"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set all masses to zero"
 
     sf_int%mr2 = 0
     sf_int%mo2 = 0
     sf_int%mi2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping energy"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5, keeping momentum"
     write (u, "(A)")
 
     r = 0.5_default
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_3"
 
   end subroutine sf_base_3
 
 @ %def sf_base_3
 @
 \subsubsection{Non-collinear kinematics}
 Scan over the possibilities for mass assignment and on-shell
 projections, non-collinear case.
 <<SF base: execute tests>>=
   call test (sf_base_4, "sf_base_4", &
        "alternatives for non-collinear kinematics", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_4
 <<SF base: tests>>=
   subroutine sf_base_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_4"
     write (u, "(A)")  "*   Purpose: check various kinematical setups"
     write (u, "(A)")  "*            for free structure-function splitting."
     write (u, "(A)")  "             (two masses equal, one zero)"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     pdg_in = 25
     call flv%init (25, model)
 
     call reset_interaction_counter ()
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in, collinear=.false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%write (u)
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
 
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set radiated mass to zero"
 
     sf_int%mr2 = 0
     sf_int%mo2 = sf_int%mi2
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set outgoing mass to zero"
 
     sf_int%mr2 = sf_int%mi2
     sf_int%mo2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set incoming mass to zero"
 
     k = vector4_moving (E, E, 3)
     call sf_int%seed_kinematics ([k])
 
     sf_int%mr2 = sf_int%mi2
     sf_int%mo2 = sf_int%mi2
     sf_int%mi2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set all masses to zero"
 
     sf_int%mr2 = 0
     sf_int%mo2 = 0
     sf_int%mi2 = 0
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-Initialize structure-function object with Q bounds"
 
     call reset_interaction_counter ()
 
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in, collinear=.false., &
             qbounds = [1._default, 100._default])
     end select
 
     call sf_int%init (data)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping energy"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.125, keeping momentum"
     write (u, "(A)")
 
     r = [0.5_default, 0.5_default, 0.125_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_MOMENTUM
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_4"
 
   end subroutine sf_base_4
 
 @ %def sf_base_4
 @
 \subsubsection{Pair spectrum}
 Construct and display a structure function object for a pair spectrum
 (a structure function involving two particles simultaneously).
 <<SF base: execute tests>>=
   call test (sf_base_5, "sf_base_5", &
        "pair spectrum with radiation", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_5
 <<SF base: tests>>=
   subroutine sf_base_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(4) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_5"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &a pair spectrum object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     allocate (sf_test_spectrum_data_t :: data)
     select type (data)
     type is (sf_test_spectrum_data_t)
        call data%init (model, pdg_in, with_radiation=.true.)
     end select
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize spectrum object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momenta with sqrts=1000"
 
     E = 500
     k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.4,0.8"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.4_default, 0.8_default]
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics with mapping for r=0.6,0.8"
     write (u, "(A)")
 
     r = [0.6_default, 0.8_default]
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call reset_interaction_counter ()
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%seed_kinematics (k)
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute inverse kinematics for x=0.36,0.64 &
          &and evaluate"
     write (u, "(A)")
 
     x = [0.36_default, 0.64_default]
     xb = 1 - x
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%apply (scale=0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_5"
 
   end subroutine sf_base_5
 
 @ %def sf_base_5
 @
 \subsubsection{Pair spectrum without radiation}
 Construct and display a structure function object for a pair spectrum
 (a structure function involving two particles simultaneously).
 <<SF base: execute tests>>=
   call test (sf_base_6, "sf_base_6", &
        "pair spectrum without radiation", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_6
 <<SF base: tests>>=
   subroutine sf_base_6 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_base_6"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &a pair spectrum object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     allocate (sf_test_spectrum_data_t :: data)
     select type (data)
     type is (sf_test_spectrum_data_t)
        call data%init (model, pdg_in, with_radiation=.false.)
     end select
 
     write (u, "(A)")  "* Initialize spectrum object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     write (u, "(A)")  "* Initialize incoming momenta with sqrts=1000"
 
     E = 500
     k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.4,0.8"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.4_default, 0.8_default]
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call reset_interaction_counter ()
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%seed_kinematics (k)
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute inverse kinematics for x=0.4,0.8 &
          &and evaluate"
     write (u, "(A)")
 
     x = [0.4_default, 0.8_default]
     xb = 1 - x
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale=0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_6"
 
   end subroutine sf_base_6
 
 @ %def sf_base_6
 @
 \subsubsection{Direct access to structure function}
 Probe a structure function directly.
 <<SF base: execute tests>>=
   call test (sf_base_7, "sf_base_7", &
        "direct access", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_7
 <<SF base: tests>>=
   subroutine sf_base_7 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     real(default), dimension(:), allocatable :: value
 
     write (u, "(A)")  "* Test output: sf_base_7"
     write (u, "(A)")  "*   Purpose: check direct access method"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     write (u, "(A)")  "* Probe structure function: states"
     write (u, "(A)")
 
     write (u, "(A,I0)")  "n_states = ", sf_int%get_n_states ()
     write (u, "(A,I0)")  "n_in     = ", sf_int%get_n_in ()
     write (u, "(A,I0)")  "n_rad    = ", sf_int%get_n_rad ()
     write (u, "(A,I0)")  "n_out    = ", sf_int%get_n_out ()
     write (u, "(A)")
     write (u, "(A)", advance="no")  "state(1)  = "
     call quantum_numbers_write (sf_int%get_state (1), u)
     write (u, *)
 
     allocate (value (sf_int%get_n_states ()))
     call sf_int%compute_values (value, &
          E=[500._default], x=[0.5_default], xb=[0.5_default], scale=0._default)
 
     write (u, "(A)")
     write (u, "(A)", advance="no")  "value (E=500, x=0.5) ="
     write (u, "(9(1x," // FMT_19 // "))")  value
 
     call sf_int%compute_values (value, &
          x=[0.1_default], xb=[0.9_default], scale=0._default)
 
     write (u, "(A)")
     write (u, "(A)", advance="no")  "value (E=500, x=0.1) ="
     write (u, "(9(1x," // FMT_19 // "))")  value
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize spectrum object"
     write (u, "(A)")
 
     deallocate (value)
     call sf_int%final ()
     deallocate (sf_int)
     deallocate (data)
 
     allocate (sf_test_spectrum_data_t :: data)
     select type (data)
     type is (sf_test_spectrum_data_t)
        call data%init (model, pdg_in, with_radiation=.false.)
     end select
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     write (u, "(A)")  "* Probe spectrum: states"
     write (u, "(A)")
 
     write (u, "(A,I0)")  "n_states = ", sf_int%get_n_states ()
     write (u, "(A,I0)")  "n_in     = ", sf_int%get_n_in ()
     write (u, "(A,I0)")  "n_rad    = ", sf_int%get_n_rad ()
     write (u, "(A,I0)")  "n_out    = ", sf_int%get_n_out ()
     write (u, "(A)")
     write (u, "(A)", advance="no")  "state(1)  = "
     call quantum_numbers_write (sf_int%get_state (1), u)
     write (u, *)
 
     allocate (value (sf_int%get_n_states ()))
     call sf_int%compute_value (1, value(1), &
          E = [500._default, 500._default], &
          x = [0.5_default, 0.6_default], &
          xb= [0.5_default, 0.4_default], &
          scale = 0._default)
 
     write (u, "(A)")
     write (u, "(A)", advance="no")  "value (E=500,500, x=0.5,0.6) ="
     write (u, "(9(1x," // FMT_19 // "))")  value
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_7"
 
   end subroutine sf_base_7
 
 @ %def sf_base_7
 @
 \subsubsection{Structure function chain configuration}
 <<SF base: execute tests>>=
   call test (sf_base_8, "sf_base_8", &
        "structure function chain configuration", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_8
 <<SF base: tests>>=
   subroutine sf_base_8 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     class(sf_data_t), allocatable, target :: data_spectrum
     type(sf_config_t), dimension(:), allocatable :: sf_config
     type(sf_chain_t) :: sf_chain
 
     write (u, "(A)")  "* Test output: sf_base_8"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     allocate (sf_test_spectrum_data_t :: data_spectrum)
     select type (data_spectrum)
     type is (sf_test_spectrum_data_t)
        call data_spectrum%init (model, pdg_in, with_radiation=.true.)
     end select
 
     write (u, "(A)")  "* Set up chain with beams only"
     write (u, "(A)")
 
     call sf_chain%init (beam_data)
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with structure function"
     write (u, "(A)")
 
     allocate (sf_config (1))
     call sf_config(1)%init ([1], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with spectrum and structure function"
     write (u, "(A)")
 
     deallocate (sf_config)
     allocate (sf_config (2))
     call sf_config(1)%init ([1,2], data_spectrum)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_8"
 
   end subroutine sf_base_8
 
 @ %def sf_base_8
 @
 \subsubsection{Structure function instance configuration}
 We create a structure-function chain instance which implements a
 configured structure-function chain.  We link the momentum entries in
 the interactions and compute kinematics.
 
 We do not actually connect the interactions and create evaluators.  We
 skip this step and manually advance the status of the chain instead.
 <<SF base: execute tests>>=
   call test (sf_base_9, "sf_base_9", &
        "structure function chain instance", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_9
 <<SF base: tests>>=
   subroutine sf_base_9 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     class(sf_data_t), allocatable, target :: data_spectrum
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
     type(sf_channel_t), dimension(2) :: sf_channel
     type(vector4_t), dimension(2) :: p
     integer :: j
 
     write (u, "(A)")  "* Test output: sf_base_9"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain &
          &and create an instance"
     write (u, "(A)")  "*            compute kinematics"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     allocate (sf_test_spectrum_data_t :: data_spectrum)
     select type (data_spectrum)
     type is (sf_test_spectrum_data_t)
        call data_spectrum%init (model, pdg_in, with_radiation=.true.)
     end select
 
     write (u, "(A)")  "* Set up chain with beams only"
     write (u, "(A)")
 
     call sf_chain%init (beam_data)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%compute_kinematics (1, [real(default) ::])
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call sf_chain_instance%get_out_momenta (p)
 
     write (u, "(A)")
     write (u, "(A)")  "* Outgoing momenta:"
 
     do j = 1, 2
        write (u, "(A)")
        call vector4_write (p(j), u)
     end do
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with structure function"
     write (u, "(A)")
 
     allocate (sf_config (1))
     call sf_config(1)%init ([1], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_channel(1)%init (1)
     call sf_channel(1)%activate_mapping ([1])
     call sf_chain_instance%set_channel (1, sf_channel(1))
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%compute_kinematics (1, [0.8_default])
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call sf_chain_instance%get_out_momenta (p)
 
     write (u, "(A)")
     write (u, "(A)")  "* Outgoing momenta:"
 
     do j = 1, 2
        write (u, "(A)")
        call vector4_write (p(j), u)
     end do
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with spectrum and structure function"
     write (u, "(A)")
 
     deallocate (sf_config)
     allocate (sf_config (2))
     call sf_config(1)%init ([1,2], data_spectrum)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_channel(2)%init (2)
     call sf_channel(2)%activate_mapping ([2])
     call sf_chain_instance%set_channel (1, sf_channel(2))
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%compute_kinematics &
          (1, [0.5_default, 0.6_default, 0.8_default])
 
     call write_separator (u, 2)
     call sf_chain%write (u)
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call sf_chain_instance%get_out_momenta (p)
 
     write (u, "(A)")
     write (u, "(A)")  "* Outgoing momenta:"
 
     do j = 1, 2
        write (u, "(A)")
        call vector4_write (p(j), u)
     end do
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_9"
 
   end subroutine sf_base_9
 
 @ %def sf_base_9
 @
 \subsubsection{Structure function chain mappings}
 Set up a structure function chain instance with a pair of
 single-particle structure functions.  We test different global
 mappings for this setup.
 
 Again, we skip evaluators.
 <<SF base: execute tests>>=
  call test (sf_base_10, "sf_base_10", &
       "structure function chain mapping", &
       u, results)
 <<SF base: test declarations>>=
   public :: sf_base_10
 <<SF base: tests>>=
   subroutine sf_base_10 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
     type(sf_channel_t), dimension(2) :: sf_channel
     real(default), dimension(2) :: x_saved
 
     write (u, "(A)")  "* Test output: sf_base_10"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain"
     write (u, "(A)")  "*            and check mappings"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Set up chain with structure function pair &
          &and standard mapping"
     write (u, "(A)")
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data_strfun)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_channel(1)%init (2)
     call sf_channel(1)%set_s_mapping ([1,2])
     call sf_chain_instance%set_channel (1, sf_channel(1))
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default])
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert the kinematics calculation"
     write (u, "(A)")
 
     x_saved = sf_chain_instance%x
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
 
     call sf_channel(2)%init (2)
     call sf_channel(2)%set_s_mapping ([1, 2])
     call sf_chain_instance%set_channel (1, sf_channel(2))
 
     call sf_chain_instance%link_interactions ()
     sf_chain_instance%status = SF_DONE_CONNECTIONS
     call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_10"
 
   end subroutine sf_base_10
 
 @ %def sf_base_10
 @
 \subsubsection{Structure function chain evaluation}
 Here, we test the complete workflow for structure-function chains.
 First, we create the template chain, then initialize an instance.  We
 set up links, mask, and evaluators.  Finally, we set kinematics and
 evaluate the matrix elements and their products.
 <<SF base: execute tests>>=
   call test (sf_base_11, "sf_base_11", &
        "structure function chain evaluation", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_11
 <<SF base: tests>>=
   subroutine sf_base_11 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     class(sf_data_t), allocatable, target :: data_spectrum
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
     type(sf_channel_t), dimension(2) :: sf_channel
     type(particle_set_t) :: pset
     type(interaction_t), pointer :: int
     logical :: ok
 
     write (u, "(A)")  "* Test output: sf_base_11"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain"
     write (u, "(A)")  "*            create an instance and evaluate"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     allocate (sf_test_spectrum_data_t :: data_spectrum)
     select type (data_spectrum)
     type is (sf_test_spectrum_data_t)
        call data_spectrum%init (model, pdg_in, with_radiation=.true.)
     end select
 
     write (u, "(A)")  "* Set up chain with beams only"
     write (u, "(A)")
 
     call sf_chain%init (beam_data)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     call sf_chain_instance%compute_kinematics (1, [real(default) ::])
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
          [0._default, 0._default], .false., .true.)
     call sf_chain_instance%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover chain:"
     write (u, "(A)")
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%fill_interaction (int, 2, check_match=.false.)
 
     call sf_chain_instance%recover_kinematics (1)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call pset%final ()
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with structure function"
     write (u, "(A)")
 
     allocate (sf_config (1))
     call sf_config(1)%init ([1], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_channel(1)%init (1)
     call sf_channel(1)%activate_mapping ([1])
     call sf_chain_instance%set_channel (1, sf_channel(1))
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     call sf_chain_instance%compute_kinematics (1, [0.8_default])
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
          [0._default, 0._default], .false., .true.)
     call sf_chain_instance%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover chain:"
     write (u, "(A)")
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_channel(1)%init (1)
     call sf_channel(1)%activate_mapping ([1])
     call sf_chain_instance%set_channel (1, sf_channel(1))
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%fill_interaction (int, 2, check_match=.false.)
 
     call sf_chain_instance%recover_kinematics (1)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call pset%final ()
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")
     write (u, "(A)")
     write (u, "(A)")  "* Set up chain with spectrum and structure function"
     write (u, "(A)")
 
     deallocate (sf_config)
     allocate (sf_config (2))
     call sf_config(1)%init ([1,2], data_spectrum)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_channel(2)%init (2)
     call sf_channel(2)%activate_mapping ([2])
     call sf_chain_instance%set_channel (1, sf_channel(2))
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     call sf_chain_instance%compute_kinematics &
          (1, [0.5_default, 0.6_default, 0.8_default])
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%init (ok, int, int, FM_IGNORE_HELICITY, &
          [0._default, 0._default], .false., .true.)
     call sf_chain_instance%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Particle content:"
     write (u, "(A)")
 
     call write_separator (u)
     call pset%write (u)
     call write_separator (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover chain:"
     write (u, "(A)")
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_channel(2)%init (2)
     call sf_channel(2)%activate_mapping ([2])
     call sf_chain_instance%set_channel (1, sf_channel(2))
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     int => sf_chain_instance%get_out_int_ptr ()
     call pset%fill_interaction (int, 2, check_match=.false.)
 
     call sf_chain_instance%recover_kinematics (1)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     call pset%final ()
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_11"
 
   end subroutine sf_base_11
 
 @ %def sf_base_11
 @
 \subsubsection{Multichannel case}
 We set up a structure-function chain as before, but with three
 different parameterizations.  The first instance is without mappings,
 the second one with single-particle mappings, and the third one with
 two-particle mappings.
 <<SF base: execute tests>>=
   call test (sf_base_12, "sf_base_12", &
        "multi-channel structure function chain", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_12
 <<SF base: tests>>=
   subroutine sf_base_12 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
     real(default), dimension(2) :: x_saved
     real(default), dimension(2,3) :: p_saved
     type(sf_channel_t), dimension(:), allocatable :: sf_channel
 
     write (u, "(A)")  "* Test output: sf_base_12"
     write (u, "(A)")  "*   Purpose: set up and evaluate a multi-channel &
          &structure-function chain"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data)
     select type (data)
     type is (sf_test_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Set up chain with structure function pair &
          &and three different mappings"
     write (u, "(A)")
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1], data)
     call sf_config(2)%init ([2], data)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 3)
 
     call allocate_sf_channels (sf_channel, n_channel = 3, n_strfun = 2)
 
     ! channel 1: no mapping
     call sf_chain_instance%set_channel (1, sf_channel(1))
 
     ! channel 2: single-particle mappings
     call sf_channel(2)%activate_mapping ([1,2])
     ! call sf_chain_instance%activate_mapping (2, [1,2])
     call sf_chain_instance%set_channel (2, sf_channel(2))
 
     ! channel 3: two-particle mapping
     call sf_channel(3)%set_s_mapping ([1,2])
     ! call sf_chain_instance%set_s_mapping (3, [1, 2])
     call sf_chain_instance%set_channel (3, sf_channel(3))
 
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     write (u, "(A)")  "* Compute kinematics in channel 1 and evaluate"
     write (u, "(A)")
 
     call sf_chain_instance%compute_kinematics (1, [0.8_default, 0.6_default])
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert the kinematics calculation"
     write (u, "(A)")
 
     x_saved = sf_chain_instance%x
 
     call sf_chain_instance%inverse_kinematics (x_saved, 1 - x_saved)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute kinematics in channel 2 and evaluate"
     write (u, "(A)")
 
     p_saved = sf_chain_instance%p
 
     call sf_chain_instance%compute_kinematics (2, p_saved(:,2))
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute kinematics in channel 3 and evaluate"
     write (u, "(A)")
 
     call sf_chain_instance%compute_kinematics (3, p_saved(:,3))
     call sf_chain_instance%evaluate (scale=0._default)
 
     call write_separator (u, 2)
     call sf_chain_instance%write (u)
     call write_separator (u, 2)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_12"
 
   end subroutine sf_base_12
 
 @ %def sf_base_12
 @
 \subsubsection{Generated spectrum}
 Construct and evaluate a structure function object for a pair spectrum
 which is evaluated as a beam-event generator.
 <<SF base: execute tests>>=
   call test (sf_base_13, "sf_base_13", &
        "pair spectrum generator", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_13
 <<SF base: tests>>=
   subroutine sf_base_13 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t), dimension(2) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, x_free
 
     write (u, "(A)")  "* Test output: sf_base_13"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &a pair generator object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     allocate (sf_test_generator_data_t :: data)
     select type (data)
     type is (sf_test_generator_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize generator object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     write (u, "(A)")  "* Generate free r values"
     write (u, "(A)")
 
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
 
     write (u, "(A)")  "* Initialize incoming momenta with sqrts=1000"
 
     E = 500
     k(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     k(2) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call sf_int%seed_kinematics (k)
 
     write (u, "(A)")
     write (u, "(A)")  "* Complete kinematics"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call reset_interaction_counter ()
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
 
     call sf_int%seed_kinematics (k)
     call sf_int%set_momenta (q, outgoing=.true.)
     x_free = 1
     call sf_int%recover_x (x, xb, x_free)
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute inverse kinematics &
          &and evaluate"
     write (u, "(A)")
 
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale=0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_13"
 
   end subroutine sf_base_13
 
 @ %def sf_base_13
 @
 \subsubsection{Structure function chain evaluation}
 Here, we test the complete workflow for a structure-function chain
 with generator.  First, we create the template chain, then initialize
 an instance.  We set up links, mask, and evaluators.  Finally, we set
 kinematics and evaluate the matrix elements and their products.
 <<SF base: execute tests>>=
   call test (sf_base_14, "sf_base_14", &
        "structure function generator evaluation", &
        u, results)
 <<SF base: test declarations>>=
   public :: sf_base_14
 <<SF base: tests>>=
   subroutine sf_base_14 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     type(beam_data_t), target :: beam_data
     class(sf_data_t), allocatable, target :: data_strfun
     class(sf_data_t), allocatable, target :: data_generator
     type(sf_config_t), dimension(:), allocatable, target :: sf_config
     real(default), dimension(:), allocatable :: p_in
     type(sf_chain_t), target :: sf_chain
     type(sf_chain_instance_t), target :: sf_chain_instance
 
     write (u, "(A)")  "* Test output: sf_base_14"
     write (u, "(A)")  "*   Purpose: set up a structure-function chain"
     write (u, "(A)")  "*            create an instance and evaluate"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_test ()
     call flv%init (25, model)
     pdg_in = 25
 
     call reset_interaction_counter ()
 
     call beam_data%init_sqrts (1000._default, [flv, flv])
 
     allocate (sf_test_data_t :: data_strfun)
     select type (data_strfun)
     type is (sf_test_data_t)
        call data_strfun%init (model, pdg_in)
     end select
 
     allocate (sf_test_generator_data_t :: data_generator)
     select type (data_generator)
     type is (sf_test_generator_data_t)
        call data_generator%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Set up chain with generator and structure function"
     write (u, "(A)")
 
     allocate (sf_config (2))
     call sf_config(1)%init ([1,2], data_generator)
     call sf_config(2)%init ([2], data_strfun)
     call sf_chain%init (beam_data, sf_config)
 
     call sf_chain_instance%init (sf_chain, n_channel = 1)
     call sf_chain_instance%link_interactions ()
     call sf_chain_instance%exchange_mask ()
     call sf_chain_instance%init_evaluators ()
 
     write (u, "(A)")  "* Inject integration parameter"
     write (u, "(A)")
 
     allocate (p_in (sf_chain%get_n_bound ()), source = 0.9_default)
     write (u, "(A,9(1x,F10.7))")  "p_in =", p_in
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_chain_instance%compute_kinematics (1, p_in)
     call sf_chain_instance%evaluate (scale=0._default)
 
     call sf_chain_instance%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Extract integration parameter"
     write (u, "(A)")
 
     call sf_chain_instance%get_mcpar (1, p_in)
     write (u, "(A,9(1x,F10.7))")  "p_in =", p_in
 
     call sf_chain_instance%final ()
     call sf_chain%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_base_14"
 
   end subroutine sf_base_14
 
 @ %def sf_base_14
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Photon radiation: ISR}
 
 <<[[sf_isr.f90]]>>=
 <<File header>>
 
 module sf_isr
 
 <<Use kinds>>
 <<Use strings>>
   use pdg_arrays
   use model_data
   use flavors
   use sf_aux
   use sf_mappings
   use sf_base
   use electron_pdfs
 
 <<Standard module head>>
 
 <<SF isr: public>>
 
 <<SF isr: parameters>>
 
 <<SF isr: types>>
 
   interface
 <<SF isr: sub interfaces>>
   end interface
 
 contains
 
 <<SF isr: main procedures>>
 
 end module sf_isr
 @ %def sf_isr
 @
 <<[[sf_isr_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_isr) sf_isr_s
 
   use io_units
   use constants, only: pi
   use format_defs, only: FMT_15, FMT_19
   use numeric_utils
   use diagnostics
   use physics_defs, only: PHOTON
   use sm_physics, only: Li2
   use lorentz
   use colors
   use quantum_numbers
   use polarizations
 
   implicit none
 
 contains
 
 <<SF isr: procedures>>
 
 end submodule sf_isr_s
 
 @ %def sf_isr_s
 @
 \subsection{Physics}
 The ISR structure function is in the most crude approximation (LLA
 without $\alpha$ corrections, i.e. $\epsilon^0$)
 \begin{equation}
   f_0(x) = \epsilon (1-x)^{-1+\epsilon} \qquad\text{with}\qquad
   \epsilon = \frac{\alpha}{\pi}q_e^2\ln\frac{s}{m^2},
 \end{equation}
 where $m$ is the mass of the incoming (and outgoing) particle, which
 is initially assumed on-shell.
 
 In $f_0(x)$, there is an integrable singularity at $x=1$ which does
 not spoil the integration, but would lead to an unbounded $f_{\rm
 max}$.  Therefore, we map this singularity like
 \begin{equation}\label{ISR-mapping}
   x = 1 - (1-x')^{1/\epsilon}
 \end{equation}
 such that
 \begin{equation}
   \int dx\,f_0(x) = \int dx'
 \end{equation}
 
 For the detailed form of the QED ISR structure function
 cf. Chap.~\ref{chap:qed_pdf}.
 
 \subsection{Implementation}
 
 In the concrete implementation, the zeroth order mapping
 (\ref{ISR-mapping}) is implemented, and the Jacobian is equal to
 $f_i(x)/f_0(x)$.  This can be written as
 \begin{align}
   \frac{f_0(x)}{f_0(x)} &= 1 \\
   \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon - \frac{1-x^2}{2(1-x')} \\
 \begin{split}\label{ISR-f2}
   \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon
     + \frac{27 - 8\pi^2}{96}\epsilon^2
     - \frac{1-x^2}{2(1-x')} \\
   &\quad - \frac{(1+3x^2)\ln x
     + (1-x)\left(4(1+x)\ln(1-x) + 5 + x\right)}{8(1-x')}\epsilon
 \end{split}
 \end{align}
 %'
 For $x=1$ (i.e., numerically indistinguishable from $1$), this reduces to
 \begin{align}
   \frac{f_0(x)}{f_0(x)} &= 1 \\
   \frac{f_1(x)}{f_0(x)} &= 1 + \frac34\epsilon \\
   \frac{f_2(x)}{f_0(x)} &= 1 + \frac34\epsilon
     + \frac{27 - 8\pi^2}{96}\epsilon^2
 \end{align}
 The last line in (\ref{ISR-f2}) is zero for
 \begin{equation}
   x_{\rm min} = 0.00714053329734592839549879772019
 \end{equation}
 (Mathematica result), independent of $\epsilon$.  For $x$ values less
 than this we ignore this correction because of the logarithmic
 singularity which should in principle be resummed.
 
 
 \subsection{The ISR data block}
 <<SF isr: public>>=
   public :: isr_data_t
 <<SF isr: types>>=
   type, extends (sf_data_t) :: isr_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(:), allocatable :: flv_in
      type(qed_pdf_t) :: pdf
      real(default) :: alpha = 0
      real(default) :: q_max = 0
      real(default) :: real_mass = 0
      real(default) :: mass = 0
      real(default) :: eps = 0
      real(default) :: log = 0
      logical :: recoil = .false.
      logical :: keep_energy = .true.
      integer :: order = 3
      integer :: error = NONE
    contains
    <<SF isr: isr data: TBP>>
   end type isr_data_t
 
 @ %def isr_data_t
 @ Error codes
 <<SF isr: parameters>>=
   integer, parameter :: NONE = 0
   integer, parameter :: ZERO_MASS = 1
   integer, parameter :: Q_MAX_TOO_SMALL = 2
   integer, parameter :: EPS_TOO_LARGE = 3
   integer, parameter :: INVALID_ORDER = 4
   integer, parameter :: CHARGE_MIX = 5
   integer, parameter :: CHARGE_ZERO = 6
   integer, parameter :: MASS_MIX = 7
 @ Generate flavor-dependent ISR data:
 <<SF isr: isr data: TBP>>=
   procedure :: init => isr_data_init
 <<SF isr: sub interfaces>>=
     module subroutine isr_data_init (data, model, pdg_in, alpha, q_max, &
          mass, order, recoil, keep_energy)
       class(isr_data_t), intent(out) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), intent(in) :: pdg_in
       real(default), intent(in) :: alpha
       real(default), intent(in) :: q_max
       real(default), intent(in), optional :: mass
       integer, intent(in), optional :: order
       logical, intent(in), optional :: recoil
       logical, intent(in), optional :: keep_energy
     end subroutine isr_data_init
 <<SF isr: procedures>>=
   module subroutine isr_data_init (data, model, pdg_in, alpha, q_max, &
        mass, order, recoil, keep_energy)
     class(isr_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     real(default), intent(in) :: alpha
     real(default), intent(in) :: q_max
     real(default), intent(in), optional :: mass
     integer, intent(in), optional :: order
     logical, intent(in), optional :: recoil
     logical, intent(in), optional :: keep_energy
     integer :: i, n_flv
     real(default) :: charge
     data%model => model
     n_flv = pdg_in%get_length ()
     allocate (data%flv_in (n_flv))
     do i = 1, n_flv
        call data%flv_in(i)%init (pdg_in%get (i), model)
     end do
     data%alpha = alpha
     data%q_max = q_max
     if (present (order)) then
        call data%set_order (order)
     end if
     if (present (recoil)) then
        data%recoil = recoil
     end if
     if (present (keep_energy)) then
        data%keep_energy = keep_energy
     end if
     data%real_mass = data%flv_in(1)%get_mass ()
     if (present (mass)) then
        if (mass > 0) then
           data%mass = mass
        else
           data%mass = data%real_mass
           if (any (data%flv_in%get_mass () /= data%mass)) then
              data%error = MASS_MIX;  return
           end if
        end if
     else
        data%mass = data%real_mass
        if (any (data%flv_in%get_mass () /= data%mass)) then
           data%error = MASS_MIX;  return
        end if
     end if
     if (vanishes (data%mass)) then
        data%error = ZERO_MASS;  return
     else if (data%mass >= data%q_max) then
        data%error = Q_MAX_TOO_SMALL;  return
     end if
     data%log = log (1 + (data%q_max / data%mass)**2)
     charge = data%flv_in(1)%get_charge ()
     if (any (abs (data%flv_in%get_charge ()) /= abs (charge))) then
        data%error = CHARGE_MIX;  return
     else if (charge == 0) then
        data%error = CHARGE_ZERO;  return
     end if
     data%eps = data%alpha / pi * charge ** 2 &
          * (2 * log (data%q_max / data%mass) - 1)
     if (data%eps > 1) then
        data%error = EPS_TOO_LARGE;  return
     end if
     call data%pdf%init (data%mass, data%alpha, charge, data%q_max, data%order, &
          0, 1)
   end subroutine isr_data_init
 
 @ %def isr_data_init
 @ Explicitly set ISR order
 <<SF isr: isr data: TBP>>=
   procedure :: set_order => isr_data_set_order
 <<SF isr: sub interfaces>>=
     elemental module subroutine isr_data_set_order (data, order)
       class(isr_data_t), intent(inout) :: data
       integer, intent(in) :: order
     end subroutine isr_data_set_order
 <<SF isr: procedures>>=
   elemental module subroutine isr_data_set_order (data, order)
     class(isr_data_t), intent(inout) :: data
     integer, intent(in) :: order
     if (order < 0 .or. order > 3) then
        data%error = INVALID_ORDER
     else
        data%order = order
     end if
   end subroutine isr_data_set_order
 
 @ %def isr_data_set_order
 @ Handle error conditions.  Should always be done after
 initialization, unless we are sure everything is ok.
 <<SF isr: isr data: TBP>>=
   procedure :: check => isr_data_check
 <<SF isr: sub interfaces>>=
     module subroutine isr_data_check (data)
       class(isr_data_t), intent(in) :: data
     end subroutine isr_data_check
 <<SF isr: procedures>>=
   module subroutine isr_data_check (data)
     class(isr_data_t), intent(in) :: data
     select case (data%error)
     case (ZERO_MASS)
        call msg_fatal ("ISR: Particle mass is zero")
     case (Q_MAX_TOO_SMALL)
        call msg_fatal ("ISR: Particle mass exceeds Qmax")
     case (EPS_TOO_LARGE)
        call msg_fatal ("ISR: Expansion parameter too large, " // &
             "perturbative expansion breaks down")
     case (INVALID_ORDER)
        call msg_error ("ISR: LLA order invalid (valid values are 0,1,2,3)")
     case (MASS_MIX)
        call msg_fatal ("ISR: Incoming particle masses must be uniform")
     case (CHARGE_MIX)
        call msg_fatal ("ISR: Incoming particle charges must be uniform")
     case (CHARGE_ZERO)
        call msg_fatal ("ISR: Incoming particle must be charged")
     end select
   end subroutine isr_data_check
 
 @ %def isr_data_check
 @ Output
 <<SF isr: isr data: TBP>>=
   procedure :: write => isr_data_write
 <<SF isr: sub interfaces>>=
     module subroutine isr_data_write (data, unit, verbose)
       class(isr_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine isr_data_write
 <<SF isr: procedures>>=
   module subroutine isr_data_write (data, unit, verbose)
     class(isr_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "ISR data:"
     if (allocated (data%flv_in)) then
        write (u, "(3x,A)", advance="no") "  flavor =  "
        do i = 1, size (data%flv_in)
           if (i > 1)  write (u, "(',',1x)", advance="no")
           call data%flv_in(i)%write (u)
        end do
        write (u, *)
        write (u, "(3x,A," // FMT_19 // ")") "  alpha    = ", data%alpha
        write (u, "(3x,A," // FMT_19 // ")") "  q_max    = ", data%q_max
        write (u, "(3x,A," // FMT_19 // ")") "  mass     = ", data%mass
        write (u, "(3x,A," // FMT_19 // ")") "  eps      = ", data%eps
        write (u, "(3x,A," // FMT_19 // ")") "  log      = ", data%log
        write (u, "(3x,A,I2)")      "  order    = ", data%order
        write (u, "(3x,A,L2)")      "  recoil   = ", data%recoil
        write (u, "(3x,A,L2)")      "  keep en. = ", data%keep_energy
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine isr_data_write
 
 @ %def isr_data_write
 @ For ISR, there is the option to generate transverse momentum is
 generated. Hence, there can be up to three parameters, $x$, and two
 angles.
 <<SF isr: isr data: TBP>>=
   procedure :: get_n_par => isr_data_get_n_par
 <<SF isr: sub interfaces>>=
     module function isr_data_get_n_par (data) result (n)
       class(isr_data_t), intent(in) :: data
       integer :: n
     end function isr_data_get_n_par
 <<SF isr: procedures>>=
   module function isr_data_get_n_par (data) result (n)
     class(isr_data_t), intent(in) :: data
     integer :: n
     if (data%recoil) then
        n = 3
     else
        n = 1
     end if
   end function isr_data_get_n_par
 
 @ %def isr_data_get_n_par
 @ Return the outgoing particles PDG codes.  For ISR, these are
 identical to the incoming particles.
 <<SF isr: isr data: TBP>>=
   procedure :: get_pdg_out => isr_data_get_pdg_out
 <<SF isr: sub interfaces>>=
     module subroutine isr_data_get_pdg_out (data, pdg_out)
       class(isr_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine isr_data_get_pdg_out
 <<SF isr: procedures>>=
   module subroutine isr_data_get_pdg_out (data, pdg_out)
     class(isr_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = data%flv_in%get_pdg ()
   end subroutine isr_data_get_pdg_out
 
 @ %def isr_data_get_pdg_out
 @ Return the [[eps]] value.  We need it for an appropriate mapping of
 structure-function parameters.
 <<SF isr: isr data: TBP>>=
   procedure :: get_eps => isr_data_get_eps
 <<SF isr: sub interfaces>>=
     module function isr_data_get_eps (data) result (eps)
       class(isr_data_t), intent(in) :: data
       real(default) :: eps
     end function isr_data_get_eps
 <<SF isr: procedures>>=
   module function isr_data_get_eps (data) result (eps)
     class(isr_data_t), intent(in) :: data
     real(default) :: eps
     eps = data%eps
   end function isr_data_get_eps
 
 @ %def isr_data_get_eps
 @ Allocate the interaction record. Gfortran 7/8/9 bug, has to remain
 in the module.
 <<SF isr: isr data: TBP>>=
   procedure :: allocate_sf_int => isr_data_allocate_sf_int
 <<SF isr: main procedures>>=
   subroutine isr_data_allocate_sf_int (data, sf_int)
     class(isr_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (isr_t :: sf_int)
   end subroutine isr_data_allocate_sf_int
 
 @ %def isr_data_allocate_sf_int
 @
 \subsection{The ISR object}
 The [[isr_t]] data type is a $1\to 2$ interaction, i.e., we allow for
 single-photon emission only (but use the multi-photon resummed
 radiator function).  The particles are ordered as (incoming, photon,
 outgoing).
 
 There is no need to handle several flavors (and data blocks) in
 parallel, since ISR is always applied immediately after beam
 collision.  (ISR for partons is accounted for by the PDFs themselves.)
 Polarization is carried through, i.e., we retain the polarization of
 the incoming particle and treat the emitted photon as unpolarized.
 Color is trivially carried through.  This implies that particles 1 and
 3 should be locked together. For ISR we don't need the q variable.
 <<SF isr: public>>=
   public :: isr_t
 <<SF isr: types>>=
   type, extends (sf_int_t) :: isr_t
      private
      type(isr_data_t), pointer :: data => null ()
      real(default) :: x = 0
      real(default) :: xb= 0
    contains
    <<SF isr: isr: TBP>>
   end type isr_t
 
 @ %def isr_t
 @ Type string: has to be here, but there is no string variable on which ISR
 depends. Hence, a dummy routine.
 <<SF isr: isr: TBP>>=
   procedure :: type_string => isr_type_string
 <<SF isr: sub interfaces>>=
     module function isr_type_string (object) result (string)
       class(isr_t), intent(in) :: object
       type(string_t) :: string
     end function isr_type_string
 <<SF isr: procedures>>=
   module function isr_type_string (object) result (string)
     class(isr_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "ISR: e+ e- ISR spectrum"
     else
        string = "ISR: [undefined]"
     end if
   end function isr_type_string
 
 @ %def isr_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF isr: isr: TBP>>=
   procedure :: write => isr_write
 <<SF isr: sub interfaces>>=
     module subroutine isr_write (object, unit, testflag)
       class(isr_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine isr_write
 <<SF isr: procedures>>=
   module subroutine isr_write (object, unit, testflag)
     class(isr_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_15 // ")")  "x =", object%x
           write (u, "(3x,A," // FMT_15 // ")")  "xb=", object%xb
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "ISR data: [undefined]"
     end if
   end subroutine isr_write
 
 @ %def isr_write
 @ Explicitly set ISR order (for unit test).
 <<SF isr: isr: TBP>>=
   procedure :: set_order => isr_set_order
 <<SF isr: sub interfaces>>=
     module subroutine isr_set_order (object, order)
       class(isr_t), intent(inout) :: object
       integer, intent(in) :: order
     end subroutine isr_set_order
 <<SF isr: procedures>>=
   module subroutine isr_set_order (object, order)
     class(isr_t), intent(inout) :: object
     integer, intent(in) :: order
     call object%data%set_order (order)
     call object%data%pdf%set_order (order)
   end subroutine isr_set_order
 
 @ %def isr_set_order
 @
 \subsection{Kinematics}
 Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ were trivial. The ISR structure
 function allows for a straightforward mapping of the unit interval.
 So, to leading order, the structure function value is unity, but the
 $x$ value is transformed.  Higher orders affect the function value.
 
 The structure function implementation applies the above mapping to the
 input (random) number [[r]] to generate the momentum fraction [[x]]
 and the function value [[f]].  For numerical stability reasons, we
 also output [[xb]], which is $\bar x=1-x$.
 
 For the ISR structure function, the mapping Jacobian cancels the
 structure function (to order zero).  We apply the cancellation
 explicitly, therefore both the Jacobian [[f]] and the zeroth-order value
 (see the [[apply]] method) are unity if mapping is turned on.  If
 mapping is turned off, the Jacobian [[f]] includes the value of the
 (zeroth-order) structure function, and strongly peaked.
 <<SF isr: isr: TBP>>=
   procedure :: complete_kinematics => isr_complete_kinematics
 <<SF isr: sub interfaces>>=
     module subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map)
       class(isr_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine isr_complete_kinematics
 <<SF isr: procedures>>=
   module subroutine isr_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(isr_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     real(default) :: eps
     eps = sf_int%data%eps
     if (map) then
        call map_power_1 (sf_int%xb, f, rb(1), eps)
     else
        sf_int%xb = rb(1)
        if (rb(1) > 0) then
           f = 1
        else
           f = 0
        end if
     end if
     sf_int%x = 1 - sf_int%xb
     x(1) = sf_int%x
     xb(1) = sf_int%xb
     if (size (x) == 3) then
        x(2:3) = r(2:3)
        xb(2:3) = rb(2:3)
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_FAILED_KINEMATICS)
        sf_int%x = 0
        sf_int%xb= 0
        f = 0
     end select
   end subroutine isr_complete_kinematics
 
 @ %def isr_complete_kinematics
 @ Overriding the default method: we compute the [[x]] array from the
 momentum configuration.  In the specific case of ISR, we also set the
 internally stored $x$ and $\bar x$ values, so they can be used in the
 following routine.
 <<SF isr: isr: TBP>>=
   procedure :: recover_x => sf_isr_recover_x
 <<SF isr: sub interfaces>>=
     module subroutine sf_isr_recover_x (sf_int, x, xb, x_free)
       class(isr_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_isr_recover_x
 <<SF isr: procedures>>=
   module subroutine sf_isr_recover_x (sf_int, x, xb, x_free)
     class(isr_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
     sf_int%xb = xb(1)
   end subroutine sf_isr_recover_x
 
 @ %def sf_isr_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 
 For extracting $x$, we rely on the stored $\bar x$ value, since the
 $x$ value in the argument is likely imprecise.  This means that either
 [[complete_kinematics]] or [[recover_x]] must be called first, for the
 current sampling point (but maybe another channel).
 <<SF isr: isr: TBP>>=
   procedure :: inverse_kinematics => isr_inverse_kinematics
 <<SF isr: sub interfaces>>=
     module subroutine isr_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(isr_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine isr_inverse_kinematics
 <<SF isr: procedures>>=
   module subroutine isr_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(isr_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default) :: eps
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     eps = sf_int%data%eps
     if (map) then
        call map_power_inverse_1 (xb(1), f, rb(1), eps)
     else
        rb(1) = xb(1)
        if (rb(1) > 0) then
           f = 1
        else
           f = 0
        end if
     end if
     r(1) = 1 - rb(1)
     if (size(r) == 3) then
        r(2:3) = x(2:3)
        rb(2:3)= xb(2:3)
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS)
           r = 0
           rb= 0
           f = 0
        end select
     end if
   end subroutine isr_inverse_kinematics
 
 @ %def isr_inverse_kinematics
 @
 <<SF isr: isr: TBP>>=
   procedure :: init => isr_init
 <<SF isr: sub interfaces>>=
     module subroutine isr_init (sf_int, data)
       class(isr_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine isr_init
 <<SF isr: procedures>>=
   module subroutine isr_init (sf_int, data)
     class(isr_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     integer, dimension(3) :: hel_lock
     type(polarization_t), target :: pol
     type(quantum_numbers_t), dimension(1) :: qn_fc
     type(flavor_t) :: flv_photon
     type(color_t) :: col_photon
     type(quantum_numbers_t) :: qn_hel, qn_photon, qn
     type(polarization_iterator_t) :: it_hel
     real(default) :: m2
     integer :: i
     mask = quantum_numbers_mask (.false., .false., &
          mask_h = [.false., .true., .false.])
     hel_lock = [3, 0, 1]
     select type (data)
     type is (isr_data_t)
        m2 = data%mass**2
        call sf_int%base_init (mask, [m2], [0._default], [m2], &
             hel_lock = hel_lock)
        sf_int%data => data
        call flv_photon%init (PHOTON, data%model)
        call col_photon%init ()
        call qn_photon%init (flv_photon, col_photon)
        call qn_photon%tag_radiated ()
        do i = 1, size (data%flv_in)
           call pol%init_generic (data%flv_in(i))
           call qn_fc(1)%init (&
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i), 1))
           call it_hel%init (pol)
           do while (it_hel%is_valid ())
              qn_hel = it_hel%get_quantum_numbers ()
              qn = qn_hel .merge. qn_fc(1)
              call sf_int%add_state ([qn, qn_photon, qn])
              call it_hel%advance ()
           end do
           ! call pol%final ()  !!! Obsolete
        end do
        call sf_int%freeze ()
        if (data%keep_energy) then
           sf_int%on_shell_mode = KEEP_ENERGY
        else
           sf_int%on_shell_mode = KEEP_MOMENTUM
        end if
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
        sf_int%status = SF_INITIAL
     end select
   end subroutine isr_init
 
 @ %def isr_init
 @
 \subsection{ISR application}
 For ISR, we could in principle compute kinematics and function value
 in a single step. In order to be able to reweight matrix elements
 including structure functions we split kinematics and structure
 function calculation. The structure function works on a single beam,
 assuming that the input momentum has been set.
 
 For the structure-function evaluation, we rely on the fact that the
 power mapping, which we apply in the kinematics method (if the [[map]]
 flag is set), has a Jacobian which is just the inverse lowest-order
 structure function.  With mapping active, the two should cancel
 exactly.
 
 After splitting momenta, we set the outgoing momenta on-shell.  We
 choose to conserve momentum, so energy conservation may be violated.
 <<SF isr: isr: TBP>>=
   procedure :: apply => isr_apply
 <<SF isr: sub interfaces>>=
     module subroutine isr_apply (sf_int, scale, negative_sf, rescale, i_sub)
       class(isr_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine isr_apply
 <<SF isr: procedures>>=
   module subroutine isr_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(isr_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: f, finv, x, xb, eps, rb
     real(default) :: log_x, log_xb, x_2
     associate (data => sf_int%data)
       eps = sf_int%data%eps
       x = sf_int%x
       xb = sf_int%xb
       call map_power_inverse_1 (xb, finv, rb, eps)
       if (finv > 0) then
          f = 1 / finv
       else
          f = 0
       end if
       call data%pdf%evolve_qed_pdf (x, xb, rb, f)
     end associate
     call sf_int%set_matrix_element (cmplx (f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine isr_apply
 
 @ %def isr_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_isr_ut.f90]]>>=
 <<File header>>
 
 module sf_isr_ut
   use unit_tests
   use sf_isr_uti
 
 <<Standard module head>>
 
 <<SF isr: public test>>
 
 contains
 
 <<SF isr: test driver>>
 
 end module sf_isr_ut
 @ %def sf_isr_ut
 @
 <<[[sf_isr_uti.f90]]>>=
 <<File header>>
 
 module sf_isr_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use format_defs, only: FMT_12
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use interactions, only: interaction_t
   use model_data
   use sf_aux, only: KEEP_ENERGY
   use sf_mappings
   use sf_base
 
   use sf_isr
 
 <<Standard module head>>
 
 <<SF isr: test declarations>>
 
 contains
 
 <<SF isr: tests>>
 
 end module sf_isr_uti
 @ %def sf_isr_ut
 @ API: driver for the unit tests below.
 <<SF isr: public test>>=
   public :: sf_isr_test
 <<SF isr: test driver>>=
   subroutine sf_isr_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF isr: execute tests>>
   end subroutine sf_isr_test
 
 @ %def sf_isr_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF isr: execute tests>>=
   call test (sf_isr_1, "sf_isr_1", &
        "structure function configuration", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_1
 <<SF isr: tests>>=
   subroutine sf_isr_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_isr_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in = ELECTRON
 
     allocate (isr_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 10._default, &
             0.000511_default, order = 3, recoil = .false.)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_1"
 
   end subroutine sf_isr_1
 
 @ %def sf_isr_1
 @
 \subsubsection{Structure function without mapping}
 Direct ISR evaluation.  This is the use case for a double-beam
 structure function.  The parameter pair is mapped in the calling program.
 <<SF isr: execute tests>>=
   call test (sf_isr_2, "sf_isr_2", &
        "no ISR mapping", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_2
 <<SF isr: tests>>=
   subroutine sf_isr_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(flavor_t) :: flv
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, f_isr
 
     write (u, "(A)")  "* Test output: sf_isr_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in = ELECTRON
     call flv%init (ELECTRON, model)
 
     call reset_interaction_counter ()
 
     allocate (isr_data_t :: data)
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 500._default, &
             0.000511_default, order = 3, recoil = .false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.9, no ISR mapping, &
          &collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.9_default
     rb = 1 - r
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A)")
     write (u, "(A,9(1x," // FMT_12 // "))")  "x =", x
     write (u, "(A,9(1x," // FMT_12 // "))")  "xb=", xb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert kinematics"
     write (u, "(A)")
 
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate ISR structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure-function value, default order"
     write (u, "(A)")
 
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-evaluate structure function, leading order"
     write (u, "(A)")
 
     select type (sf_int)
     type is (isr_t)
        call sf_int%set_order (0)
     end select
     call sf_int%apply (scale = 100._default)
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_2"
 
   end subroutine sf_isr_2
 
 @ %def sf_isr_2
 @
 \subsubsection{Structure function with mapping}
 Apply the optimal ISR mapping.  This is the use case for a single-beam
 structure function.
 <<SF isr: execute tests>>=
   call test (sf_isr_3, "sf_isr_3", &
        "ISR mapping", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_3
 <<SF isr: tests>>=
   subroutine sf_isr_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, f_isr
 
     write (u, "(A)")  "* Test output: sf_isr_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (isr_data_t :: data)
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 500._default, &
             0.000511_default, order = 3, recoil = .false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.7, with ISR mapping, &
          &collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.7_default
     rb = 1 - r
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
 
     write (u, "(A)")
     write (u, "(A,9(1x," // FMT_12 // "))")  "x =", x
     write (u, "(A,9(1x," // FMT_12 // "))")  "xb=", xb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert kinematics"
     write (u, "(A)")
 
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate ISR structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure-function value, default order"
     write (u, "(A)")
 
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Re-evaluate structure function, leading order"
     write (u, "(A)")
 
     select type (sf_int)
     type is (isr_t)
        call sf_int%set_order (0)
     end select
     call sf_int%apply (scale = 100._default)
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_3"
 
   end subroutine sf_isr_3
 
 @ %def sf_isr_3
 @
 \subsubsection{Non-collinear ISR splitting}
 Construct and display a structure function object based on the ISR
 structure function. We blank out numerical fluctuations for 32bit.
 <<SF isr: execute tests>>=
   call test (sf_isr_4, "sf_isr_4", &
        "ISR non-collinear", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_4
 <<SF isr: tests>>=
   subroutine sf_isr_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, f_isr
     character(len=80) :: buffer
     integer :: u_scratch, iostat
 
     write (u, "(A)")  "* Test output: sf_isr_4"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     allocate (isr_data_t :: data)
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 500._default, &
             0.000511_default, order = 3, recoil = .true.)
     end select
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5/0.5/0.25, with ISR mapping, "
     write (u, "(A)")  "          non-coll., keeping energy"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.5_default, 0.5_default, 0.25_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%pacify_momenta (1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "r =", r
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate ISR structure function"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%pacify_momenta (1e-10_default)
     call sf_int%apply (scale = 10._default)
     u_scratch = free_unit ()
     open (u_scratch, status="scratch", action = "readwrite")
     call sf_int%write (u_scratch, testflag = .true.)
     rewind (u_scratch)
     do
        read (u_scratch, "(A)", iostat=iostat) buffer
        if (iostat /= 0) exit
        if (buffer(1:25) == " P =   0.000000E+00  9.57") then
           buffer = replace (buffer, 26, "XXXX")
        end if
        if (buffer(1:25) == " P =   0.000000E+00 -9.57") then
           buffer = replace (buffer, 26, "XXXX")
        end if
        write (u, "(A)") buffer
     end do
     close (u_scratch)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure-function value"
     write (u, "(A)")
 
     f_isr = sf_int%get_matrix_element (1)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", f_isr
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", f_isr * f
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_4"
 
   end subroutine sf_isr_4
 
 @ %def sf_isr_4
 @
 \subsubsection{Structure function pair with mapping}
 Apply the ISR mapping for a ISR pair.
 structure function.
 <<SF isr: execute tests>>=
   call test (sf_isr_5, "sf_isr_5", &
        "ISR pair mapping", &
        u, results)
 <<SF isr: test declarations>>=
   public :: sf_isr_5
 <<SF isr: tests>>=
   subroutine sf_isr_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_mapping_t), allocatable :: mapping
     class(sf_int_t), dimension(:), allocatable :: sf_int
     type(vector4_t), dimension(2) :: k
     real(default) :: E, f_map
     real(default), dimension(:), allocatable :: p, pb, r, rb, x, xb
     real(default), dimension(2) :: f, f_isr
     integer :: i
 
     write (u, "(A)")  "* Test output: sf_isr_5"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (isr_data_t :: data)
     select type (data)
     type is (isr_data_t)
        call data%init (model, pdg_in, 1./137._default, 500._default, &
             0.000511_default, order = 3, recoil = .false.)
     end select
 
     allocate (sf_ip_mapping_t :: mapping)
     select type (mapping)
     type is (sf_ip_mapping_t)
        select type (data)
        type is (isr_data_t)
           call mapping%init (eps = data%get_eps ())
        end select
        call mapping%set_index (1, 1)
        call mapping%set_index (2, 2)
     end select
 
     call mapping%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     allocate (isr_t :: sf_int (2))
 
     do i = 1, 2
        call sf_int(i)%init (data)
        call sf_int(i)%set_beam_index ([i])
     end do
 
     write (u, "(A)")  "* Initialize incoming momenta with E=500"
     write (u, "(A)")
     E = 500
     k(1) = vector4_moving (E,   sqrt (E**2 - flv%get_mass ()**2), 3)
     k(2) = vector4_moving (E, - sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     do i = 1, 2
        call vector4_write (k(i), u)
        call sf_int(i)%seed_kinematics (k(i:i))
     end do
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for p=[0.7,0.4], collinear"
     write (u, "(A)")
 
     allocate (p (2 * data%get_n_par ()))
     allocate (pb(size (p)))
     allocate (r (size (p)))
     allocate (rb(size (p)))
     allocate (x (size (p)))
     allocate (xb(size (p)))
 
     p = [0.7_default, 0.4_default]
     pb= 1 - p
     call mapping%compute (r, rb, f_map, p, pb)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "p =", p
     write (u, "(A,9(1x," // FMT_12 // "))")  "pb=", pb
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
     write (u, "(A,9(1x," // FMT_12 // "))")  "fm=", f_map
 
     do i = 1, 2
        call sf_int(i)%complete_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), &
             map=.false.)
     end do
 
     write (u, "(A)")
     write (u, "(A,9(1x," // FMT_12 // "))")  "x =", x
     write (u, "(A,9(1x," // FMT_12 // "))")  "xb=", xb
     write (u, "(A,9(1x," // FMT_12 // "))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Invert kinematics"
     write (u, "(A)")
 
     do i = 1, 2
        call sf_int(i)%inverse_kinematics (x(i:i), xb(i:i), f(i), r(i:i), rb(i:i), &
             map=.false.)
     end do
     call mapping%inverse (r, rb, f_map, p, pb)
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "p =", p
     write (u, "(A,9(1x," // FMT_12 // "))")  "pb=", pb
     write (u, "(A,9(1x," // FMT_12 // "))")  "r =", r
     write (u, "(A,9(1x," // FMT_12 // "))")  "rb=", rb
     write (u, "(A,9(1x," // FMT_12 // "))")  "fm=", f_map
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate ISR structure function"
 
     call sf_int(1)%apply (scale = 100._default)
     call sf_int(2)%apply (scale = 100._default)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure function #1"
     write (u, "(A)")
     call sf_int(1)%write (u, testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure function #2"
     write (u, "(A)")
     call sf_int(2)%write (u, testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Structure-function value, default order"
     write (u, "(A)")
 
     do i = 1, 2
        f_isr(i) = sf_int(i)%get_matrix_element (1)
     end do
 
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr         =", &
          product (f_isr)
     write (u, "(A,9(1x," // FMT_12 // "))")  "f_isr * f_map =", &
          product (f_isr * f) * f_map
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     do i = 1, 2
        call sf_int(i)%final ()
     end do
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_isr_5"
 
   end subroutine sf_isr_5
 
 @ %def sf_isr_5
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{EPA}
 
 <<[[sf_epa.f90]]>>=
 <<File header>>
 
 module sf_epa
 
 <<Use kinds>>
 <<Use strings>>
   use lorentz
   use pdg_arrays
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use polarizations
   use interactions
   use sf_aux
   use sf_base
 
 <<Standard module head>>
 
 <<SF epa: public>>
 
 <<SF epa: parameters>>
 
 <<SF epa: types>>
 
   interface
 <<SF epa: sub interfaces>>
   end interface
 
 contains
 
 <<SF epa: main procedures>>
 
 end module sf_epa
 @ %def sf_epa
 @
 <<[[sf_epa_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_epa) sf_epa_s
 
   use io_units
   use constants, only: pi
   use format_defs, only: FMT_17, FMT_19
   use numeric_utils
   use diagnostics
   use physics_defs, only: PHOTON
   use colors
 
   implicit none
 
 contains
 
 <<SF epa: procedures>>
 
 end submodule sf_epa_s
 
 @ %def sf_epa_s
 @
 \subsection{Physics}
 The EPA structure function for a photon inside an (elementary)
 particle $p$ with energy $E$, mass $m$ and charge $q_p$ (e.g.,
 electron) is given by ($\bar x \equiv 1-x$)
 
 There are several variants of the EPA, which are steered by the
 [[\$epa\_mode]] switch. The formula (6.17b) from the report by Budnev
 et al. is given by
 %% %\cite{Budnev:1974de}
 %% \bibitem{Budnev:1974de}
 %%   V.~M.~Budnev, I.~F.~Ginzburg, G.~V.~Meledin and V.~G.~Serbo,
 %%   %``The Two photon particle production mechanism. Physical problems.
 %%   %Applications. Equivalent photon approximation,''
 %%   Phys.\ Rept.\  {\bf 15} (1974) 181.
 %%   %%CITATION = PRPLC,15,181;%%
 \begin{multline}
 \label{EPA_617}
   f(x) =
   \frac{\alpha}{\pi}\,q_p^2\,
   \frac{1}{x}\,
   \biggl[\left(\bar x + \frac{x^2}{2}\right)
         \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}}
         \\
   - \left(1 - \frac{x}{2}\right)^2
     \ln\frac{x^2+\frac{Q^2_{\rm max}}{E^2}}
                   {x^2+\frac{Q^2_{\rm min}}{E^2}}
         - x^2\frac{m^2}{Q^2_{\rm min}}
           \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right)
   \biggr].
 \end{multline}
 If no explicit $Q$ bounds are provided, the kinematical bounds are
 \begin{align}
   -Q^2_{\rm max} &= t_0 = -2\bar x(E^2+p\bar p) + 2m^2 \approx -4\bar x E^2,
 \\
   -Q^2_{\rm min} &= t_1 = -2\bar x(E^2-p\bar p) + 2m^2
   \approx
   -\frac{x^2}{\bar x}m^2.
 \end{align}
 
 The second and third terms in (\ref{EPA_617}) are negative definite (and
 subleading).  Noting that $\bar x + x^2/2$ is bounded between
 $1/2$ and $1$, we derive that $f(x)$ is always smaller than
 \begin{equation}
   \bar f(x) = \frac{\alpha}{\pi}\,q_p^2\,\frac{L - 2\ln x}{x}
   \qquad\text{where}\qquad
   L = \ln\frac{\min(4E_{\rm max}^2,Q^2_{\rm max})}{\max(m^2,Q_{\rm min}^2)},
 \end{equation}
 where we allow for explicit $Q$ bounds that narrow the kinematical range.
 Therefore, we generate this distribution:
 \begin{equation}\label{EPA-subst}
   \int_{x_0}^{x_1} dx\,\bar f(x) = C(x_0,x_1)\int_0^1 dx'
 \end{equation}
 We set
 \begin{equation}\label{EPA-x(x')}
   \ln x = \frac12\left\{ L - \sqrt{L^2 - 4\left[ x'\ln x_1(L-\ln x_1)
   + \bar x'\ln x_0(L-\ln x_0) \right]} \right\}
 \end{equation}
 such that $x(0)=x_0$ and $x(1)=x_1$ and
 \begin{equation}
   \frac{dx}{dx'} = \left(\frac{\alpha}{\pi} q_p^2 \right)^{-1}
   x\frac{C(x_0,x_1)}{L - 2\ln x}
 \end{equation}
 with
 \begin{equation}
   C(x_0,x_1) = \frac{\alpha}{\pi} q_p^2\,\left[\ln x_1(L-\ln x_1) - \ln
   x_0(L-\ln x_0)\right]
 \end{equation}
 such that (\ref{EPA-subst}) is satisfied.  Finally, we have
 \begin{equation}
   \int_{x_0}^{x_1} dx\,f(x) = C(x_0,x_1)\int_0^1 dx'\,
   \frac{f(x(x'))}{\bar f(x(x'))}
 \end{equation}
 where $x'$ is calculated from $x$ via (\ref{EPA-x(x')}).
 
 The structure of the mapping is most obvious from:
 \begin{equation}
   x'(x) = \frac{\log x ( L - \log x) - \log x_0 (L - \log x_0)}
   {\log x_1 ( L - \log x_1) - \log x_0 (L - \log x_0)} \; .
 \end{equation}
 
 Taking the Eq. (6.16e) from the Budnev et al. report, and integrating
 it over $q^2$ yields the modified result
 \begin{equation}
 \label{EPA_616e}
   f(x) =
   \frac{\alpha}{\pi}\,q_p^2\,
   \frac{1}{x}\,
   \biggl[\left(\bar x + \frac{x^2}{2}\right)
         \ln\frac{Q^2_{\rm max}}{Q^2_{\rm min}}
         - x^2\frac{m^2}{Q^2_{\rm min}}
           \left(1 - \frac{Q^2_{\rm min}}{Q^2_{\rm max}}\right)
   \biggr].
 \end{equation}
 This is closer to many standard papers from LEP times, and to textbook
 formulae like e.g. in Peskin/Schroeder. For historical reasons, we
 keep Eq.~(\ref{EPA_617}) as the default in \whizard.
 
 
 \subsection{The EPA data block}
 The EPA parameters are: $\alpha$, $E_{\rm max}$, $m$, $Q_{\rm min}$, and
 $x_{\rm min}$.  Instead of $m$ we can use the incoming particle PDG
 code as input; from this we can deduce the mass and charge.
 
 Internally we store in addition $C_{0/1} = \frac{\alpha}{\pi}q_e^2\ln
 x_{0/1} (L - \ln x_{0/1})$, the c.m. energy squared and the incoming
 particle mass.
 <<SF epa: public>>=
   public :: EPA_MODE_DEFAULT
   public :: EPA_MODE_BUDNEV_617
   public :: EPA_MODE_BUDNEV_616E
   public :: EPA_MODE_LOG_POWER
   public :: EPA_MODE_LOG_SIMPLE
   public :: EPA_MODE_LOG
 <<SF epa: parameters>>=
   integer, parameter :: EPA_MODE_DEFAULT = 0
   integer, parameter :: EPA_MODE_BUDNEV_617 = 0
   integer, parameter :: EPA_MODE_BUDNEV_616E = 1
   integer, parameter :: EPA_MODE_LOG_POWER = 2
   integer, parameter :: EPA_MODE_LOG_SIMPLE = 3
   integer, parameter :: EPA_MODE_LOG = 4
 
 @ %def EPA_MODE_DEFAULT EPA_MODE_BUDNEV_617 EPA_MODE_BUDNEV_616E
 @ %def EPA_MODE_LOG_POWER EPA_MODE_LOG_SIMPLE EPA_MODE_LOG
 @
 <<SF epa: public>>=
   public :: epa_data_t
 <<SF epa: types>>=
   type, extends(sf_data_t) :: epa_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(:), allocatable :: flv_in
      real(default) :: alpha
      real(default) :: x_min
      real(default) :: x_max
      real(default) :: q_min
      real(default) :: q_max
      real(default) :: E_max
      real(default) :: mass
      real(default) :: log
      real(default) :: a
      real(default) :: c0
      real(default) :: c1
      real(default) :: dc
      integer :: mode = EPA_MODE_DEFAULT
      integer :: error = NONE
      logical :: recoil = .false.
      logical :: keep_energy = .true.
    contains
    <<SF epa: epa data: TBP>>
   end type epa_data_t
 
 @ %def epa_data_t
 @ Error codes
 <<SF epa: parameters>>=
   integer, parameter :: NONE = 0
   integer, parameter :: ZERO_QMIN = 1
   integer, parameter :: Q_MAX_TOO_SMALL = 2
   integer, parameter :: ZERO_XMIN = 3
   integer, parameter :: MASS_MIX = 4
   integer, parameter :: NO_EPA = 5
 <<SF epa: epa data: TBP>>=
   procedure :: init => epa_data_init
 <<SF epa: sub interfaces>>=
     module subroutine epa_data_init (data, model, mode, pdg_in, alpha, &
          x_min, q_min, q_max, mass, recoil, keep_energy)
       class(epa_data_t), intent(inout) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), intent(in) :: pdg_in
       integer, intent(in) :: mode
       real(default), intent(in) :: alpha, x_min, q_min, q_max
       real(default), intent(in), optional :: mass
       logical, intent(in), optional :: recoil
       logical, intent(in), optional :: keep_energy
     end subroutine epa_data_init
 <<SF epa: procedures>>=
   module subroutine epa_data_init (data, model, mode, pdg_in, alpha, &
        x_min, q_min, q_max, mass, recoil, keep_energy)
     class(epa_data_t), intent(inout) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     integer, intent(in) :: mode
     real(default), intent(in) :: alpha, x_min, q_min, q_max
     real(default), intent(in), optional :: mass
     logical, intent(in), optional :: recoil
     logical, intent(in), optional :: keep_energy
     integer :: n_flv, i
     data%model => model
     data%mode = mode
     n_flv = pdg_in%get_length ()
     allocate (data%flv_in (n_flv))
     do i = 1, n_flv
        call data%flv_in(i)%init (pdg_in%get (i), model)
     end do
     data%alpha = alpha
     data%E_max = q_max / 2
     data%x_min = x_min
     data%x_max = 1
     if (vanishes (data%x_min)) then
        data%error = ZERO_XMIN;  return
     end if
     data%q_min = q_min
     data%q_max = q_max
     select case (char (data%model%get_name ()))
     case ("QCD","Test")
        data%error = NO_EPA;  return
     end select
     if (present (recoil)) then
        data%recoil = recoil
     end if
     if (present (keep_energy)) then
        data%keep_energy = keep_energy
     end if
     if (present (mass)) then
        data%mass = mass
     else
        data%mass = data%flv_in(1)%get_mass ()
        if (any (data%flv_in%get_mass () /= data%mass)) then
           data%error = MASS_MIX;  return
        end if
     end if
     if (max (data%mass, data%q_min) == 0) then
        data%error = ZERO_QMIN;  return
     else if (max (data%mass, data%q_min) >= data%E_max) then
        data%error = Q_MAX_TOO_SMALL;  return
     end if
     data%log = log ((data%q_max / max (data%mass, data%q_min)) ** 2 )
     data%a  = data%alpha / pi
     data%c0 = log (data%x_min) * (data%log - log (data%x_min))
     data%c1 = log (data%x_max) * (data%log - log (data%x_max))
     data%dc = data%c1 - data%c0
   end subroutine epa_data_init
 
 @ %def epa_data_init
 @ Handle error conditions.  Should always be done after
 initialization, unless we are sure everything is ok.
 <<SF epa: epa data: TBP>>=
   procedure :: check => epa_data_check
 <<SF epa: sub interfaces>>=
     module subroutine epa_data_check (data)
       class(epa_data_t), intent(in) :: data
     end subroutine epa_data_check
 <<SF epa: procedures>>=
   module subroutine epa_data_check (data)
     class(epa_data_t), intent(in) :: data
     select case (data%error)
     case (NO_EPA)
        call msg_fatal ("EPA structure function not available for model " &
             // char (data%model%get_name ()) // ".")
     case (ZERO_QMIN)
        call msg_fatal ("EPA: Particle mass is zero")
     case (Q_MAX_TOO_SMALL)
        call msg_fatal ("EPA: Particle mass exceeds Qmax")
     case (ZERO_XMIN)
        call msg_fatal ("EPA: x_min must be larger than zero")
     case (MASS_MIX)
        call msg_fatal ("EPA: incoming particle masses must be uniform")
     end select
   end subroutine epa_data_check
 
 @ %def epa_data_check
 @ Output
 <<SF epa: epa data: TBP>>=
   procedure :: write => epa_data_write
 <<SF epa: sub interfaces>>=
     module subroutine epa_data_write (data, unit, verbose)
       class(epa_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine epa_data_write
 <<SF epa: procedures>>=
   module subroutine epa_data_write (data, unit, verbose)
     class(epa_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "EPA data:"
     if (allocated (data%flv_in)) then
        write (u, "(3x,A)", advance="no") "  flavor =  "
        do i = 1, size (data%flv_in)
           if (i > 1)  write (u, "(',',1x)", advance="no")
           call data%flv_in(i)%write (u)
        end do
        write (u, *)
        write (u, "(3x,A," // FMT_19 // ")") "  alpha    = ", data%alpha
        write (u, "(3x,A," // FMT_19 // ")") "  x_min    = ", data%x_min
        write (u, "(3x,A," // FMT_19 // ")") "  x_max    = ", data%x_max
        write (u, "(3x,A," // FMT_19 // ")") "  q_min    = ", data%q_min
        write (u, "(3x,A," // FMT_19 // ")") "  q_max    = ", data%q_max
        write (u, "(3x,A," // FMT_19 // ")") "  E_max    = ", data%e_max
        write (u, "(3x,A," // FMT_19 // ")") "  mass     = ", data%mass
        write (u, "(3x,A," // FMT_19 // ")") "  a        = ", data%a
        write (u, "(3x,A," // FMT_19 // ")") "  c0       = ", data%c0
        write (u, "(3x,A," // FMT_19 // ")") "  c1       = ", data%c1
        write (u, "(3x,A," // FMT_19 // ")") "  log      = ", data%log
        write (u, "(3x,A,L2)")      "  recoil   = ", data%recoil
        write (u, "(3x,A,L2)")      "  keep en. = ", data%keep_energy
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine epa_data_write
 
 @ %def epa_data_write
 @ The number of kinematic parameters.
 <<SF epa: epa data: TBP>>=
   procedure :: get_n_par => epa_data_get_n_par
 <<SF epa: sub interfaces>>=
     module function epa_data_get_n_par (data) result (n)
       class(epa_data_t), intent(in) :: data
       integer :: n
     end function epa_data_get_n_par
 <<SF epa: procedures>>=
   module function epa_data_get_n_par (data) result (n)
     class(epa_data_t), intent(in) :: data
     integer :: n
     if (data%recoil) then
        n = 3
     else
        n = 1
     end if
   end function epa_data_get_n_par
 
 @ %def epa_data_get_n_par
 @ Return the outgoing particles PDG codes. The outgoing particle is always
 the photon while the radiated particle is identical to the incoming one.
 <<SF epa: epa data: TBP>>=
   procedure :: get_pdg_out => epa_data_get_pdg_out
 <<SF epa: sub interfaces>>=
     module subroutine epa_data_get_pdg_out (data, pdg_out)
       class(epa_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine epa_data_get_pdg_out
 <<SF epa: procedures>>=
   module subroutine epa_data_get_pdg_out (data, pdg_out)
     class(epa_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     pdg_out(1) = PHOTON
   end subroutine epa_data_get_pdg_out
 
 @ %def epa_data_get_pdg_out
 @ Allocate the interaction record. Gfortran 7/8/9 bug, has to remain
 in module.
 <<SF epa: epa data: TBP>>=
   procedure :: allocate_sf_int => epa_data_allocate_sf_int
 <<SF epa: main procedures>>=
   subroutine epa_data_allocate_sf_int (data, sf_int)
     class(epa_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (epa_t :: sf_int)
   end subroutine epa_data_allocate_sf_int
 
 @ %def epa_data_allocate_sf_int
 @
 \subsection{The EPA object}
 The [[epa_t]] data type is a $1\to 2$ interaction.  We should be able
 to handle several flavors in parallel, since EPA is not necessarily
 applied immediately after beam collision:  Photons may be radiated
 from quarks.  In that case, the partons are massless and $q_{\rm min}$
 applies instead, so we do not need to generate several kinematical
 configurations in parallel.
 
 The squared charge values multiply the matrix elements, depending on the
 flavour.  We scan the interaction after building it, so we have the correct
 assignments.
 
 The particles are ordered as (incoming, radiated, photon), where the
 photon initiates the hard interaction.
 
 We generate an unpolarized photon and transfer initial polarization to
 the radiated parton.  Color is transferred in the same way.
 <<SF epa: types>>=
   type, extends (sf_int_t) :: epa_t
      type(epa_data_t), pointer :: data => null ()
      real(default) :: x  = 0
      real(default) :: xb = 0
      real(default) :: E  = 0
      real(default), dimension(:), allocatable :: charge2
    contains
    <<SF epa: epa: TBP>>
   end type epa_t
 
 @ %def epa_t
 @ Type string: has to be here, but there is no string variable on which EPA
 depends. Hence, a dummy routine.
 <<SF epa: epa: TBP>>=
   procedure :: type_string => epa_type_string
 <<SF epa: sub interfaces>>=
     module function epa_type_string (object) result (string)
       class(epa_t), intent(in) :: object
       type(string_t) :: string
     end function epa_type_string
 <<SF epa: procedures>>=
   module function epa_type_string (object) result (string)
     class(epa_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "EPA: equivalent photon approx."
     else
        string = "EPA: [undefined]"
     end if
   end function epa_type_string
 
 @ %def epa_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF epa: epa: TBP>>=
   procedure :: write => epa_write
 <<SF epa: sub interfaces>>=
     module subroutine epa_write (object, unit, testflag)
       class(epa_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine epa_write
 <<SF epa: procedures>>=
   module subroutine epa_write (object, unit, testflag)
     class(epa_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_17 // ")")  "x =", object%x
           if (object%status >= SF_FAILED_EVALUATION) then
              write (u, "(3x,A," // FMT_17 // ")")  "E =", object%E
           end if
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "EPA data: [undefined]"
     end if
   end subroutine epa_write
 
 @ %def epa_write
 @ Prepare the interaction object.  We have to construct transition matrix
 elements for all flavor and helicity combinations.
 <<SF epa: epa: TBP>>=
   procedure :: init => epa_init
 <<SF epa: sub interfaces>>=
     module subroutine epa_init (sf_int, data)
       class(epa_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine epa_init
 <<SF epa: procedures>>=
   module subroutine epa_init (sf_int, data)
     class(epa_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     integer, dimension(3) :: hel_lock
     type(polarization_t), target :: pol
     type(quantum_numbers_t), dimension(1) :: qn_fc
     type(flavor_t) :: flv_photon
     type(color_t) :: col_photon
     type(quantum_numbers_t) :: qn_hel, qn_photon, qn, qn_rad
     type(polarization_iterator_t) :: it_hel
     integer :: i
     mask = quantum_numbers_mask (.false., .false., &
          mask_h = [.false., .false., .true.])
     hel_lock = [2, 1, 0]
     select type (data)
     type is (epa_data_t)
        call sf_int%base_init (mask, [data%mass**2], &
             [data%mass**2], [0._default], hel_lock = hel_lock)
        sf_int%data => data
        call flv_photon%init (PHOTON, data%model)
        call col_photon%init ()
        call qn_photon%init (flv_photon, col_photon)
        do i = 1, size (data%flv_in)
           call pol%init_generic (data%flv_in(i))
           call qn_fc(1)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i), 1))
           call it_hel%init (pol)
           do while (it_hel%is_valid ())
              qn_hel = it_hel%get_quantum_numbers ()
              qn = qn_hel .merge. qn_fc(1)
              qn_rad = qn
              call qn_rad%tag_radiated ()
              call sf_int%add_state ([qn, qn_rad, qn_photon])
              call it_hel%advance ()
           end do
           !  call pol%final ()
        end do
        call sf_int%freeze ()
        if (data%keep_energy) then
           sf_int%on_shell_mode = KEEP_ENERGY
        else
           sf_int%on_shell_mode = KEEP_MOMENTUM
        end if
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
     end select
   end subroutine epa_init
 
 @ %def epa_init
 @ Prepare the charge array.  This is separate from the previous routine since
 the state matrix may be helicity-contracted.
 <<SF epa: epa: TBP>>=
   procedure :: setup_constants => epa_setup_constants
 <<SF epa: sub interfaces>>=
     module subroutine epa_setup_constants (sf_int)
       class(epa_t), intent(inout), target :: sf_int
     end subroutine epa_setup_constants
 <<SF epa: procedures>>=
   module subroutine epa_setup_constants (sf_int)
     class(epa_t), intent(inout), target :: sf_int
     type(state_iterator_t) :: it
     type(flavor_t) :: flv
     integer :: i, n_me
     n_me = sf_int%get_n_matrix_elements ()
     allocate (sf_int%charge2 (n_me))
     call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
     do while (it%is_valid ())
        i = it%get_me_index ()
        flv = it%get_flavor (1)
        sf_int%charge2(i) = flv%get_charge () ** 2
        call it%advance ()
     end do
     sf_int%status = SF_INITIAL
   end subroutine epa_setup_constants
 
 @ %def epa_setup_constants
 @
 \subsection{Kinematics}
 Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 The EPA structure function allows for a straightforward mapping of the
 unit interval. The $x$ value is transformed, and the mapped structure
 function becomes unity at its upper boundary.
 
 The structure function implementation applies the above mapping to the
 input (random) number [[r]] to generate the momentum fraction [[x]]
 and the function value [[f]].  For numerical stability reasons, we
 also output [[xb]], which is $\bar x=1-x$.
 <<SF epa: epa: TBP>>=
   procedure :: complete_kinematics => epa_complete_kinematics
 <<SF epa: sub interfaces>>=
     module subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map)
       class(epa_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine epa_complete_kinematics
 <<SF epa: procedures>>=
   module subroutine epa_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(epa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     real(default) :: delta, sqrt_delta, lx
     if (map) then
        associate (data => sf_int%data)
          delta = data%log ** 2 -  4 * (r(1) * data%c1 + rb(1) * data%c0)
          if (delta > 0) then
             sqrt_delta = sqrt (delta)
             lx = (data%log - sqrt_delta) / 2
          else
             sf_int%status = SF_FAILED_KINEMATICS
             f = 0
             return
          end if
          x(1) = exp (lx)
          f = x(1) * data%dc / sqrt_delta
        end associate
     else
        x(1) = r(1)
        if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then
           f = 1
        else
           sf_int%status = SF_FAILED_KINEMATICS
           f = 0
           return
        end if
     end if
     xb(1) = 1 - x(1)
     if (size(x) == 3) then
        x(2:3) = r(2:3)
        xb(2:3) = rb(2:3)
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_DONE_KINEMATICS)
        sf_int%x = x(1)
        sf_int%xb= xb(1)
        sf_int%E  = energy (sf_int%get_momentum (1))
     case (SF_FAILED_KINEMATICS)
        sf_int%x = 0
        sf_int%xb= 0
        f = 0
     end select
   end subroutine epa_complete_kinematics
 
 @ %def epa_complete_kinematics
 @ Overriding the default method: we compute the [[x]] array from the
 momentum configuration.  In the specific case of EPA, we also set the
 internally stored $x$ and $\bar x$ values, so they can be used in the
 following routine.
 
 Note: the extraction of $\bar x$ is not numerically safe, but it cannot
 be as long as the base [[recover_x]] is not.
 <<SF epa: epa: TBP>>=
   procedure :: recover_x => sf_epa_recover_x
 <<SF epa: sub interfaces>>=
     module subroutine sf_epa_recover_x (sf_int, x, xb, x_free)
       class(epa_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_epa_recover_x
 <<SF epa: procedures>>=
   module subroutine sf_epa_recover_x (sf_int, x, xb, x_free)
     class(epa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
     sf_int%xb = xb(1)
   end subroutine sf_epa_recover_x
 
 @ %def sf_epa_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF epa: epa: TBP>>=
   procedure :: inverse_kinematics => epa_inverse_kinematics
 <<SF epa: sub interfaces>>=
     module subroutine epa_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(epa_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine epa_inverse_kinematics
 <<SF epa: procedures>>=
   module subroutine epa_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(epa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default) :: lx, delta, sqrt_delta, c
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        associate (data => sf_int%data)
          lx = log (x(1))
          sqrt_delta = data%log - 2 * lx
          delta = sqrt_delta ** 2
          c = (data%log ** 2 - delta) / 4
          r (1) = (c - data%c0) / data%dc
          rb(1) = (data%c1 - c) / data%dc
          f = x(1) * data%dc / sqrt_delta
        end associate
     else
        r (1) = x(1)
        rb(1) = xb(1)
        if (sf_int%data%x_min < x(1) .and. x(1) < sf_int%data%x_max) then
           f = 1
        else
           f = 0
        end if
     end if
     if (size(r) == 3) then
        r (2:3) = x(2:3)
        rb(2:3) = xb(2:3)
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
     sf_int%E  = energy (sf_int%get_momentum (1))
   end subroutine epa_inverse_kinematics
 
 @ %def epa_inverse_kinematics
 @
 \subsection{EPA application}
 For EPA, we can in principle compute kinematics and function value in
 a single step. In order to be able to reweight events, kinematics and
 structure function application are separated. This function works on a
 single beam, assuming that the input momentum has been set.  We need
 three random numbers as input: one for $x$, and two for the polar and
 azimuthal angles. Alternatively, for the no-recoil case, we can skip
 $p_T$ generation; in this case, we only need one.
 
 For obtaining splitting kinematics, we rely on the assumption that all
 in-particles are mass-degenerate (or there is only one), so the
 generated $x$ values are identical.
 
 Fix 2020-03-10: Divide by two if there is polarization.
 In the polarized case, the outgoing electron/positron
 retains the incoming polarization.  The latter is summed over
 when convoluting with the beam, but there are still two
 states with different outgoing polarization but identical
 structure-function value.  This leads to double-counting for the
 overall cross section.
 
 Fix 2022-02-18: The above fix was wrong!  The structure function was divided
 by 4 because there are four entries in the complete electron density
 matrix.  Now it is divided by 2 if there is more than one entry, unchanged
 otherwise.
 <<SF epa: epa: TBP>>=
   procedure :: apply => epa_apply
 <<SF epa: sub interfaces>>=
     module subroutine epa_apply (sf_int, scale, negative_sf, rescale, i_sub)
       class(epa_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine epa_apply
 <<SF epa: procedures>>=
   module subroutine epa_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(epa_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: x, xb, qminsq, qmaxsq, f, E, m2
     associate (data => sf_int%data)
       x = sf_int%x
       xb= sf_int%xb
       E = sf_int%E
       m2 = data%mass ** 2
       qminsq = max (x ** 2 / xb * data%mass ** 2, data%q_min ** 2)
       select case (data%mode)
       case (0)
          qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2)
          if (qminsq < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) &
                  - (1 - x / 2) ** 2 &
                  * log ((x**2 + qmaxsq / E ** 2) / (x**2 + qminsq / E ** 2)) &
                  - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
          else
             f = 0
          end if
       case (1)
          qmaxsq = min (4 * xb * E ** 2, data%q_max ** 2)
          if (qminsq < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / qminsq) &
                  - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
          else
             f = 0
          end if
       case (2)
          qmaxsq = data%q_max ** 2
          if (data%mass ** 2 < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / m2) &
                  - x ** 2 * data%mass ** 2 / qminsq * (1 - qminsq / qmaxsq))
          else
             f = 0
          end if
       case (3)
          qmaxsq = data%q_max ** 2
          if (data%mass ** 2 < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / m2) &
                  - x ** 2 * (1 - m2 / qmaxsq))
          else
             f = 0
          end if
       case (4)
          qmaxsq = data%q_max ** 2
          if (data%mass ** 2 < qmaxsq) then
             f = data%a / x &
                  * ((xb + x ** 2 / 2) * log (qmaxsq / m2))
          else
             f = 0
          end if
       end select
       if (sf_int%get_n_matrix_elements () > 1) then
          f = f / 2
       end if
       call sf_int%set_matrix_element &
            (cmplx (f, kind=default) * sf_int%charge2)
     end associate
     sf_int%status = SF_EVALUATED
   end subroutine epa_apply
 
 @ %def epa_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_epa_ut.f90]]>>=
 <<File header>>
 
 module sf_epa_ut
   use unit_tests
   use sf_epa_uti
 
 <<Standard module head>>
 
 <<SF epa: public test>>
 
 contains
 
 <<SF epa: test driver>>
 
 end module sf_epa_ut
 @ %def sf_epa_ut
 @
 <<[[sf_epa_uti.f90]]>>=
 <<File header>>
 
 module sf_epa_uti
 
 <<Use kinds>>
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_aux
   use sf_base
 
   use sf_epa
 
 <<Standard module head>>
 
 <<SF epa: test declarations>>
 
 contains
 
 <<SF epa: tests>>
 
 end module sf_epa_uti
 @ %def sf_epa_ut
 @ API: driver for the unit tests below.
 <<SF epa: public test>>=
   public :: sf_epa_test
 <<SF epa: test driver>>=
   subroutine sf_epa_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF epa: execute tests>>
   end subroutine sf_epa_test
 
 @ %def sf_epa_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF epa: execute tests>>=
   call test (sf_epa_1, "sf_epa_1", &
        "structure function configuration", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_1
 <<SF epa: tests>>=
   subroutine sf_epa_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_epa_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in = ELECTRON
 
     allocate (epa_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 0.000511_default, recoil = .false.)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_1"
 
   end subroutine sf_epa_1
 
 @ %def sf_epa_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the EPA
 structure function.
 <<SF epa: execute tests>>=
   call test (sf_epa_2, "sf_epa_2", &
        "structure function instance", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_2
 <<SF epa: tests>>=
   subroutine sf_epa_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_epa_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (epa_data_t :: data)
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 0.000511_default, recoil = .false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, no EPA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., &
          set_momenta=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EPA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_2"
 
   end subroutine sf_epa_2
 
 @ %def sf_epa_2
 @
 \subsubsection{Standard mapping}
 Construct and display a structure function object based on the EPA
 structure function, applying the standard single-particle mapping.
 <<SF epa: execute tests>>=
   call test (sf_epa_3, "sf_epa_3", &
        "apply mapping", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_3
 <<SF epa: tests>>=
   subroutine sf_epa_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_epa_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (epa_data_t :: data)
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 0.000511_default, recoil = .false.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, with EPA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
          set_momenta=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EPA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_3"
 
   end subroutine sf_epa_3
 
 @ %def sf_epa_3
 @
 \subsubsection{Non-collinear case}
 Construct and display a structure function object based on the EPA
 structure function.
 <<SF epa: execute tests>>=
   call test (sf_epa_4, "sf_epa_4", &
        "non-collinear", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_4
 <<SF epa: tests>>=
   subroutine sf_epa_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E, m
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_epa_4"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv%init (ELECTRON, model)
     pdg_in = ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (epa_data_t :: data)
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 5.0_default, recoil = .true.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500, me = 5 GeV"
     write (u, "(A)")
     E = 500
     m = 5
     k = vector4_moving (E, sqrt (E**2 - m**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.5/0.5/0.25, with EPA mapping, "
     write (u, "(A)")  "          non-coll., keeping energy, me = 5 GeV"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.5_default, 0.5_default, 0.25_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%pacify_momenta (1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
          set_momenta=.true.)
     call sf_int%pacify_momenta (1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EPA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u, testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_4"
 
   end subroutine sf_epa_4
 
 @ %def sf_epa_4
 @
 \subsubsection{Structure function for multiple flavors}
 Construct and display a structure function object based on the EPA
 structure function.  The incoming state has multiple particles with
 non-uniform charge.
 <<SF epa: execute tests>>=
   call test (sf_epa_5, "sf_epa_5", &
        "multiple flavors", &
        u, results)
 <<SF epa: test declarations>>=
   public :: sf_epa_5
 <<SF epa: tests>>=
   subroutine sf_epa_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_epa_5"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (1, model)
     pdg_in = [1, 2, -1, -2]
 
     call reset_interaction_counter ()
 
     allocate (epa_data_t :: data)
     select type (data)
     type is (epa_data_t)
        call data%init (model, 0, pdg_in, 1./137._default, 0.01_default, &
             10._default, 100._default, 0.000511_default, recoil = .false.)
        call data%check ()
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, no EPA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EPA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_epa_5"
 
   end subroutine sf_epa_5
 
 @ %def sf_epa_5
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{EWA}
 
 <<[[sf_ewa.f90]]>>=
 <<File header>>
 
 module sf_ewa
 
 <<Use kinds>>
 <<Use strings>>
   use pdg_arrays
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use polarizations
   use interactions
   use sf_aux
   use sf_base
 
 <<Standard module head>>
 
 <<SF ewa: public>>
 
 <<SF ewa: parameters>>
 
 <<SF ewa: types>>
 
   interface
 <<SF ewa: sub interfaces>>
   end interface
 
 contains
 
 <<SF ewa: main procedures>>
 
 end module sf_ewa
 @ %def sf_ewa
 @
 <<[[sf_ewa_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_ewa) sf_ewa_s
 
   use io_units
   use constants, only: pi
   use format_defs, only: FMT_17, FMT_19
   use numeric_utils
   use diagnostics
   use physics_defs, only: W_BOSON, Z_BOSON
   use lorentz
   use colors
 
   implicit none
 
 contains
 
 <<SF ewa: procedures>>
 
 end submodule sf_ewa_s
 
 @ %def sf_ewa_s
 @
 \subsection{Physics}
 The EWA structure function for a $Z$ or $W$ inside a fermion (lepton
 or quark) depends on the vector-boson polarization.  We distinguish
 transversal ($\pm$) and longitudinal ($0$) polarization.
 \begin{align}
   F_{+}(x) &= \frac{1}{16\pi^2}\,\frac{(v-a)^2 + (v+a)^2\bar x^2}{x}
   \left[
   \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right)
   -
   \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
   \right]
   \\
   F_{-}(x) &= \frac{1}{16\pi^2}\,\frac{(v+a)^2 + (v-a)^2\bar x^2}{x}
   \left[
   \ln\left(\frac{p_{\perp,\textrm{max}}^2 + \bar x M^2}{\bar x M^2}\right)
   -
   \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
   \right]
   \\
   F_0(x) &= \frac{v^2+a^2}{8\pi^2}\,\frac{2\bar x}{x}\,
   \frac{p_{\perp,\textrm{max}}^2}{p_{\perp,\textrm{max}}^2 + \bar x M^2}
 \end{align}
 where $p_{\perp,\textrm{max}}$ is the cutoff in transversal momentum, $M$ is
 the vector-boson mass, $v$ and $a$ are the vector and axial-vector
 couplings, and $\bar x\equiv 1-x$.  Note that the longitudinal
 structure function is finite for large cutoff, while the transversal
 structure function is logarithmically divergent.
 
 The maximal transverse momentum is given by the kinematical limit, it is
 \begin{equation}
 p_{\perp,\textrm{max}} = \bar x \sqrt{s}/2.
 \end{equation}
 The vector and axial couplings for a fermion branching into a $W$ are
 \begin{align}
   v_W &= \frac{g}{2\sqrt 2},
 & a_W &= \frac{g}{2\sqrt 2}.
 \end{align}
 For $Z$ emission, this is replaced by
 \begin{align}
   v_Z &= \frac{g}{2\cos\theta_w}\left(t_3 - 2q\sin^2\theta_w\right),
 & a_Z &= \frac{g}{2\cos\theta_w}t_3,
 \end{align}
 where $t_3=\pm\frac12$ is the fermion isospin, and $q$ its charge.
 
 For an initial antifermion, the signs of the axial couplings are
 inverted.  Note that a common sign change of $v$ and $a$ is
 irrelevant.
 
 %% Differentiating with respect to the cutoff, we get structure functions
 %% \begin{align}
 %%   f_{W,\pm}(x,p_T) &= \frac{g^2}{16\pi^2}\,
 %%   \frac{1+\bar x^2}{x}
 %%   \frac{p_\perp}{p_\perp^2 + \bar x M^2}
 %%   \\
 %%   f_{W,0}(x,p_T) &= \frac{g^2}{16\pi^2}\,
 %%   \frac{2\bar x}{x}\,
 %%   \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2}
 %%   \\
 %%   F_{Z,\pm}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}
 %%   \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\,
 %%   \frac{1+\bar x^2}{x}
 %%   \frac{p_\perp}{p_\perp^2 + \bar x M^2}
 %%   \\
 %%   F_{Z,0}(x,p_T) &= \frac{g^2}{16\pi^2\cos\theta_w^2}\,
 %%   \left[(t_3^f-2q^2\sin\theta_w^2)^2 + (t_3^f)^2\right]\,
 %%   \frac{2\bar x}{x}\,
 %%   \frac{p_\perp \bar xM^2}{(p_\perp^2 + \bar x M^2)^2}
 %% \end{align}
 %% Here, $t_3^f$ is the $SU(2)_L$ quantum number of the fermion
 %% $(\pm\frac12)$, and $q^f$ is the fermion charge in units of the
 %% positron charge.
 
 The EWA depends on the parameters $g$, $\sin^2\theta_w$, $M_W$, and
 $M_Z$.  These can all be taken from the SM input, and the prefactors
 are calculated from those and the incoming particle type.
 
 Since these structure functions have a $1/x$ singularity (which is not
 really relevant in practice, however, since the vector boson mass is
 finite), we map this singularity allowing for nontrivial $x$ bounds:
 \begin{equation}
   x = \exp(\bar r\ln x_0 + r\ln x_1)
 \end{equation}
 such that
 \begin{equation}
   \int_{x_0}^{x_1}\frac{dx}{x} = (\ln x_1 - \ln x_0)\int_0^1 dr.
 \end{equation}
 
 As a user parameter, we have the cutoff $p_{\perp,\textrm{max}}$.
 The divergence $1/x$ also requires a $x_0$ cutoff; and for
 completeness we introduce a corresponding $x_1$.  Physically, the
 minimal sensible value of $x$ is $M^2/s$, although the approximation
 loses its value already at higher $x$ values.
 
 
 \subsection{The EWA data block}
 The EWA parameters are: $p_{T,\rm max}$, $c_V$, $c_A$, and
 $m$. Instead of $m$ we can use the incoming particle PDG code as
 input; from this we can deduce the mass and charges. In the
 initialization phase it is not yet determined whether a $W$ or a $Z$
 is radiated, hence we set the vector and axial-vector couplings equal
 to the common prefactors $g/2 = e/2/\sin\theta_W$.
 
 In principle, for EWA it would make sense to allow the user to also
 set the upper bound for $x$, $x_{\rm max}$, but we fix it to one here.
 <<SF ewa: public>>=
   public :: ewa_data_t
 <<SF ewa: types>>=
   type, extends(sf_data_t) :: ewa_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(:), allocatable :: flv_in
      type(flavor_t), dimension(:), allocatable :: flv_out
      real(default) :: pt_max
      real(default) :: sqrts
      real(default) :: x_min
      real(default) :: x_max
      real(default) :: mass
      real(default) :: m_out
      real(default) :: q_min
      real(default) :: cv
      real(default) :: ca
      real(default) :: costhw
      real(default) :: sinthw
      real(default) :: mW
      real(default) :: mZ
      real(default) :: coeff
      logical :: mass_set = .false.
      logical :: recoil = .false.
      logical :: keep_energy = .false.
      integer :: id = 0
      integer :: error = NONE
    contains
    <<SF ewa: ewa data: TBP>>
   end type ewa_data_t
 
 @ %def ewa_data_t
 @ Error codes
 <<SF ewa: parameters>>=
   integer, parameter :: NONE = 0
   integer, parameter :: ZERO_QMIN = 1
   integer, parameter :: Q_MAX_TOO_SMALL = 2
   integer, parameter :: ZERO_XMIN = 3
   integer, parameter :: MASS_MIX = 4
   integer, parameter :: ZERO_SW = 5
   integer, parameter :: ISOSPIN_MIX = 6
   integer, parameter :: WRONG_PRT = 7
   integer, parameter :: MASS_MIX_OUT = 8
   integer, parameter :: NO_EWA = 9
 <<SF ewa: ewa data: TBP>>=
   procedure :: init => ewa_data_init
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, &
           sqrts, recoil, keep_energy, mass)
       class(ewa_data_t), intent(inout) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), intent(in) :: pdg_in
       real(default), intent(in) :: x_min, pt_max, sqrts
       logical, intent(in) :: recoil, keep_energy
       real(default), intent(in), optional :: mass
     end subroutine ewa_data_init
 <<SF ewa: procedures>>=
   module subroutine ewa_data_init (data, model, pdg_in, x_min, pt_max, &
         sqrts, recoil, keep_energy, mass)
     class(ewa_data_t), intent(inout) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     real(default), intent(in) :: x_min, pt_max, sqrts
     logical, intent(in) :: recoil, keep_energy
     real(default), intent(in), optional :: mass
     real(default) :: g, ee
     integer :: n_flv, i
     data%model => model
     if (.not. any (pdg_in .match. &
          [1,2,3,4,5,6,11,13,15,-1,-2,-3,-4,-5,-6,-11,-13,-15])) then
        data%error = WRONG_PRT;  return
     end if
     n_flv = pdg_in%get_length ()
     allocate (data%flv_in (n_flv))
     allocate (data%flv_out(n_flv))
     do i = 1, n_flv
        call data%flv_in(i)%init (pdg_in%get (i), model)
     end do
     data%pt_max = pt_max
     data%sqrts = sqrts
     data%x_min = x_min
     data%x_max = 1
     if (vanishes (data%x_min)) then
        data%error = ZERO_XMIN;  return
     end if
     select case (char (data%model%get_name ()))
     case ("QCD","QED","Test")
        data%error = NO_EWA;  return
     end select
     ee = data%model%get_real (var_str ("ee"))
     data%sinthw = data%model%get_real (var_str ("sw"))
     data%costhw = data%model%get_real (var_str ("cw"))
     data%mZ = data%model%get_real (var_str ("mZ"))
     data%mW = data%model%get_real (var_str ("mW"))
     if (data%sinthw /= 0) then
        g = ee / data%sinthw
     else
        data%error = ZERO_SW;  return
     end if
     data%cv = g / 2._default
     data%ca = g / 2._default
     data%coeff = 1._default / (8._default * PI**2)
     data%recoil = recoil
     data%keep_energy = keep_energy
     if (present (mass)) then
        data%mass = mass
        data%m_out = mass
        data%mass_set = .true.
     else
        data%mass = data%flv_in(1)%get_mass ()
        if (any (data%flv_in%get_mass () /= data%mass)) then
           data%error = MASS_MIX;  return
        end if
     end if
   end subroutine ewa_data_init
 
 @ %def ewa_data_init
 @ Set the vector boson ID for distinguishing $W$ and $Z$ bosons.
 <<SF ewa: ewa data: TBP>>=
   procedure :: set_id => ewa_set_id
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_set_id (data, id)
       class(ewa_data_t), intent(inout) :: data
       integer, intent(in) :: id
     end subroutine ewa_set_id
 <<SF ewa: procedures>>=
   module subroutine ewa_set_id (data, id)
     class(ewa_data_t), intent(inout) :: data
     integer, intent(in) :: id
     integer :: i, isospin, pdg
     if (.not. allocated (data%flv_in)) &
          call msg_bug ("EWA: incoming particles not set")
     data%id = id
     select case (data%id)
     case (23)
        data%m_out = data%mass
        data%flv_out = data%flv_in
     case (24)
        do i = 1, size (data%flv_in)
           pdg = data%flv_in(i)%get_pdg ()
           isospin = data%flv_in(i)%get_isospin_type ()
           if (isospin > 0) then
              !!! up-type quark or neutrinos
              if (data%flv_in(i)%is_antiparticle ()) then
                 call data%flv_out(i)%init (pdg + 1, data%model)
              else
                 call data%flv_out(i)%init (pdg - 1, data%model)
              end if
           else
              !!! down-type quark or lepton
              if (data%flv_in(i)%is_antiparticle ()) then
                 call data%flv_out(i)%init (pdg - 1, data%model)
              else
                 call data%flv_out(i)%init (pdg + 1, data%model)
              end if
           end if
        end do
        if (.not. data%mass_set) then
           data%m_out = data%flv_out(1)%get_mass ()
           if (any (data%flv_out%get_mass () /= data%m_out)) then
              data%error = MASS_MIX_OUT;  return
           end if
        end if
     end select
   end subroutine ewa_set_id
 
 @ %def ewa_set_id
 @ Handle error conditions.  Should always be done after
 initialization, unless we are sure everything is ok.
 <<SF ewa: ewa data: TBP>>=
   procedure :: check => ewa_data_check
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_data_check (data)
       class(ewa_data_t), intent(in) :: data
     end subroutine ewa_data_check
 <<SF ewa: procedures>>=
   module subroutine ewa_data_check (data)
     class(ewa_data_t), intent(in) :: data
     select case (data%error)
     case (WRONG_PRT)
        call msg_fatal ("EWA structure function only accessible for " &
             // "SM quarks and leptons.")
     case (NO_EWA)
        call msg_fatal ("EWA structure function not available for model " &
             // char (data%model%get_name ()))
     case (ZERO_SW)
        call msg_fatal ("EWA: Vanishing value of sin(theta_w)")
     case (ZERO_QMIN)
        call msg_fatal ("EWA: Particle mass is zero")
     case (Q_MAX_TOO_SMALL)
        call msg_fatal ("EWA: Particle mass exceeds Qmax")
     case (ZERO_XMIN)
        call msg_fatal ("EWA: x_min must be larger than zero")
     case (MASS_MIX)
        call msg_fatal ("EWA: incoming particle masses must be uniform")
     case (MASS_MIX_OUT)
        call msg_fatal ("EWA: outgoing particle masses must be uniform")
     case (ISOSPIN_MIX)
        call msg_fatal ("EWA: incoming particle isospins must be uniform")
     end select
   end subroutine ewa_data_check
 
 @ %def ewa_data_check
 @ Output
 <<SF ewa: ewa data: TBP>>=
   procedure :: write => ewa_data_write
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_data_write (data, unit, verbose)
       class(ewa_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine ewa_data_write
 <<SF ewa: procedures>>=
   module subroutine ewa_data_write (data, unit, verbose)
     class(ewa_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "EWA data:"
     if (allocated (data%flv_in) .and. allocated (data%flv_out)) then
        write (u, "(3x,A)", advance="no") "  flavor(in)  =  "
        do i = 1, size (data%flv_in)
           if (i > 1)  write (u, "(',',1x)", advance="no")
           call data%flv_in(i)%write (u)
        end do
        write (u, *)
        write (u, "(3x,A)", advance="no") "  flavor(out) =  "
        do i = 1, size (data%flv_out)
           if (i > 1)  write (u, "(',',1x)", advance="no")
           call data%flv_out(i)%write (u)
        end do
        write (u, *)
        write (u, "(3x,A," // FMT_19 // ")") "  x_min     = ", data%x_min
        write (u, "(3x,A," // FMT_19 // ")") "  x_max     = ", data%x_max
        write (u, "(3x,A," // FMT_19 // ")") "  pt_max    = ", data%pt_max
        write (u, "(3x,A," // FMT_19 // ")") "  sqrts     = ", data%sqrts
        write (u, "(3x,A," // FMT_19 // ")") "  mass      = ", data%mass
        write (u, "(3x,A," // FMT_19 // ")") "  cv        = ", data%cv
        write (u, "(3x,A," // FMT_19 // ")") "  ca        = ", data%ca
        write (u, "(3x,A," // FMT_19 // ")") "  coeff     = ", data%coeff
        write (u, "(3x,A," // FMT_19 // ")") "  costhw    = ", data%costhw
        write (u, "(3x,A," // FMT_19 // ")") "  sinthw    = ", data%sinthw
        write (u, "(3x,A," // FMT_19 // ")") "  mZ        = ", data%mZ
        write (u, "(3x,A," // FMT_19 // ")") "  mW        = ", data%mW
        write (u, "(3x,A,L2)")      "  recoil    = ", data%recoil
        write (u, "(3x,A,L2)")      "  keep en.  = ", data%keep_energy
        write (u, "(3x,A,I2)")      "  PDG (VB)  = ", data%id
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine ewa_data_write
 
 @ %def ewa_data_write
 @ The number of parameters is one for collinear splitting, in case the
 [[recoil]] option is set, we take the recoil into account.
 <<SF ewa: ewa data: TBP>>=
   procedure :: get_n_par => ewa_data_get_n_par
 <<SF ewa: sub interfaces>>=
     module function ewa_data_get_n_par (data) result (n)
       class(ewa_data_t), intent(in) :: data
       integer :: n
     end function ewa_data_get_n_par
 <<SF ewa: procedures>>=
   module function ewa_data_get_n_par (data) result (n)
     class(ewa_data_t), intent(in) :: data
     integer :: n
     if (data%recoil) then
        n = 3
     else
        n = 1
     end if
   end function ewa_data_get_n_par
 
 @ %def ewa_data_get_n_par
 @ Return the outgoing particles PDG codes. This depends, whether this
 is a charged-current or neutral-current interaction.
 <<SF ewa: ewa data: TBP>>=
   procedure :: get_pdg_out => ewa_data_get_pdg_out
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_data_get_pdg_out (data, pdg_out)
       class(ewa_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine ewa_data_get_pdg_out
 <<SF ewa: procedures>>=
   module subroutine ewa_data_get_pdg_out (data, pdg_out)
     class(ewa_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     integer :: i, n_flv
     if (allocated (data%flv_out)) then
        n_flv = size (data%flv_out)
     else
        n_flv = 0
     end if
     allocate (pdg1 (n_flv))
     do i = 1, n_flv
        pdg1(i) = data%flv_out(i)%get_pdg ()
     end do
     pdg_out(1) = pdg1
   end subroutine ewa_data_get_pdg_out
 
 @ %def ewa_data_get_pdg_out
 @ Allocate the interaction record. Due to a gfortran 7/8/9 bug, this
 has to remain in the main module.
 <<SF ewa: ewa data: TBP>>=
   procedure :: allocate_sf_int => ewa_data_allocate_sf_int
 <<SF ewa: main procedures>>=
   subroutine ewa_data_allocate_sf_int (data, sf_int)
     class(ewa_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (ewa_t :: sf_int)
   end subroutine ewa_data_allocate_sf_int
 
 @ %def ewa_data_allocate_sf_int
 @
 \subsection{The EWA object}
 The [[ewa_t]] data type is a $1\to 2$ interaction.  We should be able
 to handle several flavors in parallel, since EWA is not necessarily
 applied immediately after beam collision:  $W/Z$ bosons may be radiated
 from quarks.  In that case, the partons are massless and $q_{\rm min}$
 applies instead, so we do not need to generate several kinematical
 configurations in parallel.
 
 The particles are ordered as (incoming, radiated, W/Z), where the
 W/Z initiates the hard interaction.
 
 In the case of EPA, we generated an unpolarized photon and transferred
 initial polarization to the radiated parton.  Color is transferred in
 the same way. I do not know whether the same can/should be done for
 EWA, as the structure functions depend on the W/Z polarization. If we
 are having $Z$ bosons, both up- and down-type fermions can
 participate. Otherwise, with a $W^+$ an up-type fermion is transferred
 to a down-type fermion, and the other way round.
 <<SF ewa: types>>=
   type, extends (sf_int_t) :: ewa_t
      type(ewa_data_t), pointer :: data => null ()
      real(default) :: x  = 0
      real(default) :: xb = 0
      integer :: n_me = 0
      real(default), dimension(:), allocatable :: cv
      real(default), dimension(:), allocatable :: ca
    contains
    <<SF ewa: ewa: TBP>>
   end type ewa_t
 
 @ %def ewa_t
 @ Type string: has to be here, but there is no string variable on which EWA
 depends. Hence, a dummy routine.
 <<SF ewa: ewa: TBP>>=
   procedure :: type_string => ewa_type_string
 <<SF ewa: sub interfaces>>=
     module function ewa_type_string (object) result (string)
       class(ewa_t), intent(in) :: object
       type(string_t) :: string
     end function ewa_type_string
 <<SF ewa: procedures>>=
   module function ewa_type_string (object) result (string)
     class(ewa_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "EWA: equivalent W/Z approx."
     else
        string = "EWA: [undefined]"
     end if
   end function ewa_type_string
 
 @ %def ewa_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF ewa: ewa: TBP>>=
   procedure :: write => ewa_write
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_write (object, unit, testflag)
       class(ewa_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine ewa_write
 <<SF ewa: procedures>>=
   module subroutine ewa_write (object, unit, testflag)
     class(ewa_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_17 // ")")  "x =", object%x
           write (u, "(3x,A," // FMT_17 // ")")  "xb=", object%xb
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "EWA data: [undefined]"
     end if
   end subroutine ewa_write
 
 @ %def ewa_write
 @ The current implementation requires uniform isospin for all incoming
 particles, therefore we need to probe only the first one.
 <<SF ewa: ewa: TBP>>=
   procedure :: init => ewa_init
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_init (sf_int, data)
       class(ewa_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine ewa_init
 <<SF ewa: procedures>>=
   module subroutine ewa_init (sf_int, data)
     class(ewa_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     integer, dimension(3) :: hel_lock
     type(polarization_t), target :: pol
     type(quantum_numbers_t), dimension(1) :: qn_fc, qn_fc_fin
     type(flavor_t) :: flv_z, flv_wp, flv_wm
     type(color_t) :: col0
     type(quantum_numbers_t) :: qn_hel, qn_z, qn_wp, qn_wm, qn, qn_rad, qn_w
     type(polarization_iterator_t) :: it_hel
     integer :: i, isospin
     select type (data)
     type is (ewa_data_t)
        mask = quantum_numbers_mask (.false., .false., &
             mask_h = [.false., .false., .true.])
        hel_lock = [2, 1, 0]
        call col0%init ()
        select case (data%id)
        case (23)
           !!! Z boson, flavor is not changing
           call sf_int%base_init (mask, [data%mass**2], [data%mass**2], &
                [data%mZ**2], hel_lock = hel_lock)
           sf_int%data => data
           call flv_z%init (Z_BOSON, data%model)
           call qn_z%init (flv_z, col0)
           do i = 1, size (data%flv_in)
              call pol%init_generic (data%flv_in(i))
              call qn_fc(1)%init ( &
                   flv = data%flv_in(i), &
                   col = color_from_flavor (data%flv_in(i), 1))
              call it_hel%init (pol)
              do while (it_hel%is_valid ())
                 qn_hel = it_hel%get_quantum_numbers ()
                 qn = qn_hel .merge. qn_fc(1)
                 qn_rad = qn
                 call qn_rad%tag_radiated ()
                 call sf_int%add_state ([qn, qn_rad, qn_z])
                 call it_hel%advance ()
              end do
              !  call pol%final ()
           end do
        case (24)
           call sf_int%base_init (mask, [data%mass**2], [data%m_out**2], &
                [data%mW**2], hel_lock = hel_lock)
           sf_int%data => data
           call flv_wp%init (W_BOSON, data%model)
           call flv_wm%init (- W_BOSON, data%model)
           call qn_wp%init (flv_wp, col0)
           call qn_wm%init (flv_wm, col0)
           do i = 1, size (data%flv_in)
              isospin = data%flv_in(i)%get_isospin_type ()
              if (isospin > 0) then
                 !!! up-type quark or neutrinos
                 if (data%flv_in(i)%is_antiparticle ()) then
                    qn_w = qn_wm
                 else
                    qn_w = qn_wp
                 end if
              else
                 !!! down-type quark or lepton
                 if (data%flv_in(i)%is_antiparticle ()) then
                    qn_w = qn_wp
                 else
                    qn_w = qn_wm
                 end if
              end if
              call pol%init_generic (data%flv_in(i))
              call qn_fc(1)%init ( &
                   flv = data%flv_in(i), &
                   col = color_from_flavor (data%flv_in(i), 1))
              call qn_fc_fin(1)%init ( &
                   flv = data%flv_out(i), &
                   col = color_from_flavor (data%flv_out(i), 1))
              call it_hel%init (pol)
              do while (it_hel%is_valid ())
                 qn_hel = it_hel%get_quantum_numbers ()
                 qn = qn_hel .merge. qn_fc(1)
                 qn_rad = qn_hel .merge. qn_fc_fin(1)
                 call qn_rad%tag_radiated ()
                 call sf_int%add_state ([qn, qn_rad, qn_w])
                 call it_hel%advance ()
              end do
              ! call pol%final ()
           end do
        case default
           call msg_fatal ("EWA initialization failed: wrong particle type.")
        end select
        call sf_int%freeze ()
        if (data%keep_energy) then
           sf_int%on_shell_mode = KEEP_ENERGY
        else
           sf_int%on_shell_mode = KEEP_MOMENTUM
        end if
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
     end select
   end subroutine ewa_init
 
 @ %def ewa_init
 @ Prepare the coupling arrays.  This is separate from the previous routine since
 the state matrix may be helicity-contracted.
 <<SF ewa: ewa: TBP>>=
   procedure :: setup_constants => ewa_setup_constants
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_setup_constants (sf_int)
       class(ewa_t), intent(inout), target :: sf_int
     end subroutine ewa_setup_constants
 <<SF ewa: procedures>>=
   module subroutine ewa_setup_constants (sf_int)
     class(ewa_t), intent(inout), target :: sf_int
     type(state_iterator_t) :: it
     type(flavor_t) :: flv
     real(default) :: q, t3
     integer :: i
     sf_int%n_me = sf_int%get_n_matrix_elements ()
     allocate (sf_int%cv (sf_int%n_me))
     allocate (sf_int%ca (sf_int%n_me))
     associate (data => sf_int%data)
       select case (data%id)
       case (23)
          call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
          do while (it%is_valid ())
             i = it%get_me_index ()
             flv = it%get_flavor (1)
             q = flv%get_charge ()
             t3 = flv%get_isospin ()
             if (flv%is_antiparticle ()) then
                sf_int%cv(i) = - data%cv &
                     * (t3 - 2._default * q * data%sinthw**2) / data%costhw
                sf_int%ca(i) = data%ca *  t3 / data%costhw
             else
                sf_int%cv(i) = data%cv &
                     * (t3 - 2._default * q * data%sinthw**2) / data%costhw
                sf_int%ca(i) = data%ca *  t3 / data%costhw
             end if
             call it%advance ()
          end do
       case (24)
          call it%init (sf_int%interaction_t%get_state_matrix_ptr ())
          do while (it%is_valid ())
             i = it%get_me_index ()
             flv = it%get_flavor (1)
             if (flv%is_antiparticle ()) then
                sf_int%cv(i) = data%cv / sqrt(2._default)
                sf_int%ca(i) = - data%ca / sqrt(2._default)
             else
                sf_int%cv(i) = data%cv / sqrt(2._default)
                sf_int%ca(i) = data%ca / sqrt(2._default)
             end if
             call it%advance ()
          end do
       end select
     end associate
     sf_int%status = SF_INITIAL
   end subroutine ewa_setup_constants
 
 @ %def ewa_setup_constants
 @
 \subsection{Kinematics}
 Set kinematics.  The EWA structure function allows for a
 straightforward mapping of the unit interval.  So, to leading order,
 the structure function value is unity, but the $x$ value is
 transformed.  Higher orders affect the function value.
 If [[map]] is unset, the $r$ and $x$ values coincide, and the Jacobian
 $f(r)$ is trivial.
 
 If [[map]] is set, the exponential mapping for the $1/x$ singularity
 discussed above is applied.
 <<SF ewa: ewa: TBP>>=
   procedure :: complete_kinematics => ewa_complete_kinematics
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map)
       class(ewa_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine ewa_complete_kinematics
 <<SF ewa: procedures>>=
   module subroutine ewa_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(ewa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     real(default) :: e_1
     real(default) :: x0, x1, lx0, lx1, lx
     e_1 = energy (sf_int%get_momentum (1))
     if (sf_int%data%recoil) then
        select case (sf_int%data%id)
        case (23)
           x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1)
        case (24)
           x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1)
        end select
     else
        x0 = sf_int%data%x_min
     end if
     x1 = sf_int%data%x_max
     if ( x0 >= x1) then
        f = 0
        sf_int%status = SF_FAILED_KINEMATICS
        return
     end if
     if (map) then
        lx0 = log (x0)
        lx1 = log (x1)
        lx = lx1 * r(1) + lx0 * rb(1)
        x(1) = exp(lx)
        f = x(1) * (lx1 - lx0)
     else
        x(1) = r(1)
        if (x0 < x(1) .and. x(1) < x1) then
           f = 1
        else
           sf_int%status = SF_FAILED_KINEMATICS
           f = 0
           return
        end if
     end if
     xb(1) = 1 - x(1)
     if (size(x) == 3) then
        x(2:3) = r(2:3)
        xb(2:3) = rb(2:3)
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_DONE_KINEMATICS)
        sf_int%x  = x(1)
        sf_int%xb = xb(1)
     case (SF_FAILED_KINEMATICS)
        sf_int%x  = 0
        sf_int%xb = 0
        f = 0
     end select
   end subroutine ewa_complete_kinematics
 
 @ %def ewa_complete_kinematics
 @ Overriding the default method: we compute the [[x]] array from the
 momentum configuration.  In the specific case of EWA, we also set the
 internally stored $x$ and $\bar x$ values, so they can be used in the
 following routine.
 <<SF ewa: ewa: TBP>>=
   procedure :: recover_x => sf_ewa_recover_x
 <<SF ewa: sub interfaces>>=
     module subroutine sf_ewa_recover_x (sf_int, x, xb, x_free)
       class(ewa_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(inout), optional :: x_free
     end subroutine sf_ewa_recover_x
 <<SF ewa: procedures>>=
   module subroutine sf_ewa_recover_x (sf_int, x, xb, x_free)
     class(ewa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
     sf_int%xb = xb(1)
   end subroutine sf_ewa_recover_x
 
 @ %def sf_ewa_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF ewa: ewa: TBP>>=
   procedure :: inverse_kinematics => ewa_inverse_kinematics
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(ewa_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine ewa_inverse_kinematics
 <<SF ewa: procedures>>=
   module subroutine ewa_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(ewa_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default) :: x0, x1, lx0, lx1, lx, e_1
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     e_1 = energy (sf_int%get_momentum (1))
     if (sf_int%data%recoil) then
        select case (sf_int%data%id)
        case (23)
           x0 = max (sf_int%data%x_min, sf_int%data%mz / e_1)
        case (24)
           x0 = max (sf_int%data%x_min, sf_int%data%mw / e_1)
        end select
     else
        x0 = sf_int%data%x_min
     end if
     x1 = sf_int%data%x_max
     if (map) then
        lx0 = log (x0)
        lx1 = log (x1)
        lx = log (x(1))
        r(1)  = (lx - lx0) / (lx1 - lx0)
        rb(1) = (lx1 - lx) / (lx1 - lx0)
        f = x(1) * (lx1 - lx0)
     else
        r (1) = x(1)
        rb(1) = 1 - x(1)
        if (x0 < x(1) .and. x(1) < x1) then
           f = 1
        else
           f = 0
        end if
     end if
     if (size(r) == 3) then
        r (2:3) = x(2:3)
        rb(2:3) = xb(2:3)
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine ewa_inverse_kinematics
 
 @ %def ewa_inverse_kinematics
 @
 \subsection{EWA application}
 For EWA, we can compute kinematics and function value in a single
 step.  This function works on a single beam, assuming that the input
 momentum has been set.  We need four random numbers as input: one for
 $x$, one for $Q^2$, and two for the polar and azimuthal angles.
 Alternatively, we can skip $p_T$ generation; in this case, we only
 need one.
 
 For obtaining splitting kinematics, we rely on the assumption that all
 in-particles are mass-degenerate (or there is only one), so the
 generated $x$ values are identical.
 <<SF ewa: ewa: TBP>>=
   procedure :: apply => ewa_apply
 <<SF ewa: sub interfaces>>=
     module subroutine ewa_apply (sf_int, scale, negative_sf, rescale, i_sub)
       class(ewa_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine ewa_apply
 <<SF ewa: procedures>>=
   module subroutine ewa_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(ewa_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: x, xb, pt2, c1, c2
     real(default) :: cv, ca
     real(default) :: f, fm, fp, fL
     integer :: i
     associate (data => sf_int%data)
       x  = sf_int%x
       xb = sf_int%xb
       pt2 = min ((data%pt_max)**2, (xb * data%sqrts / 2)**2)
       select case (data%id)
       case (23)
          !!! Z boson structure function
          c1 = log (1 + pt2 / (xb * (data%mZ)**2))
          c2 = 1 / (1 + (xb * (data%mZ)**2) / pt2)
       case (24)
          !!! W boson structure function
          c1 = log (1 + pt2 / (xb * (data%mW)**2))
          c2 = 1 / (1 + (xb * (data%mW)**2) / pt2)
       end select
       do i = 1, sf_int%n_me
          cv = sf_int%cv(i)
          ca = sf_int%ca(i)
          fm = data%coeff * &
               ((cv + ca)**2 + ((cv - ca) * xb)**2) * (c1 - c2) / (2 * x)
          fp = data%coeff * &
               ((cv - ca)**2 + ((cv + ca) * xb)**2) * (c1 - c2) / (2 * x)
          fL = data%coeff * &
               (cv**2 + ca**2) * (2 * xb / x) * c2
          f = fp + fm + fL
          if (.not. vanishes (f)) then
             fp = fp / f
             fm = fm / f
             fL = fL / f
          end if
          call sf_int%set_matrix_element (i, cmplx (f, kind=default))
       end do
     end associate
     sf_int%status = SF_EVALUATED
   end subroutine ewa_apply
 
 @ %def ewa_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_ewa_ut.f90]]>>=
 <<File header>>
 
 module sf_ewa_ut
   use unit_tests
   use sf_ewa_uti
 
 <<Standard module head>>
 
 <<SF ewa: public test>>
 
 contains
 
 <<SF ewa: test driver>>
 
 end module sf_ewa_ut
 @ %def sf_ewa_ut
 @
 <<[[sf_ewa_uti.f90]]>>=
 <<File header>>
 
 module sf_ewa_uti
 
 <<Use kinds>>
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_aux
   use sf_base
 
   use sf_ewa
 
 <<Standard module head>>
 
 <<SF ewa: test declarations>>
 
 contains
 
 <<SF ewa: tests>>
 
 end module sf_ewa_uti
 @ %def sf_ewa_ut
 @ API: driver for the unit tests below.
 <<SF ewa: public test>>=
   public :: sf_ewa_test
 <<SF ewa: test driver>>=
   subroutine sf_ewa_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF ewa: execute tests>>
   end subroutine sf_ewa_test
 
 @ %def sf_ewa_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_1, "sf_ewa_1", &
        "structure function configuration", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_1
 <<SF ewa: tests>>=
   subroutine sf_ewa_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_ewa_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_sm_test ()
     pdg_in = 2
 
     allocate (ewa_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize for Z boson"
     write (u, "(A)")
 
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 5000._default, .false., .false.)
        call data%set_id (23)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize for W boson"
     write (u, "(A)")
 
     deallocate (data)
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 5000._default, .false., .false.)
        call data%set_id (24)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_1"
 
   end subroutine sf_ewa_1
 
 @ %def sf_ewa_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the EWA
 structure function.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_2, "sf_ewa_2", &
        "structure function instance", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_2
 <<SF ewa: tests>>=
   subroutine sf_ewa_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_ewa_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (2, model)
     pdg_in = 2
 
     call reset_interaction_counter ()
 
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 3000._default, .false., .true.)
        call data%set_id (24)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=1500"
     write (u, "(A)")
     E = 1500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, no EWA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false., &
          set_momenta=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EWA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_2"
 
   end subroutine sf_ewa_2
 
 @ %def sf_ewa_2
 @
 \subsubsection{Standard mapping}
 Construct and display a structure function object based on the EWA
 structure function, applying the standard single-particle mapping.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_3, "sf_ewa_3", &
        "apply mapping", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_3
 <<SF ewa: tests>>=
   subroutine sf_ewa_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_ewa_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (2, model)
     pdg_in = 2
 
     call reset_interaction_counter ()
 
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 3000._default, .false., .true.)
        call data%set_id (24)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=1500"
     write (u, "(A)")
     E = 1500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, with EWA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
          set_momenta=.true.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EWA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_3"
 
   end subroutine sf_ewa_3
 
 @ %def sf_ewa_3
 @
 \subsubsection{Non-collinear case}
 Construct and display a structure function object based on the EPA
 structure function.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_4, "sf_ewa_4", &
        "non-collinear", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_4
 <<SF ewa: tests>>=
   subroutine sf_ewa_4 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_ewa_4"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call modeL%init_sm_test ()
     call flv%init (2, model)
     pdg_in = 2
 
     call reset_interaction_counter ()
 
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 3000.0_default, .true., .true.)
        call data%set_id (24)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     write (u, "(A)")  "* Initialize incoming momentum with E=1500"
     write (u, "(A)")
     E = 1500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.5/0.5/0.25, with EWA mapping, "
     write (u, "(A)")  "          non-coll., keeping energy"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.5_default, 0.5_default, 0.25_default]
     rb = 1 - r
     sf_int%on_shell_mode = KEEP_ENERGY
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.true.)
     call sf_int%pacify_momenta (1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x and r from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.true., &
          set_momenta=.true.)
     call sf_int%pacify_momenta (1e-10_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EWA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 1500._default)
     call sf_int%write (u, testflag = .true.)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_4"
 
   end subroutine sf_ewa_4
 
 @ %def sf_ewa_4
 @
 \subsubsection{Structure function for multiple flavors}
 Construct and display a structure function object based on the EWA
 structure function.  The incoming state has multiple particles with
 non-uniform quantum numbers.
 <<SF ewa: execute tests>>=
   call test (sf_ewa_5, "sf_ewa_5", &
        "structure function instance", &
        u, results)
 <<SF ewa: test declarations>>=
   public :: sf_ewa_5
 <<SF ewa: tests>>=
   subroutine sf_ewa_5 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_ewa_5"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (2, model)
     pdg_in = [1, 2, -1, -2]
 
     call reset_interaction_counter ()
 
     allocate (ewa_data_t :: data)
     select type (data)
     type is (ewa_data_t)
        call data%init (model, pdg_in, 0.01_default, &
             500._default, 3000._default, .false., .true.)
        call data%set_id (24)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
     call sf_int%setup_constants ()
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=1500"
     write (u, "(A)")
     E = 1500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call pacify (k, 1e-10_default)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for r=0.4, no EWA mapping, collinear"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.4_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate EWA structure function"
     write (u, "(A)")
 
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_ewa_5"
 
   end subroutine sf_ewa_5
 
 @ %def sf_ewa_5
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{Energy-scan spectrum}
 
 This spectrum is actually a trick that allows us to plot the c.m.\ energy
 dependence of a cross section without scanning the input energy.  We
 start with the observation that a spectrum $f(x)$, applied to one of
 the incoming beams only, results in a cross section
 \begin{equation}
   \sigma = \int dx\,f(x)\,\hat\sigma(xs).
 \end{equation}
 We want to compute the distribution of $E=\sqrt{\hat s}=\sqrt{xs}$, i.e.,
 \begin{equation}
   \frac{d\sigma}{dE} = \frac{2\sqrt{x}}{\sqrt{s}}\,\frac{d\sigma}{dx}
   = \frac{2\sqrt{x}}{\sqrt{s}}\,f(x)\,\hat\sigma(xs),
 \end{equation}
 so if we set
 \begin{equation}
   f(x) = \frac{\sqrt{s}}{2\sqrt{x}},
 \end{equation}
 we get the distribution
 \begin{equation}
   \frac{d\sigma}{dE} = \hat\sigma(\hat s=E^2).
 \end{equation}
 We implement this as a spectrum with a single parameter $x$.  The
 parameters for the individual beams are computed as $x_i=\sqrt{x}$, so
 they are equal and the kinematics is always symmetric.
 <<[[sf_escan.f90]]>>=
 <<File header>>
 
 module sf_escan
 
 <<Use kinds>>
 <<Use strings>>
   use pdg_arrays
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
 
 <<Standard module head>>
 
 <<SF escan: public>>
 
 <<SF escan: types>>
 
   interface
 <<SF escan: sub interfaces>>
   end interface
 
 contains
 
 <<SF escan: main procedures>>
 
 end module sf_escan
 @ %def sf_escan
 @
 <<[[sf_escan_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_escan) sf_escan_s
 
   use io_units
   use format_defs, only: FMT_12
   use numeric_utils
   use diagnostics
   use lorentz
 
   implicit none
 
 contains
 
 <<SF escan: procedures>>
 
 end submodule sf_escan_s
 
 @ %def sf_escan_s
 @
 \subsection{Data type}
 The [[norm]] is unity if the total cross section should be normalized
 to one, and $\sqrt{s}$ if it should be normalized to the total
 energy.  In the latter case, the differential distribution
 $d\sigma/d\sqrt{\hat s}$ coincides with the partonic cross section
 $\hat\sigma$ as a function of $\sqrt{\hat s}$.
 <<SF escan: public>>=
   public :: escan_data_t
 <<SF escan: types>>=
   type, extends(sf_data_t) :: escan_data_t
      private
      type(flavor_t), dimension(:,:), allocatable :: flv_in
      integer, dimension(2) :: n_flv = 0
      real(default) :: norm = 1
    contains
    <<SF escan: escan data: TBP>>
   end type escan_data_t
 
 @  %def escan_data_t
 <<SF escan: escan data: TBP>>=
   procedure :: init => escan_data_init
 <<SF escan: sub interfaces>>=
     module subroutine escan_data_init (data, model, pdg_in, norm)
       class(escan_data_t), intent(out) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), dimension(2), intent(in) :: pdg_in
       real(default), intent(in), optional :: norm
     end subroutine escan_data_init
 <<SF escan: procedures>>=
   module subroutine escan_data_init (data, model, pdg_in, norm)
     class(escan_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     real(default), intent(in), optional :: norm
     real(default), dimension(2) :: m2
     integer :: i, j
     data%n_flv = pdg_in%get_length ()
     allocate (data%flv_in (maxval (data%n_flv), 2))
     do i = 1, 2
        do j = 1, data%n_flv(i)
           call data%flv_in(j, i)%init (pdg_in(i)%get (j), model)
        end do
     end do
     m2 = data%flv_in(1,:)%get_mass ()
     do i = 1, 2
        if (.not. any (nearly_equal (data%flv_in(1:data%n_flv(i),i)%get_mass (), m2(i)))) then
           call msg_fatal ("Energy scan: incoming particle mass must be uniform")
        end if
     end do
     if (present (norm))  data%norm = norm
   end subroutine escan_data_init
 
 @ %def escan_data_init
 @ Output
 <<SF escan: escan data: TBP>>=
   procedure :: write => escan_data_write
 <<SF escan: sub interfaces>>=
     module subroutine escan_data_write (data, unit, verbose)
       class(escan_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine escan_data_write
 <<SF escan: procedures>>=
   module subroutine escan_data_write (data, unit, verbose)
     class(escan_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, i, j
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "Energy-scan data:"
     write (u, "(3x,A)", advance="no")  "prt_in = "
     do i = 1, 2
        if (i > 1)  write (u, "(',',1x)", advance="no")
        do j = 1, data%n_flv(i)
           if (j > 1)  write (u, "(':')", advance="no")
           write (u, "(A)", advance="no")  char (data%flv_in(j,i)%get_name ())
        end do
     end do
     write (u, *)
     write (u, "(3x,A," // FMT_12 // ")")  "norm   =", data%norm
   end subroutine escan_data_write
 
 @ %def escan_data_write
 @ Kinematics is completely collinear, hence there is only one
 parameter for a pair spectrum.
 <<SF escan: escan data: TBP>>=
   procedure :: get_n_par => escan_data_get_n_par
 <<SF escan: sub interfaces>>=
     module function escan_data_get_n_par (data) result (n)
       class(escan_data_t), intent(in) :: data
       integer :: n
     end function escan_data_get_n_par
 <<SF escan: procedures>>=
   module function escan_data_get_n_par (data) result (n)
     class(escan_data_t), intent(in) :: data
     integer :: n
     n = 1
   end function escan_data_get_n_par
 
 @ %def escan_data_get_n_par
 @ Return the outgoing particles PDG codes. This is always the same as
 the incoming particle, where we use two indices for the two beams.
 <<SF escan: escan data: TBP>>=
   procedure :: get_pdg_out => escan_data_get_pdg_out
 <<SF escan: sub interfaces>>=
     module subroutine escan_data_get_pdg_out (data, pdg_out)
       class(escan_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine escan_data_get_pdg_out
 <<SF escan: procedures>>=
   module subroutine escan_data_get_pdg_out (data, pdg_out)
     class(escan_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        pdg_out(i) = data%flv_in(1:data%n_flv(i),i)%get_pdg ()
     end do
   end subroutine escan_data_get_pdg_out
 
 @ %def escan_data_get_pdg_out
 @ Allocate the interaction record. Due to a gfortran 7/8/9 this has to
 remain in the main module.
 <<SF escan: escan data: TBP>>=
   procedure :: allocate_sf_int => escan_data_allocate_sf_int
 <<SF escan: main procedures>>=
   subroutine escan_data_allocate_sf_int (data, sf_int)
     class(escan_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (escan_t :: sf_int)
   end subroutine escan_data_allocate_sf_int
 
 @ %def escan_data_allocate_sf_int
 @
 \subsection{The Energy-scan object}
 This is a spectrum, not a radiation.  We create an interaction with
 two incoming and two outgoing particles, flavor, color, and helicity
 being carried through. $x$ nevertheless is only one-dimensional, as we
 are always using only one beam parameter.
 <<SF escan: types>>=
   type, extends (sf_int_t) :: escan_t
      type(escan_data_t), pointer :: data => null ()
    contains
    <<SF escan: escan: TBP>>
   end type escan_t
 
 @ %def escan_t
 @ Type string: for the energy scan this is just a dummy function.
 <<SF escan: escan: TBP>>=
   procedure :: type_string => escan_type_string
 <<SF escan: sub interfaces>>=
     module function escan_type_string (object) result (string)
       class(escan_t), intent(in) :: object
       type(string_t) :: string
     end function escan_type_string
 <<SF escan: procedures>>=
   module function escan_type_string (object) result (string)
     class(escan_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "Escan: energy scan"
     else
        string = "Escan: [undefined]"
     end if
   end function escan_type_string
 
 @ %def escan_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF escan: escan: TBP>>=
   procedure :: write => escan_write
 <<SF escan: sub interfaces>>=
     module subroutine escan_write (object, unit, testflag)
       class(escan_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine escan_write
 <<SF escan: procedures>>=
   module subroutine escan_write (object, unit, testflag)
     class(escan_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "Energy scan data: [undefined]"
     end if
   end subroutine escan_write
 
 @ %def escan_write
 @
 <<SF escan: escan: TBP>>=
   procedure :: init => escan_init
 <<SF escan: sub interfaces>>=
     module subroutine escan_init (sf_int, data)
       class(escan_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine escan_init
 <<SF escan: procedures>>=
   module subroutine escan_init (sf_int, data)
     class(escan_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(4) :: mask
     integer, dimension(4) :: hel_lock
     real(default), dimension(2) :: m2
     real(default), dimension(0) :: mr2
     type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
     type(polarization_t), target :: pol1, pol2
     type(polarization_iterator_t) :: it_hel1, it_hel2
     integer :: j1, j2
     select type (data)
     type is (escan_data_t)
        hel_lock = [3, 4, 1, 2]
        m2 = data%flv_in(1,:)%get_mass ()
        call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
        sf_int%data => data
        do j1 = 1, data%n_flv(1)
           call qn_fc(1)%init ( &
                flv = data%flv_in(j1,1), &
                col = color_from_flavor (data%flv_in(j1,1)))
           call qn_fc(3)%init ( &
                flv = data%flv_in(j1,1), &
                col = color_from_flavor (data%flv_in(j1,1)))
           call pol1%init_generic (data%flv_in(j1,1))
           do j2 = 1, data%n_flv(2)
              call qn_fc(2)%init ( &
                   flv = data%flv_in(j2,2), &
                   col = color_from_flavor (data%flv_in(j2,2)))
              call qn_fc(4)%init ( &
                   flv = data%flv_in(j2,2), &
                   col = color_from_flavor (data%flv_in(j2,2)))
              call pol2%init_generic (data%flv_in(j2,2))
              call it_hel1%init (pol1)
              do while (it_hel1%is_valid ())
                 qn_hel(1) = it_hel1%get_quantum_numbers ()
                 qn_hel(3) = it_hel1%get_quantum_numbers ()
                 call it_hel2%init (pol2)
                 do while (it_hel2%is_valid ())
                    qn_hel(2) = it_hel2%get_quantum_numbers ()
                    qn_hel(4) = it_hel2%get_quantum_numbers ()
                    qn = qn_hel .merge. qn_fc
                    call sf_int%add_state (qn)
                    call it_hel2%advance ()
                 end do
                 call it_hel1%advance ()
              end do
              ! call pol2%final ()
           end do
           ! call pol1%final ()
        end do
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        call sf_int%freeze ()
        sf_int%status = SF_INITIAL
     end select
   end subroutine escan_init
 
 @ %def escan_init
 @
 \subsection{Kinematics}
 Set kinematics.  We have a single parameter, but reduce both beams.
 The [[map]] flag is ignored.
 <<SF escan: escan: TBP>>=
   procedure :: complete_kinematics => escan_complete_kinematics
 <<SF escan: sub interfaces>>=
     module subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map)
       class(escan_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default) :: sqrt_x
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine escan_complete_kinematics
 <<SF escan: procedures>>=
   module subroutine escan_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(escan_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default) :: sqrt_x
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     x = r
     xb= rb
     sqrt_x = sqrt (x(1))
     if (sqrt_x > 0) then
        f = 1 / (2 * sqrt_x)
     else
        f = 0
        sf_int%status = SF_FAILED_KINEMATICS
        return
     end if
     call sf_int%reduce_momenta ([sqrt_x, sqrt_x])
   end subroutine escan_complete_kinematics
 
 @ %def escan_complete_kinematics
 @ Recover $x$.  The base procedure should return two momentum
 fractions for the two beams, while we have only one parameter.  This
 is the product of the extracted momentum fractions.
 <<SF escan: escan: TBP>>=
   procedure :: recover_x => escan_recover_x
 <<SF escan: sub interfaces>>=
     module subroutine escan_recover_x (sf_int, x, xb, x_free)
       class(escan_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(inout), optional :: x_free
     end subroutine escan_recover_x
 <<SF escan: procedures>>=
   module subroutine escan_recover_x (sf_int, x, xb, x_free)
     class(escan_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     real(default), dimension(2) :: xi, xib
     call sf_int%base_recover_x (xi, xib, x_free)
     x = product (xi)
     xb= 1 - x
   end subroutine escan_recover_x
 
 @ %def escan_recover_x
 @ Compute inverse kinematics.
 <<SF escan: escan: TBP>>=
   procedure :: inverse_kinematics => escan_inverse_kinematics
 <<SF escan: sub interfaces>>=
     module subroutine escan_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(escan_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine escan_inverse_kinematics
 <<SF escan: procedures>>=
   module subroutine escan_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(escan_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     real(default) :: sqrt_x
     logical :: set_mom
 
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     sqrt_x = sqrt (x(1))
     if (sqrt_x > 0) then
        f = 1 / (2 * sqrt_x)
     else
        f = 0
        sf_int%status = SF_FAILED_KINEMATICS
        return
     end if
     r = x
     rb = xb
     if (set_mom) then
        call sf_int%reduce_momenta ([sqrt_x, sqrt_x])
     end if
   end subroutine escan_inverse_kinematics
 
 @ %def escan_inverse_kinematics
 @
 \subsection{Energy scan application}
 Here, we insert the predefined norm.
 <<SF escan: escan: TBP>>=
   procedure :: apply => escan_apply
 <<SF escan: sub interfaces>>=
     module subroutine escan_apply (sf_int, scale, negative_sf, rescale, i_sub)
       class(escan_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine escan_apply
 <<SF escan: procedures>>=
   module subroutine escan_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(escan_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: f
     associate (data => sf_int%data)
       f = data%norm
     end associate
     call sf_int%set_matrix_element (cmplx (f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine escan_apply
 
 @ %def escan_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_escan_ut.f90]]>>=
 <<File header>>
 
 module sf_escan_ut
   use unit_tests
   use sf_escan_uti
 
 <<Standard module head>>
 
 <<SF escan: public test>>
 
 contains
 
 <<SF escan: test driver>>
 
 end module sf_escan_ut
 @ %def sf_escan_ut
 @
 <<[[sf_escan_uti.f90]]>>=
 <<File header>>
 
 module sf_escan_uti
 
 <<Use kinds>>
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_aux
   use sf_base
 
   use sf_escan
 
 <<Standard module head>>
 
 <<SF escan: test declarations>>
 
 contains
 
 <<SF escan: tests>>
 
 end module sf_escan_uti
 @ %def sf_escan_ut
 @ API: driver for the unit tests below.
 <<SF escan: public test>>=
   public :: sf_escan_test
 <<SF escan: test driver>>=
   subroutine sf_escan_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF escan: execute tests>>
   end subroutine sf_escan_test
 
 @ %def sf_escan_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF escan: execute tests>>=
   call test (sf_escan_1, "sf_escan_1", &
        "structure function configuration", &
        u, results)
 <<SF escan: test declarations>>=
   public :: sf_escan_1
 <<SF escan: tests>>=
   subroutine sf_escan_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_escan_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &energy-scan structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     allocate (escan_data_t :: data)
     select type (data)
     type is (escan_data_t)
        call data%init (model, pdg_in, norm = 2._default)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_escan_1"
 
   end subroutine sf_escan_1
 
 @ %def sf_escan_1
 g@
 \subsubsection{Probe the structure-function object}
 Active the beam event reader, generate an event.
 <<SF escan: execute tests>>=
   call test (sf_escan_2, "sf_escan_2", &
        "generate event", &
        u, results)
 <<SF escan: test declarations>>=
   public :: sf_escan_2
 <<SF escan: tests>>=
   subroutine sf_escan_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: x_free, f
 
     write (u, "(A)")  "* Test output: sf_escan_2"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &beam-events structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (escan_data_t :: data)
     select type (data)
     type is (escan_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set dummy parameters and generate x"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0.8
     rb = 1 - r
     x_free = 1
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Inverse kinematics"
     write (u, "(A)")
 
     call sf_int%recover_x (x, xb, x_free)
     call sf_int%inverse_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_escan_2"
 
   end subroutine sf_escan_2
 
 @ %def sf_escan_2
 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Gaussian beam spread}
 
 Instead of an analytic beam description, beam data may be provided in
 form of an event file.  In its most simple form, the event file
 contains pairs of $x$ values, relative to nominal beam energies.  More
 advanced formats may include polarization, etc.  The current
 implementation carries beam polarization through, if specified.
 
 The code is very similar to the energy scan described above.
 
 However, we must include a file-handle manager for the beam-event
 files.  Two different processes may access a given beam-event file at
 the same time (i.e., serially but alternating).  Accessing an open
 file from two different units is non-standard and not supported by all
 compilers.  Therefore, we keep a global registry of open files,
 associated units, and reference counts.  The [[gaussian_t]] objects
 act as proxies to this registry.
 <<[[sf_gaussian.f90]]>>=
 <<File header>>
 
 module sf_gaussian
 
 <<Use kinds>>
 <<Use strings>>
   use rng_base
   use pdg_arrays
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
 
 <<Standard module head>>
 
 <<SF gaussian: public>>
 
 <<SF gaussian: types>>
 
   interface
 <<SF gaussian: sub interfaces>>
   end interface
 
 contains
 
 <<SF gaussian: main procedures>>
 
 end module sf_gaussian
 @ %def sf_gaussian
 @
 <<[[sf_gaussian_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_gaussian) sf_gaussian_s
 
   use io_units
   use format_defs, only: FMT_12
   use file_registries
   use diagnostics
   use lorentz
 
   implicit none
 
 contains
 
 <<SF gaussian: procedures>>
 
 end submodule sf_gaussian_s
 
 @ %def sf_gaussian_s
 @
 \subsection{The beam-data file registry}
 We manage data files via the [[file_registries]] module.  To this end,
 we keep the registry as a private module variable here.
 <<CCC SF gaussian: variables>>=
   type(file_registry_t), save :: beam_file_registry
 
 @ %def beam_file_registry
 @
 \subsection{Data type}
 We store the spread for each beam, as a relative number related to the beam
 energy.  For the actual generation, we include an (abstract) random-number
 generator factory.
 <<SF gaussian: public>>=
   public :: gaussian_data_t
 <<SF gaussian: types>>=
   type, extends(sf_data_t) :: gaussian_data_t
      private
      type(flavor_t), dimension(2) :: flv_in
      real(default), dimension(2) :: spread
      class(rng_factory_t), allocatable :: rng_factory
    contains
    <<SF gaussian: gaussian data: TBP>>
   end type gaussian_data_t
 
 @  %def gaussian_data_t
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: init => gaussian_data_init
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_data_init &
          (data, model, pdg_in, spread, rng_factory)
       class(gaussian_data_t), intent(out) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), dimension(2), intent(in) :: pdg_in
       real(default), dimension(2), intent(in) :: spread
       class(rng_factory_t), intent(inout), allocatable :: rng_factory
     end subroutine gaussian_data_init
 <<SF gaussian: procedures>>=
   module subroutine gaussian_data_init &
        (data, model, pdg_in, spread, rng_factory)
     class(gaussian_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     real(default), dimension(2), intent(in) :: spread
     class(rng_factory_t), intent(inout), allocatable :: rng_factory
     if (any (spread < 0)) then
        call msg_fatal ("Gaussian beam spread: must not be negative")
     end if
     call data%flv_in(1)%init (pdg_in(1)%get (1), model)
     call data%flv_in(2)%init (pdg_in(2)%get (1), model)
     data%spread = spread
     call move_alloc (from = rng_factory, to = data%rng_factory)
   end subroutine gaussian_data_init
 
 @ %def gaussian_data_init
 @ Return true since this spectrum is always in generator mode.
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: is_generator => gaussian_data_is_generator
 <<SF gaussian: sub interfaces>>=
     module function gaussian_data_is_generator (data) result (flag)
       class(gaussian_data_t), intent(in) :: data
       logical :: flag
     end function gaussian_data_is_generator
 <<SF gaussian: procedures>>=
   module function gaussian_data_is_generator (data) result (flag)
     class(gaussian_data_t), intent(in) :: data
     logical :: flag
     flag = .true.
   end function gaussian_data_is_generator
 
 @ %def gaussian_data_is_generator
 @ The number of parameters is two.  They are free parameters.
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: get_n_par => gaussian_data_get_n_par
 <<SF gaussian: sub interfaces>>=
     module function gaussian_data_get_n_par (data) result (n)
       class(gaussian_data_t), intent(in) :: data
       integer :: n
     end function gaussian_data_get_n_par
 <<SF gaussian: procedures>>=
   module function gaussian_data_get_n_par (data) result (n)
     class(gaussian_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function gaussian_data_get_n_par
 
 @ %def gaussian_data_get_n_par
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: get_pdg_out => gaussian_data_get_pdg_out
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_data_get_pdg_out (data, pdg_out)
       class(gaussian_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine gaussian_data_get_pdg_out
 <<SF gaussian: procedures>>=
   module subroutine gaussian_data_get_pdg_out (data, pdg_out)
     class(gaussian_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        pdg_out(i) = data%flv_in(i)%get_pdg ()
     end do
   end subroutine gaussian_data_get_pdg_out
 
 @ %def gaussian_data_get_pdg_out
 @ Allocate the interaction record. Due to a gfortran 7/8/9 bug has to
 remain in the main module.
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: allocate_sf_int => gaussian_data_allocate_sf_int
 <<SF gaussian: main procedures>>=
   subroutine gaussian_data_allocate_sf_int (data, sf_int)
     class(gaussian_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (gaussian_t :: sf_int)
   end subroutine gaussian_data_allocate_sf_int
 
 @ %def gaussian_data_allocate_sf_int
 @ Output
 <<SF gaussian: gaussian data: TBP>>=
   procedure :: write => gaussian_data_write
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_data_write (data, unit, verbose)
       class(gaussian_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine gaussian_data_write
 <<SF gaussian: procedures>>=
   module subroutine gaussian_data_write (data, unit, verbose)
     class(gaussian_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "Gaussian beam spread data:"
     write (u, "(3x,A,A,A,A)") "prt_in = ", &
          char (data%flv_in(1)%get_name ()), &
          ", ", char (data%flv_in(2)%get_name ())
     write (u, "(3x,A,2(1x," // FMT_12 // "))") "spread =", data%spread
     call data%rng_factory%write (u)
   end subroutine gaussian_data_write
 
 @ %def gaussian_data_write
 @
 \subsection{The gaussian object}
 Flavor and polarization carried through, no radiated particles.  The generator
 needs a random-number generator, obviously.
 <<SF gaussian: public>>=
   public :: gaussian_t
 <<SF gaussian: types>>=
   type, extends (sf_int_t) :: gaussian_t
      type(gaussian_data_t), pointer :: data => null ()
      class(rng_t), allocatable :: rng
    contains
    <<SF gaussian: gaussian: TBP>>
   end type gaussian_t
 
 @ %def gaussian_t
 @ Type string: show gaussian file.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: type_string => gaussian_type_string
 <<SF gaussian: sub interfaces>>=
     module function gaussian_type_string (object) result (string)
       class(gaussian_t), intent(in) :: object
       type(string_t) :: string
     end function gaussian_type_string
 <<SF gaussian: procedures>>=
   module function gaussian_type_string (object) result (string)
     class(gaussian_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "Gaussian: gaussian beam-energy spread"
     else
        string = "Gaussian: [undefined]"
     end if
   end function gaussian_type_string
 
 @ %def gaussian_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: write => gaussian_write
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_write (object, unit, testflag)
       class(gaussian_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine gaussian_write
 <<SF gaussian: procedures>>=
   module subroutine gaussian_write (object, unit, testflag)
     class(gaussian_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%rng%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "gaussian data: [undefined]"
     end if
   end subroutine gaussian_write
 
 @ %def gaussian_write
 @
 <<SF gaussian: gaussian: TBP>>=
   procedure :: init => gaussian_init
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_init (sf_int, data)
       class(gaussian_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine gaussian_init
 <<SF gaussian: procedures>>=
   module subroutine gaussian_init (sf_int, data)
     class(gaussian_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     real(default), dimension(2) :: m2
     real(default), dimension(0) :: mr2
     type(quantum_numbers_mask_t), dimension(4) :: mask
     integer, dimension(4) :: hel_lock
     type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
     type(polarization_t), target :: pol1, pol2
     type(polarization_iterator_t) :: it_hel1, it_hel2
     integer :: i
     select type (data)
     type is (gaussian_data_t)
        m2 = data%flv_in%get_mass () ** 2
        hel_lock = [3, 4, 1, 2]
        mask = quantum_numbers_mask (.false., .false., .false.)
        call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
        sf_int%data => data
        do i = 1, 2
           call qn_fc(i)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i)))
           call qn_fc(i+2)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i)))
        end do
        call pol1%init_generic (data%flv_in(1))
        call it_hel1%init (pol1)
        do while (it_hel1%is_valid ())
           qn_hel(1) = it_hel1%get_quantum_numbers ()
           qn_hel(3) = it_hel1%get_quantum_numbers ()
           call pol2%init_generic (data%flv_in(2))
           call it_hel2%init (pol2)
           do while (it_hel2%is_valid ())
              qn_hel(2) = it_hel2%get_quantum_numbers ()
              qn_hel(4) = it_hel2%get_quantum_numbers ()
              qn = qn_hel .merge. qn_fc
              call sf_int%add_state (qn)
              call it_hel2%advance ()
           end do
           ! call pol2%final ()
           call it_hel1%advance ()
        end do
        ! call pol1%final ()
        call sf_int%freeze ()
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        sf_int%status = SF_INITIAL
     end select
     call sf_int%data%rng_factory%make (sf_int%rng)
   end subroutine gaussian_init
 
 @ %def gaussian_init
 @ This spectrum type needs a finalizer, which closes the data file.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: final => sf_gaussian_final
 <<SF gaussian: sub interfaces>>=
     module subroutine sf_gaussian_final (object)
       class(gaussian_t), intent(inout) :: object
     end subroutine sf_gaussian_final
 <<SF gaussian: procedures>>=
   module subroutine sf_gaussian_final (object)
     class(gaussian_t), intent(inout) :: object
     call object%interaction_t%final ()
   end subroutine sf_gaussian_final
 
 @ %def sf_gaussian_final
 @
 \subsection{Kinematics}
 Refer to the [[data]] component.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: is_generator => gaussian_is_generator
 <<SF gaussian: sub interfaces>>=
     module function gaussian_is_generator (sf_int) result (flag)
       class(gaussian_t), intent(in) :: sf_int
       logical :: flag
     end function gaussian_is_generator
 <<SF gaussian: procedures>>=
   module function gaussian_is_generator (sf_int) result (flag)
     class(gaussian_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function gaussian_is_generator
 
 @ %def gaussian_is_generator
 @ Generate free parameters.  The $x$ value should be distributed with mean $1$
 and $\sigma$ given by the spread.  We reject negative $x$ values.  (This
 cut slightly biases the distribution, but for reasonable (small)
 spreads negative $r$ should not occur.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: generate_free => gaussian_generate_free
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_generate_free (sf_int, r, rb, x_free)
       class(gaussian_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(inout) :: x_free
     end subroutine gaussian_generate_free
 <<SF gaussian: procedures>>=
   module subroutine gaussian_generate_free (sf_int, r, rb, x_free)
     class(gaussian_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     real(default), dimension(size(r)) :: z
     associate (data => sf_int%data)
       do
          call sf_int%rng%generate_gaussian (z)
          rb = z * data%spread
          r = 1 - rb
          x_free = x_free * product (r)
          if (all (r > 0))  exit
       end do
     end associate
   end subroutine gaussian_generate_free
 
 @ %def gaussian_generate_free
 @ Set kinematics.  Trivial transfer since this is a pure generator.
 The [[map]] flag doesn't apply.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: complete_kinematics => gaussian_complete_kinematics
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_complete_kinematics &
          (sf_int, x, xb, f, r, rb, map)
       class(gaussian_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine gaussian_complete_kinematics
 <<SF gaussian: procedures>>=
   module subroutine gaussian_complete_kinematics &
        (sf_int, x, xb, f, r, rb, map)
     class(gaussian_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("gaussian: map flag not supported")
     else
        x = r
        xb= rb
        f = 1
     end if
     call sf_int%reduce_momenta (x)
   end subroutine gaussian_complete_kinematics
 
 @ %def gaussian_complete_kinematics
 @ Compute inverse kinematics.  Trivial in this case.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: inverse_kinematics => gaussian_inverse_kinematics
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(gaussian_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine gaussian_inverse_kinematics
 <<SF gaussian: procedures>>=
   module subroutine gaussian_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(gaussian_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("gaussian: map flag not supported")
     else
        r = x
        rb= xb
        f = 1
     end if
     if (set_mom) then
        call sf_int%reduce_momenta (x)
     end if
   end subroutine gaussian_inverse_kinematics
 
 @ %def gaussian_inverse_kinematics
 @
 \subsection{gaussian application}
 Trivial, just set the unit weight.
 <<SF gaussian: gaussian: TBP>>=
   procedure :: apply => gaussian_apply
 <<SF gaussian: sub interfaces>>=
     module subroutine gaussian_apply &
          (sf_int, scale, negative_sf, rescale, i_sub)
       class(gaussian_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine gaussian_apply
 <<SF gaussian: procedures>>=
   module subroutine gaussian_apply &
        (sf_int, scale, negative_sf, rescale, i_sub)
     class(gaussian_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: f
     f = 1
     call sf_int%set_matrix_element (cmplx (f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine gaussian_apply
 
 @ %def gaussian_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_gaussian_ut.f90]]>>=
 <<File header>>
 
 module sf_gaussian_ut
   use unit_tests
   use sf_gaussian_uti
 
 <<Standard module head>>
 
 <<SF gaussian: public test>>
 
 contains
 
 <<SF gaussian: test driver>>
 
 end module sf_gaussian_ut
 @ %def sf_gaussian_ut
 @
 <<[[sf_gaussian_uti.f90]]>>=
 <<File header>>
 
 module sf_gaussian_uti
 
 <<Use kinds>>
   use numeric_utils, only: pacify
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use rng_base
   use sf_aux
   use sf_base
 
   use sf_gaussian
 
   use rng_base_ut, only: rng_test_factory_t
 
 <<Standard module head>>
 
 <<SF gaussian: test declarations>>
 
 contains
 
 <<SF gaussian: tests>>
 
 end module sf_gaussian_uti
 @ %def sf_gaussian_ut
 @ API: driver for the unit tests below.
 <<SF gaussian: public test>>=
   public :: sf_gaussian_test
 <<SF gaussian: test driver>>=
   subroutine sf_gaussian_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF gaussian: execute tests>>
   end subroutine sf_gaussian_test
 
 @ %def sf_gaussian_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF gaussian: execute tests>>=
   call test (sf_gaussian_1, "sf_gaussian_1", &
        "structure function configuration", &
        u, results)
 <<SF gaussian: test declarations>>=
   public :: sf_gaussian_1
 <<SF gaussian: tests>>=
   subroutine sf_gaussian_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
     class(rng_factory_t), allocatable :: rng_factory
 
     write (u, "(A)")  "* Test output: sf_gaussian_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &gaussian-spread structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     allocate (gaussian_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (gaussian_data_t)
        call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_gaussian_1"
 
   end subroutine sf_gaussian_1
 
 @ %def sf_gaussian_1
 @
 \subsubsection{Probe the structure-function object}
 Active the beam event reader, generate an event.
 <<SF gaussian: execute tests>>=
   call test (sf_gaussian_2, "sf_gaussian_2", &
        "generate event", &
        u, results)
 <<SF gaussian: test declarations>>=
   public :: sf_gaussian_2
 <<SF gaussian: tests>>=
   subroutine sf_gaussian_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(rng_factory_t), allocatable :: rng_factory
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: x_free, f
     integer :: i
 
     write (u, "(A)")  "* Test output: sf_gaussian_2"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &gaussian-spread structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (gaussian_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (gaussian_data_t)
        call data%init (model, pdg_in, [1e-2_default, 2e-2_default], rng_factory)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set dummy parameters and generate x."
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call pacify (rb, 1.e-8_default)
     call pacify (xb, 1.e-8_default)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate more events"
     write (u, "(A)")
 
     select type (sf_int)
     type is (gaussian_t)
        do i = 1, 3
           call sf_int%generate_free (r, rb, x_free)
           write (u, "(A,9(1x,F10.7))")  "r =", r
        end do
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_gaussian_2"
 
   end subroutine sf_gaussian_2
 
 @ %def sf_gaussian_2
 @
 \clearpage
 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Using beam event data}
 
 Instead of an analytic beam description, beam data may be provided in
 form of an event file.  In its most simple form, the event file
 contains pairs of $x$ values, relative to nominal beam energies.  More
 advanced formats may include polarization, etc.  The current
 implementation carries beam polarization through, if specified.
 
 The code is very similar to the energy scan described above.
 
 However, we must include a file-handle manager for the beam-event
 files.  Two different processes may access a given beam-event file at
 the same time (i.e., serially but alternating).  Accessing an open
 file from two different units is non-standard and not supported by all
 compilers.  Therefore, we keep a global registry of open files,
 associated units, and reference counts.  The [[beam_events_t]] objects
 act as proxies to this registry.
 <<[[sf_beam_events.f90]]>>=
 <<File header>>
 
 module sf_beam_events
 
 <<Use kinds>>
 <<Use strings>>
   use file_registries
   use pdg_arrays
   use model_data
   use flavors
   use quantum_numbers
   use state_matrices
   use polarizations
   use sf_base
 
 <<Standard module head>>
 
 <<SF beam events: public>>
 
 <<SF beam events: types>>
 
 <<SF beam events: variables>>
 
   interface
 <<SF beam events: sub interfaces>>
   end interface
 
 contains
 
 <<SF beam events: main procedures>>
 
 end module sf_beam_events
 @ %def sf_beam_events
 @
 <<[[sf_beam_events_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_beam_events) sf_beam_events_s
 
   use io_units
   use diagnostics
   use lorentz
 
   implicit none
 
 contains
 
 <<SF beam events: procedures>>
 
 end submodule sf_beam_events_s
 
 @ %def sf_beam_events_s
 @
 \subsection{The beam-data file registry}
 We manage data files via the [[file_registries]] module.  To this end,
 we keep the registry as a private module variable here.
 
 This is public only for the unit tests.
 <<SF beam events: public>>=
   public :: beam_file_registry
 <<SF beam events: variables>>=
   type(file_registry_t), save :: beam_file_registry
 
 @ %def beam_file_registry
 @
 \subsection{Data type}
 <<SF beam events: public>>=
   public :: beam_events_data_t
 <<SF beam events: types>>=
   type, extends(sf_data_t) :: beam_events_data_t
      private
      type(flavor_t), dimension(2) :: flv_in
      type(string_t) :: dir
      type(string_t) :: file
      type(string_t) :: fqn
      integer :: unit = 0
      logical :: warn_eof = .true.
    contains
    <<SF beam events: beam events data: TBP>>
   end type beam_events_data_t
 
 @  %def beam_events_data_t
 <<SF beam events: beam events data: TBP>>=
   procedure :: init => beam_events_data_init
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_data_init &
          (data, model, pdg_in, dir, file, warn_eof)
       class(beam_events_data_t), intent(out) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), dimension(2), intent(in) :: pdg_in
       type(string_t), intent(in) :: dir
       type(string_t), intent(in) :: file
       logical, intent(in), optional :: warn_eof
     end subroutine beam_events_data_init
 <<SF beam events: procedures>>=
   module subroutine beam_events_data_init &
        (data, model, pdg_in, dir, file, warn_eof)
     class(beam_events_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     type(string_t), intent(in) :: dir
     type(string_t), intent(in) :: file
     logical, intent(in), optional :: warn_eof
     if (any (pdg_in%get_length () /= 1)) then
        call msg_fatal ("Beam events: incoming beam particles must be unique")
     end if
     call data%flv_in(1)%init (pdg_in(1)%get (1), model)
     call data%flv_in(2)%init (pdg_in(2)%get (1), model)
     data%dir = dir
     data%file = file
     if (present (warn_eof))  data%warn_eof = warn_eof
   end subroutine beam_events_data_init
 
 @ %def beam_events_data_init
 @ Return true since this spectrum is always in generator mode.
 <<SF beam events: beam events data: TBP>>=
   procedure :: is_generator => beam_events_data_is_generator
 <<SF beam events: sub interfaces>>=
     module function beam_events_data_is_generator (data) result (flag)
       class(beam_events_data_t), intent(in) :: data
       logical :: flag
     end function beam_events_data_is_generator
 <<SF beam events: procedures>>=
   module function beam_events_data_is_generator (data) result (flag)
     class(beam_events_data_t), intent(in) :: data
     logical :: flag
     flag = .true.
   end function beam_events_data_is_generator
 
 @ %def beam_events_data_is_generator
 @ The number of parameters is two.  They are free parameters.
 <<SF beam events: beam events data: TBP>>=
   procedure :: get_n_par => beam_events_data_get_n_par
 <<SF beam events: sub interfaces>>=
     module function beam_events_data_get_n_par (data) result (n)
       class(beam_events_data_t), intent(in) :: data
       integer :: n
     end function beam_events_data_get_n_par
 <<SF beam events: procedures>>=
   module function beam_events_data_get_n_par (data) result (n)
     class(beam_events_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function beam_events_data_get_n_par
 
 @ %def beam_events_data_get_n_par
 <<SF beam events: beam events data: TBP>>=
   procedure :: get_pdg_out => beam_events_data_get_pdg_out
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_data_get_pdg_out (data, pdg_out)
       class(beam_events_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine beam_events_data_get_pdg_out
 <<SF beam events: procedures>>=
   module subroutine beam_events_data_get_pdg_out (data, pdg_out)
     class(beam_events_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        pdg_out(i) = data%flv_in(i)%get_pdg ()
     end do
   end subroutine beam_events_data_get_pdg_out
 
 @ %def beam_events_data_get_pdg_out
 @ Allocate the interaction record. Due to a gfortran 7/8/9 bug has to
 remain in the main module.
 <<SF beam events: beam events data: TBP>>=
   procedure :: allocate_sf_int => beam_events_data_allocate_sf_int
 <<SF beam events: main procedures>>=
   subroutine beam_events_data_allocate_sf_int (data, sf_int)
     class(beam_events_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (beam_events_t :: sf_int)
   end subroutine beam_events_data_allocate_sf_int
 
 @ %def beam_events_data_allocate_sf_int
 @ Output
 <<SF beam events: beam events data: TBP>>=
   procedure :: write => beam_events_data_write
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_data_write (data, unit, verbose)
       class(beam_events_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine beam_events_data_write
 <<SF beam events: procedures>>=
   module subroutine beam_events_data_write (data, unit, verbose)
     class(beam_events_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "Beam-event file data:"
     write (u, "(3x,A,A,A,A)") "prt_in = ", &
          char (data%flv_in(1)%get_name ()), &
          ", ", char (data%flv_in(2)%get_name ())
     write (u, "(3x,A,A,A)") "file   = '", char (data%file), "'"
     write (u, "(3x,A,I0)")  "unit   = ", data%unit
     write (u, "(3x,A,L1)")  "warn   = ", data%warn_eof
   end subroutine beam_events_data_write
 
 @ %def beam_events_data_write
 @ The data file needs to be opened and closed explicitly.  The
 open/close message is communicated to the file handle registry, which
 does the actual work.
 
 We determine first whether to look in the local directory or in the
 given system directory.
 <<SF beam events: beam events data: TBP>>=
   procedure :: open => beam_events_data_open
   procedure :: close => beam_events_data_close
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_data_open (data)
       class(beam_events_data_t), intent(inout) :: data
     end subroutine beam_events_data_open
     module subroutine beam_events_data_close (data)
       class(beam_events_data_t), intent(inout) :: data
     end subroutine beam_events_data_close
 <<SF beam events: procedures>>=
   module subroutine beam_events_data_open (data)
     class(beam_events_data_t), intent(inout) :: data
     logical :: exist
     if (data%unit == 0) then
        data%fqn = data%file
        if (data%fqn == "") &
             call msg_fatal ("Beam events: $beam_events_file is not set")
        inquire (file = char (data%fqn), exist = exist)
        if (.not. exist) then
           data%fqn = data%dir // "/" // data%file
           inquire (file = char (data%fqn), exist = exist)
           if (.not. exist) then
              data%fqn = ""
              call msg_fatal ("Beam events: file '" &
                   // char (data%file) // "' not found")
              return
           end if
        end if
        call msg_message ("Beam events: reading from file '" &
             // char (data%file) // "'")
        call beam_file_registry%open (data%fqn, data%unit)
     else
        call msg_bug ("Beam events: file '" &
          // char (data%file) // "' is already open")
     end if
   end subroutine beam_events_data_open
 
   module subroutine beam_events_data_close (data)
     class(beam_events_data_t), intent(inout) :: data
     if (data%unit /= 0) then
        call beam_file_registry%close (data%fqn)
        call msg_message ("Beam events: closed file '" &
          // char (data%file) // "'")
        data%unit = 0
     end if
   end subroutine beam_events_data_close
 
 @ %def beam_events_data_close
 @ Return the beam event file.
 <<SF beam events: beam events data: TBP>>=
   procedure :: get_beam_file => beam_events_data_get_beam_file
 <<SF beam events: sub interfaces>>=
     module function beam_events_data_get_beam_file (data) result (file)
       class(beam_events_data_t), intent(in) :: data
       type(string_t) :: file
     end function beam_events_data_get_beam_file
 <<SF beam events: procedures>>=
   module function beam_events_data_get_beam_file (data) result (file)
     class(beam_events_data_t), intent(in) :: data
     type(string_t) :: file
     file = "Beam events: " // data%file
   end function beam_events_data_get_beam_file
 
 @ %def beam_events_data_get_beam_file
 @
 \subsection{The beam events object}
 Flavor and polarization carried through, no radiated particles.
 <<SF beam events: public>>=
   public :: beam_events_t
 <<SF beam events: types>>=
   type, extends (sf_int_t) :: beam_events_t
      type(beam_events_data_t), pointer :: data => null ()
      integer :: count = 0
    contains
    <<SF beam events: beam events: TBP>>
   end type beam_events_t
 
 @ %def beam_events_t
 @ Type string: show beam events file.
 <<SF beam events: beam events: TBP>>=
   procedure :: type_string => beam_events_type_string
 <<SF beam events: sub interfaces>>=
     module function beam_events_type_string (object) result (string)
       class(beam_events_t), intent(in) :: object
       type(string_t) :: string
     end function beam_events_type_string
 <<SF beam events: procedures>>=
   module function beam_events_type_string (object) result (string)
     class(beam_events_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "Beam events: " // object%data%file
     else
        string = "Beam events: [undefined]"
     end if
   end function beam_events_type_string
 
 @ %def beam_events_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF beam events: beam events: TBP>>=
   procedure :: write => beam_events_write
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_write (object, unit, testflag)
       class(beam_events_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine beam_events_write
 <<SF beam events: procedures>>=
   module subroutine beam_events_write (object, unit, testflag)
     class(beam_events_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "Beam events data: [undefined]"
     end if
   end subroutine beam_events_write
 
 @ %def beam_events_write
 @
 <<SF beam events: beam events: TBP>>=
   procedure :: init => beam_events_init
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_init (sf_int, data)
       class(beam_events_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine beam_events_init
 <<SF beam events: procedures>>=
   module subroutine beam_events_init (sf_int, data)
     class(beam_events_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     real(default), dimension(2) :: m2
     real(default), dimension(0) :: mr2
     type(quantum_numbers_mask_t), dimension(4) :: mask
     integer, dimension(4) :: hel_lock
     type(quantum_numbers_t), dimension(4) :: qn_fc, qn_hel, qn
     type(polarization_t), target :: pol1, pol2
     type(polarization_iterator_t) :: it_hel1, it_hel2
     integer :: i
     select type (data)
     type is (beam_events_data_t)
        m2 = data%flv_in%get_mass () ** 2
        hel_lock = [3, 4, 1, 2]
        mask = quantum_numbers_mask (.false., .false., .false.)
        call sf_int%base_init (mask, m2, mr2, m2, hel_lock = hel_lock)
        sf_int%data => data
        do i = 1, 2
           call qn_fc(i)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i)))
           call qn_fc(i+2)%init ( &
                flv = data%flv_in(i), &
                col = color_from_flavor (data%flv_in(i)))
        end do
        call pol1%init_generic (data%flv_in(1))
        call it_hel1%init (pol1)
        do while (it_hel1%is_valid ())
           qn_hel(1) = it_hel1%get_quantum_numbers ()
           qn_hel(3) = it_hel1%get_quantum_numbers ()
           call pol2%init_generic (data%flv_in(2))
           call it_hel2%init (pol2)
           do while (it_hel2%is_valid ())
              qn_hel(2) = it_hel2%get_quantum_numbers ()
              qn_hel(4) = it_hel2%get_quantum_numbers ()
              qn = qn_hel .merge. qn_fc
              call sf_int%add_state (qn)
              call it_hel2%advance ()
           end do
           ! call pol2%final ()
           call it_hel1%advance ()
        end do
        ! call pol1%final ()
        call sf_int%freeze ()
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        call sf_int%data%open ()
        sf_int%status = SF_INITIAL
     end select
   end subroutine beam_events_init
 
 @ %def beam_events_init
 @ This spectrum type needs a finalizer, which closes the data file.
 <<SF beam events: beam events: TBP>>=
   procedure :: final => sf_beam_events_final
 <<SF beam events: sub interfaces>>=
     module subroutine sf_beam_events_final (object)
       class(beam_events_t), intent(inout) :: object
     end subroutine sf_beam_events_final
 <<SF beam events: procedures>>=
   module subroutine sf_beam_events_final (object)
     class(beam_events_t), intent(inout) :: object
     call object%data%close ()
     call object%interaction_t%final ()
   end subroutine sf_beam_events_final
 
 @ %def sf_beam_events_final
 @
 \subsection{Kinematics}
 Refer to the [[data]] component.
 <<SF beam events: beam events: TBP>>=
   procedure :: is_generator => beam_events_is_generator
 <<SF beam events: sub interfaces>>=
     module function beam_events_is_generator (sf_int) result (flag)
       class(beam_events_t), intent(in) :: sf_int
       logical :: flag
     end function beam_events_is_generator
 <<SF beam events: procedures>>=
   module function beam_events_is_generator (sf_int) result (flag)
     class(beam_events_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function beam_events_is_generator
 
 @ %def beam_events_is_generator
 @ Generate free parameters.  We read them from file.
 <<SF beam events: beam events: TBP>>=
   procedure :: generate_free => beam_events_generate_free
 <<SF beam events: sub interfaces>>=
     recursive module subroutine beam_events_generate_free &
          (sf_int, r, rb,  x_free)
       class(beam_events_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(inout) :: x_free
     end subroutine beam_events_generate_free
 <<SF beam events: procedures>>=
   recursive module subroutine beam_events_generate_free &
        (sf_int, r, rb,  x_free)
     class(beam_events_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     integer :: iostat
     associate (data => sf_int%data)
       if (data%unit /= 0) then
          read (data%unit, fmt=*, iostat=iostat)  r
          if (iostat > 0) then
             write (msg_buffer, "(A,I0,A)") &
                  "Beam events: I/O error after reading ", sf_int%count, &
                  " events"
             call msg_fatal ()
          else if (iostat < 0) then
             if (sf_int%count == 0) then
                call msg_fatal ("Beam events: file is empty")
             else if (sf_int%data%warn_eof) then
                write (msg_buffer, "(A,I0,A)") &
                     "Beam events: End of file after reading ", sf_int%count, &
                     " events, rewinding"
                call msg_warning ()
             end if
             rewind (data%unit)
             sf_int%count = 0
             call sf_int%generate_free (r, rb, x_free)
          else
             sf_int%count = sf_int%count + 1
             rb = 1 - r
             x_free = x_free * product (r)
          end if
       else
          call msg_bug ("Beam events: file is not open for reading")
       end if
     end associate
   end subroutine beam_events_generate_free
 
 @ %def beam_events_generate_free
 @ Set kinematics.  Trivial transfer since this is a pure generator.
 The [[map]] flag doesn't apply.
 <<SF beam events: beam events: TBP>>=
   procedure :: complete_kinematics => beam_events_complete_kinematics
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_complete_kinematics &
          (sf_int, x, xb, f, r, rb, map)
       class(beam_events_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine beam_events_complete_kinematics
 <<SF beam events: procedures>>=
   module subroutine beam_events_complete_kinematics &
        (sf_int, x, xb, f, r, rb, map)
     class(beam_events_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("Beam events: map flag not supported")
     else
        x = r
        xb= rb
        f = 1
     end if
     call sf_int%reduce_momenta (x)
   end subroutine beam_events_complete_kinematics
 
 @ %def beam_events_complete_kinematics
 @ Compute inverse kinematics.  Trivial in this case.
 <<SF beam events: beam events: TBP>>=
   procedure :: inverse_kinematics => beam_events_inverse_kinematics
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(beam_events_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine beam_events_inverse_kinematics
 <<SF beam events: procedures>>=
   module subroutine beam_events_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(beam_events_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("Beam events: map flag not supported")
     else
        r = x
        rb= xb
        f = 1
     end if
     if (set_mom) then
        call sf_int%reduce_momenta (x)
     end if
   end subroutine beam_events_inverse_kinematics
 
 @ %def beam_events_inverse_kinematics
 @
 \subsection{Beam events application}
 Trivial, just set the unit weight.
 <<SF beam events: beam events: TBP>>=
   procedure :: apply => beam_events_apply
 <<SF beam events: sub interfaces>>=
     module subroutine beam_events_apply &
          (sf_int, scale, negative_sf, rescale, i_sub)
       class(beam_events_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine beam_events_apply
 <<SF beam events: procedures>>=
   module subroutine beam_events_apply &
        (sf_int, scale, negative_sf, rescale, i_sub)
     class(beam_events_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: f
     f = 1
     call sf_int%set_matrix_element (cmplx (f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine beam_events_apply
 
 @ %def beam_events_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_beam_events_ut.f90]]>>=
 <<File header>>
 
 module sf_beam_events_ut
   use unit_tests
   use sf_beam_events_uti
 
 <<Standard module head>>
 
 <<SF beam events: public test>>
 
 contains
 
 <<SF beam events: test driver>>
 
 end module sf_beam_events_ut
 @ %def sf_beam_events_ut
 @
 <<[[sf_beam_events_uti.f90]]>>=
 <<File header>>
 
 module sf_beam_events_uti
 
 <<Use kinds>>
 <<Use strings>>
   use io_units
   use numeric_utils, only: pacify
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_aux
   use sf_base
 
   use sf_beam_events
 
 <<Standard module head>>
 
 <<SF beam events: test declarations>>
 
 contains
 
 <<SF beam events: tests>>
 
 end module sf_beam_events_uti
 @ %def sf_beam_events_ut
 @ API: driver for the unit tests below.
 <<SF beam events: public test>>=
   public :: sf_beam_events_test
 <<SF beam events: test driver>>=
   subroutine sf_beam_events_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF beam events: execute tests>>
   end subroutine sf_beam_events_test
 
 @ %def sf_beam_events_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF beam events: execute tests>>=
   call test (sf_beam_events_1, "sf_beam_events_1", &
        "structure function configuration", &
        u, results)
 <<SF beam events: test declarations>>=
   public :: sf_beam_events_1
 <<SF beam events: tests>>=
   subroutine sf_beam_events_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_beam_events_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &beam-events structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     allocate (beam_events_data_t :: data)
     select type (data)
     type is (beam_events_data_t)
        call data%init (model, pdg_in, var_str (""), var_str ("beam_events.dat"))
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_beam_events_1"
 
   end subroutine sf_beam_events_1
 
 @ %def sf_beam_events_1
 @
 \subsubsection{Probe the structure-function object}
 Active the beam event reader, generate an event.
 <<SF beam events: execute tests>>=
   call test (sf_beam_events_2, "sf_beam_events_2", &
        "generate event", &
        u, results)
 <<SF beam events: test declarations>>=
   public :: sf_beam_events_2
 <<SF beam events: tests>>=
   subroutine sf_beam_events_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: x_free, f
     integer :: i
 
     write (u, "(A)")  "* Test output: sf_beam_events_2"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &beam-events structure function data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (beam_events_data_t :: data)
     select type (data)
     type is (beam_events_data_t)
        call data%init (model, pdg_in, &
             var_str (""), var_str ("test_beam_events.dat"))
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set dummy parameters and generate x."
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "r =", r
     write (u, "(A,9(1x,F10.7))")  "rb=", rb
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
     select type (sf_int)
     type is (beam_events_t)
        write (u, "(A,1x,I0)")  "count =", sf_int%count
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate more events, rewind"
     write (u, "(A)")
 
     select type (sf_int)
     type is (beam_events_t)
        do i = 1, 3
           call sf_int%generate_free (r, rb, x_free)
           write (u, "(A,9(1x,F10.7))")  "r =", r
           write (u, "(A,1x,I0)")  "count =", sf_int%count
        end do
     end select
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_beam_events_2"
 
   end subroutine sf_beam_events_2
 
 @ %def sf_beam_events_2
 @
 \subsubsection{Check the file handle registry}
 Open and close some files, checking the registry contents.
 <<SF beam events: execute tests>>=
   call test (sf_beam_events_3, "sf_beam_events_3", &
        "check registry", &
        u, results)
 <<SF beam events: test declarations>>=
   public :: sf_beam_events_3
 <<SF beam events: tests>>=
   subroutine sf_beam_events_3 (u)
     integer, intent(in) :: u
     integer :: u1
 
     write (u, "(A)")  "* Test output: sf_beam_events_2"
     write (u, "(A)")  "*   Purpose: check file handle registry"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create some empty files"
     write (u, "(A)")
 
     u1 = free_unit ()
     open (u1, file = "sf_beam_events_f1.tmp", action="write", status="new")
     close (u1)
     open (u1, file = "sf_beam_events_f2.tmp", action="write", status="new")
     close (u1)
     open (u1, file = "sf_beam_events_f3.tmp", action="write", status="new")
     close (u1)
 
     write (u, "(A)")  "* Empty registry"
     write (u, "(A)")
 
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Insert three entries"
     write (u, "(A)")
 
     call beam_file_registry%open (var_str ("sf_beam_events_f3.tmp"))
     call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp"))
     call beam_file_registry%open (var_str ("sf_beam_events_f1.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Open a second channel"
     write (u, "(A)")
 
     call beam_file_registry%open (var_str ("sf_beam_events_f2.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Close second entry twice"
     write (u, "(A)")
 
     call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp"))
     call beam_file_registry%close (var_str ("sf_beam_events_f2.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Close last entry"
     write (u, "(A)")
 
     call beam_file_registry%close (var_str ("sf_beam_events_f3.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Close remaining entry"
     write (u, "(A)")
 
     call beam_file_registry%close (var_str ("sf_beam_events_f1.tmp"))
     call beam_file_registry%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     open (u1, file = "sf_beam_events_f1.tmp", action="write")
     close (u1, status = "delete")
     open (u1, file = "sf_beam_events_f2.tmp", action="write")
     close (u1, status = "delete")
     open (u1, file = "sf_beam_events_f3.tmp", action="write")
     close (u1, status = "delete")
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_beam_events_3"
 
   end subroutine sf_beam_events_3
 
 @ %def sf_beam_events_3
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{Lepton collider beamstrahlung: CIRCE1}
 
 <<[[sf_circe1.f90]]>>=
 <<File header>>
 
 module sf_circe1
 
 <<Use kinds>>
   use kinds, only: double
 <<Use strings>>
   use rng_base
   use pdg_arrays
   use model_data
   use flavors
   use polarizations
   use sf_mappings
   use sf_base
   use circe1, circe1_rng_t => rng_type !NODEP!
 
 <<Standard module head>>
 
 <<SF circe1: public>>
 
 <<SF circe1: types>>
 
   interface
 <<SF circe1: sub interfaces>>
   end interface
 
 contains
 
 <<SF circe1: main procedures>>
 
 end module sf_circe1
 @ %def sf_circe1
 @
 <<[[sf_circe1_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_circe1) sf_circe1_s
 
   use io_units
   use format_defs, only: FMT_17, FMT_19
   use diagnostics
   use physics_defs, only: ELECTRON, PHOTON
   use lorentz
   use colors
   use quantum_numbers
   use state_matrices
 
   implicit none
 
 contains
 
 <<SF circe1: procedures>>
 
 end submodule sf_circe1_s
 
 @ %def sf_circe1_s
 @
 \subsection{Physics}
 Beamstrahlung is applied before ISR.  The [[CIRCE1]] implementation has
 a single structure function for both beams (which makes sense since it
 has to be switched on or off for both beams simultaneously).
 Nevertheless it is factorized:
 
 The functional form in the [[CIRCE1]] parameterization is defined for
 electrons or photons
 \begin{equation}
   f(x) = \alpha\,x^\beta\,(1-x)^\gamma
 \end{equation}
 for $x<1-\epsilon$ (resp.\ $x>\epsilon$ in the photon case).  In the
 remaining interval, the standard form is zero, with a delta
 singularity at $x=1$ (resp.\ $x=0$).  Equivalently, the delta part may be
 distributed uniformly among this interval.  This latter form is
 implemented in the [[kirke]] version of the [[CIRCE1]] subroutines, and
 is used here.
 
 The parameter [[circe1\_eps]] sets the peak mapping of the [[CIRCE1]]
 structure function. Its default value is $10^{-5}$.
 The other parameters are the parameterization version and revision
 number, the accelerator type, and the $\sqrt{s}$ value used by
 [[CIRCE1]]. The chattiness can also be set.
 
 Since the energy is distributed in a narrow region around unity (for
 electrons) or zero (for photons), it is advantageous to map the
 interval first.  The mapping is controlled by the parameter
 [[circe1\_epsilon]] which is taken from the [[CIRCE1]]
 internal data structure.
 
 The $\sqrt{s}$ value, if not explicitly set, is taken from the
 process data.  Note that interpolating $\sqrt{s}$ is not recommended;
 one should rather choose one of the distinct values known to [[CIRCE1]].
 
 \subsection{The CIRCE1 data block}
 The CIRCE1 parameters are: The incoming flavors, the flags whether the photon
 or the lepton is the parton in the hard interaction, the flags for the
 generation mode (generator/mapping/no mapping), the mapping parameter
 $\epsilon$, $\sqrt{s}$ and several steering parameters: [[ver]],
 [[rev]], [[acc]], [[chat]].
 
 In generator mode, the $x$ values are actually discarded and a random number
 generator is used instead.
 <<SF circe1: public>>=
   public :: circe1_data_t
 <<SF circe1: types>>=
   type, extends (sf_data_t) :: circe1_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(2) :: flv_in
      integer, dimension(2) :: pdg_in
      real(default), dimension(2) :: m_in = 0
      logical, dimension(2) :: photon = .false.
      logical :: generate = .false.
      class(rng_factory_t), allocatable :: rng_factory
      real(default) :: sqrts = 0
      real(default) :: eps = 0
      integer :: ver = 0
      integer :: rev = 0
      character(6) :: acc = "?"
      integer :: chat = 0
      logical :: with_radiation = .false.
    contains
      <<SF circe1: circe1 data: TBP>>
   end type circe1_data_t
 
 @ %def circe1_data_t
 @
 <<SF circe1: circe1 data: TBP>>=
   procedure :: init => circe1_data_init
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_data_init &
          (data, model, pdg_in, sqrts, eps, out_photon, &
           ver, rev, acc, chat, with_radiation)
       class(circe1_data_t), intent(out) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), dimension(2), intent(in) :: pdg_in
       real(default), intent(in) :: sqrts
       real(default), intent(in) :: eps
       logical, dimension(2), intent(in) :: out_photon
       character(*), intent(in) :: acc
       integer, intent(in) :: ver, rev, chat
       logical, intent(in) :: with_radiation
     end subroutine circe1_data_init
 <<SF circe1: procedures>>=
   module subroutine circe1_data_init &
        (data, model, pdg_in, sqrts, eps, out_photon, &
         ver, rev, acc, chat, with_radiation)
     class(circe1_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     real(default), intent(in) :: sqrts
     real(default), intent(in) :: eps
     logical, dimension(2), intent(in) :: out_photon
     character(*), intent(in) :: acc
     integer, intent(in) :: ver, rev, chat
     logical, intent(in) :: with_radiation
     data%model => model
     if (any (pdg_in%get_length () /= 1)) then
        call msg_fatal ("CIRCE1: incoming beam particles must be unique")
     end if
     call data%flv_in(1)%init (pdg_in(1)%get (1), model)
     call data%flv_in(2)%init (pdg_in(2)%get (1), model)
     data%pdg_in = data%flv_in%get_pdg ()
     data%m_in = data%flv_in%get_mass ()
     data%sqrts = sqrts
     data%eps = eps
     data%photon = out_photon
     data%ver = ver
     data%rev = rev
     data%acc = acc
     data%chat = chat
     data%with_radiation = with_radiation
     call data%check ()
     call circex (0.d0, 0.d0, dble (data%sqrts), &
          data%acc, data%ver, data%rev, data%chat)
   end subroutine circe1_data_init
 
 @ %def circe1_data_init
 @ Activate the generator mode.  We import a RNG factory into the data
 type, which can then spawn RNG generator objects.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: set_generator_mode => circe1_data_set_generator_mode
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_data_set_generator_mode (data, rng_factory)
       class(circe1_data_t), intent(inout) :: data
       class(rng_factory_t), intent(inout), allocatable :: rng_factory
     end subroutine circe1_data_set_generator_mode
 <<SF circe1: procedures>>=
   module subroutine circe1_data_set_generator_mode (data, rng_factory)
     class(circe1_data_t), intent(inout) :: data
     class(rng_factory_t), intent(inout), allocatable :: rng_factory
     data%generate = .true.
     call move_alloc (from = rng_factory, to = data%rng_factory)
   end subroutine circe1_data_set_generator_mode
 
 @ %def circe1_data_set_generator_mode
 @ Handle error conditions.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: check => circe1_data_check
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_data_check (data)
       class(circe1_data_t), intent(in) :: data
     end subroutine circe1_data_check
 <<SF circe1: procedures>>=
   module subroutine circe1_data_check (data)
     class(circe1_data_t), intent(in) :: data
     type(flavor_t) :: flv_electron, flv_photon
     call flv_electron%init (ELECTRON, data%model)
     call flv_photon%init (PHOTON, data%model)
     if (.not. flv_electron%is_defined () &
          .or. .not. flv_photon%is_defined ()) then
        call msg_fatal ("CIRCE1: model must contain photon and electron")
     end if
     if (any (abs (data%pdg_in) /= ELECTRON) &
          .or. (data%pdg_in(1) /= - data%pdg_in(2))) then
        call msg_fatal ("CIRCE1: applicable only for e+e- or e-e+ collisions")
     end if
     if (data%eps <= 0) then
        call msg_error ("CIRCE1: circe1_eps = 0: integration will &
             &miss x=1 peak")
     end if
   end subroutine circe1_data_check
 
 @ %def circe1_data_check
 @ Output
 <<SF circe1: circe1 data: TBP>>=
   procedure :: write => circe1_data_write
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_data_write (data, unit, verbose)
       class(circe1_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine circe1_data_write
 <<SF circe1: procedures>>=
   module subroutine circe1_data_write (data, unit, verbose)
     class(circe1_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     logical :: verb
     verb = .false.;  if (present (verbose))  verb = verbose
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "CIRCE1 data:"
     write (u, "(3x,A,2(1x,A))") "prt_in   =", &
          char (data%flv_in(1)%get_name ()), &
          char (data%flv_in(2)%get_name ())
     write (u, "(3x,A,2(1x,L1))")  "photon   =", data%photon
     write (u, "(3x,A,L1)")        "generate = ", data%generate
     write (u, "(3x,A,2(1x," // FMT_19 // "))") "m_in     =", data%m_in
     write (u, "(3x,A," // FMT_19 // ")") "sqrts    = ", data%sqrts
     write (u, "(3x,A," // FMT_19 // ")") "eps      = ", data%eps
     write (u, "(3x,A,I0)") "ver      = ", data%ver
     write (u, "(3x,A,I0)") "rev      = ", data%rev
     write (u, "(3x,A,A)")  "acc      = ", data%acc
     write (u, "(3x,A,I0)") "chat     = ", data%chat
     write (u, "(3x,A,L1)") "with rad.= ", data%with_radiation
     if (data%generate) then
        if (verb) then
           call data%rng_factory%write (u)
        end if
     end if
   end subroutine circe1_data_write
 
 @ %def circe1_data_write
 @ Return true if this structure function is in generator mode.  In
 that case, all parameters are free, otherwise bound.  (We do not
 support mixed cases.)  Default is: no generator.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: is_generator => circe1_data_is_generator
 <<SF circe1: sub interfaces>>=
     module function circe1_data_is_generator (data) result (flag)
       class(circe1_data_t), intent(in) :: data
       logical :: flag
     end function circe1_data_is_generator
 <<SF circe1: procedures>>=
   module function circe1_data_is_generator (data) result (flag)
     class(circe1_data_t), intent(in) :: data
     logical :: flag
     flag = data%generate
   end function circe1_data_is_generator
 
 @ %def circe1_data_is_generator
 @ The number of parameters is two, collinear splitting for the two beams.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: get_n_par => circe1_data_get_n_par
 <<SF circe1: sub interfaces>>=
     module function circe1_data_get_n_par (data) result (n)
       class(circe1_data_t), intent(in) :: data
       integer :: n
     end function circe1_data_get_n_par
 <<SF circe1: procedures>>=
   module function circe1_data_get_n_par (data) result (n)
     class(circe1_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function circe1_data_get_n_par
 
 @ %def circe1_data_get_n_par
 @ Return the outgoing particles PDG codes. This is either the incoming
 particle (if a photon is radiated), or the photon if that is the particle
 of the hard interaction. The latter is determined via the [[photon]]
 flag. There are two entries for the two beams.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: get_pdg_out => circe1_data_get_pdg_out
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_data_get_pdg_out (data, pdg_out)
       class(circe1_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine circe1_data_get_pdg_out
 <<SF circe1: procedures>>=
   module subroutine circe1_data_get_pdg_out (data, pdg_out)
     class(circe1_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        if (data%photon(i)) then
           pdg_out(i) = PHOTON
        else
           pdg_out(i) = data%pdg_in(i)
        end if
     end do
   end subroutine circe1_data_get_pdg_out
 
 @ %def circe1_data_get_pdg_out
 @ This variant is not inherited, it returns integers.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: get_pdg_int => circe1_data_get_pdg_int
 <<SF circe1: sub interfaces>>=
     module function circe1_data_get_pdg_int (data) result (pdg)
       class(circe1_data_t), intent(in) :: data
       integer, dimension(2) :: pdg
     end function circe1_data_get_pdg_int
 <<SF circe1: procedures>>=
   module function circe1_data_get_pdg_int (data) result (pdg)
     class(circe1_data_t), intent(in) :: data
     integer, dimension(2) :: pdg
     integer :: i
     do i = 1, 2
        if (data%photon(i)) then
           pdg(i) = PHOTON
        else
           pdg(i) = data%pdg_in(i)
        end if
     end do
   end function circe1_data_get_pdg_int
 
 @ %def circe1_data_get_pdg_int
 @ Allocate the interaction record. Due to the gfortran 7/8/9 bug this
 has to remain in the main module.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: allocate_sf_int => circe1_data_allocate_sf_int
 <<SF circe1: main procedures>>=
   subroutine circe1_data_allocate_sf_int (data, sf_int)
     class(circe1_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (circe1_t :: sf_int)
   end subroutine circe1_data_allocate_sf_int
 
 @ %def circe1_data_allocate_sf_int
 @ Return the accelerator type.
 <<SF circe1: circe1 data: TBP>>=
   procedure :: get_beam_file => circe1_data_get_beam_file
 <<SF circe1: sub interfaces>>=
     module function circe1_data_get_beam_file (data) result (file)
       class(circe1_data_t), intent(in) :: data
       type(string_t) :: file
     end function circe1_data_get_beam_file
 <<SF circe1: procedures>>=
   module function circe1_data_get_beam_file (data) result (file)
     class(circe1_data_t), intent(in) :: data
     type(string_t) :: file
     file = "CIRCE1: " // data%acc
   end function circe1_data_get_beam_file
 
 @ %def circe1_data_get_beam_file
 @
 \subsection{Random Number Generator for CIRCE}
 The CIRCE implementation now supports a generic random-number
 generator object that allows for a local state as a component.  To
 support this, we must extend the abstract type provided by CIRCE and
 delegate the generator call to the (also abstract) RNG used by WHIZARD.
 <<SF circe1: types>>=
   type, extends (circe1_rng_t) :: rng_obj_t
      class(rng_t), allocatable :: rng
    contains
      procedure :: generate => rng_obj_generate
   end type rng_obj_t
 
 @ %def rng_obj_t
 <<SF circe1: sub interfaces>>=
     module subroutine rng_obj_generate (rng_obj, u)
       class(rng_obj_t), intent(inout) :: rng_obj
       real(double), intent(out) :: u
     end subroutine rng_obj_generate
 <<SF circe1: procedures>>=
   module subroutine rng_obj_generate (rng_obj, u)
     class(rng_obj_t), intent(inout) :: rng_obj
     real(double), intent(out) :: u
     real(default) :: x
     call rng_obj%rng%generate (x)
     u = x
   end subroutine rng_obj_generate
 
 @ %def rng_obj_generate
 @
 \subsection{The CIRCE1 object}
 This is a $2\to 4$ interaction, where, depending on the parameters, any two of
 the four outgoing particles are connected to the hard interactions, the others
 are radiated.  Knowing that all particles are colorless, we do not have to
 deal with color.
 
 The flavors are sorted such that the first two particles are the incoming
 leptons, the next two are the radiated particles, and the last two are the
 partons initiating the hard interaction.
 
 CIRCE1 does not support polarized beams explicitly.  For simplicity, we
 nevertheless carry beam polarization through to the outgoing electrons and
 make the photons unpolarized.
 
 In the case that no radiated particle is kept (which actually is the
 default), polarization is always transferred to the electrons, too. If
 there is a recoil photon in the event, the radiated particles are 3
 and 4, respectively, and 5 and 6 are the outgoing ones (triggering the
 hard scattering process), while in the case of no radiation, the
 outgoing particles are 3 and 4, respectively. In the case of the
 electron being the radiated particle, helicity is not kept.
 <<SF circe1: public>>=
   public :: circe1_t
 <<SF circe1: types>>=
   type, extends (sf_int_t) :: circe1_t
      type(circe1_data_t), pointer :: data => null ()
      real(default), dimension(2) :: x = 0
      real(default), dimension(2) :: xb= 0
      real(default) :: f = 0
      logical, dimension(2) :: continuum = .true.
      logical, dimension(2) :: peak = .true.
      type(rng_obj_t) :: rng_obj
    contains
    <<SF circe1: circe1: TBP>>
   end type circe1_t
 
 @ %def circe1_t
 @ Type string: has to be here, but there is no string variable on which CIRCE1
 depends. Hence, a dummy routine.
 <<SF circe1: circe1: TBP>>=
   procedure :: type_string => circe1_type_string
 <<SF circe1: sub interfaces>>=
     module function circe1_type_string (object) result (string)
       class(circe1_t), intent(in) :: object
       type(string_t) :: string
     end function circe1_type_string
 <<SF circe1: procedures>>=
   module function circe1_type_string (object) result (string)
     class(circe1_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "CIRCE1: beamstrahlung"
     else
        string = "CIRCE1: [undefined]"
     end if
   end function circe1_type_string
 
 @ %def circe1_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF circe1: circe1: TBP>>=
   procedure :: write => circe1_write
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_write (object, unit, testflag)
       class(circe1_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine circe1_write
 <<SF circe1: procedures>>=
   module subroutine circe1_write (object, unit, testflag)
     class(circe1_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%data%generate)  call object%rng_obj%rng%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(3x,A,2(1x," // FMT_17 // "))")  "x =", object%x
           write (u, "(3x,A,2(1x," // FMT_17 // "))")  "xb=", object%xb
           if (object%status >= SF_FAILED_EVALUATION) then
              write (u, "(3x,A,1x," // FMT_17 // ")")  "f =", object%f
           end if
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "CIRCE1 data: [undefined]"
     end if
   end subroutine circe1_write
 
 @ %def circe1_write
 @
 <<SF circe1: circe1: TBP>>=
   procedure :: init => circe1_init
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_init (sf_int, data)
       class(circe1_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine circe1_init
 <<SF circe1: procedures>>=
   module subroutine circe1_init (sf_int, data)
     class(circe1_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     logical, dimension(6) :: mask_h
     type(quantum_numbers_mask_t), dimension(6) :: mask
     integer, dimension(6) :: hel_lock
     type(polarization_t), target :: pol1, pol2
     type(quantum_numbers_t), dimension(1) :: qn_fc1, qn_fc2
     type(flavor_t) :: flv_photon
     type(color_t) :: col0
     real(default), dimension(2) :: mi2, mr2, mo2
     type(quantum_numbers_t) :: qn_hel1, qn_hel2, qn_photon, qn1, qn2
     type(quantum_numbers_t), dimension(6) :: qn
     type(polarization_iterator_t) :: it_hel1, it_hel2
     hel_lock = 0
     mask_h = .false.
     select type (data)
     type is (circe1_data_t)
        mi2 = data%m_in**2
        if (data%with_radiation) then
           if (data%photon(1)) then
              hel_lock(1) = 3;  hel_lock(3) = 1;  mask_h(5) = .true.
              mr2(1) = mi2(1)
              mo2(1) = 0._default
           else
              hel_lock(1) = 5;  hel_lock(5) = 1;  mask_h(3) = .true.
              mr2(1) = 0._default
              mo2(1) = mi2(1)
           end if
           if (data%photon(2)) then
              hel_lock(2) = 4;  hel_lock(4) = 2;  mask_h(6) = .true.
              mr2(2) = mi2(2)
              mo2(2) = 0._default
           else
              hel_lock(2) = 6;  hel_lock(6) = 2;  mask_h(4) = .true.
              mr2(2) = 0._default
              mo2(2) = mi2(2)
           end if
           mask = quantum_numbers_mask (.false., .false., mask_h)
           call sf_int%base_init (mask, mi2, mr2, mo2, &
                hel_lock = hel_lock)
           sf_int%data => data
           call flv_photon%init (PHOTON, data%model)
           call col0%init ()
           call qn_photon%init (flv_photon, col0)
           call pol1%init_generic (data%flv_in(1))
           call qn_fc1(1)%init (flv = data%flv_in(1), col = col0)
           call pol2%init_generic (data%flv_in(2))
           call qn_fc2(1)%init (flv = data%flv_in(2), col = col0)
           call it_hel1%init (pol1)
 
           do while (it_hel1%is_valid ())
              qn_hel1 = it_hel1%get_quantum_numbers ()
              qn1 = qn_hel1 .merge. qn_fc1(1)
              qn(1) = qn1
              if (data%photon(1)) then
                 qn(3) = qn1;  qn(5) = qn_photon
              else
                 qn(3) = qn_photon;  qn(5) = qn1
              end if
              call it_hel2%init (pol2)
              do while (it_hel2%is_valid ())
                 qn_hel2 = it_hel2%get_quantum_numbers ()
                 qn2 = qn_hel2 .merge. qn_fc2(1)
                 qn(2) = qn2
                 if (data%photon(2)) then
                    qn(4) = qn2;  qn(6) = qn_photon
                 else
                    qn(4) = qn_photon;  qn(6) = qn2
                 end if
                 call qn(3:4)%tag_radiated ()
                 call sf_int%add_state (qn)
                 call it_hel2%advance ()
              end do
              call it_hel1%advance ()
           end do
 !           call pol1%final ()
 !           call pol2%final ()
           call sf_int%freeze ()
           call sf_int%set_incoming ([1,2])
           call sf_int%set_radiated ([3,4])
           call sf_int%set_outgoing ([5,6])
        else
           if (data%photon(1)) then
              mask_h(3) = .true.
              mo2(1) = 0._default
           else
              hel_lock(1) = 3;  hel_lock(3) = 1
              mo2(1) = mi2(1)
           end if
           if (data%photon(2)) then
              mask_h(4) = .true.
              mo2(2) = 0._default
           else
              hel_lock(2) = 4;  hel_lock(4) = 2
              mo2(2) = mi2(2)
           end if
           mask = quantum_numbers_mask (.false., .false., mask_h)
           call sf_int%base_init (mask(1:4), mi2, [real(default) :: ], mo2, &
                hel_lock = hel_lock(1:4))
           sf_int%data => data
           call flv_photon%init (PHOTON, data%model)
           call col0%init ()
           call qn_photon%init (flv_photon, col0)
           call pol1%init_generic (data%flv_in(1))
           call qn_fc1(1)%init (flv = data%flv_in(1), col = col0)
           call pol2%init_generic (data%flv_in(2))
           call qn_fc2(1)%init (flv = data%flv_in(2), col = col0)
           call it_hel1%init (pol1)
 
           do while (it_hel1%is_valid ())
              qn_hel1 = it_hel1%get_quantum_numbers ()
              qn1 = qn_hel1 .merge. qn_fc1(1)
              qn(1) = qn1
              if (data%photon(1)) then
                 qn(3) = qn_photon
              else
                 qn(3) = qn1
              end if
              call it_hel2%init (pol2)
              do while (it_hel2%is_valid ())
                 qn_hel2 = it_hel2%get_quantum_numbers ()
                 qn2 = qn_hel2 .merge. qn_fc2(1)
                 qn(2) = qn2
                 if (data%photon(2)) then
                    qn(4) = qn_photon
                 else
                    qn(4) = qn2
                 end if
                 call sf_int%add_state (qn(1:4))
                 call it_hel2%advance ()
              end do
              call it_hel1%advance ()
           end do
 !           call pol1%final ()
 !           call pol2%final ()
           call sf_int%freeze ()
           call sf_int%set_incoming ([1,2])
           call sf_int%set_outgoing ([3,4])
        end if
        sf_int%status = SF_INITIAL
     end select
     if (sf_int%data%generate) then
        call sf_int%data%rng_factory%make (sf_int%rng_obj%rng)
     end if
   end subroutine circe1_init
 
 @ %def circe1_init
 @
 \subsection{Kinematics}
 Refer to the [[data]] component.
 <<SF circe1: circe1: TBP>>=
   procedure :: is_generator => circe1_is_generator
 <<SF circe1: sub interfaces>>=
     module function circe1_is_generator (sf_int) result (flag)
       class(circe1_t), intent(in) :: sf_int
       logical :: flag
     end function circe1_is_generator
 <<SF circe1: procedures>>=
   module function circe1_is_generator (sf_int) result (flag)
     class(circe1_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function circe1_is_generator
 
 @ %def circe1_is_generator
 @ Generate free parameters, if generator mode is on.  Otherwise, the
 parameters will be discarded.
 <<SF circe1: circe1: TBP>>=
   procedure :: generate_free => circe1_generate_free
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_generate_free (sf_int, r, rb,  x_free)
       class(circe1_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(inout) :: x_free
     end subroutine circe1_generate_free
 <<SF circe1: procedures>>=
   module subroutine circe1_generate_free (sf_int, r, rb,  x_free)
     class(circe1_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
 
     if (sf_int%data%generate) then
        call circe_generate (r, sf_int%data%get_pdg_int (), sf_int%rng_obj)
        rb = 1 - r
        x_free = x_free * product (r)
     else
        r = 0
        rb= 1
     end if
   end subroutine circe1_generate_free
 
 @ %def circe1_generate_free
 @ Generator mode: depending on the particle codes, call one of the
 available [[girce]] generators.  Illegal particle code combinations
 should have been caught during data initialization.
 <<SF circe1: procedures>>=
   subroutine circe_generate (x, pdg, rng_obj)
     real(default), dimension(2), intent(out) :: x
     integer, dimension(2), intent(in) :: pdg
     class(rng_obj_t), intent(inout) :: rng_obj
     real(double) :: xc1, xc2
     select case (abs (pdg(1)))
     case (ELECTRON)
        select case (abs (pdg(2)))
        case (ELECTRON)
           call gircee (xc1, xc2, rng_obj = rng_obj)
        case (PHOTON)
           call girceg (xc1, xc2, rng_obj = rng_obj)
        end select
     case (PHOTON)
        select case (abs (pdg(2)))
        case (ELECTRON)
           call girceg (xc2, xc1, rng_obj = rng_obj)
        case (PHOTON)
           call gircgg (xc1, xc2, rng_obj = rng_obj)
        end select
     end select
     x = [xc1, xc2]
   end subroutine circe_generate
 
 @ %def circe_generate
 @ Set kinematics.  The $r$ values (either from integration or from the
 generator call above) are copied to $x$ unchanged, and $f$ is unity.
 We store the $x$ values, so we can use them for the evaluation later.
 <<SF circe1: circe1: TBP>>=
   procedure :: complete_kinematics => circe1_complete_kinematics
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_complete_kinematics &
          (sf_int, x, xb, f, r, rb, map)
       class(circe1_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine circe1_complete_kinematics
 <<SF circe1: procedures>>=
   module subroutine circe1_complete_kinematics &
        (sf_int, x, xb, f, r, rb, map)
     class(circe1_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     x = r
     xb = rb
     sf_int%x = x
     sf_int%xb= xb
     f = 1
     if (sf_int%data%with_radiation) then
        call sf_int%split_momenta (x, xb)
     else
        call sf_int%reduce_momenta (x)
     end if
     select case (sf_int%status)
     case (SF_FAILED_KINEMATICS);  f = 0
     end select
   end subroutine circe1_complete_kinematics
 
 @ %def circe1_complete_kinematics
 @ Compute inverse kinematics.  In generator mode, the $r$ values are
 meaningless, but we copy them anyway.
 <<SF circe1: circe1: TBP>>=
   procedure :: inverse_kinematics => circe1_inverse_kinematics
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(circe1_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine circe1_inverse_kinematics
 <<SF circe1: procedures>>=
   module subroutine circe1_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(circe1_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     r = x
     rb = xb
     sf_int%x = x
     sf_int%xb= xb
     f = 1
     if (set_mom) then
        call sf_int%split_momenta (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine circe1_inverse_kinematics
 
 @ %def circe1_inverse_kinematics
 @
 \subsection{CIRCE1 application}
 CIRCE is applied for the two beams at once.  We can safely assume that no
 structure functions are applied before this, so the incoming particles are
 on-shell electrons/positrons.
 
 The scale is ignored.
 <<SF circe1: circe1: TBP>>=
   procedure :: apply => circe1_apply
 <<SF circe1: sub interfaces>>=
     module subroutine circe1_apply (sf_int, scale, negative_sf, rescale, i_sub)
       class(circe1_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine circe1_apply
 <<SF circe1: procedures>>=
   module subroutine circe1_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(circe1_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default), dimension(2) :: xb
     real(double), dimension(2) :: xc
     real(double), parameter :: one = 1
     associate (data => sf_int%data)
       xc = sf_int%x
       xb = sf_int%xb
       if (data%generate) then
          sf_int%f = 1
       else
          sf_int%f = 0
          if (all (sf_int%continuum)) then
             sf_int%f = circe (xc(1), xc(2), data%pdg_in(1), data%pdg_in(2))
          end if
          if (sf_int%continuum(2) .and. sf_int%peak(1)) then
             sf_int%f = sf_int%f &
                  + circe (one, xc(2), data%pdg_in(1), data%pdg_in(2)) &
                  * peak (xb(1), data%eps)
          end if
          if (sf_int%continuum(1) .and. sf_int%peak(2)) then
             sf_int%f = sf_int%f &
                  + circe (xc(1), one, data%pdg_in(1), data%pdg_in(2)) &
                  * peak (xb(2), data%eps)
          end if
          if (all (sf_int%peak)) then
             sf_int%f = sf_int%f &
                  + circe (one, one, data%pdg_in(1), data%pdg_in(2)) &
                  * peak (xb(1), data%eps) * peak (xb(2), data%eps)
          end if
       end if
     end associate
     call sf_int%set_matrix_element (cmplx (sf_int%f, kind=default))
     sf_int%status = SF_EVALUATED
   end subroutine circe1_apply
 
 @ %def circe1_apply
 @ This is a smeared delta peak at zero, as an endpoint singularity.
 We choose an exponentially decreasing function, starting at zero, with
 integral (from $0$ to $1$) $1-e^{-1/\epsilon}$.  For small $\epsilon$,
 this reduces to one.
 <<SF circe1: procedures>>=
   function peak (x, eps) result (f)
     real(default), intent(in) :: x, eps
     real(default) :: f
     f = exp (-x / eps) / eps
   end function peak
 
 @ %def peak
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_circe1_ut.f90]]>>=
 <<File header>>
 
 module sf_circe1_ut
   use unit_tests
   use sf_circe1_uti
 
 <<Standard module head>>
 
 <<SF circe1: public test>>
 
 contains
 
 <<SF circe1: test driver>>
 
 end module sf_circe1_ut
 @ %def sf_circe1_ut
 @
 <<[[sf_circe1_uti.f90]]>>=
 <<File header>>
 
 module sf_circe1_uti
 
 <<Use kinds>>
   use physics_defs, only: ELECTRON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use rng_base
   use sf_aux
   use sf_base
 
   use sf_circe1
 
   use rng_base_ut, only: rng_test_factory_t
 
 <<Standard module head>>
 
 <<SF circe1: test declarations>>
 
 contains
 
 <<SF circe1: tests>>
 
 end module sf_circe1_uti
 @ %def sf_circe1_ut
 @ API: driver for the unit tests below.
 <<SF circe1: public test>>=
   public :: sf_circe1_test
 <<SF circe1: test driver>>=
   subroutine sf_circe1_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF circe1: execute tests>>
   end subroutine sf_circe1_test
 
 @ %def sf_circe1_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF circe1: execute tests>>=
   call test (sf_circe1_1, "sf_circe1_1", &
        "structure function configuration", &
        u, results)
 <<SF circe1: test declarations>>=
   public :: sf_circe1_1
 <<SF circe1: tests>>=
   subroutine sf_circe1_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_circe1_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &CIRCE structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_qed_test ()
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     allocate (circe1_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     select type (data)
     type is (circe1_data_t)
        call data%init (model, pdg_in, &
             sqrts = 500._default, &
             eps = 1e-6_default, &
             out_photon = [.false., .false.], &
             ver = 0, &
             rev = 0, &
             acc = "SBAND", &
             chat = 0, &
             with_radiation = .true.)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe1_1"
 
   end subroutine sf_circe1_1
 
 @ %def sf_circe1_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the PDF builtin
 structure function.
 <<SF circe1: execute tests>>=
   call test (sf_circe1_2, "sf_circe1_2", &
        "structure function instance", &
        u, results)
 <<SF circe1: test declarations>>=
   public :: sf_circe1_2
 <<SF circe1: tests>>=
   subroutine sf_circe1_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     type(vector4_t), dimension(4) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_circe1_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &circe1 structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (circe1_data_t :: data)
     select type (data)
     type is (circe1_data_t)
        call data%init (model, pdg_in, &
             sqrts = 500._default, &
             eps = 1e-6_default, &
             out_photon = [.false., .false.], &
             ver = 0, &
             rev = 0, &
             acc = "SBAND", &
             chat = 0, &
             with_radiation = .true.)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.95,0.85."
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = [0.9_default, 0.8_default]
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1, 2])
 
     call sf_int%seed_kinematics ([k1, k2])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe1_2"
 
   end subroutine sf_circe1_2
 
 @ %def sf_circe1_2
 @
 \subsubsection{Generator mode}
 Construct and evaluate a structure function object in generator mode.
 <<SF circe1: execute tests>>=
   call test (sf_circe1_3, "sf_circe1_3", &
        "generator mode", &
        u, results)
 <<SF circe1: test declarations>>=
   public :: sf_circe1_3
 <<SF circe1: tests>>=
   subroutine sf_circe1_3 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(rng_factory_t), allocatable :: rng_factory
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, x_free
 
     write (u, "(A)")  "* Test output: sf_circe1_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &circe1 structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_qed_test ()
     call flv(1)%init (ELECTRON, model)
     call flv(2)%init (-ELECTRON, model)
     pdg_in(1) = ELECTRON
     pdg_in(2) = -ELECTRON
 
     call reset_interaction_counter ()
 
     allocate (circe1_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (circe1_data_t)
        call data%init (model, pdg_in, &
             sqrts = 500._default, &
             eps = 1e-6_default, &
             out_photon = [.false., .false.], &
             ver = 0, &
             rev = 0, &
             acc = "SBAND", &
             chat = 0, &
             with_radiation = .true.)
        call data%set_generator_mode (rng_factory)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
     select type (sf_int)
     type is (circe1_t)
        call sf_int%rng_obj%rng%init (3)
     end select
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate x"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe1_3"
 
   end subroutine sf_circe1_3
 
 @ %def sf_circe1_3
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{Lepton Collider Beamstrahlung and Photon collider: CIRCE2}
 
 <<[[sf_circe2.f90]]>>=
 <<File header>>
 
 module sf_circe2
 
 <<Use kinds>>
 <<Use strings>>
   use os_interface
   use rng_base
   use selectors
   use pdg_arrays
   use model_data
   use flavors
   use polarizations
   use sf_base
   use circe2, circe2_rng_t => rng_type !NODEP!
 
 <<Standard module head>>
 
 <<SF circe2: public>>
 
 <<SF circe2: types>>
 
   interface
 <<SF circe2: sub interfaces>>
   end interface
 
 contains
 
 <<SF circe2: main procedures>>
 
 end module sf_circe2
 @ %def sf_circe2
 @
 <<[[sf_circe2_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_circe2) sf_circe2_s
 
   use io_units
   use format_defs, only: FMT_19
   use numeric_utils
   use diagnostics
   use physics_defs, only: PHOTON, ELECTRON, MUON
   use lorentz
   use colors
   use helicities
   use quantum_numbers
   use state_matrices
 
   implicit none
 
 contains
 
 <<SF circe2: procedures>>
 
 end submodule sf_circe2_s
 
 @ %def sf_circe2_s
 @
 \subsection{Physics}
 [[CIRCE2]] describes photon spectra
 Beamstrahlung is applied before ISR.  The [[CIRCE2]] implementation has
 a single structure function for both beams (which makes sense since it
 has to be switched on or off for both beams simultaneously).
 
 
 \subsection{The CIRCE2 data block}
 The CIRCE2 parameters are: file and collider specification, incoming
 (= outgoing) particles.  The luminosity is returned by [[circe2_luminosity]].
 <<SF circe2: public>>=
   public :: circe2_data_t
 <<SF circe2: types>>=
   type, extends (sf_data_t) :: circe2_data_t
      private
      class(model_data_t), pointer :: model => null ()
      type(flavor_t), dimension(2) :: flv_in
      integer, dimension(2) :: pdg_in
      real(default) :: sqrts = 0
      logical :: polarized = .false.
      logical :: beams_polarized = .false.
      class(rng_factory_t), allocatable :: rng_factory
      type(string_t) :: filename
      type(string_t) :: file
      type(string_t) :: design
      real(default) :: lumi = 0
      real(default), dimension(4) :: lumi_hel_frac = 0
      integer, dimension(0:4) :: h1 = [0, -1, -1, 1, 1]
      integer, dimension(0:4) :: h2 = [0, -1,  1,-1, 1]
      integer :: error = 1
    contains
      <<SF circe2: circe2 data: TBP>>
   end type circe2_data_t
 
 @ %def circe2_data_t
 <<SF circe2: types>>=
   type(circe2_state) :: circe2_global_state
 
 @
 <<SF circe2: circe2 data: TBP>>=
   procedure :: init => circe2_data_init
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_data_init (data, os_data, model, pdg_in, &
          sqrts, polarized, beam_pol, file, design)
       class(circe2_data_t), intent(out) :: data
       type(os_data_t), intent(in) :: os_data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), dimension(2), intent(in) :: pdg_in
       real(default), intent(in) :: sqrts
       logical, intent(in) :: polarized, beam_pol
       type(string_t), intent(in) :: file, design
     end subroutine circe2_data_init
 <<SF circe2: procedures>>=
   module subroutine circe2_data_init (data, os_data, model, pdg_in, &
        sqrts, polarized, beam_pol, file, design)
     class(circe2_data_t), intent(out) :: data
     type(os_data_t), intent(in) :: os_data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), dimension(2), intent(in) :: pdg_in
     real(default), intent(in) :: sqrts
     logical, intent(in) :: polarized, beam_pol
     type(string_t), intent(in) :: file, design
     integer :: h
     data%model => model
     if (any (pdg_in%get_length () /= 1)) then
        call msg_fatal ("CIRCE2: incoming beam particles must be unique")
     end if
     call data%flv_in(1)%init (pdg_in(1)%get (1), model)
     call data%flv_in(2)%init (pdg_in(2)%get (1), model)
     data%pdg_in = data%flv_in%get_pdg ()
     data%sqrts = sqrts
     data%polarized = polarized
     data%beams_polarized = beam_pol
     data%filename = file
     data%design = design
     call data%check_file (os_data)
     call circe2_load (circe2_global_state, trim (char(data%file)), &
             trim (char(data%design)), data%sqrts, data%error)
     call data%check ()
     data%lumi = circe2_luminosity (circe2_global_state, data%pdg_in, [0, 0])
     if (vanishes (data%lumi)) then
        call msg_fatal ("CIRCE2: luminosity vanishes for specified beams.")
     end if
     if (data%polarized) then
        do h = 1, 4
           data%lumi_hel_frac(h) = &
                circe2_luminosity (circe2_global_state, data%pdg_in, &
                             [data%h1(h), data%h2(h)]) &
                / data%lumi
        end do
     end if
   end subroutine circe2_data_init
 
 @ %def circe2_data_init
 @ Activate the generator mode.  We import a RNG factory into the data
 type, which can then spawn RNG generator objects.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: set_generator_mode => circe2_data_set_generator_mode
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_data_set_generator_mode (data, rng_factory)
       class(circe2_data_t), intent(inout) :: data
       class(rng_factory_t), intent(inout), allocatable :: rng_factory
     end subroutine circe2_data_set_generator_mode
 <<SF circe2: procedures>>=
   module subroutine circe2_data_set_generator_mode (data, rng_factory)
     class(circe2_data_t), intent(inout) :: data
     class(rng_factory_t), intent(inout), allocatable :: rng_factory
     call move_alloc (from = rng_factory, to = data%rng_factory)
   end subroutine circe2_data_set_generator_mode
 
 @ %def circe2_data_set_generator_mode
 @ Check whether the requested data file is in the system directory or
 in the current directory.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: check_file => circe2_check_file
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_check_file (data, os_data)
       class(circe2_data_t), intent(inout) :: data
       type(os_data_t), intent(in) :: os_data
     end subroutine circe2_check_file
 <<SF circe2: procedures>>=
   module subroutine circe2_check_file (data, os_data)
     class(circe2_data_t), intent(inout) :: data
     type(os_data_t), intent(in) :: os_data
     logical :: exist
     type(string_t) :: file
     file = data%filename
     if (file == "") &
          call msg_fatal ("CIRCE2: $circe2_file is not set")
     inquire (file = char (file), exist = exist)
     if (exist) then
        data%file = file
     else
        file = os_data%whizard_circe2path // "/" // data%filename
        inquire (file = char (file), exist = exist)
        if (exist) then
           data%file = file
        else
           call msg_fatal ("CIRCE2: data file '" // char (data%filename) &
                // "' not found")
        end if
     end if
   end subroutine circe2_check_file
 
 @ %def circe2_check_file
 @ Handle error conditions.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: check => circe2_data_check
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_data_check (data)
       class(circe2_data_t), intent(in) :: data
     end subroutine circe2_data_check
 <<SF circe2: procedures>>=
   module subroutine circe2_data_check (data)
     class(circe2_data_t), intent(in) :: data
     type(flavor_t) :: flv_photon, flv_electron, flv_muon
     call flv_photon%init (PHOTON, data%model)
     if (.not. flv_photon%is_defined ()) then
        call msg_fatal ("CIRCE2: model must contain photon")
     end if
     if (any (abs (data%pdg_in) /= PHOTON .and. abs (data%pdg_in) /= &
          ELECTRON .and. abs (data%pdg_in) /= MUON)) then
        call msg_fatal ("CIRCE2: applicable only for e+e-, mu+mu- or " // &
             "photon collisions")
     end if
     if (any (abs (data%pdg_in) == ELECTRON)) then
        call flv_electron%init (ELECTRON, data%model)
        if (.not. flv_electron%is_defined ()) then
           call msg_fatal ("CIRCE2: model must contain electron")
        end if
     end if
     if (any (abs (data%pdg_in) == MUON)) then
        call flv_muon%init (MUON, data%model)
        if (.not. flv_muon%is_defined ()) then
           call msg_fatal ("CIRCE2: model must contain muon")
        end if
     end if
     select case (data%error)
     case (-1)
        call msg_fatal ("CIRCE2: data file not found.")
     case (-2)
        call msg_fatal ("CIRCE2: beam setup does not match data file.")
     case (-3)
        call msg_fatal ("CIRCE2: invalid format of data file.")
     case (-4)
        call msg_fatal ("CIRCE2: data file too large.")
     end select
   end subroutine circe2_data_check
 
 @ %def circe2_data_check
 @ Output
 <<SF circe2: circe2 data: TBP>>=
   procedure :: write => circe2_data_write
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_data_write (data, unit, verbose)
       class(circe2_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine circe2_data_write
 <<SF circe2: procedures>>=
   module subroutine circe2_data_write (data, unit, verbose)
     class(circe2_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u, h
     logical :: verb
     verb = .false.;  if (present (verbose))  verb = verbose
     u = given_output_unit (unit)
     write (u, "(1x,A)") "CIRCE2 data:"
     write (u, "(3x,A,A)")       "file   = ", char(data%filename)
     write (u, "(3x,A,A)")       "design = ", char(data%design)
     write (u, "(3x,A," // FMT_19 // ")") "sqrts  = ", data%sqrts
     write (u, "(3x,A,A,A,A)")   "prt_in = ", &
          char (data%flv_in(1)%get_name ()), &
          ", ", char (data%flv_in(2)%get_name ())
     write (u, "(3x,A,L1)")      "polarized  = ", data%polarized
     write (u, "(3x,A,L1)")      "beams pol. = ", data%beams_polarized
     write (u, "(3x,A," // FMT_19 // ")") "luminosity = ", data%lumi
     if (data%polarized) then
        do h = 1, 4
           write (u, "(6x,'(',I2,1x,I2,')',1x,'=',1x)", advance="no") &
                data%h1(h), data%h2(h)
           write (u, "(6x, " // FMT_19 // ")")  data%lumi_hel_frac(h)
        end do
     end if
     if (verb) then
        call data%rng_factory%write (u)
     end if
   end subroutine circe2_data_write
 
 @ %def circe2_data_write
 @ This is always in generator mode.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: is_generator => circe2_data_is_generator
 <<SF circe2: sub interfaces>>=
     module function circe2_data_is_generator (data) result (flag)
       class(circe2_data_t), intent(in) :: data
       logical :: flag
     end function circe2_data_is_generator
 <<SF circe2: procedures>>=
   module function circe2_data_is_generator (data) result (flag)
     class(circe2_data_t), intent(in) :: data
     logical :: flag
     flag = .true.
   end function circe2_data_is_generator
 
 @ %def circe2_data_is_generator
 @ The number of parameters is two, collinear splitting for
 the two beams.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: get_n_par => circe2_data_get_n_par
 <<SF circe2: sub interfaces>>=
     module function circe2_data_get_n_par (data) result (n)
       class(circe2_data_t), intent(in) :: data
       integer :: n
     end function circe2_data_get_n_par
 <<SF circe2: procedures>>=
   module function circe2_data_get_n_par (data) result (n)
     class(circe2_data_t), intent(in) :: data
     integer :: n
     n = 2
   end function circe2_data_get_n_par
 
 @ %def circe2_data_get_n_par
 @ Return the outgoing particles PDG codes.  They are equal to the
 incoming ones.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: get_pdg_out => circe2_data_get_pdg_out
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_data_get_pdg_out (data, pdg_out)
       class(circe2_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine circe2_data_get_pdg_out
 <<SF circe2: procedures>>=
   module subroutine circe2_data_get_pdg_out (data, pdg_out)
     class(circe2_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer :: i, n
     n = 2
     do i = 1, n
        pdg_out(i) = data%pdg_in(i)
     end do
   end subroutine circe2_data_get_pdg_out
 
 @ %def circe2_data_get_pdg_out
 @ Allocate the interaction record. Due to gfortran 7/8/9 bug has to
 remain in the main module.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: allocate_sf_int => circe2_data_allocate_sf_int
 <<SF circe2: main procedures>>=
   subroutine circe2_data_allocate_sf_int (data, sf_int)
     class(circe2_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (circe2_t :: sf_int)
   end subroutine circe2_data_allocate_sf_int
 
 @ %def circe2_data_allocate_sf_int
 @ Return the beam file.
 <<SF circe2: circe2 data: TBP>>=
   procedure :: get_beam_file => circe2_data_get_beam_file
 <<SF circe2: sub interfaces>>=
     module function circe2_data_get_beam_file (data) result (file)
       class(circe2_data_t), intent(in) :: data
       type(string_t) :: file
     end function circe2_data_get_beam_file
 <<SF circe2: procedures>>=
   module function circe2_data_get_beam_file (data) result (file)
     class(circe2_data_t), intent(in) :: data
     type(string_t) :: file
     file = "CIRCE2: " // data%filename
   end function circe2_data_get_beam_file
 
 @ %def circe2_data_get_beam_file
 @
 \subsection{Random Number Generator for CIRCE}
 The CIRCE implementation now supports a generic random-number
 generator object that allows for a local state as a component.  To
 support this, we must extend the abstract type provided by CIRCE and
 delegate the generator call to the (also abstract) RNG used by WHIZARD.
 <<SF circe2: types>>=
   type, extends (circe2_rng_t) :: rng_obj_t
      class(rng_t), allocatable :: rng
    contains
      procedure :: generate => rng_obj_generate
   end type rng_obj_t
 
 @ %def rng_obj_t
 <<SF circe2: sub interfaces>>=
     module subroutine rng_obj_generate (rng_obj, u)
       class(rng_obj_t), intent(inout) :: rng_obj
       real(default), intent(out) :: u
     end subroutine rng_obj_generate
 <<SF circe2: procedures>>=
   module subroutine rng_obj_generate (rng_obj, u)
     class(rng_obj_t), intent(inout) :: rng_obj
     real(default), intent(out) :: u
     real(default) :: x
     call rng_obj%rng%generate (x)
     u = x
   end subroutine rng_obj_generate
 
 @ %def rng_obj_generate
 @
 \subsection{The CIRCE2 object}
 For CIRCE2 spectra it does not make sense to describe the state matrix
 as a radiation interaction, even if photons originate from laser
 backscattering.  Instead, it is a $2\to 2$ interaction where the
 incoming particles are identical to the outgoing ones.
 
 The current implementation of CIRCE2 does support polarization and
 classical correlations, but no entanglement, so the density matrix of
 the outgoing particles is diagonal.  The incoming particles are
 unpolarized (user-defined polarization for beams is meaningless, since
 polarization is described by the data file).  The outgoing particles
 are polarized or polarization-averaged, depending on user request.
 
 When assigning matrix elements, we scan the previously initialized
 state matrix.  For each entry, we extract helicity and call the
 structure function.  In the unpolarized case, the helicity is
 undefined and replaced by value zero.  In the polarized case, there
 are four entries.  If the generator is used, only one entry is nonzero
 in each call.  Which one, is determined by comparing with a previously
 (randomly, distributed by relative luminosity) selected pair of
 helicities.
 <<SF circe2: public>>=
   public :: circe2_t
 <<SF circe2: types>>=
   type, extends (sf_int_t) :: circe2_t
      type(circe2_data_t), pointer :: data => null ()
      type(rng_obj_t) :: rng_obj
      type(selector_t) :: selector
      integer :: h_sel = 0
    contains
    <<SF circe2: circe2: TBP>>
   end type circe2_t
 
 @ %def circe2_t
 @ Type string: show file and design of [[CIRCE2]] structure function.
 <<SF circe2: circe2: TBP>>=
   procedure :: type_string => circe2_type_string
 <<SF circe2: sub interfaces>>=
     module function circe2_type_string (object) result (string)
       class(circe2_t), intent(in) :: object
       type(string_t) :: string
     end function circe2_type_string
 <<SF circe2: procedures>>=
   module function circe2_type_string (object) result (string)
     class(circe2_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "CIRCE2: " // object%data%design
     else
        string = "CIRCE2: [undefined]"
     end if
   end function circe2_type_string
 
 @ %def circe2_type_string
 @
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF circe2: circe2: TBP>>=
   procedure :: write => circe2_write
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_write (object, unit, testflag)
       class(circe2_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine circe2_write
 <<SF circe2: procedures>>=
   module subroutine circe2_write (object, unit, testflag)
     class(circe2_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "CIRCE2 data: [undefined]"
     end if
   end subroutine circe2_write
 
 @ %def circe2_write
 @
 <<SF circe2: circe2: TBP>>=
   procedure :: init => circe2_init
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_init (sf_int, data)
       class(circe2_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine circe2_init
 <<SF circe2: procedures>>=
   module subroutine circe2_init (sf_int, data)
     class(circe2_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     logical, dimension(4) :: mask_h
     real(default), dimension(2) :: m2_array
     real(default), dimension(0) :: null_array
     type(quantum_numbers_mask_t), dimension(4) :: mask
     type(quantum_numbers_t), dimension(4) :: qn
     type(helicity_t) :: hel
     type(color_t) :: col0
     integer :: h
     select type (data)
     type is (circe2_data_t)
        if (data%polarized .and. data%beams_polarized) then
           call msg_fatal ("CIRCE2: Beam polarization can't be set &
                &for polarized data file")
        else if (data%beams_polarized) then
           call msg_warning ("CIRCE2: User-defined beam polarization set &
                &for unpolarized CIRCE2 data file")
        end if
        mask_h(1:2) = .not. data%beams_polarized
        mask_h(3:4) = .not. (data%polarized .or. data%beams_polarized)
        mask = quantum_numbers_mask (.false., .false., mask_h)
        m2_array(:) = (data%flv_in(:)%get_mass ())**2
        call sf_int%base_init (mask, m2_array, null_array, m2_array)
        sf_int%data => data
        if (data%polarized) then
           if (vanishes (sum (data%lumi_hel_frac)) .or. &
                any (data%lumi_hel_frac < 0)) then
              call msg_fatal ("CIRCE2: Helicity-dependent lumi " &
                   // "fractions all vanish or",  &
                   [var_str ("are negative: Please inspect the " &
                   // "CIRCE2 file or "), &
                    var_str ("switch off the polarized" // &
                   " option for CIRCE2.")])
           else
              call sf_int%selector%init (data%lumi_hel_frac)
           end if
        end if
        call col0%init ()
        if (data%beams_polarized) then
           do h = 1, 4
              call hel%init (data%h1(h))
              call qn(1)%init &
                   (flv = data%flv_in(1), col = col0, hel = hel)
              call qn(3)%init &
                   (flv = data%flv_in(1), col = col0, hel = hel)
              call hel%init (data%h2(h))
              call qn(2)%init &
                   (flv = data%flv_in(2), col = col0, hel = hel)
              call qn(4)%init &
                   (flv = data%flv_in(2), col = col0, hel = hel)
              call sf_int%add_state (qn)
           end do
        else if (data%polarized) then
           call qn(1)%init (flv = data%flv_in(1), col = col0)
           call qn(2)%init (flv = data%flv_in(2), col = col0)
           do h = 1, 4
              call hel%init (data%h1(h))
              call qn(3)%init &
                   (flv = data%flv_in(1), col = col0, hel = hel)
              call hel%init (data%h2(h))
              call qn(4)%init &
                   (flv = data%flv_in(2), col = col0, hel = hel)
              call sf_int%add_state (qn)
           end do
        else
           call qn(1)%init (flv = data%flv_in(1), col = col0)
           call qn(2)%init (flv = data%flv_in(2), col = col0)
           call qn(3)%init (flv = data%flv_in(1), col = col0)
           call qn(4)%init (flv = data%flv_in(2), col = col0)
           call sf_int%add_state (qn)
        end if
        call sf_int%freeze ()
        call sf_int%set_incoming ([1,2])
        call sf_int%set_outgoing ([3,4])
        call sf_int%data%rng_factory%make (sf_int%rng_obj%rng)
        sf_int%status = SF_INITIAL
     end select
   end subroutine circe2_init
 
 @ %def circe2_init
 @
 \subsection{Kinematics}
 Refer to the [[data]] component.
 <<SF circe2: circe2: TBP>>=
   procedure :: is_generator => circe2_is_generator
 <<SF circe2: sub interfaces>>=
     module function circe2_is_generator (sf_int) result (flag)
       class(circe2_t), intent(in) :: sf_int
       logical :: flag
     end function circe2_is_generator
 <<SF circe2: procedures>>=
   module function circe2_is_generator (sf_int) result (flag)
     class(circe2_t), intent(in) :: sf_int
     logical :: flag
     flag = sf_int%data%is_generator ()
   end function circe2_is_generator
 
 @ %def circe2_is_generator
 @ Generate free parameters.  We first select a helicity, which we have
 to store, then generate $x$ values for that helicity.
 <<SF circe2: circe2: TBP>>=
   procedure :: generate_free => circe2_generate_whizard_free
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free)
       class(circe2_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: r, rb
       real(default), intent(inout) :: x_free
     end subroutine circe2_generate_whizard_free
 <<SF circe2: procedures>>=
   module subroutine circe2_generate_whizard_free (sf_int, r, rb, x_free)
     class(circe2_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: r, rb
     real(default), intent(inout) :: x_free
     integer :: h_sel
     if (sf_int%data%polarized) then
        call sf_int%selector%generate (sf_int%rng_obj%rng, h_sel)
     else
        h_sel = 0
     end if
     sf_int%h_sel = h_sel
     call circe2_generate_whizard (r, sf_int%data%pdg_in, &
          [sf_int%data%h1(h_sel), sf_int%data%h2(h_sel)], &
          sf_int%rng_obj)
     rb = 1 - r
     x_free = x_free * product (r)
   end subroutine circe2_generate_whizard_free
 
 @ %def circe2_generate_whizard_free
 @ Generator mode: call the CIRCE2 generator for the given particles
 and helicities.  (For unpolarized generation, helicities are zero.)
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_generate_whizard (x, pdg, hel, rng_obj)
       real(default), dimension(2), intent(out) :: x
       integer, dimension(2), intent(in) :: pdg
       integer, dimension(2), intent(in) :: hel
       class(rng_obj_t), intent(inout) :: rng_obj
     end subroutine circe2_generate_whizard
 <<SF circe2: procedures>>=
   module subroutine circe2_generate_whizard (x, pdg, hel, rng_obj)
     real(default), dimension(2), intent(out) :: x
     integer, dimension(2), intent(in) :: pdg
     integer, dimension(2), intent(in) :: hel
     class(rng_obj_t), intent(inout) :: rng_obj
     call circe2_generate (circe2_global_state, rng_obj, x, pdg, hel)
   end subroutine circe2_generate_whizard
 
 @ %def circe2_generate_whizard
 @ Set kinematics.  Trivial here.
 <<SF circe2: circe2: TBP>>=
   procedure :: complete_kinematics => circe2_complete_kinematics
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map)
       class(circe2_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine circe2_complete_kinematics
 <<SF circe2: procedures>>=
   module subroutine circe2_complete_kinematics (sf_int, x, xb, f, r, rb, map)
     class(circe2_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("CIRCE2: map flag not supported")
     else
        x = r
        xb= rb
        f = 1
     end if
     call sf_int%reduce_momenta (x)
   end subroutine circe2_complete_kinematics
 
 @ %def circe2_complete_kinematics
 @ Compute inverse kinematics.
 <<SF circe2: circe2: TBP>>=
   procedure :: inverse_kinematics => circe2_inverse_kinematics
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(circe2_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine circe2_inverse_kinematics
 <<SF circe2: procedures>>=
   module subroutine circe2_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(circe2_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("CIRCE2: map flag not supported")
     else
        r = x
        rb= xb
        f = 1
     end if
     if (set_mom) then
        call sf_int%reduce_momenta (x)
     end if
   end subroutine circe2_inverse_kinematics
 
 @ %def circe2_inverse_kinematics
 @
 \subsection{CIRCE2 application}
 This function works on both beams.  In polarized mode, we set only the
 selected helicity.  In unpolarized mode,
 the interaction has only one entry, and the factor is unity.
 <<SF circe2: circe2: TBP>>=
   procedure :: apply => circe2_apply
 <<SF circe2: sub interfaces>>=
     module subroutine circe2_apply (sf_int, scale, negative_sf, rescale, i_sub)
       class(circe2_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine circe2_apply
 <<SF circe2: procedures>>=
   module subroutine circe2_apply (sf_int, scale, negative_sf, rescale, i_sub)
     class(circe2_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     complex(default) :: f
     associate (data => sf_int%data)
       f = 1
       if (data%beams_polarized) then
          call sf_int%set_matrix_element (f)
       else if (data%polarized) then
          call sf_int%set_matrix_element (sf_int%h_sel, f)
       else
          call sf_int%set_matrix_element (1, f)
       end if
     end associate
     sf_int%status = SF_EVALUATED
   end subroutine circe2_apply
 
 @ %def circe2_apply
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_circe2_ut.f90]]>>=
 <<File header>>
 
 module sf_circe2_ut
   use unit_tests
   use sf_circe2_uti
 
 <<Standard module head>>
 
 <<SF circe2: public test>>
 
 contains
 
 <<SF circe2: test driver>>
 
 end module sf_circe2_ut
 @ %def sf_circe2_ut
 @
 <<[[sf_circe2_uti.f90]]>>=
 <<File header>>
 
 module sf_circe2_uti
 
 <<Use kinds>>
 <<Use strings>>
   use os_interface
   use physics_defs, only: PHOTON
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use rng_base
   use sf_aux
   use sf_base
 
   use sf_circe2
 
   use rng_base_ut, only: rng_test_factory_t
 
 <<Standard module head>>
 
 <<SF circe2: test declarations>>
 
 contains
 
 <<SF circe2: tests>>
 
 end module sf_circe2_uti
 @ %def sf_circe2_ut
 @ API: driver for the unit tests below.
 <<SF circe2: public test>>=
   public :: sf_circe2_test
 <<SF circe2: test driver>>=
   subroutine sf_circe2_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF circe2: execute tests>>
   end subroutine sf_circe2_test
 
 @ %def sf_circe2_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF circe2: execute tests>>=
   call test (sf_circe2_1, "sf_circe2_1", &
        "structure function configuration", &
        u, results)
 <<SF circe2: test declarations>>=
   public :: sf_circe2_1
 <<SF circe2: tests>>=
   subroutine sf_circe2_1 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(pdg_array_t), dimension(2) :: pdg_in
     type(pdg_array_t), dimension(2) :: pdg_out
     integer, dimension(:), allocatable :: pdg1, pdg2
     class(sf_data_t), allocatable :: data
     class(rng_factory_t), allocatable :: rng_factory
 
     write (u, "(A)")  "* Test output: sf_circe2_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &CIRCE structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_qed_test ()
     pdg_in(1) = PHOTON
     pdg_in(2) = PHOTON
 
     allocate (circe2_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize (unpolarized)"
     write (u, "(A)")
 
     select type (data)
     type is (circe2_data_t)
        call data%init (os_data, model, pdg_in, &
             sqrts = 500._default, &
             polarized = .false., &
             beam_pol = .false., &
             file = var_str ("teslagg_500_polavg.circe"), &
             design = var_str ("TESLA/GG"))
        call data%set_generator_mode (rng_factory)
     end select
 
     call data%write (u, verbose = .true.)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     pdg2 = pdg_out(2)
     write (u, "(2x,99(1x,I0))")  pdg1, pdg2
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize (polarized)"
     write (u, "(A)")
 
     allocate (rng_test_factory_t :: rng_factory)
 
     select type (data)
     type is (circe2_data_t)
        call data%init (os_data, model, pdg_in, &
             sqrts = 500._default, &
             polarized = .true., &
             beam_pol = .false., &
             file = var_str ("teslagg_500.circe"), &
             design = var_str ("TESLA/GG"))
        call data%set_generator_mode (rng_factory)
     end select
 
     call data%write (u, verbose = .true.)
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe2_1"
 
   end subroutine sf_circe2_1
 
 @ %def sf_circe2_1
 @
 \subsubsection{Generator mode, unpolarized}
 Construct and evaluate a structure function object in generator mode.
 <<SF circe2: execute tests>>=
   call test (sf_circe2_2, "sf_circe2_2", &
        "generator, unpolarized", &
        u, results)
 <<SF circe2: test declarations>>=
   public :: sf_circe2_2
 <<SF circe2: tests>>=
   subroutine sf_circe2_2 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(rng_factory_t), allocatable :: rng_factory
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, x_free
 
     write (u, "(A)")  "* Test output: sf_circe2_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &circe2 structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_qed_test ()
     call flv(1)%init (PHOTON, model)
     call flv(2)%init (PHOTON, model)
     pdg_in(1) = PHOTON
     pdg_in(2) = PHOTON
 
     call reset_interaction_counter ()
 
     allocate (circe2_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (circe2_data_t)
        call data%init (os_data, model, pdg_in, &
             sqrts = 500._default, &
             polarized = .false., &
             beam_pol = .false., &
             file = var_str ("teslagg_500_polavg.circe"), &
             design = var_str ("TESLA/GG"))
        call data%set_generator_mode (rng_factory)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
     select type (sf_int)
     type is (circe2_t)
        call sf_int%rng_obj%rng%init (3)
     end select
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate x"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe2_2"
 
   end subroutine sf_circe2_2
 
 @ %def sf_circe2_2
 @
 \subsubsection{Generator mode, polarized}
 Construct and evaluate a structure function object in generator mode.
 <<SF circe2: execute tests>>=
   call test (sf_circe2_3, "sf_circe2_3", &
        "generator, polarized", &
        u, results)
 <<SF circe2: test declarations>>=
   public :: sf_circe2_3
 <<SF circe2: tests>>=
   subroutine sf_circe2_3 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(flavor_t), dimension(2) :: flv
     type(pdg_array_t), dimension(2) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(rng_factory_t), allocatable :: rng_factory
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k1, k2
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f, x_free
 
     write (u, "(A)")  "* Test output: sf_circe2_3"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &circe2 structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_qed_test ()
     call flv(1)%init (PHOTON, model)
     call flv(2)%init (PHOTON, model)
     pdg_in(1) = PHOTON
     pdg_in(2) = PHOTON
 
     call reset_interaction_counter ()
 
     allocate (circe2_data_t :: data)
     allocate (rng_test_factory_t :: rng_factory)
     select type (data)
     type is (circe2_data_t)
        call data%init (os_data, model, pdg_in, &
             sqrts = 500._default, &
             polarized = .true., &
             beam_pol = .false., &
             file = var_str ("teslagg_500.circe"), &
             design = var_str ("TESLA/GG"))
        call data%set_generator_mode (rng_factory)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1,2])
     select type (sf_int)
     type is (circe2_t)
        call sf_int%rng_obj%rng%init (3)
     end select
 
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 250
     k1 = vector4_moving (E, sqrt (E**2 - flv(1)%get_mass ()**2), 3)
     k2 = vector4_moving (E,-sqrt (E**2 - flv(2)%get_mass ()**2), 3)
     call vector4_write (k1, u)
     call vector4_write (k2, u)
     call sf_int%seed_kinematics ([k1, k2])
 
     write (u, "(A)")
     write (u, "(A)")  "* Generate x"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r  = 0
     rb = 0
     x_free = 1
     call sf_int%generate_free (r, rb, x_free)
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
     write (u, "(A,9(1x,F10.7))")  "xf=", x_free
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate"
     write (u, "(A)")
 
     call sf_int%apply (scale = 0._default)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_circe2_3"
 
   end subroutine sf_circe2_3
 
 @ %def sf_circe2_3
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{HOPPET interface}
 Interface to the HOPPET wrapper necessary to perform
 the LO vs. NLO matching of processes containing an initial
 b quark.
 <<[[hoppet_interface.f90]]>>=
 <<File header>>
 
 module hoppet_interface
   use lhapdf !NODEP!
 
 <<Standard module head>>
 
   public :: hoppet_init, hoppet_eval
 
 contains
 
   subroutine hoppet_init (pdf_builtin, pdf, pdf_id)
     logical, intent(in) :: pdf_builtin
     type(lhapdf_pdf_t), intent(inout), optional :: pdf
     integer, intent(in), optional :: pdf_id
     external InitForWhizard
     call InitForWhizard (pdf_builtin, pdf, pdf_id)
   end subroutine hoppet_init
 
   subroutine hoppet_eval (x, q, f)
     double precision, intent(in)  :: x, q
     double precision, intent(out) :: f(-6:6)
     external EvalForWhizard
     call EvalForWhizard (x, q, f)
   end subroutine hoppet_eval
 
 end module hoppet_interface
 @ %def hoppet_interface
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{Builtin PDF sets}
 For convenience in order not to depend on the external package LHAPDF,
 we ship some PDFs with WHIZARD.
 @
 \subsection{The module}
 <<[[sf_pdf_builtin.f90]]>>=
 <<File header>>
 
 module sf_pdf_builtin
 
 <<Use kinds>>
   use kinds, only: double
 <<Use strings>>
   use sm_qcd
   use pdg_arrays
   use model_data
   use flavors
   use polarizations
   use sf_base
 
 <<Standard module head>>
 
 <<SF pdf builtin: public>>
 
 <<SF pdf builtin: types>>
 
   interface
 <<SF pdf builtin: sub interfaces>>
   end interface
 
 contains
 
 <<SF pdf builtin: main procedures>>
 
 end module sf_pdf_builtin
 @ %def sf_pdf_builtin
 @
 <<[[sf_pdf_builtin_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_pdf_builtin) sf_pdf_builtin_s
 
   use io_units
   use format_defs, only: FMT_17
   use diagnostics
   use os_interface
   use physics_defs, only: PROTON, PHOTON, GLUON
   use physics_defs, only: HADRON_REMNANT_SINGLET
   use physics_defs, only: HADRON_REMNANT_TRIPLET
   use physics_defs, only: HADRON_REMNANT_OCTET
   use lorentz
   use colors
   use quantum_numbers
   use state_matrices
   use pdf_builtin !NODEP!
   use hoppet_interface
 
   implicit none
 
 <<SF pdf builtin: parameters>>
 
 contains
 
 <<SF pdf builtin: procedures>>
 
 end submodule sf_pdf_builtin_s
 
 @ %def sf_pdf_builtin_s
 @
 \subsection{Codes for default PDF sets}
 <<SF pdf builtin: parameters>>=
   character(*), parameter :: PDF_BUILTIN_DEFAULT_PROTON = "CTEQ6L"
   ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PION   = "NONE"
   ! character(*), parameter :: PDF_BUILTIN_DEFAULT_PHOTON = "MRST2004QEDp"
 @ %def PDF_BUILTIN_DEFAULT_SET
 @
 \subsection{The PDF builtin data block}
 The data block holds the incoming flavor (which has to be proton,
 pion, or photon), the corresponding pointer to the global access data
 (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the
 bounds as returned by LHAPDF for the specified set, and a mask that
 determines which partons will be actually in use.
 <<SF pdf builtin: public>>=
   public :: pdf_builtin_data_t
 <<SF pdf builtin: types>>=
   type, extends (sf_data_t) :: pdf_builtin_data_t
      private
      integer :: id = -1
      type (string_t) :: name
      class(model_data_t), pointer :: model => null ()
      type(flavor_t) :: flv_in
      logical :: invert
      logical :: has_photon
      logical :: photon
      logical, dimension(-6:6) :: mask
      logical :: mask_photon
      logical :: hoppet_b_matching = .false.
    contains
    <<SF pdf builtin: pdf builtin data: TBP>>
   end type pdf_builtin_data_t
 
 @ %def pdf_builtin_data_t
 @ Generate PDF data and initialize the requested set. Pion and photon PDFs
 are disabled at the moment until we ship appropiate structure functions.
 needed.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: init => pdf_builtin_data_init
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_data_init (data, &
          model, pdg_in, name, path, hoppet_b_matching)
       class(pdf_builtin_data_t), intent(out) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), intent(in) :: pdg_in
       type(string_t), intent(in) :: name
       type(string_t), intent(in) :: path
       logical, intent(in), optional :: hoppet_b_matching
     end subroutine pdf_builtin_data_init
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_data_init (data, &
        model, pdg_in, name, path, hoppet_b_matching)
     class(pdf_builtin_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: path
     logical, intent(in), optional :: hoppet_b_matching
     data%model => model
     if (pdg_in%get_length () /= 1) &
          call msg_fatal ("PDF: incoming particle must be unique")
     call data%flv_in%init (pdg_in%get (1), model)
     data%mask = .true.
     data%mask_photon = .true.
     select case (pdg_in%get (1))
     case (PROTON)
        data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON)
        data%invert = .false.
        data%photon = .false.
     case (-PROTON)
        data%name = var_str (PDF_BUILTIN_DEFAULT_PROTON)
        data%invert = .true.
        data%photon = .false.
        ! case (PIPLUS)
        !    data%name = var_str (PDF_BUILTIN_DEFAULT_PION)
        !    data%invert = .false.
        !    data%photon = .false.
        ! case (-PIPLUS)
        !    data%name = var_str (PDF_BUILTIN_DEFAULT_PION)
        !    data%invert = .true.
        !    data%photon = .false.
        ! case (PHOTON)
        !    data%name = var_str (PDF_BUILTIN_DEFAULT_PHOTON)
        !    data%invert = .false.
        !    data%photon = .true.
     case default
        call msg_fatal ("PDF: " &
             // "incoming particle must either proton or antiproton.")
        return
     end select
     data%name = name
     data%id = pdf_get_id (data%name)
     if (data%id < 0) call msg_fatal ("unknown PDF set " // char (data%name))
     data%has_photon = pdf_provides_photon (data%id)
     if (present (hoppet_b_matching))  data%hoppet_b_matching = hoppet_b_matching
     call pdf_init (data%id, path)
     if (data%hoppet_b_matching)  call hoppet_init (.true., pdf_id = data%id)
   end subroutine pdf_builtin_data_init
 
 @ %def pdf_builtin_data_init
 @ Enable/disable partons explicitly.  If a mask entry is true,
 applying the PDF will generate the corresponding flavor on output.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: set_mask => pdf_builtin_data_set_mask
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_data_set_mask (data, mask)
       class(pdf_builtin_data_t), intent(inout) :: data
       logical, dimension(-6:6), intent(in) :: mask
     end subroutine pdf_builtin_data_set_mask
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_data_set_mask (data, mask)
     class(pdf_builtin_data_t), intent(inout) :: data
     logical, dimension(-6:6), intent(in) :: mask
     data%mask = mask
   end subroutine pdf_builtin_data_set_mask
 
 @ %def pdf_builtin_data_set_mask
 @ Output.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: write => pdf_builtin_data_write
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_data_write (data, unit, verbose)
       class(pdf_builtin_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine pdf_builtin_data_write
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_data_write (data, unit, verbose)
     class(pdf_builtin_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     integer :: u
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)")  "PDF builtin data:"
     if (data%id < 0) then
        write (u, "(3x,A)") "[undefined]"
        return
     end if
     write (u, "(3x,A)", advance="no") "flavor       = "
     call data%flv_in%write (u);  write (u, *)
     write (u, "(3x,A,A)")   "name         = ", char (data%name)
     write (u, "(3x,A,L1)")  "invert       = ", data%invert
     write (u, "(3x,A,L1)")  "has photon   = ", data%has_photon
     write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") &
          "mask         =", &
          data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6)
     write (u, "(3x,A,L1)") "photon mask  = ", data%mask_photon
     write (u, "(3x,A,L1)") "hoppet_b     = ", data%hoppet_b_matching
   end subroutine pdf_builtin_data_write
 
 @ %def pdf_builtin_data_write
 @ The number of parameters is one.  We do not generate transverse momentum.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: get_n_par => pdf_builtin_data_get_n_par
 <<SF pdf builtin: sub interfaces>>=
     module function pdf_builtin_data_get_n_par (data) result (n)
       class(pdf_builtin_data_t), intent(in) :: data
       integer :: n
     end function pdf_builtin_data_get_n_par
 <<SF pdf builtin: procedures>>=
   module function pdf_builtin_data_get_n_par (data) result (n)
     class(pdf_builtin_data_t), intent(in) :: data
     integer :: n
     n = 1
   end function pdf_builtin_data_get_n_par
 
 @ %def pdf_builtin_data_get_n_par
 @ Return the outgoing particle PDG codes.  This is based on the mask.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: get_pdg_out => pdf_builtin_data_get_pdg_out
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_data_get_pdg_out (data, pdg_out)
       class(pdf_builtin_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine pdf_builtin_data_get_pdg_out
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_data_get_pdg_out (data, pdg_out)
     class(pdf_builtin_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     integer :: n, np, i
     n = count (data%mask)
     np = 0;  if (data%has_photon .and. data%mask_photon)  np = 1
     allocate (pdg1 (n + np))
     pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask)
     if (np == 1)  pdg1(n+np) = PHOTON
     pdg_out(1) = pdg1
   end subroutine pdf_builtin_data_get_pdg_out
 
 @ %def pdf_builtin_data_get_pdg_out
 @ Allocate the interaction record. Due to gfortran 7/8/9 bug this has
 to remain in the main module.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: allocate_sf_int => pdf_builtin_data_allocate_sf_int
 <<SF pdf builtin: main procedures>>=
   subroutine pdf_builtin_data_allocate_sf_int (data, sf_int)
     class(pdf_builtin_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (pdf_builtin_t :: sf_int)
   end subroutine pdf_builtin_data_allocate_sf_int
 
 @ %def pdf_builtin_data_allocate_sf_int
 @ Return the numerical PDF set index.
 <<SF pdf builtin: pdf builtin data: TBP>>=
   procedure :: get_pdf_set => pdf_builtin_data_get_pdf_set
 <<SF pdf builtin: sub interfaces>>=
     elemental module function pdf_builtin_data_get_pdf_set &
          (data) result (pdf_set)
       class(pdf_builtin_data_t), intent(in) :: data
       integer :: pdf_set
     end function pdf_builtin_data_get_pdf_set
 <<SF pdf builtin: procedures>>=
   elemental module function pdf_builtin_data_get_pdf_set &
        (data) result (pdf_set)
     class(pdf_builtin_data_t), intent(in) :: data
     integer :: pdf_set
     pdf_set = data%id
   end function pdf_builtin_data_get_pdf_set
 
 @ %def pdf_builtin_data_get_pdf_set
 @
 \subsection{The PDF object}
 The PDF $1\to 2$ interaction which describes
 the splitting of an (anti)proton into a parton and a beam remnant.  We
 stay in the strict forward-splitting limit, but allow some invariant
 mass for the beam remnant such that the outgoing parton is exactly
 massless.  For a real event, we would replace this by a parton
 cascade, where the outgoing partons have virtuality as dictated by
 parton-shower kinematics, and transverse momentum is generated.
 
 The PDF application is a $1\to 2$ splitting process, where the
 particles are ordered as (hadron, remnant, parton).
 
 Polarization is ignored completely.  The beam particle is colorless,
 while partons and beam remnant carry color.  The remnant gets a
 special flavor code.
 <<SF pdf builtin: public>>=
   public :: pdf_builtin_t
 <<SF pdf builtin: types>>=
   type, extends (sf_int_t) :: pdf_builtin_t
      type(pdf_builtin_data_t), pointer :: data => null ()
      real(default) :: x = 0
      real(default) :: q = 0
   contains
   <<SF pdf builtin: pdf builtin: TBP>>
   end type pdf_builtin_t
 
 @ %def pdf_builtin_t
 @ Type string: display the chosen PDF set.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: type_string => pdf_builtin_type_string
 <<SF pdf builtin: sub interfaces>>=
     module function pdf_builtin_type_string (object) result (string)
       class(pdf_builtin_t), intent(in) :: object
       type(string_t) :: string
     end function pdf_builtin_type_string
 <<SF pdf builtin: procedures>>=
   module function pdf_builtin_type_string (object) result (string)
     class(pdf_builtin_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "PDF builtin: " // object%data%name
     else
        string = "PDF builtin: [undefined]"
     end if
   end function pdf_builtin_type_string
 
 @ %def pdf_builtin_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: write => pdf_builtin_write
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_write (object, unit, testflag)
       class(pdf_builtin_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine pdf_builtin_write
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_write (object, unit, testflag)
     class(pdf_builtin_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_17 // ")")  "x =", object%x
           if (object%status >= SF_FAILED_EVALUATION) then
              write (u, "(3x,A," // FMT_17 // ")")  "Q =", object%q
           end if
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "PDF builtin data: [undefined]"
     end if
   end subroutine pdf_builtin_write
 
 @ %def pdf_builtin_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_test_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass, but keep the radiated mass zero.
 
 Optionally, we can provide minimum and maximum values for the momentum
 transfer.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: init => pdf_builtin_init
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_init (sf_int, data)
       class(pdf_builtin_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine pdf_builtin_init
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_init (sf_int, data)
     class(pdf_builtin_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     type(flavor_t) :: flv, flv_remnant
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(3) :: qn
     integer :: i
     select type (data)
     type is (pdf_builtin_data_t)
        mask = quantum_numbers_mask (.false., .false., .true.)
        call col0%init ()
        call sf_int%base_init (mask, [0._default], [0._default], [0._default])
        sf_int%data => data
        do i = -6, 6
           if (data%mask(i)) then
              call qn(1)%init (data%flv_in, col = col0)
              if (i == 0) then
                 call flv%init (GLUON, data%model)
                 call flv_remnant%init (HADRON_REMNANT_OCTET, data%model)
              else
                 call flv%init (i, data%model)
                 call flv_remnant%init &
                      (sign (HADRON_REMNANT_TRIPLET, -i), data%model)
              end if
              call qn(2)%init ( &
                   flv = flv_remnant, col = color_from_flavor (flv_remnant, 1))
              call qn(2)%tag_radiated ()
              call qn(3)%init ( &
                   flv = flv, col = color_from_flavor (flv, 1, reverse=.true.))
              call sf_int%add_state (qn)
           end if
        end do
        if (data%has_photon .and. data%mask_photon) then
           call flv%init (PHOTON, data%model)
           call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model)
           call qn(2)%init (flv = flv_remnant, &
                col = color_from_flavor (flv_remnant, 1))
           call qn(2)%tag_radiated ()
           call qn(3)%init (flv = flv, &
                col = color_from_flavor (flv, 1, reverse = .true.))
           call sf_int%add_state (qn)
        end if
        call sf_int%freeze ()
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
        sf_int%status = SF_INITIAL
     end select
   end subroutine pdf_builtin_init
 
 @ %def pdf_builtin_init
 @
 \subsection{Kinematics}
 Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 If [[map]] is set, we are asked to provide an efficient mapping.
 For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: complete_kinematics => pdf_builtin_complete_kinematics
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_complete_kinematics &
          (sf_int, x, xb, f, r, rb, map)
       class(pdf_builtin_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine pdf_builtin_complete_kinematics
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_complete_kinematics &
        (sf_int, x, xb, f, r, rb, map)
     class(pdf_builtin_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("PDF builtin: map flag not supported")
     else
        x(1) = r(1)
        xb(1)= rb(1)
        f = 1
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_DONE_KINEMATICS)
        sf_int%x = x(1)
     case (SF_FAILED_KINEMATICS)
        sf_int%x = 0
        f = 0
     end select
   end subroutine pdf_builtin_complete_kinematics
 
 @ %def pdf_builtin_complete_kinematics
 @ Overriding the default method: we compute the [[x]] value from the
 momentum configuration.  In this specific case, we also set the
 internally stored $x$ value, so it can be used in the
 following routine.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: recover_x => pdf_builtin_recover_x
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free)
       class(pdf_builtin_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(inout), optional :: x_free
     end subroutine pdf_builtin_recover_x
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_recover_x (sf_int, x, xb, x_free)
     class(pdf_builtin_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
   end subroutine pdf_builtin_recover_x
 
 @ %def sf_pdf_builtin_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: inverse_kinematics => pdf_builtin_inverse_kinematics
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(pdf_builtin_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine pdf_builtin_inverse_kinematics
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(pdf_builtin_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("PDF builtin: map flag not supported")
     else
        r(1) = x(1)
        rb(1)= xb(1)
        f = 1
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine pdf_builtin_inverse_kinematics
 
 @ %def pdf_builtin_inverse_kinematics
 @
 \subsection{Structure function}
 Once the scale is also known, we can actually call the PDF and
 set the values.  Contrary to LHAPDF, the wrapper already takes care of
 adjusting to the $x$ and $Q$ bounds.  Account for the Jacobian.
 
 The parameter [[negative_sf]] is necessary to determine if we allow for negative PDF values.
 The class [[rescale]] gives rescaling prescription for NLO convolution of the
 structure function in combination with [[i_sub]].
 <<SF pdf builtin: pdf builtin: TBP>>=
   procedure :: apply => pdf_builtin_apply
 <<SF pdf builtin: sub interfaces>>=
     module subroutine pdf_builtin_apply &
          (sf_int, scale, negative_sf, rescale, i_sub)
       class(pdf_builtin_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine pdf_builtin_apply
 <<SF pdf builtin: procedures>>=
   module subroutine pdf_builtin_apply &
        (sf_int, scale, negative_sf, rescale, i_sub)
     class(pdf_builtin_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default), dimension(-6:6) :: ff
     real(double), dimension(-6:6) :: ff_dbl
     real(default) :: x, fph
     real(double) :: xx, qq
     complex(default), dimension(:), allocatable :: fc
     integer :: i, j_sub, i_sub_opt
     logical :: negative_sf_opt
     i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub
     negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf
     associate (data => sf_int%data)
       sf_int%q = scale
       x = sf_int%x
       if (present (rescale))  call rescale%apply (x)
       if (debug2_active (D_BEAMS)) then
          call msg_debug2 (D_BEAMS, "pdf_builtin_apply")
          call msg_debug2 (D_BEAMS, "rescale: ", present(rescale))
          call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt)
          call msg_debug2 (D_BEAMS, "x: ", x)
       end if
       xx = x
       qq = scale
       if (data%invert) then
          if (data%has_photon) then
             call pdf_evolve (data%id, x, scale, ff(6:-6:-1), fph)
          else
             if (data%hoppet_b_matching) then
                call hoppet_eval (xx, qq, ff_dbl(6:-6:-1))
                ff = ff_dbl
             else
                call pdf_evolve (data%id, x, scale, ff(6:-6:-1))
             end if
          end if
       else
          if (data%has_photon) then
             call pdf_evolve (data%id, x, scale, ff, fph)
          else
             if (data%hoppet_b_matching) then
                call hoppet_eval (xx, qq, ff_dbl)
                ff = ff_dbl
             else
                call pdf_evolve (data%id, x, scale, ff)
             end if
          end if
       end if
       if (data%has_photon) then
          allocate (fc (count ([data%mask, data%mask_photon])))
          if (negative_sf_opt) then
             fc = pack ([ff, fph], [data%mask, data%mask_photon])
          else
             fc = max( pack ([ff, fph], [data%mask, data%mask_photon]), 0._default)
          end if
       else
          allocate (fc (count (data%mask)))
          if (negative_sf_opt) then
             fc = pack (ff, data%mask)
          else
             fc = max( pack (ff, data%mask), 0._default)
          end if
       end if
     end associate
     if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc)
     call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))])
     sf_int%status = SF_EVALUATED
   end subroutine pdf_builtin_apply
 
 @ %def pdf_builtin_apply
 @
 \subsection{Strong Coupling}
 Since the PDF codes provide a function for computing the running
 $\alpha_s$ value, we make this available as an implementation of the
 abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation.
 <<SF pdf builtin: public>>=
   public :: alpha_qcd_pdf_builtin_t
 <<SF pdf builtin: types>>=
   type, extends (alpha_qcd_t) :: alpha_qcd_pdf_builtin_t
      type(string_t) :: pdfset_name
      integer :: pdfset_id = -1
    contains
    <<SF pdf builtin: alpha qcd: TBP>>
   end type alpha_qcd_pdf_builtin_t
 
 @ %def alpha_qcd_pdf_builtin_t
 @ Output.
 <<SF pdf builtin: alpha qcd: TBP>>=
   procedure :: write => alpha_qcd_pdf_builtin_write
 <<SF pdf builtin: sub interfaces>>=
     module subroutine alpha_qcd_pdf_builtin_write (object, unit)
       class(alpha_qcd_pdf_builtin_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine alpha_qcd_pdf_builtin_write
 <<SF pdf builtin: procedures>>=
   module subroutine alpha_qcd_pdf_builtin_write (object, unit)
     class(alpha_qcd_pdf_builtin_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A)")  "QCD parameters (pdf_builtin):"
     write (u, "(5x,A,A)")  "PDF set = ", char (object%pdfset_name)
     write (u, "(5x,A,I0)") "PDF ID  = ", object%pdfset_id
   end subroutine alpha_qcd_pdf_builtin_write
 
 @ %def alpha_qcd_pdf_builtin_write
 @ Calculation: the numeric ID selects the correct PDF set, which must
 be properly initialized.
 <<SF pdf builtin: alpha qcd: TBP>>=
   procedure :: get => alpha_qcd_pdf_builtin_get
 <<SF pdf builtin: sub interfaces>>=
     module function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha)
       class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd
       real(default), intent(in) :: scale
       real(default) :: alpha
     end function alpha_qcd_pdf_builtin_get
 <<SF pdf builtin: procedures>>=
   module function alpha_qcd_pdf_builtin_get (alpha_qcd, scale) result (alpha)
     class(alpha_qcd_pdf_builtin_t), intent(in) :: alpha_qcd
     real(default), intent(in) :: scale
     real(default) :: alpha
     alpha = pdf_alphas (alpha_qcd%pdfset_id, scale)
   end function alpha_qcd_pdf_builtin_get
 
 @ %def alpha_qcd_pdf_builtin_get
 @
 Initialization.  We need to access the global initialization status.
 <<SF pdf builtin: alpha qcd: TBP>>=
   procedure :: init => alpha_qcd_pdf_builtin_init
 <<SF pdf builtin: sub interfaces>>=
     module subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path)
       class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd
       type(string_t), intent(in) :: name
       type(string_t), intent(in) :: path
     end subroutine alpha_qcd_pdf_builtin_init
 <<SF pdf builtin: procedures>>=
   module subroutine alpha_qcd_pdf_builtin_init (alpha_qcd, name, path)
     class(alpha_qcd_pdf_builtin_t), intent(out) :: alpha_qcd
     type(string_t), intent(in) :: name
     type(string_t), intent(in) :: path
     alpha_qcd%pdfset_name = name
     alpha_qcd%pdfset_id = pdf_get_id (name)
     if (alpha_qcd%pdfset_id < 0) &
          call msg_fatal ("QCD parameter initialization: PDF set " &
          // char (name) // " is unknown")
     call pdf_init (alpha_qcd%pdfset_id, path)
   end subroutine alpha_qcd_pdf_builtin_init
 
 @ %def alpha_qcd_pdf_builtin_init
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_pdf_builtin_ut.f90]]>>=
 <<File header>>
 
 module sf_pdf_builtin_ut
   use unit_tests
   use sf_pdf_builtin_uti
 
 <<Standard module head>>
 
 <<SF pdf builtin: public test>>
 
 contains
 
 <<SF pdf builtin: test driver>>
 
 end module sf_pdf_builtin_ut
 @ %def sf_pdf_builtin_ut
 @
 <<[[sf_pdf_builtin_uti.f90]]>>=
 <<File header>>
 
 module sf_pdf_builtin_uti
 
 <<Use kinds>>
 <<Use strings>>
   use os_interface
   use physics_defs, only: PROTON
   use sm_qcd
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_base
 
   use sf_pdf_builtin
 
 <<Standard module head>>
 
 <<SF pdf builtin: test declarations>>
 
 contains
 
 <<SF pdf builtin: tests>>
 
 end module sf_pdf_builtin_uti
 @ %def sf_pdf_builtin_ut
 @ API: driver for the unit tests below.
 <<SF pdf builtin: public test>>=
   public :: sf_pdf_builtin_test
 <<SF pdf builtin: test driver>>=
   subroutine sf_pdf_builtin_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF pdf builtin: execute tests>>
   end subroutine sf_pdf_builtin_test
 
 @ %def sf_pdf_builtin_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF pdf builtin: execute tests>>=
   call test (sf_pdf_builtin_1, "sf_pdf_builtin_1", &
        "structure function configuration", &
        u, results)
 <<SF pdf builtin: test declarations>>=
   public :: sf_pdf_builtin_1
 <<SF pdf builtin: tests>>=
   subroutine sf_pdf_builtin_1 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
     type(string_t) :: name
 
     write (u, "(A)")  "* Test output: sf_pdf_builtin_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call os_data%init ()
 
     call model%init_sm_test ()
     pdg_in = PROTON
 
     allocate (pdf_builtin_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     name = "CTEQ6L"
 
     select type (data)
     type is (pdf_builtin_data_t)
        call data%init (model, pdg_in, name, &
             os_data%pdf_builtin_datapath)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_pdf_builtin_1"
 
   end subroutine sf_pdf_builtin_1
 
 @ %def sf_pdf_builtin_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the PDF builtin
 structure function.
 <<SF pdf builtin: execute tests>>=
   call test (sf_pdf_builtin_2, "sf_pdf_builtin_2", &
        "structure function instance", &
        u, results)
 <<SF pdf builtin: test declarations>>=
   public :: sf_pdf_builtin_2
 <<SF pdf builtin: tests>>=
   subroutine sf_pdf_builtin_2 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(string_t) :: name
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_pdf_builtin_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call os_data%init ()
     call model%init_sm_test ()
     call flv%init (PROTON, model)
     pdg_in = PROTON
 
     call reset_interaction_counter ()
 
     name = "CTEQ6L"
 
     allocate (pdf_builtin_data_t :: data)
     select type (data)
     type is (pdf_builtin_data_t)
        call data%init (model, pdg_in, name, &
             os_data%pdf_builtin_datapath)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.5_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for Q = 100 GeV"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_pdf_builtin_2"
 
   end subroutine sf_pdf_builtin_2
 
 @ %def sf_pdf_builtin_2
 @
 \subsubsection{Strong Coupling}
 Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract
 type.
 <<SF pdf builtin: execute tests>>=
   call test (sf_pdf_builtin_3, "sf_pdf_builtin_3", &
        "running alpha_s", &
        u, results)
 <<SF pdf builtin: test declarations>>=
   public :: sf_pdf_builtin_3
 <<SF pdf builtin: tests>>=
   subroutine sf_pdf_builtin_3 (u)
     integer, intent(in) :: u
     type(os_data_t) :: os_data
     type(qcd_t) :: qcd
     type(string_t) :: name
 
     write (u, "(A)")  "* Test output: sf_pdf_builtin_3"
     write (u, "(A)")  "*   Purpose: initialize and evaluate alpha_s"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call os_data%init ()
 
     name = "CTEQ6L"
 
     write (u, "(A)")  "* Initialize qcd object"
     write (u, "(A)")
 
     allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha)
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_pdf_builtin_t)
        call alpha%init (name, os_data%pdf_builtin_datapath)
     end select
     call qcd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for Q = 100"
     write (u, "(A)")
 
     write (u, "(1x,A,F8.5)")  "alpha = ", qcd%alpha%get (100._default)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_pdf_builtin_3"
 
   end subroutine sf_pdf_builtin_3
 
 @ %def sf_pdf_builtin_3
 @
 \clearpage
 %------------------------------------------------------------------------
 \section{LHAPDF}
 Parton distribution functions (PDFs) are available via an interface to
 the LHAPDF standard library.
 @
 \subsection{The module}
 <<[[sf_lhapdf.f90]]>>=
 <<File header>>
 
 module sf_lhapdf
 
 <<Use kinds>>
 <<Use strings>>
   use sm_qcd
   use pdg_arrays
   use model_data
   use flavors
   use polarizations
   use sf_base
   use lhapdf !NODEP!
 
 <<Standard module head>>
 
 <<SF lhapdf: public>>
 
 <<SF lhapdf: types>>
 
 <<SF lhapdf: variables>>
 
 <<SF lhapdf: interfaces>>
 
   interface
 <<SF lhapdf: sub interfaces>>
   end interface
 
 contains
 
 <<SF lhapdf: main procedures>>
 
 end module sf_lhapdf
 @ %def sf_lhapdf
 @
 <<[[sf_lhapdf_sub.f90]]>>=
 <<File header>>
 
 submodule (sf_lhapdf) sf_lhapdf_s
 
   use format_defs, only: FMT_17, FMT_19
   use io_units
   use system_dependencies, only: LHAPDF_PDFSETS_PATH
   use system_dependencies, only: LHAPDF5_AVAILABLE
   use system_dependencies, only: LHAPDF6_AVAILABLE
   use diagnostics
   use physics_defs, only: PROTON, PHOTON, PIPLUS, GLUON
   use physics_defs, only: HADRON_REMNANT_SINGLET
   use physics_defs, only: HADRON_REMNANT_TRIPLET
   use physics_defs, only: HADRON_REMNANT_OCTET
   use lorentz
   use colors
   use quantum_numbers
   use state_matrices
   use hoppet_interface
 
   implicit none
 
 <<SF lhapdf: parameters>>
 
 contains
 
 <<SF lhapdf: procedures>>
 
 end submodule sf_lhapdf_s
 
 @ %def sf_lhapdf_s
 @
 \subsection{Codes for default PDF sets}
 The default PDF for protons set is chosen to be CTEQ6ll (LO fit with
 LO $\alpha_s$).
 <<SF lhapdf: parameters>>=
   character(*), parameter :: LHAPDF5_DEFAULT_PROTON = "cteq6ll.LHpdf"
   character(*), parameter :: LHAPDF5_DEFAULT_PION   = "ABFKWPI.LHgrid"
   character(*), parameter :: LHAPDF5_DEFAULT_PHOTON = "GSG960.LHgrid"
   character(*), parameter :: LHAPDF6_DEFAULT_PROTON = "CT10"
 @ %def LHAPDF5_DEFAULT_PROTON LHAPDF5_DEFAULT_PION
 @ %def LHAPDF5_DEFAULT_PHOTON LHAPDF6_DEFAULT_PROTON
 @
 \subsection{LHAPDF library interface}
 Here we specify explicit interfaces for all LHAPDF routines that we
 use below.
 <<SF lhapdf: interfaces>>=
   interface
      subroutine InitPDFsetM (set, file)
        integer, intent(in) :: set
        character(*), intent(in) :: file
      end subroutine InitPDFsetM
   end interface
 
 @ %def InitPDFsetM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine InitPDFM (set, mem)
        integer, intent(in) :: set, mem
      end subroutine InitPDFM
   end interface
 
 @ %def InitPDFM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine numberPDFM (set, n_members)
        integer, intent(in) :: set
        integer, intent(out) :: n_members
      end subroutine numberPDFM
   end interface
 
 @ %def numberPDFM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine evolvePDFM (set, x, q, ff)
        integer, intent(in) :: set
        double precision, intent(in) :: x, q
        double precision, dimension(-6:6), intent(out) :: ff
      end subroutine evolvePDFM
   end interface
 
 @ %def evolvePDFM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine evolvePDFphotonM (set, x, q, ff, fphot)
        integer, intent(in) :: set
        double precision, intent(in) :: x, q
        double precision, dimension(-6:6), intent(out) :: ff
        double precision, intent(out) :: fphot
      end subroutine evolvePDFphotonM
   end interface
 
 @ %def evolvePDFphotonM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine evolvePDFpM (set, x, q, s, scheme, ff)
        integer, intent(in) :: set
        double precision, intent(in) :: x, q, s
        integer, intent(in) :: scheme
        double precision, dimension(-6:6), intent(out) :: ff
      end subroutine evolvePDFpM
   end interface
 
 @ %def evolvePDFpM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine GetXminM (set, mem, xmin)
        integer, intent(in) :: set, mem
        double precision, intent(out) :: xmin
      end subroutine GetXminM
   end interface
 
 @ %def GetXminM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine GetXmaxM (set, mem, xmax)
        integer, intent(in) :: set, mem
        double precision, intent(out) :: xmax
      end subroutine GetXmaxM
   end interface
 
 @ %def GetXmaxM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine GetQ2minM (set, mem, q2min)
        integer, intent(in) :: set, mem
        double precision, intent(out) :: q2min
      end subroutine GetQ2minM
   end interface
 
 @ %def GetQ2minM
 <<SF lhapdf: interfaces>>=
   interface
      subroutine GetQ2maxM (set, mem, q2max)
        integer, intent(in) :: set, mem
        double precision, intent(out) :: q2max
      end subroutine GetQ2maxM
   end interface
 
 @ %def GetQ2maxM
 <<SF lhapdf: interfaces>>=
   interface
      function has_photon () result(flag)
         logical :: flag
      end function has_photon
   end interface
 
 @ %def has_photon
 @
 \subsection{The LHAPDF status}
 This type holds the initialization status of the LHAPDF system. Entry
 1 is for proton PDFs, entry 2 for pion PDFs, entry 3 for photon PDFs.
 
 Since it is connected to the external LHAPDF library, this is a truly
 global object.  We implement it as a a private module variable.  To
 access it from elsewhere, the caller has to create and initialize an
 object of type [[lhapdf_status_t]], which acts as a proxy.
 <<SF lhapdf: types>>=
   type :: lhapdf_global_status_t
      private
      logical, dimension(3) :: initialized = .false.
   end type lhapdf_global_status_t
 
 @ %def lhapdf_global_status_t
 <<SF lhapdf: variables>>=
   type(lhapdf_global_status_t), save :: lhapdf_global_status
 @ %def lhapdf_global_status
 <<SF lhapdf: procedures>>=
   function lhapdf_global_status_is_initialized (set) result (flag)
     logical :: flag
     integer, intent(in), optional :: set
     if (present (set)) then
        select case (set)
        case (1:3);    flag = lhapdf_global_status%initialized(set)
        case default;  flag = .false.
        end select
     else
        flag = any (lhapdf_global_status%initialized)
     end if
   end function lhapdf_global_status_is_initialized
 
 @ %def lhapdf_global_status_is_initialized
 <<SF lhapdf: procedures>>=
   subroutine lhapdf_global_status_set_initialized (set)
     integer, intent(in) :: set
     lhapdf_global_status%initialized(set) = .true.
   end subroutine lhapdf_global_status_set_initialized
 
 @ %def lhapdf_global_status_set_initialized
 @ This is the only public procedure, it tells the system to forget
 about previous initialization, allowing for changing the chosen PDF
 set.  Note that such a feature works only if the global program flow
 is serial, so no two distinct sets are accessed simultaneously.  But
 this applies to LHAPDF anyway.
 <<SF lhapdf: public>>=
   public :: lhapdf_global_reset
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_global_reset ()
     end subroutine lhapdf_global_reset
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_global_reset ()
     lhapdf_global_status%initialized = .false.
   end subroutine lhapdf_global_reset
 
 @ %def lhapdf_global_status_reset
 @
 \subsection{LHAPDF initialization}
 Before using LHAPDF, we have to initialize it with a particular data
 set and member.  This applies not just if we use structure functions,
 but also if we just use an $\alpha_s$ formula.  The integer [[set]]
 should be $1$ for proton, $2$ for pion, and $3$ for photon, but this
 is just convention.
 
 It appears as if LHAPDF does not allow for multiple data sets being
 used concurrently (?), so multi-threaded usage with different sets
 (e.g., a scan) is excluded.  The current setup with a global flag that
 indicates initialization is fine as long as Whizard itself is run in
 serial mode at the Sindarin level.  If we introduce multithreading in
 any form from Sindarin, we have to rethink the implementation of the
 LHAPDF interface.  (The same considerations apply to builtin PDFs.)
 
 If the particular set has already been initialized, do nothing.  This
 implies that whenever we want to change the setup for a particular
 set, we have to reset the LHAPDF status.
 [[lhapdf_initialize]] has an obvious name clash with [[lhapdf_init]],
 the reason it works for [[pdf_builtin]] is that there things are
 outsourced to a separate module (inc. [[lhapdf_status]] etc.).
 <<SF lhapdf: public>>=
   public :: lhapdf_initialize
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_initialize &
          (set, prefix, file, member, pdf, b_match)
       integer, intent(in) :: set
       type(string_t), intent(inout) :: prefix
       type(string_t), intent(inout) :: file
       type(lhapdf_pdf_t), intent(inout), optional :: pdf
       integer, intent(inout) :: member
       logical, intent(in), optional :: b_match
     end subroutine lhapdf_initialize
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_initialize &
        (set, prefix, file, member, pdf, b_match)
     integer, intent(in) :: set
     type(string_t), intent(inout) :: prefix
     type(string_t), intent(inout) :: file
     type(lhapdf_pdf_t), intent(inout), optional :: pdf
     integer, intent(inout) :: member
     logical, intent(in), optional :: b_match
     if (prefix == "")  prefix = LHAPDF_PDFSETS_PATH
     if (LHAPDF5_AVAILABLE) then
        if (lhapdf_global_status_is_initialized (set))  return
        if (file == "") then
           select case (set)
           case (1);  file = LHAPDF5_DEFAULT_PROTON
           case (2);  file = LHAPDF5_DEFAULT_PION
           case (3);  file = LHAPDF5_DEFAULT_PHOTON
           end select
        end if
        if (data_file_exists (prefix // "/" // file)) then
           call InitPDFsetM (set, char (prefix // "/" // file))
        else
           call msg_fatal ("LHAPDF: Data file '" &
                // char (file) // "' not found in '" // char (prefix) // "'.")
           return
        end if
        if (.not. dataset_member_exists (set, member)) then
           call msg_error (" LHAPDF: Chosen member does not exist for set '" &
                // char (file) // "', using default.")
           member = 0
        end if
        call InitPDFM (set, member)
     else if (LHAPDF6_AVAILABLE) then
     ! TODO: (bcn 2015-07-07) we should have a closer look why this global
     !                        check must not be executed
     !   if (lhapdf_global_status_is_initialized (set) .and. &
     !        pdf%is_associated ()) return
        if (file == "") then
           select case (set)
           case (1);  file = LHAPDF6_DEFAULT_PROTON
           case (2);
              call msg_fatal ("LHAPDF6: no pion PDFs supported")
           case (3);
              call msg_fatal ("LHAPDF6: no photon PDFs supported")
           end select
        end if
        if (data_file_exists (prefix // "/" // file // "/" // file // ".info")) then
           call pdf%init (char (file), member)
        else
           call msg_fatal ("LHAPDF: Data file '" &
                // char (file) // "' not found in '" // char (prefix) // "'.")
           return
        end if
     end if
     if (present (b_match)) then
        if (b_match) then
           if (LHAPDF5_AVAILABLE) then
              call hoppet_init (.false.)
           else if (LHAPDF6_AVAILABLE) then
              call hoppet_init (.false., pdf)
           end if
        end if
     end if
     call lhapdf_global_status_set_initialized (set)
   contains
     function data_file_exists (fq_name) result (exist)
       type(string_t), intent(in) :: fq_name
       logical :: exist
       inquire (file = char(fq_name), exist = exist)
     end function data_file_exists
     function dataset_member_exists (set, member) result (exist)
       integer, intent(in) :: set, member
       logical :: exist
       integer :: n_members
       call numberPDFM (set, n_members)
       exist = member >= 0 .and. member <= n_members
     end function dataset_member_exists
   end subroutine lhapdf_initialize
 
 @ %def lhapdf_initialize
 @
 \subsection{Kinematics}
 Set kinematics.  If [[map]] is unset, the $r$ and $x$ values
 coincide, and the Jacobian $f(r)$ is trivial.
 
 If [[map]] is set, we are asked to provide an efficient mapping.
 For the test case, we set $x=r^2$ and consequently $f(r)=2r$.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: complete_kinematics => lhapdf_complete_kinematics
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_complete_kinematics &
          (sf_int, x, xb, f, r, rb, map)
       class(lhapdf_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(in) :: r
       real(default), dimension(:), intent(in) :: rb
       logical, intent(in) :: map
     end subroutine lhapdf_complete_kinematics
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_complete_kinematics &
        (sf_int, x, xb, f, r, rb, map)
     class(lhapdf_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(in) :: r
     real(default), dimension(:), intent(in) :: rb
     logical, intent(in) :: map
     if (map) then
        call msg_fatal ("LHAPDF: map flag not supported")
     else
        x(1) = r(1)
        xb(1)= rb(1)
        f = 1
     end if
     call sf_int%split_momentum (x, xb)
     select case (sf_int%status)
     case (SF_DONE_KINEMATICS)
        sf_int%x = x(1)
     case (SF_FAILED_KINEMATICS)
        sf_int%x = 0
        f = 0
     end select
   end subroutine lhapdf_complete_kinematics
 
 @ %def lhapdf_complete_kinematics
 @ Overriding the default method: we compute the [[x]] value from the
 momentum configuration.  In this specific case, we also set the
 internally stored $x$ value, so it can be used in the
 following routine.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: recover_x => lhapdf_recover_x
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_recover_x (sf_int, x, xb, x_free)
       class(lhapdf_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(out) :: x
       real(default), dimension(:), intent(out) :: xb
       real(default), intent(inout), optional :: x_free
     end subroutine lhapdf_recover_x
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_recover_x (sf_int, x, xb, x_free)
     class(lhapdf_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(out) :: x
     real(default), dimension(:), intent(out) :: xb
     real(default), intent(inout), optional :: x_free
     call sf_int%base_recover_x (x, xb, x_free)
     sf_int%x  = x(1)
   end subroutine lhapdf_recover_x
 
 @ %def lhapdf_recover_x
 @ Compute inverse kinematics.  Here, we start with the $x$ array and
 compute the ``input'' $r$ values and the Jacobian $f$.  After this, we
 can set momenta by the same formula as for normal kinematics.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: inverse_kinematics => lhapdf_inverse_kinematics
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_inverse_kinematics &
          (sf_int, x, xb, f, r, rb, map, set_momenta)
       class(lhapdf_t), intent(inout) :: sf_int
       real(default), dimension(:), intent(in) :: x
       real(default), dimension(:), intent(in) :: xb
       real(default), intent(out) :: f
       real(default), dimension(:), intent(out) :: r
       real(default), dimension(:), intent(out) :: rb
       logical, intent(in) :: map
       logical, intent(in), optional :: set_momenta
     end subroutine lhapdf_inverse_kinematics
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_inverse_kinematics &
        (sf_int, x, xb, f, r, rb, map, set_momenta)
     class(lhapdf_t), intent(inout) :: sf_int
     real(default), dimension(:), intent(in) :: x
     real(default), dimension(:), intent(in) :: xb
     real(default), intent(out) :: f
     real(default), dimension(:), intent(out) :: r
     real(default), dimension(:), intent(out) :: rb
     logical, intent(in) :: map
     logical, intent(in), optional :: set_momenta
     logical :: set_mom
     set_mom = .false.;  if (present (set_momenta))  set_mom = set_momenta
     if (map) then
        call msg_fatal ("LHAPDF: map flag not supported")
     else
        r(1) = x(1)
        rb(1)= xb(1)
        f = 1
     end if
     if (set_mom) then
        call sf_int%split_momentum (x, xb)
        select case (sf_int%status)
        case (SF_FAILED_KINEMATICS);  f = 0
        end select
     end if
   end subroutine lhapdf_inverse_kinematics
 
 @ %def lhapdf_inverse_kinematics
 @
 \subsection{The LHAPDF data block}
 The data block holds the incoming flavor (which has to be proton,
 pion, or photon), the corresponding pointer to the global access data
 (1, 2, or 3), the flag [[invert]] which is set for an antiproton, the
 bounds as returned by LHAPDF for the specified set, and a mask that
 determines which partons will be actually in use.
 <<SF lhapdf: public>>=
   public :: lhapdf_data_t
 <<SF lhapdf: types>>=
   type, extends (sf_data_t) :: lhapdf_data_t
      private
      type(string_t) :: prefix
      type(string_t) :: file
      type(lhapdf_pdf_t) :: pdf
      integer :: member = 0
      class(model_data_t), pointer :: model => null ()
      type(flavor_t) :: flv_in
      integer :: set = 0
      logical :: invert = .false.
      logical :: photon = .false.
      logical :: has_photon = .false.
      integer :: photon_scheme = 0
      real(default) :: xmin = 0, xmax = 0
      real(default) :: qmin = 0, qmax = 0
      logical, dimension(-6:6) :: mask = .true.
      logical :: mask_photon = .true.
      logical :: hoppet_b_matching = .false.
    contains
      <<SF lhapdf: lhapdf data: TBP>>
   end type lhapdf_data_t
 
 @ %def lhapdf_data_t
 @ Generate PDF data.  This is provided as a function, but it has the
 side-effect of initializing the requested PDF set.  A finalizer is not
 needed.
 
 The library uses double precision, so since the default precision may be
 extended or quadruple, we use auxiliary variables for type casting.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: init => lhapdf_data_init
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_data_init &
          (data, model, pdg_in, prefix, file, member, photon_scheme, &
               hoppet_b_matching)
       class(lhapdf_data_t), intent(out) :: data
       class(model_data_t), intent(in), target :: model
       type(pdg_array_t), intent(in) :: pdg_in
       type(string_t), intent(in), optional :: prefix, file
       integer, intent(in), optional :: member
       integer, intent(in), optional :: photon_scheme
       logical, intent(in), optional :: hoppet_b_matching
     end subroutine lhapdf_data_init
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_data_init &
        (data, model, pdg_in, prefix, file, member, photon_scheme, &
             hoppet_b_matching)
     class(lhapdf_data_t), intent(out) :: data
     class(model_data_t), intent(in), target :: model
     type(pdg_array_t), intent(in) :: pdg_in
     type(string_t), intent(in), optional :: prefix, file
     integer, intent(in), optional :: member
     integer, intent(in), optional :: photon_scheme
     logical, intent(in), optional :: hoppet_b_matching
     double precision :: xmin, xmax, q2min, q2max
     external :: InitPDFsetM, InitPDFM, numberPDFM
     external :: GetXminM, GetXmaxM, GetQ2minM, GetQ2maxM
     if (.not. LHAPDF5_AVAILABLE .and. .not. LHAPDF6_AVAILABLE) then
        call msg_fatal ("LHAPDF requested but library is not linked")
        return
     end if
     data%model => model
     if (pdg_in%get_length () /= 1) &
          call msg_fatal ("PDF: incoming particle must be unique")
     call data%flv_in%init (pdg_in%get (1), model)
     select case (pdg_in%get (1))
     case (PROTON)
        data%set = 1
     case (-PROTON)
        data%set = 1
        data%invert = .true.
     case (PIPLUS)
        data%set = 2
     case (-PIPLUS)
        data%set = 2
        data%invert = .true.
     case (PHOTON)
        data%set = 3
        data%photon = .true.
        if (present (photon_scheme))  data%photon_scheme = photon_scheme
     case default
        call msg_fatal (" LHAPDF: " &
             // "incoming particle must be (anti)proton, pion, or photon.")
        return
     end select
     if (present (prefix)) then
        data%prefix = prefix
     else
        data%prefix = ""
     end if
     if (present (file)) then
        data%file = file
     else
        data%file = ""
     end if
     if (present (hoppet_b_matching))  data%hoppet_b_matching = hoppet_b_matching
     if (LHAPDF5_AVAILABLE) then
        call lhapdf_initialize (data%set, &
             data%prefix, data%file, data%member, &
             b_match = data%hoppet_b_matching)
        call GetXminM (data%set, data%member, xmin)
        call GetXmaxM (data%set, data%member, xmax)
        call GetQ2minM (data%set, data%member, q2min)
        call GetQ2maxM (data%set, data%member, q2max)
        data%xmin = xmin
        data%xmax = xmax
        data%qmin = sqrt (q2min)
        data%qmax = sqrt (q2max)
        data%has_photon = has_photon ()
     else if (LHAPDF6_AVAILABLE) then
        call lhapdf_initialize (data%set, &
             data%prefix, data%file, data%member, &
             data%pdf, data%hoppet_b_matching)
        data%xmin = data%pdf%getxmin ()
        data%xmax = data%pdf%getxmax ()
        data%qmin = sqrt(data%pdf%getq2min ())
        data%qmax = sqrt(data%pdf%getq2max ())
        data%has_photon = data%pdf%has_photon ()
     end if
   end subroutine lhapdf_data_init
 
 @ %def lhapdf_data_init
 @ Enable/disable partons explicitly.  If a mask entry is true,
 applying the PDF will generate the corresponding flavor on output.
 <<LHAPDF: lhapdf data: TBP>>=
   procedure :: set_mask => lhapdf_data_set_mask
 <<LHAPDF: procedures>>=
   subroutine lhapdf_data_set_mask (data, mask)
     class(lhapdf_data_t), intent(inout) :: data
     logical, dimension(-6:6), intent(in) :: mask
     data%mask = mask
   end subroutine lhapdf_data_set_mask
 
 @ %def lhapdf_data_set_mask
 @ Return the public part of the data set.
 <<LHAPDF: public>>=
   public :: lhapdf_data_get_public_info
 <<LHAPDF: procedures>>=
   subroutine lhapdf_data_get_public_info &
        (data, lhapdf_dir, lhapdf_file, lhapdf_member)
     type(lhapdf_data_t), intent(in) :: data
     type(string_t), intent(out) :: lhapdf_dir, lhapdf_file
     integer, intent(out) :: lhapdf_member
     lhapdf_dir = data%prefix
     lhapdf_file = data%file
     lhapdf_member = data%member
   end subroutine lhapdf_data_get_public_info
 
 @ %def lhapdf_data_get_public_info
 @ Return the number of the member of the data set.
 <<LHAPDF: public>>=
   public :: lhapdf_data_get_set
 <<LHAPDF: procedures>>=
   function lhapdf_data_get_set(data) result(set)
     type(lhapdf_data_t), intent(in) :: data
     integer :: set
     set = data%set
   end function lhapdf_data_get_set
 
 @ %def lhapdf_data_get_set
 @ Output
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: write => lhapdf_data_write
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_data_write (data, unit, verbose)
       class(lhapdf_data_t), intent(in) :: data
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine lhapdf_data_write
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_data_write (data, unit, verbose)
     class(lhapdf_data_t), intent(in) :: data
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: verbose
     logical :: verb
     integer :: u
     if (present (verbose)) then
        verb = verbose
     else
        verb = .false.
     end if
     u = given_output_unit (unit);  if (u < 0)  return
     write (u, "(1x,A)") "LHAPDF data:"
     if (data%set /= 0) then
        write (u, "(3x,A)", advance="no") "flavor       =  "
        call data%flv_in%write (u);  write (u, *)
        if (verb) then
           write (u, "(3x,A,A)")       "  prefix       =  ", char (data%prefix)
        else
           write (u, "(3x,A,A)")       "  prefix       = ", &
                " <empty (non-verbose version)>"
        end if
        write (u, "(3x,A,A)")       "  file         =  ", char (data%file)
        write (u, "(3x,A,I3)")      "  member       = ", data%member
        write (u, "(3x,A," // FMT_19 // ")") "  x(min)       = ", data%xmin
        write (u, "(3x,A," // FMT_19 // ")") "  x(max)       = ", data%xmax
        write (u, "(3x,A," // FMT_19 // ")") "  Q(min)       = ", data%qmin
        write (u, "(3x,A," // FMT_19 // ")") "  Q(max)       = ", data%qmax
        write (u, "(3x,A,L1)")      "  invert       =  ", data%invert
        if (data%photon)  write (u, "(3x,A,I3)") &
             "  IP2 (scheme) = ", data%photon_scheme
           write (u, "(3x,A,6(1x,L1),1x,A,1x,L1,1x,A,6(1x,L1))") &
                "  mask         = ", &
                data%mask(-6:-1), "*", data%mask(0), "*", data%mask(1:6)
           write (u, "(3x,A,L1)")   "  photon mask  =  ", data%mask_photon
        if (data%set == 1)  write (u, "(3x,A,L1)") &
             "  hoppet_b     =  ", data%hoppet_b_matching
     else
        write (u, "(3x,A)") "[undefined]"
     end if
   end subroutine lhapdf_data_write
 @ %def lhapdf_data_write
 @ The number of parameters is one.  We do not generate transverse momentum.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: get_n_par => lhapdf_data_get_n_par
 <<SF lhapdf: sub interfaces>>=
     module function lhapdf_data_get_n_par (data) result (n)
       class(lhapdf_data_t), intent(in) :: data
       integer :: n
     end function lhapdf_data_get_n_par
 <<SF lhapdf: procedures>>=
   module function lhapdf_data_get_n_par (data) result (n)
     class(lhapdf_data_t), intent(in) :: data
     integer :: n
     n = 1
   end function lhapdf_data_get_n_par
 
 @ %def lhapdf_data_get_n_par
 @ Return the outgoing particle PDG codes.  This is based on the mask.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: get_pdg_out => lhapdf_data_get_pdg_out
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_data_get_pdg_out (data, pdg_out)
       class(lhapdf_data_t), intent(in) :: data
       type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     end subroutine lhapdf_data_get_pdg_out
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_data_get_pdg_out (data, pdg_out)
     class(lhapdf_data_t), intent(in) :: data
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     integer :: n, np, i
     n = count (data%mask)
     np = 0;  if (data%has_photon .and. data%mask_photon)  np = 1
     allocate (pdg1 (n + np))
     pdg1(1:n) = pack ([(i, i = -6, 6)], data%mask)
     if (np == 1)  pdg1(n+np) = PHOTON
     pdg_out(1) = pdg1
   end subroutine lhapdf_data_get_pdg_out
 
 @ %def lhapdf_data_get_pdg_out
 @ Allocate the interaction record. Due to a gfortran 7/8/9 bug this
 has to remain in the main module.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: allocate_sf_int => lhapdf_data_allocate_sf_int
 <<SF lhapdf: main procedures>>=
   subroutine lhapdf_data_allocate_sf_int (data, sf_int)
     class(lhapdf_data_t), intent(in) :: data
     class(sf_int_t), intent(inout), allocatable :: sf_int
     allocate (lhapdf_t :: sf_int)
   end subroutine lhapdf_data_allocate_sf_int
 
 @ %def lhapdf_data_allocate_sf_int
 @ Return the numerical PDF set index.
 <<SF lhapdf: lhapdf data: TBP>>=
   procedure :: get_pdf_set => lhapdf_data_get_pdf_set
 <<SF lhapdf: sub interfaces>>=
     elemental module function lhapdf_data_get_pdf_set (data) result (pdf_set)
       class(lhapdf_data_t), intent(in) :: data
       integer :: pdf_set
     end function lhapdf_data_get_pdf_set
 <<SF lhapdf: procedures>>=
   elemental module function lhapdf_data_get_pdf_set (data) result (pdf_set)
     class(lhapdf_data_t), intent(in) :: data
     integer :: pdf_set
     pdf_set = data%set
   end function lhapdf_data_get_pdf_set
 
 @ %def lhapdf_data_get_pdf_set
 @
 \subsection{The LHAPDF object}
 The [[lhapdf_t]] data type is a $1\to 2$ interaction which describes
 the splitting of an (anti)proton into a parton and a beam remnant.  We
 stay in the strict forward-splitting limit, but allow some invariant
 mass for the beam remnant such that the outgoing parton is exactly
 massless.  For a real event, we would replace this by a parton
 cascade, where the outgoing partons have virtuality as dictated by
 parton-shower kinematics, and transverse momentum is generated.
 
 This is the LHAPDF object which holds input data together with the
 interaction.  We also store the $x$ momentum fraction and the scale,
 since kinematics and function value are requested at different times.
 
 The PDF application is a $1\to 2$ splitting process, where the
 particles are ordered as (hadron, remnant, parton).
 
 Polarization is ignored completely.  The beam particle is colorless,
 while partons and beam remnant carry color.  The remnant gets a
 special flavor code.
 <<SF lhapdf: public>>=
   public :: lhapdf_t
 <<SF lhapdf: types>>=
   type, extends (sf_int_t) :: lhapdf_t
      type(lhapdf_data_t), pointer :: data => null ()
      real(default) :: x = 0
      real(default) :: q = 0
      real(default) :: s = 0
    contains
    <<SF lhapdf: lhapdf: TBP>>
   end type lhapdf_t
 
 @ %def lhapdf_t
 @ Type string: display the chosen PDF set.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: type_string => lhapdf_type_string
 <<SF lhapdf: sub interfaces>>=
     module function lhapdf_type_string (object) result (string)
       class(lhapdf_t), intent(in) :: object
       type(string_t) :: string
     end function lhapdf_type_string
 <<SF lhapdf: procedures>>=
   module function lhapdf_type_string (object) result (string)
     class(lhapdf_t), intent(in) :: object
     type(string_t) :: string
     if (associated (object%data)) then
        string = "LHAPDF: " // object%data%file
     else
        string = "LHAPDF: [undefined]"
     end if
   end function lhapdf_type_string
 
 @ %def lhapdf_type_string
 @ Output.  Call the interaction routine after displaying the configuration.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: write => lhapdf_write
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_write (object, unit, testflag)
       class(lhapdf_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: testflag
     end subroutine lhapdf_write
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_write (object, unit, testflag)
     class(lhapdf_t), intent(in) :: object
     integer, intent(in), optional :: unit
     logical, intent(in), optional :: testflag
     integer :: u
     u = given_output_unit (unit)
     if (associated (object%data)) then
        call object%data%write (u)
        if (object%status >= SF_DONE_KINEMATICS) then
           write (u, "(1x,A)")  "SF parameters:"
           write (u, "(3x,A," // FMT_17 // ")")  "x =", object%x
           if (object%status >= SF_FAILED_EVALUATION) then
              write (u, "(3x,A," // FMT_17 // ")")  "Q =", object%q
           end if
        end if
        call object%base_write (u, testflag)
     else
        write (u, "(1x,A)")  "LHAPDF data: [undefined]"
     end if
   end subroutine lhapdf_write
 
 @ %def lhapdf_write
 @ Initialize.  We know that [[data]] will be of concrete type
 [[sf_lhapdf_data_t]], but we have to cast this explicitly.
 
 For this implementation, we set the incoming and outgoing masses equal
 to the physical particle mass, but keep the radiated mass zero.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: init => lhapdf_init
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_init (sf_int, data)
       class(lhapdf_t), intent(out) :: sf_int
       class(sf_data_t), intent(in), target :: data
     end subroutine lhapdf_init
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_init (sf_int, data)
     class(lhapdf_t), intent(out) :: sf_int
     class(sf_data_t), intent(in), target :: data
     type(quantum_numbers_mask_t), dimension(3) :: mask
     type(flavor_t) :: flv, flv_remnant
     type(color_t) :: col0
     type(quantum_numbers_t), dimension(3) :: qn
     integer :: i
     select type (data)
     type is (lhapdf_data_t)
        mask = quantum_numbers_mask (.false., .false., .true.)
        call col0%init ()
        call sf_int%base_init (mask, [0._default], [0._default], [0._default])
        sf_int%data => data
        do i = -6, 6
           if (data%mask(i)) then
              call qn(1)%init (data%flv_in, col = col0)
              if (i == 0) then
                 call flv%init (GLUON, data%model)
                 call flv_remnant%init (HADRON_REMNANT_OCTET, data%model)
              else
                 call flv%init (i, data%model)
                 call flv_remnant%init &
                      (sign (HADRON_REMNANT_TRIPLET, -i), data%model)
              end if
              call qn(2)%init ( &
                   flv = flv_remnant, col = color_from_flavor (flv_remnant, 1))
              call qn(2)%tag_radiated ()
              call qn(3)%init ( &
                   flv = flv, col = color_from_flavor (flv, 1, reverse=.true.))
              call sf_int%add_state (qn)
           end if
        end do
        if (data%has_photon .and. data%mask_photon) then
           call flv%init (PHOTON, data%model)
           call flv_remnant%init (HADRON_REMNANT_SINGLET, data%model)
           call qn(2)%init (flv = flv_remnant, &
                col = color_from_flavor (flv_remnant, 1))
           call qn(2)%tag_radiated ()
           call qn(3)%init (flv = flv, &
                col = color_from_flavor (flv, 1, reverse=.true.))
           call sf_int%add_state (qn)
        end if
        call sf_int%freeze ()
        call sf_int%set_incoming ([1])
        call sf_int%set_radiated ([2])
        call sf_int%set_outgoing ([3])
        sf_int%status = SF_INITIAL
     end select
   end subroutine lhapdf_init
 
 @ %def lhapdf_init
 @
 \subsection{Structure function}
 We have to cast the LHAPDF arguments to/from double precision (possibly
 from/to extended/quadruple precision), if necessary.
 Some structure functions can yield negative results (sea quarks close
 to $x=1$). In an NLO computation, this is perfectly fine and we keep negative values.
 Unlike total cross sections, PDFs do not have to be positive definite. For LO however,
 negative PDFs would cause negative event weights so we set these values to zero instead.
 <<SF lhapdf: lhapdf: TBP>>=
   procedure :: apply => lhapdf_apply
 <<SF lhapdf: sub interfaces>>=
     module subroutine lhapdf_apply &
          (sf_int, scale, negative_sf, rescale, i_sub)
       class(lhapdf_t), intent(inout) :: sf_int
       real(default), intent(in) :: scale
       logical, intent(in), optional :: negative_sf
       class(sf_rescale_t), intent(in), optional :: rescale
       integer, intent(in), optional :: i_sub
     end subroutine lhapdf_apply
 <<SF lhapdf: procedures>>=
   module subroutine lhapdf_apply &
        (sf_int, scale, negative_sf, rescale, i_sub)
     class(lhapdf_t), intent(inout) :: sf_int
     real(default), intent(in) :: scale
     logical, intent(in), optional :: negative_sf
     class(sf_rescale_t), intent(in), optional :: rescale
     integer, intent(in), optional :: i_sub
     real(default) :: x, s
     double precision :: xx, qq, ss
     double precision, dimension(-6:6) :: ff
     double precision :: fphot
     complex(default), dimension(:), allocatable :: fc
     integer :: i, i_sub_opt, j_sub
     logical :: negative_sf_opt
     external :: evolvePDFM, evolvePDFpM
     i_sub_opt = 0; if (present (i_sub)) i_sub_opt = i_sub
     negative_sf_opt = .false.; if (present(negative_sf)) negative_sf_opt = negative_sf
     associate (data => sf_int%data)
       sf_int%q = scale
       x = sf_int%x
       if (present (rescale))  call rescale%apply (x)
       s = sf_int%s
       xx = x
       if (debug2_active (D_BEAMS)) then
          call msg_debug2 (D_BEAMS, "lhapdf_apply")
          call msg_debug2 (D_BEAMS, "rescale: ", present(rescale))
          call msg_debug2 (D_BEAMS, "i_sub: ", i_sub_opt)
          call msg_debug2 (D_BEAMS, "x: ", x)
       end if
       qq = min (data%qmax, scale)
       qq = max (data%qmin, qq)
       if (.not. data%photon) then
          if (data%invert) then
             if (data%has_photon) then
                if (LHAPDF5_AVAILABLE) then
                   call evolvePDFphotonM &
                        (data%set, xx, qq, ff(6:-6:-1), fphot)
                else if (LHAPDF6_AVAILABLE) then
                   call data%pdf%evolve_pdfphotonm &
                        (xx, qq, ff(6:-6:-1), fphot)
                end if
             else
                if (data%hoppet_b_matching) then
                   call hoppet_eval (xx, qq, ff(6:-6:-1))
                else
                   if (LHAPDF5_AVAILABLE) then
                      call evolvePDFM (data%set, xx, qq, ff(6:-6:-1))
                   else if (LHAPDF6_AVAILABLE) then
                      call data%pdf%evolve_pdfm (xx, qq, ff(6:-6:-1))
                   end if
                end if
             end if
          else
             if (data%has_photon) then
                if (LHAPDF5_AVAILABLE) then
                   call evolvePDFphotonM (data%set, xx, qq, ff, fphot)
                else if (LHAPDF6_AVAILABLE) then
                   call data%pdf%evolve_pdfphotonm (xx, qq, ff, fphot)
                end if
             else
                if (data%hoppet_b_matching) then
                   call hoppet_eval (xx, qq, ff)
                else
                   if (LHAPDF5_AVAILABLE) then
                      call evolvePDFM (data%set, xx, qq, ff)
                   else if (LHAPDF6_AVAILABLE) then
                      call data%pdf%evolve_pdfm (xx, qq, ff)
                   end if
                end if
             end if
          end if
       else
          ss = s
          if (LHAPDF5_AVAILABLE) then
             call evolvePDFpM (data%set, xx, qq, &
                  ss, data%photon_scheme, ff)
          else if (LHAPDF6_AVAILABLE) then
             call data%pdf%evolve_pdfpm (xx, qq, ss, &
                  data%photon_scheme, ff)
          end if
       end if
       if (data%has_photon) then
          allocate (fc (count ([data%mask, data%mask_photon])))
          if (negative_sf_opt) then
             fc = pack ([ff, fphot] / x, [data%mask, data%mask_photon])
          else
             fc = max( pack ([ff, fphot] / x, [data%mask, data%mask_photon]), 0._default)
          end if
       else
          allocate (fc (count (data%mask)))
          if (negative_sf_opt) then
             fc = pack (ff / x, data%mask)
          else
             fc = max( pack (ff / x, data%mask), 0._default)
          end if
       end if
     end associate
     if (debug_active (D_BEAMS)) print *, 'Set pdfs: ', real (fc)
     call sf_int%set_matrix_element (fc, [(i_sub_opt * size(fc) + i, i = 1, size(fc))])
     sf_int%status = SF_EVALUATED
   end subroutine lhapdf_apply
 
 @ %def apply_lhapdf
 @
 \subsection{Strong Coupling}
 Since the PDF codes provide a function for computing the running
 $\alpha_s$ value, we make this available as an implementation of the
 abstract [[alpha_qcd_t]] type, which is used for matrix element evaluation.
 <<SF lhapdf: public>>=
   public :: alpha_qcd_lhapdf_t
 <<SF lhapdf: types>>=
   type, extends (alpha_qcd_t) :: alpha_qcd_lhapdf_t
      type(string_t) :: pdfset_dir
      type(string_t) :: pdfset_file
      integer :: pdfset_member = -1
      type(lhapdf_pdf_t) :: pdf
    contains
    <<SF lhapdf: alpha qcd: TBP>>
   end type alpha_qcd_lhapdf_t
 
 @ %def alpha_qcd_lhapdf_t
 @ Output. As in earlier versions we leave the LHAPDF path out.
 <<SF lhapdf: alpha qcd: TBP>>=
   procedure :: write => alpha_qcd_lhapdf_write
 <<SF lhapdf: sub interfaces>>=
     module subroutine alpha_qcd_lhapdf_write (object, unit)
       class(alpha_qcd_lhapdf_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine alpha_qcd_lhapdf_write
 <<SF lhapdf: procedures>>=
   module subroutine alpha_qcd_lhapdf_write (object, unit)
     class(alpha_qcd_lhapdf_t), intent(in) :: object
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit)
     write (u, "(3x,A)")  "QCD parameters (lhapdf):"
     write (u, "(5x,A,A)")  "PDF set    = ", char (object%pdfset_file)
     write (u, "(5x,A,I0)") "PDF member = ", object%pdfset_member
   end subroutine alpha_qcd_lhapdf_write
 
 @ %def alpha_qcd_lhapdf_write
 @ Calculation: the numeric member ID selects the correct PDF set, which must
 be properly initialized.
 <<SF lhapdf: interfaces>>=
   interface
      double precision function alphasPDF (Q)
        double precision, intent(in) :: Q
      end function alphasPDF
   end interface
 
 @ %def alphasPDF
 @
 <<SF lhapdf: alpha qcd: TBP>>=
   procedure :: get => alpha_qcd_lhapdf_get
 <<SF lhapdf: sub interfaces>>=
     module function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha)
       class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
       real(default), intent(in) :: scale
       real(default) :: alpha
     end function alpha_qcd_lhapdf_get
 <<SF lhapdf: procedures>>=
   module function alpha_qcd_lhapdf_get (alpha_qcd, scale) result (alpha)
     class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
     real(default), intent(in) :: scale
     real(default) :: alpha
     if (LHAPDF5_AVAILABLE) then
        alpha = alphasPDF (dble (scale))
     else if (LHAPDF6_AVAILABLE) then
        alpha = alpha_qcd%pdf%alphas_pdf (dble (scale))
     end if
   end function alpha_qcd_lhapdf_get
 
 @ %def alpha_qcd_lhapdf_get
 @
 Initialization.  We need to access the (quasi-global) initialization status.
 <<SF lhapdf: alpha qcd: TBP>>=
   procedure :: init => alpha_qcd_lhapdf_init
 <<SF lhapdf: sub interfaces>>=
     module subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path)
       class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd
       type(string_t), intent(inout) :: file
       integer, intent(inout) :: member
       type(string_t), intent(inout) :: path
     end subroutine alpha_qcd_lhapdf_init
 <<SF lhapdf: procedures>>=
   module subroutine alpha_qcd_lhapdf_init (alpha_qcd, file, member, path)
     class(alpha_qcd_lhapdf_t), intent(out) :: alpha_qcd
     type(string_t), intent(inout) :: file
     integer, intent(inout) :: member
     type(string_t), intent(inout) :: path
     alpha_qcd%pdfset_file = file
     alpha_qcd%pdfset_member = member
     if (alpha_qcd%pdfset_member < 0) &
          call msg_fatal ("QCD parameter initialization: PDF set " &
          // char (file) // " is unknown")
     if (LHAPDF5_AVAILABLE) then
        call lhapdf_initialize (1, path, file, member)
     else if (LHAPDF6_AVAILABLE) then
        call lhapdf_initialize &
             (1, path, file, member, alpha_qcd%pdf)
     end if
   end subroutine alpha_qcd_lhapdf_init
 
 @ %def alpha_qcd_lhapdf_init
 @ Retrieves the quark masses from the PDF.
 <<SF lhapdf: alpha qcd: TBP>>=
   procedure :: get_qmass => alpha_qcd_lhapdf_get_qmass
 <<SF lhapdf: sub interfaces>>=
     module function alpha_qcd_lhapdf_get_qmass (alpha_qcd, i_q) result (mq)
       real(default) :: mq
       class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
       integer, intent(in) :: i_q
     end function alpha_qcd_lhapdf_get_qmass
 <<SF lhapdf: procedures>>=
   module function alpha_qcd_lhapdf_get_qmass (alpha_qcd, i_q) result (mq)
     real(default) :: mq
     class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
     integer, intent(in) :: i_q
     mq = alpha_qcd%pdf%get_qmass (i_q)
   end function alpha_qcd_lhapdf_get_qmass
 
 @ %def alpha_qcd_lhapdf_get_qmass
 @ Retrieves the order from the PDF.
 <<SF lhapdf: alpha qcd: TBP>>=
   procedure :: get_order => alpha_qcd_lhapdf_get_order
 <<SF lhapdf: sub interfaces>>=
     module function alpha_qcd_lhapdf_get_order (alpha_qcd) result (order)
       integer :: order
       class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
     end function alpha_qcd_lhapdf_get_order
 <<SF lhapdf: procedures>>=
   module function alpha_qcd_lhapdf_get_order (alpha_qcd) result (order)
     integer :: order
     class(alpha_qcd_lhapdf_t), intent(in) :: alpha_qcd
     order = alpha_qcd%pdf%get_order ()
   end function alpha_qcd_lhapdf_get_order
 
 @ %def alpha_qcd_lhapdf_get_order
 @
 \subsection{Unit tests}
 Test module, followed by the corresponding implementation module.
 <<[[sf_lhapdf_ut.f90]]>>=
 <<File header>>
 
 module sf_lhapdf_ut
   use unit_tests
   use system_dependencies, only: LHAPDF5_AVAILABLE
   use system_dependencies, only: LHAPDF6_AVAILABLE
   use sf_lhapdf_uti
 
 <<Standard module head>>
 
 <<SF lhapdf: public test>>
 
 contains
 
 <<SF lhapdf: test driver>>
 
 end module sf_lhapdf_ut
 @ %def sf_lhapdf_ut
 @
 <<[[sf_lhapdf_uti.f90]]>>=
 <<File header>>
 
 module sf_lhapdf_uti
 
 <<Use kinds>>
 <<Use strings>>
   use system_dependencies, only: LHAPDF5_AVAILABLE
   use system_dependencies, only: LHAPDF6_AVAILABLE
   use os_interface
   use physics_defs, only: PROTON
   use sm_qcd
   use lorentz
   use pdg_arrays
   use flavors
   use interactions, only: reset_interaction_counter
   use model_data
   use sf_base
 
   use sf_lhapdf
 
 <<Standard module head>>
 
 <<SF lhapdf: test declarations>>
 
 contains
 
 <<SF lhapdf: tests>>
 
 end module sf_lhapdf_uti
 @ %def sf_lhapdf_ut
 @ API: driver for the unit tests below.
 <<SF lhapdf: public test>>=
   public :: sf_lhapdf_test
 <<SF lhapdf: test driver>>=
   subroutine sf_lhapdf_test (u, results)
     integer, intent(in) :: u
     type(test_results_t), intent(inout) :: results
   <<SF lhapdf: execute tests>>
   end subroutine sf_lhapdf_test
 
 @ %def sf_lhapdf_test
 @
 \subsubsection{Test structure function data}
 Construct and display a test structure function data object.
 <<SF lhapdf: execute tests>>=
   if (LHAPDF5_AVAILABLE) then
      call test (sf_lhapdf_1, "sf_lhapdf5_1", &
           "structure function configuration", &
           u, results)
   else if (LHAPDF6_AVAILABLE) then
      call test (sf_lhapdf_1, "sf_lhapdf6_1", &
           "structure function configuration", &
           u, results)
   end if
 <<SF lhapdf: test declarations>>=
   public :: sf_lhapdf_1
 <<SF lhapdf: tests>>=
   subroutine sf_lhapdf_1 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(pdg_array_t) :: pdg_in
     type(pdg_array_t), dimension(1) :: pdg_out
     integer, dimension(:), allocatable :: pdg1
     class(sf_data_t), allocatable :: data
 
     write (u, "(A)")  "* Test output: sf_lhapdf_1"
     write (u, "(A)")  "*   Purpose: initialize and display &
          &test structure function data"
     write (u, "(A)")
 
     write (u, "(A)")  "* Create empty data object"
     write (u, "(A)")
 
     call model%init_sm_test ()
     pdg_in = PROTON
 
     allocate (lhapdf_data_t :: data)
     call data%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize"
     write (u, "(A)")
 
     select type (data)
     type is (lhapdf_data_t)
        call data%init (model, pdg_in)
     end select
 
     call data%write (u)
 
     write (u, "(A)")
 
     write (u, "(1x,A)")  "Outgoing particle codes:"
     call data%get_pdg_out (pdg_out)
     pdg1 = pdg_out(1)
     write (u, "(2x,99(1x,I0))")  pdg1
 
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_lhapdf_1"
 
   end subroutine sf_lhapdf_1
 
 @ %def sf_lhapdf_1
 @
 \subsubsection{Test and probe structure function}
 Construct and display a structure function object based on the PDF builtin
 structure function.
 <<SF lhapdf: execute tests>>=
   if (LHAPDF5_AVAILABLE) then
      call test (sf_lhapdf_2, "sf_lhapdf5_2", &
           "structure function instance", &
           u, results)
   else if (LHAPDF6_AVAILABLE) then
      call test (sf_lhapdf_2, "sf_lhapdf6_2", &
           "structure function instance", &
           u, results)
   end if
 <<SF lhapdf: test declarations>>=
   public :: sf_lhapdf_2
 <<SF lhapdf: tests>>=
   subroutine sf_lhapdf_2 (u)
     integer, intent(in) :: u
     type(model_data_t), target :: model
     type(flavor_t) :: flv
     type(pdg_array_t) :: pdg_in
     class(sf_data_t), allocatable, target :: data
     class(sf_int_t), allocatable :: sf_int
     type(vector4_t) :: k
     type(vector4_t), dimension(2) :: q
     real(default) :: E
     real(default), dimension(:), allocatable :: r, rb, x, xb
     real(default) :: f
 
     write (u, "(A)")  "* Test output: sf_lhapdf_2"
     write (u, "(A)")  "*   Purpose: initialize and fill &
          &test structure function object"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call model%init_sm_test ()
     call flv%init (PROTON, model)
     pdg_in = PROTON
     call lhapdf_global_reset ()
 
     call reset_interaction_counter ()
 
     allocate (lhapdf_data_t :: data)
     select type (data)
     type is (lhapdf_data_t)
        call data%init (model, pdg_in)
     end select
 
     write (u, "(A)")  "* Initialize structure-function object"
     write (u, "(A)")
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Initialize incoming momentum with E=500"
     write (u, "(A)")
     E = 500
     k = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
     call vector4_write (k, u)
     call sf_int%seed_kinematics ([k])
 
     write (u, "(A)")
     write (u, "(A)")  "* Set kinematics for x=0.5"
     write (u, "(A)")
 
     allocate (r (data%get_n_par ()))
     allocate (rb(size (r)))
     allocate (x (size (r)))
     allocate (xb(size (r)))
 
     r = 0.5_default
     rb = 1 - r
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%write (u)
 
     write (u, "(A)")
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
     write (u, "(A,9(1x,F10.7))")  "f =", f
 
     write (u, "(A)")
     write (u, "(A)")  "* Recover x from momenta"
     write (u, "(A)")
 
     q = sf_int%get_momenta (outgoing=.true.)
     call sf_int%final ()
     deallocate (sf_int)
 
     call data%allocate_sf_int (sf_int)
     call sf_int%init (data)
     call sf_int%set_beam_index ([1])
 
     call sf_int%seed_kinematics ([k])
     call sf_int%set_momenta (q, outgoing=.true.)
     call sf_int%recover_x (x, xb)
 
     write (u, "(A,9(1x,F10.7))")  "x =", x
     write (u, "(A,9(1x,F10.7))")  "xb=", xb
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for Q = 100 GeV"
     write (u, "(A)")
 
     call sf_int%complete_kinematics (x, xb, f, r, rb, map=.false.)
     call sf_int%apply (scale = 100._default)
     call sf_int%write (u, testflag = .true.)
 
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     call sf_int%final ()
     call model%final ()
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_lhapdf_2"
 
   end subroutine sf_lhapdf_2
 
 @ %def sf_lhapdf_2
 @
 \subsubsection{Strong Coupling}
 Test $\alpha_s$ as an implementation of the [[alpha_qcd_t]] abstract
 type.
 <<SF lhapdf: execute tests>>=
   if (LHAPDF5_AVAILABLE) then
      call test (sf_lhapdf_3, "sf_lhapdf5_3", &
           "running alpha_s", &
           u, results)
   else if (LHAPDF6_AVAILABLE) then
      call test (sf_lhapdf_3, "sf_lhapdf6_3", &
           "running alpha_s", &
           u, results)
   end if
 <<SF lhapdf: test declarations>>=
   public :: sf_lhapdf_3
 <<SF lhapdf: tests>>=
   subroutine sf_lhapdf_3 (u)
     integer, intent(in) :: u
     type(qcd_t) :: qcd
     type(string_t) :: name, path
     integer :: member
 
     write (u, "(A)")  "* Test output: sf_lhapdf_3"
     write (u, "(A)")  "*   Purpose: initialize and evaluate alpha_s"
     write (u, "(A)")
 
     write (u, "(A)")  "* Initialize configuration data"
     write (u, "(A)")
 
     call lhapdf_global_reset ()
 
     if (LHAPDF5_AVAILABLE) then
        name = "cteq6ll.LHpdf"
        member = 1
        path = ""
     else if (LHAPDF6_AVAILABLE) then
        name = "CT10"
        member = 1
        path = ""
     end if
 
     write (u, "(A)")  "* Initialize qcd object"
     write (u, "(A)")
 
     allocate (alpha_qcd_lhapdf_t :: qcd%alpha)
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_lhapdf_t)
        call alpha%init (name, member, path)
     end select
     call qcd%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Evaluate for Q = 100"
     write (u, "(A)")
 
     write (u, "(1x,A,F8.5)")  "alpha = ", qcd%alpha%get (100._default)
 
     write (u, "(A)")
     write (u, "(A)")  "* Cleanup"
 
     write (u, "(A)")
     write (u, "(A)")  "* Test output end: sf_lhapdf_3"
 
   end subroutine sf_lhapdf_3
 
 @ %def sf_lhapdf_3
 @
 \section{Easy PDF Access}
 For the shower, subtraction and matching, it is very useful to have
 direct access to $f(x,Q)$ independently of the used library.
 <<[[pdf.f90]]>>=
 <<File header>>
 
 module pdf
 
 <<Use kinds with double>>
   use beam_structures
   use lhapdf !NODEP!
   use pdf_builtin !NODEP!
 
 <<Standard module head>>
 
 <<PDF: public>>
 
 <<PDF: parameters>>
 
 <<PDF: types>>
 
   interface
 <<PDF: sub interfaces>>
   end interface
 
 end module pdf
 @ %def pdf
 @
 <<[[pdf_sub.f90]]>>=
 <<File header>>
 
 submodule (pdf) pdf_s
 
   use io_units
   use system_dependencies, only: LHAPDF5_AVAILABLE, LHAPDF6_AVAILABLE
   use diagnostics
 
   implicit none
 
 contains
 
 <<PDF: procedures>>
 
 end submodule pdf_s
 
 @ %def pdf_s
 @
 We support the following implementations:
 <<PDF: parameters>>=
   integer, parameter, public :: STRF_NONE = 0
   integer, parameter, public :: STRF_LHAPDF6 = 1
   integer, parameter, public :: STRF_LHAPDF5 = 2
   integer, parameter, public :: STRF_PDF_BUILTIN = 3
 
 @ %def STRF_NONE STRF_LHAPDF6 STRF_LHAPDF5 STRF_PDF_BUILTIN
 @ A container to bundle all necessary PDF data. Could be moved to a more
 central location.
 <<PDF: public>>=
   public :: pdf_data_t
 <<PDF: types>>=
   type :: pdf_data_t
     type(lhapdf_pdf_t) :: pdf
     real(default) :: xmin, xmax, qmin, qmax
     integer :: type = STRF_NONE
     integer :: set = 0
    contains
    <<PDF: pdf data: TBP>>
   end type pdf_data_t
 
 @ %def pdf_data
 @
 <<PDF: pdf data: TBP>>=
   procedure :: init => pdf_data_init
 <<PDF: sub interfaces>>=
     module subroutine pdf_data_init (pdf_data, pdf_data_in)
       class(pdf_data_t), intent(out) :: pdf_data
       type(pdf_data_t), target, intent(in) :: pdf_data_in
     end subroutine pdf_data_init
 <<PDF: procedures>>=
   module subroutine pdf_data_init (pdf_data, pdf_data_in)
     class(pdf_data_t), intent(out) :: pdf_data
     type(pdf_data_t), target, intent(in) :: pdf_data_in
     pdf_data%xmin = pdf_data_in%xmin
     pdf_data%xmax = pdf_data_in%xmax
     pdf_data%qmin = pdf_data_in%qmin
     pdf_data%qmax = pdf_data_in%qmax
     pdf_data%set = pdf_data_in%set
     pdf_data%type = pdf_data_in%type
     if (pdf_data%type == STRF_LHAPDF6) then
        if (pdf_data_in%pdf%is_associated ()) then
           call lhapdf_copy_pointer (pdf_data_in%pdf, pdf_data%pdf)
        else
           call msg_bug ('pdf_data_init: pdf_data%pdf was not associated!')
        end if
     end if
   end subroutine pdf_data_init
 
 @ %def pdf_data_init
 @
 <<PDF: pdf data: TBP>>=
   procedure :: write => pdf_data_write
 <<PDF: sub interfaces>>=
     module subroutine pdf_data_write (pdf_data, unit)
       class(pdf_data_t), intent(in) :: pdf_data
       integer, intent(in), optional :: unit
     end subroutine pdf_data_write
 <<PDF: procedures>>=
   module subroutine pdf_data_write (pdf_data, unit)
     class(pdf_data_t), intent(in) :: pdf_data
     integer, intent(in), optional :: unit
     integer :: u
     u = given_output_unit (unit); if (u < 0) return
     write (u, "(3x,A,I0)") "PDF set  = ", pdf_data%set
     write (u, "(3x,A,I0)") "PDF type = ", pdf_data%type
   end subroutine pdf_data_write
 
 @ %def pdf_data_write
 @
 <<PDF: pdf data: TBP>>=
   procedure :: setup => pdf_data_setup
 <<PDF: sub interfaces>>=
     module subroutine pdf_data_setup &
          (pdf_data, caller, beam_structure, lhapdf_member, set)
       class(pdf_data_t), intent(inout) :: pdf_data
       character(len=*), intent(in) :: caller
       type(beam_structure_t), intent(in) :: beam_structure
       integer, intent(in) :: lhapdf_member, set
     end subroutine pdf_data_setup
 <<PDF: procedures>>=
   module subroutine pdf_data_setup &
        (pdf_data, caller, beam_structure, lhapdf_member, set)
     class(pdf_data_t), intent(inout) :: pdf_data
     character(len=*), intent(in) :: caller
     type(beam_structure_t), intent(in) :: beam_structure
     integer, intent(in) :: lhapdf_member, set
     real(default) :: xmin, xmax, q2min, q2max
     pdf_data%set = set
     if (beam_structure%contains ("lhapdf")) then
        if (LHAPDF6_AVAILABLE) then
           pdf_data%type = STRF_LHAPDF6
        else if (LHAPDF5_AVAILABLE) then
           pdf_data%type = STRF_LHAPDF5
        end if
        write (msg_buffer, "(A,I0)")  caller &
             // ": interfacing LHAPDF set #", pdf_data%set
        call msg_message ()
     else if (beam_structure%contains ("pdf_builtin")) then
        pdf_data%type = STRF_PDF_BUILTIN
        write (msg_buffer, "(A,I0)")  caller &
             // ": interfacing PDF builtin set #", pdf_data%set
        call msg_message ()
     end if
     select case (pdf_data%type)
     case (STRF_LHAPDF6)
        pdf_data%xmin = pdf_data%pdf%getxmin ()
        pdf_data%xmax = pdf_data%pdf%getxmax ()
        pdf_data%qmin = sqrt(pdf_data%pdf%getq2min ())
        pdf_data%qmax = sqrt(pdf_data%pdf%getq2max ())
     case (STRF_LHAPDF5)
        call GetXminM (1, lhapdf_member, xmin)
        call GetXmaxM (1, lhapdf_member, xmax)
        call GetQ2minM (1, lhapdf_member, q2min)
        call GetQ2maxM (1, lhapdf_member, q2max)
        pdf_data%xmin = xmin
        pdf_data%xmax = xmax
        pdf_data%qmin = sqrt(q2min)
        pdf_data%qmax = sqrt(q2max)
     end select
   end subroutine pdf_data_setup
 
 @ %def pdf_data_setup
 @ This could be overloaded with a version that only asks for a specific
 flavor as it is supported by LHAPDF6.
 <<PDF: pdf data: TBP>>=
   procedure :: evolve => pdf_data_evolve
 <<PDF: sub interfaces>>=
     module subroutine pdf_data_evolve (pdf_data, x, q_in, f)
       class(pdf_data_t), intent(inout) :: pdf_data
       real(double), intent(in) :: x, q_in
       real(double), dimension(-6:6), intent(out) :: f
     end subroutine pdf_data_evolve
 <<PDF: procedures>>=
   module subroutine pdf_data_evolve (pdf_data, x, q_in, f)
     class(pdf_data_t), intent(inout) :: pdf_data
     real(double), intent(in) :: x, q_in
     real(double), dimension(-6:6), intent(out) :: f
     real(double) :: q
     select case (pdf_data%type)
     case (STRF_PDF_BUILTIN)
        call pdf_evolve_LHAPDF (pdf_data%set, x, q_in, f)
     case (STRF_LHAPDF6)
        q = min (pdf_data%qmax, q_in)
        q = max (pdf_data%qmin, q)
        call pdf_data%pdf%evolve_pdfm (x, q, f)
     case (STRF_LHAPDF5)
        q = min (pdf_data%qmax, q_in)
        q = max (pdf_data%qmin, q)
        call evolvePDFM (pdf_data%set, x, q, f)
     case default
        call msg_fatal ("PDF function: unknown PDF method.")
     end select
   end subroutine pdf_data_evolve
 @ %def pdf_data_evolve
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \section{Dispatch}
 @
 <<[[dispatch_beams.f90]]>>=
 <<File header>>
 
 module dispatch_beams
 
 <<Use kinds>>
 <<Use strings>>
   use constants, only: PI, one
   use numeric_utils, only: vanishes
   use diagnostics
   use os_interface, only: os_data_t
   use variables, only: var_list_t
   use rng_base, only: rng_factory_t
   use pdg_arrays
   use model_data, only: model_data_t
   use flavors, only: flavor_t
   use physics_defs, only: PHOTON
   use physics_defs, only: MZ_REF, ME_REF, ALPHA_QCD_MZ_REF, ALPHA_QED_ME_REF
   use sm_qcd, only: qcd_t, alpha_qcd_fixed_t, alpha_qcd_from_scale_t
   use sm_qcd, only: alpha_qcd_from_lambda_t
   use sm_qed, only: qed_t, alpha_qed_fixed_t, alpha_qed_from_scale_t
   use beam_structures
   use dispatch_rng, only: dispatch_rng_factory
   use dispatch_rng, only: update_rng_seed_in_var_list
   use sf_base
   use sf_mappings
   use sf_isr
   use sf_epa
   use sf_ewa
   use sf_escan
   use sf_gaussian
   use sf_beam_events
   use sf_circe1
   use sf_circe2
   use sf_pdf_builtin
   use sf_lhapdf
 
 <<Standard module head>>
 
 <<Dispatch beams: public>>
 
 <<Dispatch beams: types>>
 
 <<Dispatch beams: variables>>
 
   interface
 <<Dispatch beams: sub interfaces>>
   end interface
 
 contains
 
 <<Dispatch beams: main procedures>>
 
 end module dispatch_beams
 @ %def dispatch_beams
 @
 <<[[dispatch_beams_sub.f90]]>>=
 <<File header>>
 
 submodule (dispatch_beams) dispatch_beams_s
 
   implicit none
 
 contains
 
 <<Dispatch beams: procedures>>
 
 end submodule dispatch_beams_s
 
 @ %def dispatch_beams_s
 @ This data type is a container for transferring structure-function
 specific data from the [[dispatch_sf_data]] to the
 [[dispatch_sf_channels]] subroutine.
 <<Dispatch beams: public>>=
   public :: sf_prop_t
 <<Dispatch beams: types>>=
   type :: sf_prop_t
      real(default), dimension(2) :: isr_eps = 1
   end type sf_prop_t
 
 @ %def sf_prop_t
 @
 Allocate a structure-function configuration object according to the
 [[sf_method]] string.
 
 The [[sf_prop]] object can be used to transfer structure-function
 specific data up and to the [[dispatch_sf_channels]] subroutine below,
 so they can be used for particular mappings.
 
 The [[var_list_global]] object is used for the RNG generator seed.
 It is intent(inout) because the RNG generator seed
 may change during initialization.
 
 The [[pdg_in]] array is the array of incoming flavors, corresponding
 to the upstream structure function or the beam array.  This will be
 checked for the structure function in question and replaced by the
 outgoing flavors.  The [[pdg_prc]] array is the array of incoming
 flavors (beam index, component index) for the hard process.
 Due to a bug in gfortran 7/8/9 this has to remain in the main module.
 <<Dispatch beams: public>>=
   public :: dispatch_sf_data
 <<Dispatch beams: main procedures>>=
   subroutine dispatch_sf_data (data, sf_method, i_beam, sf_prop, &
        var_list, var_list_global, model, &
        os_data, sqrts, pdg_in, pdg_prc, polarized)
     class(sf_data_t), allocatable, intent(inout) :: data
     type(string_t), intent(in) :: sf_method
     integer, dimension(:), intent(in) :: i_beam
     type(pdg_array_t), dimension(:), intent(inout) :: pdg_in
     type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
     type(sf_prop_t), intent(inout) :: sf_prop
     type(var_list_t), intent(in) :: var_list
     type(var_list_t), intent(inout) :: var_list_global
     integer :: next_rng_seed
     class(model_data_t), target, intent(in) :: model
     type(os_data_t), intent(in) :: os_data
     real(default), intent(in) :: sqrts
     logical, intent(in) :: polarized
     type(pdg_array_t), dimension(:), allocatable :: pdg_out
     real(default) :: isr_alpha, isr_q_max, isr_mass
     integer :: isr_order
     logical :: isr_recoil, isr_keep_energy
     real(default) :: epa_alpha, epa_x_min, epa_q_min, epa_q_max, epa_mass
     logical :: epa_recoil, epa_keep_energy
     integer :: epa_int_mode
     type(string_t) :: epa_mode
     real(default) :: ewa_x_min, ewa_pt_max, ewa_mass
     logical :: ewa_recoil, ewa_keep_energy
     type(pdg_array_t), dimension(:), allocatable :: pdg_prc1
     integer :: ewa_id
     type(string_t) :: pdf_name
     type(string_t) :: lhapdf_dir, lhapdf_file
     type(string_t), dimension(13) :: lhapdf_photon_sets
     integer :: lhapdf_member, lhapdf_photon_scheme
     logical :: hoppet_b_matching
     class(rng_factory_t), allocatable :: rng_factory
     logical :: circe1_photon1, circe1_photon2, circe1_generate, &
          circe1_with_radiation
     real(default) :: circe1_sqrts, circe1_eps
     integer :: circe1_version, circe1_chattiness, &
          circe1_revision
     character(6) :: circe1_accelerator
     logical :: circe2_polarized
     type(string_t) :: circe2_design, circe2_file
     real(default), dimension(2) :: gaussian_spread
     logical :: beam_events_warn_eof
     type(string_t) :: beam_events_dir, beam_events_file
     logical :: escan_normalize
     integer :: i
     lhapdf_photon_sets = [var_str ("DOG0.LHgrid"), var_str ("DOG1.LHgrid"), &
          var_str ("DGG.LHgrid"), var_str ("LACG.LHgrid"), &
          var_str ("GSG0.LHgrid"), var_str ("GSG1.LHgrid"), &
          var_str ("GSG960.LHgrid"), var_str ("GSG961.LHgrid"), &
          var_str ("GRVG0.LHgrid"), var_str ("GRVG1.LHgrid"), &
          var_str ("ACFGPG.LHgrid"), var_str ("WHITG.LHgrid"), &
          var_str ("SASG.LHgrid")]
     select case (char (sf_method))
     case ("pdf_builtin")
        allocate (pdf_builtin_data_t :: data)
        select type (data)
        type is (pdf_builtin_data_t)
           pdf_name = &
                var_list%get_sval (var_str ("$pdf_builtin_set"))
           hoppet_b_matching = &
                var_list%get_lval (var_str ("?hoppet_b_matching"))
           call data%init ( &
                model, pdg_in(i_beam(1)), &
                name = pdf_name, &
                path = os_data%pdf_builtin_datapath, &
                hoppet_b_matching = hoppet_b_matching)
        end select
     case ("pdf_builtin_photon")
        call msg_fatal ("Currently, there are no photon PDFs built into WHIZARD,", &
             [var_str ("for the photon content inside a proton or neutron use"), &
              var_str ("the 'lhapdf_photon' structure function.")])
     case ("lhapdf")
        allocate (lhapdf_data_t :: data)
        if (pdg_in(i_beam(1))%get (1) == PHOTON) then
           call msg_fatal ("The 'lhapdf' structure is intended only for protons and", &
                [var_str ("pions, please use 'lhapdf_photon' for photon beams.")])
        end if
        lhapdf_dir = &
             var_list%get_sval (var_str ("$lhapdf_dir"))
        lhapdf_file = &
             var_list%get_sval (var_str ("$lhapdf_file"))
        lhapdf_member = &
             var_list%get_ival (var_str ("lhapdf_member"))
        lhapdf_photon_scheme = &
             var_list%get_ival (var_str ("lhapdf_photon_scheme"))
        hoppet_b_matching = &
             var_list%get_lval (var_str ("?hoppet_b_matching"))
        select type (data)
        type is (lhapdf_data_t)
           call data%init &
                (model, pdg_in(i_beam(1)), &
                 lhapdf_dir, lhapdf_file, lhapdf_member, &
                 lhapdf_photon_scheme, hoppet_b_matching)
        end select
     case ("lhapdf_photon")
        allocate (lhapdf_data_t :: data)
        if (pdg_in(i_beam(1))%get_length () /= 1 .or. &
             pdg_in(i_beam(1))%get (1) /= PHOTON) then
           call msg_fatal ("The 'lhapdf_photon' structure function is exclusively for", &
                [var_str ("photon PDFs, i.e. for photons as beam particles")])
        end if
        lhapdf_dir = &
             var_list%get_sval (var_str ("$lhapdf_dir"))
        lhapdf_file = &
             var_list%get_sval (var_str ("$lhapdf_photon_file"))
        lhapdf_member = &
             var_list%get_ival (var_str ("lhapdf_member"))
        lhapdf_photon_scheme = &
             var_list%get_ival (var_str ("lhapdf_photon_scheme"))
        if (.not. any (lhapdf_photon_sets == lhapdf_file)) then
           call msg_fatal ("This PDF set is not supported or not " // &
                "intended for photon beams.")
        end if
        select type (data)
        type is (lhapdf_data_t)
           call data%init &
                (model, pdg_in(i_beam(1)), &
                 lhapdf_dir, lhapdf_file, lhapdf_member, &
                 lhapdf_photon_scheme)
        end select
     case ("isr")
        allocate (isr_data_t :: data)
        isr_alpha = &
             var_list%get_rval (var_str ("isr_alpha"))
        if (vanishes (isr_alpha)) then
           isr_alpha = (var_list%get_rval (var_str ("ee"))) &
                ** 2 / (4 * PI)
        end if
        isr_q_max = &
             var_list%get_rval (var_str ("isr_q_max"))
        if (vanishes (isr_q_max)) then
           isr_q_max = sqrts
        end if
        isr_mass   = var_list%get_rval (var_str ("isr_mass"))
        isr_order  = var_list%get_ival (var_str ("isr_order"))
        isr_recoil = var_list%get_lval (var_str ("?isr_recoil"))
        isr_keep_energy = var_list%get_lval (var_str ("?isr_keep_energy"))
        select type (data)
        type is (isr_data_t)
           call data%init &
                (model, pdg_in (i_beam(1)), isr_alpha, isr_q_max, &
                isr_mass, isr_order, recoil = isr_recoil, keep_energy = &
                isr_keep_energy)
           call data%check ()
           sf_prop%isr_eps(i_beam(1)) = data%get_eps ()
        end select
     case ("epa")
        allocate (epa_data_t :: data)
        epa_mode = var_list%get_sval (var_str ("$epa_mode"))
        epa_int_mode = 0
        epa_alpha = var_list%get_rval (var_str ("epa_alpha"))
        if (vanishes (epa_alpha)) then
           epa_alpha = (var_list%get_rval (var_str ("ee"))) &
                ** 2 / (4 * PI)
        end if
        epa_x_min = var_list%get_rval (var_str ("epa_x_min"))
        epa_q_min = var_list%get_rval (var_str ("epa_q_min"))
        epa_q_max = var_list%get_rval (var_str ("epa_q_max"))
        if (vanishes (epa_q_max)) then
           epa_q_max = sqrts
        end if
        select case (char (epa_mode))
        case ("default", "Budnev_617")
           epa_int_mode = 0
        case ("Budnev_616e")
           epa_int_mode = 1
        case ("log_power")
           epa_int_mode = 2
           epa_q_max = sqrts
        case ("log_simple")
           epa_int_mode = 3
           epa_q_max = sqrts
        case ("log")
           epa_int_mode = 4
           epa_q_max = sqrts
        case default
           call msg_fatal ("EPA: unsupported EPA mode; please choose " // &
                "'default', 'Budnev_616', 'Budnev_616e', 'log_power', " // &
                "'log_simple', or 'log'")
        end select
        epa_mass   = var_list%get_rval (var_str ("epa_mass"))
        epa_recoil = var_list%get_lval (var_str ("?epa_recoil"))
        epa_keep_energy = var_list%get_lval (var_str ("?epa_keep_energy"))
        select type (data)
        type is (epa_data_t)
           call data%init &
                (model, epa_int_mode, pdg_in (i_beam(1)), epa_alpha, &
                epa_x_min, epa_q_min, epa_q_max, epa_mass, &
                recoil = epa_recoil, keep_energy = epa_keep_energy)
           call data%check ()
        end select
     case ("ewa")
        allocate (ewa_data_t :: data)
        allocate (pdg_prc1 (size (pdg_prc, 2)))
        pdg_prc1 = pdg_prc(i_beam(1),:)
        if (any (pdg_prc1%get_length () /= 1) &
             .or. any (pdg_prc1 /= pdg_prc1(1))) then
           call msg_fatal &
                ("EWA: process incoming particle (W/Z) must be unique")
        end if
        ewa_id = abs (pdg_prc1(1)%get (1))
        ewa_x_min = var_list%get_rval (var_str ("ewa_x_min"))
        ewa_pt_max = var_list%get_rval (var_str ("ewa_pt_max"))
        if (vanishes (ewa_pt_max)) then
           ewa_pt_max = sqrts
        end if
        ewa_mass = var_list%get_rval (var_str ("ewa_mass"))
        ewa_recoil = var_list%get_lval (&
             var_str ("?ewa_recoil"))
        ewa_keep_energy = var_list%get_lval (&
             var_str ("?ewa_keep_energy"))
        select type (data)
        type is (ewa_data_t)
           call data%init &
                (model, pdg_in (i_beam(1)), ewa_x_min, &
                ewa_pt_max, sqrts, ewa_recoil, &
                ewa_keep_energy, ewa_mass)
           call data%set_id (ewa_id)
           call data%check ()
        end select
     case ("circe1")
        allocate (circe1_data_t :: data)
        select type (data)
        type is (circe1_data_t)
           circe1_photon1 = &
                var_list%get_lval (var_str ("?circe1_photon1"))
           circe1_photon2 = &
                var_list%get_lval (var_str ("?circe1_photon2"))
           circe1_sqrts = &
                var_list%get_rval (var_str ("circe1_sqrts"))
           circe1_eps = &
                var_list%get_rval (var_str ("circe1_eps"))
           if (circe1_sqrts <= 0)  circe1_sqrts = sqrts
           circe1_generate = &
                var_list%get_lval (var_str ("?circe1_generate"))
           circe1_version = &
                var_list%get_ival (var_str ("circe1_ver"))
           circe1_revision = &
                var_list%get_ival (var_str ("circe1_rev"))
           circe1_accelerator = &
                char (var_list%get_sval (var_str ("$circe1_acc")))
           circe1_chattiness = &
                var_list%get_ival (var_str ("circe1_chat"))
           circe1_with_radiation = &
                var_list%get_lval (var_str ("?circe1_with_radiation"))
           call data%init (model, pdg_in, circe1_sqrts, circe1_eps, &
                [circe1_photon1, circe1_photon2], &
                circe1_version, circe1_revision, circe1_accelerator, &
                circe1_chattiness, circe1_with_radiation)
           if (circe1_generate) then
              call msg_message ("CIRCE1: activating generator mode")
              call dispatch_rng_factory &
                   (rng_factory, var_list_global, next_rng_seed)
              call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
              call data%set_generator_mode (rng_factory)
           end if
        end select
     case ("circe2")
        allocate (circe2_data_t :: data)
        select type (data)
        type is (circe2_data_t)
           circe2_polarized = &
                var_list%get_lval (var_str ("?circe2_polarized"))
           circe2_file = &
                var_list%get_sval (var_str ("$circe2_file"))
           circe2_design = &
                var_list%get_sval (var_str ("$circe2_design"))
           call data%init (os_data, model, pdg_in, sqrts, &
                circe2_polarized, polarized, circe2_file, circe2_design)
           call msg_message ("CIRCE2: activating generator mode")
           call dispatch_rng_factory &
                (rng_factory, var_list_global, next_rng_seed)
           call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
           call data%set_generator_mode (rng_factory)
        end select
     case ("gaussian")
        allocate (gaussian_data_t :: data)
        select type (data)
        type is (gaussian_data_t)
           gaussian_spread = &
                [var_list%get_rval (var_str ("gaussian_spread1")), &
                var_list%get_rval (var_str ("gaussian_spread2"))]
           call dispatch_rng_factory &
                (rng_factory, var_list_global, next_rng_seed)
           call update_rng_seed_in_var_list (var_list_global, next_rng_seed)
           call data%init (model, pdg_in, gaussian_spread, rng_factory)
        end select
     case ("beam_events")
        allocate (beam_events_data_t :: data)
        select type (data)
        type is (beam_events_data_t)
           beam_events_dir = os_data%whizard_beamsimpath
           beam_events_file = var_list%get_sval (&
                var_str ("$beam_events_file"))
           beam_events_warn_eof = var_list%get_lval (&
                var_str ("?beam_events_warn_eof"))
           call data%init (model, pdg_in, &
                   beam_events_dir, beam_events_file, beam_events_warn_eof)
        end select
     case ("energy_scan")
        escan_normalize = &
             var_list%get_lval (var_str ("?energy_scan_normalize"))
        allocate (escan_data_t :: data)
        select type (data)
        type is (escan_data_t)
           if (escan_normalize) then
              call data%init (model, pdg_in)
           else
              call data%init (model, pdg_in, sqrts)
           end if
        end select
     case default
        if (associated (dispatch_sf_data_extra)) then
           call dispatch_sf_data_extra (data, sf_method, i_beam, &
                sf_prop, var_list, var_list_global, model, os_data, sqrts, pdg_in, &
                pdg_prc, polarized)
        end if
        if (.not. allocated (data)) then
           call msg_fatal ("Structure function '" &
                // char (sf_method) // "' not implemented")
        end if
     end select
     if (allocated (data)) then
        allocate (pdg_out (size (pdg_prc, 1)))
        call data%get_pdg_out (pdg_out)
        do i = 1, size (i_beam)
           pdg_in(i_beam(i)) = pdg_out(i)
        end do
     end if
   end subroutine dispatch_sf_data
 
 @ %def dispatch_sf_data
 @ This is a hook that allows us to inject further handlers for
 structure-function objects, in particular a test structure function.
 <<Dispatch beams: public>>=
   public :: dispatch_sf_data_extra
 <<Dispatch beams: variables>>=
   procedure (dispatch_sf_data), pointer :: &
        dispatch_sf_data_extra => null ()
 @ %def dispatch_sf_data_extra
 @ This is an auxiliary procedure, used by the beam-structure
 expansion: tell for a given structure function name, whether it
 corresponds to a pair spectrum ($n=2$), a single-particle structure
 function ($n=1$), or nothing ($n=0$). Though [[energy_scan]] can
 in principle also be a pair spectrum, it always has only one
 parameter.
 <<Dispatch beams: public>>=
   public :: strfun_mode
 <<Dispatch beams: sub interfaces>>=
     module function strfun_mode (name) result (n)
       type(string_t), intent(in) :: name
       integer :: n
     end function strfun_mode
 <<Dispatch beams: procedures>>=
   module function strfun_mode (name) result (n)
     type(string_t), intent(in) :: name
     integer :: n
     select case (char (name))
     case ("none")
        n = 0
     case ("sf_test_0", "sf_test_1")
        n = 1
     case ("pdf_builtin","pdf_builtin_photon", &
           "lhapdf","lhapdf_photon")
        n = 1
     case ("isr","epa","ewa")
        n = 1
     case ("circe1", "circe2")
        n = 2
     case ("gaussian")
        n = 2
     case ("beam_events")
        n = 2
     case ("energy_scan")
        n = 2
     case default
        n = -1
        call msg_bug ("Structure function '" // char (name) &
             // "' not supported yet")
     end select
   end function strfun_mode
 
 @ %def strfun_mode
 @ Dispatch a whole structure-function chain, given beam data and beam
 structure data.
 
 This could be done generically, but we should look at the specific
 combination of structure functions in order to select appropriate mappings.
 
 The [[beam_structure]] argument gets copied because
 we want to expand it to canonical form (one valid structure-function
 entry per record) before proceeding further.
 
 The [[pdg_prc]] argument is the array of incoming flavors.  The first
 index is the beam index, the second one the process component index.
 Each element is itself a PDG array, notrivial if there is a flavor sum
 for the incoming state of this component.
 
 The dispatcher is divided in two parts.  The first part configures the
 structure function data themselves.  After this, we can configure the
 phase space for the elementary process.
 <<Dispatch beams: public>>=
   public :: dispatch_sf_config
 <<Dispatch beams: sub interfaces>>=
     module subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, &
            var_list, var_list_global, model, os_data, sqrts, pdg_prc)
       type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config
       type(sf_prop_t), intent(out) :: sf_prop
       type(beam_structure_t), intent(inout) :: beam_structure
       type(var_list_t), intent(in) :: var_list
       type(var_list_t), intent(inout) :: var_list_global
       class(model_data_t), target, intent(in) :: model
       type(os_data_t), intent(in) :: os_data
       real(default), intent(in) :: sqrts
       class(sf_data_t), allocatable :: sf_data
       type(beam_structure_t) :: beam_structure_tmp
       type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
       type(string_t), dimension(:), allocatable :: prt_in
       type(pdg_array_t), dimension(:), allocatable :: pdg_in
     end subroutine dispatch_sf_config
 <<Dispatch beams: procedures>>=
   module subroutine dispatch_sf_config (sf_config, sf_prop, beam_structure, &
          var_list, var_list_global, model, os_data, sqrts, pdg_prc)
     type(sf_config_t), dimension(:), allocatable, intent(out) :: sf_config
     type(sf_prop_t), intent(out) :: sf_prop
     type(beam_structure_t), intent(inout) :: beam_structure
     type(var_list_t), intent(in) :: var_list
     type(var_list_t), intent(inout) :: var_list_global
     class(model_data_t), target, intent(in) :: model
     type(os_data_t), intent(in) :: os_data
     real(default), intent(in) :: sqrts
     class(sf_data_t), allocatable :: sf_data
     type(beam_structure_t) :: beam_structure_tmp
     type(pdg_array_t), dimension(:,:), intent(in) :: pdg_prc
     type(string_t), dimension(:), allocatable :: prt_in
     type(pdg_array_t), dimension(:), allocatable :: pdg_in
     type(flavor_t) :: flv_in
     integer :: n_beam, n_record, i
     beam_structure_tmp = beam_structure
     call beam_structure_tmp%expand (strfun_mode)
     n_record = beam_structure_tmp%get_n_record ()
     allocate (sf_config (n_record))
     n_beam = beam_structure_tmp%get_n_beam ()
     if (n_beam > 0) then
        allocate (prt_in (n_beam), pdg_in (n_beam))
        prt_in = beam_structure_tmp%get_prt ()
        do i = 1, n_beam
           call flv_in%init (prt_in(i), model)
           pdg_in(i) = flv_in%get_pdg ()
        end do
     else
        n_beam = size (pdg_prc, 1)
        allocate (pdg_in (n_beam))
        pdg_in = pdg_prc(:,1)
     end if
     do i = 1, n_record
        call dispatch_sf_data (sf_data, &
             beam_structure_tmp%get_name (i), &
             beam_structure_tmp%get_i_entry (i), &
             sf_prop, var_list, var_list_global, model, os_data, sqrts, &
             pdg_in, pdg_prc, &
             beam_structure_tmp%polarized ())
        call sf_config(i)%init (beam_structure_tmp%get_i_entry (i), sf_data)
        deallocate (sf_data)
     end do
   end subroutine dispatch_sf_config
 
 @ %def dispatch_sf_config
 @
 \subsection{QCD and QED coupling}
 Allocate the [[alpha]] (running coupling) component of the [[qcd]] block with
 a concrete implementation, depending on the variable settings in the
 [[global]] record.
 
 If a fixed $\alpha_s$ is requested, we do not allocate the
 [[qcd%alpha]] object.  In this case, the matrix element code will just take
 the model parameter as-is, which implies fixed $\alpha_s$.  If the
 object is allocated, the $\alpha_s$ value is computed and updated for
 each matrix-element call.
 
 Also fetch the [[alphas_nf]] variable from the list and store it in
 the QCD record.  This is not used in the $\alpha_s$ calculation, but
 the QCD record thus becomes a messenger for this user parameter.
 Gfortran 7/8/9 bug: has to be part of main module.
 <<Dispatch beams: public>>=
   public :: dispatch_qcd
 <<Dispatch beams: main procedures>>=
   subroutine dispatch_qcd (qcd, var_list, os_data)
     type(qcd_t), intent(inout) :: qcd
     type(var_list_t), intent(in) :: var_list
     type(os_data_t), intent(in) :: os_data
     logical :: fixed, from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd
     real(default) :: mz, alpha_val, lambda
     integer :: nf, order, lhapdf_member
     type(string_t) :: pdfset, lhapdf_dir, lhapdf_file
     call unpack_variables ()
     if (allocated (qcd%alpha))  deallocate (qcd%alpha)
     if (from_lhapdf .and. from_pdf_builtin) then
         call msg_fatal (" Mixing alphas evolution",  &
              [var_str (" from LHAPDF and builtin PDF is not permitted")])
     end if
     select case (count ([from_mz, from_pdf_builtin, from_lhapdf, from_lambda_qcd]))
     case (0)
        if (fixed) then
           allocate (alpha_qcd_fixed_t :: qcd%alpha)
        else
           call msg_fatal ("QCD alpha: no calculation mode set")
        end if
     case (2:)
        call msg_fatal ("QCD alpha: calculation mode is ambiguous")
     case (1)
        if (fixed) then
           call msg_fatal ("QCD alpha: use '?alphas_is_fixed = false' for " // &
                "running alphas")
        else if (from_mz) then
           allocate (alpha_qcd_from_scale_t :: qcd%alpha)
        else if (from_pdf_builtin) then
           allocate (alpha_qcd_pdf_builtin_t :: qcd%alpha)
        else if (from_lhapdf) then
           allocate (alpha_qcd_lhapdf_t :: qcd%alpha)
        else if (from_lambda_qcd) then
           allocate (alpha_qcd_from_lambda_t :: qcd%alpha)
        end if
        call msg_message ("QCD alpha: using a running strong coupling")
     end select
     call init_alpha ()
     qcd%n_f = var_list%get_ival (var_str ("alphas_nf"))
   contains
   <<Dispatch qcd: dispatch qcd: procedures>>
   end subroutine dispatch_qcd
 
 @ %def dispatch_qcd
 @
 <<Dispatch qcd: dispatch qcd: procedures>>=
   subroutine unpack_variables ()
     fixed = var_list%get_lval (var_str ("?alphas_is_fixed"))
     from_mz = var_list%get_lval (var_str ("?alphas_from_mz"))
     from_pdf_builtin = &
          var_list%get_lval (var_str ("?alphas_from_pdf_builtin"))
     from_lhapdf = &
          var_list%get_lval (var_str ("?alphas_from_lhapdf"))
     from_lambda_qcd = &
          var_list%get_lval (var_str ("?alphas_from_lambda_qcd"))
     pdfset = var_list%get_sval (var_str ("$pdf_builtin_set"))
     lambda = var_list%get_rval (var_str ("lambda_qcd"))
     nf = var_list%get_ival (var_str ("alphas_nf"))
     order = var_list%get_ival (var_str ("alphas_order"))
     lhapdf_dir = var_list%get_sval (var_str ("$lhapdf_dir"))
     lhapdf_file = var_list%get_sval (var_str ("$lhapdf_file"))
     lhapdf_member = var_list%get_ival (var_str ("lhapdf_member"))
     if (var_list%contains (var_str ("mZ"))) then
        mz = var_list%get_rval (var_str ("mZ"))
     else
        mz = MZ_REF
     end if
     if (var_list%contains (var_str ("alphas"))) then
        alpha_val = var_list%get_rval (var_str ("alphas"))
     else
        alpha_val = ALPHA_QCD_MZ_REF
     end if
   end subroutine unpack_variables
 
 @
 <<Dispatch qcd: dispatch qcd: procedures>>=
   subroutine init_alpha ()
     select type (alpha => qcd%alpha)
     type is (alpha_qcd_fixed_t)
        alpha%val = alpha_val
     type is (alpha_qcd_from_scale_t)
        alpha%mu_ref = mz
        alpha%ref = alpha_val
        alpha%order = order
        alpha%nf = nf
     type is (alpha_qcd_from_lambda_t)
        alpha%lambda = lambda
        alpha%order = order
        alpha%nf = nf
     type is (alpha_qcd_pdf_builtin_t)
        call alpha%init (pdfset, &
             os_data%pdf_builtin_datapath)
     type is (alpha_qcd_lhapdf_t)
        call alpha%init (lhapdf_file, lhapdf_member, lhapdf_dir)
     end select
   end subroutine init_alpha
 
 @
 @ Same for QED. Gfortran 7/8/9: has to be part of main module.
 <<Dispatch beams: public>>=
   public :: dispatch_qed
 <<Dispatch beams: main procedures>>=
   subroutine dispatch_qed (qed, var_list)
     type(qed_t), intent(inout) :: qed
     type(var_list_t), intent(in) :: var_list
     logical :: fixed, from_me, analytic
     real(default) :: me, alpha_val
     integer :: nf, nlep, order
     call unpack_variables ()
     if (allocated (qed%alpha))  deallocate (qed%alpha)
     select case (count ([from_me]))
     case (0)
        if (fixed) then
           allocate (alpha_qed_fixed_t :: qed%alpha)
        else
           call msg_fatal ("QED alpha: no calculation mode set")
        end if
     case (2:)
        call msg_fatal ("QED alpha: calculation mode is ambiguous")
     case (1)
        if (fixed) then
           call msg_fatal ("QED alpha: use '?alphas_is_fixed = false' for " // &
                "running alpha")
        else if (from_me) then
           allocate (alpha_qed_from_scale_t :: qed%alpha)
        end if
        call msg_message ("QED alpha: using a running electromagnetic coupling")
     end select
     call init_alpha ()
     if (var_list%get_ival (var_str ("alpha_nf")) == -1) then
        qed%n_f = var_list%get_ival (var_str ("alphas_nf"))
     else
        qed%n_f = var_list%get_ival (var_str ("alpha_nf"))
     end if
     qed%n_lep = var_list%get_ival (var_str ("alpha_nlep"))
   contains
   <<Dispatch qed: dispatch qed: procedures>>
   end subroutine dispatch_qed
 
 @ %def dispatch_qed
 @
 <<Dispatch qed: dispatch qed: procedures>>=
   subroutine unpack_variables ()
     fixed = var_list%get_lval (var_str ("?alpha_is_fixed"))
     from_me = var_list%get_lval (var_str ("?alpha_from_me"))
     if (var_list%get_ival (var_str ("alpha_nf")) == -1) then
        nf = var_list%get_ival (var_str ("alphas_nf"))
     else
        nf = var_list%get_ival (var_str ("alpha_nf"))
     end if
     analytic = var_list%get_lval (var_str ("?alpha_evolve_analytic"))
     nlep = var_list%get_ival (var_str ("alpha_nlep"))
     order = var_list%get_ival (var_str ("alpha_order"))
     if (var_list%contains (var_str ("me"))) then
        me = var_list%get_rval (var_str ("me"))
     else
        me = ME_REF
     end if
     if (var_list%contains (var_str ("alpha_em_i"))) then
        alpha_val = one / var_list%get_rval (var_str ("alpha_em_i"))
     else
        alpha_val = ALPHA_QED_ME_REF
     end if
   end subroutine unpack_variables
 
 @
 <<Dispatch qed: dispatch qed: procedures>>=
   subroutine init_alpha ()
     select type (alpha => qed%alpha)
     type is (alpha_qed_fixed_t)
        alpha%val = alpha_val
     type is (alpha_qed_from_scale_t)
        alpha%mu_ref = me
        alpha%ref = alpha_val
        alpha%order = order
        alpha%nf = nf
        alpha%nlep = nlep
        alpha%analytic = analytic
     end select
   end subroutine init_alpha
 
 @
Index: trunk/src/phase_space/phase_space.nw
===================================================================
--- trunk/src/phase_space/phase_space.nw	(revision 8865)
+++ trunk/src/phase_space/phase_space.nw	(revision 8866)
@@ -1,31078 +1,31080 @@
 % -*- 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\_none]
   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 lorentz
   use model_data
   use flavors
   use process_constants
 
 <<Standard module head>>
 
 <<PHS base: public>>
 
 <<PHS base: types>>
 
 <<PHS base: interfaces>>
 
   interface
 <<PHS base: sub interfaces>>
   end interface
 
 contains
 
 <<PHS base: main procedures>>
 
 end module phs_base
 @ %def phs_base
 @
 <<[[phs_base_sub.f90]]>>=
 <<File header>>
 
 submodule (phs_base) phs_base_s
 
   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
 
   implicit none
 
 contains
 
 <<PHS base: procedures>>
 
 end submodule phs_base_s
 
 @ %def phs_base_s
 @
 \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: sub interfaces>>=
     module function resonance_to_string (object) result (string)
       class(resonance_t), intent(in) :: object
       type(string_t) :: string
     end function resonance_to_string
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function resonance_is_equal (prop1, prop2) result (flag)
       class(resonance_t), intent(in) :: prop1
       class(channel_prop_t), intent(in) :: prop2
       logical :: flag
     end function resonance_is_equal
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function on_shell_to_string (object) result (string)
       class(on_shell_t), intent(in) :: object
       type(string_t) :: string
     end function on_shell_to_string
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function on_shell_is_equal
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_equivalence_write (object, unit)
       class(phs_equivalence_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine phs_equivalence_write
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_equivalence_init (eq, n_dim)
       class(phs_equivalence_t), intent(out) :: eq
       integer, intent(in) :: n_dim
     end subroutine phs_equivalence_init
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_channel_write (object, unit)
       class(phs_channel_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine phs_channel_write
 <<PHS base: procedures>>=
   module 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.
 Gfortran 7/8/9 bug: has to remain in the main module.
 <<PHS base: phs channel: TBP>>=
   procedure :: set_resonant => channel_set_resonant
 <<PHS base: main 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.
 Gfortran 7/8/9 bug: has to remain in the main module.
 <<PHS base: phs channel: TBP>>=
   procedure :: set_on_shell => channel_set_on_shell
 <<PHS base: main 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: sub interfaces>>=
     module subroutine phs_channel_collection_final (object)
       class(phs_channel_collection_t), intent(inout) :: object
     end subroutine phs_channel_collection_final
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_channel_collection_write (object, unit)
       class(phs_channel_collection_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine phs_channel_collection_write
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_channel_collection_push (coll, channel)
       class(phs_channel_collection_t), intent(inout) :: coll
       type(phs_channel_t), intent(inout) :: channel
     end subroutine phs_channel_collection_push
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_channel_collection_get_n (coll) result (n)
       class(phs_channel_collection_t), intent(in) :: coll
       integer :: n
     end function phs_channel_collection_get_n
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_channel_collection_get_entry
 <<PHS base: procedures>>=
   module 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 :: lab_is_cm = .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: sub interfaces>>=
     module 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
     end subroutine phs_config_write
 <<PHS base: procedures>>=
   module 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)")  "lab_is_cm = ", object%lab_is_cm
     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: sub interfaces>>=
     module 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
     end subroutine phs_config_init
 <<PHS base: procedures>>=
   module 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, lab_is_cm, 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 :: lab_is_cm
        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: sub interfaces>>=
     module subroutine phs_config_set_sf_channel (phs_config, sf_channel)
       class(phs_config_t), intent(inout) :: phs_config
       integer, dimension(:), intent(in) :: sf_channel
     end subroutine phs_config_set_sf_channel
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_config_collect_channels (phs_config, coll)
       class(phs_config_t), intent(inout) :: phs_config
       type(phs_channel_collection_t), intent(inout) :: coll
     end subroutine phs_config_collect_channels
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_config_compute_md5sum (phs_config, include_id)
       class(phs_config_t), intent(inout) :: phs_config
       logical, intent(in), optional :: include_id
     end subroutine phs_config_compute_md5sum
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_startup_message (phs_config, unit)
       class(phs_config_t), intent(in) :: phs_config
       integer, intent(in), optional :: unit
     end subroutine phs_startup_message
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_config_get_n_par (phs_config) result (n)
       class(phs_config_t), intent(in) :: phs_config
       integer :: n
     end function phs_config_get_n_par
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_config_get_flat_dimensions &
          (phs_config) result (dim_flat)
       class(phs_config_t), intent(in) :: phs_config
       integer, dimension(:), allocatable :: dim_flat
     end function phs_config_get_flat_dimensions
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_config_get_n_channel (phs_config) result (n)
       class(phs_config_t), intent(in) :: phs_config
       integer :: n
     end function phs_config_get_n_channel
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function phs_config_get_sf_channel
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_config_get_masses_in (phs_config, m)
       class(phs_config_t), intent(in) :: phs_config
       real(default), dimension(:), intent(out) :: m
     end subroutine phs_config_get_masses_in
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_config_get_md5sum (phs_config) result (md5sum)
       class(phs_config_t), intent(in) :: phs_config
       character(32) :: md5sum
     end function phs_config_get_md5sum
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_base_write (object, unit)
       class(phs_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine phs_base_write
 <<PHS base: procedures>>=
   module 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%lab_is_cm) 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: sub interfaces>>=
     module subroutine phs_base_init (phs, phs_config)
       class(phs_t), intent(out) :: phs
       class(phs_config_t), intent(in), target :: phs_config
     end subroutine phs_base_init
 <<PHS base: procedures>>=
   module subroutine phs_base_init (phs, phs_config)
     class(phs_t), intent(out) :: phs
     class(phs_config_t), intent(in), target :: phs_config
     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))
     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 = 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: sub interfaces>>=
     module subroutine phs_base_select_channel (phs, channel)
       class(phs_t), intent(inout) :: phs
       integer, intent(in), optional :: channel
     end subroutine phs_base_select_channel
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_set_incoming_momenta (phs, p)
       class(phs_t), intent(inout) :: phs
       type(vector4_t), dimension(:), intent(in) :: p
     end subroutine phs_set_incoming_momenta
 <<PHS base: procedures>>=
   module 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%lab_is_cm) 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 we 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: sub interfaces>>=
     module subroutine phs_set_outgoing_momenta (phs, q)
       class(phs_t), intent(inout) :: phs
       type(vector4_t), dimension(:), intent(in) :: q
     end subroutine phs_set_outgoing_momenta
 <<PHS base: procedures>>=
   module 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%lab_is_cm) 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: sub interfaces>>=
     module subroutine phs_get_outgoing_momenta (phs, q)
       class(phs_t), intent(in) :: phs
       type(vector4_t), dimension(:), intent(out) :: q
     end subroutine phs_get_outgoing_momenta
 <<PHS base: procedures>>=
   module 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%lab_is_cm) 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 :: lab_is_cm => phs_lab_is_cm
 <<PHS base: sub interfaces>>=
     module function phs_lab_is_cm (phs) result (lab_is_cm)
       logical :: lab_is_cm
       class(phs_t), intent(in) :: phs
     end function phs_lab_is_cm
 <<PHS base: procedures>>=
   module function phs_lab_is_cm (phs) result (lab_is_cm)
     logical :: lab_is_cm
     class(phs_t), intent(in) :: phs
     lab_is_cm = phs%config%lab_is_cm
   end function phs_lab_is_cm
 
 @ %def phs_lab_is_cm
 @
 <<PHS base: phs: TBP>>=
   procedure :: get_n_tot => phs_get_n_tot
 <<PHS base: sub interfaces>>=
     elemental module function phs_get_n_tot (phs) result (n_tot)
       integer :: n_tot
       class(phs_t), intent(in) :: phs
     end function phs_get_n_tot
 <<PHS base: procedures>>=
   elemental module 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: sub interfaces>>=
     module subroutine phs_set_lorentz_transformation (phs, lt)
       class(phs_t), intent(inout) :: phs
       type(lorentz_transformation_t), intent(in) :: lt
     end subroutine phs_set_lorentz_transformation
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_get_lorentz_transformation (phs) result (lt)
       type(lorentz_transformation_t) :: lt
       class(phs_t), intent(in) :: phs
     end function phs_get_lorentz_transformation
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_get_mcpar (phs, c, r)
       class(phs_t), intent(in) :: phs
       integer, intent(in) :: c
       real(default), dimension(:), intent(out) :: r
     end subroutine phs_get_mcpar
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_get_f (phs, c) result (f)
       class(phs_t), intent(in) :: phs
       integer, intent(in) :: c
       real(default) :: f
     end function phs_get_f
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_get_overall_factor (phs) result (f)
       class(phs_t), intent(in) :: phs
       real(default) :: f
     end function phs_get_overall_factor
 <<PHS base: procedures>>=
   module 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
   procedure :: compute_base_flux => phs_compute_flux
 <<PHS base: sub interfaces>>=
     module subroutine phs_compute_flux (phs)
       class(phs_t), intent(inout) :: phs
     end subroutine phs_compute_flux
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module function phs_get_sqrts (phs) result (sqrts)
       real(default) :: sqrts
       class(phs_t), intent(in) :: phs
     end function phs_get_sqrts
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine compute_kinematics_solid_angle
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine inverse_kinematics_solid_angle
 <<PHS base: procedures>>=
   module 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: sub interfaces>>=
     module subroutine pacify_phs (phs)
       class(phs_t), intent(inout) :: phs
     end subroutine pacify_phs
 <<PHS base: procedures>>=
   module 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 [[lab_is_cm]] 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, lab_is_cm, 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 :: lab_is_cm
     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 (lab_is_cm)) then
        phs_config%lab_is_cm = lab_is_cm
     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 phs_base, only: phs_config_t, phs_t
 
 <<Standard module head>>
 
 <<PHS none: public>>
 
 <<PHS none: types>>
 
   interface
 <<PHS none: sub interfaces>>
   end interface
 
 contains
 
 <<PHS none: main procedures>>
 
 end module phs_none
 @ %def phs_none
 @
 <<[[phs_none_sub.f90]]>>=
 <<File header>>
 
 submodule (phs_none) phs_none_s
 
   use io_units, only: given_output_unit
   use diagnostics, only: msg_message, msg_fatal
 
   implicit none
 
 contains
 
 <<PHS none: procedures>>
 
 end submodule phs_none_s
 
 @ %def phs_none_s
 @
 \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: sub interfaces>>=
     module subroutine phs_none_config_final (object)
       class(phs_none_config_t), intent(inout) :: object
     end subroutine phs_none_config_final
 <<PHS none: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_none_config_write
 <<PHS none: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_none_config_configure (phs_config, sqrts, &
          sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
       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
 <<PHS none: procedures>>=
   module subroutine phs_none_config_configure (phs_config, sqrts, &
        sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
     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: sub interfaces>>=
     module subroutine phs_none_config_startup_message (phs_config, unit)
       class(phs_none_config_t), intent(in) :: phs_config
       integer, intent(in), optional :: unit
     end subroutine phs_none_config_startup_message
 <<PHS none: procedures>>=
   module 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.
 Gfortran 7/8/9 bug: has to remain in the main module.
 <<PHS none: phs none config: TBP>>=
   procedure, nopass :: allocate_instance => phs_none_config_allocate_instance
 <<PHS none: main 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: sub interfaces>>=
     module subroutine phs_none_write (object, unit, verbose)
       class(phs_none_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine phs_none_write
 <<PHS none: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_none_final (object)
       class(phs_none_t), intent(inout) :: object
     end subroutine phs_none_final
 <<PHS none: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_none_init (phs, phs_config)
       class(phs_none_t), intent(out) :: phs
       class(phs_config_t), intent(in), target :: phs_config
     end subroutine phs_none_init
 <<PHS none: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_none_evaluate_selected_channel
     module 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
 <<PHS none: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     module subroutine phs_none_inverse (phs)
       class(phs_none_t), intent(inout) :: phs
     end subroutine phs_none_inverse
 <<PHS none: procedures>>=
   module 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 lorentz
   use phs_base
 
 <<Standard module head>>
 
 <<PHS single: public>>
 
 <<PHS single: types>>
 
   interface
 <<PHS single: sub interfaces>>
   end interface
 
 contains
 
 <<PHS single: main procedures>>
 
 end module phs_single
 @ %def phs_single
 @
 <<[[phs_single_sub.f90]]>>=
 <<File header>>
 
 submodule (phs_single) phs_single_s
 
   use io_units
   use constants
   use numeric_utils
   use diagnostics
   use physics_defs
 
   implicit none
 
 contains
 
 <<PHS single: procedures>>
 
 end submodule phs_single_s
 
 @ %def phs_single_s
 @
 \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: sub interfaces>>=
     module subroutine phs_single_config_final (object)
       class(phs_single_config_t), intent(inout) :: object
     end subroutine phs_single_config_final
 <<PHS single: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_single_config_write
 <<PHS single: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_single_config_configure (phs_config, sqrts, &
          sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
       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_single_config_configure
 <<PHS single: procedures>>=
   module subroutine phs_single_config_configure (phs_config, sqrts, &
        sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
     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 (lab_is_cm))  phs_config%lab_is_cm = lab_is_cm
        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: sub interfaces>>=
     module subroutine phs_single_config_startup_message (phs_config, unit)
       class(phs_single_config_t), intent(in) :: phs_config
       integer, intent(in), optional :: unit
     end subroutine phs_single_config_startup_message
 <<PHS single: procedures>>=
   module 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.
 Gfortran 7/8/9 bug, has to remain in the main module.
 <<PHS single: phs single config: TBP>>=
   procedure, nopass :: allocate_instance => phs_single_config_allocate_instance
 <<PHS single: main 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: sub interfaces>>=
     module subroutine phs_single_write (object, unit, verbose)
       class(phs_single_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine phs_single_write
 <<PHS single: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_single_final (object)
       class(phs_single_t), intent(inout) :: object
     end subroutine phs_single_final
 <<PHS single: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_single_init (phs, phs_config)
       class(phs_single_t), intent(out) :: phs
       class(phs_config_t), intent(in), target :: phs_config
     end subroutine phs_single_init
 <<PHS single: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_single_compute_factor (phs)
       class(phs_single_t), intent(inout) :: phs
     end subroutine phs_single_compute_factor
 <<PHS single: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_single_evaluate_selected_channel
     module 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
 <<PHS single: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     module function phs_single_decay_p (phs) result (p)
       class(phs_single_t), intent(in) :: phs
       type(vector4_t), dimension(2) :: p
     end function phs_single_decay_p
 <<PHS single: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_single_inverse (phs)
       class(phs_single_t), intent(inout) :: phs
     end subroutine phs_single_inverse
 <<PHS single: procedures>>=
   module 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, lab_is_cm=.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 lorentz
   use phs_base
 
 <<Standard module head>>
 
 <<PHS rambo: types>>
 
 <<PHS rambo: public>>
 
   interface
 <<PHS rambo: sub interfaces>>
   end interface
 
 contains
 
 <<PHS rambo: main procedures>>
 
 end module phs_rambo
 @ %def phs_rambo
 @
 <<[[phs_rambo_sub.f90]]>>=
 <<File header>>
 
 submodule (phs_rambo) phs_rambo_s
 
   use io_units
   use constants
   use numeric_utils
   use format_defs, only: FMT_19
   use permutations, only: factorial
   use diagnostics
   use physics_defs
 
   implicit none
 
 <<PHS rambo: parameters>>
 
 contains
 
 <<PHS rambo: procedures>>
 
 end submodule phs_rambo_s
 
 @ %def phs_rambo_s
 @
 \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: sub interfaces>>=
     module subroutine phs_rambo_config_final (object)
       class(phs_rambo_config_t), intent(inout) :: object
     end subroutine phs_rambo_config_final
 <<PHS rambo: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_rambo_config_write
 <<PHS rambo: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_rambo_config_configure (phs_config, sqrts, &
          sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
       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_rambo_config_configure
 <<PHS rambo: procedures>>=
   module subroutine phs_rambo_config_configure (phs_config, sqrts, &
        sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
     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 (lab_is_cm))  phs_config%lab_is_cm = lab_is_cm
     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: sub interfaces>>=
     module subroutine phs_rambo_config_startup_message (phs_config, unit)
       class(phs_rambo_config_t), intent(in) :: phs_config
       integer, intent(in), optional :: unit
     end subroutine phs_rambo_config_startup_message
 <<PHS rambo: procedures>>=
   module 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.
 Gfortran 7/8/9 bug, has to remain in the main module.
 <<PHS rambo: phs rambo config: TBP>>=
   procedure, nopass :: allocate_instance => phs_rambo_config_allocate_instance
 <<PHS rambo: main 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: sub interfaces>>=
     module subroutine phs_rambo_write (object, unit, verbose)
       class(phs_rambo_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine phs_rambo_write
 <<PHS rambo: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_rambo_final (object)
       class(phs_rambo_t), intent(inout) :: object
     end subroutine phs_rambo_final
 <<PHS rambo: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_rambo_init (phs, phs_config)
       class(phs_rambo_t), intent(out) :: phs
       class(phs_config_t), intent(in), target :: phs_config
     end subroutine phs_rambo_init
 <<PHS rambo: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_rambo_evaluate_selected_channel
     module 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
 <<PHS rambo: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_rambo_decay_intermediate
 <<PHS rambo: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_rambo_generate_intermediates (phs, r)
       class(phs_rambo_t), intent(inout) :: phs
       real(default), dimension(:), intent(in) :: r
     end subroutine phs_rambo_generate_intermediates
     module subroutine phs_rambo_invert_intermediates (phs)
       class(phs_rambo_t), intent(inout) :: phs
     end subroutine phs_rambo_invert_intermediates
 <<PHS rambo: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     module subroutine phs_rambo_inverse (phs)
       class(phs_rambo_t), intent(inout) :: phs
     end subroutine phs_rambo_inverse
 <<PHS rambo: procedures>>=
   module 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, lab_is_cm=.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 lorentz
   use model_data, only: model_data_t
   use flavors, only: flavor_t
 
 <<Standard module head>>
 
 <<Resonances: public>>
 
 <<Resonances: parameters>>
 
 <<Resonances: types>>
 
   interface
 <<Resonances: sub interfaces>>
   end interface
 
 end module resonances
 @ %def resonances
 @
 <<[[resonances_sub.f90]]>>=
 <<File header>>
 
 submodule (resonances) resonances_s
 
 <<Use debug>>
   use string_utils, only: str
   use format_utils, only: write_indent
   use constants, only: one
   use io_units
   use diagnostics
 
   implicit none
 
 contains
 
 <<Resonances: procedures>>
 
 end submodule resonances_s
 
 @ %def resonances_s
 @
 \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: sub interfaces>>=
     elemental module function resonance_contributors_equal &
          (c1, c2) result (equal)
       logical :: equal
       class(resonance_contributors_t), intent(in) :: c1, c2
     end function resonance_contributors_equal
 <<Resonances: procedures>>=
   elemental module 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: sub interfaces>>=
     pure module subroutine resonance_contributors_assign &
          (contributors_out, contributors_in)
       class(resonance_contributors_t), intent(inout) :: contributors_out
       class(resonance_contributors_t), intent(in) :: contributors_in
     end subroutine resonance_contributors_assign
 <<Resonances: procedures>>=
   pure module 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: sub interfaces>>=
     module subroutine resonance_info_copy (resonance_in, resonance_out)
       class(resonance_info_t), intent(in) :: resonance_in
       type(resonance_info_t), intent(out) :: resonance_out
     end subroutine resonance_info_copy
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module subroutine resonance_info_write (resonance, unit, verbose)
       class(resonance_info_t), intent(in) :: resonance
       integer, optional, intent(in) :: unit
       logical, optional, intent(in) :: verbose
     end subroutine resonance_info_write
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_info_init_pdg
     module 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
     end subroutine resonance_info_init_flv
 <<Resonances: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     elemental module function resonance_info_equal (r1, r2) result (equal)
       logical :: equal
       class(resonance_info_t), intent(in) :: r1, r2
     end function resonance_info_equal
 <<Resonances: procedures>>=
   elemental module 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: sub interfaces>>=
     module function resonance_info_mapping (resonance, s) result (bw)
       real(default) :: bw
       class(resonance_info_t), intent(in) :: resonance
       real(default), intent(in) :: s
     end function resonance_info_mapping
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     elemental module function resonance_info_get_n_contributors &
          (resonance) result (n)
       class(resonance_info_t), intent(in) :: resonance
       integer :: n
     end function resonance_info_get_n_contributors
     elemental module function resonance_info_contains &
          (resonance, c) result (flag)
       class(resonance_info_t), intent(in) :: resonance
       integer, intent(in) :: c
       logical :: flag
     end function resonance_info_contains
 <<Resonances: procedures>>=
   elemental module 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 module 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: sub interfaces>>=
     module subroutine resonance_history_clear (res_hist)
       class(resonance_history_t), intent(out) :: res_hist
     end subroutine resonance_history_clear
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_copy
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_write
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_assign
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     elemental module function resonance_history_equal (rh1, rh2) result (equal)
       logical :: equal
       class(resonance_history_t), intent(in) :: rh1, rh2
     end function resonance_history_equal
 <<Resonances: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module function resonance_history_contains &
          (rh1, rh2) result (flag)
       logical :: flag
       class(resonance_history_t), intent(in) :: rh1, rh2
     end function resonance_history_contains
 <<Resonances: procedures>>=
   elemental module 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: sub interfaces>>=
     module subroutine resonance_history_add_resonance (res_hist, resonance)
       class(resonance_history_t), intent(inout) :: res_hist
       type(resonance_info_t), intent(in) :: resonance
     end subroutine resonance_history_add_resonance
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module subroutine resonance_history_remove_resonance (res_hist, i_res)
       class(resonance_history_t), intent(inout) :: res_hist
       integer, intent(in) :: i_res
     end subroutine resonance_history_remove_resonance
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module subroutine resonance_history_add_offset (res_hist, n)
       class(resonance_history_t), intent(inout) :: res_hist
       integer, intent(in) :: n
     end subroutine resonance_history_add_offset
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_history_contains_leg
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_history_mapping
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_history_only_has_n_contributors
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_history_has_flavor
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_info_evaluate_distance
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_evaluate_distances
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_info_evaluate_gaussian
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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) :: factor
     end function resonance_history_evaluate_gaussian
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_info_is_on_shell
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_history_is_on_shell
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_info_as_omega_string
     module 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
     end function resonance_history_as_omega_string
 <<Resonances: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     module subroutine resonance_tree_write (tree, unit, indent)
       class(resonance_tree_t), intent(in) :: tree
       integer, intent(in), optional :: unit, indent
     end subroutine resonance_tree_write
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module function resonance_tree_get_n_resonances (tree) result (n)
       class(resonance_tree_t), intent(in) :: tree
       integer :: n
     end function resonance_tree_get_n_resonances
     module function resonance_tree_get_flv (tree, i) result (flv)
       class(resonance_tree_t), intent(in) :: tree
       integer, intent(in) :: i
       type(flavor_t) :: flv
     end function resonance_tree_get_flv
 <<Resonances: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     module 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
     end function resonance_tree_get_children
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module subroutine resonance_history_to_tree (res_hist, tree)
       class(resonance_history_t), intent(in) :: res_hist
       type(resonance_tree_t), intent(out) :: tree
     end subroutine resonance_history_to_tree
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_set_write
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_set_init
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_set_enter
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module subroutine resonance_history_set_freeze (res_set)
       class(resonance_history_set_t), intent(inout) :: res_set
     end subroutine resonance_history_set_freeze
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_set_determine_on_shell_histories
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_history_set_evaluate_gaussian
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module function resonance_history_set_get_n_history (res_set) result (n)
       class(resonance_history_set_t), intent(in) :: res_set
       integer :: n
     end function resonance_history_set_get_n_history
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function resonance_history_set_get_history
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_set_to_array
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine resonance_history_set_get_tree
 <<Resonances: procedures>>=
   module 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: sub interfaces>>=
     module subroutine resonance_history_set_expand (res_set)
       class(resonance_history_set_t), intent(inout) :: res_set
     end subroutine resonance_history_set_expand
 <<Resonances: procedures>>=
   module 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 model_data
   use flavors
 
 <<Standard module head>>
 
 <<Mappings: public>>
 
 <<Mappings: parameters>>
 
 <<Mappings: types>>
 
 <<Mappings: interfaces>>
 
   interface
 <<Mappings: sub interfaces>>
   end interface
 
 end module mappings
 @ %def mappings
 @
 <<[[mappings_sub.f90]]>>=
 <<File header>>
 
 submodule (mappings) mappings_s
 
   use io_units
   use constants, only: pi
   use format_defs, only: FMT_19
   use diagnostics
   use md5
 
   implicit none
 
 contains
 
 <<Mappings: procedures>>
 
 end submodule mappings_s
 
 @ %def mappings_s
 @
 \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: sub interfaces>>=
     module subroutine mapping_defaults_write (object, unit)
       class(mapping_defaults_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine mapping_defaults_write
 <<Mappings: procedures>>=
   module 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: sub interfaces>>=
     module function mapping_defaults_md5sum &
          (mapping_defaults) result (md5sum_map)
       character(32) :: md5sum_map
       type(mapping_defaults_t), intent(in) :: mapping_defaults
     end function mapping_defaults_md5sum
 <<Mappings: procedures>>=
   module 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: mapping: TBP>>=
   procedure :: write => mapping_write
 <<Mappings: sub interfaces>>=
     module subroutine mapping_write (map, unit, verbose)
       class(mapping_t), intent(in) :: map
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine mapping_write
 <<Mappings: procedures>>=
   module subroutine mapping_write (map, unit, verbose)
     class(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: mapping: TBP>>=
   procedure :: init => mapping_init
 <<Mappings: sub interfaces>>=
     module subroutine mapping_init (mapping, bincode, type, f, model)
       class(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
     end subroutine mapping_init
 <<Mappings: procedures>>=
   module subroutine mapping_init (mapping, bincode, type, f, model)
     class(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: mapping: TBP>>=
   procedure :: set_parameters => mapping_set_parameters
 <<Mappings: sub interfaces>>=
     module subroutine mapping_set_parameters &
          (map, mapping_defaults, variable_limits)
       class(mapping_t), intent(inout) :: map
       type(mapping_defaults_t), intent(in) :: mapping_defaults
       logical, intent(in) :: variable_limits
     end subroutine mapping_set_parameters
 <<Mappings: procedures>>=
   module subroutine mapping_set_parameters &
        (map, mapping_defaults, variable_limits)
     class(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 map%write ()
              call msg_fatal &
                   & (" S-channel resonance must have positive mass")
           else if (map%width <= 0) then
              call map%write ()
              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: mapping: TBP>>=
   procedure :: set_step_mapping_parameters => &
        mapping_set_step_mapping_parameters
 <<Mappings: sub interfaces>>=
     module subroutine mapping_set_step_mapping_parameters (map, &
          mass, width, variable_limits)
       class(mapping_t), intent(inout) :: map
       real(default), intent(in) :: mass, width
       logical, intent(in) :: variable_limits
     end subroutine mapping_set_step_mapping_parameters
 <<Mappings: procedures>>=
   module subroutine mapping_set_step_mapping_parameters (map, &
        mass, width, variable_limits)
     class(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: 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: sub interfaces>>=
   module function mapping_is_set (mapping) result (flag)
     class(mapping_t), intent(in) :: mapping
     logical :: flag
   end function mapping_is_set
   module function mapping_is_s_channel (mapping) result (flag)
     class(mapping_t), intent(in) :: mapping
     logical :: flag
   end function mapping_is_s_channel
   module function mapping_is_on_shell (mapping) result (flag)
     class(mapping_t), intent(in) :: mapping
     logical :: flag
   end function mapping_is_on_shell
 <<Mappings: procedures>>=
   module 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
 
   module 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
 
   module 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: sub interfaces>>=
     module function mapping_get_bincode (mapping) result (bincode)
       class(mapping_t), intent(in) :: mapping
       integer(TC) :: bincode
     end function mapping_get_bincode
 <<Mappings: procedures>>=
   module 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: sub interfaces>>=
     module function mapping_get_flv (mapping) result (flv)
       class(mapping_t), intent(in) :: mapping
       type(flavor_t) :: flv
     end function mapping_get_flv
 <<Mappings: procedures>>=
   module 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: mapping: TBP>>=
   procedure :: get_mass => mapping_get_mass
   procedure :: get_width => mapping_get_width
 <<Mappings: sub interfaces>>=
     module function mapping_get_mass (mapping) result (mass)
       class(mapping_t), intent(in) :: mapping
       real(default) :: mass
     end function mapping_get_mass
     module function mapping_get_width (mapping) result (width)
       class(mapping_t), intent(in) :: mapping
       real(default) :: width
     end function mapping_get_width
 <<Mappings: procedures>>=
   module function mapping_get_mass (mapping) result (mass)
     class(mapping_t), intent(in) :: mapping
     real(default) :: mass
     mass = mapping%mass
   end function mapping_get_mass
 
   module function mapping_get_width (mapping) result (width)
     class(mapping_t), intent(in) :: mapping
     real(default) :: width
     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: sub interfaces>>=
     module function mapping_equal (m1, m2) result (equal)
       type(mapping_t), intent(in) :: m1, m2
       logical :: equal
     end function mapping_equal
 <<Mappings: procedures>>=
   module 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: mapping: TBP>>=
   procedure :: compute_msq_from_x => mapping_compute_msq_from_x
 <<Mappings: sub interfaces>>=
     module subroutine mapping_compute_msq_from_x &
          (map, s, msq_min, msq_max, msq, f, x)
       class(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
     end subroutine mapping_compute_msq_from_x
 <<Mappings: procedures>>=
   module subroutine mapping_compute_msq_from_x &
        (map, s, msq_min, msq_max, msq, f, x)
     class(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: mapping: TBP>>=
   procedure :: compute_x_from_msq => mapping_compute_x_from_msq
 <<Mappings: sub interfaces>>=
     module subroutine mapping_compute_x_from_msq &
          (map, s, msq_min, msq_max, msq, f, x)
       class(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
     end subroutine mapping_compute_x_from_msq
 <<Mappings: procedures>>=
   module subroutine mapping_compute_x_from_msq &
        (map, s, msq_min, msq_max, msq, f, x)
     class(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: mapping: TBP>>=
   procedure :: compute_ct_from_x => mapping_compute_ct_from_x
 <<Mappings: sub interfaces>>=
     module subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x)
       class(mapping_t), intent(inout) :: map
       real(default), intent(in) :: s
       real(default), intent(out) :: ct, st, f
       real(default), intent(in) :: x
     end subroutine mapping_compute_ct_from_x
 <<Mappings: procedures>>=
   module subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x)
     class(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: mapping: TBP>>=
   procedure :: compute_x_from_ct => mapping_compute_x_from_ct
 <<Mappings: sub interfaces>>=
     module subroutine mapping_compute_x_from_ct (map, s, ct, f, x)
       class(mapping_t), intent(inout) :: map
       real(default), intent(in) :: s
       real(default), intent(in) :: ct
       real(default), intent(out) :: f, x
     end subroutine mapping_compute_x_from_ct
 <<Mappings: procedures>>=
   module subroutine mapping_compute_x_from_ct (map, s, ct, f, x)
     class(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 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>>
 
   interface
 <<PHS trees: sub interfaces>>
   end interface
 
 end module phs_trees
 @ %def phs_trees
 @
 <<[[phs_trees_sub.f90]]>>=
 <<File header>>
 
 submodule (phs_trees) phs_trees_s
 
   use io_units
   use constants, only: twopi, twopi2, twopi5
   use format_defs, only: FMT_19
   use numeric_utils, only: vanishes
   use diagnostics
 
   implicit none
 
 contains
 
 <<PHS trees: procedures>>
 
 end submodule phs_trees_s
 
 @ %def phs_trees_s
 @
 \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
    contains
    <<PHS trees: prt: TBP>>
   end type phs_prt_t
 
 @ %def phs_prt_t
 @ Set contents:
 <<PHS trees: prt: TBP>>=
   procedure :: set_defined => phs_prt_set_defined
   procedure :: set_undefined => phs_prt_set_undefined
   procedure :: set_momentum => phs_prt_set_momentum
   procedure :: set_msq => phs_prt_set_msq
 <<PHS trees: sub interfaces>>=
     elemental module subroutine phs_prt_set_defined (prt)
       class(phs_prt_t), intent(inout) :: prt
     end subroutine phs_prt_set_defined
     elemental module subroutine phs_prt_set_undefined (prt)
       class(phs_prt_t), intent(inout) :: prt
     end subroutine phs_prt_set_undefined
     elemental module subroutine phs_prt_set_momentum (prt, p)
       class(phs_prt_t), intent(inout) :: prt
       type(vector4_t), intent(in) :: p
     end subroutine phs_prt_set_momentum
     elemental module subroutine phs_prt_set_msq (prt, p2)
       class(phs_prt_t), intent(inout) :: prt
       real(default), intent(in) :: p2
     end subroutine phs_prt_set_msq
 <<PHS trees: procedures>>=
   elemental module subroutine phs_prt_set_defined (prt)
     class(phs_prt_t), intent(inout) :: prt
     prt%defined = .true.
   end subroutine phs_prt_set_defined
 
   elemental module subroutine phs_prt_set_undefined (prt)
     class(phs_prt_t), intent(inout) :: prt
     prt%defined = .false.
   end subroutine phs_prt_set_undefined
 
   elemental module subroutine phs_prt_set_momentum (prt, p)
     class(phs_prt_t), intent(inout) :: prt
     type(vector4_t), intent(in) :: p
     prt%p = p
   end subroutine phs_prt_set_momentum
 
   elemental module subroutine phs_prt_set_msq (prt, p2)
     class(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: prt: TBP>>=
   procedure :: is_defined => phs_prt_is_defined
   procedure :: get_momentum => phs_prt_get_momentum
   procedure :: get_msq => phs_prt_get_msq
 <<PHS trees: sub interfaces>>=
     elemental module function phs_prt_is_defined (prt) result (defined)
       logical :: defined
       class(phs_prt_t), intent(in) :: prt
     end function phs_prt_is_defined
     elemental module function phs_prt_get_momentum (prt) result (p)
       type(vector4_t) :: p
       class(phs_prt_t), intent(in) :: prt
     end function phs_prt_get_momentum
     elemental module function phs_prt_get_msq (prt) result (p2)
       real(default) :: p2
       class(phs_prt_t), intent(in) :: prt
     end function phs_prt_get_msq
 <<PHS trees: procedures>>=
   elemental module function phs_prt_is_defined (prt) result (defined)
     logical :: defined
     class(phs_prt_t), intent(in) :: prt
     defined = prt%defined
   end function phs_prt_is_defined
 
   elemental module function phs_prt_get_momentum (prt) result (p)
     type(vector4_t) :: p
     class(phs_prt_t), intent(in) :: prt
     p = prt%p
   end function phs_prt_get_momentum
 
   elemental module function phs_prt_get_msq (prt) result (p2)
     real(default) :: p2
     class(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: prt: TBP>>=
   procedure :: combine => phs_prt_combine
 <<PHS trees: sub interfaces>>=
     elemental module subroutine phs_prt_combine (prt, prt1, prt2)
       class(phs_prt_t), intent(inout) :: prt
       type(phs_prt_t), intent(in) :: prt1, prt2
     end subroutine phs_prt_combine
 <<PHS trees: procedures>>=
   elemental module subroutine phs_prt_combine (prt, prt1, prt2)
     class(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: prt: TBP>>=
   procedure :: write => phs_prt_write
 <<PHS trees: sub interfaces>>=
     module subroutine phs_prt_write (prt, unit)
       class(phs_prt_t), intent(in) :: prt
       integer, intent(in), optional :: unit
     end subroutine phs_prt_write
 <<PHS trees: procedures>>=
   module subroutine phs_prt_write (prt, unit)
     class(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: prt: TBP>>=
   procedure :: check => phs_prt_check
 <<PHS trees: sub interfaces>>=
     elemental module subroutine phs_prt_check (prt)
       class(phs_prt_t), intent(inout) :: prt
     end subroutine phs_prt_check
 <<PHS trees: procedures>>=
   elemental module subroutine phs_prt_check (prt)
     class(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$.
 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: sub interfaces>>=
     elemental module 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
     end subroutine phs_tree_init
     elemental module subroutine phs_tree_final (tree)
       class(phs_tree_t), intent(inout) :: tree
     end subroutine phs_tree_final
 <<PHS trees: procedures>>=
   elemental module 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 module 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: phs tree: TBP>>=
   procedure :: write => phs_tree_write
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_write (tree, unit)
       class(phs_tree_t), intent(in) :: tree
       integer, intent(in), optional :: unit
     end subroutine phs_tree_write
 <<PHS trees: procedures>>=
   module 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 tree%mapping (k)%write (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: sub interfaces>>=
     module subroutine phs_tree_from_array (tree, a)
       class(phs_tree_t), intent(inout) :: tree
       integer(TC), dimension(:), intent(in) :: a
     end subroutine phs_tree_from_array
 <<PHS trees: procedures>>=
   module 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: phs tree: TBP>>=
   procedure :: flip_t_to_s_channel => phs_tree_flip_t_to_s_channel
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_flip_t_to_s_channel (tree)
       class(phs_tree_t), intent(inout) :: tree
     end subroutine phs_tree_flip_t_to_s_channel
 <<PHS trees: procedures>>=
   module subroutine phs_tree_flip_t_to_s_channel (tree)
     class(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: phs tree: TBP>>=
   procedure :: canonicalize => phs_tree_canonicalize
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_canonicalize (tree)
       class(phs_tree_t), intent(inout) :: tree
     end subroutine phs_tree_canonicalize
 <<PHS trees: procedures>>=
   module subroutine phs_tree_canonicalize (tree)
     class(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: phs tree: TBP>>=
   procedure :: init_mapping => phs_tree_init_mapping
 <<PHS trees: sub interfaces>>=
     module 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
     end subroutine phs_tree_init_mapping
 <<PHS trees: procedures>>=
   module 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 tree%mapping(kk)%init (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: phs tree: TBP>>=
   procedure :: set_mapping_parameters => phs_tree_set_mapping_parameters
 <<PHS trees: sub interfaces>>=
     module 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
     end subroutine phs_tree_set_mapping_parameters
 <<PHS trees: procedures>>=
   module 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 tree%mapping(k)%set_parameters (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: phs tree: TBP>>=
   procedure :: assign_s_mapping => phs_tree_assign_s_mapping
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_assign_s_mapping (tree, mapping)
       class(phs_tree_t), intent(in) :: tree
       type(mapping_t), intent(out) :: mapping
     end subroutine phs_tree_assign_s_mapping
 <<PHS trees: procedures>>=
   module subroutine phs_tree_assign_s_mapping (tree, mapping)
     class(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: phs tree: TBP>>=
   procedure :: set_mass_sum => phs_tree_set_mass_sum
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_set_mass_sum (tree, flv)
       class(phs_tree_t), intent(inout) :: tree
       type(flavor_t), dimension(:), intent(in) :: flv
     end subroutine phs_tree_set_mass_sum
 <<PHS trees: procedures>>=
   module 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: phs tree: TBP>>=
   procedure :: set_effective_masses => phs_tree_set_effective_masses
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_set_effective_masses (tree)
       class(phs_tree_t), intent(inout) :: tree
     end subroutine phs_tree_set_effective_masses
 <<PHS trees: procedures>>=
   module 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 (tree%mapping(k)%is_s_channel ()) then
             tree%effective_mass(k) = tree%mapping(k)%get_mass ()
             tree%effective_width(k) = tree%mapping(k)%get_width ()
          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: phs tree: TBP>>=
   procedure :: set_step_mappings => phs_tree_set_step_mappings
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_set_step_mappings &
          (tree, exp_type, variable_limits)
       class(phs_tree_t), intent(inout) :: tree
       logical, intent(in) :: exp_type
       logical, intent(in) :: variable_limits
     end subroutine phs_tree_set_step_mappings
 <<PHS trees: procedures>>=
   module subroutine phs_tree_set_step_mappings &
        (tree, exp_type, variable_limits)
     class(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. tree%mapping(k)%is_set ()) then
                call tree%mapping(k)%init (k, map_str)
                call tree%mapping(k)%set_step_mapping_parameters (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 (tree%mapping(k)%is_s_channel ()) then
             call set_step_mappings_x (kk(1), &
                  tree%mapping(k)%get_mass () - m(2), &
                  tree%mapping(k)%get_width () + w(2))
             call set_step_mappings_x (kk(2), &
                  tree%mapping(k)%get_mass () - m(1), &
                  tree%mapping(k)%get_width () + 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: sub interfaces>>=
     module subroutine phs_tree_extract_resonance_history (tree, res_history)
       class(phs_tree_t), intent(in) :: tree
       type(resonance_history_t), intent(out) :: res_history
     end subroutine phs_tree_extract_resonance_history
 <<PHS trees: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function phs_tree_equivalent
 <<PHS trees: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_tree_find_msq_permutation
 <<PHS trees: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_tree_find_angle_permutation
 <<PHS trees: procedures>>=
   module 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: phs tree: TBP>>=
   procedure :: compute_volume => phs_tree_compute_volume
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_compute_volume (tree, sqrts, volume)
       class(phs_tree_t), intent(in) :: tree
       real(default), intent(in) :: sqrts
       real(default), intent(out) :: volume
     end subroutine phs_tree_compute_volume
 <<PHS trees: procedures>>=
   module subroutine phs_tree_compute_volume (tree, sqrts, volume)
     class(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: phs tree: TBP>>=
   procedure :: compute_momenta_from_x => phs_tree_compute_momenta_from_x
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_compute_momenta_from_x &
          (tree, prt, factor, volume, sqrts, x, ok)
       class(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
     end subroutine phs_tree_compute_momenta_from_x
 <<PHS trees: procedures>>=
   module subroutine phs_tree_compute_momenta_from_x &
        (tree, prt, factor, volume, sqrts, x, ok)
     class(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 tree%mapping(k)%compute_msq_from_x (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 prt(k)%set_msq (msq)
             call prt(k)%set_defined ()
          else
             ok = .false.
          end if
       end if
       if (ok) then
          msq1 = prt(k1)%get_msq ();  m1 = sqrt (msq1)
          msq2 = prt(k2)%get_msq ();  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 = prt(k)%get_msq ();  m = sqrt (msq)
       E = sqrt (msq + p**2)
       if (present (L0)) then
          call prt(k)%set_momentum (L0 * vector4_moving (E,p,3))
       else
          call prt(k)%set_momentum (vector4_moving (E,p,3))
       end if
       call prt(k)%set_defined ()
       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 tree%mapping(k)%compute_ct_from_x (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 * prt(tree%branch(k)%friend)%get_momentum () )
             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: phs tree: TBP>>=
   procedure :: compute_x_from_momenta => phs_tree_compute_x_from_momenta
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_compute_x_from_momenta &
          (tree, prt, factor, sqrts, x)
       class(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
     end subroutine phs_tree_compute_x_from_momenta
 <<PHS trees: procedures>>=
   module subroutine phs_tree_compute_x_from_momenta &
        (tree, prt, factor, sqrts, x)
     class(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 = prt(k)%get_msq ();  m = sqrt (msq)
       if (initial) then
          factor = f1 * f2
       else
          call tree%mapping(k)%compute_x_from_msq (sqrts**2, m_min**2, &
               m_max**2, msq, factor, x(ix));  ix = ix + 1
          factor = f1 * f2 * factor
       end if
       msq1 = prt(k1)%get_msq ()
       msq2 = prt(k2)%get_msq ()
       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 * prt(k1)%get_momentum ()
          if (has_friend)  pf = L0 * prt(kf)%get_momentum ()
       else
          p1 = prt(k1)%get_momentum ()
          if (has_friend)  pf = prt(kf)%get_momentum ()
       end if
       if (present(phi0)) then
          cp0 = cos (phi0)
          sp0 = sin (phi0)
       end if
       msq = prt(k)%get_msq ();  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 tree%mapping(k)%compute_x_from_ct (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: sub interfaces>>=
     module subroutine phs_tree_combine_particles (tree, prt)
       type(phs_tree_t), intent(in) :: tree
       type(phs_prt_t), dimension(:), intent(inout) :: prt
     end subroutine phs_tree_combine_particles
 <<PHS trees: procedures>>=
   module 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 prt(k)%combine (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: sub interfaces>>=
     module subroutine phs_tree_setup_prt_combinations (tree, comb)
       type(phs_tree_t), intent(in) :: tree
       integer, dimension(:,:), intent(out) :: comb
     end subroutine phs_tree_setup_prt_combinations
 <<PHS trees: procedures>>=
   module 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
 @ JRR: 2022-01-22 [[reshuffle_mappings]] is commented out, and no
 longer used, not clear why?
 <<PHS trees: phs tree: TBP>>=
   procedure :: reshuffle_mappings => phs_tree_reshuffle_mappings
 <<PHS trees: sub interfaces>>=
     module subroutine phs_tree_reshuffle_mappings (tree)
      class(phs_tree_t), intent(inout) :: tree
     end subroutine phs_tree_reshuffle_mappings
 <<PHS trees: procedures>>=
   module subroutine phs_tree_reshuffle_mappings (tree)
    class(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: sub interfaces>>=
     module subroutine phs_tree_set_momentum_links (tree, list)
       type(phs_tree_t), intent(inout) :: tree
       integer, dimension(:), allocatable :: list
     end subroutine phs_tree_set_momentum_links
 <<PHS trees: procedures>>=
   module 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 lorentz
   use permutations
   use syntax_rules
   use parser
   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>>
 
   interface
 <<PHS forests: sub interfaces>>
   end interface
 
 contains
 
 <<PHS forests: main procedures>>
 
 end module phs_forests
 @ %def phs_forests
 @
 <<[[phs_forests_sub.f90]]>>=
 <<File header>>
 
 submodule (phs_forests) phs_forests_s
 
   use io_units
   use format_defs, only: FMT_19
   use diagnostics
   use numeric_utils
   use ifiles
   use lexers
 
   implicit none
 
 contains
 
 <<PHS forests: procedures>>
 
 end submodule phs_forests_s
 
 @ %def phs_forests_s
 @
 \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: sub interfaces>>=
     module subroutine phs_parameters_write (phs_par, unit)
       class(phs_parameters_t), intent(in) :: phs_par
       integer, intent(in), optional :: unit
     end subroutine phs_parameters_write
 <<PHS forests: procedures>>=
   module 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: phs parameters: TBP>>=
   procedure :: read => phs_parameters_read
 <<PHS forests: sub interfaces>>=
     module subroutine phs_parameters_read (phs_par, unit)
       class(phs_parameters_t), intent(out) :: phs_par
       integer, intent(in) :: unit
     end subroutine phs_parameters_read
 <<PHS forests: procedures>>=
   module subroutine phs_parameters_read (phs_par, unit)
     class(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: sub interfaces>>=
     module function phs_parameters_eq (phs_par1, phs_par2) result (equal)
       logical :: equal
       type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
     end function phs_parameters_eq
     module function phs_parameters_ne (phs_par1, phs_par2) result (ne)
       logical :: ne
       type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
     end function phs_parameters_ne
 <<PHS forests: procedures>>=
   module 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
 
   module 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: main 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 grove%tree%init (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. This triggers double free corruption with the Intel
 compiler and hence has to remain in the main module.
 <<PHS forests: interfaces>>=
   interface assignment(=)
      module procedure phs_grove_assign0
      module procedure phs_grove_assign1
   end interface
 
 <<PHS forests: main 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 grove%tree(i)%assign_s_mapping (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: phs forest: TBP>>=
   procedure :: init => phs_forest_init
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_init (forest, n_tree, n_in, n_out)
       class(phs_forest_t), intent(inout) :: forest
       integer, dimension(:), intent(in) :: n_tree
       integer, intent(in) :: n_in, n_out
     end subroutine phs_forest_init
 <<PHS forests: procedures>>=
   module subroutine phs_forest_init (forest, n_tree, n_in, n_out)
     class(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: phs forest: TBP>>=
   procedure :: set_s_mappings => phs_forest_set_s_mappings
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_set_s_mappings (forest)
       class(phs_forest_t), intent(inout) :: forest
     end subroutine phs_forest_set_s_mappings
 <<PHS forests: procedures>>=
   module subroutine phs_forest_set_s_mappings (forest)
     class(phs_forest_t), intent(inout) :: forest
     integer :: g, i0, i1, n
     do g = 1, size (forest%grove)
        call forest%get_grove_bounds (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: phs forest: TBP>>=
   procedure :: final => phs_forest_final
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_final (forest)
       class(phs_forest_t), intent(inout) :: forest
     end subroutine phs_forest_final
 <<PHS forests: procedures>>=
   module subroutine phs_forest_final (forest)
     class(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: phs forest: TBP>>=
   procedure :: write => phs_forest_write
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_write (forest, unit)
       class(phs_forest_t), intent(in) :: forest
       integer, intent(in), optional :: unit
     end subroutine phs_forest_write
 <<PHS forests: procedures>>=
   module 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 () .or. mapping%is_on_shell ()) then
                write (u, "(1x,I0,':',1x)", advance="no")  i
                call forest%s_mapping(i)%write (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 (forest%prt_in%is_defined ())) then
           do i = 1, size (forest%prt_in)
              if (forest%prt_in(i)%is_defined ()) then
                 write (u, "(1x,A,1x,I0)")  "Particle", i
                 call forest%prt_in(i)%write (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 (forest%prt_out%is_defined ())) then
           do i = 1, size (forest%prt_out)
              if (forest%prt_out(i)%is_defined ()) then
                 write (u, "(1x,A,1x,I0)")  "Particle", i
                 call forest%prt_out(i)%write (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 (forest%prt%is_defined ())) then
           do i = 1, size (forest%prt)
              if (forest%prt(i)%is_defined ()) then
                 write (u, "(1x,A,1x,I0)")  "Particle", i
                 call forest%prt(i)%write (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 grove%tree(t)%write (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: sub interfaces>>=
     module subroutine phs_forest_assign (forest_out, forest_in)
       type(phs_forest_t), intent(out) :: forest_out
       type(phs_forest_t), intent(in) :: forest_in
     end subroutine phs_forest_assign
 <<PHS forests: procedures>>=
   module 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: phs forest: TBP>>=
   procedure :: get_n_parameters => phs_forest_get_n_parameters
 <<PHS forests: sub interfaces>>=
     module function phs_forest_get_n_parameters (forest) result (n)
       integer :: n
       class(phs_forest_t), intent(in) :: forest
     end function phs_forest_get_n_parameters
 <<PHS forests: procedures>>=
   module function phs_forest_get_n_parameters (forest) result (n)
     integer :: n
     class(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: phs forest: TBP>>=
   procedure :: get_n_channels => phs_forest_get_n_channels
 <<PHS forests: sub interfaces>>=
     module function phs_forest_get_n_channels (forest) result (n)
       integer :: n
       class(phs_forest_t), intent(in) :: forest
     end function phs_forest_get_n_channels
 <<PHS forests: procedures>>=
   module function phs_forest_get_n_channels (forest) result (n)
     integer :: n
     class(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: phs forest: TBP>>=
   procedure :: get_n_groves => phs_forest_get_n_groves
 <<PHS forests: sub interfaces>>=
     module function phs_forest_get_n_groves (forest) result (n)
       integer :: n
       class(phs_forest_t), intent(in) :: forest
     end function phs_forest_get_n_groves
 <<PHS forests: procedures>>=
   module function phs_forest_get_n_groves (forest) result (n)
     integer :: n
     class(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: phs forest: TBP>>=
   procedure :: get_grove_bounds => phs_forest_get_grove_bounds
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n)
       class(phs_forest_t), intent(in) :: forest
       integer, intent(in) :: g
       integer, intent(out) :: i0, i1, n
     end subroutine phs_forest_get_grove_bounds
 <<PHS forests: procedures>>=
   module subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n)
     class(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: phs forest: TBP>>=
   procedure :: get_n_equivalences => phs_forest_get_n_equivalences
 <<PHS forests: sub interfaces>>=
     module function phs_forest_get_n_equivalences (forest) result (n)
       integer :: n
       class(phs_forest_t), intent(in) :: forest
     end function phs_forest_get_n_equivalences
 <<PHS forests: procedures>>=
   module function phs_forest_get_n_equivalences (forest) result (n)
     integer :: n
     class(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: phs forest: TBP>>=
   procedure :: get_s_mapping => phs_forest_get_s_mapping
   procedure :: get_on_shell => phs_forest_get_on_shell
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_get_s_mapping &
          (forest, channel, flag, mass, width)
       class(phs_forest_t), intent(in) :: forest
       integer, intent(in) :: channel
       logical, intent(out) :: flag
       real(default), intent(out) :: mass, width
     end subroutine phs_forest_get_s_mapping
     module subroutine phs_forest_get_on_shell (forest, channel, flag, mass)
       class(phs_forest_t), intent(in) :: forest
       integer, intent(in) :: channel
       logical, intent(out) :: flag
       real(default), intent(out) :: mass
     end subroutine phs_forest_get_on_shell
 <<PHS forests: procedures>>=
   module subroutine phs_forest_get_s_mapping &
        (forest, channel, flag, mass, width)
     class(phs_forest_t), intent(in) :: forest
     integer, intent(in) :: channel
     logical, intent(out) :: flag
     real(default), intent(out) :: mass, width
     flag = forest%s_mapping(channel)%is_s_channel ()
     if (flag) then
        mass = forest%s_mapping(channel)%get_mass ()
        width = forest%s_mapping(channel)%get_width ()
     else
        mass = 0
        width = 0
     end if
   end subroutine phs_forest_get_s_mapping
 
   module subroutine phs_forest_get_on_shell (forest, channel, flag, mass)
     class(phs_forest_t), intent(in) :: forest
     integer, intent(in) :: channel
     logical, intent(out) :: flag
     real(default), intent(out) :: mass
     flag = forest%s_mapping(channel)%is_on_shell ()
     if (flag) then
        mass = forest%s_mapping(channel)%get_mass ()
     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: sub interfaces>>=
     module 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
     end subroutine phs_forest_extract_resonance_history_set
 <<PHS forests: procedures>>=
   module 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: sub interfaces>>=
     module subroutine syntax_phs_forest_init ()
     end subroutine syntax_phs_forest_init
 <<PHS forests: procedures>>=
   module 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: sub interfaces>>=
     module subroutine syntax_phs_forest_final ()
     end subroutine syntax_phs_forest_final
 <<PHS forests: procedures>>=
   module 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: sub interfaces>>=
     module subroutine syntax_phs_forest_write (unit)
       integer, intent(in), optional :: unit
     end subroutine syntax_phs_forest_write
 <<PHS forests: procedures>>=
   module 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: phs forest: TBP>>=
   generic :: read => read_file, read_unit, read_parse_tree
   procedure :: read_file => phs_forest_read_file
   procedure :: read_unit => phs_forest_read_unit
   procedure :: read_parse_tree => phs_forest_read_parse_tree
 <<PHS forests: sub interfaces>>=
     module 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)
       class(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
     end subroutine phs_forest_read_file
     module 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)
       class(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
     end subroutine phs_forest_read_unit
     module 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)
       class(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
     end subroutine phs_forest_read_parse_tree
 <<PHS forests: procedures>>=
   module 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)
     class(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_parse_tree (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
 
   module 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)
     class(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_parse_tree (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
 
   module 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)
     class(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 forest%init (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 tree%flip_t_to_s_channel ()
     call tree%canonicalize ()
     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 tree%init_mapping (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: phs forest: TBP>>=
   procedure :: set_flavors => phs_forest_set_flavors
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra)
       class(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
     end subroutine phs_forest_set_flavors
 <<PHS forests: procedures>>=
   module subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra)
     class(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: phs forest: TBP>>=
   procedure :: set_momentum_links => phs_forest_set_momentum_links
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_set_momentum_links (forest, list)
       class(phs_forest_t), intent(inout) :: forest
       integer, intent(in), dimension(:), allocatable :: list
     end subroutine phs_forest_set_momentum_links
 <<PHS forests: procedures>>=
   module subroutine phs_forest_set_momentum_links (forest, list)
     class(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 tree%reshuffle_mappings ()
         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: phs forest: TBP>>=
   procedure :: set_parameters => phs_forest_set_parameters
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_set_parameters &
          (forest, mapping_defaults, variable_limits)
       class(phs_forest_t), intent(inout) :: forest
       type(mapping_defaults_t), intent(in) :: mapping_defaults
       logical, intent(in) :: variable_limits
     end subroutine phs_forest_set_parameters
 <<PHS forests: procedures>>=
   module subroutine phs_forest_set_parameters &
        (forest, mapping_defaults, variable_limits)
     class(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 forest%grove(g)%tree(t)%set_mass_sum (forest%flv(forest%n_in+1:))
           call forest%grove(g)%tree(t)%set_mapping_parameters &
                (mapping_defaults, variable_limits)
           call forest%grove(g)%tree(t)%set_effective_masses ()
           if (mapping_defaults%step_mapping) then
              call forest%grove(g)%tree(t)%set_step_mappings &
                   (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: phs forest: TBP>>=
   procedure :: setup_prt_combinations => phs_forest_setup_prt_combinations
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_setup_prt_combinations (forest)
       class(phs_forest_t), intent(inout) :: forest
     end subroutine phs_forest_setup_prt_combinations
 <<PHS forests: procedures>>=
   module subroutine phs_forest_setup_prt_combinations (forest)
     class(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: phs forest: TBP>>=
   generic :: set_prt_in => set_prt_in_int, set_prt_in_mom
   procedure :: set_prt_in_int => phs_forest_set_prt_in_int
   procedure :: set_prt_in_mom => phs_forest_set_prt_in_mom
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab)
       class(phs_forest_t), intent(inout) :: forest
       type(interaction_t), intent(in) :: int
       type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     end subroutine phs_forest_set_prt_in_int
     module subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab)
       class(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
     end subroutine phs_forest_set_prt_in_mom
 <<PHS forests: procedures>>=
   module subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab)
     class(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 forest%prt_in%set_momentum (inverse (lt_cm_to_lab) * &
             int%get_momenta (outgoing=.false.))
     else
        call forest%prt_in%set_momentum (int%get_momenta (outgoing=.false.))
     end if
     associate (m_in => forest%flv(:forest%n_in)%get_mass ())
       call forest%prt_in%set_msq (m_in ** 2)
     end associate
     call forest%prt_in%set_defined ()
   end subroutine phs_forest_set_prt_in_int
 
   module subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab)
     class(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 forest%prt_in%set_momentum (inverse (lt_cm_to_lab) * mom)
     else
        call forest%prt_in%set_momentum (mom)
     end if
     associate (m_in => forest%flv(:forest%n_in)%get_mass ())
       call forest%prt_in%set_msq (m_in ** 2)
     end associate
     call forest%prt_in%set_defined ()
   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: phs forest: TBP>>=
   generic :: set_prt_out => set_prt_out_int, set_prt_out_mom
   procedure :: set_prt_out_int => phs_forest_set_prt_out_int
   procedure :: set_prt_out_mom => phs_forest_set_prt_out_mom
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab)
       class(phs_forest_t), intent(inout) :: forest
       type(interaction_t), intent(in) :: int
       type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     end subroutine phs_forest_set_prt_out_int
     module subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab)
       class(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
     end subroutine phs_forest_set_prt_out_mom
 <<PHS forests: procedures>>=
   module subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab)
     class(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 forest%prt_out%set_momentum (inverse (lt_cm_to_lab) * &
             int%get_momenta (outgoing=.true.))
     else
        call forest%prt_out%set_momentum (int%get_momenta (outgoing=.true.))
     end if
     associate (m_out => forest%flv(forest%n_in+1:)%get_mass ())
       call forest%prt_out%set_msq (m_out ** 2)
     end associate
     call forest%prt_out%set_defined ()
   end subroutine phs_forest_set_prt_out_int
 
   module subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab)
     class(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 forest%prt_out%set_momentum (inverse (lt_cm_to_lab) * mom)
     else
        call forest%prt_out%set_momentum (mom)
     end if
     associate (m_out => forest%flv(forest%n_in+1:)%get_mass ())
       call forest%prt_out%set_msq (m_out ** 2)
     end associate
     call forest%prt_out%set_defined ()
   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: phs forest: TBP>>=
   procedure :: combine_particles => phs_forest_combine_particles
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_combine_particles (forest)
       class(phs_forest_t), intent(inout) :: forest
     end subroutine phs_forest_combine_particles
 <<PHS forests: procedures>>=
   module subroutine phs_forest_combine_particles (forest)
     class(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 forest%prt(k)%combine (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: phs forest: TBP>>=
   procedure :: get_prt_out => phs_forest_get_prt_out
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab)
       class(phs_forest_t), intent(in) :: forest
       type(interaction_t), intent(inout) :: int
       type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
     end subroutine phs_forest_get_prt_out
 <<PHS forests: procedures>>=
   module subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab)
     class(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 * &
             forest%prt_out%get_momentum (), outgoing=.true.)
     else
        call int%set_momenta (forest%prt_out%get_momentum (), &
             outgoing=.true.)
     end if
   end subroutine phs_forest_get_prt_out
 
 @ %def phs_forest_get_prt_out
 @ Extract the outgoing particle momenta
 <<PHS forests: phs forest: TBP>>=
   procedure :: get_momenta_out => phs_forest_get_momenta_out
 <<PHS forests: sub interfaces>>=
     module function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p)
       class(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
     end function phs_forest_get_momenta_out
 <<PHS forests: procedures>>=
   module function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p)
     class(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 = forest%prt_out%get_momentum ()
     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: phs forest: TBP>>=
   procedure :: set_equivalences => phs_forest_set_equivalences
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_set_equivalences (forest)
       class(phs_forest_t), intent(inout) :: forest
     end subroutine phs_forest_set_equivalences
 <<PHS forests: procedures>>=
   module subroutine phs_forest_set_equivalences (forest)
     class(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: phs forest: TBP>>=
   procedure :: get_equivalences => phs_forest_get_equivalences
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_get_equivalences &
          (forest, channel, azimuthal_dependence)
       class(phs_forest_t), intent(in) :: forest
       type(phs_channel_t), dimension(:), intent(out) :: channel
       logical, intent(in) :: azimuthal_dependence
     end subroutine phs_forest_get_equivalences
 <<PHS forests: procedures>>=
   module subroutine phs_forest_get_equivalences &
        (forest, channel, azimuthal_dependence)
     class(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: phs forest: TBP>>=
   procedure :: evaluate_selected_channel => phs_forest_evaluate_selected_channel
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_evaluate_selected_channel &
          (forest, channel, active, sqrts, x, phs_factor, volume, ok)
       class(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
     end subroutine phs_forest_evaluate_selected_channel
 <<PHS forests: procedures>>=
   module subroutine phs_forest_evaluate_selected_channel &
        (forest, channel, active, sqrts, x, phs_factor, volume, ok)
     class(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 forest%prt%set_undefined ()
     call forest%prt_out%set_undefined ()
     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 forest%prt(ibset(0,k-1))%set_msq &
             (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 forest%prt(k_root)%combine (forest%prt_in(1), forest%prt_in(2))
     end select
     call forest%grove(g)%tree(t)%compute_momenta_from_x (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: phs forest: TBP>>=
   procedure :: evaluate_other_channels => phs_forest_evaluate_other_channels
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_evaluate_other_channels &
          (forest, channel, active, sqrts, x, phs_factor, combine)
       class(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
     end subroutine phs_forest_evaluate_other_channels
 <<PHS forests: procedures>>=
   module subroutine phs_forest_evaluate_other_channels &
        (forest, channel, active, sqrts, x, phs_factor, combine)
     class(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 forest%grove(g)%tree(t)%compute_x_from_momenta (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: phs forest: TBP>>=
   procedure :: recover_channel => phs_forest_recover_channel
 <<PHS forests: sub interfaces>>=
     module subroutine phs_forest_recover_channel &
          (forest, channel, sqrts, x, phs_factor, volume)
       class(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
     end subroutine phs_forest_recover_channel
 <<PHS forests: procedures>>=
   module subroutine phs_forest_recover_channel &
        (forest, channel, sqrts, x, phs_factor, volume)
     class(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 forest%prt%set_undefined ()
     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 forest%combine_particles ()
     call forest%grove(g)%tree(t)%compute_volume (sqrts, volume)
     call forest%grove(g)%tree(t)%compute_x_from_momenta (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 forest%read (filename, process_id, 2, 3, model, found_process)
 
     write (u, "(A)")
     write (u, "(A)")  "* Set parameters, flavors, equiv, momenta"
     write (u, "(A)")
 
     call forest%set_flavors (flv)
     call forest%set_parameters (mapping_defaults, .false.)
     call forest%setup_prt_combinations ()
     call forest%set_equivalences ()
     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 forest%set_prt_in (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 forest%evaluate_selected_channel (n_channel, active, sqrts, &
          x, factor, volume, ok)
     call forest%evaluate_other_channels (n_channel, active, sqrts, &
          x, factor, combine=.true.)
     call forest%get_prt_out (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 forest%write (u)
 
     write (u, "(A)")
     write (u, "(A)")  "* Compute equivalences"
 
     n_channel = 4
     allocate (channel (n_channel))
     call forest%get_equivalences (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 forest%final ()
     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 forest%read (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 forest%final ()
     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 physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
   use physics_defs, only: UNDEFINED
   use model_data
   use flavors
 
   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>>
 
   interface
 <<Cascades: sub interfaces>>
   end interface
 
 end module cascades
 @ %def cascades
 @
 <<[[cascades_sub.f90]]>>=
 <<File header>>
 
 submodule (cascades) cascades_s
 
   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 lorentz
 
   implicit none
 
 contains
 
 <<Cascades: procedures>>
 
 end submodule cascades_s
 
 @ %def cascades_s
 @
 \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: sub interfaces>>=
     module function cascade_disjunct (cascade1, cascade2) result (flag)
       logical :: flag
       type(cascade_t), intent(in) :: cascade1, cascade2
     end function cascade_disjunct
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module subroutine hash_entry_init (entry, entry_in)
       type(hash_entry_t), intent(out) :: entry
       type(hash_entry_t), intent(in) :: entry_in
     end subroutine hash_entry_init
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     elemental module function pdg_match (pdg1, pdg2) result (flag)
       logical :: flag
       integer(TC), intent(in) :: pdg1, pdg2
     end function pdg_match
 <<Cascades: procedures>>=
   elemental module 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: sub interfaces>>=
     module 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
     end subroutine cascade_set_init_from_cascade
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module function cascade_set_is_valid (cascade_set) result (flag)
       logical :: flag
       type(cascade_set_t), intent(in) :: cascade_set
     end function cascade_set_is_valid
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine cascade_set_init_base
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module subroutine cascade_set_final (cascade_set)
       type(cascade_set_t), intent(inout), target :: cascade_set
     end subroutine cascade_set_final
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module subroutine cascade_set_write_process_bincode_format &
          (cascade_set, unit)
       type(cascade_set_t), intent(in), target :: cascade_set
       integer, intent(in), optional :: unit
     end subroutine cascade_set_write_process_bincode_format
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module subroutine cascade_set_write_file_format (cascade_set, unit)
       type(cascade_set_t), intent(in), target :: cascade_set
       integer, intent(in), optional :: unit
     end subroutine cascade_set_write_file_format
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine cascade_set_write_graph_format
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine cascade_set_write
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module subroutine cascade_set_add_outgoing1 (cascade_set, flv)
       type(cascade_set_t), intent(inout), target :: cascade_set
       type(flavor_t), dimension(:), intent(in) :: flv
     end subroutine cascade_set_add_outgoing1
     module subroutine cascade_set_add_outgoing2 (cascade_set, flv)
       type(cascade_set_t), intent(inout), target :: cascade_set
       type(flavor_t), dimension(:,:), intent(in) :: flv
     end subroutine cascade_set_add_outgoing2
 <<Cascades: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     module 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
     end subroutine cascade_set_add_incoming1
     module 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
     end subroutine cascade_set_add_incoming0
 <<Cascades: procedures>>=
   module 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
 
   module 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
+    real(default) :: width
     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 ()
+    width = flv%get_width ()
     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 (cascade3%m_rea > cascade3%m_min .and. &
+         cascade3%m_rea <= cascade_set%sqrts) then
+       if (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: sub interfaces>>=
     module 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
     end subroutine cascade_set_generate
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function phase_space_vanishes
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine cascade_extract_resonance_history
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module function cascade_set_get_n_trees (cascade_set) result (n)
       type(cascade_set_t), intent(in), target :: cascade_set
       integer :: n
     end function cascade_set_get_n_trees
 <<Cascades: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine cascade_set_get_resonance_histories
 <<Cascades: procedures>>=
   module 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{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>>
 
   interface
 <<Cascades2 lexer: sub interfaces>>
   end interface
 
 end module cascades2_lexer
 
 @ %def cascades2_lexer
 @
 <<[[cascades2_lexer_sub.f90]]>>=
 <<File header>>
 
 submodule (cascades2_lexer) cascades2_lexer_s
 
   implicit none
 
 contains
 
 <<Cascades2 lexer: procedures>>
 
 end submodule cascades2_lexer_s
 
 @ %def cascades2_lexer_s
 @
 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(len=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: sub interfaces>>=
     module 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
     end subroutine dag_token_init_dag_object_token
 <<Cascades2 lexer: procedures>>=
   module 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
       end do
     end function integer_n_dec_digits
   end subroutine dag_token_init_dag_object_token
 
 @ %def dag_token_init_dag_object_token
 <<Cascades2 lexer: sub interfaces>>=
     elemental module 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
     end subroutine dag_token_assign_from_char_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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)
                 end do
              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
        end do
     end if
   end subroutine dag_token_assign_from_char_string
 
 @ %def dag_token_assign_from_char_string
 <<Cascades2 lexer: sub interfaces>>=
     elemental module 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
     end subroutine dag_token_assign_from_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end subroutine dag_string_assign_from_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     module 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
     end subroutine dag_string_assign_from_dag_token_array
 <<Cascades2 lexer: procedures>>=
   module 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: sub interfaces>>=
     elemental module 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
     end subroutine dag_string_assign_from_char_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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
        end do
        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: sub interfaces>>=
     elemental module 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
     end subroutine dag_string_assign_from_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     module 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
     end function concat_dag_token_dag_token
 <<Cascades2 lexer: procedures>>=
   module 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
        call dag_string_assign_from_dag_token (res_string, token2)
     else if (token2%type == EMPTY_TK) then
        call dag_string_assign_from_dag_token (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: sub interfaces>>=
     module 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
     end function concat_dag_string_dag_token
 <<Cascades2 lexer: procedures>>=
   module 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
        call dag_string_assign_from_dag_token (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: sub interfaces>>=
     module 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
     end function concat_dag_token_dag_string
 <<Cascades2 lexer: procedures>>=
   module 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
        call dag_string_assign_from_dag_token (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: sub interfaces>>=
     module 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
     end function concat_dag_string_dag_string
 <<Cascades2 lexer: procedures>>=
   module 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: sub interfaces>>=
     elemental module function dag_token_eq_dag_token &
          (token1, token2) result (flag)
       type(dag_token_t), intent(in) :: token1, token2
       logical :: flag
     end function dag_token_eq_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module function dag_string_eq_dag_string &
          (string1, string2) result (flag)
       type(dag_string_t), intent(in) :: string1, string2
       logical :: flag
     end function dag_string_eq_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function dag_token_eq_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function dag_string_eq_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function dag_token_eq_char_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function char_string_eq_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function dag_string_eq_char_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function char_string_eq_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module function dag_token_ne_dag_token &
          (token1, token2) result (flag)
       type(dag_token_t), intent(in) :: token1, token2
       logical :: flag
     end function dag_token_ne_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module function dag_string_ne_dag_string &
          (string1, string2) result (flag)
       type(dag_string_t), intent(in) :: string1, string2
       logical :: flag
     end function dag_string_ne_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function dag_token_ne_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function dag_string_ne_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function dag_token_ne_char_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function char_string_ne_dag_token
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function dag_string_ne_char_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     elemental module 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
     end function char_string_ne_dag_string
 <<Cascades2 lexer: procedures>>=
   elemental module 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: sub interfaces>>=
     pure module function char_dag_token (dag_token) result (char_string)
       type(dag_token_t), intent(in) :: dag_token
       character (dag_token%char_len) :: char_string
     end function char_dag_token
 <<Cascades2 lexer: procedures>>=
   pure module 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
        end do
     end select
   end function char_dag_token
 
 @ %def char_dag_token
 <<Cascades2 lexer: sub interfaces>>=
     pure module function char_dag_string (dag_string) result (char_string)
       type(dag_string_t), intent(in) :: dag_string
       character (dag_string%char_len) :: char_string
     end function char_dag_string
 <<Cascades2 lexer: procedures>>=
   pure module 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
     end do
   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: sub interfaces>>=
     module subroutine dag_string_clean (dag_string)
       class(dag_string_t), intent(inout) :: dag_string
     end subroutine dag_string_clean
 <<Cascades2 lexer: procedures>>=
   module 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
     end do
     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: sub interfaces>>=
     module subroutine dag_string_update_char_len (dag_string)
       class(dag_string_t), intent(inout) :: dag_string
     end subroutine dag_string_update_char_len
 <<Cascades2 lexer: procedures>>=
   module 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
        end do
     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: sub interfaces>>=
     module subroutine dag_chain_append_string (dag_chain, char_string)
       class(dag_chain_t), intent(inout) :: dag_chain
       character(len=*), intent(in) :: char_string
     end subroutine dag_chain_append_string
 <<Cascades2 lexer: procedures>>=
   module 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: sub interfaces>>=
     module subroutine dag_chain_compress (dag_chain)
       class(dag_chain_t), intent(inout) :: dag_chain
     end subroutine dag_chain_compress
 <<Cascades2 lexer: procedures>>=
   module 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)
     end do
   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: sub interfaces>>=
     module subroutine dag_string_final (dag_string)
       class(dag_string_t), intent(inout) :: dag_string
     end subroutine dag_string_final
 <<Cascades2 lexer: procedures>>=
   module 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: sub interfaces>>=
     module subroutine dag_chain_final (dag_chain)
       class(dag_chain_t), intent(inout) :: dag_chain
     end subroutine dag_chain_final
 <<Cascades2 lexer: procedures>>=
   module 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
     end do
     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)
     end do
     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, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit
 <<Use kinds>>
   use kinds, only: TC, i8
 <<Use strings>>
 <<Use debug>>
   use diagnostics
   use flavors
   use model_data
   use phs_forests, only: phs_parameters_t
   use resonances, only: resonance_info_t
   use resonances, only: resonance_history_t
   use resonances, only: resonance_history_set_t
   use cascades2_lexer
 
 <<Standard module head>>
 
 <<Cascades2: public>>
 
 <<Cascades2: parameters>>
 
 <<Cascades2: types>>
 
 <<Cascades2: interfaces>>
 
   interface
 <<Cascades2: sub interfaces>>
   end interface
 
 contains
 
 <<Cascades2: main procedures>>
 
 end module cascades2
 
 @ %def cascades2
 @
 <<[[cascades2_sub.f90]]>>=
 <<File header>>
 
 submodule (cascades2) cascades2_s
 
   use sorting
   use io_units
   use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
   use hashes
   use cascades, only: phase_space_vanishes, MAX_WARN_RESONANCE
 
   implicit none
 
 contains
 
 <<Cascades2: procedures>>
 
 end submodule cascades2_s
 
 @ %def cascades2_s
 @
 \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: sub interfaces>>=
     module subroutine part_prop_final (part)
       class(part_prop_t), intent(inout) :: part
     end subroutine part_prop_final
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine tree_final (tree)
       class(tree_t), intent(inout) :: tree
     end subroutine tree_final
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine tree_assign (tree1, tree2)
       type(tree_t), intent(inout) :: tree1
       type(tree_t), intent(in) :: tree2
     end subroutine tree_assign
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine tree_add_entry_from_numbers
 <<Cascades2: procedures>>=
   module 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
        !! Proof: tree_size > 0 (always)
        tree_size = tree1%n_entries + tree2%n_entries + 1
        allocate (tree%bc (tree_size))
        allocate (tree%pdg (tree_size))
        allocate (tree%mapping (tree_size))
        if (.not. tree1%empty) then
           tree%bc(:i1) = tree1%bc
           tree%pdg(:i1) = tree1%pdg
           tree%mapping(:i1) = tree1%mapping
        end if
        if (.not. tree2%empty) then
           tree%bc(i1+1:i2) = tree2%bc
           tree%pdg(i1+1:i2) = tree2%pdg
           tree%mapping(i1+1:i2) = tree2%mapping
        end if
        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: sub interfaces>>=
     module subroutine tree_add_entry_from_node (tree, node)
       class(tree_t), intent(inout) :: tree
       type(k_node_t), intent(in) :: node
     end subroutine tree_add_entry_from_node
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine tree_sort (tree)
       class(tree_t), intent(inout) :: tree
     end subroutine tree_sort
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine feyngraph_final (graph)
       class(feyngraph_t), intent(inout) :: graph
     end subroutine feyngraph_final
 <<Cascades2: procedures>>=
   module 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)
     end do
   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: sub interfaces>>=
     module subroutine kingraph_final (graph)
       class(kingraph_t), intent(inout) :: graph
     end subroutine kingraph_final
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine k_node_entry_final (entry)
       class(k_node_entry_t), intent(inout) :: entry
     end subroutine k_node_entry_final
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module 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
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine k_node_list_final (list)
       class(k_node_list_t), intent(inout) :: list
     end subroutine k_node_list_final
 <<Cascades2: procedures>>=
   module 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)
     end do
   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: sub interfaces>>=
     recursive module subroutine f_node_final (node)
       class(f_node_t), intent(inout) :: node
     end subroutine f_node_final
 <<Cascades2: procedures>>=
   recursive module 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: sub interfaces>>=
     module subroutine f_node_entry_final (entry)
       class(f_node_entry_t), intent(inout) :: entry
     end subroutine f_node_entry_final
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine f_node_set_index (f_node)
       class(f_node_t), intent(inout) :: f_node
     end subroutine f_node_set_index
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine f_node_ptr_final (f_node_ptr)
       class(f_node_ptr_t), intent(inout) :: f_node_ptr
     end subroutine f_node_ptr_final
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine f_node_ptr_assign (ptr1, ptr2)
       type(f_node_ptr_t), intent(out) :: ptr1
       type(f_node_ptr_t), intent(in) :: ptr2
     end subroutine f_node_ptr_assign
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine k_node_assign (k_node1, k_node2)
       type(k_node_t), intent(inout) :: k_node1
       type(k_node_t), intent(in) :: k_node2
     end subroutine k_node_assign
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     recursive module subroutine k_node_final (k_node)
       class(k_node_t), intent(inout) :: k_node
     end subroutine k_node_final
 <<Cascades2: procedures>>=
   recursive module 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: sub interfaces>>=
     module subroutine k_node_set_index (k_node)
       class(k_node_t), intent(inout) :: k_node
     end subroutine k_node_set_index
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine f_node_entry_write (f_node_entry, u)
       class(f_node_entry_t), intent(in) :: f_node_entry
       integer, intent(in) :: u
     end subroutine f_node_entry_write
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine f_node_entry_assign (entry1, entry2)
       type(f_node_entry_t), intent(out) :: entry1
       type(f_node_entry_t), intent(in) :: entry2
     end subroutine f_node_entry_assign
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine f_node_list_add_entry
 <<Cascades2: procedures>>=
   module 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
        end do
     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: sub interfaces>>=
     module subroutine f_node_list_write (f_node_list, u)
       class(f_node_list_t), intent(in) :: f_node_list
       integer, intent(in) :: u
     end subroutine f_node_list_write
 <<Cascades2: procedures>>=
   module 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
     end do
   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: sub interfaces>>=
     module subroutine k_node_entry_assign (entry1, entry2)
       type(k_node_entry_t), intent(out) :: entry1
       type(k_node_entry_t), intent(in) :: entry2
     end subroutine k_node_entry_assign
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     recursive module 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
     end subroutine k_node_list_add_entry
 <<Cascades2: procedures>>=
   recursive module 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: sub interfaces>>=
     module 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
     end subroutine k_node_list_add_pointer
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine k_node_list_check_subtree_equivalences (list, model)
       class(k_node_list_t), intent(inout) :: list
       type(model_data_t), intent(in) :: model
     end subroutine k_node_list_check_subtree_equivalences
 <<Cascades2: procedures>>=
   module 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
     end do
     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
           end do
        end if
     end do
     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: sub interfaces>>=
     module 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
     end subroutine k_node_list_get_nodes
 <<Cascades2: procedures>>=
   module 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
     end do
     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)
        end do
        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
           end do
           if (current%recycle .and. current%node%keep) then
              nodes(pos)%node => current%node
              pos = pos + 1
           end if
           current => current%next
        end do
     end if
   end subroutine k_node_list_get_nodes
 
 @ %def k_node_list_get_nodes
 Gfortran 7/8/9 bug, has to remain in the main module:
 <<Cascades2: f node list: TBP>>=
   procedure :: final => f_node_list_final
 <<Cascades2: main 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)
     end do
   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: sub interfaces>>=
     module subroutine compare_tree_final (ctree)
       class(compare_tree_t), intent(inout) :: ctree
     end subroutine compare_tree_final
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     recursive module subroutine compare_tree_entry_final (ct_entry)
       class(compare_tree_entry_t), intent(inout) :: ct_entry
     end subroutine compare_tree_entry_final
 <<Cascades2: procedures>>=
   recursive module 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 ()
        end do
        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: sub interfaces>>=
     module 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
     end subroutine compare_tree_check_kingraph
 <<Cascades2: procedures>>=
   module 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))
        end do
        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
     end do
     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: sub interfaces>>=
     recursive module 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
     end subroutine compare_tree_entry_check_kingraph
 <<Cascades2: procedures>>=
   recursive module 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
         end do
         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
         end do
         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
         end do
         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: sub interfaces>>=
     module subroutine grove_final (grove)
       class(grove_t), intent(inout) :: grove
     end subroutine grove_final
 <<Cascades2: procedures>>=
   module 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
 Gfortran 7/8/9 bug, has to remain in the main module:
 <<Cascades2: grove list: TBP>>=
   procedure :: final => grove_list_final
 <<Cascades2: main 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. Gfortran 7/8/9 bug, has to remain in the main module:
 <<Cascades2: feyngraph set: TBP>>=
   procedure :: final => feyngraph_set_final
 <<Cascades2: main 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 ()
        end do
        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: sub interfaces>>=
     module subroutine feyngraph_set_build (feyngraph_set, u_in)
       class(feyngraph_set_t), intent(inout) :: feyngraph_set
       integer, intent(in) :: u_in
     end subroutine feyngraph_set_build
 <<Cascades2: procedures>>=
   module 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
                 end do
                 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
           end do
           current_graph => feyngraph_set%first
           do while (associated (current_graph))
              call feyngraph_construct (feyngraph_set, current_graph)
              current_graph => current_graph%next
           end do
           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: sub interfaces>>=
     module 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
     end subroutine dag_read_string
 <<Cascades2: procedures>>=
   module 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
     end do
     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
     end do
     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
     end do
   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: sub interfaces>>=
     module subroutine init_sm_full_test (model)
       class(model_data_t), intent(out) :: model
     end subroutine init_sm_full_test
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     recursive module 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
     end subroutine part_prop_init
 <<Cascades2: procedures>>=
   recursive module 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
        end do
     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: sub interfaces>>=
     module subroutine f_node_assign_particle_properties (node, feyngraph_set)
       class(f_node_t), intent(inout ) :: node
       type(feyngraph_set_t), intent(inout) :: feyngraph_set
     end subroutine f_node_assign_particle_properties
 <<Cascades2: procedures>>=
   module 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
     end do
     !!! 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: sub interfaces>>=
     module subroutine dag_node_final (dag_node)
       class(dag_node_t), intent(inout) :: dag_node
     end subroutine dag_node_final
 <<Cascades2: procedures>>=
   module 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
        end do
        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: sub interfaces>>=
     module subroutine dag_options_final (dag_options)
       class(dag_options_t), intent(inout) :: dag_options
     end subroutine dag_options_final
 <<Cascades2: procedures>>=
   module 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 ()
        end do
        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 ()
        end do
        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: sub interfaces>>=
     module subroutine dag_combination_final (dag_combination)
       class(dag_combination_t), intent(inout) :: dag_combination
     end subroutine dag_combination_final
 <<Cascades2: procedures>>=
   module 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 ()
        end do
        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 ()
        end do
        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: sub interfaces>>=
     module subroutine dag_final (dag)
       class(dag_t), intent(inout) :: dag
     end subroutine dag_final
 <<Cascades2: procedures>>=
   module 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 ()
        end do
        deallocate (dag%node)
     end if
     if (allocated (dag%options)) then
        do i=1, size (dag%options)
           call dag%options(i)%final ()
        end do
        deallocate (dag%options)
     end if
     if (allocated (dag%combination)) then
        do i=1, size (dag%combination)
           call dag%combination(i)%final ()
        end do
        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: sub interfaces>>=
     module subroutine dag_construct (dag, feyngraph_set)
       class(dag_t), intent(inout) :: dag
       type(feyngraph_set_t), intent(inout) :: feyngraph_set
     end subroutine dag_construct
 <<Cascades2: procedures>>=
   module 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)
     end do
     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)
           end do
           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)
           end do
           !$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)
           end do
           !$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
     end do
 !!! 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 ()
           end do
        end if
     end do
   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: sub interfaces>>=
       module subroutine dag_get_nodes_and_combinations (dag, leaves)
         class(dag_t), intent(inout) :: dag
         logical, intent(in) :: leaves
       end subroutine dag_get_nodes_and_combinations
 <<Cascades2: procedures>>=
   module 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
        end do
        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
              end do
           else
              new_size = new_size + 1
              new_string%t(new_size) = dag%string%t(i)
              i = i + 1
           end if
        end do
        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: sub interfaces>>=
       module subroutine dag_get_options (dag)
         class(dag_t), intent(inout) :: dag
       end subroutine dag_get_options
 <<Cascades2: procedures>>=
   module 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
           end do
        else
           new_size = new_size + 1
           new_string%t(new_size) = dag%string%t(i)
           i = i + 1
        end if
     end do
     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: sub interfaces>>=
     module 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
     end subroutine dag_add_node
 <<Cascades2: procedures>>=
   module 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
      end do
      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: sub interfaces>>=
     module 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
     end subroutine dag_add_options
 <<Cascades2: procedures>>=
   module 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
      end do
      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: sub interfaces>>=
     module 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
     end subroutine dag_add_combination
 <<Cascades2: procedures>>=
   module 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
      end do
      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: sub interfaces>>=
     module 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
     end subroutine dag_node_make_f_nodes
 <<Cascades2: procedures>>=
   module 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
        end do
        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
                 end do
              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
                 end do
              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
                 end do
              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
                 end do
              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
                 end do
              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
                 end do
              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
             end do
          end if
       end do
     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: sub interfaces>>=
     module 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
     end subroutine dag_options_make_f_nodes
 <<Cascades2: procedures>>=
   module 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
     end do
     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
       end do
       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
          end do
       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
       end do
       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
          end do
       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: sub interfaces>>=
     module 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
     end subroutine dag_combination_make_f_nodes
 <<Cascades2: procedures>>=
   module 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
     end do
     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)
                 end do
              end do
           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)
                 end do
              end do
           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)
                 end do
              end do
           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)
                 end do
              end do
           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: sub interfaces>>=
     module subroutine dag_make_feyngraphs (dag, feyngraph_set)
       class(dag_t), intent(inout) :: dag
       type(feyngraph_set_t), intent(inout) :: feyngraph_set
     end subroutine dag_make_feyngraphs
 <<Cascades2: procedures>>=
   module 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
        end do
        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: sub interfaces>>=
     module subroutine dag_write (dag, u)
       class(dag_t), intent(in) :: dag
       integer, intent(in) :: u
     end subroutine dag_write
 <<Cascades2: procedures>>=
   module 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)
     end do
     write (u,fmt='(A)') 'options'
     do i=1, dag%n_options
        write (u,fmt='(I5,3X,A)') i, char (dag%options(i)%string)
     end do
     write (u,fmt='(A)') 'combination'
     do i=1, dag%n_combinations
        write (u,fmt='(I5,3X,A)') i, char (dag%combination(i)%string)
     end do
   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: sub interfaces>>=
     module subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set)
       class(feyngraph_t), intent(inout) :: feyngraph
       type(feyngraph_set_t), intent(in) :: feyngraph_set
     end subroutine feyngraph_make_kingraphs
 <<Cascades2: procedures>>=
   module 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
        end do
        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
              end do
           end do
           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
           end do
        else
           return
        end if
     end do
     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
     end do
   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
        end do
     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: sub interfaces>>=
     module subroutine feyngraph_make_inverse_kingraphs (feyngraph)
       class(feyngraph_t), intent(inout) :: feyngraph
     end subroutine feyngraph_make_inverse_kingraphs
 <<Cascades2: procedures>>=
   module 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
     end do
   end subroutine feyngraph_make_inverse_kingraphs
 
 @ %def feyngraph_make_inverse_kingraphs
 <<Cascades2: feyngraph: TBP>>=
   procedure :: compute_mappings => feyngraph_compute_mappings
 <<Cascades2: sub interfaces>>=
     module subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set)
       class(feyngraph_t), intent(inout) :: feyngraph
       type(feyngraph_set_t), intent(inout) :: feyngraph_set
     end subroutine feyngraph_compute_mappings
 <<Cascades2: procedures>>=
   module 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
     end do
   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
                 end do
              end if
           end do
        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
           end do
        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
                 end do
              end if
           end do
        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
           end do
        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)
        end do
        !$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
           end do
        end do
        !$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
           end do
        end do
        deallocate (set)
        call compare_list%check_subtree_equivalences(feyngraph_set%model)
        call compare_list%final
        deallocate (compare_list)
     end do
   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: sub interfaces>>=
     module 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
     end subroutine grove_list_get_grove
 <<Cascades2: procedures>>=
   module 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
     end do
   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: sub interfaces>>=
     module 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
     end subroutine grove_list_add_kingraph
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine grove_list_add_feyngraph
 <<Cascades2: procedures>>=
   module 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
     end do
     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
        end do
     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: sub interfaces>>=
     module 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
     end function grove_prop_match
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function grove_prop_equal
 <<Cascades2: procedures>>=
   module 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
     end do
     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
     end do
     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
     end do
     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
                 end do
                 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
                 end do
                 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
                 end do
                 deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match)
                 if (.not. (kingraph1%keep .and. kingraph2%keep)) exit
              end if
           end if
        end do
     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: sub interfaces>>=
     module 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
     end subroutine grove_list_merge
 <<Cascades2: procedures>>=
   module 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
        end do
        current_grove => current_grove%next
     end do
   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: sub interfaces>>=
     module subroutine grove_list_rebuild (grove_list)
       class(grove_list_t), intent(inout) :: grove_list
     end subroutine grove_list_rebuild
 <<Cascades2: procedures>>=
   module 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
        end do
        current_grove => current_grove%next
     end do
     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: sub interfaces>>=
     module subroutine feyngraph_set_write_file_format (feyngraph_set, u)
       type(feyngraph_set_t), intent(in) :: feyngraph_set
       integer, intent(in) :: u
     end subroutine feyngraph_set_write_file_format
 <<Cascades2: procedures>>=
   module 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
     end do
   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: sub interfaces>>=
     recursive module 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
     end subroutine grove_write_file_format
 <<Cascades2: procedures>>=
   recursive module 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
     end do
   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: sub interfaces>>=
     module 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
     end subroutine kingraph_write_file_format
 <<Cascades2: procedures>>=
   module 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
     end do
     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
     end do
   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
      end do
    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: sub interfaces>>=
     module subroutine feyngraph_make_invertible (feyngraph)
       class(feyngraph_t), intent(inout) :: feyngraph
     end subroutine feyngraph_make_invertible
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph)
       class(kingraph_t), intent(inout) :: original_kingraph
       type(feyngraph_t), intent(inout) :: feyngraph
     end subroutine kingraph_make_inverse_copy
 <<Cascades2: procedures>>=
   module 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
     end do
     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: sub interfaces>>=
     module 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
     end subroutine feyngraph_set_generate_single
 <<Cascades2: procedures>>=
   module 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
     end do
     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
        end do
        !$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
     end do
     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
        end do
     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
     end do
     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
     end do
   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: sub interfaces>>=
     elemental module function tree_equal (tree1, tree2) result (flag)
       type(tree_t), intent(in) :: tree1, tree2
       logical :: flag
     end function tree_equal
 <<Cascades2: procedures>>=
   elemental module 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: sub interfaces>>=
     pure module function subtree_eqv (subtree1, subtree2) result (eqv)
       type(tree_t), intent(in) :: subtree1, subtree2
       logical :: eqv
     end function subtree_eqv
 <<Cascades2: procedures>>=
   pure module 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
        end do
        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
        end do
        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
        end do
        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
              end do
              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
              end do
              deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match)
              if (.not. (subtree1%keep .and. subtree2%keep)) exit
           end if
        end do
     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: sub interfaces>>=
     module subroutine kingraph_assign_resonance_hash (kingraph)
       class(kingraph_t), intent(inout) :: kingraph
     end subroutine kingraph_assign_resonance_hash
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module subroutine feyngraph_set_write_process_bincode_format &
          (feyngraph_set, unit)
       type(feyngraph_set_t), intent(in), target :: feyngraph_set
       integer, intent(in), optional :: unit
     end subroutine feyngraph_set_write_process_bincode_format
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine feyngraph_set_write_graph_format
 <<Cascades2: procedures>>=
   module 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
        end do
        grove => grove%next
     end do
     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: sub interfaces>>=
     module 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
     end subroutine feyngraph_set_generate
 <<Cascades2: procedures>>=
   module 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()
     end do
     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: sub interfaces>>=
     module function feyngraph_set_is_valid (feyngraph_set) result (flag)
       class(feyngraph_set_t), intent(in) :: feyngraph_set
       logical :: flag
     end function feyngraph_set_is_valid
 <<Cascades2: procedures>>=
   module 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
           end do
           grove => grove%next
        end do
     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: sub interfaces>>=
     module 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
     end subroutine kingraph_extract_resonance_history
 <<Cascades2: procedures>>=
   module 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: sub interfaces>>=
     module function grove_list_get_n_trees (grove_list) result (n)
       class(grove_list_t), intent(in) :: grove_list
       integer :: n
     end function grove_list_get_n_trees
 <<Cascades2: procedures>>=
   module 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
        end do
        grove => grove%next
     end do
     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: sub interfaces>>=
     module 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
     end subroutine feyngraph_set_get_resonance_histories
 <<Cascades2: procedures>>=
   module 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
 @
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 \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 os_interface
   use lorentz
   use model_data
   use flavors
   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: types>>
 
   interface
 <<PHS wood: sub interfaces>>
   end interface
 
 contains
 
 <<PHS wood: main procedures>>
 
 end module phs_wood
 @ %def phs_wood
 @
 <<[[phs_wood_sub.f90]]>>=
 <<File header>>
 
 submodule (phs_wood) phs_wood_s
 
   use io_units
   use constants
   use numeric_utils
   use diagnostics
   use physics_defs
   use md5
   use process_constants
   use sf_mappings
   use sf_base
 
   implicit none
 
 contains
 
 <<PHS wood: procedures>>
 
 end submodule phs_wood_s
 
 @ %def phs_wood_s
 @
 \subsection{Configuration}
 <<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
      logical :: is_combined_integration = .false.
    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: sub interfaces>>=
     module subroutine phs_wood_config_final (object)
       class(phs_wood_config_t), intent(inout) :: object
     end subroutine phs_wood_config_final
 <<PHS wood: procedures>>=
   module 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 object%forest%final ()
   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: sub interfaces>>=
     module subroutine phs_wood_config_increase_n_par (phs_config)
       class(phs_wood_config_t), intent(inout) :: phs_config
     end subroutine phs_wood_config_increase_n_par
 <<PHS wood: procedures>>=
   module subroutine phs_wood_config_increase_n_par (phs_config)
     class(phs_wood_config_t), intent(inout) :: phs_config
     if (phs_config%is_combined_integration) then
        phs_config%n_par = phs_config%n_par + 3
     end if
   end subroutine phs_wood_config_increase_n_par
 
 @ %def phs_wood_config_increase_n_par
 @ 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: sub interfaces>>=
     module 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
     end subroutine phs_wood_config_write
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_wood_config_write_forest (object, unit)
       class(phs_wood_config_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine phs_wood_config_write_forest
 <<PHS wood: procedures>>=
   module 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 object%forest%write (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: sub interfaces>>=
     module 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
     end subroutine phs_wood_config_set_parameters
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_wood_config_enable_equivalences (phs_config)
       class(phs_wood_config_t), intent(inout) :: phs_config
     end subroutine phs_wood_config_enable_equivalences
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_wood_config_set_mapping_defaults
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_wood_config_set_input (phs_config, unit)
       class(phs_wood_config_t), intent(inout) :: phs_config
       integer, intent(in) :: unit
     end subroutine phs_wood_config_set_input
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_wood_config_generate_phase_space (phs_config)
       class(phs_wood_config_t), intent(inout) :: phs_config
     end subroutine phs_wood_config_generate_phase_space
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_wood_config_write_phase_space
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_wood_config_clear_phase_space (phs_config)
       class(phs_wood_config_t), intent(inout) :: phs_config
     end subroutine phs_wood_config_clear_phase_space
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_wood_config_extract_resonance_history_set
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_wood_config_configure (phs_config, sqrts, &
          sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
       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_wood_config_configure
 <<PHS wood: procedures>>=
   module subroutine phs_wood_config_configure (phs_config, sqrts, &
        sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
     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 (lab_is_cm)) &
          phs_config%lab_is_cm = lab_is_cm
     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_config%forest%read (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_config%forest%set_flavors (phs_config%flv(:,1))
        variable_limits = .not. phs_config%lab_is_cm
        call phs_config%forest%set_parameters (phs_config%mapping_defaults, &
             variable_limits)
        call phs_config%forest%setup_prt_combinations ()
        phs_config%n_channel = phs_config%forest%get_n_channels ()
        phs_config%n_par = phs_config%forest%get_n_parameters ()
        allocate (phs_config%channel (phs_config%n_channel))
        if (phs_config%use_equivalences) then
           call phs_config%forest%set_equivalences ()
           call phs_config%forest%get_equivalences (phs_config%channel, &
                phs_config%azimuthal_dependence)
           phs_config%provides_equivalences = .true.
        end if
        call phs_config%forest%set_s_mappings ()
        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_config%forest%get_n_groves ()
           call phs_config%forest%get_grove_bounds (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: sub interfaces>>=
     module subroutine phs_wood_config_compute_md5sum_forest (phs_config)
       class(phs_wood_config_t), intent(inout) :: phs_config
     end subroutine phs_wood_config_compute_md5sum_forest
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function phs_wood_make_phs_filename
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_wood_config_reshuffle_flavors
 <<PHS wood: procedures>>=
   module 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_config%forest%set_flavors (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: sub interfaces>>=
     module 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
     end subroutine phs_wood_config_set_momentum_links
 <<PHS wood: procedures>>=
   module 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_config%forest%set_momentum_links (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: sub interfaces>>=
     module subroutine phs_wood_config_record_s_mappings (phs_config)
       class(phs_wood_config_t), intent(inout) :: phs_config
     end subroutine phs_wood_config_record_s_mappings
 <<PHS wood: procedures>>=
   module 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_config%forest%get_s_mapping (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: sub interfaces>>=
     module subroutine phs_wood_config_record_on_shell (phs_config)
       class(phs_wood_config_t), intent(inout) :: phs_config
     end subroutine phs_wood_config_record_on_shell
 <<PHS wood: procedures>>=
   module 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_config%forest%get_on_shell (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: sub interfaces>>=
     module function phs_wood_config_get_md5sum (phs_config) result (md5sum)
       class(phs_wood_config_t), intent(in) :: phs_config
       character(32) :: md5sum
     end function phs_wood_config_get_md5sum
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_wood_read_phs_file
 <<PHS wood: procedures>>=
   module 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_config%forest%read (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: sub interfaces>>=
     module subroutine phs_wood_config_startup_message (phs_config, unit)
       class(phs_wood_config_t), intent(in) :: phs_config
       integer, intent(in), optional :: unit
     end subroutine phs_wood_config_startup_message
 <<PHS wood: procedures>>=
   module 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_config%forest%get_n_groves ()
     n_eq = phs_config%forest%get_n_equivalences ()
     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 ", n_groves, &
             " 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.
 Gfortran 7/8/9 bug, has to remain in the main module.
 <<PHS wood: phs wood config: TBP>>=
   procedure, nopass :: allocate_instance => phs_wood_config_allocate_instance
 <<PHS wood: main 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: sub interfaces>>=
     module subroutine phs_wood_write (object, unit, verbose)
       class(phs_wood_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine phs_wood_write
 <<PHS wood: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_wood_write_forest (object, unit)
       class(phs_wood_t), intent(in) :: object
       integer, intent(in), optional :: unit
     end subroutine phs_wood_write_forest
 <<PHS wood: procedures>>=
   module 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 object%forest%write (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: sub interfaces>>=
     module subroutine phs_wood_final (object)
       class(phs_wood_t), intent(inout) :: object
     end subroutine phs_wood_final
 <<PHS wood: procedures>>=
   module subroutine phs_wood_final (object)
     class(phs_wood_t), intent(inout) :: object
     call object%forest%final ()
   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: sub interfaces>>=
     module subroutine phs_wood_init (phs, phs_config)
       class(phs_wood_t), intent(out) :: phs
       class(phs_config_t), intent(in), target :: phs_config
     end subroutine phs_wood_init
 <<PHS wood: procedures>>=
   module 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
        if (phs_config%is_combined_integration) then
           phs%n_r_born = phs_config%n_par - 3
        end if
     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: sub interfaces>>=
     module subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in)
       class(phs_wood_t), intent(inout) :: phs
       real(default), intent(in), dimension(:) :: r_in
       integer, intent(in) :: c_in
     end subroutine phs_wood_evaluate_selected_channel
     module subroutine phs_wood_evaluate_other_channels (phs, c_in)
       class(phs_wood_t), intent(inout) :: phs
       integer, intent(in) :: c_in
     end subroutine phs_wood_evaluate_other_channels
 <<PHS wood: procedures>>=
   module 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%p)
        phs%r(:,c_in) = r_in
        call phs%forest%evaluate_selected_channel (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%is_combined_integration) 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%q_defined = .true.
        end if
     end if
   end subroutine phs_wood_evaluate_selected_channel
 
   module 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 (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%is_combined_integration) 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: sub interfaces>>=
     module subroutine phs_wood_inverse (phs)
       class(phs_wood_t), intent(inout) :: phs
     end subroutine phs_wood_inverse
 <<PHS wood: procedures>>=
   module 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%p)
        call phs%forest%set_prt_out (phs%q)
        call phs%forest%recover_channel (1, phs%sqrts_hat, phs%r, &
             phs%f, phs%volume)
        call phs%forest%evaluate_other_channels (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 constants
   use lorentz
   use phs_points
   use models, only: model_t
   use phs_base
   use resonances, only: resonance_contributors_t, resonance_history_t
   use phs_wood
 
 <<Standard module head>>
 
 <<PHS fks: public>>
 
 <<PHS fks: parameters>>
 
 <<PHS fks: types>>
 
   interface
 <<PHS fks: sub interfaces>>
   end interface
 
 contains
 
 <<PHS fks: main procedures>>
 
 end module phs_fks
 
 @ %def phs_fks
 @
 <<[[phs_fks_sub.f90]]>>=
 <<File header>>
 
 submodule (phs_fks) phs_fks_s
 
 <<Use debug>>
   use diagnostics
   use io_units, only: given_output_unit, free_unit
   use format_defs, only: FMT_17
   use format_utils, only: write_separator
   use physics_defs
   use flavors
   use pdg_arrays, only: is_colored
   use cascades
   use cascades2
   use ttv_formfactors, only: generate_on_shell_decay_threshold, m1s_to_mpole
 
   implicit none
 
 <<PHS fks: interfaces>>
 
 contains
 
 <<PHS fks: procedures>>
 
 end submodule phs_fks_s
 
 @ %def phs_fks_s
 @ 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) :: sqrts_born = zero
     real(default), dimension(:), allocatable :: beam_energy
     real(default) :: fac_scale = zero
     real(default), dimension(2) :: jacobian = one
     integer :: isr_mode = SQRTS_FIXED
   contains
   <<PHS fks: isr kinematics: TBP>>
   end type isr_kinematics_t
 
 @ %def type isr_kinematics_t
 @
 <<PHS fks: isr kinematics: TBP>>=
   procedure :: write => isr_kinematics_write
 <<PHS fks: sub interfaces>>=
     module subroutine isr_kinematics_write (isr, unit)
       class(isr_kinematics_t), intent(in) :: isr
       integer, intent(in), optional :: unit
     end subroutine isr_kinematics_write
 <<PHS fks: procedures>>=
   module subroutine isr_kinematics_write (isr, unit)
     class(isr_kinematics_t), intent(in) :: isr
     integer, intent(in), optional :: unit
     integer :: u, i
     u = given_output_unit (unit); if (u < 0) return
     write (u,"(A)") "ISR kinematics: "
     write (u,"(A," // FMT_17 // ",1X)") "x(+):         ", isr%x(1)
     write (u,"(A," // FMT_17 // ",1X)") "x(-):         ", isr%x(2)
     write (u,"(A," // FMT_17 // ",1X)") "z(+):         ", isr%z(1)
     write (u,"(A," // FMT_17 // ",1X)") "z(-):         ", isr%z(2)
     write (u,"(A," // FMT_17 // ",1X)") "sqrts (Born): ", isr%sqrts_born
     if (allocated (isr%beam_energy)) then
        do i = 1, size (isr%beam_energy)
           write (u,"(A," // FMT_17 // ",1X)") "Beam energy:  ", &
                isr%beam_energy(i)
        end do
     end if
     write (u,"(A," // FMT_17 // ",1X)") "Fac. scale:   ", isr%fac_scale
     do i = 1, 2
        write (u,"(A," // FMT_17 // ",1X)") "Jacobian:     ", isr%jacobian(i)
     end do
     write (u,"(A,I0,1X)") "ISR mode:     ", isr%isr_mode
   end subroutine isr_kinematics_write
 
 @ %def isr_kinematics_write
 @
 <<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: sub interfaces>>=
     module 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
     end subroutine phs_point_set_init
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_point_set_write
 <<PHS fks: procedures>>=
   module 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
        if (debug_on)  call msg_debug &
             (D_SUBTRACTION, "Invariant masses for real emission: ")
        associate (pp => phs_point_set%phs_point(i_phs))
          p_sum = sum (pp, [contributors, size (pp)])
        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: sub interfaces>>=
     elemental module 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
     end function phs_point_set_get_n_momenta
 <<PHS fks: procedures>>=
   elemental module 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 = size (phs_point_set%phs_point(i_res))
   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: sub interfaces>>=
     pure module 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
     end function phs_point_set_get_momenta
 <<PHS fks: procedures>>=
   pure module 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
     integer :: i
     if (present (n_in)) then
        p = phs_point_set%phs_point(i_phs)%select ([(i, i=1, n_in)])
     else
        p = phs_point_set%phs_point(i_phs)
     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: sub interfaces>>=
     pure module 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
     end function phs_point_set_get_momentum
 <<PHS fks: procedures>>=
   pure module 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)%select (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: sub interfaces>>=
     pure module 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
     end function phs_point_set_get_energy
 <<PHS fks: procedures>>=
   pure module 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 = energy (phs_point_set%phs_point(i_phs)%select (i_mom))
   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: sub interfaces>>=
     module 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
     end function phs_point_set_get_sqrts
 <<PHS fks: procedures>>=
   module 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
     sqrts = sqrt (phs_point_set%phs_point(i_phs)%get_msq ([1,2]))
   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: sub interfaces>>=
     module 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
     end subroutine phs_point_set_set_momenta_p
 <<PHS fks: procedures>>=
   module 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
   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: sub interfaces>>=
     module 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
     end subroutine phs_point_set_set_momenta_phs_point
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function phs_point_set_get_n_particles
 <<PHS fks: procedures>>=
   module 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))
   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: sub interfaces>>=
     module 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
     end function phs_point_set_get_n_phs
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function phs_point_set_get_invariant_mass
 <<PHS fks: procedures>>=
   module 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
     m2 = phs_point_set%phs_point(i_phs)%get_msq (i_part)
   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: sub interfaces>>=
     module 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
     end subroutine phs_point_set_write_phs_point
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_point_set_final (phs_point_set)
       class(phs_point_set_t), intent(inout) :: phs_point_set
     end subroutine phs_point_set_final
 <<PHS fks: procedures>>=
   module subroutine phs_point_set_final (phs_point_set)
     class(phs_point_set_t), intent(inout) :: phs_point_set
     integer :: i
     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: sub interfaces>>=
     module 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
     end subroutine real_kinematics_init
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine real_kinematics_init_onshell (r, n_tot, n_phs)
       class(real_kinematics_t), intent(inout) :: r
       integer, intent(in) :: n_tot, n_phs
     end subroutine real_kinematics_init_onshell
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine real_kinematics_write (r, unit)
       class(real_kinematics_t), intent(in) :: r
       integer, intent(in), optional :: unit
     end subroutine real_kinematics_write
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end function get_boost_for_threshold_projection
 <<PHS fks: procedures>>=
   module 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._default, 0._default, 1._default]
     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: sub interfaces>>=
     module 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
     end subroutine real_kinematics_apply_threshold_projection_real
 <<PHS fks: procedures>>=
   module 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(:), allocatable :: p_real
     type(vector4_t), dimension(:), allocatable :: p_real_onshell
     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
        p_real = r%p_real_cms%phs_point(i_phs)
        allocate (p_real_onshell (size (p_real)))
        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
        r%p_real_onshell(leg)%phs_point(i_phs) = p_real_onshell
        deallocate (p_real_onshell)
     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: sub interfaces>>=
     module 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
     end subroutine threshold_projection_born
 <<PHS fks: procedures>>=
   module 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.
 The corresponding derivation can be found in [[1202.0465]], App. A.
 It is also used for the POWHEG matching 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: sub interfaces>>=
     pure module 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
     end subroutine compute_dalitz_bounds
 <<PHS fks: procedures>>=
   pure module 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: sub interfaces>>=
     module 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
     end function real_kinematics_kt2
 <<PHS fks: procedures>>=
   module 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 (UBF_FSR_SIMPLE)
        kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy)
     case (UBF_FSR_MASSIVE)
        q = sqrt (real_kinematics%cms_energy2)
        p_emitter = real_kinematics%p_born_cms%phs_point(1)%select (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 (UBF_FSR_MASSLESS_RECOIL)
        kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy**2) / two
     case (UBF_ISR)
        kt2 = real_kinematics%cms_energy2 / four * xii**2 * (1 - yy**2) / (1 - xii)
     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
 @ These are the possible values for [[upper_bound_func_type]] and will be
 used to decide which UBF object is allocated and which $K_T$ scale for the
 matching is computed.
 <<PHS fks: parameters>>=
   integer, parameter, public :: UBF_FSR_SIMPLE = 1
   integer, parameter, public :: UBF_FSR_MASSIVE = 2
   integer, parameter, public :: UBF_FSR_MASSLESS_RECOIL = 3
   integer, parameter, public :: UBF_ISR = 4
 @ %def UBF_FSR_SIMPLE UBF_FSR_MASSIVE UBF_FSR_MASSLESS_RECOIL UBF_ISR
 @
 <<PHS fks: real kinematics: TBP>>=
   procedure :: final => real_kinematics_final
 <<PHS fks: sub interfaces>>=
     module subroutine real_kinematics_final (real_kin)
       class(real_kinematics_t), intent(inout) :: real_kin
     end subroutine real_kinematics_final
 <<PHS fks: procedures>>=
   module 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 :: born_2_to_1 = .false.
     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: sub interfaces>>=
     module subroutine fks_config_clear_phase_space (phs_config)
       class(phs_fks_config_t), intent(inout) :: phs_config
     end subroutine fks_config_clear_phase_space
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_config_write
 <<PHS fks: procedures>>=
   module 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, "(3x,A,I0)")  "NLO mode  = ", object%mode
     write (u, "(3x,A,L1)")  "2->1 proc = ", object%born_2_to_1
     write (u, "(3x,A,L1)")  "Dalitz    = ", object%make_dalitz_plot
     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: sub interfaces>>=
     module subroutine phs_fks_config_set_mode (phs_config, mode)
       class(phs_fks_config_t), intent(inout) :: phs_config
       integer, intent(in) :: mode
     end subroutine phs_fks_config_set_mode
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_config_configure (phs_config, sqrts, &
          sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
       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_fks_config_configure
 <<PHS fks: procedures>>=
   module subroutine phs_fks_config_configure (phs_config, sqrts, &
        sqrts_fixed, lab_is_cm, 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 :: lab_is_cm
     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 (present (nlo_type))  phs_config%nlo_type = nlo_type
     if (.not. phs_config%is_combined_integration) then
        select case (phs_config%mode)
        case (PHS_MODE_ADDITIONAL_PARTICLE)
           phs_config%n_par = phs_config%n_par + 3
           if (phs_config%nlo_type == NLO_REAL .and. phs_config%n_out == 2) then
              phs_config%born_2_to_1 = .true.
           end if
        case (PHS_MODE_COLLINEAR_REMNANT)
           phs_config%n_par = phs_config%n_par + 1
        end select
     end if
     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: sub interfaces>>=
     module subroutine phs_fks_config_startup_message (phs_config, unit)
       class(phs_fks_config_t), intent(in) :: phs_config
       integer, intent(in), optional :: unit
     end subroutine phs_fks_config_startup_message
 <<PHS fks: procedures>>=
   module 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
 @ Gfortran 7/8/9 bug, has to remain in the main module:
 <<PHS fks: fks config: TBP>>=
   procedure, nopass :: allocate_instance => phs_fks_config_allocate_instance
 <<PHS fks: main 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: sub interfaces>>=
     module subroutine phs_fks_config_generate_phase_space_extra (phs_config)
       class(phs_fks_config_t), intent(inout) :: phs_config
     end subroutine phs_fks_config_generate_phase_space_extra
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_config_set_born_config
 <<PHS fks: procedures>>=
   module 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%lab_is_cm = phs_cfg_born%lab_is_cm
     phs_config%vis_channels = phs_cfg_born%vis_channels
     phs_config%provides_equivalences = phs_cfg_born%provides_equivalences
     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: sub interfaces>>=
     module 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
     end function phs_fks_config_get_resonance_histories
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine dalitz_plot_init
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine dalitz_plot_write_header (plot)
       class(dalitz_plot_t), intent(in) :: plot
     end subroutine dalitz_plot_write_header
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine dalitz_plot_register (plot, k0_n, k0_np1)
       class(dalitz_plot_t), intent(in) :: plot
       real(default), intent(in) :: k0_n, k0_np1
     end subroutine dalitz_plot_register
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine dalitz_plot_final (plot)
       class(dalitz_plot_t), intent(inout) :: plot
     end subroutine dalitz_plot_final
 <<PHS fks: procedures>>=
   module 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
   !!! for testing EW singularities: y_test_coll = 0.99999999_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.\\
 Naturally, this happens very rarely but for some processes,
 setting [[?test_coll_limit = true]] and/or [[?test_soft_limit = true]]
 leads to all phase space points beeing discarded by this routine.
 <<PHS fks: public>>=
   public :: check_scalar_products
 <<PHS fks: sub interfaces>>=
     module function check_scalar_products (p) result (valid)
       logical :: valid
       type(vector4_t), intent(in), dimension(:) :: p
     end function check_scalar_products
 <<PHS fks: procedures>>=
   module function check_scalar_products (p) result (valid)
     logical :: valid
     type(vector4_t), intent(in), dimension(:) :: p
     real(default), parameter :: tolerance = 1E-7_default
     !!! for testing EW singularities: tolerance = 5E-9_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
     real(default) :: y_max
     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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_connect_kinematics
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_isr_kinematics
 <<PHS fks: procedures>>=
   module 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)%select ([1,2])
     end if
 
     associate (isr_kinematics => generator%isr_kinematics)
        do em = 1, 2
           isr_kinematics%x(em) = p(em)%p(0) / isr_kinematics%beam_energy(em)
           isr_kinematics%z(em) = one - (one - isr_kinematics%x(em)) * r
           isr_kinematics%jacobian(em) =  one - isr_kinematics%x(em)
        end do
        isr_kinematics%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: sub interfaces>>=
     module subroutine phs_fks_generator_final (generator)
       class(phs_fks_generator_t), intent(inout) :: generator
     end subroutine phs_fks_generator_final
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_identifier_init_from_emitter (phs_id, emitter)
       class(phs_identifier_t), intent(out) :: phs_id
       integer, intent(in) :: emitter
     end subroutine phs_identifier_init_from_emitter
     module 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
     end subroutine phs_identifier_init_from_emitter_and_contributors
 <<PHS fks: procedures>>=
   module 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
 
   module 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: sub interfaces>>=
     module 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
     end function phs_identifier_check
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_identifier_write (phs_id, unit)
       class(phs_identifier_t), intent(in) :: phs_id
       integer, intent(in), optional :: unit
     end subroutine phs_identifier_write
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine check_for_phs_identifier
 <<PHS fks: procedures>>=
   module 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
     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: sub interfaces>>=
     module subroutine phs_fks_write (object, unit, verbose)
       class(phs_fks_t), intent(in) :: object
       integer, intent(in), optional :: unit
       logical, intent(in), optional :: verbose
     end subroutine phs_fks_write
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_init (phs, phs_config)
       class(phs_fks_t), intent(out) :: phs
       class(phs_config_t), intent(in), target :: phs_config
     end subroutine phs_fks_init
 <<PHS fks: procedures>>=
   module 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
 @ For real components of $2\to 1$ NLO processes we have to recompute the
 flux factor as this has to be the one of the underlying Born.
 <<PHS fks: phs fks: TBP>>=
   procedure :: compute_flux => phs_fks_compute_flux
 <<PHS fks: sub interfaces>>=
     module subroutine phs_fks_compute_flux (phs)
       class(phs_fks_t), intent(inout) :: phs
     end subroutine phs_fks_compute_flux
 <<PHS fks: procedures>>=
   module subroutine phs_fks_compute_flux (phs)
     class(phs_fks_t), intent(inout) :: phs
     call phs%compute_base_flux ()
     select type (config => phs%config)
     type is (phs_fks_config_t)
        if (config%born_2_to_1) then
           phs%flux = conv * twopi &
                / (2 * config%sqrts ** 2 * phs%m_out(1) ** 2)
        end if
     end select
   end subroutine phs_fks_compute_flux
 
 @  %def phs_fks_compute_flux
 @
 <<PHS fks: phs fks: TBP>>=
   procedure :: allocate_momenta => phs_fks_allocate_momenta
 <<PHS fks: sub interfaces>>=
     module 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
     end subroutine phs_fks_allocate_momenta
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_evaluate_selected_channel
 <<PHS fks: procedures>>=
   module 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
 
     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 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: sub interfaces>>=
     module subroutine phs_fks_evaluate_other_channels (phs, c_in)
       class(phs_fks_t), intent(inout) :: phs
       integer, intent(in) :: c_in
     end subroutine phs_fks_evaluate_other_channels
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_get_mcpar
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_set_beam_energy (phs)
       class(phs_fks_t), intent(inout) :: phs
     end subroutine phs_fks_set_beam_energy
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_set_emitters (phs, emitters)
       class(phs_fks_t), intent(inout) :: phs
       integer, intent(in), dimension(:), allocatable :: emitters
     end subroutine phs_fks_set_emitters
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_set_momenta (phs, p)
       class(phs_fks_t), intent(inout) :: phs
       type(vector4_t), intent(in), dimension(:) :: p
     end subroutine phs_fks_set_momenta
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_setup_masses (phs, n_tot)
       class(phs_fks_t), intent(inout) :: phs
       integer, intent(in) :: n_tot
     end subroutine phs_fks_setup_masses
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_get_born_momenta (phs, p)
       class(phs_fks_t), intent(inout) :: phs
       type(vector4_t), intent(out), dimension(:) :: p
     end subroutine phs_fks_get_born_momenta
 <<PHS fks: procedures>>=
   module 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%lab_is_cm)  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: sub interfaces>>=
     module subroutine phs_fks_get_outgoing_momenta (phs, q)
       class(phs_fks_t), intent(in) :: phs
       type(vector4_t), intent(out), dimension(:) :: q
     end subroutine phs_fks_get_outgoing_momenta
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_get_incoming_momenta (phs, p)
       class(phs_fks_t), intent(in) :: phs
       type(vector4_t), intent(inout), dimension(:), allocatable :: p
     end subroutine phs_fks_get_incoming_momenta
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_set_isr_kinematics (phs, requires_boost)
       class(phs_fks_t), intent(inout) :: phs
       logical, intent(in) :: requires_boost
     end subroutine phs_fks_set_isr_kinematics
 <<PHS fks: procedures>>=
   module 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)%select ([1,2])
        else
           p = phs%generator%real_kinematics%p_born_lab%phs_point(1)%select ([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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generate_radiation_variables
 <<PHS fks: procedures>>=
   module 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%lab_is_cm ()) &
             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: sub interfaces>>=
     module 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
     end subroutine phs_fks_compute_xi_ref_momenta
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_compute_xi_ref_momenta_threshold (phs)
       class(phs_fks_t), intent(inout) :: phs
     end subroutine phs_fks_compute_xi_ref_momenta_threshold
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_compute_cms_energy (phs)
       class(phs_fks_t), intent(inout) :: phs
     end subroutine phs_fks_compute_cms_energy
 <<PHS fks: procedures>>=
   module 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 beamstrahlung or
 QCD/QED 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: sub interfaces>>=
     module subroutine phs_fks_set_reference_frames (phs, is_cms)
       class(phs_fks_t), intent(inout) :: phs
       logical, intent(in) :: is_cms
     end subroutine phs_fks_set_reference_frames
 <<PHS fks: procedures>>=
   module subroutine phs_fks_set_reference_frames (phs, is_cms)
     class(phs_fks_t), intent(inout) :: phs
     logical, intent(in) :: is_cms
     associate (real_kinematics => phs%generator%real_kinematics)
        if (phs%config%lab_is_cm) then
           real_kinematics%p_born_cms%phs_point(1) = phs%p_born_tot
           real_kinematics%p_born_lab%phs_point(1) = phs%p_born_tot
        else
           if (is_cms) then
              real_kinematics%p_born_cms%phs_point(1) &
                   = phs%p_born_tot
              real_kinematics%p_born_lab%phs_point(1) &
                   = phs%lt_cm_to_lab * phs%p_born_tot
           else
              real_kinematics%p_born_cms%phs_point(1) &
                   = inverse (phs%lt_cm_to_lab) * phs%p_born_tot
              real_kinematics%p_born_lab%phs_point(1) &
                   = 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: sub interfaces>>=
     module 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
     end function phs_fks_i_phs_is_isr
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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(out), dimension(:) :: p_real
       real(default), intent(in), dimension(3), optional :: xi_y_phi
       logical, intent(in), optional :: no_jacobians
     end subroutine phs_fks_generator_generate_fsr_default
 <<PHS fks: procedures>>=
   module 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(out), 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_generate_fsr_resonances
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_generate_fsr_threshold
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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(out), dimension(:) :: p_real
     end subroutine phs_fks_generator_generate_fsr_in
 <<PHS fks: procedures>>=
   module 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(out), 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_generate_fsr_out
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_generate_fsr_in (phs)
       class(phs_fks_t), intent(inout) :: phs
     end subroutine phs_fks_generate_fsr_in
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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(out), 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
     end subroutine phs_fks_generate_fsr
 <<PHS fks: procedures>>=
   module 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(out), 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)
       p = generator%real_kinematics%p_born_cms%phs_point(1)
       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_real
       if (.not. phs%config%lab_is_cm)  p_real = phs%lt_cm_to_lab * p_real
       generator%real_kinematics%p_real_lab%phs_point(i_phs) = 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: sub interfaces>>=
     pure module function phs_fks_get_onshell_projected_momenta (phs) result (p)
       type(vector4_t), dimension(:), allocatable :: p
       class(phs_fks_t), intent(in) :: phs
     end function phs_fks_get_onshell_projected_momenta
 <<PHS fks: procedures>>=
   pure module 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)
   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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generate_fsr_threshold
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_compute_xi_max_internal
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_compute_xi_max_with_output
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_emitter_kinematics_massless
     module 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
     end subroutine phs_fks_generator_compute_emitter_kinematics_massive
 <<PHS fks: procedures>>=
   module 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
 
   module 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}.
 It is also used for the POWHEG matching.
 <<PHS fks: public>>=
   public :: get_xi_max_isr
 <<PHS fks: sub interfaces>>=
     module 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
     end function get_xi_max_isr
 <<PHS fks: procedures>>=
   module 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>>=
   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: sub interfaces>>=
     module 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(out), dimension(:) :: p_real
     end subroutine phs_fks_generate_isr
 <<PHS fks: procedures>>=
   module 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(out), 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)
           p_work = generator%real_kinematics%p_born_cms%phs_point(1)
           call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real)
           phs%config%lab_is_cm = .true.
        case (2)
           select case (generator%isr_kinematics%isr_mode)
           case (SQRTS_FIXED)
              p_work = generator%real_kinematics%p_born_cms%phs_point(1)
              call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real)
           case (SQRTS_VAR)
              p_work = generator%real_kinematics%p_born_lab%phs_point(1)
              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_real
        if (.not. phs%config%lab_is_cm) 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) &
                = inverse (lt) * p_real
        else
           phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) &
                = 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: sub interfaces>>=
     module 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(out), dimension(:) :: p_real
     end subroutine phs_fks_generator_generate_isr_fixed_beam_energy
 <<PHS fks: procedures>>=
   module 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(out), 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: sub interfaces>>=
     module 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(out), dimension(:) :: p_real
     end subroutine phs_fks_generator_generate_isr_factorized
 <<PHS fks: procedures>>=
   module 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(out), 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
 @ Construction of the real momenta [[p_real]] in case of ISR.
 Follows the discussion in [0709.2092] sec. 5.1.
 The sequence of Lorentz boosts required to construct [[p_real]] from
 [[p_born]] is as follows:
 \begin{enumerate}
   \item[\labelitemii] We construct the IS momenta of [[p_real]] from
     the Born momenta via rescaling:
   [[p_real(1:2)]] $= \frac{x}{\overline{x}} \cdot$ [[p_born(1:2)]].
   If the Born momenta are imported in the lab frame, these will define
   the real lab frame.
   \item[\labelitemii] We construct the momentum of the radiated
     particle in the real CMS:
     $k_{n+1} = \frac{s \xi}{2} \cdot (1, \sin(\theta) \sin(\phi),
     \sin(\theta) \cos(\phi), \cos(\theta))$
     \setcounter{enumi}{-1}
   \item We first boost the momentum of the radiated particle from the
     real CMS to the real lab frame determined from [[p_real(1:2)]].
   \item We initialize the non-radiated real FS momenta by a
     longitudinal boost of [[p_born]] to a system with zero rapidity,
     i.e. zero longitudinal momenum. This is $\mathbb{B}_L$.
   \item We boost these momenta in a transverse direction to compensate
     the transverse momentum of the radiation. This is
     $\mathbb{B}_T$. Note: we switched $\mathbb{B}_T$ and
     $\mathbb{B}^{-1}_T$ in Eq. (5.16) and their definition
     w.r.t. [0709.2092].
   \item We restore longitudinal momentum conservation by applying the
     inverse boost of $\mathbb{B}_L$ to all non-radiated real FS momenta.
 \end{enumerate}
 This way, all components of [[p_real]] are constructed in the real Lab frame.
 <<PHS fks: phs fks generator: TBP>>=
   procedure :: generate_isr => phs_fks_generator_generate_isr
 <<PHS fks: sub interfaces>>=
     module subroutine phs_fks_generator_generate_isr &
          (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(out), dimension(:) :: p_real
     end subroutine phs_fks_generator_generate_isr
 <<PHS fks: procedures>>=
   module subroutine phs_fks_generator_generate_isr &
        (generator, i_phs, p_born, p_real)
     !!! Important: Import Born 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(out), 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)
 
     !!! Fraction of momentum fractions in a collinear splitting
     generator%isr_kinematics%z(I_PLUS) = (one - xi_plus)
     generator%isr_kinematics%z(I_MINUS) = (one - xi_minus)
 
     !!! Create radiation momentum in the real CMS
     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
 
     !!! Boosts the radiation from real CMS to the real LAB frame
     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-xi) 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: sub interfaces>>=
     module subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts)
       class(phs_fks_generator_t), intent(inout) :: generator
       real(default), intent(in) :: sqrts
     end subroutine phs_fks_generator_set_sqrts_hat
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_generator_set_emitters (generator, emitters)
       class(phs_fks_generator_t), intent(inout) :: generator
       integer, intent(in), dimension(:), allocatable ::  emitters
     end subroutine phs_fks_generator_set_emitters
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_generator_setup_masses (generator, n_tot)
       class(phs_fks_generator_t), intent(inout) :: generator
       integer, intent(in) :: n_tot
     end subroutine phs_fks_generator_setup_masses
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_generator_set_xi_and_y_bounds &
          (generator, fks_xi_min, fks_y_max)
       class(phs_fks_generator_t), intent(inout) :: generator
       real(default), intent(in), optional :: fks_xi_min, fks_y_max
     end subroutine phs_fks_generator_set_xi_and_y_bounds
 <<PHS fks: procedures>>=
   module subroutine phs_fks_generator_set_xi_and_y_bounds &
        (generator, fks_xi_min, fks_y_max)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in), optional :: fks_xi_min, fks_y_max
     real(default) :: xi_min, y_max
     xi_min = zero; y_max = one
     if (present (fks_xi_min)) xi_min = fks_xi_min
     if (present (fks_y_max)) y_max = fks_y_max
     generator%xi_min = min (one, max (xi_min, tiny_07))
     generator%y_max = min (abs (y_max), one)
   end subroutine phs_fks_generator_set_xi_and_y_bounds
 
 @ %def phs_fks_generator_set_xi_and_y_bounds
 @ Sets [[x]] in the [[isr_kinematics]] of the generator.
 <<PHS fks: phs fks generator: TBP>>=
   procedure :: set_isr_kinematics => phs_fks_generator_set_isr_kinematics
 <<PHS fks: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_set_isr_kinematics
 <<PHS fks: procedures>>=
   module 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
     if (allocated (generator%isr_kinematics%beam_energy)) then
        select case (size (generator%isr_kinematics%beam_energy))
        case (1)
           generator%isr_kinematics%x = p%p(0) / &
                generator%isr_kinematics%beam_energy(1)
        case (2)
           generator%isr_kinematics%x = p%p(0) / &
                generator%isr_kinematics%beam_energy
        end select
     else
        generator%isr_kinematics%x = 0
     end if
   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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_generate_radiation_variables
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_xi_ref_momenta
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold
 <<PHS fks: procedures>>=
   module 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_threshold
 @
 <<PHS fks: phs fks generator: TBP>>=
   procedure :: compute_cms_energy => phs_fks_generator_compute_cms_energy
 <<PHS fks: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_cms_energy
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_xi_max
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_xi_max_isr_factorized
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_set_masses
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine compute_y_from_emitter
 <<PHS fks: procedures>>=
   module 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_max
        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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_y_real_phs
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_compute_y_mismatch
 <<PHS fks: procedures>>=
   module 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) * generator%y_max
     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: sub interfaces>>=
     module subroutine phs_fks_generator_compute_y_test (generator, y)
       class(phs_fks_generator_t), intent(inout) :: generator
       real(default), intent(out), dimension(:):: y
     end subroutine phs_fks_generator_compute_y_test
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     pure module function beta_emitter (q0, p) result (beta)
       real(default), intent(in) :: q0
       type(vector4_t), intent(in) :: p
       real(default) :: beta
     end function beta_emitter
 <<PHS fks: procedures>>=
   pure module 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: sub interfaces>>=
     pure module subroutine phs_fks_generator_compute_xi_tilde (generator, r)
       class(phs_fks_generator_t), intent(inout) :: generator
       real(default), intent(in) :: r
     end subroutine phs_fks_generator_compute_xi_tilde
 <<PHS fks: procedures>>=
   pure module 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: sub interfaces>>=
     module 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
     end subroutine phs_fks_generator_prepare_generation
 <<PHS fks: procedures>>=
   module 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 &
          (generator%real_kinematics%p_born_lab%phs_point(1)%get (), &
          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: sub interfaces>>=
     module 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(out), dimension(:) :: p_real
     end subroutine phs_fks_generator_generate_fsr_from_xi_and_y
 <<PHS fks: procedures>>=
   module 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(out), 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
 @ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and
 generate the ISR phase space.
 For this, we need to overwrite all variables of the real kinematics
 dependent on $(\xi,y,\phi)$ that we need to compute [[p_real]].
 From the [[isr_kinematics]] we just need [[sqme_born]] and [[x]].
 Both do not depend on the real radiation so we can leave them as they are.
 <<PHS fks: phs fks generator: TBP>>=
   procedure :: generate_isr_from_xi_and_y => &
      phs_fks_generator_generate_isr_from_xi_and_y
 <<PHS fks: sub interfaces>>=
     module subroutine phs_fks_generator_generate_isr_from_xi_and_y &
          (generator, xi, xi_max, y, phi, i_phs, p_born, p_real)
       class(phs_fks_generator_t), intent(inout) :: generator
       real(default), intent(in) :: xi, xi_max, y, phi
       integer, intent(in) :: i_phs
       type(vector4_t), intent(in), dimension(:) :: p_born
       type(vector4_t), intent(out), dimension(:) :: p_real
     end subroutine phs_fks_generator_generate_isr_from_xi_and_y
 <<PHS fks: procedures>>=
   module subroutine phs_fks_generator_generate_isr_from_xi_and_y &
        (generator, xi, xi_max, y, phi, i_phs, p_born, p_real)
     class(phs_fks_generator_t), intent(inout) :: generator
     real(default), intent(in) :: xi, xi_max, y, phi
     integer, intent(in) :: i_phs
     type(vector4_t), intent(in), dimension(:) :: p_born
     type(vector4_t), intent(out), dimension(:) :: p_real
     associate (rad_var => generator%real_kinematics)
        rad_var%xi_max(i_phs) = xi_max
        rad_var%xi_tilde = xi / xi_max
        rad_var%y(i_phs) = y
        rad_var%phi = phi
     end associate
     call generator%generate_isr (i_phs, p_born, p_real)
   end subroutine phs_fks_generator_generate_isr_from_xi_and_y
 
 @ %def phs_fks_generator_generate_isr_from_xi_and_y
 @
 <<PHS fks: phs fks generator: TBP>>=
   procedure :: get_radiation_variables => &
      phs_fks_generator_get_radiation_variables
 <<PHS fks: sub interfaces>>=
     pure module 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
     end subroutine phs_fks_generator_get_radiation_variables
 <<PHS fks: procedures>>=
   pure module 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: sub interfaces>>=
     module subroutine phs_fks_generator_write (generator, unit)
       class(phs_fks_generator_t), intent(in) :: generator
       integer, intent(in), optional :: unit
     end subroutine phs_fks_generator_write
 <<PHS fks: procedures>>=
   module 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: sub interfaces>>=
     module subroutine phs_fks_compute_isr_kinematics (phs, r)
       class(phs_fks_t), intent(inout) :: phs
       real(default), intent(in) :: r
     end subroutine phs_fks_compute_isr_kinematics
 <<PHS fks: procedures>>=
   module subroutine phs_fks_compute_isr_kinematics (phs, r)
     class(phs_fks_t), intent(inout) :: phs
     real(default), intent(in) :: r
     if (.not. phs%config%lab_is_cm) 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: sub interfaces>>=
     module subroutine phs_fks_final (object)
       class(phs_fks_t), intent(inout) :: object
     end subroutine phs_fks_final
 <<PHS fks: procedures>>=
   module subroutine phs_fks_final (object)
     class(phs_fks_t), intent(inout) :: object
     call object%forest%final ()
     call object%generator%final ()
   end subroutine phs_fks_final
 
 @ %def phs_fks_final
 @
 <<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: public>>=
   public :: get_filtered_resonance_histories
 <<PHS fks: sub interfaces>>=
     module 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
     end subroutine get_filtered_resonance_histories
 <<PHS fks: procedures>>=
   module 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 phs_points, only: assignment(=)
 
   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_xi_and_y_bounds ()
 
     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
     allocate (generator%isr_kinematics%beam_energy(2))
     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
     call generator%set_xi_and_y_bounds ()
     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
     call generator%set_xi_and_y_bounds ()
 
     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_xi_and_y_bounds ()
 
     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, pb1
     type(vector4_t), dimension(:), allocatable :: p_born_onshell, pb1_os
     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
     call generator%set_xi_and_y_bounds ()
 
     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_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:"
     pb1 = generator%real_kinematics%p_born_cms%phs_point(1)
     call threshold_projection_born (mtop, L_to_cms, pb1, p_born_onshell)
     generator%real_kinematics%p_born_onshell%phs_point(1) = p_born_onshell
 
     call generator%real_kinematics%p_born_onshell%write &
         (1, unit = u, testflag = .true., ultra = .true.)
 
     pb1_os = generator%real_kinematics%p_born_onshell%phs_point(1)
     call check_phsp (pb1_os, 0)
 
     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
     call generator%set_xi_and_y_bounds ()
 
     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
     call generator%set_xi_and_y_bounds ()
     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 variables, only: var_list_t
   use os_interface, only: os_data_t
 
   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
 
 <<Standard module head>>
 
 <<Dispatch phs: public>>
 
   interface
 <<Dispatch phs: sub interfaces>>
   end interface
 
 end module dispatch_phase_space
 @ %def dispatch_phase_space
 @
 <<[[dispatch_phase_space_sub.f90]]>>=
 <<File header>>
 
 submodule (dispatch_phase_space) dispatch_phase_space_s
 
   use io_units, only: free_unit
   use diagnostics
   use phs_none
   use phs_single
   use phs_rambo
   use phs_wood
   use phs_fks
 
   implicit none
 
 contains
 
 <<Dispatch phs: procedures>>
 
 end submodule dispatch_phase_space_s
 
 @ %def dispatch_phase_space_s
 @
 Allocate a phase-space object according to the variable [[$phs_method]].
 <<Dispatch phs: public>>=
   public :: dispatch_phs
 <<Dispatch phs: sub interfaces>>=
     module 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
     end subroutine dispatch_phs
 <<Dispatch phs: procedures>>=
   module 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)
        if (use_equivalences) then
           select type (phs)
           type is (phs_fks_config_t)
              call phs%enable_equivalences ()
           end select
        end if
     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: sub interfaces>>=
     module 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
     end subroutine dispatch_sf_channels
 <<Dispatch phs: procedures>>=
   module 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
 @
Index: trunk/share/tests/functional_tests/ref-output-ext/resonances_13.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output-ext/resonances_13.ref	(revision 8865)
+++ trunk/share/tests/functional_tests/ref-output-ext/resonances_13.ref	(revision 8866)
@@ -1,275 +1,275 @@
 ?openmp_logging = false
 ?vis_history = false
 ?integration_timer = false
 ?pacify = true
 seed = 0
 ?resonance_history = true
 resonance_on_shell_limit =  4.00000E+00
 | Process library 'resonances_13_lib': recorded process 'resonances_13_p'
 sqrts =  9.20000E+01
 openmp_num_threads = 1
 | Integrate: current process library needs compilation
 | Process library 'resonances_13_lib': compiling ...
 | Process library 'resonances_13_lib': writing makefile
 | Process library 'resonances_13_lib': removing old files
 | Process library 'resonances_13_lib': writing driver
 | Process library 'resonances_13_lib': creating source code
 | Process library 'resonances_13_lib': compiling sources
 | Process library 'resonances_13_lib': linking
 | Process library 'resonances_13_lib': loading
 | Process library 'resonances_13_lib': ... success.
 | Integrate: compilation done
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 0
 | Initializing integration for process resonances_13_p:
 | Beam structure: e-, e+ => isr
 | Beam data (collision):
 |   e-  (mass = 5.1099700E-04 GeV)
 |   e+  (mass = 5.1099700E-04 GeV)
 |   sqrts = 9.200000000000E+01 GeV
 | Phase space: generating configuration ...
 | Phase space: ... success.
 | Phase space: writing configuration file 'resonances_13_p.i1.phs'
 | ------------------------------------------------------------------------
 | Process [scattering]: 'resonances_13_p'
 |   Library name  = 'resonances_13_lib'
 |   Process index = 1
 |   Process components:
 |     1: 'resonances_13_p_i1':   e-, e+ => mu-, mu+ [omega]
 | ------------------------------------------------------------------------
 | Phase space: 2 channels, 2 dimensions
 | Phase space: found 2 channels, collected in 2 groves.
 | Phase space: Using 2 equivalences between channels.
 | Phase space: wood
 | Beam structure: isr, none => none, isr
 | Beam structure: 2 channels, 2 dimensions
 Warning: No cuts have been defined.
 | Starting integration for process 'resonances_13_p'
 | Integrate: iterations = 3:1000:"gw", 1:1000
 | Integrator: 2 chains, 2 channels, 4 dimensions
 | Integrator: Using VAMP channel equivalences
 | Integrator: 1000 initial calls, 20 bins, stratified = T
 | Integrator: VAMP
 |=============================================================================|
 | It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
 |=============================================================================|
    1       1000     1.348E+06   4.37E+04    3.24    1.03     8.9
    2        999     1.251E+06   1.98E+04    1.58    0.50    45.3
    3        998     1.227E+06   1.04E+04    0.85    0.27    53.4
 |-----------------------------------------------------------------------------|
    3       2997     1.237E+06   9.01E+03    0.73    0.40    53.4    3.99   3
 |-----------------------------------------------------------------------------|
    4        998     1.245E+06   1.02E+04    0.82    0.26    46.0
 |-----------------------------------------------------------------------------|
    4        998     1.245E+06   1.02E+04    0.82    0.26    46.0
 |=============================================================================|
 n_events = 1
 | Particle mu- declared as polarized
 | Particle mu+ declared as polarized
 ?polarized_events = false
 $sample = "resonances_13_a"
 | Starting simulation for process 'resonances_13_p'
 | Simulate: using integration grids from file 'resonances_13_p.m1.vg'
 | Creating library for resonant subprocesses 'resonances_13_p_R'
 | Process library 'resonances_13_p_R': initialized
 | Resonant subprocess #1: 3+4~Z
 | Process library 'resonances_13_p_R': recorded process 'resonances_13_p_R1'
 | Process library 'resonances_13_p_R': compiling ...
 | Process library 'resonances_13_p_R': writing makefile
 | Process library 'resonances_13_p_R': removing old files
 | Process library 'resonances_13_p_R': writing driver
 | Process library 'resonances_13_p_R': creating source code
 | Process library 'resonances_13_p_R': compiling sources
 | Process library 'resonances_13_p_R': linking
 | Process library 'resonances_13_p_R': loading
 | Process library 'resonances_13_p_R': ... success.
 | Simulate: initializing resonant subprocess 'resonances_13_p_R1'
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 1
 | Initializing integration for process resonances_13_p_R1:
 | Beam structure: e-, e+ => isr
 | Beam data (collision):
 |   e-  (mass = 5.1099700E-04 GeV)
 |   e+  (mass = 5.1099700E-04 GeV)
 |   sqrts = 9.200000000000E+01 GeV
 | ------------------------------------------------------------------------
 | Process [scattering]: 'resonances_13_p_R1'
 |   Library name  = 'resonances_13_p_R'
 |   Process index = 1
 |   Process components:
 |     1: 'resonances_13_p_R1_i1':   e-, e+ => mu-, mu+ [omega]
 | ------------------------------------------------------------------------
 | Phase space: none
 | Beam structure: isr, none => none, isr
 | Beam structure: 1 channels, 2 dimensions
 Warning: No cuts have been defined.
 | Simulate: activating resonance insertion
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 2
 | Simulation: requested number of events = 1
 |             corr. to luminosity [fb-1] =   8.0313E-07
 | Events: writing to event dump file 'resonances_13_a.pset.dat'
 | Events: writing to raw file 'resonances_13_a.evx'
 | Events: generating 1 unweighted, unpolarized events ...
 | Events: event normalization mode '1'
 |         ... event sample complete.
 | Events: actual unweighting efficiency = 100.00 %
 | Events: closing event dump file 'resonances_13_a.pset.dat'
 | Events: closing raw file 'resonances_13_a.evx'
 ?polarized_events = true
 $sample = "resonances_13_b"
 | Starting simulation for process 'resonances_13_p'
 | Simulate: using integration grids from file 'resonances_13_p.m1.vg'
 | Using library for resonant subprocesses 'resonances_13_p_R'
 | Simulate: initializing resonant subprocess 'resonances_13_p_R1'
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 3
 | Initializing integration for process resonances_13_p_R1:
 | Beam structure: e-, e+ => isr
 | Beam data (collision):
 |   e-  (mass = 5.1099700E-04 GeV)
 |   e+  (mass = 5.1099700E-04 GeV)
 |   sqrts = 9.200000000000E+01 GeV
 | ------------------------------------------------------------------------
 | Process [scattering]: 'resonances_13_p_R1'
 |   Library name  = 'resonances_13_p_R'
 |   Process index = 1
 |   Process components:
 |     1: 'resonances_13_p_R1_i1':   e-, e+ => mu-, mu+ [omega]
 | ------------------------------------------------------------------------
 | Phase space: none
 | Beam structure: isr, none => none, isr
 | Beam structure: 1 channels, 2 dimensions
 Warning: No cuts have been defined.
 | Simulate: activating resonance insertion
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 4
 | Simulation: requested number of events = 1
 |             corr. to luminosity [fb-1] =   8.0313E-07
 | Events: writing to event dump file 'resonances_13_b.pset.dat'
 | Events: writing to raw file 'resonances_13_b.evx'
 | Events: generating 1 unweighted, polarized events ...
 | Events: event normalization mode '1'
 |         ... event sample complete.
 | Events: actual unweighting efficiency =  50.00 %
 | Events: closing event dump file 'resonances_13_b.pset.dat'
 | Events: closing raw file 'resonances_13_b.evx'
 | There were no errors and    3 warning(s).
 | WHIZARD run finished.
 |=============================================================================|
 Output of resonances_13_a.pset.dat:
 ========================================================================
  Event #1
 ========================================================================
  count  = 1
  passed = T
  prc id = 1
 ------------------------------------------------------------------------
  Particle set:
 ------------------------------------------------------------------------
  Particle 1 [b] f(11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00  4.600000E+01
  T =   2.611179340E-07
  Children: 3 5
  Particle 2 [b] f(-11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00 -4.600000E+01
  T =   2.611179340E-07
  Children: 4 6
  Particle 3 [i] f(11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00  4.600000E+01
  T =   2.611179340E-07
  Parents:  1
  Children: 7
  Particle 4 [i] f(-11)
  E =   4.599997E+01
  P =   0.000000E+00  0.000000E+00 -4.599997E+01
  T =   2.611179340E-07
  Parents:  2
  Children: 7
  Particle 5 [x] f(22*)
- E =   9.480951E-09
- P =   0.000000E+00  0.000000E+00  9.480951E-09
+ E =   9.481562E-09
+ P =   0.000000E+00  0.000000E+00  9.481562E-09
  T =   0.000000000E+00
  Parents:  1
  Particle 6 [x] f(22*)
- E =   3.282689E-05
- P =   0.000000E+00  0.000000E+00 -3.282689E-05
+ E =   3.282760E-05
+ P =   0.000000E+00  0.000000E+00 -3.282760E-05
  T =   0.000000000E+00
  Parents:  2
  Particle 7 [r] f(23)
  E =   9.199997E+01
- P =   0.000000E+00  0.000000E+00  3.281741E-05
+ P =   0.000000E+00  0.000000E+00  3.281812E-05
  T =   8.463993958E+03
  Parents:  3 4
  Children: 8 9
  Particle 8 [o] f(13)
  E =   4.599997E+01
- P =   2.507458E+01  1.750254E+01 -3.436441E+01
+ P =   2.507457E+01  1.750253E+01 -3.436442E+01
  T =   1.116369517E-02
  Parents:  7
  Particle 9 [o] f(-13)
  E =   4.600000E+01
- P =  -2.507458E+01 -1.750254E+01  3.436445E+01
+ P =  -2.507457E+01 -1.750253E+01  3.436445E+01
  T =   1.116369517E-02
  Parents:  7
 Output of resonances_13_b.pset.dat:
 ========================================================================
  Event #1
 ========================================================================
  count  = 1
  passed = T
  prc id = 1
 ------------------------------------------------------------------------
  Particle set:
 ------------------------------------------------------------------------
  Particle 1 [b] f(11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00  4.600000E+01
  T =   2.611179340E-07
  Children: 3 5
  Particle 2 [b] f(-11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00 -4.600000E+01
  T =   2.611179340E-07
  Children: 4 6
  Particle 3 [i] f(11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00  4.600000E+01
  T =   2.611179340E-07
  Parents:  1
  Children: 7
  Particle 4 [i] f(-11)
  E =   4.421868E+01
  P =   0.000000E+00  0.000000E+00 -4.421868E+01
  T =   2.611179340E-07
  Parents:  2
  Children: 7
  Particle 5 [x] f(22*)
- E =   5.767915E-09
- P =   0.000000E+00  0.000000E+00  5.767915E-09
+ E =   5.767822E-09
+ P =   0.000000E+00  0.000000E+00  5.767822E-09
  T =   0.000000000E+00
  Parents:  1
  Particle 6 [x] f(22*)
  E =   1.781323E+00
  P =   0.000000E+00  0.000000E+00 -1.781323E+00
  T =   0.000000000E+00
  Parents:  2
  Particle 7 [r] f(23)
  E =   9.021868E+01
  P =   0.000000E+00  0.000000E+00  1.781323E+00
- T =   8.136236588E+03
+ T =   8.136236566E+03
  Parents:  3 4
  Children: 8 9
  Particle 8 [o] f(13)h(-1)
  E =   4.470301E+01
  P =   1.872954E+01  3.549524E+01 -1.968859E+01
  T =   1.116369517E-02
  Parents:  7
  Particle 9 [o] f(-13)h(1)
  E =   4.551567E+01
  P =  -1.872954E+01 -3.549524E+01  2.146991E+01
  T =   1.116369517E-02
  Parents:  7
Index: trunk/share/tests/functional_tests/ref-output-ext/pythia6_3.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output-ext/pythia6_3.ref	(revision 8865)
+++ trunk/share/tests/functional_tests/ref-output-ext/pythia6_3.ref	(revision 8866)
@@ -1,757 +1,757 @@
 ?openmp_logging = false
 ?vis_history = false
 ?integration_timer = false
 ?pacify = true
 $method = "omega"
 | Process library 'pythia6_3_lib': recorded process 'pythia6_3_p1'
 SM.me =>  1.00000E+01
 | Process library 'pythia6_3_lib': compiling ...
 | Process library 'pythia6_3_lib': writing makefile
 | Process library 'pythia6_3_lib': removing old files
 | Process library 'pythia6_3_lib': writing driver
 | Process library 'pythia6_3_lib': creating source code
 | Process library 'pythia6_3_lib': compiling sources
 | Process library 'pythia6_3_lib': linking
 | Process library 'pythia6_3_lib': loading
 | Process library 'pythia6_3_lib': ... success.
 seed = 0
 $phs_method = "wood"
 $integration_method = "vamp"
 sqrts =  5.00000E+02
 openmp_num_threads = 1
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 0
 | Initializing integration for process pythia6_3_p1:
 | Beam structure: e-, e+ => circe1 => isr
 | Beam data (collision):
 |   e-  (mass = 1.0000000E+01 GeV)
 |   e+  (mass = 1.0000000E+01 GeV)
 |   sqrts = 5.000000000000E+02 GeV
 | CIRCE1: activating generator mode
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 1
 | Phase space: generating configuration ...
 | Phase space: ... success.
 | Phase space: writing configuration file 'pythia6_3_p1.i1.phs'
 | ------------------------------------------------------------------------
 | Process [scattering]: 'pythia6_3_p1'
 |   Library name  = 'pythia6_3_lib'
 |   Process index = 1
 |   Process components:
 |     1: 'pythia6_3_p1_i1':   e-, e+ => u, ubar [omega]
 | ------------------------------------------------------------------------
 | Phase space: 2 channels, 2 dimensions
 | Phase space: found 2 channels, collected in 2 groves.
 | Phase space: Using 2 equivalences between channels.
 | Phase space: wood
 | Beam structure: circe1 => isr, none => none, isr
 | Beam structure: 2 channels, 2 dimensions
 | Applying user-defined cuts.
 | Starting integration for process 'pythia6_3_p1'
 | Integrate: iterations = 3:1000:"g", 3:1000
 | Integrator: 2 chains, 2 channels, 4 dimensions
 | Integrator: Using VAMP channel equivalences
 | Integrator: 1000 initial calls, 20 bins, stratified = T
 | Integrator: VAMP
 |=============================================================================|
 | It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
 |=============================================================================|
    1       1000     6.612E+02   2.37E+01    3.58    1.13    22.4
    2       1000     6.567E+02   1.27E+01    1.94    0.61    36.6
    3       1000     6.521E+02   1.09E+01    1.67    0.53    36.1
 |-----------------------------------------------------------------------------|
    3       3000     6.548E+02   7.81E+00    1.19    0.65    36.1    0.08   3
 |-----------------------------------------------------------------------------|
    4       1000     6.726E+02   1.02E+01    1.52    0.48    31.0
    5       1000     6.538E+02   1.15E+01    1.76    0.56    25.4
    6       1000     6.639E+02   1.11E+01    1.66    0.53    24.9
 |-----------------------------------------------------------------------------|
    6       3000     6.642E+02   6.28E+00    0.95    0.52    24.9    0.74   3
 |=============================================================================|
 n_events = 1
 ?debug_decay = false
 ?debug_process = false
 ?debug_verbose = false
 ?sample_pacify = true
 ?allow_shower = true
 ?ps_fsr_active = true
 $shower_method = "PYTHIA6"
 $sample = "pythia6_3a"
 | Starting simulation for process 'pythia6_3_p1'
 | Simulate: using integration grids from file 'pythia6_3_p1.m1.vg'
 | Simulate: activating parton shower
 | Shower: Using PYTHIA6 shower
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 2
 | Simulation: requested number of events = 1
 |             corr. to luminosity [fb-1] =   1.5056E-03
 | Events: writing to ASCII file 'pythia6_3a.debug'
 | Events: writing to raw file 'pythia6_3a.evx'
 | Events: generating 1 unweighted, unpolarized events ...
 | Events: event normalization mode '1'
 |         ... event sample complete.
 | Events: actual unweighting efficiency =  12.50 %
 | Events: closing ASCII file 'pythia6_3a.debug'
 | Events: closing raw file 'pythia6_3a.evx'
 ?hadronization_active = true
 $sample = "pythia6_3b"
 | Starting simulation for process 'pythia6_3_p1'
 | Simulate: using integration grids from file 'pythia6_3_p1.m1.vg'
 | Simulate: activating parton shower
 | Shower: Using PYTHIA6 shower
 | Simulate: activating hadronization
 | Hadronization: Using PYTHIA6 interface for hadronization and decays
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 3
 | Simulation: requested number of events = 1
 |             corr. to luminosity [fb-1] =   1.5056E-03
 | Events: writing to ASCII file 'pythia6_3b.debug'
 | Events: writing to raw file 'pythia6_3b.evx'
 | Events: generating 1 unweighted, unpolarized events ...
 | Events: event normalization mode '1'
 |         ... event sample complete.
 | Events: actual unweighting efficiency =  50.00 %
 | Events: closing ASCII file 'pythia6_3b.debug'
 | Events: closing raw file 'pythia6_3b.evx'
 | WHIZARD run finished.
 |=============================================================================|
 Partial contents of pythia6_3a.debug:
 ========================================================================
  Event #1
 ------------------------------------------------------------------------
    Unweighted         = T
    Normalization      = '1'
    Helicity handling  = drop
    Keep correlations  = F
 ------------------------------------------------------------------------
    Squared matrix el. (ref) =  2.93612E+15
    Squared matrix el. (prc) =  2.93612E+15
    Event weight (ref)       =  1.00000E+00
    Event weight (prc)       =  1.00000E+00
 ------------------------------------------------------------------------
    Selected MCI group = 1
    Selected term      = 1
    Selected channel   = 1
 ------------------------------------------------------------------------
    Passed selection   = T
    Reweighting factor =  1.00000E+00
    Analysis flag      = T
 ========================================================================
  Event transform: trivial (hard process)
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 2
      calls = 3
    Number of tries = 1
 ------------------------------------------------------------------------
  Particle set:
 ------------------------------------------------------------------------
  Particle 1 [b] f(11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00  2.497999E+02
  T =   1.000000000E+02
  Children: 3 4
  Particle 2 [b] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Children: 3 4
  Particle 3 [v] f(11)
  E =   2.476793E+02
  P =   0.000000E+00  0.000000E+00  2.474773E+02
  T =   1.000000000E+02
  Parents:  1 2
  Children: 5 7
  Particle 4 [v] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Parents:  1 2
  Children: 6 8
  Particle 5 [i] f(11)
  E =   1.816946E+02
  P =   0.000000E+00  0.000000E+00  1.814192E+02
  T =   1.000000000E+02
  Parents:  3
  Children: 9 10
  Particle 6 [i] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Parents:  4
  Children: 9 10
  Particle 7 [x] f(22*)
  E =   6.605811E+01
  P =   0.000000E+00  0.000000E+00  6.605811E+01
  T =   0.000000000E+00
  Parents:  3
  Particle 8 [x] f(22*)
  E =   1.063882E-18
  P =   0.000000E+00  0.000000E+00 -1.063882E-18
  T =   0.000000000E+00
  Parents:  4
  Particle 9 [o] f(2)c(1 )
  E =   1.994960E+02
  P =  -2.038944E+01 -1.860559E+02  6.903719E+01
  T =   0.000000000E+00
  Parents:  5 6
  Particle 10 [o] f(-2)c(-1 )
  E =   2.321986E+02
  P =   2.038944E+01  1.860559E+02 -1.374179E+02
  T =   0.000000000E+00
  Parents:  5 6
 ========================================================================
 ========================================================================
  Event transform: shower
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 3
      calls = 1
    Number of tries = 1
  Particle set:
 ------------------------------------------------------------------------
   Nr Status  Flavor  Col ACol              Parents             Children         P(0)         P(1)         P(2)         P(3)          P^2
    1    [b]      e-    0    0               [none]                  3-4      250.000        0.000        0.000      249.800      100.000
    2    [b]      e+    0    0               [none]                  3-4      250.000        0.000        0.000     -249.800      100.000
    3    [r]      e-    0    0                  1-2                  5,7      247.679        0.000        0.000      247.477      100.000
    4    [r]      e+    0    0                  1-2                  6,8      250.000        0.000        0.000     -249.800      100.000
    5    [i]      e-    0    0                    3                 9-10      181.695        0.000        0.000      181.419      100.000
    6    [i]      e+    0    0                    4                 9-10      250.000        0.000        0.000     -249.800      100.000
    7    [x]       A    0    0                    3               [none]       66.058        0.000        0.000       66.058        0.000
    8    [x]       A    0    0                    4               [none]        0.000        0.000        0.000       -0.000        0.000
    9    [r]       u    1    0                  5-6                18-28      199.496      -20.389     -186.056       69.037        0.000
   10    [r]    ubar    0    1                  5-6                11-17      232.199       20.389      186.056     -137.418        0.000
   11    [o]    ubar    0  500                   10               [none]       17.841        0.835       15.017       -9.596        0.000
   12    [o]      gl  500  501                   10               [none]        6.032       -0.227        5.313       -2.848        0.000
   13    [o]      gl  501  502                   10               [none]        2.657        0.140        1.996       -1.748        0.000
   14    [o]      gl  502  503                   10               [none]        6.248        0.663        4.791       -3.955        0.000
   15    [o]      gl  503  504                   10               [none]       40.323        4.179       31.764      -24.485        0.000
   16    [o]      gl  504  505                   10               [none]       71.139        6.390       57.012      -42.067        0.000
   17    [o]      gl  505  506                   10               [none]       59.971        5.932       47.552      -36.057        0.000
   18    [o]      gl  506  507                    9               [none]        1.832       -1.515       -0.920        0.462        0.000
   19    [o]      gl  507  508                    9               [none]        0.982       -0.069       -0.980       -0.022        0.000
   20    [o]      gl  508  509                    9               [none]        2.047       -1.584       -0.573       -1.163        0.000
   21    [o]      gl  509  510                    9               [none]        9.757       -8.611       -1.046       -4.467        0.000
   22    [o]      gl  510  511                    9               [none]       31.749      -27.254       -1.890      -16.175        0.000
   23    [o]      gl  511  512                    9               [none]        1.145       -1.075        0.159       -0.360        0.000
   24    [o]      gl  512  513                    9               [none]        2.337       -1.921       -0.890       -0.991        0.000
   25    [o]      gl  513  514                    9               [none]        1.913       -1.459       -1.204        0.283        0.000
   26    [o]      gl  514  515                    9               [none]        8.198        2.070       -5.298        5.904        0.000
   27    [o]      gl  515  516                    9               [none]       84.260       13.920      -75.989       33.641        0.000
   28    [o]       u  516    0                    9               [none]       83.263        9.587      -74.816       35.262        0.000
 ------------------------------------------------------------------------
 Sum of incoming momenta: p(0:3) =          431.695        0.000        0.000      -68.381 
 Sum of beam remnant momenta: p(0:3) =       66.058        0.000        0.000       66.058 
 Sum of outgoing momenta: p(0:3) =          431.695        0.000        0.000      -68.381 
 ------------------------------------------------------------------------
  Shower settings:
 ------------------------------------------------------------------------
  Master switches:
    ps_isr_active                =  F
    ps_fsr_active                =  T
    ps_tau_dec                   =  F
    muli_active                  =  F
    hadronization_active         =  F
  General settings:
    method                       =  PYTHIA6
    shower_verbose               =  F
    ps_mass_cutoff               =  1.000000000000E+00
    ps_max_n_flavors             =  5
     [ISR off]
  FSR settings:
    ps_fsr_lambda                =  2.900000000000E-01
    ps_fsr_alphas_running        =  T
  Matching Settings:
    mlm_matching                 =  F
    ckkw_matching                =  F
  PYTHIA6 specific settings:
    ps_PYTHIA_PYGIVE             = ''
  PYTHIA8 specific settings:
    ps_PYTHIA8_config            = ''
    ps_PYTHIA8_config_file       = ''
 ========================================================================
  Local variables:
 ------------------------------------------------------------------------
 sqrts* =  5.00000E+02
 sqrts_hat* =>  4.26244E+02
 n_in* => 2
 n_out* => 20
 n_tot* => 22
 $process_id* => "pythia6_3_p1"
 process_num_id* => [unknown integer]
 sqme* =>  2.93612E+15
 sqme_ref* =>  2.93612E+15
 event_index* => 1
 event_weight* =>  1.00000E+00
 event_weight_ref* =>  1.00000E+00
 event_excess* =>  0.00000E+00
 ------------------------------------------------------------------------
  subevent:
  1 prt(b:11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00,-2.4979992E+02| 1.0000000E+02| 1)
  2 prt(b:-11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00, 2.4979992E+02| 1.0000000E+02| 2)
  3 prt(i:11|-1.8169462E+02; 0.0000000E+00, 0.0000000E+00,-1.8141923E+02| 1.0000000E+02| 3)
  4 prt(i:-11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00, 2.4979992E+02| 1.0000000E+02| 4)
  5 prt(o:22| 6.6058108E+01; 0.0000000E+00, 0.0000000E+00, 6.6058108E+01| 0.0000000E+00| 5)
  6 prt(o:22| 0.0000000E+00; 0.0000000E+00, 0.0000000E+00, 0.0000000E+00| 0.0000000E+00| 6)
  7 prt(o:-2| 1.7840634E+01; 8.3460447E-01, 1.5017223E+01,-9.5955541E+00| 0.0000000E+00| 7)
  8 prt(o:21| 6.0324718E+00;-2.2699804E-01, 5.3129592E+00,-2.8480962E+00| 0.0000000E+00| 8)
  9 prt(o:21| 2.6573876E+00; 1.3984694E-01, 1.9963137E+00,-1.7483945E+00| 0.0000000E+00| 9)
  10 prt(o:21| 6.2479216E+00; 6.6348653E-01, 4.7913372E+00,-3.9546678E+00| 0.0000000E+00| 10)
  11 prt(o:21| 4.0323145E+01; 4.1788996E+00, 3.1764352E+01,-2.4485072E+01| 0.0000000E+00| 11)
  12 prt(o:21| 7.1138927E+01; 6.3899647E+00, 5.7011544E+01,-4.2066603E+01| 0.0000000E+00| 12)
  13 prt(o:21| 5.9970744E+01; 5.9318769E+00, 4.7552315E+01,-3.6056627E+01| 0.0000000E+00| 13)
  14 prt(o:21| 1.8317853E+00;-1.5147227E+00,-9.2045887E-01, 4.6239364E-01| 0.0000000E+00| 14)
  15 prt(o:21| 9.8227009E-01;-6.9130408E-02,-9.7957930E-01,-2.2358821E-02| 0.0000000E+00| 15)
  16 prt(o:21| 2.0468051E+00;-1.5841871E+00,-5.7297660E-01,-1.1625232E+00| 0.0000000E+00| 16)
  17 prt(o:21| 9.7571594E+00;-8.6110771E+00,-1.0456541E+00,-4.4674509E+00| 0.0000000E+00| 17)
  18 prt(o:21| 3.1749301E+01;-2.7254493E+01,-1.8895828E+00,-1.6175295E+01| 0.0000000E+00| 18)
  19 prt(o:21| 1.1445548E+00;-1.0747946E+00, 1.5857305E-01,-3.6010679E-01| 0.0000000E+00| 19)
  20 prt(o:21| 2.3373271E+00;-1.9208641E+00,-8.9002739E-01,-9.9057068E-01| 0.0000000E+00| 20)
  21 prt(o:21| 1.9130354E+00;-1.4594063E+00,-1.2039558E+00, 2.8342240E-01| 0.0000000E+00| 21)
  22 prt(o:21| 8.1983843E+00; 2.0701192E+00,-5.2980644E+00, 5.9041194E+00| 0.0000000E+00| 22)
  23 prt(o:21| 8.4260032E+01; 1.3919781E+01,-7.5988726E+01, 3.3640843E+01| 0.0000000E+00| 23)
  24 prt(o:2| 8.3262736E+01; 9.5870941E+00,-7.4815592E+01, 3.5261848E+01| 0.0000000E+00| 24)
 ========================================================================
 Partial contents of pythia6_3b.debug:
 ========================================================================
  Event #1
 ------------------------------------------------------------------------
    Unweighted         = T
    Normalization      = '1'
    Helicity handling  = drop
    Keep correlations  = F
 ------------------------------------------------------------------------
    Squared matrix el. (ref) =  1.50392E+33
    Squared matrix el. (prc) =  1.50392E+33
    Event weight (ref)       =  1.00000E+00
    Event weight (prc)       =  1.00000E+00
 ------------------------------------------------------------------------
    Selected MCI group = 1
    Selected term      = 1
    Selected channel   = 1
 ------------------------------------------------------------------------
    Passed selection   = T
    Reweighting factor =  1.00000E+00
    Analysis flag      = T
 ========================================================================
  Event transform: trivial (hard process)
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 6
      calls = 3
    Number of tries = 1
 ------------------------------------------------------------------------
  Particle set:
 ------------------------------------------------------------------------
  Particle 1 [b] f(11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00  2.497999E+02
  T =   1.000000000E+02
  Children: 3 4
  Particle 2 [b] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Children: 3 4
  Particle 3 [v] f(11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00  2.497999E+02
  T =   1.000000000E+02
  Parents:  1 2
  Children: 5 7
  Particle 4 [v] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Parents:  1 2
  Children: 6 8
  Particle 5 [i] f(11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00  2.497999E+02
  T =   1.000000000E+02
  Parents:  3
  Children: 9 10
  Particle 6 [i] f(-11)
  E =   2.448851E+02
  P =   0.000000E+00  0.000000E+00 -2.446809E+02
  T =   1.000000000E+02
  Parents:  4
  Children: 9 10
  Particle 7 [x] f(22*)
  E =   1.372454E-35
  P =   0.000000E+00  0.000000E+00  1.372454E-35
  T =   0.000000000E+00
  Parents:  3
  Particle 8 [x] f(22*)
  E =   5.119062E+00
  P =   0.000000E+00  0.000000E+00 -5.119062E+00
  T =   0.000000000E+00
  Parents:  4
  Particle 9 [o] f(2)c(1 )
  E =   2.482222E+02
  P =  -2.281888E+02  5.891499E+01  7.793054E+01
  T =   0.000000000E+00
  Parents:  5 6
  Particle 10 [o] f(-2)c(-1 )
  E =   2.466629E+02
  P =   2.281888E+02 -5.891499E+01 -7.281148E+01
  T =   0.000000000E+00
  Parents:  5 6
 ========================================================================
 ========================================================================
  Event transform: shower
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 7
      calls = 1
    Number of tries = 1
  Particle set:
 ------------------------------------------------------------------------
   Nr Status  Flavor  Col ACol              Parents             Children         P(0)         P(1)         P(2)         P(3)          P^2
    1    [b]      e-    0    0               [none]                  3-4      250.000        0.000        0.000      249.800      100.000
    2    [b]      e+    0    0               [none]                  3-4      250.000        0.000        0.000     -249.800      100.000
    3    [r]      e-    0    0                  1-2                  5,7      250.000        0.000        0.000      249.800      100.000
    4    [r]      e+    0    0                  1-2                  6,8      250.000        0.000        0.000     -249.800      100.000
    5    [i]      e-    0    0                    3                 9-10      250.000        0.000        0.000      249.800      100.000
    6    [i]      e+    0    0                    4                 9-10      244.885        0.000        0.000     -244.681      100.000
    7    [x]       A    0    0                    3               [none]        0.000        0.000        0.000        0.000        0.000
    8    [x]       A    0    0                    4               [none]        5.119        0.000        0.000       -5.119        0.000
    9    [r]       u    1    0                  5-6                18-24      248.222     -228.189       58.915       77.931        0.000
   10    [r]    ubar    0    1                  5-6          11-17,25-27      246.663      228.189      -58.915      -72.811        0.000
   11    [o]    ubar    0  500                   10               [none]       67.357       66.997        6.823        1.338        0.000
   12    [o]      gl  500  501                   10               [none]       11.047       10.915        1.575       -0.649        0.000
   13    [o]      gl  501  502                   10               [none]       11.146       11.016        1.691       -0.137        0.000
   14    [o]      gl  502  503                   10               [none]       21.964       21.568        3.720       -1.849        0.000
   15    [o]      gl  503  504                   10               [none]       12.944       11.841        2.560       -4.558        0.000
   16    [o]      gl  504  505                   10               [none]        3.236        2.996       -0.650       -1.036        0.000
   17    [o]       d  505    0                   10               [none]      115.187       79.739      -61.708      -55.693        0.109
   18    [o]       u  506    0                    9               [none]      103.402      -95.300       24.538       31.745        0.000
   19    [o]      gl  507  506                    9               [none]       91.901      -84.310       22.825       28.578        0.000
   20    [o]      gl  508  507                    9               [none]       25.417      -23.490        6.720        7.007        0.000
   21    [o]      gl  509  508                    9               [none]        5.099       -4.741        0.335        1.846        0.000
   22    [o]      gl  510  509                    9               [none]        3.435       -2.839        1.076        1.606        0.000
   23    [o]      gl  511  510                    9               [none]        6.122       -5.399        0.472        2.847        0.000
   24    [o]      gl  512  511                    9               [none]        0.284       -0.118       -0.149        0.211        0.000
   25    [o]      gl  513  512                   10               [none]        3.181        1.224       -2.448       -1.622        0.000
   26    [o]      gl  514  513                   10               [none]        5.206        4.057       -2.824       -1.632        0.000
   27    [o]    dbar    0  514                   10               [none]        7.958        5.843       -4.558       -2.882        0.109
 ------------------------------------------------------------------------
 Sum of incoming momenta: p(0:3) =          494.885        0.000        0.000        5.119 
 Sum of beam remnant momenta: p(0:3) =        5.119        0.000        0.000       -5.119 
 Sum of outgoing momenta: p(0:3) =          494.885        0.000        0.000        5.119 
 ------------------------------------------------------------------------
  Shower settings:
 ------------------------------------------------------------------------
  Master switches:
    ps_isr_active                =  F
    ps_fsr_active                =  T
    ps_tau_dec                   =  F
    muli_active                  =  F
    hadronization_active         =  T
  General settings:
    method                       =  PYTHIA6
    shower_verbose               =  F
    ps_mass_cutoff               =  1.000000000000E+00
    ps_max_n_flavors             =  5
     [ISR off]
  FSR settings:
    ps_fsr_lambda                =  2.900000000000E-01
    ps_fsr_alphas_running        =  T
  Matching Settings:
    mlm_matching                 =  F
    ckkw_matching                =  F
  PYTHIA6 specific settings:
    ps_PYTHIA_PYGIVE             = ''
  PYTHIA8 specific settings:
    ps_PYTHIA8_config            = ''
    ps_PYTHIA8_config_file       = ''
 ========================================================================
 ========================================================================
  Event transform: hadronization
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 9
      calls = 1
    Number of tries = 1
  Particle set:
 ------------------------------------------------------------------------
   Nr Status  Flavor  Col ACol              Parents             Children         P(0)         P(1)         P(2)         P(3)          P^2
    1    [b]      e-    0    0               [none]                  3-4      250.000        0.000        0.000      249.800      100.000
    2    [b]      e+    0    0               [none]                  3-4      250.000        0.000        0.000     -249.800      100.000
    3    [r]      e-    0    0                  1-2                  5,7      250.000        0.000        0.000      249.800      100.000
    4    [r]      e+    0    0                  1-2                  6,8      250.000        0.000        0.000     -249.800      100.000
    5    [i]      e-    0    0                    3                 9-10      250.000        0.000        0.000      249.800      100.000
    6    [i]      e+    0    0                    4                 9-10      244.885        0.000        0.000     -244.681      100.000
    7    [x]       A    0    0                    3               [none]        0.000        0.000        0.000        0.000        0.000
    8    [x]       A    0    0                    4               [none]        5.119        0.000        0.000       -5.119        0.000
    9    [r]       u    1    0                  5-6                18-24      248.222     -228.189       58.915       77.931        0.000
   10    [r]    ubar    0    1                  5-6          11-17,25-27      246.663      228.189      -58.915      -72.811        0.000
   11    [r]    ubar    0  500                   10                   28       67.357       66.997        6.823        1.338        0.000
   12    [r]      gl  500  501                   10                   28       11.047       10.915        1.575       -0.649        0.000
   13    [r]      gl  501  502                   10                   28       11.146       11.016        1.691       -0.137        0.000
   14    [r]      gl  502  503                   10                   28       21.964       21.568        3.720       -1.849        0.000
   15    [r]      gl  503  504                   10                   28       12.944       11.841        2.560       -4.558        0.000
   16    [r]      gl  504  505                   10                   28        3.236        2.996       -0.650       -1.036        0.000
   17    [r]       d  505    0                   10                   28      115.187       79.739      -61.708      -55.693        0.109
   18    [r]       u  506    0                    9                   43      103.402      -95.300       24.538       31.745        0.000
   19    [r]      gl  507  506                    9                   43       91.901      -84.310       22.825       28.578        0.000
   20    [r]      gl  508  507                    9                   43       25.417      -23.490        6.720        7.007        0.000
   21    [r]      gl  509  508                    9                   43        5.099       -4.741        0.335        1.846        0.000
   22    [r]      gl  510  509                    9                   43        3.435       -2.839        1.076        1.606        0.000
   23    [r]      gl  511  510                    9                   43        6.122       -5.399        0.472        2.847        0.000
   24    [r]      gl  512  511                    9                   43        0.284       -0.118       -0.149        0.211        0.000
   25    [r]      gl  513  512                   10                   43        3.181        1.224       -2.448       -1.622        0.000
   26    [r]      gl  514  513                   10                   43        5.206        4.057       -2.824       -1.632        0.000
   27    [r]    dbar    0  514                   10                   43        7.958        5.843       -4.558       -2.882        0.109
   28    [r]     hr3    0    0                11-17                29-42      242.880      205.072      -45.988      -62.585    10904.722
   29    [r]     eta    0    0                   28                61-62       46.261       46.022        4.643        0.467        0.300
   30    [r]    rhom    0    0                   28                63-64       21.989       21.860        2.220        0.469        0.503
   31    [o]     pip    0    0                   28               [none]       12.531       12.296        2.129       -1.131        0.019
   32    [o]     pim    0    0                   28               [none]        7.484        7.385        1.188        0.176        0.019
   33    [r] Deltaba    0    0                   28                65-66       13.176       12.996        1.548       -0.953        1.394
   34    [r]    rhom    0    0                   28                67-68        5.729        5.434        1.396       -0.884        0.559
   35    [r]  Delta0    0    0                   28                69-70       12.026       11.481        2.262       -2.494        1.474
   36    [r] etaprim    0    0                   28                71-73        5.769        5.402        0.821       -1.585        0.917
   37    [o]    nbar    0    0                   28               [none]        4.121        2.740       -2.146       -1.998        0.883
   38    [r]  lambda    0    0                   28                74-75       11.162        8.411       -5.246       -5.007        1.245
   39    [o]      kp    0    0                   28               [none]        2.239        1.529       -1.059       -1.144        0.244
   40    [r]    rhom    0    0                   28                76-77       29.728       20.577      -16.048      -14.231        0.285
   41    [r] etaprim    0    0                   28                78-79       31.116       21.617      -16.528      -15.060        0.917
   42    [r]   omega    0    0                   28                80-82       39.549       27.320      -21.169      -19.210        0.590
   43    [r]     hr3    0    0                18-27                44-60      252.005     -205.072       45.988       67.704    14753.285
   44    [r]  kstarp    0    0                   43                83-84       91.143      -83.758       22.325       28.147        0.846
   45    [r]      k0    0    0                   43                   85       58.028      -53.701       13.747       17.154        0.248
   46    [r]    rho0    0    0                   43                86-87       20.299      -18.491        5.060        6.609        0.852
   47    [r]      k0    0    0                   43                   88       21.384      -19.668        4.678        6.949        0.248
   48    [o]      km    0    0                   43               [none]       16.013      -14.682        4.375        4.634        0.244
   49    [r]    rhop    0    0                   43                89-90       14.432      -13.297        3.323        4.489        0.281
   50    [o]     pim    0    0                   43               [none]        2.473       -2.072        0.941        0.958        0.019
   51    [r]    rho0    0    0                   43                91-92        6.531       -5.860        0.784        2.602        0.928
   52    [r]     pi0    0    0                   43                93-94        1.708       -1.657        0.307        0.240        0.018
   53    [r]   omega    0    0                   43                95-97        1.815       -1.187        0.286        1.092        0.611
   54    [r]    rho0    0    0                   43                98-99        1.669       -1.426       -0.231        0.021        0.700
   55    [o]     pip    0    0                   43               [none]        0.718       -0.237       -0.652        0.119        0.019
   56    [r]    rhom    0    0                   43              100-101        1.673        1.124       -1.001       -0.339        0.416
   57    [r]  kstarp    0    0                   43              102-103        3.822        3.212       -1.671       -0.818        0.829
   58    [r]      k0    0    0                   43                  104        3.760        1.740       -2.527       -2.115        0.248
   59    [o]     pim    0    0                   43               [none]        2.447        1.809       -1.575       -0.463        0.019
   60    [o]     pip    0    0                   43               [none]        4.091        3.080       -2.180       -1.575        0.019
   61    [o]       A    0    0                   29               [none]       20.027       19.906        2.148        0.435        0.000
   62    [o]       A    0    0                   29               [none]       26.235       26.116        2.495        0.032        0.000
   63    [o]     pim    0    0                   30               [none]        5.683        5.630        0.750       -0.093        0.019
   64    [r]     pi0    0    0                   30              105-106       16.307       16.230        1.470        0.562        0.018
   65    [o]    nbar    0    0                   33               [none]        8.951        8.821        1.047       -0.562        0.883
   66    [o]     pip    0    0                   33               [none]        4.225        4.175        0.500       -0.391        0.019
   67    [o]     pim    0    0                   34               [none]        2.318        2.117        0.642       -0.678        0.019
   68    [r]     pi0    0    0                   34              107-108        3.411        3.317        0.754       -0.205        0.018
   69    [o]       p    0    0                   35               [none]        8.602        8.248        1.589       -1.600        0.880
   70    [o]     pim    0    0                   35               [none]        3.424        3.233        0.673       -0.893        0.019
   71    [o]     pim    0    0                   36               [none]        1.553        1.504        0.123       -0.338        0.019
   72    [o]     pip    0    0                   36               [none]        1.520        1.430        0.294       -0.401        0.019
   73    [r]     eta    0    0                   36              109-111        2.697        2.469        0.405       -0.846        0.300
   74    [o]       p    0    0                   38               [none]       10.130        7.615       -4.828       -4.522        0.880
   75    [o]     pim    0    0                   38               [none]        1.032        0.796       -0.418       -0.486        0.019
   76    [o]     pim    0    0                   40               [none]        2.712        1.835       -1.467       -1.348        0.019
   77    [r]     pi0    0    0                   40              112-113       27.016       18.742      -14.580      -12.883        0.018
   78    [o]       A    0    0                   41               [none]        3.573        2.496       -1.969       -1.630        0.000
   79    [r]    rho0    0    0                   41              114-115       27.543       19.121      -14.559      -13.430        0.680
   80    [o]     pim    0    0                   42               [none]       14.294        9.990       -7.402       -7.051        0.019
   81    [o]     pip    0    0                   42               [none]       16.069       11.022       -8.718       -7.792        0.019
   82    [r]     pi0    0    0                   42              116-117        9.185        6.308       -5.048       -4.366        0.018
   83    [r]      k0    0    0                   44                  118       28.784      -26.474        7.060        8.808        0.248
   84    [o]     pip    0    0                   44               [none]       62.359      -57.285       15.265       19.339        0.019
   85    [o]     kL0    0    0                   45               [none]       58.028      -53.701       13.747       17.154        0.248
   86    [o]     pim    0    0                   46               [none]       13.730      -12.649        3.050        4.380        0.019
   87    [o]     pip    0    0                   46               [none]        6.569       -5.842        2.010        2.229        0.019
   88    [r]     kS0    0    0                   47              119-120       21.384      -19.668        4.678        6.949        0.248
   89    [o]     pip    0    0                   49               [none]        3.943       -3.670        0.721        1.240        0.019
   90    [r]     pi0    0    0                   49              121-122       10.490       -9.627        2.603        3.249        0.018
   91    [o]     pim    0    0                   51               [none]        5.906       -5.432        0.527        2.253        0.019
   92    [o]     pip    0    0                   51               [none]        0.626       -0.428        0.257        0.350        0.019
   93    [o]       A    0    0                   52               [none]        0.348       -0.326        0.062        0.102        0.000
   94    [o]       A    0    0                   52               [none]        1.360       -1.331        0.245        0.138        0.000
   95    [o]     pip    0    0                   53               [none]        0.528       -0.291        0.231        0.349        0.019
   96    [o]     pim    0    0                   53               [none]        0.159       -0.021        0.059        0.045        0.019
   97    [r]     pi0    0    0                   53              123-124        1.127       -0.874       -0.004        0.698        0.018
   98    [o]     pip    0    0                   54               [none]        1.127       -1.083        0.081        0.266        0.019
   99    [o]     pim    0    0                   54               [none]        0.542       -0.342       -0.312       -0.245        0.019
  100    [o]     pim    0    0                   56               [none]        0.321        0.026       -0.250       -0.142        0.019
  101    [r]     pi0    0    0                   56              125-126        1.352        1.098       -0.750       -0.197        0.018
  102    [r]      k0    0    0                   57                  127        2.210        1.727       -1.221       -0.405        0.248
  103    [o]     pip    0    0                   57               [none]        1.612        1.485       -0.450       -0.412        0.019
  104    [r]     kS0    0    0                   58              128-129        3.760        1.740       -2.527       -2.115        0.248
  105    [o]       A    0    0                   64               [none]       15.070       14.997        1.380        0.548        0.000
  106    [o]       A    0    0                   64               [none]        1.237        1.233        0.091        0.014        0.000
  107    [o]       A    0    0                   68               [none]        1.147        1.101        0.304       -0.106        0.000
  108    [o]       A    0    0                   68               [none]        2.263        2.216        0.450       -0.099        0.000
  109    [r]     pi0    0    0                   73              130-131        0.659        0.614        0.164       -0.113        0.018
  110    [r]     pi0    0    0                   73              132-133        0.593        0.545        0.116       -0.153        0.018
  111    [r]     pi0    0    0                   73              134-135        1.444        1.310        0.125       -0.580        0.018
  112    [o]       A    0    0                   77               [none]       25.723       17.861      -13.859      -12.272        0.000
  113    [o]       A    0    0                   77               [none]        1.292        0.881       -0.721       -0.611        0.000
  114    [o]     pim    0    0                   79               [none]       26.657       18.540      -14.088      -12.975        0.019
  115    [o]     pip    0    0                   79               [none]        0.886        0.581       -0.471       -0.455        0.019
  116    [o]       A    0    0                   82               [none]        7.813        5.360       -4.331       -3.683        0.000
  117    [o]       A    0    0                   82               [none]        1.372        0.948       -0.718       -0.683        0.000
  118    [o]     kL0    0    0                   83               [none]       28.784      -26.474        7.060        8.808        0.248
  119    [o]     pip    0    0                   88               [none]        4.788       -4.345        1.169        1.629        0.019
  120    [o]     pim    0    0                   88               [none]       16.596      -15.323        3.509        5.320        0.019
  121    [o]       A    0    0                   90               [none]        7.131       -6.520        1.805        2.254        0.000
  122    [o]       A    0    0                   90               [none]        3.359       -3.108        0.798        0.995        0.000
  123    [o]       A    0    0                   97               [none]        0.132       -0.081        0.034        0.099        0.000
  124    [o]       A    0    0                   97               [none]        0.995       -0.793       -0.037        0.599        0.000
  125    [o]       A    0    0                  101               [none]        0.486        0.370       -0.288       -0.128        0.000
  126    [o]       A    0    0                  101               [none]        0.865        0.728       -0.462       -0.070        0.000
  127    [o]     kL0    0    0                  102               [none]        2.210        1.727       -1.221       -0.405        0.248
  128    [r]     pi0    0    0                  104              136-137        1.531        0.572       -0.991       -1.007        0.018
  129    [r]     pi0    0    0                  104              138-139        2.229        1.168       -1.536       -1.107        0.018
  130    [o]       A    0    0                  109               [none]        0.210        0.206       -0.010       -0.037        0.000
  131    [o]       A    0    0                  109               [none]        0.450        0.407        0.174       -0.077        0.000
  132    [o]       A    0    0                  110               [none]        0.538        0.516        0.072       -0.135        0.000
  133    [o]       A    0    0                  110               [none]        0.055        0.029        0.043       -0.018        0.000
  134    [o]       A    0    0                  111               [none]        0.766        0.722        0.070       -0.246        0.000
  135    [o]       A    0    0                  111               [none]        0.678        0.588        0.055       -0.334        0.000
  136    [o]       A    0    0                  128               [none]        1.499        0.561       -0.962       -1.003        0.000
  137    [o]       A    0    0                  128               [none]        0.032        0.011       -0.030       -0.004        0.000
  138    [o]       A    0    0                  129               [none]        0.802        0.470       -0.511       -0.401        0.000
  139    [o]       A    0    0                  129               [none]        1.426        0.698       -1.024       -0.706        0.000
 ------------------------------------------------------------------------
 Sum of incoming momenta: p(0:3) =          494.885        0.000        0.000        5.119 
 Sum of beam remnant momenta: p(0:3) =        5.119        0.000        0.000       -5.119 
 Sum of outgoing momenta: p(0:3) =          494.885        0.000        0.000        5.119 
 ------------------------------------------------------------------------
  Shower settings:
 ------------------------------------------------------------------------
  Master switches:
    ps_isr_active                =  F
    ps_fsr_active                =  T
    ps_tau_dec                   =  F
    muli_active                  =  F
    hadronization_active         =  T
  General settings:
    method                       =  PYTHIA6
    shower_verbose               =  F
    ps_mass_cutoff               =  1.000000000000E+00
    ps_max_n_flavors             =  5
     [ISR off]
  FSR settings:
    ps_fsr_lambda                =  2.900000000000E-01
    ps_fsr_alphas_running        =  T
  Matching Settings:
    mlm_matching                 =  F
    ckkw_matching                =  F
  PYTHIA6 specific settings:
    ps_PYTHIA_PYGIVE             = ''
  PYTHIA8 specific settings:
    ps_PYTHIA8_config            = ''
    ps_PYTHIA8_config_file       = ''
 ------------------------------------------------------------------------
  Hadronization settings:
 ------------------------------------------------------------------------
  Master switches:
    active                =  T
  General settings:
    hadron_method         =  PYTHIA6
  pT generation parameters
    enhanced_fraction     =   1.000000000000E-02
    enhanced_width        =   2.000000000000E+00
 ========================================================================
  Local variables:
 ------------------------------------------------------------------------
 sqrts* =  5.00000E+02
 sqrts_hat* =>  4.94859E+02
 n_in* => 2
 n_out* => 72
 n_tot* => 74
 $process_id* => "pythia6_3_p1"
 process_num_id* => [unknown integer]
 sqme* =>  1.50392E+33
 sqme_ref* =>  1.50392E+33
 event_index* => 1
 event_weight* =>  1.00000E+00
 event_weight_ref* =>  1.00000E+00
 event_excess* =>  0.00000E+00
 ------------------------------------------------------------------------
  subevent:
  1 prt(b:11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00,-2.4979992E+02| 1.0000000E+02| 1)
  2 prt(b:-11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00, 2.4979992E+02| 1.0000000E+02| 2)
  3 prt(i:11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00,-2.4979992E+02| 1.0000000E+02| 3)
  4 prt(i:-11|-2.4488512E+02; 0.0000000E+00, 0.0000000E+00, 2.4468086E+02| 1.0000000E+02| 4)
  5 prt(o:22| 0.0000000E+00; 0.0000000E+00, 0.0000000E+00, 0.0000000E+00| 0.0000000E+00| 5)
  6 prt(o:22| 5.1190622E+00; 0.0000000E+00, 0.0000000E+00,-5.1190622E+00| 0.0000000E+00| 6)
  7 prt(o:211| 1.2530681E+01; 1.2295693E+01, 2.1293536E+00,-1.1314940E+00| 1.9479785E-02| 7)
  8 prt(o:-211| 7.4835368E+00; 7.3852032E+00, 1.1880869E+00, 1.7625995E-01| 1.9479785E-02| 8)
  9 prt(o:-2112| 4.1213079E+00; 2.7398599E+00,-2.1459217E+00,-1.9976423E+00| 8.8279178E-01| 9)
  10 prt(o:321| 2.2392647E+00; 1.5293545E+00,-1.0592300E+00,-1.1444526E+00| 2.4364096E-01| 10)
  11 prt(o:-321| 1.6013061E+01;-1.4682054E+01, 4.3747208E+00, 4.6339589E+00| 2.4364096E-01| 11)
  12 prt(o:-211| 2.4729411E+00;-2.0717229E+00, 9.4137190E-01, 9.5798797E-01| 1.9479785E-02| 12)
  13 prt(o:211| 7.1777862E-01;-2.3700953E-01,-6.5221914E-01, 1.1900854E-01| 1.9479785E-02| 13)
  14 prt(o:-211| 2.4467750E+00; 1.8087005E+00,-1.5751762E+00,-4.6330359E-01| 1.9479785E-02| 14)
  15 prt(o:211| 4.0910459E+00; 3.0796740E+00,-2.1802696E+00,-1.5745505E+00| 1.9479785E-02| 15)
  16 prt(o:22| 2.0026531E+01; 1.9906239E+01, 2.1480479E+00, 4.3528147E-01| 0.0000000E+00| 16)
- 17 prt(o:22| 2.6234807E+01; 2.6115845E+01, 2.4953370E+00, 3.2070180E-02| 0.0000000E+00| 17)
+ 17 prt(o:22| 2.6234807E+01; 2.6115845E+01, 2.4953370E+00, 3.2070178E-02| 0.0000000E+00| 17)
  18 prt(o:-211| 5.6825825E+00; 5.6303688E+00, 7.5007759E-01,-9.2712024E-02| 1.9479785E-02| 18)
  19 prt(o:-2112| 8.9506348E+00; 8.8214396E+00, 1.0474669E+00,-5.6221671E-01| 8.8279178E-01| 19)
  20 prt(o:211| 4.2249068E+00; 4.1745882E+00, 5.0036748E-01,-3.9090082E-01| 1.9479785E-02| 20)
  21 prt(o:-211| 2.3183681E+00; 2.1172550E+00, 6.4206190E-01,-6.7848263E-01| 1.9479785E-02| 21)
  22 prt(o:2212| 8.6024560E+00; 8.2483586E+00, 1.5891970E+00,-1.6002911E+00| 8.8035059E-01| 22)
  23 prt(o:-211| 3.4238271E+00; 3.2330791E+00, 6.7266577E-01,-8.9321454E-01| 1.9479785E-02| 23)
  24 prt(o:-211| 1.5527678E+00; 1.5041124E+00, 1.2253668E-01,-3.3799222E-01| 1.9479785E-02| 24)
  25 prt(o:211| 1.5198510E+00; 1.4296278E+00, 2.9351524E-01,-4.0059995E-01| 1.9479785E-02| 25)
  26 prt(o:2212| 1.0130369E+01; 7.6148263E+00,-4.8284883E+00,-4.5215193E+00| 8.8035059E-01| 26)
  27 prt(o:-211| 1.0316100E+00; 7.9644702E-01,-4.1792307E-01,-4.8554291E-01| 1.9479785E-02| 27)
  28 prt(o:-211| 2.7121648E+00; 1.8347827E+00,-1.4672275E+00,-1.3480260E+00| 1.9479785E-02| 28)
  29 prt(o:22| 3.5730342E+00; 2.4962413E+00,-1.9693661E+00,-1.6300153E+00| 0.0000000E+00| 29)
  30 prt(o:-211| 1.4294042E+01; 9.9895009E+00,-7.4018992E+00,-7.0513770E+00| 1.9479785E-02| 30)
  31 prt(o:211| 1.6069427E+01; 1.1021664E+01,-8.7182583E+00,-7.7924244E+00| 1.9479785E-02| 31)
  32 prt(o:211| 6.2358530E+01;-5.7284879E+01, 1.5264935E+01, 1.9338850E+01| 1.9479785E-02| 32)
  33 prt(o:130| 5.8028447E+01;-5.3701213E+01, 1.3747274E+01, 1.7153576E+01| 2.4767543E-01| 33)
  34 prt(o:-211| 1.3729673E+01;-1.2649085E+01, 3.0502674E+00, 4.3796081E+00| 1.9479785E-02| 34)
  35 prt(o:211| 6.5694269E+00;-5.8419961E+00, 2.0099127E+00, 2.2291752E+00| 1.9479785E-02| 35)
  36 prt(o:211| 3.9425909E+00;-3.6698975E+00, 7.2050479E-01, 1.2398662E+00| 1.9479785E-02| 36)
  37 prt(o:-211| 5.9056482E+00;-5.4318526E+00, 5.2661586E-01, 2.2527437E+00| 1.9479785E-02| 37)
  38 prt(o:211| 6.2567044E-01;-4.2847298E-01, 2.5731858E-01, 3.4954509E-01| 1.9479785E-02| 38)
  39 prt(o:22| 3.4750803E-01;-3.2632382E-01, 6.2211220E-02, 1.0200177E-01| 0.0000000E+00| 39)
  40 prt(o:22| 1.3603457E+00;-1.3309775E+00, 2.4512949E-01, 1.3766231E-01| 0.0000000E+00| 40)
  41 prt(o:211| 5.2824567E-01;-2.9069234E-01, 2.3084437E-01, 3.4895923E-01| 1.9479785E-02| 41)
  42 prt(o:-211| 1.5937125E-01;-2.1486518E-02, 5.8809300E-02, 4.4712467E-02| 1.9479785E-02| 42)
- 43 prt(o:211| 1.1269250E+00;-1.0831744E+00, 8.0839918E-02, 2.6585391E-01| 1.9479785E-02| 43)
+ 43 prt(o:211| 1.1269250E+00;-1.0831744E+00, 8.0839917E-02, 2.6585391E-01| 1.9479785E-02| 43)
  44 prt(o:-211| 5.4212853E-01;-3.4240129E-01,-3.1180086E-01,-2.4487780E-01| 1.9479785E-02| 44)
  45 prt(o:-211| 3.2092519E-01; 2.5889393E-02,-2.5043812E-01,-1.4185796E-01| 1.9479785E-02| 45)
  46 prt(o:211| 1.6119430E+00; 1.4853360E+00,-4.5019054E-01,-4.1229357E-01| 1.9479785E-02| 46)
  47 prt(o:22| 1.5070158E+01; 1.4996879E+01, 1.3795122E+00, 5.4793131E-01| 0.0000000E+00| 47)
- 48 prt(o:22| 1.2366052E+00; 1.2332024E+00, 9.0651626E-02, 1.3658241E-02| 0.0000000E+00| 48)
+ 48 prt(o:22| 1.2366052E+00; 1.2332024E+00, 9.0651626E-02, 1.3658240E-02| 0.0000000E+00| 48)
  49 prt(o:22| 1.1474455E+00; 1.1014434E+00, 3.0376491E-01,-1.0573842E-01| 0.0000000E+00| 49)
  50 prt(o:22| 2.2630965E+00; 2.2156161E+00, 4.5030912E-01,-9.9362118E-02| 0.0000000E+00| 50)
  51 prt(o:22| 2.5723320E+01; 1.7861109E+01,-1.3859262E+01,-1.2271545E+01| 0.0000000E+00| 51)
  52 prt(o:22| 1.2922120E+00; 8.8082910E-01,-7.2113538E-01,-6.1148638E-01| 0.0000000E+00| 52)
  53 prt(o:-211| 2.6656891E+01; 1.8540072E+01,-1.4088157E+01,-1.2975359E+01| 1.9479785E-02| 53)
  54 prt(o:211| 8.8649514E-01; 5.8110715E-01,-4.7081264E-01,-4.5502063E-01| 1.9479785E-02| 54)
  55 prt(o:22| 7.8134836E+00; 5.3602932E+00,-4.3305092E+00,-3.6829978E+00| 0.0000000E+00| 55)
  56 prt(o:22| 1.3716461E+00; 9.4808661E-01,-7.1794748E-01,-6.8344447E-01| 0.0000000E+00| 56)
  57 prt(o:130| 2.8784102E+01;-2.6473571E+01, 7.0597805E+00, 8.8083155E+00| 2.4767543E-01| 57)
  58 prt(o:211| 4.7876720E+00;-4.3453291E+00, 1.1689907E+00, 1.6290793E+00| 1.9479785E-02| 58)
  59 prt(o:-211| 1.6595841E+01;-1.5322803E+01, 3.5087358E+00, 5.3200494E+00| 1.9479785E-02| 59)
  60 prt(o:22| 7.1307803E+00;-6.5198202E+00, 1.8049787E+00, 2.2543345E+00| 0.0000000E+00| 60)
  61 prt(o:22| 3.3590229E+00;-3.1075700E+00, 7.9770349E-01, 9.9484327E-01| 0.0000000E+00| 61)
  62 prt(o:22| 1.3197249E-01;-8.1170274E-02, 3.3517353E-02, 9.8512489E-02| 0.0000000E+00| 62)
  63 prt(o:22| 9.9492774E-01;-7.9315846E-01,-3.7167947E-02, 5.9949930E-01| 0.0000000E+00| 63)
  64 prt(o:22| 4.8630881E-01; 3.7008631E-01,-2.8841249E-01,-1.2786954E-01| 0.0000000E+00| 64)
  65 prt(o:22| 8.6531352E-01; 7.2829306E-01,-4.6207273E-01,-6.9609631E-02| 0.0000000E+00| 65)
  66 prt(o:130| 2.2102857E+00; 1.7268553E+00,-1.2211795E+00,-4.0543653E-01| 2.4767543E-01| 66)
  67 prt(o:22| 2.0971931E-01; 2.0628426E-01,-9.6011512E-03,-3.6562448E-02| 0.0000000E+00| 67)
  68 prt(o:22| 4.4962554E-01; 4.0745002E-01, 1.7395911E-01,-7.6719211E-02| 0.0000000E+00| 68)
  69 prt(o:22| 5.3778592E-01; 5.1556119E-01, 7.2490651E-02,-1.3474219E-01| 0.0000000E+00| 69)
  70 prt(o:22| 5.5301990E-02; 2.9230655E-02, 4.3388173E-02,-1.7926109E-02| 0.0000000E+00| 70)
  71 prt(o:22| 7.6595826E-01; 7.2199166E-01, 6.9603670E-02,-2.4612076E-01| 0.0000000E+00| 71)
  72 prt(o:22| 6.7846105E-01; 5.8801710E-01, 5.5007826E-02,-3.3394525E-01| 0.0000000E+00| 72)
  73 prt(o:22| 1.4986092E+00; 5.6068207E-01,-9.6156156E-01,-1.0034263E+00| 0.0000000E+00| 73)
  74 prt(o:22| 3.2114863E-02; 1.1132152E-02,-2.9848766E-02,-4.0608905E-03| 0.0000000E+00| 74)
  75 prt(o:22| 8.0243018E-01; 4.7028597E-01,-5.1139548E-01,-4.0149716E-01| 0.0000000E+00| 75)
  76 prt(o:22| 1.4263871E+00; 6.9806751E-01,-1.0243908E+00,-7.0562408E-01| 0.0000000E+00| 76)
 ========================================================================
Index: trunk/share/tests/functional_tests/ref-output-double/pythia6_3.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output-double/pythia6_3.ref	(revision 8865)
+++ trunk/share/tests/functional_tests/ref-output-double/pythia6_3.ref	(revision 8866)
@@ -1,757 +1,757 @@
 ?openmp_logging = false
 ?vis_history = false
 ?integration_timer = false
 ?pacify = true
 $method = "omega"
 | Process library 'pythia6_3_lib': recorded process 'pythia6_3_p1'
 SM.me =>  1.00000E+01
 | Process library 'pythia6_3_lib': compiling ...
 | Process library 'pythia6_3_lib': writing makefile
 | Process library 'pythia6_3_lib': removing old files
 | Process library 'pythia6_3_lib': writing driver
 | Process library 'pythia6_3_lib': creating source code
 | Process library 'pythia6_3_lib': compiling sources
 | Process library 'pythia6_3_lib': linking
 | Process library 'pythia6_3_lib': loading
 | Process library 'pythia6_3_lib': ... success.
 seed = 0
 $phs_method = "wood"
 $integration_method = "vamp"
 sqrts =  5.00000E+02
 openmp_num_threads = 1
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 0
 | Initializing integration for process pythia6_3_p1:
 | Beam structure: e-, e+ => circe1 => isr
 | Beam data (collision):
 |   e-  (mass = 1.0000000E+01 GeV)
 |   e+  (mass = 1.0000000E+01 GeV)
 |   sqrts = 5.000000000000E+02 GeV
 | CIRCE1: activating generator mode
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 1
 | Phase space: generating configuration ...
 | Phase space: ... success.
 | Phase space: writing configuration file 'pythia6_3_p1.i1.phs'
 | ------------------------------------------------------------------------
 | Process [scattering]: 'pythia6_3_p1'
 |   Library name  = 'pythia6_3_lib'
 |   Process index = 1
 |   Process components:
 |     1: 'pythia6_3_p1_i1':   e-, e+ => u, ubar [omega]
 | ------------------------------------------------------------------------
 | Phase space: 2 channels, 2 dimensions
 | Phase space: found 2 channels, collected in 2 groves.
 | Phase space: Using 2 equivalences between channels.
 | Phase space: wood
 | Beam structure: circe1 => isr, none => none, isr
 | Beam structure: 2 channels, 2 dimensions
 | Applying user-defined cuts.
 | Starting integration for process 'pythia6_3_p1'
 | Integrate: iterations = 3:1000:"g", 3:1000
 | Integrator: 2 chains, 2 channels, 4 dimensions
 | Integrator: Using VAMP channel equivalences
 | Integrator: 1000 initial calls, 20 bins, stratified = T
 | Integrator: VAMP
 |=============================================================================|
 | It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
 |=============================================================================|
    1       1000     6.612E+02   2.37E+01    3.58    1.13    22.4
    2       1000     6.567E+02   1.27E+01    1.94    0.61    36.6
    3       1000     6.522E+02   1.09E+01    1.67    0.53    36.1
 |-----------------------------------------------------------------------------|
    3       3000     6.549E+02   7.81E+00    1.19    0.65    36.1    0.08   3
 |-----------------------------------------------------------------------------|
    4       1000     6.726E+02   1.02E+01    1.52    0.48    31.0
    5       1000     6.538E+02   1.15E+01    1.76    0.56    25.4
    6       1000     6.640E+02   1.11E+01    1.67    0.53    24.9
 |-----------------------------------------------------------------------------|
    6       3000     6.642E+02   6.29E+00    0.95    0.52    24.9    0.75   3
 |=============================================================================|
 n_events = 1
 ?debug_decay = false
 ?debug_process = false
 ?debug_verbose = false
 ?sample_pacify = true
 ?allow_shower = true
 ?ps_fsr_active = true
 $shower_method = "PYTHIA6"
 $sample = "pythia6_3a"
 | Starting simulation for process 'pythia6_3_p1'
 | Simulate: using integration grids from file 'pythia6_3_p1.m1.vg'
 | Simulate: activating parton shower
 | Shower: Using PYTHIA6 shower
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 2
 | Simulation: requested number of events = 1
 |             corr. to luminosity [fb-1] =   1.5055E-03
 | Events: writing to ASCII file 'pythia6_3a.debug'
 | Events: writing to raw file 'pythia6_3a.evx'
 | Events: generating 1 unweighted, unpolarized events ...
 | Events: event normalization mode '1'
 |         ... event sample complete.
 | Events: actual unweighting efficiency =  12.50 %
 | Events: closing ASCII file 'pythia6_3a.debug'
 | Events: closing raw file 'pythia6_3a.evx'
 ?hadronization_active = true
 $sample = "pythia6_3b"
 | Starting simulation for process 'pythia6_3_p1'
 | Simulate: using integration grids from file 'pythia6_3_p1.m1.vg'
 | Simulate: activating parton shower
 | Shower: Using PYTHIA6 shower
 | Simulate: activating hadronization
 | Hadronization: Using PYTHIA6 interface for hadronization and decays
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 3
 | Simulation: requested number of events = 1
 |             corr. to luminosity [fb-1] =   1.5055E-03
 | Events: writing to ASCII file 'pythia6_3b.debug'
 | Events: writing to raw file 'pythia6_3b.evx'
 | Events: generating 1 unweighted, unpolarized events ...
 | Events: event normalization mode '1'
 |         ... event sample complete.
 | Events: actual unweighting efficiency =  50.00 %
 | Events: closing ASCII file 'pythia6_3b.debug'
 | Events: closing raw file 'pythia6_3b.evx'
 | WHIZARD run finished.
 |=============================================================================|
 Partial contents of pythia6_3a.debug:
 ========================================================================
  Event #1
 ------------------------------------------------------------------------
    Unweighted         = T
    Normalization      = '1'
    Helicity handling  = drop
    Keep correlations  = F
 ------------------------------------------------------------------------
    Squared matrix el. (ref) =  2.93481E+15
    Squared matrix el. (prc) =  2.93481E+15
    Event weight (ref)       =  1.00000E+00
    Event weight (prc)       =  1.00000E+00
 ------------------------------------------------------------------------
    Selected MCI group = 1
    Selected term      = 1
    Selected channel   = 1
 ------------------------------------------------------------------------
    Passed selection   = T
    Reweighting factor =  1.00000E+00
    Analysis flag      = T
 ========================================================================
  Event transform: trivial (hard process)
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 2
      calls = 3
    Number of tries = 1
 ------------------------------------------------------------------------
  Particle set:
 ------------------------------------------------------------------------
  Particle 1 [b] f(11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00  2.497999E+02
  T =   1.000000000E+02
  Children: 3 4
  Particle 2 [b] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Children: 3 4
  Particle 3 [v] f(11)
  E =   2.476793E+02
  P =   0.000000E+00  0.000000E+00  2.474773E+02
  T =   1.000000000E+02
  Parents:  1 2
  Children: 5 7
  Particle 4 [v] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Parents:  1 2
  Children: 6 8
  Particle 5 [i] f(11)
  E =   1.816877E+02
  P =   0.000000E+00  0.000000E+00  1.814123E+02
  T =   1.000000000E+02
  Parents:  3
  Children: 9 10
  Particle 6 [i] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Parents:  4
  Children: 9 10
  Particle 7 [x] f(22*)
  E =   6.606507E+01
  P =   0.000000E+00  0.000000E+00  6.606507E+01
  T =   0.000000000E+00
  Parents:  3
  Particle 8 [x] f(22*)
  E =   1.064227E-18
  P =   0.000000E+00  0.000000E+00 -1.064227E-18
  T =   0.000000000E+00
  Parents:  4
  Particle 9 [o] f(2)c(1 )
  E =   1.994908E+02
  P =  -2.038903E+01 -1.860521E+02  6.903249E+01
  T =   0.000000000E+00
  Parents:  5 6
  Particle 10 [o] f(-2)c(-1 )
  E =   2.321969E+02
  P =   2.038903E+01  1.860521E+02 -1.374201E+02
  T =   0.000000000E+00
  Parents:  5 6
 ========================================================================
 ========================================================================
  Event transform: shower
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 3
      calls = 1
    Number of tries = 1
  Particle set:
 ------------------------------------------------------------------------
   Nr Status  Flavor  Col ACol              Parents             Children         P(0)         P(1)         P(2)         P(3)          P^2
    1    [b]      e-    0    0               [none]                  3-4      250.000        0.000        0.000      249.800      100.000
    2    [b]      e+    0    0               [none]                  3-4      250.000        0.000        0.000     -249.800      100.000
    3    [r]      e-    0    0                  1-2                  5,7      247.679        0.000        0.000      247.477      100.000
    4    [r]      e+    0    0                  1-2                  6,8      250.000        0.000        0.000     -249.800      100.000
    5    [i]      e-    0    0                    3                 9-10      181.688        0.000        0.000      181.412      100.000
    6    [i]      e+    0    0                    4                 9-10      250.000        0.000        0.000     -249.800      100.000
    7    [x]       A    0    0                    3               [none]       66.065        0.000        0.000       66.065        0.000
    8    [x]       A    0    0                    4               [none]        0.000        0.000        0.000       -0.000        0.000
    9    [r]       u    1    0                  5-6                18-28      199.491      -20.389     -186.052       69.032        0.000
   10    [r]    ubar    0    1                  5-6                11-17      232.197       20.389      186.052     -137.420        0.000
   11    [o]    ubar    0  500                   10               [none]       17.840        0.835       15.017       -9.596        0.000
   12    [o]      gl  500  501                   10               [none]        6.032       -0.227        5.313       -2.848        0.000
   13    [o]      gl  501  502                   10               [none]        2.657        0.140        1.996       -1.748        0.000
   14    [o]      gl  502  503                   10               [none]        6.248        0.663        4.791       -3.955        0.000
   15    [o]      gl  503  504                   10               [none]       40.324        4.179       31.765      -24.486        0.000
   16    [o]      gl  504  505                   10               [none]       71.138        6.390       57.010      -42.067        0.000
   17    [o]      gl  505  506                   10               [none]       59.970        5.932       47.551      -36.057        0.000
   18    [o]      gl  506  507                    9               [none]        1.832       -1.515       -0.920        0.462        0.000
   19    [o]      gl  507  508                    9               [none]        0.982       -0.069       -0.980       -0.022        0.000
   20    [o]      gl  508  509                    9               [none]        2.047       -1.584       -0.573       -1.163        0.000
   21    [o]      gl  509  510                    9               [none]        9.757       -8.611       -1.046       -4.468        0.000
   22    [o]      gl  510  511                    9               [none]       31.749      -27.254       -1.890      -16.175        0.000
   23    [o]      gl  511  512                    9               [none]        1.145       -1.075        0.159       -0.360        0.000
   24    [o]      gl  512  513                    9               [none]        2.337       -1.921       -0.890       -0.991        0.000
   25    [o]      gl  513  514                    9               [none]        1.913       -1.459       -1.204        0.283        0.000
   26    [o]      gl  514  515                    9               [none]        8.198        2.070       -5.298        5.904        0.000
   27    [o]      gl  515  516                    9               [none]       84.258       13.920      -75.987       33.639        0.000
   28    [o]       u  516    0                    9               [none]       83.260        9.587      -74.814       35.260        0.000
 ------------------------------------------------------------------------
 Sum of incoming momenta: p(0:3) =          431.688        0.000        0.000      -68.388 
 Sum of beam remnant momenta: p(0:3) =       66.065        0.000        0.000       66.065 
 Sum of outgoing momenta: p(0:3) =          431.688        0.000        0.000      -68.388 
 ------------------------------------------------------------------------
  Shower settings:
 ------------------------------------------------------------------------
  Master switches:
    ps_isr_active                =  F
    ps_fsr_active                =  T
    ps_tau_dec                   =  F
    muli_active                  =  F
    hadronization_active         =  F
  General settings:
    method                       =  PYTHIA6
    shower_verbose               =  F
    ps_mass_cutoff               =  1.000000000000E+00
    ps_max_n_flavors             =  5
     [ISR off]
  FSR settings:
    ps_fsr_lambda                =  2.900000000000E-01
    ps_fsr_alphas_running        =  T
  Matching Settings:
    mlm_matching                 =  F
    ckkw_matching                =  F
  PYTHIA6 specific settings:
    ps_PYTHIA_PYGIVE             = ''
  PYTHIA8 specific settings:
    ps_PYTHIA8_config            = ''
    ps_PYTHIA8_config_file       = ''
 ========================================================================
  Local variables:
 ------------------------------------------------------------------------
 sqrts* =  5.00000E+02
 sqrts_hat* =>  4.26236E+02
 n_in* => 2
 n_out* => 20
 n_tot* => 22
 $process_id* => "pythia6_3_p1"
 process_num_id* => [unknown integer]
 sqme* =>  2.93481E+15
 sqme_ref* =>  2.93481E+15
 event_index* => 1
 event_weight* =>  1.00000E+00
 event_weight_ref* =>  1.00000E+00
 event_excess* =>  0.00000E+00
 ------------------------------------------------------------------------
  subevent:
  1 prt(b:11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00,-2.4979992E+02| 1.0000000E+02| 1)
  2 prt(b:-11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00, 2.4979992E+02| 1.0000000E+02| 2)
  3 prt(i:11|-1.8168767E+02; 0.0000000E+00, 0.0000000E+00,-1.8141227E+02| 1.0000000E+02| 3)
  4 prt(i:-11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00, 2.4979992E+02| 1.0000000E+02| 4)
  5 prt(o:22| 6.6065065E+01; 0.0000000E+00, 0.0000000E+00, 6.6065065E+01| 0.0000000E+00| 5)
  6 prt(o:22| 0.0000000E+00; 0.0000000E+00, 0.0000000E+00, 0.0000000E+00| 0.0000000E+00| 6)
- 7 prt(o:-2| 1.7840363E+01; 8.3458261E-01, 1.5016817E+01,-9.5956879E+00| 0.0000000E+00| 7)
+ 7 prt(o:-2| 1.7840363E+01; 8.3458261E-01, 1.5016817E+01,-9.5956880E+00| 0.0000000E+00| 7)
  8 prt(o:21| 6.0324361E+00;-2.2698312E-01, 5.3128683E+00,-2.8481913E+00| 0.0000000E+00| 8)
  9 prt(o:21| 2.6574615E+00; 1.3985103E-01, 1.9963433E+00,-1.7484727E+00| 0.0000000E+00| 9)
  10 prt(o:21| 6.2481251E+00; 6.6349745E-01, 4.7914324E+00,-3.9548722E+00| 0.0000000E+00| 10)
  11 prt(o:21| 4.0323927E+01; 4.1789129E+00, 3.1764563E+01,-2.4486085E+01| 0.0000000E+00| 11)
  12 prt(o:21| 7.1137951E+01; 6.3898001E+00, 5.7010018E+01,-4.2067045E+01| 0.0000000E+00| 12)
- 13 prt(o:21| 5.9969604E+01; 5.9316697E+00, 4.7550805E+01,-3.6056755E+01| 0.0000000E+00| 13)
+ 13 prt(o:21| 5.9969603E+01; 5.9316697E+00, 4.7550805E+01,-3.6056755E+01| 0.0000000E+00| 13)
  14 prt(o:21| 1.8317721E+00;-1.5147157E+00,-9.2046176E-01, 4.6235855E-01| 0.0000000E+00| 14)
- 15 prt(o:21| 9.8226448E-01;-6.9131687E-02,-9.7957324E-01,-2.2373561E-02| 0.0000000E+00| 15)
+ 15 prt(o:21| 9.8226447E-01;-6.9131687E-02,-9.7957324E-01,-2.2373561E-02| 0.0000000E+00| 15)
  16 prt(o:21| 2.0468250E+00;-1.5841906E+00,-5.7298893E-01,-1.1625474E+00| 0.0000000E+00| 16)
  17 prt(o:21| 9.7571174E+00;-8.6109749E+00,-1.0457295E+00,-4.4675385E+00| 0.0000000E+00| 17)
  18 prt(o:21| 3.1748937E+01;-2.7253986E+01,-1.8898703E+00,-1.6175403E+01| 0.0000000E+00| 18)
  19 prt(o:21| 1.1445698E+00;-1.0748048E+00, 1.5855989E-01,-3.6012969E-01| 0.0000000E+00| 19)
  20 prt(o:21| 2.3373315E+00;-1.9208514E+00,-8.9003317E-01,-9.9060037E-01| 0.0000000E+00| 20)
  21 prt(o:21| 1.9130277E+00;-1.4594023E+00,-1.2039567E+00, 2.8338690E-01| 0.0000000E+00| 21)
  22 prt(o:21| 8.1981939E+00; 2.0701013E+00,-5.2980301E+00, 5.9038919E+00| 0.0000000E+00| 22)
  23 prt(o:21| 8.4257748E+01; 1.3919610E+01,-7.5987122E+01, 3.3638813E+01| 0.0000000E+00| 23)
  24 prt(o:2| 8.3260021E+01; 9.5870151E+00,-7.4813641E+01, 3.5259600E+01| 0.0000000E+00| 24)
 ========================================================================
 Partial contents of pythia6_3b.debug:
 ========================================================================
  Event #1
 ------------------------------------------------------------------------
    Unweighted         = T
    Normalization      = '1'
    Helicity handling  = drop
    Keep correlations  = F
 ------------------------------------------------------------------------
    Squared matrix el. (ref) =  1.50365E+33
    Squared matrix el. (prc) =  1.50365E+33
    Event weight (ref)       =  1.00000E+00
    Event weight (prc)       =  1.00000E+00
 ------------------------------------------------------------------------
    Selected MCI group = 1
    Selected term      = 1
    Selected channel   = 1
 ------------------------------------------------------------------------
    Passed selection   = T
    Reweighting factor =  1.00000E+00
    Analysis flag      = T
 ========================================================================
  Event transform: trivial (hard process)
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 6
      calls = 3
    Number of tries = 1
 ------------------------------------------------------------------------
  Particle set:
 ------------------------------------------------------------------------
  Particle 1 [b] f(11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00  2.497999E+02
  T =   1.000000000E+02
  Children: 3 4
  Particle 2 [b] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Children: 3 4
  Particle 3 [v] f(11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00  2.497999E+02
  T =   1.000000000E+02
  Parents:  1 2
  Children: 5 7
  Particle 4 [v] f(-11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00 -2.497999E+02
  T =   1.000000000E+02
  Parents:  1 2
  Children: 6 8
  Particle 5 [i] f(11)
  E =   2.500000E+02
  P =   0.000000E+00  0.000000E+00  2.497999E+02
  T =   1.000000000E+02
  Parents:  3
  Children: 9 10
  Particle 6 [i] f(-11)
  E =   2.448843E+02
  P =   0.000000E+00  0.000000E+00 -2.446800E+02
  T =   1.000000000E+02
  Parents:  4
  Children: 9 10
  Particle 7 [x] f(22*)
  E =   1.372475E-35
  P =   0.000000E+00  0.000000E+00  1.372475E-35
  T =   0.000000000E+00
  Parents:  3
  Particle 8 [x] f(22*)
  E =   5.119932E+00
  P =   0.000000E+00  0.000000E+00 -5.119932E+00
  T =   0.000000000E+00
  Parents:  4
  Particle 9 [o] f(2)c(1 )
  E =   2.482219E+02
  P =  -2.281881E+02  5.891482E+01  7.793173E+01
  T =   0.000000000E+00
  Parents:  5 6
  Particle 10 [o] f(-2)c(-1 )
  E =   2.466624E+02
  P =   2.281881E+02 -5.891482E+01 -7.281180E+01
  T =   0.000000000E+00
  Parents:  5 6
 ========================================================================
 ========================================================================
  Event transform: shower
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 7
      calls = 1
    Number of tries = 1
  Particle set:
 ------------------------------------------------------------------------
   Nr Status  Flavor  Col ACol              Parents             Children         P(0)         P(1)         P(2)         P(3)          P^2
    1    [b]      e-    0    0               [none]                  3-4      250.000        0.000        0.000      249.800      100.000
    2    [b]      e+    0    0               [none]                  3-4      250.000        0.000        0.000     -249.800      100.000
    3    [r]      e-    0    0                  1-2                  5,7      250.000        0.000        0.000      249.800      100.000
    4    [r]      e+    0    0                  1-2                  6,8      250.000        0.000        0.000     -249.800      100.000
    5    [i]      e-    0    0                    3                 9-10      250.000        0.000        0.000      249.800      100.000
    6    [i]      e+    0    0                    4                 9-10      244.884        0.000        0.000     -244.680      100.000
    7    [x]       A    0    0                    3               [none]        0.000        0.000        0.000        0.000        0.000
    8    [x]       A    0    0                    4               [none]        5.120        0.000        0.000       -5.120        0.000
    9    [r]       u    1    0                  5-6                18-24      248.222     -228.188       58.915       77.932        0.000
   10    [r]    ubar    0    1                  5-6          11-17,25-27      246.662      228.188      -58.915      -72.812        0.000
   11    [o]    ubar    0  500                   10               [none]       67.357       66.997        6.822        1.337        0.000
   12    [o]      gl  500  501                   10               [none]       11.047       10.915        1.575       -0.649        0.000
   13    [o]      gl  501  502                   10               [none]       11.146       11.016        1.691       -0.137        0.000
   14    [o]      gl  502  503                   10               [none]       21.964       21.568        3.720       -1.849        0.000
   15    [o]      gl  503  504                   10               [none]       12.944       11.841        2.560       -4.558        0.000
   16    [o]      gl  504  505                   10               [none]        3.236        2.996       -0.650       -1.036        0.000
   17    [o]       d  505    0                   10               [none]      115.186       79.739      -61.708      -55.693        0.109
   18    [o]       u  506    0                    9               [none]      103.402      -95.299       24.538       31.745        0.000
   19    [o]      gl  507  506                    9               [none]       91.901      -84.310       22.825       28.578        0.000
   20    [o]      gl  508  507                    9               [none]       25.417      -23.490        6.720        7.007        0.000
   21    [o]      gl  509  508                    9               [none]        5.099       -4.741        0.335        1.846        0.000
   22    [o]      gl  510  509                    9               [none]        3.435       -2.839        1.076        1.606        0.000
   23    [o]      gl  511  510                    9               [none]        6.122       -5.399        0.472        2.847        0.000
   24    [o]      gl  512  511                    9               [none]        0.284       -0.118       -0.149        0.211        0.000
   25    [o]      gl  513  512                   10               [none]        3.181        1.224       -2.448       -1.622        0.000
   26    [o]      gl  514  513                   10               [none]        5.206        4.057       -2.824       -1.632        0.000
   27    [o]    dbar    0  514                   10               [none]        7.958        5.843       -4.558       -2.882        0.109
 ------------------------------------------------------------------------
 Sum of incoming momenta: p(0:3) =          494.884        0.000        0.000        5.120 
 Sum of beam remnant momenta: p(0:3) =        5.120        0.000        0.000       -5.120 
 Sum of outgoing momenta: p(0:3) =          494.884        0.000        0.000        5.120 
 ------------------------------------------------------------------------
  Shower settings:
 ------------------------------------------------------------------------
  Master switches:
    ps_isr_active                =  F
    ps_fsr_active                =  T
    ps_tau_dec                   =  F
    muli_active                  =  F
    hadronization_active         =  T
  General settings:
    method                       =  PYTHIA6
    shower_verbose               =  F
    ps_mass_cutoff               =  1.000000000000E+00
    ps_max_n_flavors             =  5
     [ISR off]
  FSR settings:
    ps_fsr_lambda                =  2.900000000000E-01
    ps_fsr_alphas_running        =  T
  Matching Settings:
    mlm_matching                 =  F
    ckkw_matching                =  F
  PYTHIA6 specific settings:
    ps_PYTHIA_PYGIVE             = ''
  PYTHIA8 specific settings:
    ps_PYTHIA8_config            = ''
    ps_PYTHIA8_config_file       = ''
 ========================================================================
 ========================================================================
  Event transform: hadronization
 ------------------------------------------------------------------------
    Associated process: 'pythia6_3_p1'
    TAO random-number generator:
      seed  = 9
      calls = 1
    Number of tries = 1
  Particle set:
 ------------------------------------------------------------------------
   Nr Status  Flavor  Col ACol              Parents             Children         P(0)         P(1)         P(2)         P(3)          P^2
    1    [b]      e-    0    0               [none]                  3-4      250.000        0.000        0.000      249.800      100.000
    2    [b]      e+    0    0               [none]                  3-4      250.000        0.000        0.000     -249.800      100.000
    3    [r]      e-    0    0                  1-2                  5,7      250.000        0.000        0.000      249.800      100.000
    4    [r]      e+    0    0                  1-2                  6,8      250.000        0.000        0.000     -249.800      100.000
    5    [i]      e-    0    0                    3                 9-10      250.000        0.000        0.000      249.800      100.000
    6    [i]      e+    0    0                    4                 9-10      244.884        0.000        0.000     -244.680      100.000
    7    [x]       A    0    0                    3               [none]        0.000        0.000        0.000        0.000        0.000
    8    [x]       A    0    0                    4               [none]        5.120        0.000        0.000       -5.120        0.000
    9    [r]       u    1    0                  5-6                18-24      248.222     -228.188       58.915       77.932        0.000
   10    [r]    ubar    0    1                  5-6          11-17,25-27      246.662      228.188      -58.915      -72.812        0.000
   11    [r]    ubar    0  500                   10                   28       67.357       66.997        6.822        1.337        0.000
   12    [r]      gl  500  501                   10                   28       11.047       10.915        1.575       -0.649        0.000
   13    [r]      gl  501  502                   10                   28       11.146       11.016        1.691       -0.137        0.000
   14    [r]      gl  502  503                   10                   28       21.964       21.568        3.720       -1.849        0.000
   15    [r]      gl  503  504                   10                   28       12.944       11.841        2.560       -4.558        0.000
   16    [r]      gl  504  505                   10                   28        3.236        2.996       -0.650       -1.036        0.000
   17    [r]       d  505    0                   10                   28      115.186       79.739      -61.708      -55.693        0.109
   18    [r]       u  506    0                    9                   43      103.402      -95.299       24.538       31.745        0.000
   19    [r]      gl  507  506                    9                   43       91.901      -84.310       22.825       28.578        0.000
   20    [r]      gl  508  507                    9                   43       25.417      -23.490        6.720        7.007        0.000
   21    [r]      gl  509  508                    9                   43        5.099       -4.741        0.335        1.846        0.000
   22    [r]      gl  510  509                    9                   43        3.435       -2.839        1.076        1.606        0.000
   23    [r]      gl  511  510                    9                   43        6.122       -5.399        0.472        2.847        0.000
   24    [r]      gl  512  511                    9                   43        0.284       -0.118       -0.149        0.211        0.000
   25    [r]      gl  513  512                   10                   43        3.181        1.224       -2.448       -1.622        0.000
   26    [r]      gl  514  513                   10                   43        5.206        4.057       -2.824       -1.632        0.000
   27    [r]    dbar    0  514                   10                   43        7.958        5.843       -4.558       -2.882        0.109
   28    [r]     hr3    0    0                11-17                29-42      242.880      205.071      -45.988      -62.585    10904.673
   29    [r]     eta    0    0                   28                61-62       46.261       46.022        4.643        0.467        0.300
   30    [r]    rhom    0    0                   28                63-64       21.989       21.860        2.220        0.469        0.503
   31    [o]     pip    0    0                   28               [none]       12.531       12.296        2.129       -1.132        0.019
   32    [o]     pim    0    0                   28               [none]        7.484        7.385        1.188        0.176        0.019
   33    [r] Deltaba    0    0                   28                65-66       13.176       12.996        1.548       -0.953        1.394
   34    [r]    rhom    0    0                   28                67-68        5.729        5.434        1.396       -0.884        0.559
   35    [r]  Delta0    0    0                   28                69-70       12.026       11.481        2.262       -2.494        1.474
   36    [r] etaprim    0    0                   28                71-73        5.769        5.402        0.821       -1.585        0.917
   37    [o]    nbar    0    0                   28               [none]        4.121        2.740       -2.146       -1.998        0.883
   38    [r]  lambda    0    0                   28                74-75       11.162        8.411       -5.246       -5.007        1.245
   39    [o]      kp    0    0                   28               [none]        2.239        1.529       -1.059       -1.144        0.244
   40    [r]    rhom    0    0                   28                76-77       29.728       20.577      -16.048      -14.231        0.285
   41    [r] etaprim    0    0                   28                78-79       31.116       21.617      -16.528      -15.060        0.917
   42    [r]   omega    0    0                   28                80-82       39.548       27.319      -21.169      -19.210        0.590
   43    [r]     hr3    0    0                18-27                44-60      252.004     -205.071       45.988       67.705    14753.249
   44    [r]  kstarp    0    0                   43                83-84       91.143      -83.758       22.325       28.148        0.846
   45    [r]      k0    0    0                   43                   85       58.028      -53.701       13.747       17.154        0.248
   46    [r]    rho0    0    0                   43                86-87       20.299      -18.491        5.060        6.609        0.852
   47    [r]      k0    0    0                   43                   88       21.383      -19.668        4.678        6.949        0.248
   48    [o]      km    0    0                   43               [none]       16.013      -14.682        4.375        4.634        0.244
   49    [r]    rhop    0    0                   43                89-90       14.432      -13.297        3.323        4.489        0.281
   50    [o]     pim    0    0                   43               [none]        2.473       -2.072        0.941        0.958        0.019
   51    [r]    rho0    0    0                   43                91-92        6.531       -5.860        0.784        2.602        0.928
   52    [r]     pi0    0    0                   43                93-94        1.708       -1.657        0.307        0.240        0.018
   53    [r]   omega    0    0                   43                95-97        1.815       -1.186        0.286        1.092        0.611
   54    [r]    rho0    0    0                   43                98-99        1.669       -1.426       -0.231        0.021        0.700
   55    [o]     pip    0    0                   43               [none]        0.718       -0.237       -0.652        0.119        0.019
   56    [r]    rhom    0    0                   43              100-101        1.673        1.124       -1.001       -0.339        0.416
   57    [r]  kstarp    0    0                   43              102-103        3.822        3.212       -1.671       -0.818        0.829
   58    [r]      k0    0    0                   43                  104        3.760        1.740       -2.527       -2.115        0.248
   59    [o]     pim    0    0                   43               [none]        2.447        1.809       -1.575       -0.463        0.019
   60    [o]     pip    0    0                   43               [none]        4.091        3.080       -2.180       -1.575        0.019
   61    [o]       A    0    0                   29               [none]       20.026       19.906        2.148        0.435        0.000
   62    [o]       A    0    0                   29               [none]       26.235       26.116        2.495        0.032        0.000
   63    [o]     pim    0    0                   30               [none]        5.683        5.630        0.750       -0.093        0.019
   64    [r]     pi0    0    0                   30              105-106       16.307       16.230        1.470        0.562        0.018
   65    [o]    nbar    0    0                   33               [none]        8.951        8.821        1.047       -0.562        0.883
   66    [o]     pip    0    0                   33               [none]        4.225        4.175        0.500       -0.391        0.019
   67    [o]     pim    0    0                   34               [none]        2.318        2.117        0.642       -0.678        0.019
   68    [r]     pi0    0    0                   34              107-108        3.411        3.317        0.754       -0.205        0.018
   69    [o]       p    0    0                   35               [none]        8.602        8.248        1.589       -1.600        0.880
   70    [o]     pim    0    0                   35               [none]        3.424        3.233        0.673       -0.893        0.019
   71    [o]     pim    0    0                   36               [none]        1.553        1.504        0.123       -0.338        0.019
   72    [o]     pip    0    0                   36               [none]        1.520        1.430        0.294       -0.401        0.019
   73    [r]     eta    0    0                   36              109-111        2.697        2.469        0.405       -0.846        0.300
   74    [o]       p    0    0                   38               [none]       10.130        7.615       -4.828       -4.522        0.880
   75    [o]     pim    0    0                   38               [none]        1.032        0.796       -0.418       -0.486        0.019
   76    [o]     pim    0    0                   40               [none]        2.712        1.835       -1.467       -1.348        0.019
   77    [r]     pi0    0    0                   40              112-113       27.015       18.742      -14.580      -12.883        0.018
   78    [o]       A    0    0                   41               [none]        3.573        2.496       -1.969       -1.630        0.000
   79    [r]    rho0    0    0                   41              114-115       27.543       19.121      -14.559      -13.430        0.680
   80    [o]     pim    0    0                   42               [none]       14.294        9.989       -7.402       -7.051        0.019
   81    [o]     pip    0    0                   42               [none]       16.069       11.022       -8.718       -7.792        0.019
   82    [r]     pi0    0    0                   42              116-117        9.185        6.308       -5.048       -4.366        0.018
   83    [r]      k0    0    0                   44                  118       28.784      -26.473        7.060        8.808        0.248
   84    [o]     pip    0    0                   44               [none]       62.358      -57.285       15.265       19.339        0.019
   85    [o]     kL0    0    0                   45               [none]       58.028      -53.701       13.747       17.154        0.248
   86    [o]     pim    0    0                   46               [none]       13.730      -12.649        3.050        4.380        0.019
   87    [o]     pip    0    0                   46               [none]        6.569       -5.842        2.010        2.229        0.019
   88    [r]     kS0    0    0                   47              119-120       21.383      -19.668        4.678        6.949        0.248
   89    [o]     pip    0    0                   49               [none]        3.943       -3.670        0.720        1.240        0.019
   90    [r]     pi0    0    0                   49              121-122       10.490       -9.627        2.603        3.249        0.018
   91    [o]     pim    0    0                   51               [none]        5.906       -5.432        0.527        2.253        0.019
   92    [o]     pip    0    0                   51               [none]        0.626       -0.428        0.257        0.350        0.019
   93    [o]       A    0    0                   52               [none]        0.348       -0.326        0.062        0.102        0.000
   94    [o]       A    0    0                   52               [none]        1.360       -1.331        0.245        0.138        0.000
   95    [o]     pip    0    0                   53               [none]        0.528       -0.291        0.231        0.349        0.019
   96    [o]     pim    0    0                   53               [none]        0.159       -0.021        0.059        0.045        0.019
   97    [r]     pi0    0    0                   53              123-124        1.127       -0.874       -0.004        0.698        0.018
   98    [o]     pip    0    0                   54               [none]        1.127       -1.083        0.081        0.266        0.019
   99    [o]     pim    0    0                   54               [none]        0.542       -0.342       -0.312       -0.245        0.019
  100    [o]     pim    0    0                   56               [none]        0.321        0.026       -0.250       -0.142        0.019
  101    [r]     pi0    0    0                   56              125-126        1.352        1.098       -0.750       -0.197        0.018
  102    [r]      k0    0    0                   57                  127        2.210        1.727       -1.221       -0.405        0.248
  103    [o]     pip    0    0                   57               [none]        1.612        1.485       -0.450       -0.412        0.019
  104    [r]     kS0    0    0                   58              128-129        3.760        1.740       -2.527       -2.115        0.248
  105    [o]       A    0    0                   64               [none]       15.070       14.997        1.379        0.548        0.000
  106    [o]       A    0    0                   64               [none]        1.237        1.233        0.091        0.014        0.000
  107    [o]       A    0    0                   68               [none]        1.147        1.101        0.304       -0.106        0.000
  108    [o]       A    0    0                   68               [none]        2.263        2.216        0.450       -0.099        0.000
  109    [r]     pi0    0    0                   73              130-131        0.659        0.614        0.164       -0.113        0.018
  110    [r]     pi0    0    0                   73              132-133        0.593        0.545        0.116       -0.153        0.018
  111    [r]     pi0    0    0                   73              134-135        1.444        1.310        0.125       -0.580        0.018
  112    [o]       A    0    0                   77               [none]       25.723       17.861      -13.859      -12.272        0.000
  113    [o]       A    0    0                   77               [none]        1.292        0.881       -0.721       -0.611        0.000
  114    [o]     pim    0    0                   79               [none]       26.657       18.540      -14.088      -12.975        0.019
  115    [o]     pip    0    0                   79               [none]        0.886        0.581       -0.471       -0.455        0.019
  116    [o]       A    0    0                   82               [none]        7.813        5.360       -4.330       -3.683        0.000
  117    [o]       A    0    0                   82               [none]        1.372        0.948       -0.718       -0.683        0.000
  118    [o]     kL0    0    0                   83               [none]       28.784      -26.473        7.060        8.808        0.248
  119    [o]     pip    0    0                   88               [none]        4.788       -4.345        1.169        1.629        0.019
  120    [o]     pim    0    0                   88               [none]       16.596      -15.323        3.509        5.320        0.019
  121    [o]       A    0    0                   90               [none]        7.131       -6.520        1.805        2.254        0.000
  122    [o]       A    0    0                   90               [none]        3.359       -3.108        0.798        0.995        0.000
  123    [o]       A    0    0                   97               [none]        0.132       -0.081        0.034        0.099        0.000
  124    [o]       A    0    0                   97               [none]        0.995       -0.793       -0.037        0.600        0.000
  125    [o]       A    0    0                  101               [none]        0.486        0.370       -0.288       -0.128        0.000
  126    [o]       A    0    0                  101               [none]        0.865        0.728       -0.462       -0.070        0.000
  127    [o]     kL0    0    0                  102               [none]        2.210        1.727       -1.221       -0.405        0.248
  128    [r]     pi0    0    0                  104              136-137        1.531        0.572       -0.991       -1.007        0.018
  129    [r]     pi0    0    0                  104              138-139        2.229        1.168       -1.536       -1.107        0.018
  130    [o]       A    0    0                  109               [none]        0.210        0.206       -0.010       -0.037        0.000
  131    [o]       A    0    0                  109               [none]        0.450        0.407        0.174       -0.077        0.000
  132    [o]       A    0    0                  110               [none]        0.538        0.516        0.072       -0.135        0.000
  133    [o]       A    0    0                  110               [none]        0.055        0.029        0.043       -0.018        0.000
  134    [o]       A    0    0                  111               [none]        0.766        0.722        0.070       -0.246        0.000
  135    [o]       A    0    0                  111               [none]        0.678        0.588        0.055       -0.334        0.000
  136    [o]       A    0    0                  128               [none]        1.499        0.561       -0.962       -1.003        0.000
  137    [o]       A    0    0                  128               [none]        0.032        0.011       -0.030       -0.004        0.000
  138    [o]       A    0    0                  129               [none]        0.802        0.470       -0.511       -0.401        0.000
  139    [o]       A    0    0                  129               [none]        1.426        0.698       -1.024       -0.706        0.000
 ------------------------------------------------------------------------
 Sum of incoming momenta: p(0:3) =          494.884        0.000        0.000        5.120 
 Sum of beam remnant momenta: p(0:3) =        5.120        0.000        0.000       -5.120 
 Sum of outgoing momenta: p(0:3) =          494.884        0.000        0.000        5.120 
 ------------------------------------------------------------------------
  Shower settings:
 ------------------------------------------------------------------------
  Master switches:
    ps_isr_active                =  F
    ps_fsr_active                =  T
    ps_tau_dec                   =  F
    muli_active                  =  F
    hadronization_active         =  T
  General settings:
    method                       =  PYTHIA6
    shower_verbose               =  F
    ps_mass_cutoff               =  1.000000000000E+00
    ps_max_n_flavors             =  5
     [ISR off]
  FSR settings:
    ps_fsr_lambda                =  2.900000000000E-01
    ps_fsr_alphas_running        =  T
  Matching Settings:
    mlm_matching                 =  F
    ckkw_matching                =  F
  PYTHIA6 specific settings:
    ps_PYTHIA_PYGIVE             = ''
  PYTHIA8 specific settings:
    ps_PYTHIA8_config            = ''
    ps_PYTHIA8_config_file       = ''
 ------------------------------------------------------------------------
  Hadronization settings:
 ------------------------------------------------------------------------
  Master switches:
    active                =  T
  General settings:
    hadron_method         =  PYTHIA6
  pT generation parameters
    enhanced_fraction     =   1.000000000000E-02
    enhanced_width        =   2.000000000000E+00
 ========================================================================
  Local variables:
 ------------------------------------------------------------------------
 sqrts* =  5.00000E+02
 sqrts_hat* =>  4.94858E+02
 n_in* => 2
 n_out* => 72
 n_tot* => 74
 $process_id* => "pythia6_3_p1"
 process_num_id* => [unknown integer]
 sqme* =>  1.50365E+33
 sqme_ref* =>  1.50365E+33
 event_index* => 1
 event_weight* =>  1.00000E+00
 event_weight_ref* =>  1.00000E+00
 event_excess* =>  0.00000E+00
 ------------------------------------------------------------------------
  subevent:
  1 prt(b:11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00,-2.4979992E+02| 1.0000000E+02| 1)
  2 prt(b:-11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00, 2.4979992E+02| 1.0000000E+02| 2)
  3 prt(i:11|-2.5000000E+02; 0.0000000E+00, 0.0000000E+00,-2.4979992E+02| 1.0000000E+02| 3)
  4 prt(i:-11|-2.4488425E+02; 0.0000000E+00, 0.0000000E+00, 2.4467999E+02| 1.0000000E+02| 4)
  5 prt(o:22| 0.0000000E+00; 0.0000000E+00, 0.0000000E+00, 0.0000000E+00| 0.0000000E+00| 5)
- 6 prt(o:22| 5.1199315E+00; 0.0000000E+00, 0.0000000E+00,-5.1199315E+00| 0.0000000E+00| 6)
+ 6 prt(o:22| 5.1199316E+00; 0.0000000E+00, 0.0000000E+00,-5.1199316E+00| 0.0000000E+00| 6)
  7 prt(o:211| 1.2530564E+01; 1.2295576E+01, 2.1293341E+00,-1.1315039E+00| 1.9479785E-02| 7)
- 8 prt(o:-211| 7.4835960E+00; 7.3852619E+00, 1.1880966E+00, 1.7624362E-01| 1.9479785E-02| 8)
+ 8 prt(o:-211| 7.4835960E+00; 7.3852619E+00, 1.1880966E+00, 1.7624361E-01| 1.9479785E-02| 8)
  9 prt(o:-2112| 4.1213007E+00; 2.7398508E+00,-2.1459160E+00,-1.9976462E+00| 8.8279178E-01| 9)
  10 prt(o:321| 2.2392609E+00; 1.5293502E+00,-1.0592266E+00,-1.1444542E+00| 2.4364096E-01| 10)
  11 prt(o:-321| 1.6013057E+01;-1.4682024E+01, 4.3747203E+00, 4.6340446E+00| 2.4364096E-01| 11)
- 12 prt(o:-211| 2.4729218E+00;-2.0716999E+00, 9.4136316E-01, 9.5799675E-01| 1.9479785E-02| 12)
+ 12 prt(o:-211| 2.4729218E+00;-2.0716998E+00, 9.4136316E-01, 9.5799675E-01| 1.9479785E-02| 12)
  13 prt(o:211| 7.1777686E-01;-2.3701446E-01,-6.5221419E-01, 1.1901527E-01| 1.9479785E-02| 13)
  14 prt(o:-211| 2.4467731E+00; 1.8086975E+00,-1.5751756E+00,-4.6330784E-01| 1.9479785E-02| 14)
  15 prt(o:211| 4.0910409E+00; 3.0796670E+00,-2.1802659E+00,-1.5745562E+00| 1.9479785E-02| 15)
- 16 prt(o:22| 2.0026465E+01; 1.9906175E+01, 2.1480410E+00, 4.3524408E-01| 0.0000000E+00| 16)
- 17 prt(o:22| 2.6234805E+01; 2.6115843E+01, 2.4953362E+00, 3.2022179E-02| 0.0000000E+00| 17)
- 18 prt(o:-211| 5.6825564E+00; 5.6303426E+00, 7.5007455E-01,-9.2723455E-02| 1.9479785E-02| 18)
- 19 prt(o:-2112| 8.9506389E+00; 8.8214430E+00, 1.0474656E+00,-5.6223039E-01| 8.8279178E-01| 19)
- 20 prt(o:211| 4.2249108E+00; 4.1745917E+00, 5.0036710E-01,-3.9090710E-01| 1.9479785E-02| 20)
- 21 prt(o:-211| 2.3183627E+00; 2.1172490E+00, 6.4206094E-01,-6.7848372E-01| 1.9479785E-02| 21)
+ 16 prt(o:22| 2.0026465E+01; 1.9906175E+01, 2.1480410E+00, 4.3524407E-01| 0.0000000E+00| 16)
+ 17 prt(o:22| 2.6234805E+01; 2.6115843E+01, 2.4953362E+00, 3.2022166E-02| 0.0000000E+00| 17)
+ 18 prt(o:-211| 5.6825564E+00; 5.6303426E+00, 7.5007455E-01,-9.2723457E-02| 1.9479785E-02| 18)
+ 19 prt(o:-2112| 8.9506389E+00; 8.8214430E+00, 1.0474656E+00,-5.6223040E-01| 8.8279178E-01| 19)
+ 20 prt(o:211| 4.2249108E+00; 4.1745917E+00, 5.0036710E-01,-3.9090711E-01| 1.9479785E-02| 20)
+ 21 prt(o:-211| 2.3183627E+00; 2.1172490E+00, 6.4206095E-01,-6.7848372E-01| 1.9479785E-02| 21)
  22 prt(o:2212| 8.6024627E+00; 8.2483630E+00, 1.5892002E+00,-1.6003015E+00| 8.8035059E-01| 22)
  23 prt(o:-211| 3.4238326E+00; 3.2330833E+00, 6.7266748E-01,-8.9321909E-01| 1.9479785E-02| 23)
  24 prt(o:-211| 1.5527677E+00; 1.5041120E+00, 1.2253691E-01,-3.3799370E-01| 1.9479785E-02| 24)
  25 prt(o:211| 1.5198516E+00; 1.4296280E+00, 2.9351554E-01,-4.0060153E-01| 1.9479785E-02| 25)
  26 prt(o:2212| 1.0130344E+01; 7.6147994E+00,-4.8284752E+00,-4.5215241E+00| 8.8035059E-01| 26)
  27 prt(o:-211| 1.0316079E+00; 7.9644446E-01,-4.1792187E-01,-4.8554364E-01| 1.9479785E-02| 27)
  28 prt(o:-211| 2.7121640E+00; 1.8347791E+00,-1.4672267E+00,-1.3480301E+00| 1.9479785E-02| 28)
  29 prt(o:22| 3.5730191E+00; 2.4962273E+00,-1.9693577E+00,-1.6300137E+00| 0.0000000E+00| 29)
  30 prt(o:-211| 1.4294008E+01; 9.9894627E+00,-7.4018791E+00,-7.0513831E+00| 1.9479785E-02| 30)
  31 prt(o:211| 1.6069386E+01; 1.1021620E+01,-8.7182344E+00,-7.7924297E+00| 1.9479785E-02| 31)
  32 prt(o:211| 6.2358495E+01;-5.7284746E+01, 1.5264901E+01, 1.9339158E+01| 1.9479785E-02| 32)
  33 prt(o:130| 5.8028485E+01;-5.3701158E+01, 1.3747261E+01, 1.7153887E+01| 2.4767543E-01| 33)
  34 prt(o:-211| 1.3729654E+01;-1.2649044E+01, 3.0502547E+00, 4.3796744E+00| 1.9479785E-02| 34)
  35 prt(o:211| 6.5694343E+00;-5.8419907E+00, 2.0099104E+00, 2.2292132E+00| 1.9479785E-02| 35)
  36 prt(o:211| 3.9425782E+00;-3.6698797E+00, 7.2049767E-01, 1.2398827E+00| 1.9479785E-02| 36)
- 37 prt(o:-211| 5.9056150E+00;-5.4318119E+00, 5.2660529E-01, 2.2527573E+00| 1.9479785E-02| 37)
+ 37 prt(o:-211| 5.9056150E+00;-5.4318119E+00, 5.2660528E-01, 2.2527573E+00| 1.9479785E-02| 37)
  38 prt(o:211| 6.2567121E-01;-4.2847103E-01, 2.5731743E-01, 3.4954970E-01| 1.9479785E-02| 38)
  39 prt(o:22| 3.4750730E-01;-3.2632231E-01, 6.2213195E-02, 1.0200288E-01| 0.0000000E+00| 39)
  40 prt(o:22| 1.3603311E+00;-1.3309615E+00, 2.4513427E-01, 1.3766455E-01| 0.0000000E+00| 40)
  41 prt(o:211| 5.2824349E-01;-2.9068937E-01, 2.3084186E-01, 3.4896006E-01| 1.9479785E-02| 41)
  42 prt(o:-211| 1.5937081E-01;-2.1485222E-02, 5.8807986E-02, 4.4713253E-02| 1.9479785E-02| 42)
- 43 prt(o:211| 1.1269109E+00;-1.0831605E+00, 8.0837758E-02, 2.6585145E-01| 1.9479785E-02| 43)
+ 43 prt(o:211| 1.1269109E+00;-1.0831605E+00, 8.0837757E-02, 2.6585145E-01| 1.9479785E-02| 43)
  44 prt(o:-211| 5.4212782E-01;-3.4239723E-01,-3.1180295E-01,-2.4487926E-01| 1.9479785E-02| 44)
  45 prt(o:-211| 3.2092517E-01; 2.5889248E-02,-2.5043780E-01,-1.4185851E-01| 1.9479785E-02| 45)
- 46 prt(o:211| 1.6119431E+00; 1.4853352E+00,-4.5019012E-01,-4.1229711E-01| 1.9479785E-02| 46)
- 47 prt(o:22| 1.5070039E+01; 1.4996762E+01, 1.3794994E+00, 5.4790110E-01| 0.0000000E+00| 47)
- 48 prt(o:22| 1.2366024E+00; 1.2331997E+00, 9.0651194E-02, 1.3655893E-02| 0.0000000E+00| 48)
+ 46 prt(o:211| 1.6119431E+00; 1.4853352E+00,-4.5019012E-01,-4.1229712E-01| 1.9479785E-02| 46)
+ 47 prt(o:22| 1.5070039E+01; 1.4996762E+01, 1.3794994E+00, 5.4790109E-01| 0.0000000E+00| 47)
+ 48 prt(o:22| 1.2366024E+00; 1.2331997E+00, 9.0651194E-02, 1.3655892E-02| 0.0000000E+00| 48)
  49 prt(o:22| 1.1474415E+00; 1.1014394E+00, 3.0376414E-01,-1.0573869E-01| 0.0000000E+00| 49)
- 50 prt(o:22| 2.2630868E+00; 2.2156066E+00, 4.5030723E-01,-9.9362536E-02| 0.0000000E+00| 50)
+ 50 prt(o:22| 2.2630868E+00; 2.2156066E+00, 4.5030723E-01,-9.9362537E-02| 0.0000000E+00| 50)
  51 prt(o:22| 2.5723241E+01; 1.7861029E+01,-1.3859217E+01,-1.2271548E+01| 0.0000000E+00| 51)
- 52 prt(o:22| 1.2922092E+00; 8.8082586E-01,-7.2113379E-01,-6.1148718E-01| 0.0000000E+00| 52)
+ 52 prt(o:22| 1.2922092E+00; 8.8082586E-01,-7.2113378E-01,-6.1148718E-01| 0.0000000E+00| 52)
  53 prt(o:-211| 2.6656825E+01; 1.8540000E+01,-1.4088118E+01,-1.2975368E+01| 1.9479785E-02| 53)
- 54 prt(o:211| 8.8649538E-01; 5.8110600E-01,-4.7081254E-01,-4.5502269E-01| 1.9479785E-02| 54)
+ 54 prt(o:211| 8.8649538E-01; 5.8110600E-01,-4.7081255E-01,-4.5502269E-01| 1.9479785E-02| 54)
  55 prt(o:22| 7.8134538E+00; 5.3602648E+00,-4.3304923E+00,-3.6829957E+00| 0.0000000E+00| 55)
  56 prt(o:22| 1.3716445E+00; 9.4808402E-01,-7.1794647E-01,-6.8344589E-01| 0.0000000E+00| 56)
  57 prt(o:130| 2.8784020E+01;-2.6473449E+01, 7.0597487E+00, 8.8084397E+00| 2.4767543E-01| 57)
  58 prt(o:211| 4.7876845E+00;-4.3453320E+00, 1.1689906E+00, 1.6291085E+00| 1.9479785E-02| 58)
  59 prt(o:-211| 1.6595806E+01;-1.5322744E+01, 3.5087191E+00, 5.3201227E+00| 1.9479785E-02| 59)
  60 prt(o:22| 7.1307614E+00;-6.5197924E+00, 1.8049675E+00, 2.2543641E+00| 0.0000000E+00| 60)
  61 prt(o:22| 3.3589876E+00;-3.1075329E+00, 7.9769168E-01, 9.9484933E-01| 0.0000000E+00| 61)
  62 prt(o:22| 1.3197203E-01;-8.1169434E-02, 3.3516616E-02, 9.8512819E-02| 0.0000000E+00| 62)
  63 prt(o:22| 9.9492597E-01;-7.9315445E-01,-3.7171875E-02, 5.9950142E-01| 0.0000000E+00| 63)
- 64 prt(o:22| 4.8630875E-01; 3.7008628E-01,-2.8841219E-01,-1.2787006E-01| 0.0000000E+00| 64)
+ 64 prt(o:22| 4.8630875E-01; 3.7008628E-01,-2.8841220E-01,-1.2787006E-01| 0.0000000E+00| 64)
  65 prt(o:22| 8.6531205E-01; 7.2829200E-01,-4.6207154E-01,-6.9610326E-02| 0.0000000E+00| 65)
- 66 prt(o:130| 2.2102843E+00; 1.7268532E+00,-1.2211784E+00,-4.0544135E-01| 2.4767543E-01| 66)
+ 66 prt(o:130| 2.2102843E+00; 1.7268532E+00,-1.2211784E+00,-4.0544136E-01| 2.4767543E-01| 66)
  67 prt(o:22| 2.0971926E-01; 2.0628417E-01,-9.6011240E-03,-3.6562689E-02| 0.0000000E+00| 67)
  68 prt(o:22| 4.4962562E-01; 4.0744998E-01, 1.7395920E-01,-7.6719686E-02| 0.0000000E+00| 68)
  69 prt(o:22| 5.3778610E-01; 5.1556122E-01, 7.2490752E-02,-1.3474275E-01| 0.0000000E+00| 69)
  70 prt(o:22| 5.5302074E-02; 2.9230696E-02, 4.3388201E-02,-1.7926233E-02| 0.0000000E+00| 70)
  71 prt(o:22| 7.6595846E-01; 7.2199161E-01, 6.9603838E-02,-2.4612148E-01| 0.0000000E+00| 71)
  72 prt(o:22| 6.7846243E-01; 5.8801805E-01, 5.5008071E-02,-3.3394633E-01| 0.0000000E+00| 72)
  73 prt(o:22| 1.4986082E+00; 5.6067882E-01,-9.6156053E-01,-1.0034277E+00| 0.0000000E+00| 73)
  74 prt(o:22| 3.2114559E-02; 1.1131862E-02,-2.9848555E-02,-4.0608314E-03| 0.0000000E+00| 74)
  75 prt(o:22| 8.0242534E-01; 4.7028235E-01,-5.1139229E-01,-4.0149578E-01| 0.0000000E+00| 75)
  76 prt(o:22| 1.4263816E+00; 6.9806271E-01,-1.0243872E+00,-7.0562306E-01| 0.0000000E+00| 76)
 ========================================================================
Index: trunk/share/tests/functional_tests/ref-output-double/resonances_13.ref
===================================================================
--- trunk/share/tests/functional_tests/ref-output-double/resonances_13.ref	(revision 8865)
+++ trunk/share/tests/functional_tests/ref-output-double/resonances_13.ref	(revision 8866)
@@ -1,275 +1,275 @@
 ?openmp_logging = false
 ?vis_history = false
 ?integration_timer = false
 ?pacify = true
 seed = 0
 ?resonance_history = true
 resonance_on_shell_limit =  4.00000E+00
 | Process library 'resonances_13_lib': recorded process 'resonances_13_p'
 sqrts =  9.20000E+01
 openmp_num_threads = 1
 | Integrate: current process library needs compilation
 | Process library 'resonances_13_lib': compiling ...
 | Process library 'resonances_13_lib': writing makefile
 | Process library 'resonances_13_lib': removing old files
 | Process library 'resonances_13_lib': writing driver
 | Process library 'resonances_13_lib': creating source code
 | Process library 'resonances_13_lib': compiling sources
 | Process library 'resonances_13_lib': linking
 | Process library 'resonances_13_lib': loading
 | Process library 'resonances_13_lib': ... success.
 | Integrate: compilation done
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 0
 | Initializing integration for process resonances_13_p:
 | Beam structure: e-, e+ => isr
 | Beam data (collision):
 |   e-  (mass = 5.1099700E-04 GeV)
 |   e+  (mass = 5.1099700E-04 GeV)
 |   sqrts = 9.200000000000E+01 GeV
 | Phase space: generating configuration ...
 | Phase space: ... success.
 | Phase space: writing configuration file 'resonances_13_p.i1.phs'
 | ------------------------------------------------------------------------
 | Process [scattering]: 'resonances_13_p'
 |   Library name  = 'resonances_13_lib'
 |   Process index = 1
 |   Process components:
 |     1: 'resonances_13_p_i1':   e-, e+ => mu-, mu+ [omega]
 | ------------------------------------------------------------------------
 | Phase space: 2 channels, 2 dimensions
 | Phase space: found 2 channels, collected in 2 groves.
 | Phase space: Using 2 equivalences between channels.
 | Phase space: wood
 | Beam structure: isr, none => none, isr
 | Beam structure: 2 channels, 2 dimensions
 Warning: No cuts have been defined.
 | Starting integration for process 'resonances_13_p'
 | Integrate: iterations = 3:1000:"gw", 1:1000
 | Integrator: 2 chains, 2 channels, 4 dimensions
 | Integrator: Using VAMP channel equivalences
 | Integrator: 1000 initial calls, 20 bins, stratified = T
 | Integrator: VAMP
 |=============================================================================|
 | It      Calls  Integral[fb]  Error[fb]   Err[%]    Acc  Eff[%]   Chi2 N[It] |
 |=============================================================================|
    1       1000     1.348E+06   4.37E+04    3.24    1.03     8.9
    2        999     1.251E+06   1.98E+04    1.58    0.50    45.3
-   3        998     1.227E+06   1.04E+04    0.85    0.27    53.6
+   3        998     1.227E+06   1.04E+04    0.85    0.27    53.4
 |-----------------------------------------------------------------------------|
-   3       2997     1.237E+06   9.00E+03    0.73    0.40    53.6    3.96   3
+   3       2997     1.237E+06   9.01E+03    0.73    0.40    53.4    3.99   3
 |-----------------------------------------------------------------------------|
-   4        998     1.245E+06   1.01E+04    0.82    0.26    46.0
+   4        998     1.245E+06   1.02E+04    0.82    0.26    46.0
 |-----------------------------------------------------------------------------|
-   4        998     1.245E+06   1.01E+04    0.82    0.26    46.0
+   4        998     1.245E+06   1.02E+04    0.82    0.26    46.0
 |=============================================================================|
 n_events = 1
 | Particle mu- declared as polarized
 | Particle mu+ declared as polarized
 ?polarized_events = false
 $sample = "resonances_13_a"
 | Starting simulation for process 'resonances_13_p'
 | Simulate: using integration grids from file 'resonances_13_p.m1.vg'
 | Creating library for resonant subprocesses 'resonances_13_p_R'
 | Process library 'resonances_13_p_R': initialized
 | Resonant subprocess #1: 3+4~Z
 | Process library 'resonances_13_p_R': recorded process 'resonances_13_p_R1'
 | Process library 'resonances_13_p_R': compiling ...
 | Process library 'resonances_13_p_R': writing makefile
 | Process library 'resonances_13_p_R': removing old files
 | Process library 'resonances_13_p_R': writing driver
 | Process library 'resonances_13_p_R': creating source code
 | Process library 'resonances_13_p_R': compiling sources
 | Process library 'resonances_13_p_R': linking
 | Process library 'resonances_13_p_R': loading
 | Process library 'resonances_13_p_R': ... success.
 | Simulate: initializing resonant subprocess 'resonances_13_p_R1'
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 1
 | Initializing integration for process resonances_13_p_R1:
 | Beam structure: e-, e+ => isr
 | Beam data (collision):
 |   e-  (mass = 5.1099700E-04 GeV)
 |   e+  (mass = 5.1099700E-04 GeV)
 |   sqrts = 9.200000000000E+01 GeV
 | ------------------------------------------------------------------------
 | Process [scattering]: 'resonances_13_p_R1'
 |   Library name  = 'resonances_13_p_R'
 |   Process index = 1
 |   Process components:
 |     1: 'resonances_13_p_R1_i1':   e-, e+ => mu-, mu+ [omega]
 | ------------------------------------------------------------------------
 | Phase space: none
 | Beam structure: isr, none => none, isr
 | Beam structure: 1 channels, 2 dimensions
 Warning: No cuts have been defined.
 | Simulate: activating resonance insertion
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 2
 | Simulation: requested number of events = 1
-|             corr. to luminosity [fb-1] =   8.0314E-07
+|             corr. to luminosity [fb-1] =   8.0313E-07
 | Events: writing to event dump file 'resonances_13_a.pset.dat'
 | Events: writing to raw file 'resonances_13_a.evx'
 | Events: generating 1 unweighted, unpolarized events ...
 | Events: event normalization mode '1'
 |         ... event sample complete.
 | Events: actual unweighting efficiency = 100.00 %
 | Events: closing event dump file 'resonances_13_a.pset.dat'
 | Events: closing raw file 'resonances_13_a.evx'
 ?polarized_events = true
 $sample = "resonances_13_b"
 | Starting simulation for process 'resonances_13_p'
 | Simulate: using integration grids from file 'resonances_13_p.m1.vg'
 | Using library for resonant subprocesses 'resonances_13_p_R'
 | Simulate: initializing resonant subprocess 'resonances_13_p_R1'
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 3
 | Initializing integration for process resonances_13_p_R1:
 | Beam structure: e-, e+ => isr
 | Beam data (collision):
 |   e-  (mass = 5.1099700E-04 GeV)
 |   e+  (mass = 5.1099700E-04 GeV)
 |   sqrts = 9.200000000000E+01 GeV
 | ------------------------------------------------------------------------
 | Process [scattering]: 'resonances_13_p_R1'
 |   Library name  = 'resonances_13_p_R'
 |   Process index = 1
 |   Process components:
 |     1: 'resonances_13_p_R1_i1':   e-, e+ => mu-, mu+ [omega]
 | ------------------------------------------------------------------------
 | Phase space: none
 | Beam structure: isr, none => none, isr
 | Beam structure: 1 channels, 2 dimensions
 Warning: No cuts have been defined.
 | Simulate: activating resonance insertion
 | RNG: Initializing TAO random-number generator
 | RNG: Setting seed for random-number generator to 4
 | Simulation: requested number of events = 1
-|             corr. to luminosity [fb-1] =   8.0314E-07
+|             corr. to luminosity [fb-1] =   8.0313E-07
 | Events: writing to event dump file 'resonances_13_b.pset.dat'
 | Events: writing to raw file 'resonances_13_b.evx'
 | Events: generating 1 unweighted, polarized events ...
 | Events: event normalization mode '1'
 |         ... event sample complete.
 | Events: actual unweighting efficiency =  50.00 %
 | Events: closing event dump file 'resonances_13_b.pset.dat'
 | Events: closing raw file 'resonances_13_b.evx'
 | There were no errors and    3 warning(s).
 | WHIZARD run finished.
 |=============================================================================|
 Output of resonances_13_a.pset.dat:
 ========================================================================
  Event #1
 ========================================================================
  count  = 1
  passed = T
  prc id = 1
 ------------------------------------------------------------------------
  Particle set:
 ------------------------------------------------------------------------
  Particle 1 [b] f(11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00  4.600000E+01
  T =   2.611179340E-07
  Children: 3 5
  Particle 2 [b] f(-11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00 -4.600000E+01
  T =   2.611179340E-07
  Children: 4 6
  Particle 3 [i] f(11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00  4.600000E+01
  T =   2.611179340E-07
  Parents:  1
  Children: 7
  Particle 4 [i] f(-11)
  E =   4.599997E+01
  P =   0.000000E+00  0.000000E+00 -4.599997E+01
  T =   2.611179340E-07
  Parents:  2
  Children: 7
  Particle 5 [x] f(22*)
- E =   9.436829E-09
- P =   0.000000E+00  0.000000E+00  9.436829E-09
+ E =   9.481400E-09
+ P =   0.000000E+00  0.000000E+00  9.481400E-09
  T =   0.000000000E+00
  Parents:  1
  Particle 6 [x] f(22*)
- E =   3.274592E-05
- P =   0.000000E+00  0.000000E+00 -3.274592E-05
+ E =   3.282727E-05
+ P =   0.000000E+00  0.000000E+00 -3.282727E-05
  T =   0.000000000E+00
  Parents:  2
  Particle 7 [r] f(23)
  E =   9.199997E+01
- P =   0.000000E+00  0.000000E+00  3.273648E-05
- T =   8.463993973E+03
+ P =   0.000000E+00  0.000000E+00  3.281778E-05
+ T =   8.463993958E+03
  Parents:  3 4
  Children: 8 9
  Particle 8 [o] f(13)
  E =   4.599997E+01
- P =   2.507786E+01  1.750483E+01 -3.436085E+01
+ P =   2.507458E+01  1.750254E+01 -3.436441E+01
  T =   1.116369517E-02
  Parents:  7
  Particle 9 [o] f(-13)
  E =   4.600000E+01
- P =  -2.507786E+01 -1.750483E+01  3.436088E+01
+ P =  -2.507458E+01 -1.750254E+01  3.436445E+01
  T =   1.116369517E-02
  Parents:  7
 Output of resonances_13_b.pset.dat:
 ========================================================================
  Event #1
 ========================================================================
  count  = 1
  passed = T
  prc id = 1
 ------------------------------------------------------------------------
  Particle set:
 ------------------------------------------------------------------------
  Particle 1 [b] f(11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00  4.600000E+01
  T =   2.611179340E-07
  Children: 3 5
  Particle 2 [b] f(-11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00 -4.600000E+01
  T =   2.611179340E-07
  Children: 4 6
  Particle 3 [i] f(11)
  E =   4.600000E+01
  P =   0.000000E+00  0.000000E+00  4.600000E+01
  T =   2.611179340E-07
  Parents:  1
  Children: 7
  Particle 4 [i] f(-11)
  E =   4.421868E+01
  P =   0.000000E+00  0.000000E+00 -4.421868E+01
  T =   2.611179340E-07
  Parents:  2
  Children: 7
  Particle 5 [x] f(22*)
- E =   5.768983E-09
- P =   0.000000E+00  0.000000E+00  5.768983E-09
+ E =   5.767829E-09
+ P =   0.000000E+00  0.000000E+00  5.767829E-09
  T =   0.000000000E+00
  Parents:  1
  Particle 6 [x] f(22*)
- E =   1.781322E+00
- P =   0.000000E+00  0.000000E+00 -1.781322E+00
+ E =   1.781324E+00
+ P =   0.000000E+00  0.000000E+00 -1.781324E+00
  T =   0.000000000E+00
  Parents:  2
  Particle 7 [r] f(23)
  E =   9.021868E+01
- P =   0.000000E+00  0.000000E+00  1.781322E+00
- T =   8.136236777E+03
+ P =   0.000000E+00  0.000000E+00  1.781324E+00
+ T =   8.136236303E+03
  Parents:  3 4
  Children: 8 9
  Particle 8 [o] f(13)h(-1)
  E =   4.470301E+01
- P =   1.872954E+01  3.549524E+01 -1.968858E+01
+ P =   1.872953E+01  3.549523E+01 -1.968860E+01
  T =   1.116369517E-02
  Parents:  7
  Particle 9 [o] f(-13)h(1)
  E =   4.551567E+01
- P =  -1.872954E+01 -3.549524E+01  2.146990E+01
+ P =  -1.872953E+01 -3.549523E+01  2.146993E+01
  T =   1.116369517E-02
  Parents:  7
Index: trunk/share/tests/unit_tests/ref-output/sf_mappings_8.ref
===================================================================
--- trunk/share/tests/unit_tests/ref-output/sf_mappings_8.ref	(revision 8865)
+++ trunk/share/tests/unit_tests/ref-output/sf_mappings_8.ref	(revision 8866)
@@ -1,114 +1,114 @@
 * Test output: sf_mappings_8
 *   Purpose: probe power pair mapping
 
  map(1,2): isr (eps = 1.00000E-01)
 
 Probe at (0,0.5):
    p =  0.000000000E+00  5.000000000E-01
    pb=  1.000000000E+00  5.000000000E-01
    r =  0.000000000E+00  0.000000000E+00
    rb=  1.000000000E+00  1.000000000E+00
    f =  0.000000000E+00
 
    p =  0.000000000E+00  5.000000000E-01
    pb=  1.000000000E+00  5.000000000E-01
    r =  0.000000000E+00  0.000000000E+00
    rb=  1.000000000E+00  1.000000000E+00
    f =  0.000000000E+00
 
    *r=  0.000000000E+00
 
 Probe at (0.5,0.5):
    p =  5.000000000E-01  5.000000000E-01
    pb=  5.000000000E-01  5.000000000E-01
    r =  9.842509843E-01  9.842509843E-01
    rb=  1.574901575E-02  1.574901575E-02
    f =  9.921468223E-02
 
    p =  5.000000000E-01  5.000000000E-01
    pb=  5.000000000E-01  5.000000000E-01
    r =  9.842509843E-01  9.842509843E-01
    rb=  1.574901575E-02  1.574901575E-02
    f =  9.921468223E-02
 
    *r=  9.687500000E-01
 
 Probe at (0.9,0.5):
    p =  9.000000000E-01  5.000000000E-01
    pb=  1.000000000E-01  5.000000000E-01
    r =  9.999950000E-01  9.999950000E-01
    rb=  5.000012500E-06  5.000012500E-06
    f =  5.000025000E-08
 
    p =  9.000000000E-01  5.000000000E-01
    pb=  1.000000000E-01  5.000000000E-01
    r =  9.999950000E-01  9.999950000E-01
    rb=  5.000012500E-06  5.000012500E-06
    f =  5.000025000E-08
 
    *r=  9.999900000E-01
 
 Probe at (0.7,0.2):
    p =  7.000000000E-01  2.000000000E-01
    pb=  3.000000000E-01  8.000000000E-01
    r =  9.975701272E-01  9.999998724E-01
    rb=  2.429872753E-03  1.275570205E-07
    f =  2.583029830E-07
 
    p =  7.000000000E-01  2.000000000E-01
    pb=  3.000000000E-01  8.000000000E-01
    r =  9.975701272E-01  9.999998724E-01
    rb=  2.429872753E-03  1.275570205E-07
    f =  2.583029830E-07
 
    *r=  9.975700000E-01
 
 Probe at (0.7,0.8):
    p =  7.000000000E-01  8.000000000E-01
    pb=  3.000000000E-01  2.000000000E-01
    r =  9.999998724E-01  9.975701272E-01
    rb=  1.275570205E-07  2.429872753E-03
    f =  2.583029830E-07
 
    p =  7.000000000E-01  8.000000000E-01
    pb=  3.000000000E-01  2.000000000E-01
    r =  9.999998724E-01  9.975701272E-01
    rb=  1.275570205E-07  2.429872753E-03
    f =  2.583029830E-07
 
    *r=  9.975700000E-01
 
 Probe at (0.99,0.02):
    p =  9.9000000E-01  2.0000000E-02
    pb=  1.0000000E-02  9.8000000E-01
    r =  1.0000000E+00  1.0000000E+00
    rb=  1.0000000E-10  0.0000000E+00
    f =  1.31072E-29
 
-   p =  9.9000000E-01  0.0000000E+00
-   pb=  1.0000000E-02  1.0000000E+00
+   p =  9.9000000E-01  2.0000000E-02
+   pb=  1.0000000E-02  9.8000000E-01
    r =  1.0000000E+00  1.0000000E+00
    rb=  1.0000000E-10  0.0000000E+00
-   f =  0.00000E+00
+   f =  1.31072E-29
 
    *r=  1.0000000E+00
 
 Probe at (0.99,0.98):
    p =  9.9000000E-01  9.8000000E-01
    pb=  1.0000000E-02  2.0000000E-02
    r =  1.0000000E+00  1.0000000E+00
    rb=  0.0000000E+00  1.0000000E-10
    f =  1.31072E-29
 
-   p =  9.9000000E-01  1.0000000E+00
-   pb=  1.0000000E-02  0.0000000E+00
+   p =  9.9000000E-01  9.8000000E-01
+   pb=  1.0000000E-02  2.0000000E-02
    r =  1.0000000E+00  1.0000000E+00
    rb=  0.0000000E+00  1.0000000E-10
-   f =  0.00000E+00
+   f =  1.31072E-29
 
    *r=  1.0000000E+00
 
 Compute integral:
    I = 0.99433
 
 * Test output end: sf_mappings_8
Index: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog	(revision 8865)
+++ trunk/ChangeLog	(revision 8866)
@@ -1,2365 +1,2371 @@
 ChangeLog -- Summary of changes to the WHIZARD package
 
 Use svn log to see detailed changes.
 
 	Version 3.1.0.1
 
+2023-03-01
+	Bug fix: numerical mapping stability for peaked PDFs
+
+2023-02-28
+	Bug fix UFO interface: avoid too long ME code lines
+
 2023-02-22
 	Infrastructure for calculation of kinematic MT2 variable
 
 2023-02-17
 	Bug fix UFO interface: correct parentheses in rational functions
 
 ##################################################################
 
 2022-12-14
 	RELEASE: version 3.1.0
 
 2022-12-12
 	Bug fix Pythia8 interface: production vertices, shower history
 	O'Mega support for epsilon tensor color structures
 
 2023-01-27
 	Support for loop-induced processes
 
 2022-11-30
 	O'Mega support for general SU(N) color representations
 
 2022-11-07
 	Modernize configure checks for Python versions v3.10+
 
 2022-10-21
         General POWHEG matching
           with optional NLO real phase space partitioning
 
 2022-09-26
 	Bug fix: accept negative scale values in SLHA block header
 
 2022-08-08
 	Numerical stability of testsuite for Apple M1 processors
 
 2022-08-07
 	Technically allow for muons as CIRCE2 beam spectra
 
 2022-06-22
         POWHEG matching for Drell-Yan and similar processes
 
 2022-06-12
 	Add unit tests for Lorentz and phase-space modules
 
 2022-05-09
 	Massive eikonals: Numeric robustness at ultrahigh energies
 
 2022-04-20
 	Bug fix for VAMP2 event generation with indefinite samples
 
 ##################################################################
 
 2022-04-06
 	RELEASE: version 3.0.3
 
 2022-04-05
 	POWHEG matching for single flavor hadron collisions
 
 2022-03-31
 	NLO EW processes with massless leptons and jets (i.e.
 	   jet clustering and photon recombination) supported
 	NLO EW for massive initial leptons validated
 
 2022-03-27
 	Complete implementation/validation of NLL electron PDFs
 
 2022-02-22
 	Bug fix: correct normalization for CIRCE2+EPA+polarization
 
 2022-02-21
 	WHIZARD core now uses Fortran modules and submodules
 
 2022-01-27
 	Infrastructure for POWHEG matching for hadron collisions
 
 2021-12-16
 	Event files can be written/read also for decay processes
 	Implementation of running QED coupling alpha
 
 2021-12-10
 	Independent variations of renormalization/factorization scale
 
 ##################################################################
 
 2021-11-23
 	RELEASE: version 3.0.2
 
 2021-11-19
 	Support for a wide class of mixed NLO QCD/EW processes
 
 2021-11-18
 	Add pp processes for NLO EW corrections to testsuite
 
 2021-11-11
 	Output numerically critical values with LCIO 2.17+ as double
 
 2021-11-05
 	Minor refactoring on phase space points and kinematics
 
 2021-10-21
 	NLO (QCD) differential distributions supported for full
 	  lepton collider setup: polarization, QED ISR, beamstrahlung
 
 2021-10-15
 	SINDARIN now has a sum and product function of expressions,
 	SINDARIN supports observables defined on full (sub)events
 	First application: transverse mass
 	Bug fix: 2HDM did not allow H+, H- as external particles
 
 2021-10-14
 	CT18 PDFs included (NLO, NNLO)
 
 2021-09-30
 	Bug fix: keep non-recombined photons in the event record
 
 2021-09-13
 	Modular NLO event generation with real partition
 
 2021-08-20
 	Bug fix: correctly reading in NLO fixed order events
 
 2021-08-06
         Generalize optional partitioning of the NLO real phase space
 
 ##################################################################
 
 2021-07-08
 	RELEASE: version 3.0.1
 
 2021-07-06
 	MPI parallelization now comes with two incarnations:
 	- standard MPI parallelization ("simple", default)
 	- MPI with load balancer ("load")
 
 2021-07-05
 	Bug fix for C++17 default compilers w/ HepMC3/ROOT interface
 
 2021-07-02
 	Improvement for POWHEG matching:
 	- implement massless recoil case
 	- enable reading in existing POWHEG grids
 	- support kinematic cuts at generator level
 
 2021-07-01
 	Distinguish different cases of photons in NLO EW corrections
 
 2021-06-21
 	Option to keep negative PDF entries or set them zero
 
 2021-05-31
 	Full LCIO MC production files can be properly recasted
 
 2021-05-24
         Use defaults for UFO models without propagators.py
 
 2021-05-21
 	Bug fix: prevent invalid code for UFO models containing hyphens
 
 2021-05-20
 	UFO files with scientific notation float constants allowed
 	UFO files: max. n-arity of vertices bound by process multiplicity
 
 ##################################################################
 
 2021-04-27
 	RELEASE: version 3.0.0
 
 2021-04-20
 	Minimal required OCaml version is now 4.05.0.
 	Bug fix for tau polarization from stau decays
 
 2021-04-19
 	NLO EW splitting functions and collinear remnants completed
 	Photon recombination implemented
 
 2021-04-14
 	Bug fix for vertices/status codes with HepMC2/3 event format
 
 2021-04-08
 	Correct Lorentz statistics for UFO model with Majorana fermions
 
 2021-04-06
 	Bug fix for rare script failure in system_dependencies.f90.in
 	Kappa factor for quartic Higgs coupling in SM_ac(_CKM) model
 
 2021-04-04
 	Support for UFO extensions in SMEFTSim 3.0
 
 2021-02-25
 	Enable VAMP and VAMP2 channel equivalences for NLO integrations
 
 2021-02-04
 	Bug fix if user does not set a prefix at configuration
 
 2020-12-10
 	Generalize NLO calculations to non-CMS lab frames
 
 2020-12-08
 	Bug fix in expanded p-wave form factor for top threshold
 
 2020-12-06
 	Patch for macOS Big Sur shared library handling due to libtool;
 	   the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5
 
 2020-12-04
 	O'Mega only inserts non-vanishing couplings from UFO models
 
 2020-11-21
 	Bug fix for fractional hypercharges in UFO models
 
 2020-11-11
 	Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh)
 
 2020-11-09
 	Correct flavor assignment for NLO fixed-order events
 
 2020-11-05
 	Bug fix for ISR handler not working with unstable particles
 
 2020-10-08
 	Bug fix in LHAPDF interface for photon PDFs
 
 2020-10-07
 	Bug fix for structure function setup with asymmetric beams
 
 2020-10-02
 	Python/Cython layer for WHIZARD API
 
 2020-09-30
 	Allow mismatches of Python and name attributes in UFO models
 
 2020-09-26
 	Support for negative PDG particles from certain UFO models
 
 2020-09-24
 	Allow for QNUMBERS blocks in BSM SLHA files
 
 2020-09-22
 	Full support for compilation with clang(++) on Darwin/macOS
 	More documentation in the manual
 	Minor clean-ups
 
 2020-09-16
 	Bug fix enables reading LCIO events with LCIO v2.15+
 
 ##################################################################
 
 2020-09-16
 	RELEASE: version 2.8.5
 
 2020-09-11
 	Bug fix for H->tau tau transverse polarization with PYTHIA6
 	   (thanks to Junping Tian / Akiya Miyamoto)
 
 2020-09-09
 	Fix a long standing bug (since 2.0) in the calculation of color
 	factors when particles of different color were combined in a
 	particle class.  NB: O'Mega never produced a wrong number,
 	it only declared all processes as invalid.
 
 2020-09-08
 	Enable Openloops matrix element equivalences for optimization
 
 2020-09-02
 	Compatibility fix for PYTHIA v8.301+ interface
 
 2020-09-01
 	Support exclusive jet clustering in ee for Fastjet interface
 
 ##################################################################
 
 2020-08-30
 	RELEASE: version 3.0.0_beta
 
 2020-08-27
 	Major revision of NLO distributions and events for
 	   processes with structure functions:
 	- Use parton momenta/flavors (instead of beams) for events
 	- Bug fix for Lorentz boosts and Lorentz frames of momenta
 	- Bug fix: apply cuts to virtual NLO component in correct frame
 	- Correctly assign ISR radiation momenta in data structures
 	- Refactoring on quantum numbers for NLO event data structures
 	- Functional tests for hadron collider NLO distributions
 	- many minor bug fixes regarding NLO hadron collider physics
 
 2020-08-11
 	Bug fix for linking problem with OpenMPI
 
 2020-08-07
 	New WHIZARD API: WHIZARD can be externally linked as a
 	  library, added examples for Fortran, C, C++ programs
 
 ##################################################################
 
 2020-07-08
 	RELEASE: version 2.8.4
 
 2020-07-07
 	Bug fix: steering of UFO Majorana models from WHIZARD
 
 ##################################################################
 
 2020-07-06
 	Combined integration also for hadron collider processes at NLO
 
 2020-07-05
 	Bug fix: correctly steer e+e- FastJet clustering algorithms
 	Major revision of NLO differential distributions and events:
 	- Correctly assign quantum numbers to NLO fixed-order events
 	- Correctly assign weights to NLO fixed-order events for
 	     combined simulation
 	- Cut all NLO fixed-order subevents in event groups individually
 	- Only allow "sigma" normalization for NLO fixed-order events
 	- Use correct PDF setup for NLO counter events
 	- Several technical fixes and updates of the NLO testsuite
 
 ##################################################################
 
 2020-07-03
 	RELEASE: version 2.8.3
 
 2020-07-02
 	Feature-complete UFO implementation for Majorana fermions
 
 2020-06-22
 	Running width scheme supported for O'Mega matrix elements
 
 2020-06-20
 	Adding H-s-s coupling to SM_Higgs(_CKM) models
 
 2020-06-17
 	Completion of ILC 2->6 fermion extended test suite
 
 2020-06-15
 	Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays
 
 2020-06-09
 	Bug fix: correctly update calls for additional VAMP/2 iterations
 	Bug fix: correct assignment for tau spins from PYTHIA6 interface
 
 2020-06-04
 	Bug fix: cascades2 tree merge with empty subtree(s)
 
 2020-05-31
 	Switch $epa_mode for different EPA implementations
 
 2020-05-26
 	Bug fix: spin information transferred for resonance histories
 
 2020-04-13
 	HepMC: correct weighted events for non-xsec event normalizations
 
 2020-04-04
 	Improved HepMC3 interface: HepMC3 Root/RootTree interface
 
 2020-03-24
 	ISR: Fix on-shell kinematics for events with ?isr_handler=true
 	   (set ?isr_handler_keep_mass=false for old behavior)
 
 2020-03-11
 	Beam masses are correctly passed to hard matrix element for CIRCE2
 	EPA with polarized beams: double-counting corrected
 
 ##################################################################
 
 2020-03-03
 	RELEASE: version 3.0.0_alpha
 
 2020-02-25
 	Bug fix: Scale and alphas can be retrieved from internal event format to
 	   external formats
 
 2020-02-17
 	Bug fix: ?keep_failed_events now forces output of actual event data
 	Bug fix: particle-set reconstruction (rescanning events w/o radiation)
 
 2020-01-28
 	Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max)
 
 2020-01-23
 	Bug fix for real components of NLO QCD 2->1 processes
 
 2020-01-22
         Bug fix: correct random number sequencing during parallel MPI event
 	   generation with rng_stream
 
 2020-01-21
 	Consistent distribution of events during parallel MPI event generation
 
 2020-01-20
 	Bug fix for configure setup for automake v1.16+
 
 2020-01-18
 	General SLHA parameter files for UFO models supported
 
 2020-01-08
 	Bug fix: correctly register RECOLA processes with flavor sums
 
 2019-12-19
 	Support for UFO customized propagators
 	O'Mega unit tests for fermion-number violating interactions
 
 2019-12-10
 	For distribution building: check for graphviz/dot
 	   version 2.40 or newer
 
 2019-11-21
 	Bug fix: alternate setups now work correctly
 	Infrastructure for accessing alpha_QED event-by-event
 	Guard against tiny numbers that break ASCII event output
 	Enable inverse hyperbolic functions as SINDARIN observables
 	Remove old compiler bug workarounds
 
 2019-11-20
 	Allow quoted -e argument, implemented -f option
 
 2019-11-19
 	Bug fix: resonance histories now work also with UFO models
 	Fix in numerical precision of ASCII VAMP2 grids
 
 2019-11-06
 	Add squared matrix elements to the LCIO event header
 
 2019-11-05
 	Do not include RNG state in MD5 sum for CIRCE1/2
 
 2019-11-04
 	Full CIRCE2 ILC 250 and 500 GeV beam spectra added
 	Minor update on LCIO event header information
 
 2019-10-30
 	NLO QCD for final states completed
 	When using Openloops, v2.1.1+ mandatory
 
 2019-10-25
 	Binary grid files for VAMP2 integrator
 
 ##################################################################
 
 2019-10-24
 	RELEASE: version 2.8.2
 
 2019-10-20
 	Bug fix for HepMC linker flags
 
 2019-10-19
 	Support for spin-2 particles from UFO files
 
 2019-09-27
 	LCIO event format allows rescan and alternate weights
 
 2019-09-24
 	Compatibility fix for OCaml v4.08.0+
 
 ##################################################################
 
 2019-09-21
 	RELEASE: version 2.8.1
 
 2019-09-19
 	Carriage return characters in UFO models can be parsed
 	Mathematica symbols in UFO models possible
 	Unused/undefined parameters in UFO models handled
 
 2019-09-13
 	New extended NLO test suite for ee and pp processes
 
 2019-09-09
 	Photon isolation (separation of perturbative and fragmentation
 	   part a la Frixione)
 
 2019-09-05
 	Major progress on NLO QCD for hadron collisions:
 	- correctly assign flavor structures for alpha regions
 	- fix crossing of particles for initial state splittings
 	- correct assignment for PDF factors for real subtractions
 	- fix kinematics for collinear splittings
 	- bug fix for integrated virtual subtraction terms
 
 2019-09-03
 	b and c jet selection in cuts and analysis
 
 2019-08-27
 	Support for Intel MPI
 
 2019-08-20
 	Complete (preliminary) HepMC3 support (incl.
 	   backwards HepMC2 write/read mode)
 
 2019-08-08
 	Bug fix: handle carriage returns in UFO files (non-Unix OS)
 
 ##################################################################
 
 2019-08-07
 	RELEASE: version 2.8.0
 
 2019-07-31
 	Complete WHIZARD UFO interface:
 	- general Lorentz structures
 	- matrix element support for general color factors
 	- missing features: Majorana fermions and SLHA
 
 2019-07-20
 	Make WHIZARD compatible with OCaml 4.08.0+
 
 2019-07-19
 	Fix version testing for LHAPDF 6.2.3 and newer
 	Minimal required OCaml version is now 4.02.3.
 
 2019-04-18
 	Correctly generate ordered FKS tuples for alpha regions
 	   from all possible underlying Born processes
 
 2019-04-08
 	Extended O'Mega/Recola matrix element test suite
 
 2019-03-29
 	Correct identical particle symmetry factors for FKS subtraction
 
 2019-03-28
 	Correct assertion of spin-correlated matrix
 	   elements for hadron collisions
 
 2019-03-27
 	Bug fix for cut-off parameter delta_i for
 	   collinear plus/minus regions
 
 ##################################################################
 
 2019-03-27
 	RELEASE: version 2.7.1
 
 2019-02-19
 	Further infrastructure for HepMC3 interface (v3.01.00)
 
 2019-02-07
 	Explicit configure option for using debugging options
 	Bug fix for performance by removing unnecessary debug operations
 
 2019-01-29
 	Bug fix for DGLAP remnants with cut-off parameter delta_i
 
 2019-01-24
 	Radiative decay neu2 -> neu1 A added to MSSM_Hgg model
 
 ##################################################################
 
 2019-01-21
 	RELEASE: version 2.7.0
 
 2018-12-18
 	Support RECOLA for integrated und unintegrated subtractions
 
 2018-12-11
 	FCNC top-up sector in model SM_top_anom
 
 2018-12-05
 	Use libtirpc instead of SunRPC on Arch Linux etc.
 
 2018-11-30
 	Display rescaling factor for weighted event samples with cuts
 
 2018-11-29
 	Reintroduce check against different masses in flavor sums
 	Bug fix for wrong couplings in the Littlest Higgs model(s)
 
 2018-11-22
 	Bug fix for rescanning events with beam structure
 
 2018-11-09
 	Major refactoring of internal process data
 
 2018-11-02
 	PYTHIA8 interface
 
 2018-10-29
         Flat phase space parametrization with RAMBO (on diet) implemented
 
 2018-10-17
 	Revise extended test suite
 
 2018-09-27
 	Process container for RECOLA processes
 
 2018-09-15
 	Fixes by M. Berggren for PYTHIA6 interface
 
 2018-09-14
 	First fixes after HepForge modernization
 
 ##################################################################
 
 2018-08-23
 	RELEASE: version 2.6.4
 
 2018-08-09
 	Infrastructure to check colored subevents
 
 2018-07-10
 	Infrastructure for running WHIZARD in batch mode
 
 2018-07-04
 	MPI available from distribution tarball
 
 2018-06-03
 	Support Intel Fortran Compiler under MAC OS X
 
 2018-05-07
 	FKS slicing parameter delta_i (initial state) implementend
 
 2018-05-03
 	Refactor structure function assignment for NLO
 
 2018-05-02
 	FKS slicing parameter xi_cut, delta_0 implemented
 
 2018-04-20
 	Workspace subdirectory for process integration (grid/phs files)
 	Packing/unpacking of files at job end/start
 	Exporting integration results from scan loops
 
 2018-04-13
 	Extended QCD NLO test suite
 
 2018-04-09
 	Bug fix for Higgs Singlet Extension model
 
 2018-04-06
 	Workspace subdirectory for process generation and compilation
 	--job-id option for creating job-specific names
 
 2018-03-20
 	Bug fix for color flow matching in hadron collisions
 	   with identical initial state quarks
 
 2018-03-08
 	Structure functions quantum numbers correctly assigned for NLO
 
 2018-02-24
 	Configure setup includes 'pgfortran' and 'flang'
 
 2018-02-21
 	Include spin-correlated matrix elements in interactions
 
 2018-02-15
 	Separate module for QED ISR structure functions
 
 ##################################################################
 
 2018-02-10
 	RELEASE: version 2.6.3
 
 2018-02-08
 	Improvements in memory management for PS generation
 
 2018-01-31
 	Partial refactoring: quantum number assigment NLO
 	Initial-state QCD splittings for hadron collisions
 
 2018-01-25
 	Bug fix for weighted events with VAMP2
 
 2018-01-17
 	Generalized interface for Recola versions 1.3+  and 2.1+
 
 2018-01-15
 	Channel equivalences also for VAMP2 integrator
 
 2018-01-12
 	Fix for OCaml compiler 4.06 (and newer)
 
 2017-12-19
 	RECOLA matrix elements with flavor sums can be integrated
 
 2017-12-18
 	Bug fix for segmentation fault in empty resonance histories
 
 2017-12-16
 	Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers
 	  from transferral between PYTHIA and WHIZARD event records
 
 2017-12-15
 	Event index for multiple processes in event file correct
 
 ##################################################################
 
 2017-12-13
 	RELEASE: version 2.6.2
 
 2017-12-07
 	User can set offset in event numbers
 
 2017-11-29
 	Possibility to have more than one RECOLA process in one file
 
 2017-11-23
 	Transversal/mixed (and unitarized) dim-8 operators
 
 2017-11-16
 	epa_q_max replaces epa_e_max (trivial factor 2)
 
 2017-11-15
 	O'Mega matrix element compilation silent now
 
 2017-11-14
 	Complete expanded P-wave form factor for top threshold
 
 2017-11-10
 	Incoming particles can be accessed in SINDARIN
 
 2017-11-08
 	Improved handling of resonance insertion, additional parameters
 
 2017-11-04
 	Added Higgs-electron coupling (SM_Higgs)
 
 ##################################################################
 
 2017-11-03
 	RELEASE: version 2.6.1
 
 2017-10-20
 	More than 5 NLO components possible at same time
 
 2017-10-19
 	Gaussian cutoff for shower resonance matching
 
 2017-10-12
 	Alternative (more efficient) method to generate
 	   phase space file
 
 2017-10-11
 	Bug fix for shower resonance histories for processes
 	   with multiple components
 
 2017-09-25
 	Bug fix for process libraries in shower resonance histories
 
 2017-09-21
 	Correctly generate pT distribution for EPA remnants
 
 2017-09-20
 	Set branching ratios for unstable particles also by hand
 
 2017-09-14
 	Correctly generate pT distribution for ISR photons
 
 ##################################################################
 
 2017-09-08
 	RELEASE: version 2.6.0
 
 2017-09-05
 	Bug fix for initial state NLO QCD flavor structures
 	Real and virtual NLO QCD hadron collider processes
 	   work with internal interactions
 
 2017-09-04
 	Fully validated MPI integration and event generation
 
 2017-09-01
 	Resonance histories for shower: full support
 	Bug fix in O'Mega model constraints
 	O'Mega allows to output a parsable form of the DAG
 
 2017-08-24
 	Resonance histories in events for transferral
 	   to parton shower (e.g. in ee -> jjjj)
 
 2017-08-01
 	Alpha version of HepMC v3 interface
 	   (not yet really functional)
 
 2017-07-31
 	Beta version for RECOLA OLP support
 
 2017-07-06
 	Radiation generator fix for LHC processes
 
 2017-06-30
 	Fix bug for NLO with structure
 	   functions and/or polarization
 
 2017-06-23
 	Collinear limit for QED corrections works
 
 2017-06-17
 	POWHEG grids generated already during integration
 
 2017-06-12
 	Soft limit for QED corrections works
 
 2017-05-16
 	Beta version of full MPI parallelization (VAMP2)
 	Check consistency of POWHEG grid files
 	Logfile config-summary.log for configure summary
 
 2017-05-12
 	Allow polarization in top threshold
 
 2017-05-09
 	Minimal demand automake 1.12.2
 	Silent rules for make procedures
 
 2017-05-07
 	Major fix for POWHEG damping
 	Correctly initialize FKS ISR phasespace
 
 ##################################################################
 
 2017-05-06
 	RELEASE: version 2.5.0
 
 2017-05-05
 	Full UFO support (SM-like models)
 	Fixed-beam ISR FKS phase space
 
 2017-04-26
 	QED splittings in radiation generator
 
 2017-04-10
 	Retire deprecated O'Mega vertex cache files
 
 ##################################################################
 
 2017-03-24
 	RELEASE: version 2.4.1
 
 2017-03-16
 	Distinguish resonance charge in phase space channels
 	Keep track of resonance histories in phase space
 	Complex mass scheme default for OpenLoops amplitudes
 
 2017-03-13
 	Fix helicities for polarized OpenLoops calculations
 
 2017-03-09
 	Possibility to advance RNG state in rng_stream
 
 2017-03-04
 	General setup for partitioning real emission
 	   phase space
 
 2017-03-06
 	Bug fix on rescan command for converting event files
 
 2017-02-27
 	Alternative multi-channel VEGAS implementation
 	   VAMP2: serial backbone for MPI setup
 	Smoothstep top threshold matching
 
 2017-02-25
 	Single-beam structure function with
 	   s-channel mapping supported
 	Safeguard against invalid process libraries
 
 2017-02-16
 	Radiation generator for photon emission
 
 2017-02-10
 	Fixes for NLO QCD processes (color correlations)
 
 2017-01-16
 	LCIO variable takes precedence over LCIO_DIR
 
 2017-01-13
 	Alternative random number generator
 	   rng_stream (cf. L'Ecuyer et al.)
 
 2017-01-01
 	Fix for multi-flavor BLHA tree
 	   matrix elements
 
 2016-12-31
 	Grid path option for VAMP grids
 
 2016-12-28
 	Alpha version of Recola OLP support
 
 2016-12-27
 	Dalitz plots for FKS phase space
 
 2016-12-14
 	NLO multi-flavor events possible
 
 2016-12-09
 	LCIO event header information added
 
 2016-12-02
 	Alpha version of RECOLA interface
 	Bug fix for generator status in LCIO
 
 ##################################################################
 
 2016-11-28
 	RELEASE: version 2.4.0
 
 2016-11-24
 	Bug fix for OpenLoops interface: EW scheme
 	   is set by WHIZARD
 	Bug fixes for top threshold implementation
 
 2016-11-11
 	Refactoring of dispatching
 
 2016-10-18
 	Bug fix for LCIO output
 
 2016-10-10
 	First implementation for collinear soft terms
 
 2016-10-06
 	First full WHIZARD models from UFO files
 
 2016-10-05
 	WHIZARD does not support legacy gcc 4.7.4 any longer
 
 2016-09-30
 	Major refactoring of process core and NLO components
 
 2016-09-23
 	WHIZARD homogeneous entity: discarding subconfigures
 	  for CIRCE1/2, O'Mega, VAMP subpackages; these are
 	  reconstructable by script projectors
 
 2016-09-06
 	Introduce main configure summary
 
 2016-08-26
 	Fix memory leak in event generation
 
 ##################################################################
 
 2016-08-25
 	RELEASE: version 2.3.1
 
 2016-08-19
 	Bug fix for EW-scheme dependence of gluino propagators
 
 2016-08-01
 	Beta version of complex mass scheme support
 
 2016-07-26
 	Fix bug in POWHEG damping for the matching
 
 ##################################################################
 
 2016-07-21
 	RELEASE: version 2.3.0
 
 2016-07-20
 	UFO file support (alpha version) in O'Mega
 
 2016-07-13
 	New (more) stable of WHIZARD GUI
 	Support for EW schemes for OpenLoops
 	Factorized NLO top decays for threshold model
 
 2016-06-15
 	Passing factorization scale to PYTHIA6
 	Adding charge and neutral observables
 
 2016-06-14
 	Correcting angular distribution/tweaked kinematics in
 	   non-collinear structure functions splittings
 
 2016-05-10
 	Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6
 	   (backwards validation of LC CDR/TDR samples)
 
 2016-04-27
 	Within OpenLoops virtuals: support for Collier library
 
 2016-04-25
 	O'Mega vertex tables only loaded at first usage
 
 2016-04-21
 	New CJ15 PDF parameterizations added
 
 2016-04-21
 	Support for hadron collisions at NLO QCD
 
 2016-04-05
 	Support for different (parameter) schemes in model files
 
 2016-03-31
 	Correct transferral of lifetime/vertex from PYTHIA/TAUOLA
 	  into the event record
 
 2016-03-21
 	New internal implementation of polarization
 	  via Bloch vectors, remove pointer constructions
 
 2016-03-13
 	Extension of cascade syntax for processes:
 	  exclude propagators/vertices etc. possible
 
 2016-02-24
 	Full support for OpenLoops QCD NLO matrix
 	  elements, inclusion in test suite
 
 2016-02-12
 	Substantial progress on QCD NLO support
 
 2016-02-02
 	Automated resonance mapping for FKS subtraction
 
 2015-12-17
 	New BSM model WZW for diphoton resonances
 
 ##################################################################
 
 2015-11-22
 	RELEASE: version 2.2.8
 
 2015-11-21
 	Bug fix for fixed-order NLO events
 
 2015-11-20
 	Anomalous FCNC top-charm vertices
 
 2015-11-19
 	StdHEP output via HEPEVT/HEPEV4 supported
 
 2015-11-18
 	Full set of electroweak dim-6 operators included
 
 2015-10-22
 	Polarized one-loop amplitudes supported
 
 2015-10-21
 	Fixes for event formats for showered events
 
 2015-10-14
 	Callback mechanism for event output
 
 2015-09-22
 	Bypass matrix elements in pure event sample rescans
 	StdHep frozen final version v5.06.01 included internally
 
 2015-09-21
 	configure option --with-precision to
 	  demand 64bit, 80bit, or 128bit Fortran
 	  and bind C precision types
 
 2015-09-07
 	More extensive tests of NLO
 	   infrastructure and POWHEG matching
 
 2015-09-01
 	NLO decay infrastructure
 	User-defined squared matrix elements
 	Inclusive FastJet algorithm plugin
 	Numerical improvement for small boosts
 
 ##################################################################
 
 2015-08-11
 	RELEASE: version 2.2.7
 
 2015-08-10
 	Infrastructure for damped POWHEG
 	Massive emitters in POWHEG
 	Born matrix elements via BLHA
 	GoSam filters via SINDARIN
 	Minor running coupling bug fixes
 	Fixed-order NLO events
 
 2015-08-06
 	CT14 PDFs included (LO, NLO, NNLL)
 
 2015-07-07
 	Revalidation of ILC WHIZARD-PYTHIA event chain
 	Extended test suite for showered events
 	Alpha version of massive FSR for POWHEG
 
 2015-06-09
 	Fix memory leak in interaction for long cascades
 	Catch mismatch between beam definition and CIRCE2 spectrum
 
 2015-06-08
 	Automated POWHEG matching: beta version
 	Infrastructure for GKS matching
 	Alpha version of fixed-order NLO events
 	CIRCE2 polarization averaged spectra with
 	   explicitly polarized beams
 
 2015-05-12
 	Abstract matching type: OO structure for matching/merging
 
 2015-05-07
 	Bug fix in event record WHIZARD-PYTHIA6 transferral
 	Gaussian beam spectra for lepton colliders
 
 ##################################################################
 
 2015-05-02
 	RELEASE: version 2.2.6
 
 2015-05-01
 	Models for (unitarized) tensor resonances in VBS
 
 2015-04-28
 	Bug fix in channel weights for event generation.
 
 2015-04-18
 	Improved event record transfer WHIZARD/PYTHIA6
 
 2015-03-19
 	POWHEG matching: alpha version
 
 ##################################################################
 
 2015-02-27
 	RELEASE: version 2.2.5
 
 2015-02-26
 	Abstract types for quantum numbers
 
 2015-02-25
 	Read-in of StdHEP events, self-tests
 
 2015-02-22
 	Bug fix for mother-daughter relations in
 	   showered/hadronized events
 
 2015-02-20
 	Projection on polarization in intermediate states
 
 2015-02-13
 	Correct treatment of beam remnants in
 	   event formats (also LC remnants)
 
 ##################################################################
 
 2015-02-06
 	RELEASE: version 2.2.4
 
 2015-02-06
 	Bug fix in event output
 
 2015-02-05
 	LCIO event format supported
 
 2015-01-30
 	Including state matrices in WHIZARD's internal IO
 	Versioning for WHIZARD's internal IO
 	Libtool update from 2.4.3 to 2.4.5
 	LCIO event output (beta version)
 
 2015-01-27
 	Progress on NLO integration
 	Fixing a bug for multiple processes in a single
 	   event file when using beam event files
 
 2015-01-19
 	Bug fix for spin correlations evaluated in the rest
 	   frame of the mother particle
 
 2015-01-17
 	Regression fix for statically linked processes
 	   from SARAH and FeynRules
 
 2015-01-10
 	NLO: massive FKS emitters supported (experimental)
 
 2015-01-06
 	MMHT2014 PDF sets included
 
 2015-01-05
 	Handling mass degeneracies in auto_decays
 
 2014-12-19
 	Fixing bug in rescan of event files
 
 ##################################################################
 
 2014-11-30
 	RELEASE: version 2.2.3
 
 2014-11-29
 	Beta version of LO continuum/NLL-threshold
 	matched top threshold model for e+e- physics
 
 2014-11-28
 	More internal refactoring: disentanglement of module
 	   dependencies
 
 2014-11-21
 	OVM: O'Mega Virtual Machine, bytecode instructions
 	   instead of compiled Fortran code
 
 2014-11-01
 	Higgs Singlet extension model included
 
 2014-10-18
 	Internal restructuring of code; half-way
 	  WHIZARD main code file disassembled
 
 2014-07-09
 	Alpha version of NLO infrastructure
 
 ##################################################################
 
 2014-07-06
 	RELEASE: version 2.2.2
 
 2014-07-05
 	CIRCE2: correlated LC beam spectra and
 	  GuineaPig Interface to LC machine parameters
 
 2014-07-01
 	Reading LHEF for decayed/factorized/showered/
 	   hadronized events
 
 2014-06-25
 	Configure support for GoSAM/Ninja/Form/QGraf
 
 2014-06-22
 	LHAPDF6 interface
 
 2014-06-18
 	Module for automatic generation of
 	  radiation and loop infrastructure code
 
 2014-06-11
 	Improved internal directory structure
 
 ##################################################################
 
 2014-06-03
 	RELEASE: version 2.2.1
 
 2014-05-30
 	Extensions of internal PDG arrays
 
 2014-05-26
 	FastJet interface
 
 2014-05-24
 	CJ12 PDFs included
 
 2014-05-20
 	Regression fix for external models (via SARAH
 	    or FeynRules)
 
 ##################################################################
 
 2014-05-18
 	RELEASE: version 2.2.0
 
 2014-04-11
 	Multiple components: inclusive process definitions,
 	   syntax: process A + B + ...
 
 2014-03-13
 	Improved PS mappings for e+e- ISR
 	ILC TDR and CLIC spectra included in CIRCE1
 
 2014-02-23
 	New models: AltH w\ Higgs for exclusion purposes,
 	  SM_rx for Dim 6-/Dim-8 operators, SSC for
 	  general strong interactions (w/ Higgs), and
 	  NoH_rx (w\ Higgs)
 
 2014-02-14
 	Improved s-channel mapping, new on-shell
 	  production mapping (e.g. Drell-Yan)
 
 2014-02-03
 	PRE-RELEASE: version 2.2.0_beta
 
 2014-01-26
 	O'Mega: Feynman diagram generation possible (again)
 
 2013-12-16
 	HOPPET interface for b parton matching
 
 2013-11-15
 	PRE-RELEASE: version 2.2.0_alpha-4
 
 2013-10-27
 	LHEF standards 1.0/2.0/3.0 implemented
 
 2013-10-15
 	PRE-RELEASE: version 2.2.0_alpha-3
 
 2013-10-02
 	PRE-RELEASE: version 2.2.0_alpha-2
 
 2013-09-25
 	PRE-RELEASE: version 2.2.0_alpha-1
 
 2013-09-12
 	PRE-RELEASE: version 2.2.0_alpha
 
 2013-09-03
 	General 2HDM implemented
 
 2013-08-18
 	Rescanning/recalculating events
 
 2013-06-07
 	Reconstruction of complete event
 	  from 4-momenta possible
 
 2013-05-06
 	Process library stacks
 
 2013-05-02
 	Process stacks
 
 2013-04-29
 	Single-particle phase space module
 
 2013-04-26
 	Abstract interface for random
 	  number generator
 
 2013-04-24
 	More object-orientation on modules
 	Midpoint-rule integrator
 
 2013-04-05
 	Object-oriented integration and
 	  event generation
 
 2013-03-12
 	Processes recasted object-oriented:
 	  MEs, scales, structure functions
 	First infrastructure for general Lorentz
 	  structures
 
 2013-01-17
 	Object-orientated reworking of library and
 	   process core, more variable internal structure,
 	   unit tests
 
 2012-12-14
 	Update Pythia version to 6.4.27
 
 2012-12-04
 	Fix the phase in HAZ vertices
 
 2012-11-21
 	First O'Mega unit tests, some infrastructure
 
 2012-11-13
 	Bug fix in anom. HVV Lorentz structures
 
 ##################################################################
 
 2012-09-18
 	RELEASE: version 2.1.1
 
 2012-09-11
 	Model MSSM_Hgg with Hgg and HAA vertices
 
 2012-09-10
 	First version of implementation of multiple
 	   interactions in WHIZARD
 
 2012-09-05
 	Infrastructure for internal CKKW matching
 
 2012-09-02
 	C, C++, Python API
 
 2012-07-19
 	Fixing particle numbering in HepMC format
 
 ##################################################################
 
 2012-06-15
 	RELEASE: version 2.1.0
 
 2012-06-14
 	Analytical and kT-ordered shower officially
 	  released
 	PYTHIA interface officially released
 
 2012-05-09
 	Intrisince PDFs can be used for showering
 
 2012-05-04
 	Anomalous Higgs couplings a la hep-ph/9902321
 
 ##################################################################
 
 2012-03-19
 	RELEASE: version 2.0.7
 
 2012-03-15
 	Run IDs are available now
 	More event variables in analysis
 	Modified raw event format (compatibility mode exists)
 
 2012-03-12
 	Bug fix in decay-integration order
 	MLM matching steered completely internally now
 
 2012-03-09
 	Special phase space mapping for narrow resonances
 	  decaying to 4-particle final states with far off-shell
 	  intermediate states
 	Running alphas from PDF collaborations with
 	  builtin PDFs
 
 2012-02-16
 	Bug fix in cascades decay infrastructure
 
 2012-02-04
 	WHIZARD documentation compatible with TeXLive 2011
 
 2012-02-01
 	Bug fix in FeynRules interface with --prefix flag
 
 2012-01-29
 	Bug fix with name clash of O'Mega variable names
 
 2012-01-27
 	Update internal PYTHIA to version 6.4.26
 	Bug fix in LHEF output
 
 2012-01-21
 	Catching stricter automake 1.11.2 rules
 
 2011-12-23
 	Bug fix in decay cascade setup
 
 2011-12-20
 	Bug fix in helicity selection rules
 
 2011-12-16
 	Accuracy goal reimplemented
 
 2011-12-14
 	WHIZARD compatible with TeXLive 2011
 
 2011-12-09
 	Option --user-target added
 
 ##################################################################
 
 2011-12-07
 	RELEASE: version 2.0.6
 
 2011-12-07
 	Bug fixes in SM_top_anom
 	Added missing entries to HepMC format
 
 2011-12-06
 	Allow to pass options to O'Mega
 	Bug fix for HEPEVT block for showered/hadronized events
 
 2011-12-01
 	Reenabled user plug-in for external code for
 	   cuts, structure functions, routines etc.
 
 2011-11-29
 	Changed model SM_Higgs for Higgs phenomenology
 
 2011-11-25
 	Supporting a Y, (B-L) Z' model
 
 2011-11-23
 	Make WHIZARD compatible for MAC OS X Lion/XCode 4
 
 2011-09-25
 	WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742
 
 2011-08-16
 	Model SM_QCD: QCD with one EW insertion
 
 2011-07-19
 	Explicit output channel for dvips avoids printing
 
 2011-07-10
 	Test suite for WHIZARD unit tests
 
 2011-07-01
 	Commands for matrix element tests
 	More OpenMP parallelization of kinematics
 	Added unit tests
 
 2011-06-23
 	Conversion of CIRCE2 from F77 to F90, major
 	  clean-up
 
 2011-06-14
 	Conversion of CIRCE1 from F77 to F90
 
 2011-06-10
 	OpenMP parallelization of channel kinematics
 		(by Matthias Trudewind)
 
 2011-05-31
 	RELEASE: version 1.97
 
 2011-05-24
 	Minor bug fixes: update grids and elsif statement.
 
 ##################################################################
 
 2011-05-10
 	RELEASE: version 2.0.5
 
 2011-05-09
 	Fixed bug in final state flavor sums
 	Minor improvements on phase-space setup
 
 2011-05-05
 	Minor bug fixes
 
 2011-04-15
 	WHIZARD as a precompiled 64-bit binary available
 
 2011-04-06
 	Wall clock instead of cpu time for time estimates
 
 2011-04-05
 	Major improvement on the phase space setup
 
 2011-04-02
 	OpenMP parallelization for helicity loop in O'Mega
 	   matrix elements
 
 2011-03-31
 	Tools for relocating WHIZARD and use in batch
 	environments
 
 2011-03-29
 	Completely static builds possible, profiling options
 
 2011-03-28
 	Visualization of integration history
 
 2011-03-27
 	Fixed broken K-matrix implementation
 
 2011-03-23
 	Including the GAMELAN manual in the distribution
 
 2011-01-26
 	WHIZARD analysis can handle hadronized event files
 
 2011-01-17
 	MSTW2008 and CT10 PDF sets included
 
 2010-12-23
 	Inclusion of NMSSM with Hgg couplings
 
 2010-12-21
 	Advanced options for integration passes
 
 2010-11-16
 	WHIZARD supports CTEQ6 and possibly other PDFs
 	directly; data files included in the distribution
 
 ##################################################################
 
 2010-10-26
 	RELEASE: version 2.0.4
 
 2010-10-06
 	Bug fix in MSSM implementation
 
 2010-10-01
 	Update to libtool 2.4
 
 2010-09-29
 	Support for anomalous top couplings (form factors etc.)
 	Bug fix for running gauge Yukawa SUSY couplings
 
 2010-09-28
 	RELEASE: version 1.96
 
 2010-09-21
 	Beam remnants and pT spectra for lepton collider re-enabled
 	Restructuring subevt class
 
 2010-09-16
 	Shower and matching are disabled by default
 	PYTHIA as a conditional on these two options
 
 2010-09-14
 	Possibility to read in beam spectra re-enabled (e.g. Guinea
 	   Pig)
 
 2010-09-13
 	Energy scan as (pseudo-) structure functions re-implemented
 
 2010-09-10
 	CIRCE2 included again in WHIZARD 2 and validated
 
 2010-09-02
 	Re-implementation of asymmetric beam energies and collision
 	  angles, e-p collisions work, inclusion of a HERA DIS test
 	  case
 
 ##################################################################
 
 2010-10-18
 	RELEASE: version 2.0.3
 
 2010-08-08
 	Bug in CP-violating anomalous triple TGCs fixed
 
 2010-08-06
 	Solving backwards compatibility problem with O'Caml 3.12.0
 
 2010-07-12
 	Conserved quantum numbers speed up O'Mega code generation
 
 2010-07-07
 	Attaching full ISR/FSR parton shower and MPI/ISR
 	   module
 	Added SM model containing Hgg, HAA, HAZ vertices
 
 2010-07-02
 	Matching output available as LHEF and STDHEP
 
 2010-06-30
 	Various bug fixes, missing files, typos
 
 2010-06-26
 	CIRCE1 completely re-enabled
 	Chaining structure functions supported
 
 2010-06-25
 	Partial support for conserved quantum numbers in
 	   O'Mega
 
 2010-06-21
 	Major upgrade of the graphics package: error bars,
 	   smarter SINDARIN steering, documentation, and all that...
 
 2010-06-17
 	MLM matching with PYTHIA shower included
 
 2010-06-16
 	Added full CIRCE1 and CIRCE2 versions including
 	full documentation and miscellanea to the trunk
 
 2010-06-12
 	User file management supported, improved variable
 	and command structure
 
 2010-05-24
 	Improved handling of variables in local command lists
 
 2010-05-20
 	PYTHIA interface re-enabled
 
 2010-05-19
 	ASCII file formats for interfacing ROOT and gnuplot in
 	   data analysis
 
 ##################################################################
 
 2010-05-18
 	RELEASE: version 2.0.2
 
 2010-05-14
 	Reimplementation of visualization of phase space
 	   channels
 	Minor bug fixes
 
 2010-05-12
 	Improved phase space - elimination of redundancies
 
 2010-05-08
 	Interface for polarization completed: polarized beams etc.
 
 2010-05-06
 	Full quantum numbers appear in process log
 	Integration results are usable as user variables
 	Communication with external programs
 
 2010-05-05
 	Split module commands into commands, integration,
 	   simulation modules
 
 2010-05-04
 	FSR+ISR for the first time connected to the WHIZARD 2 core
 
 ##################################################################
 
 2010-04-25
 	RELEASE: version 2.0.1
 
 2010-04-23
 	Automatic compile and integrate if simulate is called
 	Minor bug fixes in O'Mega
 
 2010-04-21
 	Checkpointing for event generation
 	Flush statements to use WHIZARD inside a pipe
 
 2010-04-20
 	Reimplementation of signal handling in WGIZARD 2.0
 
 2010-04-19
 	VAMP is now a separately configurable and installable unit of
 	   WHIZARD, included VAMP self-checks
 	Support again compilation in quadruple precision
 
 2010-04-06
 	Allow for logarithmic plots in GAMELAN, reimplement the
 	   possibility to set the number of bins
 
 2010-04-15
 	Improvement on time estimates for event generation
 
 ##################################################################
 
 2010-04-12
 	RELEASE: version 2.0.0
 
 2010-04-09
 	Per default, the code for the amplitudes is subdivided to allow
 	  faster compiler optimization
 	More advanced and unified and straightforward command language
 	  syntax
 	Final bug fixes
 
 2010-04-07
 	Improvement on SINDARIN syntax; printf, sprintf function
 	  thorugh a C interface
 
 2010-04-05
 	Colorizing DAGs instead of model vertices: speed boost
 	  in colored code generation
 
 2010-03-31
 	Generalized options for normalization of weighted and
 	  unweighted events
 	Grid and weight histories added again to log files
 	Weights can be used in analyses
 
 2010-03-28
 	Cascade decays completely implemented including color and
 	   spin correlations
 
 2010-03-07
 	Added new WHIZARD header with logo
 
 2010-03-05
 	Removed conflict in O'Mega amplitudes between flavour sums
 	   and cascades
 	StdHEP interface re-implemented
 
 2010-03-03
 	RELEASE: version 2.0.0rc3
 	Several bug fixes for preventing abuse in input files
 	OpenMP support for amplitudes
 	Reimplementation of WHIZARD 1 HEPEVT ASCII event formats
 	FeynRules interface successfully passed MSSM test
 
 2010-02-26
 	Eliminating ghost gluons from multi-gluon amplitudes
 
 2010-02-25
 	RELEASE: version 1.95
 	HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2
 
 2010-02-23
 	Running alpha_s implemented in the FeynRules interface
 
 2010-02-19
 	MSSM (semi-) automatized self-tests finalized
 
 2010-02-17
 	RELEASE: version 1.94
 
 2010-02-16
 	Closed memory corruption in WHIZARD 1
 	Fixed problems of old MadGraph and CompHep drivers
 	   with modern compilers
 	Uncolored vertex selection rules for colored amplitudes in
 	   O'Mega
 
 2010-02-15
 	Infrastructure for color correlation computation in O'Mega
 	   finished
 	Forbidden processes are warned about, but treated as non-fatal
 
 2010-02-14
 	Color correlation computation in O'Mega finalized
 
 2010-02-10
 	Improving phase space mappings for identical particles in
 	initial and final states
 	Introduction of more extended multi-line error message
 
 2010-02-08
 	First O'Caml code for computation of color correlations in
 	O'Mega
 
 2010-02-07
 	First MLM matching with e+ e- -> jets
 
 ##################################################################
 
 2010-02-06
 	RELEASE: version 2.0.0rc2
 
 2010-02-05
 	Reconsidered the Makefile structure and more extended tests
 	Catch a crash between WHIZARD and O'Mega for forbidden processes
 	Tensor products of arbitrary color structures in jet definitions
 
 2010-02-04
 	Color correlation computation in O'Mega finalized
 
 ##################################################################
 
 2010-02-03
 	RELEASE: version 2.0.0rc1
 
 ##################################################################
 
 2010-01-31
 	Reimplemented numerical helicity selection rules
 	Phase space functionality of version 1 restored and improved
 
 2009-12-05
 	NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam)
 
 2009-12-04
 	RELEASE: version 2.0.0alpha
 
 ##################################################################
 
 2009-04-16
 	RELEASE: version 1.93
 
 2009-04-15
 	Clean-up of Makefiles and configure scripts
 	Reconfiguration of BSM model implementation
 	extended supersymmetric models
 
 2008-12-23
 	New model NMSSM	(Felix Braam)
 	SLHA2 added
 	Bug in LHAPDF interface fixed
 
 2008-08-16
 	Bug fixed in K matrix implementation
 	Gravitino option in the MSSM added
 
 2008-03-20
 	Improved color and flavor sums
 
 ##################################################################
 
 2008-03-12
 	RELEASE: version 1.92
 	LHEF (Les Houches Event File) format added
 	Fortran 2003 command-line interface (if supported by the compiler)
 	Automated interface to colored models
 	More bug fixes and workarounds for compiler compatibility
 
 ##################################################################
 
 2008-03-06
 	RELEASE: version 1.91
 	New model K-matrix (resonances and anom. couplings in WW scattering)
 	EWA spectrum
 	Energy-scan pseudo spectrum
 	Preliminary parton shower module (only from final-state quarks)
 	Cleanup and improvements of configure process
 	Improvements for O'Mega parameter files
 	Quadruple precision works again
 	More plotting options: lines, symbols, errors
 	Documentation with PDF bookmarks enabled
 	Various bug fixes
 
 2007-11-29
 	New model UED
 
 ##################################################################
 
 2007-11-23
 	RELEASE: version 1.90
 	O'Mega now part of the WHIZARD tree
 	Madgraph/CompHEP disabled by default (but still usable)
 	Support for LHAPDF (preliminary)
 	Added new models: SMZprime, SM_km, Template
 	Improved compiler recognition and compatibility
 	Minor bug fixes
 
 ##################################################################
 
 2006-06-15
 	RELEASE: version 1.51
 	Support for anomaly-type Higgs couplings (to gluon and photon/Z)
 	Support for spin 3/2 and spin 2
 	New models: Little Higgs (4 versions), toy models for extra dimensions
           and gravitinos
 	Fixes to the whizard.nw source documentation to run through LaTeX
 	Intel 9.0 bug workaround (deallocation of some arrays)
 
 2006-05-15
 	O'Mega RELEASE: version 0.11
 	merged JRR's O'Mega extensions
 
 ##################################################################
 
 2006-02-07
 	RELEASE: version 1.50
         To avoid confusion: Mention outdated manual example in BUGS file
         O'Mega becomes part of the WHIZARD generator
 
 2006-02-02   [bug fix update]
 	Bug fix: spurious error when writing event files for weighted events
 	Bug fix: 'r' option for omega produced garbage for some particle names
 	Workaround for ifort90 bug (crash when compiling whizard_event)
 	Workaround for ifort90 bug (crash when compiling hepevt_common)
 
 2006-01-27
 	Added process definition files for MSSM 2->2 processes
 	Included beam recoil for EPA (T.Barklow)
 	Updated STDHEP byte counts (for STDHEP 5.04.02)
 	Fixed STDHEP compatibility (avoid linking of incomplete .so libs)
 	Fixed issue with comphep requiring Xlibs on Opteron
 	Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface)
 	Fixed color-flow code: was broken for omega with option 'c' and 'w'
 	Workaround hacks for g95 compatibility
 
 2005-11-07
 	O'Mega RELEASE: version 0.10
 	O'Mega, merged JRR's and WK's color hack for WHiZard
         O'Mega, EXPERIMENTAL: cache fusion tables (required for colors
 	  a la JRR/WK)
         O'Mega, make JRR's MSSM official
 
 ##################################################################
 
 2005-10-25
 	RELEASE: version 1.43
 	Minor fixes in MSSM couplings (Higgs/3rd gen squarks).
 	  This should be final, since the MSSM results agree now completely
           with Madgraph and Sherpa
 	User-defined lower and upper limits for split event file count
 	Allow for counters (events, bytes) exceeding $2^{31}$
 	Revised checksum treatment and implementation (now MD5)
         Bug fix: missing process energy scale in raw event file
 
 ##################################################################
 
 2005-09-30
 	RELEASE: version 1.42
 	Graphical display of integration history ('make history')
 	Allow for switching off signals even if supported (configure option)
 
 2005-09-29
 	Revised phase space generation code, in particular for flavor sums
 	Negative cut and histogram codes use initial beams instead of
 	  initial parton momenta.  This allows for computing, e.g., E_miss
 	Support constant-width and zero-width options for O'Mega
 	Width options now denoted by w:X (X=f,c,z).  f option obsolescent
 	Bug fix: colorized code: flipped indices could screw up result
 	Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem)
 	Bug fix: dvips on systems where dvips defaults to lpr
 	Bug fix: integer overflow if too many events are requested
 
 2005-07-29
 	Allow for 2 -> 1 processes (if structure functions are on)
 
 2005-07-26
 	Fixed and expanded the 'test' matrix element:
 	  Unit matrix element with option 'u' / default: normalized phase space
 
 ##################################################################
 
 2005-07-15
 	RELEASE: version 1.41
 	Bug fix: no result for particle decay processes with width=0
 	Bug fix: line breaks in O'Mega files with color decomposition
 
 2005-06-02
 	New self-tests (make test-QED / test-QCD / test-SM)
 	  check lists of 2->2 processes
 	Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex)
 
 2005-05-25
 	Revised Makefile structure
 	Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA)
 
 2005-05-19
 	Support for color in O'Mega (using color flow decomposition)
 	New model QCD
 	Parameter file changes that correspond to replaced SM module in O'Mega
 	Bug fixes in MSSM (O'Mega) parameter file
 
 2005-05-18
 	New event file formats, useful for LHC applications:
           ATHENA and Les Houches Accord (external fragmentation)
         Naive (i.e., leading 1/N) color factor now implemented both for
           incoming and outgoing partons
 
 2005-01-26
 	include missing HELAS files for bundle
 	pgf90 compatibility issues [note: still internal error in pgf90]
 
 ##################################################################
 
 2004-12-13
 	RELEASE: version 1.40
 	compatibility fix: preprocessor marks in helas code now commented out
 	minor bug fix: format string in madgraph source
 
 2004-12-03
 	support for arbitray beam energies and directions
 	allow for pT kick in structure functions
 	bug fix: rounding error could result in zero cross section
 	  (compiler-dependent)
 
 2004-10-07
 	simulate decay processes
 	list fraction (of total width/cross section) instead of efficiency
           in process summary
 	new cut/analysis parameters AA, AAD, CTA: absolute polar angle
 
 2004-10-04
 	Replaced Madgraph I by Madgraph II.  Main improvement: model no
           longer hardcoded
 	introduced parameter reset_seed_each_process (useful for debugging)
         bug fix: color initialization for some processes was undefined
 
 2004-09-21
 	don't compile unix_args module if it is not required
 
 ##################################################################
 
 2004-09-20
 	RELEASE: version 1.30
 	g95 compatibility issues resolved
 	some (irrelevant) memory leaks closed
 	removed obsolete warning in circe1
 	manual update (essentially) finished
 
 2004-08-03
 	O'Mega RELEASE: version 0.9
 	O'Mega, src/trie.mli, src/trie.ml: make interface compatible with
           the O'Caml 3.08 library (remains compatible with older
           versions).  Implementation of unused functions still
           incomplete.
 
 2004-07-26
 	minor fixes and improvements in make process
 
 2004-06-29
 	workarounds for new Intel compiler bugs ...
 	no rebuild of madgraph/comphep executables after 'make clean'
 	bug fix in phase space routine:
           wrong energy for massive initial particles
         bug fix in (new) model interface: name checks for antiparticles
         pre-run checks for comphep improved
         ww-strong model file extended
         Model files particle name fixes, chep SM vertices included
 
 2004-06-22
 	O'Mega RELEASE: version 0.8
 	O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings
 
 2004-05-05
 	Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO)
 	NAG compiler: set number of continuation lines to 200 as default
 	Extended format for cross section summary; appears now in whizard.out
 	Fixed 'bundle' feature
 
 2004-04-28
 	Fixed compatibility with revised O'Mega SM_ac model
 	Fixed problem with x=0 or x=1 when calling PDFLIB (ThO)
 	Fixed bug in comphep module: Vtb was overlooked
 
 ##################################################################
 
 2004-04-15
 	RELEASE: version 1.28
         Fixed bug: Color factor was missing for O'Mega processes with
           four quarks and more
         Manual partially updated
 
 2004-04-08
 	Support for grid files in binary format
 	New default value show_histories=F (reduce output file size)
 	Revised phase space switches: removed annihilation_lines,
 	  removed s_channel_resonance, changed meaning of
 	  extra_off_shell_lines, added show_deleted_channels
 	Bug fixed which lead to omission of some phase space channels
 	Color flow guessed only if requested by guess_color_flow
 
 2004-03-10
 	New model interface: Only one model name specified in whizard.prc
         All model-dependent files reside in conf/models (modellib removed)
 
 2004-03-03
 	Support for input/output in SUSY Les Houches Accord format
 	Split event files if requested
 	Support for overall time limit
 	Support for CIRCE and CIRCE2 generator mode
 	Support for reading beam events from file
 
 2004-02-05
 	Fixed compiler problems with Intel Fortran 7.1 and 8.0
 	Support for catching signals
 
 ##################################################################
 
 2003-08-06
 	RELEASE: version 1.27
 	User-defined PDF libraries as an alternative to the standard PDFLIB
 
 2003-07-23
 	Revised phase space module: improved mappings for massless particles,
 	  equivalences of phase space channels are exploited
 	Improved mapping for PDF (hadron colliders)
 	Madgraph module: increased max number of color flows from 250 to 1000
 
 ##################################################################
 
 2003-06-23
 	RELEASE: version 1.26
 	CIRCE2 support
 	Fixed problem with 'TC' integer kind [Intel compiler complained]
 
 2003-05-28
 	Support for drawing histograms of grids
 	Bug fixes for MSSM definitions
 
 ##################################################################
 
 2003-05-22
 	RELEASE: version 1.25
 	Experimental MSSM support with ISAJET interface
 	Improved capabilities of generating/analyzing weighted events
 	Optional drawing phase space diagrams using FeynMF
 
 ##################################################################
 
 2003-01-31
 	RELEASE: version 1.24
 	A few more fixes and workarounds (Intel and Lahey compiler)
 
 2003-01-15
 	Fixes and workarounds needed for WHIZARD to run with Intel compiler
 	Command-line option interface for the Lahey compiler
 
 	Bug fix: problem with reading whizard.phs
 
 ##################################################################
 
 2002-12-10
 	RELEASE: version 1.23
 
 	Command-line options (on some systems)
 
 	Allow for initial particles in the event record, ordered:
           [beams, initials] - [remnants] - outgoing partons
 
 	Support for PYTHIA 6.2: Les Houches external process interface
 	String pythia_parameters can be up to 1000 characters long
 	Select color flow states in (internal) analysis
 	Bug fix in color flow content of raw event files
 
 	Support for transversal polarization of fermion beams
 	Cut codes: PHI now for absolute azimuthal angle, DPHI for distance
 	'Test' matrix elements optionally respect polarization
 
 	User-defined code can be inserted for spectra, structure functions
           and fragmentation
 
 	Time limits can be specified for adaptation and simulation
 	User-defined file names and file directory
         Initial weights in input file no longer supported
 
         Bug fix in MadGraph (wave function counter could overflow)
 
 	Bug fix: Gamelan (graphical analysis) was not built if noweb absent
 
 ##################################################################
 
 2002-03-16
 	RELEASE: version 1.22
 	Allow for beam remnants in the event record
 
 2002-03-01
         Handling of aliases in whizard.prc fixed (aliases are whole tokens)
 
 2002-02-28
 	Optimized phase space handling routines
 	  (total execution time reduced by 20-60%, depending on process)
 
 ##################################################################
 
 2002-02-26
 	RELEASE: version 1.21
 	Fixed ISR formula (ISR was underestimated in previous versions).
           New version includes ISR in leading-log approximation up to
           third order.  Parameter ISR_sqrts renamed to ISR_scale.
 
 ##################################################################
 
 2002-02-19
 	RELEASE: version 1.20
 	New process-generating method 'test' (dummy matrix element)
 	Compatibility with autoconf 2.50 and current O'Mega version
 
 2002-02-05
 	Prevent integration channels from being dropped (optionally)
 	New internal mapping for structure functions improves performance
 	Old whizard.phx file deleted after recompiling (could cause trouble)
 
 2002-01-24
 	Support for user-defined cuts and matrix element reweighting
 	STDHEP output now written by write_events_format=20 (was 3)
 
 2002-01-16
 	Improved structure function handling; small changes in user interface:
           new parameter structured_beams in &process_input
           parameter fixed_energy in &beam_input removed
 	Support for multiple initial states
 	Eta-phi (cone) cut possible (hadron collider applications)
 	Fixed bug: Whizard library was not always recompiled when necessary
 	Fixed bug: Default cuts were insufficient in some cases
 	Fixed bug: Unusable phase space mappings generated in some cases
 
 2001-12-06
 	Reorganized document source
 
 2001-12-05
 	Preliminary CIRCE2 support (no functionality yet)
 
 2001-11-27
 	Intel compiler support (does not yet work because of compiler bugs)
 	New cut and analysis mode cos-theta* and related
 	Fixed circular jetset_interface dependency warning
 	Some broadcast routines removed (parallel support disabled anyway)
 	Minor shifts in cleanup targets (Makefiles)
         Modified library search, check for pdflib8*
 
 2001-08-06
 	Fixed bug: I/O unit number could be undefined when reading phase space
 	Fixed bug: Unitialized variable could cause segfault when
                    event generation was disabled
 	Fixed bug: Undefined subroutine in CIRCE replacement module
 	Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements
 		   (CompHEP model sm-GF #5, O'Mega model SM_ac)
 	Fixed portability issue: Makefile did rely on PWD environment variable
 	Fixed portability issue: PYTHIA library search ambiguity resolved
 
 2001-08-01
 	Default whizard.prc and whizard.in depend on activated modules
 	Fixed bug: TEX=latex was not properly enabled when making plots
 
 2001-07-20
 	Fixed output settings in PERL script calls
 	Cache enabled in various configure checks
 
 2001-07-13
 	Support for multiple processes in a single WHIZARD run.  The
           integrations are kept separate, but the generated events are mixed
 	The whizard.evx format has changed (incompatible), including now
 	  the color flow information for PYTHIA fragmentation
 	Output files are now process-specific, except for the event file
 	Phase space file whizard.phs (if present) is used only as input,
 	  program-generated phase space is now in whizard.phx
 
 2001-07-10
 	Bug fix: Undefined parameters in parameters_SM_ac.f90 removed
 
 2001-07-04
 	Bug fix: Compiler options for the case OMEGA is disabled
 	Small inconsistencies in whizard.out format fixed
 
 2001-07-01
 	Workaround for missing PDFLIB dummy routines in PYTHIA library
 
 ##################################################################
 
 2001-06-30
 	RELEASE: version 1.13
 	Default path /cern/pro/lib in configure script
 
 2001-06-20
 	New fragmentation option: Interface for PYTHIA with full color flow
           information, beam remnants etc.
 
 2001-06-18
 	Severe bug fixed in madgraph interface: 3-gluon coupling was missing
 	Enabled color flow information in madgraph
 
 2001-06-11
 	VAMP interface module rewritten
 	Revised output format: Multiple VAMP iterations count as one WHIZARD
           iteration in integration passes 1 and 3
 	Improved message and error handling
 	Bug fix in VAMP: handle exceptional cases in rebinning_weights
 
 2001-05-31
 	new parameters for grid adaptation: accuracy_goal and efficiency_goal
 
 ##################################################################
 
 2001-05-29
 	RELEASE: version 1.12
 	bug fixes (compilation problems): deleted/modified unused functions
 
 2001-05-16
 	diagram selection improved and documented
 
 2001-05-06
         allow for disabling packages during configuration
 
 2001-05-03
 	slight changes in whizard.out format; manual extended
 
 ##################################################################
 
 2001-04-20
 	RELEASE: version 1.11
 	fixed some configuration and compilation problems (PDFLIB etc.)
 
 2001-04-18
 	linked PDFLIB: support for quark/gluon structure functions
 
 2001-04-05
 	parameter interface written by PERL script
 	SM_ac model file: fixed error in continuation line
 
 2001-03-13
 	O'Mega, O'Caml 3.01: incompatible changes
 	O'Mega, src/trie.mli: add covariance annotation to T.t
 	  This breaks O'Caml 3.00, but is required for O'Caml 3.01.
 	O'Mega, many instances: replace `sig include Module.T end' by
 	  `Module.T', since the bug is fixed in O'Caml 3.01
 
 2001-02-28
 	O'Mega, src/model.mli:
             new field Model.vertices required for model functors, will
 	    retire Model.fuse2, Model.fuse3, Model.fusen soon.
 
 ##################################################################
 
 2001-03-27
 	RELEASE: version 1.10
 	reorganized the modules as libraries
 	linked PYTHIA: support for parton fragmentation
 
 2000-12-14
 	fixed some configuration problems (if noweb etc. are absent)
 
 ##################################################################
 
 2000-12-01
 	RELEASE of first public version: version 1.00beta