shower.nw
No OneTemporary
Actions

Size

334 KB

Subscribers

None

shower.nw
View Options

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

	% -- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; --
	% WHIZARD shower code as NOWEB source
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\chapter{Parton shower and interface to PYTHIA6}

	This is the code for the \whizard\ QCD parton shower for final state
	radiation (FSR) and initial state radiation (ISR) as well as the interface
	to the \pythia\ module for showering and hadronization.

	\section{Basics of the shower}
	<<[[shower_base.f90]]>>=
	<<File header>>

	module shower_base

	<<Use kinds with double>>
	<<Use strings>>
	use io_units
	use constants
	use diagnostics
	use format_utils, only: write_separator
	use os_interface
	use rng_base
	use physics_defs
	use lhapdf !NODEP!
	use pdf_builtin !NODEP!
	use sm_physics, only: running_as_lam
	use particles
	use variables
	use model_data

	<<Standard module head>>

	<<Shower base: parameters>>

	<<Shower base: public>>

	<<Shower base: types>>

	<<Shower base: interfaces>>

	contains

	<<Shower base: procedures>>

	end module shower_base
	@ %def shower_base
	@
	\subsection{Shower implementations}
	<<Shower base: public>>=
	public :: PS_WHIZARD, PS_PYTHIA6, PS_PYTHIA8, PS_UNDEFINED
	<<Shower base: parameters>>=
	integer, parameter :: PS_WHIZARD = 1
	integer, parameter :: PS_PYTHIA6 = 2
	integer, parameter :: PS_PYTHIA8 = 3
	integer, parameter :: PS_UNDEFINED = 17
	@ %def PS_WHIZARD PS_PYTHIA6 PS_PYTHIA8 PS_UNDEFINED
	@ A dictionary
	<<Shower base: public>>=
	public :: shower_method_of_string
	<<Shower base: procedures>>=
	elemental function shower_method_of_string (string) result (i)
	integer :: i
	type(string_t), intent(in) :: string
	select case (char(string))
	case ("WHIZARD")
	i = PS_WHIZARD
	case ("PYTHIA6")
	i = PS_PYTHIA6
	case ("PYTHIA8")
	i = PS_PYTHIA8
	case default
	i = PS_UNDEFINED
	end select
	end function shower_method_of_string

	@ %def shower_method_of_string
	@
	<<Shower base: public>>=
	public :: shower_method_to_string
	<<Shower base: procedures>>=
	elemental function shower_method_to_string (i) result (string)
	type(string_t) :: string
	integer, intent(in) :: i
	select case (i)
	case (PS_WHIZARD)
	string = "WHIZARD"
	case (PS_PYTHIA6)
	string = "PYTHIA6"
	case (PS_PYTHIA8)
	string = "PYTHIA8"
	case default
	string = "UNDEFINED"
	end select
	end function shower_method_to_string

	@ %def shower_method_to_string
	@
	\subsection{PDF Parameters}
	The shower has to know about the PDF set used for the parent process,
	if any. We support the following:
	<<Shower base: 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.
	<<Shower base: public>>=
	public :: pdf_data_t
	<<Shower base: types>>=
	type :: pdf_data_t
	type(lhapdf_pdf_t) :: pdf
	real(default) :: xmin, xmax, qmin, qmax
	integer :: type = STRF_NONE
	integer :: set = 0
	contains
	<<Shower base: pdf data: TBP>>
	end type pdf_data_t

	@ %def pdf_data
	@
	<<Shower base: pdf data: TBP>>=
	procedure :: init => pdf_data_init
	<<Shower base: procedures>>=
	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
	@
	<<Shower base: pdf data: TBP>>=
	procedure :: write => pdf_data_write
	<<Shower base: procedures>>=
	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
	@ This could be overloaded with a version that only asks for a specific
	flavor as it is supported by LHAPDF6.
	<<Shower base: pdf data: TBP>>=
	procedure :: evolve => pdf_data_evolve
	<<Shower base: procedures>>=
	subroutine pdf_data_evolve (pdf_data, x, q, f)
	class(pdf_data_t), intent(inout) :: pdf_data
	real(double) :: x, q
	real(double), dimension(-6:6), intent(out) :: f
	select case (pdf_data%type)
	case (STRF_PDF_BUILTIN)
	call pdf_evolve_LHAPDF (pdf_data%set, x, q, f)
	case (STRF_LHAPDF6)
	q = min (pdf_data%qmax, q)
	q = max (pdf_data%qmin, q)
	call pdf_data%pdf%evolve_pdfm (x, q, f)
	case (STRF_LHAPDF5)
	q = min (pdf_data%qmax, q)
	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
	@
	\subsection{Shower settings}
	These the general shower settings, the settings and parameters for the
	matching are defined in the corresponding matching modules.
	<<Shower base: public>>=
	public :: shower_settings_t
	<<Shower base: types>>=
	type :: shower_settings_t
	logical :: active = .false.
	logical :: isr_active = .false.
	logical :: fsr_active = .false.
	logical :: muli_active = .false.
	logical :: verbose = .false.
	integer :: method = PS_UNDEFINED
	logical :: hadronization_active = .false.
	logical :: mlm_matching = .false.
	logical :: ckkw_matching = .false.
	logical :: powheg_matching = .false.
	type(string_t) :: pythia6_pygive
	!!! values present in PYTHIA and WHIZARDs PS,
	!!! comments denote corresponding PYTHIA values
	real(default) :: d_min_t = 1._default ! PARJ(82)^2
	real(default) :: fsr_lambda = 0.29_default ! PARP(72)
	real(default) :: isr_lambda = 0.29_default ! PARP(61)
	integer :: max_n_flavors = 5 ! MSTJ(45)
	logical :: isr_alpha_s_running = .true. ! MSTP(64)
	logical :: fsr_alpha_s_running = .true. ! MSTJ(44)
	real(default) :: fixed_alpha_s = 0._default ! PARU(111)
	logical :: isr_pt_ordered = .false.
	logical :: isr_angular_ordered = .true. ! MSTP(62)
	real(default) :: isr_primordial_kt_width = 0._default ! PARP(91)
	real(default) :: isr_primordial_kt_cutoff = 5._default ! PARP(93)
	real(default) :: isr_z_cutoff = 0.999_default ! 1-PARP(66)
	real(default) :: isr_minenergy = 2._default ! PARP(65)
	real(default) :: isr_tscalefactor = 1._default
	logical :: isr_only_onshell_emitted_partons = .true. ! MSTP(63)
	contains
	<<Shower base: shower settings: TBP>>
	end type shower_settings_t

	@ %def shower_settings_t
	@ Read in the shower settings (and flags whether matching and
	hadronization are switched on).
	<<Shower base: shower settings: TBP>>=
	procedure :: init => shower_settings_init
	<<Shower base: procedures>>=
	subroutine shower_settings_init (shower_settings, var_list)
	class(shower_settings_t), intent(out) :: shower_settings
	type(var_list_t), intent(in) :: var_list

	shower_settings%fsr_active = &
	var_list%get_lval (var_str ("?ps_fsr_active"))
	shower_settings%isr_active = &
	var_list%get_lval (var_str ("?ps_isr_active"))
	shower_settings%muli_active = &
	var_list%get_lval (var_str ("?muli_active"))
	shower_settings%hadronization_active = &
	var_list%get_lval (var_str ("?hadronization_active"))
	shower_settings%mlm_matching = &
	var_list%get_lval (var_str ("?mlm_matching"))
	shower_settings%ckkw_matching = &
	var_list%get_lval (var_str ("?ckkw_matching"))
	shower_settings%powheg_matching = &
	var_list%get_lval (var_str ("?powheg_matching"))

	shower_settings%method = shower_method_of_string ( &
	var_list%get_sval (var_str ("$shower_method")))

	!!! We have to split off hadronization settings at some point.

	shower_settings%active = shower_settings%isr_active .or. &
	shower_settings%fsr_active .or. &
	shower_settings%powheg_matching .or. &
	shower_settings%muli_active .or. &
	shower_settings%hadronization_active
	if (.not. shower_settings%active) return
	shower_settings%verbose = &
	var_list%get_lval (var_str ("?shower_verbose"))
	shower_settings%pythia6_pygive = &
	var_list%get_sval (var_str ("$ps_PYTHIA_PYGIVE"))
	shower_settings%d_min_t = &
	(var_list%get_rval (var_str ("ps_mass_cutoff"))**2)
	shower_settings%fsr_lambda = &
	var_list%get_rval (var_str ("ps_fsr_lambda"))
	shower_settings%isr_lambda = &
	var_list%get_rval (var_str ("ps_isr_lambda"))
	shower_settings%max_n_flavors = &
	var_list%get_ival (var_str ("ps_max_n_flavors"))
	shower_settings%isr_alpha_s_running = &
	var_list%get_lval (var_str ("?ps_isr_alpha_s_running"))
	shower_settings%fsr_alpha_s_running = &
	var_list%get_lval (var_str ("?ps_fsr_alpha_s_running"))
	shower_settings%fixed_alpha_s = &
	var_list%get_rval (var_str ("ps_fixed_alpha_s"))
	shower_settings%isr_pt_ordered = &
	var_list%get_lval (var_str ("?ps_isr_pt_ordered"))
	shower_settings%isr_angular_ordered = &
	var_list%get_lval (var_str ("?ps_isr_angular_ordered"))
	shower_settings%isr_primordial_kt_width = &
	var_list%get_rval (var_str ("ps_isr_primordial_kt_width"))
	shower_settings%isr_primordial_kt_cutoff = &
	var_list%get_rval (var_str ("ps_isr_primordial_kt_cutoff"))
	shower_settings%isr_z_cutoff = &
	var_list%get_rval (var_str ("ps_isr_z_cutoff"))
	shower_settings%isr_minenergy = &
	var_list%get_rval (var_str ("ps_isr_minenergy"))
	shower_settings%isr_tscalefactor = &
	var_list%get_rval (var_str ("ps_isr_tscalefactor"))
	shower_settings%isr_only_onshell_emitted_partons = &
	var_list%get_lval (&
	var_str ("?ps_isr_only_onshell_emitted_partons"))
	end subroutine shower_settings_init

	@ %def shower_settings_init
	@
	<<Shower base: shower settings: TBP>>=
	procedure :: write => shower_settings_write
	<<Shower base: procedures>>=
	subroutine shower_settings_write (settings, unit)
	class(shower_settings_t), intent(in) :: settings
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "Shower settings:"
	call write_separator (u)
	write (u, "(1x,A)") "Master switches:"
	write (u, "(3x,A,1x,L1)") &
	"ps_isr_active = ", settings%isr_active
	write (u, "(3x,A,1x,L1)") &
	"ps_fsr_active = ", settings%fsr_active
	write (u, "(1x,A)") "General settings:"
	if (settings%isr_active .or. settings%fsr_active) then
	write (u, "(3x,A)") &
	"shower_method = " // &
	char (shower_method_to_string (settings%method))
	write (u, "(3x,A,1x,L1)") &
	"shower_verbose = ", settings%verbose
	write (u, "(3x,A,ES19.12)") &
	"ps_mass_cutoff = ", sqrt (abs (settings%d_min_t))
	write (u, "(3x,A,1x,I1)") &
	"ps_max_n_flavors = ", settings%max_n_flavors
	else
	write (u, "(3x,A)") " [ISR and FSR off]"
	end if
	if (settings%isr_active) then
	write (u, "(1x,A)") "ISR settings:"
	write (u, "(3x,A,1x,L1)") &
	"ps_isr_pt_ordered = ", settings%isr_pt_ordered
	write (u, "(3x,A,ES19.12)") &
	"ps_isr_lambda = ", settings%isr_lambda
	write (u, "(3x,A,1x,L1)") &
	"ps_isr_alpha_s_running = ", settings%isr_alpha_s_running
	write (u, "(3x,A,ES19.12)") &
	"ps_isr_primordial_kt_width = ", settings%isr_primordial_kt_width
	write (u, "(3x,A,ES19.12)") &
	"ps_isr_primordial_kt_cutoff = ", &
	settings%isr_primordial_kt_cutoff
	write (u, "(3x,A,ES19.12)") &
	"ps_isr_z_cutoff = ", settings%isr_z_cutoff
	write (u, "(3x,A,ES19.12)") &
	"ps_isr_minenergy = ", settings%isr_minenergy
	write (u, "(3x,A,ES19.12)") &
	"ps_isr_tscalefactor = ", settings%isr_tscalefactor
	else if (settings%fsr_active) then
	write (u, "(3x,A)") " [ISR off]"
	end if
	if (settings%fsr_active) then
	write (u, "(1x,A)") "FSR settings:"
	write (u, "(3x,A,ES19.12)") &
	"ps_fsr_lambda = ", settings%fsr_lambda
	write (u, "(3x,A,1x,L1)") &
	"ps_fsr_alpha_s_running = ", settings%fsr_alpha_s_running
	else if (settings%isr_active) then
	write (u, "(3x,A)") " [FSR off]"
	end if
	write (u, "(1x,A)") "Hadronization settings:"
	write (u, "(3x,A,1x,L1)") &
	"hadronization_active = ", settings%hadronization_active
	write (u, "(1x,A)") "Matching Settings:"
	write (u, "(3x,A,1x,L1)") &
	"mlm_matching = ", settings%mlm_matching
	write (u, "(3x,A,1x,L1)") &
	"ckkw_matching = ", settings%ckkw_matching
	write (u, "(1x,A)") "PYTHIA6 specific settings:"
	write (u, "(3x,A,A,A)") &
	"ps_PYTHIA_PYGIVE = '", &
	char(settings%pythia6_pygive), "'"
	end subroutine shower_settings_write

	@ %def shower_settings_write
	@
	\subsection{Abstract matching settings and data types}
	<<Shower base: public>>=
	public :: matching_settings_t
	<<Shower base: types>>=
	type, abstract :: matching_settings_t
	contains
	<<Shower base: matching settings: TBP>>
	end type matching_settings_t

	@ %def matching_settings_write
	@
	<<Shower base: matching settings: TBP>>=
	procedure (matching_settings_init), deferred :: init
	<<Shower base: interfaces>>=
	abstract interface
	subroutine matching_settings_init (settings, var_list)
	import
	class(matching_settings_t), intent(out) :: settings
	type(var_list_t), intent(in) :: var_list
	end subroutine matching_settings_init
	end interface

	@ %def matching_settings_init
	@
	<<Shower base: matching settings: TBP>>=
	procedure (matching_settings_write), deferred :: write
	<<Shower base: interfaces>>=
	abstract interface
	subroutine matching_settings_write (settings, unit)
	import
	class(matching_settings_t), intent(in) :: settings
	integer, intent(in), optional :: unit
	end subroutine matching_settings_write
	end interface

	@ %def matching_settings_write
	@
	<<Shower base: public>>=
	public :: matching_data_t
	<<Shower base: types>>=
	type, abstract :: matching_data_t
	logical :: is_hadron_collision = .false.
	end type matching_data_t

	@ %def matching_data_t
	@
	\subsection{Abstract Shower Type}
	Any parton shower implementation will use random numbers to generate
	emissions.
	<<Shower base: public>>=
	public :: shower_base_t
	<<Shower base: types>>=
	type, abstract :: shower_base_t
	class(rng_t), allocatable :: rng
	type(string_t) :: name
	type(pdf_data_t) :: pdf_data
	type(shower_settings_t) :: settings
	contains
	<<Shower base: shower base: TBP>>
	end type shower_base_t

	@ %def shower_base_t
	@
	<<Shower base: shower base: TBP>>=
	procedure :: write_msg => shower_base_write_msg
	<<Shower base: procedures>>=
	subroutine shower_base_write_msg (shower)
	class(shower_base_t), intent(inout) :: shower
	call msg_message ("Shower: Using " // char(shower%name) // " shower")
	end subroutine shower_base_write_msg

	@ %def shower_base_write_msg
	@
	<<Shower base: shower base: TBP>>=
	procedure :: import_rng => shower_base_import_rng
	<<Shower base: procedures>>=
	pure subroutine shower_base_import_rng (shower, rng)
	class(shower_base_t), intent(inout) :: shower
	class(rng_t), intent(inout), allocatable :: rng
	call move_alloc (from = rng, to = shower%rng)
	end subroutine shower_base_import_rng

	@ %def shower_base_import_rng
	@ Shower implementations need to know the overall settings as well as
	[[pdf_data_t]] if ISR needs to be simulated.
	<<Shower base: shower base: TBP>>=
	procedure (shower_base_init), deferred :: init
	<<Shower base: interfaces>>=
	abstract interface
	subroutine shower_base_init (shower, settings, pdf_data)
	import
	class(shower_base_t), intent(out) :: shower
	type(shower_settings_t), intent(in) :: settings
	type(pdf_data_t), intent(in) :: pdf_data
	end subroutine shower_base_init
	end interface

	@ %def shower_base_init
	@
	<<Shower base: shower base: TBP>>=
	procedure (shower_base_generate_emissions), deferred :: generate_emissions
	<<Shower base: interfaces>>=
	abstract interface
	subroutine shower_base_generate_emissions (shower, particle_set, &
	model, model_hadrons, os_data, matching_settings, data, &
	valid, vetoed, number_of_emissions)
	import
	class(shower_base_t), intent(inout), target :: shower
	type(particle_set_t), intent(inout) :: particle_set
	class(model_data_t), intent(in), target :: model
	class(model_data_t), intent(in), target :: model_hadrons
	class(matching_settings_t), intent(in), allocatable :: matching_settings
	class(matching_data_t), intent(inout), allocatable :: data
	type(os_data_t), intent(in) :: os_data
	logical, intent(inout) :: valid
	logical, intent(inout) :: vetoed
	integer, optional, intent(in) :: number_of_emissions
	end subroutine shower_base_generate_emissions
	end interface

	@ %def shower_base_generate_emissions
	@
	\subsection{Additional parameters}
	[[D_PRINT]] decides whether to print out additional information while
	[[ASSERT]] does additional sanity checks that should be disabled for
	production.
	<<Shower base: parameters>>=
	! TODO: (bcn 2015-02-18) Rename D_PRINT to DEBUG and ASSERT to ENSURE
	logical, parameter, public :: D_PRINT = .false.
	logical, parameter, public :: ASSERT = .false.
	@ %def D_PRINT
	@
	These parameters are the cut-off scale $t_{\text{cut}}$, given in
	GeV$^2$ ([[PARJ(82)]]), the cut-off scale for the $P_t^2$-ordered
	shower in GeV$^2$, and the two shower parameters [[PARP(72)]] and
	[[PARP(61)]], respectively.
	<<Shower base: parameters>>=
	real(default), public :: D_min_scale = 0.5_default
	real(default), public :: D_Lambda_isr = 0.29_default
	@ %def D_min_scale
	@ %def D_Lambda_isr
	@
	The parameter [[MSTJ(45)]] gives the maximum number of flavors in
	gluon decay to quarks:
	<<Shower base: parameters>>=
	integer, public :: D_Nf = 5
	@ %def D_Nf
	@
	These two parameters decide whether to use constant or running
	$alpha_s$ in the form of the function $D\_{alpha_s} (t)$ for the FSR
	and ISR ([[MSTJ(44)]], [[MSTP(64)]]), respectively. The next is the
	parameter [[PARU(111)]], which sets the value for constant $\alpha_s$,
	and the flag whether to use $P_t$-ordered ISR.
	<<Shower base: parameters>>=
	logical, public :: D_running_alpha_s_fsr = .true.
	logical, public :: D_running_alpha_s_isr = .true.
	real(default), public :: D_constalpha_s = 0.20_default
	logical, public :: alpha_s_fudged = .true.
	logical, public :: isr_pt_ordered = .false.
	@ %def D_running_alpha_s_fsr
	@ %def D_running_alpha_s_isr
	@ %def D_constantalpha_s
	@ %def isr_pt_ordered
	Treating either $u$ and $d$, or all quarks except $t$ as massless:
	<<Shower base: parameters>>=
	logical, public :: treat_light_quarks_massless = .true.
	logical, public :: treat_duscb_quarks_massless = .false.
	@ %def treat_light_quarks_massless
	@ %def treat_duscb_quarks_massless
	@
	The width and the cutoff of the Gaussian primordial $k_t$
	distribution, [[PARP(91)]] and [[PARP(93)]], in GeV:
	<<Shower base: parameters>>=
	real(default), public :: primordial_kt_width = 1.5_default
	real(default), public :: primordial_kt_cutoff = five
	@ %def primordial_kt_width
	@ %def primordial_kt_cutoff
	Temporary parameters for the $P_t$-ordered shower:
	<<Shower base: parameters>>=
	real(default), public :: scalefactor1 = 0.02_default
	real(default), public :: scalefactor2 = 0.02_default
	@ %def scalefactor1 scalefactor2
	@
	<<Shower base: public>>=
	public :: D_alpha_s_isr
	public :: D_alpha_s_fsr
	<<Shower base: procedures>>=
	function D_alpha_s_isr (tin, d_min_t) result (alpha_s)
	real(default), intent(in) :: tin, d_min_t
	real(default) :: t
	real(default) :: alpha_s
	if (alpha_s_fudged) then
	t = max (max (0.1_default * d_min_t, &
	1.1_default * D_Lambda_isr**2), abs(tin))
	else
	t = abs(tin)
	end if
	if (D_running_alpha_s_isr) then
	alpha_s = running_as_lam (number_of_flavors(t, d_min_t), &
	sqrt(t), D_Lambda_isr, 0)
	else
	alpha_s = D_constalpha_s
	end if
	end function D_alpha_s_isr

	function D_alpha_s_fsr (tin, d_min_t, d_lambda_fsr) result (alpha_s)
	real(default), intent(in) :: tin, d_min_t, d_lambda_fsr
	real(default) :: t
	real(default) :: alpha_s
	if (alpha_s_fudged) then
	t = max (max (0.1_default * d_min_t, &
	1.1_default * d_lambda_fsr**2), abs(tin))
	else
	t = abs(tin)
	end if
	if (D_running_alpha_s_fsr) then
	alpha_s = running_as_lam (number_of_flavors (t, d_min_t), &
	sqrt(t), d_lambda_fsr, 0)
	else
	alpha_s = D_constalpha_s
	end if
	end function D_alpha_s_fsr

	@ %def D_alpha_s_isr D_alpha_s_fsr
	@ Mass and mass squared selection functions. All masses are in
	GeV. Light quarks are assumed to be ordered, $m_1 < m_2 < m_3 \ldots$,
	and they get current masses, not elementary ones. Mesons and baryons
	other than proton and neutron are needed as beam-remnants. Particles
	with PDG number zero are taken massless, as well as proper beam
	remnants and any other particles.
	<<Shower base: public>>=
	public :: mass_type
	public :: mass_squared_type
	<<Shower base: procedures>>=
	elemental function mass_type (type) result (mass)
	integer, intent(in) :: type
	real(default) :: mass
	mass = sqrt (mass_squared_type (type))
	end function mass_type

	elemental function mass_squared_type (type) result (mass2)
	integer, intent(in) :: type
	real(default) :: mass2

	select case (abs (type))
	case (1,2)
	if (treat_light_quarks_massless .or. &
	treat_duscb_quarks_massless) then
	mass2 = zero
	else
	mass2 = 0.330_default**2
	end if
	case (3)
	if (treat_duscb_quarks_massless) then
	mass2 = zero
	else
	mass2 = 0.500_default**2
	end if
	case (4)
	if (treat_duscb_quarks_massless) then
	mass2 = zero
	else
	mass2 = 1.500_default**2
	end if
	case (5)
	if (treat_duscb_quarks_massless) then
	mass2 = zero
	else
	mass2 = 4.800_default**2
	end if
	case (6)
	mass2 = 175.00_default**2
	case (GLUON)
	mass2 = zero
	case (NEUTRON)
	mass2 = 0.939565_default**2
	case (PROTON)
	mass2 = 0.93827_default**2
	case (DPLUS)
	mass2 = 1.86960_default**2
	case (D0)
	mass2 = 1.86483_default**2
	case (B0)
	mass2 = 5.27950_default**2
	case (BPLUS)
	mass2 = 5.27917_default**2
	case (DELTAPLUSPLUS)
	mass2 = 1.232_default**2
	case (SIGMA0)
	mass2 = 1.192642_default**2
	case (SIGMAPLUS)
	mass2 = 1.18937_default**2
	case (SIGMACPLUS)
	mass2 = 2.4529_default**2
	case (SIGMACPLUSPLUS)
	mass2 = 2.45402_default**2
	case (SIGMAB0)
	mass2 = 5.8152_default**2
	case (SIGMABPLUS)
	mass2 = 5.8078_default**2
	case (UNDEFINED)
	mass2 = zero
	case (BEAM_REMNANT)
	mass2 = zero ! don't know how to handle the beamremnant
	case default !others not implemented
	mass2 = zero
	end select
	end function mass_squared_type

	@ %def mass_type mass_squared_type
	@ The number of flavors active at a certain scale (virtuality) $t$.
	<<Shower base: public>>=
	public :: number_of_flavors
	<<Shower base: procedures>>=
	elemental function number_of_flavors (t, d_min_t) result (nr)
	real(default), intent(in) :: t, d_min_t
	real(default) :: nr
	integer :: i
	nr = 0
	if (t < d_min_t) return ! arbitrary cut off
	! TODO: do i = 1, min (max (3, D_Nf), 6)
	do i = 1, min (3, D_Nf)
	!!! to do: take heavier quarks(-> cuts on allowed costheta in g->qq)
	!!! into account
	if ((four * mass_squared_type (i) + d_min_t) < t ) then
	nr = i
	else
	exit
	end if
	end do
	end function number_of_flavors

	@ %def number_of_flavors
	@ Methods to set parameters, once there should be a better interface.
	<<Shower base: public>>=
	public :: shower_set_D_lambda_isr
	public :: shower_set_D_Nf
	public :: shower_set_D_running_alpha_s_fsr
	public :: shower_set_D_running_alpha_s_isr
	public :: shower_set_D_constantalpha_s
	public :: shower_set_isr_pt_ordered
	public :: shower_set_primordial_kt_width
	public :: shower_set_primordial_kt_cutoff
	<<Shower base: procedures>>=
	subroutine shower_set_D_Lambda_isr (input)
	real(default) :: input
	D_Lambda_isr = input
	end subroutine shower_set_D_Lambda_isr

	subroutine shower_set_D_Nf (input)
	integer :: input
	D_Nf = input
	end subroutine shower_set_D_Nf

	subroutine shower_set_D_running_alpha_s_fsr (input)
	logical :: input
	D_running_alpha_s_fsr = input
	end subroutine shower_set_D_running_alpha_s_fsr

	subroutine shower_set_D_running_alpha_s_isr (input)
	logical :: input
	D_running_alpha_s_isr = input
	end subroutine shower_set_D_running_alpha_s_isr

	subroutine shower_set_D_constantalpha_s (input)
	real(default) :: input
	D_constalpha_s = input
	end subroutine shower_set_D_constantalpha_s

	subroutine shower_set_isr_pt_ordered (input)
	logical :: input
	isr_pt_ordered = input
	end subroutine shower_set_isr_pt_ordered

	subroutine shower_set_primordial_kt_width (input)
	real(default) :: input
	primordial_kt_width = input
	end subroutine shower_set_primordial_kt_width

	subroutine shower_set_primordial_kt_cutoff (input)
	real(default) :: input
	primordial_kt_cutoff = input
	end subroutine shower_set_primordial_kt_cutoff

	@ %def shower_set_D_Lambda_isr shower_set_D_Nf
	@ %def shower_set_D_running_alpha_s_fsr
	@ %def shower_set_D_running_alpha_s_isr
	@ %def shower_set_D_constantalpha_s
	@ %def shower_set_isr_pt_ordered
	@ %def shower_set_primordial_kt_width
	@ %def shower_set_primordial_kt_cutoff
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Parton module for the shower}
	<<[[shower_partons.f90]]>>=
	<<File header>>

	module shower_partons

	<<Use kinds>>
	use io_units
	use constants
	use system_defs, only: TAB
	use diagnostics
	use physics_defs
	use lorentz
	use sm_physics
	use particles
	use flavors
	use colors
	use subevents
	use model_data
	use shower_base
	use rng_base

	<<Standard module head>>

	<<Shower partons: public>>

	<<Shower partons: types>>

	contains

	<<Shower partons: procedures>>

	end module shower_partons
	@ %def shower_partons
	@
	\subsection{The basic type defintions}

	The type [[parton_t]] defines a parton for the shower. The [[x]] value
	of the parton is only needed for spacelike showers. The pointer
	[[initial]] is only needed for partons in initial showers, it points to
	the hadron the parton is coming from. An auxiliary value for the
	$P_t$-ordered ISR is [[aux_pt]]. Then, there are two auxiliary entries
	for the clustering of CKKW pseudo weights and CKKW matching,
	[[ckkwlabel]] and [[ckkwscale]]. In order to make shower settings
	available to all operations on the shower partons, we endow the
	[[parton_t]] type with a pointer to [[shower_settings_t]].
	<<Shower partons: public>>=
	public :: parton_t
	<<Shower partons: types>>=
	type :: parton_t
	integer :: nr = 0
	integer :: type = 0
	type(shower_settings_t), pointer :: settings => null()
	type(vector4_t) :: momentum = vector4_null
	real(default) :: t = zero
	real(default) :: scale = zero
	real(default) :: z = zero
	real(default) :: costheta = zero
	real(default) :: x = zero
	logical :: simulated = .false.
	logical :: belongstoFSR = .true.
	logical :: belongstointeraction = .false.
	type(parton_t), pointer :: parent => null ()
	type(parton_t), pointer :: child1 => null ()
	type(parton_t), pointer :: child2 => null ()
	type(parton_t), pointer :: initial => null ()
	integer :: c1 = 0, c2 = 0
	integer :: aux_pt = 0
	integer :: ckkwlabel = 0
	real(default) :: ckkwscale = zero
	integer :: ckkwtype = -1
	integer :: interactionnr = 0
	contains
	<<Shower partons: parton: TBP>>
	end type parton_t

	@ %def parton_t
	@
	<<Shower partons: public>>=
	public :: parton_pointer_t
	<<Shower partons: types>>=
	type :: parton_pointer_t
	type(parton_t), pointer :: p => null ()
	end type parton_pointer_t

	@ %def parton_pointer_t
	@
	\subsection{Routines}
	<<Shower partons: parton: TBP>>=
	procedure :: to_particle => parton_to_particle
	<<Shower partons: procedures>>=
	function parton_to_particle (parton, model) result (particle)
	type(particle_t) :: particle
	class(parton_t), intent(in) :: parton
	class(model_data_t), pointer, intent(in) :: model
	type(flavor_t) :: flavor
	call flavor%init (parton%type, model)
	call particle%set_color (parton%to_color ())
	call particle%set_flavor (flavor)
	call particle%set_status (parton%to_status ())
	call particle%set_momentum (parton%momentum)
	!!! skip pol, hel and polarization for now
	end function parton_to_particle

	@ %def parton_to_particle
	@
	<<Shower partons: parton: TBP>>=
	procedure :: to_status => parton_to_status
	<<Shower partons: procedures>>=
	pure function parton_to_status (parton) result (status)
	integer :: status
	class(parton_t), intent(in) :: parton
	!!! Not clear if the shower can handle a pure decay (1->n) and if it
	!!! is a relevant use case. Assume 2->n for now
	if (parton%is_colored ()) then
	if (parton%nr <= 2) then
	status = PRT_INCOMING
	else
	status = PRT_OUTGOING
	end if
	else
	status = PRT_BEAM_REMNANT
	end if
	end function parton_to_status

	@ %def parton_to_status
	@
	<<Shower partons: parton: TBP>>=
	procedure :: to_color => parton_to_color
	<<Shower partons: procedures>>=
	pure function parton_to_color (parton) result (color)
	class(parton_t), intent(in) :: parton
	type(color_t) :: color
	integer :: c1, c2
	c1 = 0
	c2 = 0
	if (parton%is_colored ()) then
	if (parton%c1 /= 0) c1 = 500 + parton%c1
	if (parton%c2 /= 0) c2 = 500 + parton%c2
	end if
	call color%init_col_acl (c1, c2)
	end function parton_to_color

	@ %def parton_to_color
	<<Shower partons: public>>=
	public :: parton_copy
	<<Shower partons: procedures>>=
	subroutine parton_copy (prt1, prt2)
	type(parton_t), intent(in) :: prt1
	type(parton_t), intent(out) :: prt2
	if (associated (prt1%settings)) prt2%settings => prt1%settings
	prt2%nr = prt1%nr
	prt2%type = prt1%type
	prt2%momentum = prt1%momentum
	prt2%t = prt1%t
	prt2%scale = prt1%scale
	prt2%z = prt1%z
	prt2%costheta = prt1%costheta
	prt2%x = prt1%x
	prt2%simulated = prt1%simulated
	prt2%belongstoFSR = prt1%belongstoFSR
	prt2%belongstointeraction = prt1%belongstointeraction
	prt2%interactionnr = prt1%interactionnr
	if (associated (prt1%parent)) prt2%parent => prt1%parent
	if (associated (prt1%child1)) prt2%child1 => prt1%child1
	if (associated (prt1%child2)) prt2%child2 => prt1%child2
	if (associated (prt1%initial)) prt2%initial => prt1%initial
	prt2%c1 = prt1%c1
	prt2%c2 = prt1%c2
	prt2%aux_pt = prt1%aux_pt
	end subroutine parton_copy

	@ %def parton_copy
	@ This returns the angle between the daughters assuming them to be
	massless.
	<<Shower partons: parton: TBP>>=
	procedure :: get_costheta => parton_get_costheta
	<<Shower partons: procedures>>=
	elemental function parton_get_costheta (prt) result (costheta)
	class(parton_t), intent(in) :: prt
	real(default) :: costheta
	real(default) :: denom
	denom = two * prt%z * (one - prt%z) * prt%momentum%p(0)**2
	if (denom > eps0) then
	costheta = one - prt%t / denom
	else
	costheta = - one
	end if
	end function parton_get_costheta

	@ %def parton_get_costheta
	@ The same for massive daughters.
	<<Shower partons: parton: TBP>>=
	procedure :: get_costheta_mass => parton_get_costheta_mass
	<<Shower partons: procedures>>=
	elemental function parton_get_costheta_mass (prt) result (costheta)
	class(parton_t), intent(in) :: prt
	real(default) :: costheta, sqrt12
	if (parton_is_branched (prt)) then
	if (prt%child1%simulated .and. &
	prt%child2%simulated) then
	sqrt12 = sqrt (max (zero, (prt%z)*2 prt%momentum%p(0)**2 &
	- prt%child1%t)) * &
	sqrt (max (zero, (one - prt%z)*2 prt%momentum%p(0)**2 &
	- prt%child2%t))
	if (sqrt12 > eps0) then
	costheta = (prt%t - prt%child1%t - prt%child2%t - &
	two * prt%z * (one - prt%z) * prt%momentum%p(0)**2) / &
	(- two * sqrt12)
	return
	end if
	end if
	end if
	costheta = prt%get_costheta ()
	end function parton_get_costheta_mass

	@ %def parton_get_costheta_mass
	@ This function returns the angle between the momentum vectors of the
	parton and first daughter. This is only used for debugging.
	<<Shower partons: parton: TBP>>=
	procedure :: get_costheta_motherfirst => parton_get_costheta_motherfirst
	<<Shower partons: procedures>>=
	elemental function parton_get_costheta_motherfirst (prt) result (costheta)
	class(parton_t), intent(in) :: prt
	real(default) :: costheta
	if (parton_is_branched (prt)) then
	if ((prt%child1%simulated .or. &
	parton_is_final (prt%child1) .or. &
	parton_is_branched (prt%child1)) .and. &
	(prt%child2%simulated .or. &
	parton_is_final (prt%child2) .or. &
	parton_is_branched (prt%child2))) then
	costheta = enclosed_angle_ct (prt%momentum, prt%child1%momentum)
	return
	end if
	end if
	costheta = - two
	end function parton_get_costheta_motherfirst

	@ %def parton_get_costheta_motherfirst
	@ Get the parton velocities.
	<<Shower partons: parton: TBP>>=
	procedure :: get_beta => parton_get_beta
	@
	<<Shower partons: procedures>>=
	pure function get_beta (t,E) result (beta)
	real(default), intent(in) :: t,E
	real(default) :: beta
	beta = sqrt (max (tiny_07, one - t /(E**2)))
	end function get_beta

	elemental function parton_get_beta (prt) result (beta)
	class(parton_t), intent(in) :: prt
	real(default) :: beta
	beta = sqrt (max (tiny_07, one - prt%t / prt%momentum%p(0)**2))
	end function parton_get_beta

	@ %def get_beta parton_get_beta
	@ Write routine.
	<<Shower partons: public>>=
	public :: parton_write
	<<Shower partons: procedures>>=
	subroutine parton_write (prt, unit)
	type(parton_t), intent(in) :: prt
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return

	write (u, "(1x,7A)") "Shower parton <nr>", TAB, "<type>", TAB // TAB, &
	"<parent>", TAB, "<mom(0:3)>"
	write (u, "(2x,I5,3A)", advance = "no") prt%nr, TAB, TAB, TAB
	if (parton_is_final (prt)) then
	write (u, "(1x,I5,1x,A)", advance = "no") prt%type, TAB // TAB
	else
	write (u, "('[',I5,']',A)", advance = "no") prt%type, TAB // TAB
	end if
	if (associated (prt%parent)) then
	write (u, "(I5,A)", advance = "no") prt%parent%nr, TAB // TAB
	else
	write (u, "(5x,2A)", advance = "no") TAB, TAB
	end if
	write (u, "(4(ES12.5,A))") prt%momentum%p(0), TAB, &
	prt%momentum%p(1), TAB, &
	prt%momentum%p(2), TAB, &
	prt%momentum%p(3)
	write (u, "(1x,9A)") "<p4square>", TAB // TAB, "<t>", TAB // TAB, &
	"<scale>", TAB // TAB, "<c1>", TAB, "<c2>"
	write (u, "(1x,3(ES12.5,A))", advance = "no") &
	prt%momentum ** 2, TAB // TAB, prt%t, TAB, prt%scale, TAB
	write (u, "(2(I4,A))") prt%c1, TAB, prt%c2, TAB
	if (parton_is_branched (prt)) then
	if (prt%belongstoFSR) then
	write (u, "(1x,9A)") "costheta(prt)", TAB, &
	"costheta_correct(prt)", TAB, &
	"prt%costheta", TAB, "prt%z", TAB, &
	"costheta_motherfirst(prt)"
	write (u, "(1X,5(ES12.5,A))") &
	prt%get_costheta (), TAB, &
	prt%get_costheta_mass (), TAB // TAB, &
	prt%costheta, TAB, prt%z, TAB, &
	prt%get_costheta_motherfirst (), TAB
	else
	write (u, "(1x,9A)") "prt%z", TAB, "prt%x", TAB, &
	"costheta_correct(prt)", TAB, &
	"prt%costheta", TAB, &
	"costheta_motherfirst(prt)"
	write (u, "(1X,5(ES12.5,A))") &
	prt%z, TAB, prt%x, TAB, &
	prt%get_costheta_mass (), TAB, &
	prt%costheta, TAB, &
	prt%get_costheta_motherfirst (), TAB
	end if
	else
	if (prt%belongstoFSR) then
	write (u, "(1X,A)") "not branched."
	else
	write (u, "(1X,A,ES12.5)") "not branched. x = ", prt%x
	end if
	end if
	write (u, "(A)", advance = "no") " Parton"
	if (prt%belongstoFSR) then
	write (u, "(A)", advance = "no") " is FSR,"
	else
	if (associated (prt%initial)) then
	write (u, "(A,I1)", advance = "no") " from hadron,", prt%initial%nr
	else
	write (u, "(A)", advance = "no") ""
	end if
	end if
	if (parton_is_final (prt)) then
	write (u, "(A)", advance = "no") " is final,"
	else
	write (u, "(A)", advance = "no") ""
	end if
	if (prt%simulated) then
	write (u, "(A)", advance = "no") " is simulated,"
	else
	write (u, "(A)", advance = "no") ""
	end if
	if (associated (prt%child1) .and. associated (prt%child2)) then
	write (u, "(A,2(I5),A)", advance = "no") &
	" has children: ", prt%child1%nr, prt%child2%nr, ","
	else if (associated (prt%child1)) then
	write (u, "(A,1(I5),A)", advance = "no") &
	" has one child: ", prt%child1%nr, ", "
	end if
	if (prt%belongstointeraction) then
	write (u, "(A,I2)") " belongs to interaction ", &
	prt%interactionnr
	else
	write (u, "(A,I2)") " does not belong to interaction ", &
	prt%interactionnr
	end if
	write (u,"(A)") TAB
	end subroutine parton_write

	@ %def parton_write
	@
	<<Shower partons: public>>=
	public :: parton_is_final
	<<Shower partons: procedures>>=
	elemental function parton_is_final (prt) result (is_final)
	type(parton_t), intent(in) :: prt
	logical :: is_final
	is_final = .false.
	if (prt%belongstoFSR) then
	is_final = .not. associated (prt%child1) .and. &
	(.not. prt%belongstointeraction .or. &
	(prt%belongstointeraction .and. prt%simulated))
	end if
	end function parton_is_final

	@ %def parton_is_final
	@
	<<Shower partons: public>>=
	public :: parton_is_branched
	<<Shower partons: procedures>>=
	elemental function parton_is_branched (prt) result (is_branched)
	type(parton_t), intent(in) :: prt
	logical :: is_branched
	is_branched = associated (prt%child1) .and. associated (prt%child2)
	end function parton_is_branched

	@ %def parton_is_branched
	@
	<<Shower partons: parton: TBP>>=
	procedure :: set_simulated => parton_set_simulated
	<<Shower partons: procedures>>=
	pure subroutine parton_set_simulated (prt, sim)
	class(parton_t), intent(inout) :: prt
	logical, intent(in), optional :: sim
	if (present (sim)) then
	prt%simulated = sim
	else
	prt%simulated = .true.
	end if
	end subroutine parton_set_simulated

	@ %def parton_set_simulated
	@
	<<Shower partons: public>>=
	public :: parton_set_parent
	<<Shower partons: procedures>>=
	subroutine parton_set_parent (prt, parent)
	type(parton_t), intent(inout) :: prt
	type(parton_t), intent(in) , target :: parent
	prt%parent => parent
	end subroutine parton_set_parent

	@ %def parton_set_parent
	@
	<<Shower partons: public>>=
	public :: parton_get_parent
	<<Shower partons: procedures>>=
	function parton_get_parent (prt) result (parent)
	type(parton_t), intent(in) :: prt
	type(parton_t), pointer :: parent
	parent => prt%parent
	end function parton_get_parent

	@ %def parton_get_parent
	@
	<<Shower partons: public>>=
	public :: parton_set_initial
	<<Shower partons: procedures>>=
	subroutine parton_set_initial (prt, initial)
	type(parton_t), intent(inout) :: prt
	type(parton_t), intent(in) , target :: initial
	prt%initial => initial
	end subroutine parton_set_initial

	@ %def parton_set_initial
	@
	<<Shower partons: public>>=
	public :: parton_get_initial
	<<Shower partons: procedures>>=
	function parton_get_initial (prt) result (initial)
	type(parton_t), intent(in) :: prt
	type(parton_t), pointer :: initial
	initial => prt%initial
	end function parton_get_initial

	@ %def parton_get_initial
	@
	<<Shower partons: public>>=
	public :: parton_set_child
	<<Shower partons: procedures>>=
	subroutine parton_set_child (prt, child, i)
	type(parton_t), intent(inout) :: prt
	type(parton_t), intent(in), target :: child
	integer, intent(in) :: i
	if (i == 1) then
	prt%child1 => child
	else
	prt%child2 => child
	end if
	end subroutine parton_set_child

	@ %def parton_set_child
	@
	<<Shower partons: public>>=
	public :: parton_get_child
	<<Shower partons: procedures>>=
	function parton_get_child (prt, i) result (child)
	type(parton_t), pointer :: child
	type(parton_t), intent(in) :: prt
	integer, intent(in) :: i
	child => null ()
	if (i == 1) then
	child => prt%child1
	else
	child => prt%child2
	end if
	end function parton_get_child

	@ %def parton_get_child
	@
	<<Shower partons: public>>=
	public :: parton_is_quark
	@
	<<Shower partons: procedures>>=
	elemental function parton_is_quark (prt) result (is_quark)
	type(parton_t), intent(in) ::prt
	logical :: is_quark
	is_quark = abs (prt%type) <= 6 .and. prt%type /= 0
	end function parton_is_quark

	@ %def parton_is_quark
	@
	<<Shower partons: public>>=
	public :: parton_is_squark
	<<Shower partons: procedures>>=
	elemental function parton_is_squark (prt) result (is_squark)
	type(parton_t), intent(in) ::prt
	logical :: is_squark
	is_squark = ((abs(prt%type) >= 1000001) .and. (abs(prt%type) <= 1000006)) &
	.or. ((abs(prt%type) >= 2000001) .and. (abs(prt%type) <= 2000006))
	end function parton_is_squark

	@ %def parton_is_squark
	@ 9 can be used for gluons in codes for glueballs
	<<Shower partons: public>>=
	public :: parton_is_gluon
	<<Shower partons: procedures>>=
	elemental function parton_is_gluon (prt) result (is_gluon)
	type(parton_t), intent(in) :: prt
	logical :: is_gluon
	is_gluon = prt%type == GLUON .or. prt%type == 9
	end function parton_is_gluon

	@ %def parton_is_gluon
	@
	<<Shower partons: public>>=
	public :: parton_is_gluino
	<<Shower partons: procedures>>=
	elemental function parton_is_gluino (prt) result (is_gluino)
	type(parton_t), intent(in) :: prt
	logical :: is_gluino
	is_gluino = prt%type == 1000021
	end function parton_is_gluino

	@ %def parton_is_gluino
	@
	<<Shower partons: public>>=
	public :: parton_is_proton
	<<Shower partons: procedures>>=
	elemental function parton_is_proton (prt) result (is_hadron)
	type(parton_t), intent(in) :: prt
	logical :: is_hadron
	is_hadron = abs (prt%type) == PROTON
	end function parton_is_proton

	@ %def parton_is_proton
	@ TODO: SUSY partons.
	<<Shower partons: parton: TBP>>=
	procedure :: is_colored => parton_is_colored
	<<Shower partons: procedures>>=
	pure function parton_is_colored (parton) result (is_colored)
	logical :: is_colored
	class(parton_t), intent(in) :: parton
	is_colored = parton_is_quark (parton) .or. parton_is_gluon (parton)
	end function parton_is_colored

	@ %def parton_is_colored
	@
	<<Shower partons: public>>=
	public :: parton_mass
	<<Shower partons: procedures>>=
	function parton_mass (prt) result (mass)
	type(parton_t), intent(in) :: prt
	real(default) :: mass
	mass = mass_type (prt%type)
	end function parton_mass

	@ %def parton_mass
	@
	<<Shower partons: parton: TBP>>=
	procedure :: mass_squared => parton_mass_squared
	<<Shower partons: procedures>>=
	function parton_mass_squared (prt) result (mass_squared)
	class(parton_t), intent(in) :: prt
	real(default) :: mass_squared
	mass_squared = mass_squared_type (prt%type)
	end function parton_mass_squared

	@ %def parton_mass_squared
	@
	<<Shower partons: public>>=
	public :: P_prt_to_child1
	<<Shower partons: procedures>>=
	function P_prt_to_child1 (prt) result (retvalue)
	type(parton_t), intent(in) :: prt
	real(default) :: retvalue
	retvalue = zero
	if (parton_is_gluon (prt)) then
	if (parton_is_quark (prt%child1)) then
	retvalue = P_gqq (prt%z)
	else if (parton_is_gluon (prt%child1)) then
	retvalue = P_ggg (prt%z) + P_ggg (one - prt%z)
	end if
	else if (parton_is_quark (prt)) then
	if (parton_is_quark (prt%child1)) then
	retvalue = P_qqg (prt%z)
	else if (parton_is_gluon (prt%child1)) then
	retvalue = P_qqg (one - prt%z)
	end if
	end if
	end function P_prt_to_child1

	@ %def P_prt_to_child1
	@ This function returns whether the kinematics of the branching of
	parton [[prt]] into its daughters are allowed or not.
	<<Shower partons: public>>=
	public :: thetabar
	<<Shower partons: procedures>>=
	function thetabar (prt, recoiler, isr_ang, E3out) result (retvalue)
	type(parton_t), intent(inout) :: prt
	type(parton_t), intent(in) :: recoiler
	real(default), intent(out), optional :: E3out
	logical, intent(in) :: isr_ang
	logical :: retvalue
	real(default) :: ctheta, cthetachild1
	real(default) p1, p4, p3, E3, shat

	shat = (prt%child1%momentum + recoiler%momentum)**2
	E3 = 0.5_default * (shat / prt%z -recoiler%t + prt%child1%t - &
	prt%child2%mass_squared ()) / sqrt(shat)
	if (present (E3out)) then
	E3out = E3
	end if
	!!! absolute values of momenta in a 3 -> 1 + 4 branching
	p3 = sqrt (E3**2 - prt%t)
	p1 = sqrt (prt%child1%momentum%p(0)**2 - prt%child1%t)
	p4 = sqrt (max (zero, (E3 - prt%child1%momentum%p(0))**2 &
	- prt%child2%t))
	if (p3 > zero) then
	retvalue = ((p1 + p4 >= p3) .and. (p3 >= abs(p1 - p4)) )
	if (retvalue .and. isr_ang) then
	!!! check angular ordering
	if (associated (prt%child1)) then
	if (associated (prt%child1%child2)) then
	ctheta = (E32 - p12 - p4*2 +prt%t) / (two p1 * p4)
	cthetachild1 = (prt%child1%momentum%p(0)**2 - &
	space_part (prt%child1%child1%momentum)**2 &
	- space_part (prt%child1%child2%momentum)**2 + prt%child1%t) &
	/ (two * space_part (prt%child1%child1%momentum)*1 &
	space_part (prt%child1%child2%momentum)**1)
	retvalue = (ctheta > cthetachild1)
	end if
	end if
	end if
	else
	retvalue = .false.
	end if
	end function thetabar

	@ %def thetabar
	@
	<<Shower partons: public>>=
	public :: parton_apply_z
	<<Shower partons: procedures>>=
	recursive subroutine parton_apply_z(prt, newz)
	type(parton_t), intent(inout) :: prt
	real(default), intent(in) :: newz
	if (D_PRINT) print *, "D: old z = ", prt%z , " new z = ", newz
	prt%z = newz
	if (associated (prt%child1) .and. associated (prt%child2)) then
	prt%child1%momentum%p(0) = newz * prt%momentum%p(0)
	call parton_apply_z (prt%child1, prt%child1%z)
	prt%child2%momentum%p(0) = (one - newz) * prt%momentum%p(0)
	call parton_apply_z (prt%child2, prt%child2%z)
	end if
	end subroutine parton_apply_z

	@ %def parton_apply_z
	@
	<<Shower partons: public>>=
	public :: parton_apply_costheta
	<<Shower partons: procedures>>=
	recursive subroutine parton_apply_costheta (prt, rng)
	type(parton_t), intent(inout) :: prt
	class(rng_t), intent(inout), allocatable :: rng
	if (D_PRINT) print *, "D: parton_apply_costheta for parton " , prt%nr
	prt%z = 0.5_default * (one + prt%get_beta () * prt%costheta)
	if (associated (prt%child1) .and. associated (prt%child2) ) then
	if (prt%child1%simulated .and. &
	prt%child2%simulated) then
	prt%z = 0.5_default * (one + (prt%child1%t - prt%child2%t) / &
	prt%t + prt%get_beta () * prt%costheta * &
	sqrt((prt%t - prt%child1%t - prt%child2%t)**2 - &
	4 * prt%child1%t * prt%child2%t) / prt%t)
	if (prt%type /= INTERNAL) then
	prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
	prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
	end if
	call parton_generate_ps (prt, rng)
	call parton_apply_costheta (prt%child1, rng)
	call parton_apply_costheta (prt%child2, rng)
	end if
	end if
	end subroutine parton_apply_costheta

	@ %def parton_apply_costheta
	@
	<<Shower partons: public>>=
	public :: parton_apply_lorentztrafo
	<<Shower partons: procedures>>=
	subroutine parton_apply_lorentztrafo (prt, L)
	type(parton_t), intent(inout) :: prt
	type(lorentz_transformation_t), intent(in) :: L
	prt%momentum = L * prt%momentum
	end subroutine parton_apply_lorentztrafo

	@ %def parton_apply_lorentztrafo
	@
	<<Shower partons: public>>=
	public :: parton_apply_lorentztrafo_recursive
	<<Shower partons: procedures>>=
	recursive subroutine parton_apply_lorentztrafo_recursive (prt, L)
	type(parton_t), intent(inout) :: prt
	type(lorentz_transformation_t) ,intent(in) :: L
	if (prt%type /= PROTON .and. prt%type /= BEAM_REMNANT) then
	!!! don't boost hadrons and beam-remnants
	call parton_apply_lorentztrafo (prt, L)
	end if
	if (associated (prt%child1) .and. associated (prt%child2)) then
	if ((space_part_norm (prt%child1%momentum) < eps0) .and. &
	(space_part_norm (prt%child2%momentum) < eps0) .and. &
	(.not. prt%child1%belongstointeraction) .and. &
	(.not. prt%child2%belongstointeraction)) then
	!!! don't boost unevolved timelike partons
	else
	call parton_apply_lorentztrafo_recursive (prt%child1, L)
	call parton_apply_lorentztrafo_recursive (prt%child2, L)
	end if
	else
	if (associated (prt%child1)) then
	call parton_apply_lorentztrafo_recursive (prt%child1, L)
	end if
	if (associated (prt%child2)) then
	call parton_apply_lorentztrafo_recursive (prt%child2, L)
	end if
	end if
	end subroutine parton_apply_lorentztrafo_recursive

	@ %def parton_apply_lorentztrafo_recursive
	@ This takes the three-momentum of a parton and generates
	three-momenta of its children given their energy and virtuality
	<<Shower partons: public>>=
	public :: parton_generate_ps
	<<Shower partons: procedures>>=
	subroutine parton_generate_ps (prt, rng)
	type(parton_t), intent(inout) :: prt
	class(rng_t), intent(inout), allocatable :: rng
	real(default), dimension(1:3, 1:3) :: directions
	integer i,j
	real(default) :: scproduct, pabs, p1abs, p2abs, x, ptabs, phi
	real(default), dimension(1:3) :: momentum
	type(vector3_t) :: pchild1_direction
	type(lorentz_transformation_t) :: L, rotation
	if (D_PRINT) print *, "D: parton_generate_ps for parton " , prt%nr
	if (ASSERT) then
	if (.not. (associated (prt%child1) .and. associated (prt%child2))) then
	print *, "no children for generate_ps"
	stop 1
	end if
	end if
	!!! test if parton is a virtual parton from the imagined parton shower history
	if (prt%type == INTERNAL) then
	L = inverse (boost (prt%momentum, sqrt(prt%t)))
	!!! boost to restframe of mother
	call parton_apply_lorentztrafo (prt, L)
	call parton_apply_lorentztrafo (prt%child1, L)
	call parton_apply_lorentztrafo (prt%child2, L)
	!!! Store child1's momenta
	pchild1_direction = direction (space_part (prt%child1%momentum))
	!!! Redistribute energy
	prt%child1%momentum%p(0) = (prt%momentum%p(0)**2 - &
	prt%child2%t + prt%child1%t) / (two * prt%momentum%p(0))
	prt%child2%momentum%p(0) = prt%momentum%p(0) - &
	prt%child1%momentum%p(0)

	! rescale momenta and set momenta to be along z-axis
	prt%child1%momentum = vector4_moving (prt%child1%momentum%p(0), &
	vector3_canonical(3) * &
	sqrt(prt%child1%momentum%p(0)**2 - prt%child1%t))
	prt%child2%momentum = vector4_moving (prt%child2%momentum%p(0), &
	- vector3_canonical(3) * &
	sqrt(prt%child2%momentum%p(0)**2 - prt%child2%t))

	!!! rotate so that total momentum is along former total momentum
	rotation = rotation_to_2nd (space_part (prt%child1%momentum), &
	pchild1_direction)
	call parton_apply_lorentztrafo (prt%child1, rotation)
	call parton_apply_lorentztrafo (prt%child2, rotation)

	L = inverse (L) !!! inverse of the boost to restframe of mother
	call parton_apply_lorentztrafo (prt, L)
	call parton_apply_lorentztrafo (prt%child1, L)
	call parton_apply_lorentztrafo (prt%child2, L)
	else
	!!! directions(1,:) -> direction of the parent parton
	if (space_part_norm (prt%momentum) < eps0) return
	directions(1,1:3) = prt%momentum%p(1:3) / space_part_norm (prt%momentum)
	!!! directions(2,:) and directions(3,:) -> two random directions
	!!! perpendicular to the direction of the parent parton
	do j = 2, 3
	call rng%generate (directions(j,:))
	end do
	do i = 2, 3
	scproduct = zero
	do j = 1, i - 1
	scproduct = directions(i,1) * directions(j,1) + &
	directions(i,2) * directions(j,2) + directions(i,3) * directions(j,3)
	directions(i,1) = directions(i,1) - directions(j,1) * scproduct
	directions(i,2) = directions(i,2) - directions(j,2) * scproduct
	directions(i,3) = directions(i,3) - directions(j,3) * scproduct
	end do
	scproduct = directions(i,1)2 + directions(i,2)2 + directions(i,3)**2
	do j = 1, 3
	directions(i,j) = directions(i,j) / sqrt(scproduct)
	end do
	end do
	<<Enforce right-handed system for [[directions]]>>

	pabs = space_part_norm (prt%momentum)
	if ((prt%child1%momentum%p(0)**2 - prt%child1%t < 0) .or. &
	(prt%child2%momentum%p(0)**2 - prt%child2%t < 0)) then
	if (D_PRINT) print *, "D: generate_ps error at E^2 < t"
	return
	end if
	p1abs = sqrt (prt%child1%momentum%p(0)**2 - prt%child1%t)
	p2abs = sqrt (prt%child2%momentum%p(0)**2 - prt%child2%t)
	x = (pabs2 + p1abs2 - p2abs*2) / (two pabs)
	if (pabs > p1abs + p2abs .or. &
	pabs < abs(p1abs - p2abs)) then
	if (D_PRINT) then
	print *, "D: parton_generate_ps Dreiecksungleichung error for parton ", &
	prt%nr, " ", space_part_norm (prt%momentum)," ",p1abs," ",p2abs
	call parton_write (prt)
	call parton_write (prt%child1)
	call parton_write (prt%child2)
	end if
	return
	end if
	!!! Due to numerical problems transverse momentum could be imaginary ->
	!!! set transverse momentum to zero
	ptabs = sqrt (max (p1abs * p1abs - x * x, zero))
	call rng%generate (phi)
	phi = twopi * phi
	do i = 1, 3
	momentum(i) = x * directions(1,i) + ptabs * &
	(cos(phi) * directions(2,i) + sin(phi) * directions(3,i))
	end do
	prt%child1%momentum%p(1:3) = momentum(1:3)
	do i = 1, 3
	momentum(i) = (space_part_norm (prt%momentum) - x) * directions(1,i) - &
	ptabs * (cos(phi) * directions(2,i) + sin(phi) * directions(3,i))
	end do
	prt%child2%momentum%p(1:3) = momentum(1:3)
	end if
	end subroutine parton_generate_ps

	@ %def parton_generate_ps
	@
	<<Enforce right-handed system for [[directions]]>>=
	if ((directions(1,1) * (directions(2,2) * directions(3,3) - &
	directions(2,3) * directions(3,2)) + &
	directions(1,2) * (directions(2,3) * directions(3,1) - &
	directions(2,1) * directions(3,3)) + &
	directions(1,3) * (directions(2,1) * directions(3,2) - &
	directions(2,2) * directions(3,1))) < 0) then
	directions(3,:) = - directions(3,:)
	end if
	@
	This routine is similar to [[parton_generate_ps]], but now for the
	ISR. It takes the three-momentum of a parton's first child as fixed and
	generates the two remaining three-momenta.
	<<Shower partons: public>>=
	public :: parton_generate_ps_ini
	<<Shower partons: procedures>>=
	subroutine parton_generate_ps_ini (prt, rng)
	type(parton_t), intent(inout) :: prt
	class(rng_t), intent(inout), allocatable :: rng
	real(default), dimension(1:3, 1:3) :: directions
	integer :: i,j
	real(default) :: scproduct, pabs, p1abs, p2abs, x, ptabs, phi
	real(default), dimension(1:3) :: momentum
	if (D_PRINT) print *, "D: parton_generate_ps_ini: for parton " , prt%nr
	if (ASSERT) then
	if (.not. (associated (prt%child1) .and. associated (prt%child2))) then
	print *, "no children for generate_ps"
	stop 1
	end if
	end if

	if (parton_is_proton(prt) .eqv. .false.) then
	!!! generate ps for normal partons
	do i = 1, 3
	directions(1,i) = prt%child1%momentum%p(i) / &
	space_part_norm(prt%child1%momentum)
	end do
	do j = 2, 3
	call rng%generate (directions(j,:))
	end do
	do i = 2, 3
	scproduct = zero
	do j = 1, i - 1
	scproduct = directions(i,1) * directions(j,1) + &
	directions(i,2) * directions(j,2) + directions(i,3) * directions(j,3)
	directions(i,1) = directions(i,1) - directions(j,1) * scproduct
	directions(i,2) = directions(i,2) - directions(j,2) * scproduct
	directions(i,3) = directions(i,3) - directions(j,3) * scproduct
	end do
	scproduct = directions(i,1)2 + directions(i,2)2 + directions(i,3)**2
	do j = 1, 3
	directions(i,j) = directions(i,j) / sqrt(scproduct)
	end do
	end do
	<<Enforce right-handed system for [[directions]]>>

	pabs = space_part_norm (prt%child1%momentum)
	p1abs = sqrt (prt%momentum%p(0)**2 - prt%t)
	p2abs = sqrt (max(zero, prt%child2%momentum%p(0)**2 - &
	prt%child2%t))

	x = (pabs2 + p1abs2 - p2abs*2) / (two pabs)
	if (ASSERT) then
	if (pabs > p1abs + p2abs .or. pabs < abs(p1abs - p2abs)) then
	print *, "error at generate_ps, Dreiecksungleichung for parton ", &
	prt%nr, " ", pabs," ",p1abs," ",p2abs
	call parton_write (prt)
	call parton_write (prt%child1)
	call parton_write (prt%child2)
	stop 1
	end if
	end if
	if (D_PRINT) print *, "D: parton_generate_ps_ini: x = ", x
	ptabs = sqrt (p1abs * p1abs - x**2)
	call rng%generate (phi)
	phi = twopi * phi
	do i = 1,3
	momentum(i) = x * directions(1,i) + ptabs * (cos(phi) * &
	directions(2,i) + sin(phi) * directions(3,i))
	end do
	prt%momentum%p(1:3) = momentum
	do i = 1, 3
	momentum(i) = (x - pabs) * directions(1,i) + ptabs * (cos(phi) * &
	directions(2,i) + sin(phi) * directions(3,i))
	end do
	prt%child2%momentum%p(1:3) = momentum(1:3)
	else
	!!! for first partons just set beam remnants momentum
	prt%child2%momentum = prt%momentum - prt%child1%momentum
	end if
	end subroutine parton_generate_ps_ini

	@ %def parton_generate_ps_ini
	@
	\subsection{The analytic FSR}
	<<Shower partons: public>>=
	public :: parton_next_t_ana
	<<Shower partons: procedures>>=
	subroutine parton_next_t_ana (prt, rng)
	type(parton_t), intent(inout) :: prt
	class(rng_t), intent(inout), allocatable :: rng
	integer :: gtoqq
	real(default) :: integral, random

	if (signal_is_pending ()) return
	if (D_PRINT) then
	print *, "D: parton_next_t_ana: for parton " , prt%nr
	end if

	! check if branchings are possible at all
	if (min (prt%t, prt%momentum%p(0)**2) < &
	prt%mass_squared () + prt%settings%d_min_t) then
	prt%t = prt%mass_squared ()
	call prt%set_simulated ()
	return
	end if

	integral = zero
	call rng%generate (random)
	do
	if (signal_is_pending ()) return
	call parton_simulate_stept (prt, rng, integral, random, gtoqq, .false.)
	if (prt%simulated) then
	if (parton_is_gluon (prt)) then
	!!! Abusing the x-variable to store the information to which
	!!! quark flavor the gluon branches (if any)
	prt%x = one * gtoqq + 0.1_default
	!!! x = gtoqq + 0.1 -> int(x) will be the quark flavor or
	!!! zero for g -> gg
	end if
	exit
	end if
	end do
	end subroutine parton_next_t_ana

	@ %def parton_next_t_ana
	@ The shower is actually sensitive to how close we go to the one here.
	<<Shower partons: procedures>>=
	pure function cmax (prt, tt) result (cma)
	type(parton_t), intent(in) :: prt
	real(default), intent(in), optional :: tt
	real(default) :: cma
	real(default) :: t, cost

	if (present(tt)) then
	t = tt
	else
	t = prt%t
	end if

	if (associated (prt%parent)) then
	cost = prt%parent%get_costheta ()
	cma = min (0.99999_default, sqrt( max(zero, one - t/ &
	(prt%get_beta () * prt%momentum%p(0))*2 &
	(one + cost) / (one - cost))))
	else
	cma = 0.99999_default
	end if
	end function cmax

	@ %def cmax
	@ Simulation routine. The variable [[lookatsister]] takes constraints
	from the sister parton into account, if not given it is assumed
	[[.true.]]. [[a]] and [[x]] are three-dimensional arrays for values
	used for the integration.
	<<Shower partons: public>>=
	public :: parton_simulate_stept
	<<Shower partons: procedures>>=
	subroutine parton_simulate_stept &
	(prt, rng, integral, random, gtoqq, lookatsister)
	type(parton_t), intent(inout) :: prt
	class(rng_t), intent(inout), allocatable :: rng
	real(default), intent(inout) :: integral
	real(default), intent(inout) :: random
	integer, intent(out) :: gtoqq
	logical, intent(in), optional :: lookatsister

	type(parton_t), pointer :: sister
	real(default) :: tstep, tmin, oldt
	real(default) :: c, cstep
	real(default), dimension(3) :: z, P
	real(default) :: to_integral
	real(default) :: a11,a12,a13,a21,a22,a23
	real(default) :: cmax_t
	real(default) :: temprand
	real(default), dimension(3) :: a, x

	! higher values -> faster but coarser
	real(default), parameter :: tstepfactor = 0.02_default
	real(default), parameter :: tstepmin = 0.5_default
	real(default), parameter :: cstepfactor = 0.8_default
	real(default), parameter :: cstepmin = 0.03_default

	if (signal_is_pending ()) return
	gtoqq = 111 ! illegal value
	call prt%set_simulated (.false.)

	<<Set [[sister]] if [[lookatsister]] is true or not given>>

	tmin = prt%settings%d_min_t + prt%mass_squared ()
	if (parton_is_quark(prt)) then
	to_integral = three pi log(one / random)
	else if (parton_is_gluon(prt)) then
	to_integral = four pi log(one / random)
	else
	prt%t = prt%mass_squared ()
	call prt%set_simulated ()
	return
	end if

	if (associated (sister)) then
	if (sqrt(prt%t) > sqrt(prt%parent%t) - &
	sqrt(sister%mass_squared ())) then
	prt%t = (sqrt (prt%parent%t) - sqrt (sister%mass_squared ()))**2
	end if
	end if
	if (prt%t > prt%momentum%p(0)**2) then
	prt%t = prt%momentum%p(0)**2
	end if

	if (prt%t <= tmin) then
	prt%t = prt%mass_squared ()
	call prt%set_simulated ()
	return
	end if

	! simulate the branchings between prt%t and prt%t - tstep
	tstep = max(tstepfactor * (prt%t - 0.9_default * tmin), tstepmin)
	cmax_t = cmax(prt)
	c = - cmax_t ! take highest t -> minimal constraint
	cstep = max(cstepfactor * (one - abs(c)), cstepmin)
	! get values at border of "previous" bin -> to be used in first bin
	z(3) = 0.5_default + 0.5_default * get_beta (prt%t - &
	0.5_default * tstep, prt%momentum%p(0)) * c
	if (parton_is_gluon (prt)) then
	P(3) = P_ggg (z(3)) + P_gqq (z(3)) * number_of_flavors &
	(prt%t, prt%settings%d_min_t)
	else
	P(3) = P_qqg (z(3))
	end if
	a(3) = D_alpha_s_fsr (z(3) * (one - z(3)) * prt%t, &
	prt%settings%d_min_t, prt%settings%fsr_lambda) * P(3) / &
	(prt%t - 0.5_default * tstep)

	do while (c < cmax_t .and. (integral < to_integral))
	if (signal_is_pending ()) return
	cmax_t = cmax (prt)
	cstep = max (cstepfactor * (one - abs(c)**2), cstepmin)
	if (c + cstep > cmax_t) then
	cstep = cmax_t - c
	end if
	if (cstep < 1E-9_default) then
	!!! reject too small bins
	exit
	end if
	z(1) = z(3)
	z(2) = 0.5_default + 0.5_default * get_beta &
	(prt%t - 0.5_default * tstep, prt%momentum%p(0)) * &
	(c + 0.5_default * cstep)
	z(3) = 0.5_default + 0.5_default * get_beta &
	(prt%t - 0.5_default * tstep, prt%momentum%p(0)) * (c + cstep)
	P(1) = P(3)
	if (parton_is_gluon (prt)) then
	P(2) = P_ggg(z(2)) + P_gqq(z(2)) * number_of_flavors &
	(prt%t, prt%settings%d_min_t)
	P(3) = P_ggg(z(3)) + P_gqq(z(3)) * number_of_flavors &
	(prt%t, prt%settings%d_min_t)
	else
	P(2) = P_qqg(z(2))
	P(3) = P_qqg(z(3))
	end if
	! get values at borders of the intgral and in the middle
	a(1) = a(3)
	a(2) = D_alpha_s_fsr (z(2) * (one - z(2)) * prt%t, &
	prt%settings%d_min_t, prt%settings%fsr_lambda) * P(2) / &
	(prt%t - 0.5_default * tstep)
	a(3) = D_alpha_s_fsr (z(3) * (one - z(3)) * prt%t, &
	prt%settings%d_min_t, prt%settings%fsr_lambda) * P(3) / &
	(prt%t - 0.5_default * tstep)

	! fit x(1) + x(2)/(1 + c) + x(3)/(1 - c) to these values !! a little tricky
	a11 = (one+c+0.5_defaultcstep) (one-c-0.5_default*cstep) - &
	(one-c) * (one+c+0.5_default*cstep)
	a12 = (one-c-0.5_defaultcstep) - (one+c+0.5_defaultcstep) * &
	(one-c) / (one+c)
	a13 = a(2) * (one+c+0.5_defaultcstep) (one-c-0.5_default*cstep) - &
	a(1) * (one-c) * (one+c+0.5_default*cstep)
	a21 = (one+c+cstep) * (one-c-cstep) - (one+c+cstep) * (one-c)
	a22 = (one-c-cstep) - (one+c+cstep) * (one-c) / (one+c)
	a23 = a(3) * (one+c+cstep) * (one-c-cstep) - &
	a(1) * (one-c) * (one+c+cstep)

	x(2) = (a23 - a21 * a13 / a11) / (a22 - a12 * a21 / a11)
	x(1) = (a13 - a12 * x(2)) / a11
	x(3) = a(1) * (one - c) - x(1) * (one - c) - x(2) * (one - c) / (one + c)

	integral = integral + tstep * (x(1) * cstep + x(2) * &
	log((one + c + cstep) / (one + c)) - x(3) * &
	log((one - c - cstep) / (one - c)))

	if (integral > to_integral) then
	oldt = prt%t
	call rng%generate (temprand)
	prt%t = prt%t - temprand * tstep
	call rng%generate (temprand)
	prt%costheta = c + (0.5_default - temprand) * cstep
	call prt%set_simulated ()

	if (prt%t < prt%settings%d_min_t + prt%mass_squared ()) then
	prt%t = prt%mass_squared ()
	end if
	if (abs(prt%costheta) > cmax_t) then
	! reject branching due to violation of costheta-limits
	call rng%generate (random)
	if (parton_is_quark (prt)) then
	to_integral = three * pi * log(one / random)
	else if (parton_is_gluon(prt)) then
	to_integral = four * pi * log(one / random)
	end if
	integral = zero
	prt%t = oldt
	call prt%set_simulated (.false.)
	end if
	if (parton_is_gluon (prt)) then
	! decide between g->gg and g->qqbar splitting
	z(1) = 0.5_default + 0.5_default * prt%costheta
	call rng%generate (temprand)
	if (P_ggg(z(1)) > temprand * (P_ggg (z(1)) + P_gqq (z(1)) * &
	number_of_flavors(prt%t, &
	prt%settings%d_min_t))) then
	gtoqq = 0
	else
	call rng%generate (temprand)
	gtoqq = 1 + int (temprand * number_of_flavors &
	(prt%t, prt%settings%d_min_t))
	end if
	end if
	else
	c = c + cstep
	end if
	cmax_t = cmax (prt)
	end do
	if (integral <= to_integral) then
	prt%t = prt%t - tstep
	if (prt%t < prt%settings%d_min_t + prt%mass_squared ()) then
	prt%t = prt%mass_squared ()
	call prt%set_simulated ()
	end if
	end if
	end subroutine parton_simulate_stept

	@ %def parton_simulate_stept
	@
	<<Set [[sister]] if [[lookatsister]] is true or not given>>=
	sister => null()
	SET_SISTER: do
	if (present (lookatsister)) then
	if (.not. lookatsister) then
	exit SET_SISTER
	end if
	end if
	if (prt%nr == prt%parent%child1%nr) then
	sister => prt%parent%child2
	else
	sister => prt%parent%child1
	end if
	exit SET_SISTER
	end do SET_SISTER
	@
	@ From the whole ISR algorithm all functionality has been moved to
	[[shower_core.f90]]. Only [[maxzz]] remains here, because more than
	one module needs to access it.
	<<Shower partons: public>>=
	public :: maxzz
	<<Shower partons: procedures>>=
	function maxzz (shat, s, maxz_isr, minenergy_timelike) result (maxz)
	real(default), intent(in) :: shat, s, minenergy_timelike, maxz_isr
	real(default) :: maxz
	maxz = min (maxz_isr, one - (two * minenergy_timelike * sqrt(shat)) / s)
	end function maxzz

	@ %def maxzz
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Main shower module}
	<<[[shower_core.f90]]>>=
	<<File header>>

	module shower_core

	<<Use kinds with double>>
	<<Use strings>>
	use io_units
	use constants
	use unit_tests, only: vanishes, nearly_equal
	use system_defs, only: TAB
	use diagnostics
	use physics_defs
	use os_interface
	use lorentz
	use sm_physics
	use particles
	use model_data
	use flavors
	use colors
	use subevents
	use pdf_builtin !NODEP!
	use lhapdf !NODEP!
	use rng_base
	use shower_base
	use shower_partons
	use mlm_matching
	use ckkw_base
	use ckkw_matching
	use muli, only: muli_t
	use hep_common

	<<Standard module head>>

	<<Shower core: public>>

	<<Shower core: parameters>>

	<<Shower core: types>>

	<<Shower core: interfaces>>

	contains

	<<Shower core: procedures>>

	end module shower_core
	@ %def shower_core
	@
	<<Shower core: 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
	@
	<<Shower core: public>>=
	public :: shower_interaction_t
	<<Shower core: types>>=
	type :: shower_interaction_t
	type(parton_pointer_t), dimension(:), allocatable :: partons
	end type shower_interaction_t

	type :: shower_interaction_pointer_t
	type(shower_interaction_t), pointer :: i => null ()
	end type shower_interaction_pointer_t

	@ %def shower_interaction_t
	@ %def shower_interaction_pointer_t
	@
	<<Shower core: parameters>>=
	logical, parameter :: DEBUG_SHOWER = .false.
	logical, parameter :: TO_FILE = .false.

	@ %def DEBUG_SHOWER TO_FILE
	@
	The WHIZARD internal shower. Flags distinguish between analytic and
	$k_T$-ordered showers.
	The main type of [[shower_core]]: It contains many parameter of the
	shower, namely [[maxz_isr]] ([[PARP(66)]]), the minimal energy
	of the emitted timelike parton in the ISR [[minenergy_timelike]]
	([[PARP(65)]]), the factor for the first scale, as
	well as the factor by which the integral in the Sudakhov factor is
	suppressed for the respective first scale in ISR. Higher values
	here correspond to higher starting scales. Also, there is a flag
	whether ISR is angular ordered ([[MSTP(62)]]). The flag corresponding
	to [[MSTP(63)]] sets emitted timelike partons in the spacelike
	shower on shell.
	<<Shower core: public>>=
	public :: shower_t
	<<Shower core: types>>=
	type, extends (shower_base_t) :: shower_t
	type(shower_interaction_pointer_t), dimension(:), allocatable :: &
	interactions
	type(parton_pointer_t), dimension(:), allocatable :: partons
	integer :: next_free_nr
	integer :: next_color_nr
	logical :: valid
	logical :: isr_angular_ordered = .true.
	real(default) :: maxz_isr = 0.999_default
	real(default) :: minenergy_timelike = one
	real(default) :: tscalefactor_isr = one
	real(default) :: first_integral_suppression_factor = one
	logical :: isr_only_onshell_emitted_partons = .true.
	contains
	<<Shower core: shower: TBP>>
	end type shower_t

	@ %def shower_t
	@
	@ Transfer the generic shower settings to the analytic shower by calling
	the public [[set]] functions and setting up the [[shower]] object.
	<<Shower core: shower: TBP>>=
	procedure :: init => shower_init
	<<Shower core: procedures>>=
	subroutine shower_init (shower, settings, pdf_data)
	class(shower_t), intent(out) :: shower
	type(shower_settings_t), intent(in) :: settings
	type(pdf_data_t), intent(in) :: pdf_data
	if (DEBUG_SHOWER) &
	print *, "Transfer settings from shower_settings to shower"
	shower%settings = settings
	call shower_set_D_Lambda_isr (settings%isr_lambda)
	call shower_set_D_Nf (settings%max_n_flavors)
	call shower_set_D_running_alpha_s_fsr &
	(settings%fsr_alpha_s_running)
	call shower_set_D_running_alpha_s_isr &
	(settings%isr_alpha_s_running)
	call shower_set_D_constantalpha_s &
	(settings%fixed_alpha_s)
	call shower_set_isr_pt_ordered &
	(settings%isr_pt_ordered)
	call shower_set_primordial_kt_width &
	(settings%isr_primordial_kt_width)
	call shower_set_primordial_kt_cutoff &
	(settings%isr_primordial_kt_cutoff)
	shower%isr_angular_ordered = settings%isr_angular_ordered
	shower%maxz_isr = settings%isr_z_cutoff
	shower%minenergy_timelike = settings%isr_minenergy
	shower%tscalefactor_isr = settings%isr_tscalefactor
	call shower%pdf_data%init (pdf_data)
	shower%name = "WHIZARD internal"
	call shower%write_msg ()
	end subroutine shower_init

	@ %def shower_init
	@
	<<Shower core: shower: TBP>>=
	procedure :: generate_emissions => shower_generate_emissions
	<<Shower core: procedures>>=
	subroutine shower_generate_emissions ( &
	shower, particle_set, model, model_hadrons, &
	os_data, matching_settings, data, valid, vetoed, number_of_emissions)
	class(shower_t), intent(inout), target :: shower
	type(particle_set_t), intent(inout) :: particle_set
	class(model_data_t), intent(in), target :: model
	class(model_data_t), intent(in), target :: model_hadrons
	class(matching_settings_t), intent(in), allocatable :: matching_settings
	class(matching_data_t), intent(inout), allocatable :: data
	type(os_data_t), intent(in) :: os_data
	logical, intent(inout) :: valid
	logical, intent(inout) :: vetoed
	integer, optional, intent(in) :: number_of_emissions

	type(muli_t), save :: mi
	type(parton_t), dimension(:), allocatable, target :: partons, hadrons
	type(particle_t) :: particle
	type(parton_pointer_t), dimension(:), allocatable :: &
	parton_pointers, final_ME_partons
	real(default) :: mi_scale, ps_scale, shat, phi
	type(parton_pointer_t) :: temppp
	integer, dimension(:), allocatable :: connections
	integer :: n_loop, i, j, k
	integer :: n_hadrons, n_in, n_out, n_tot
	integer :: n_int, max_color_nr
	integer, dimension(2) :: col_array
	integer, dimension(1) :: parent
	integer, dimension(2,4) :: color_corr
	integer :: u_S2W

	if (signal_is_pending ()) return

	call shower%create ()
	max_color_nr = 0

	n_hadrons = particle_set%get_n_beam ()
	n_in = particle_set%get_n_in ()
	n_out = particle_set%get_n_out ()
	n_tot = particle_set%get_n_tot ()

	n_loop = 0
	TRY_SHOWER: do !!! Just a loop to be able to discard events
	n_loop = n_loop + 1
	if (n_loop > 1000) call msg_fatal &
	("Shower: too many loops (try_shower)")
	if (signal_is_pending ()) return

	allocate (connections (1:n_tot))
	connections = 0
	allocate (hadrons (1:2))
	allocate (partons (1:n_in+n_out))
	allocate (parton_pointers (1:n_in+n_out))
	<<Copy hadrons from [[particle_set]] to hadrons>>
	<<Copy incoming partons from [[particle_set]] to partons>>
	<<Copy outgoing partons from [[particle_set]] to partons>>
	deallocate (connections)
	if (signal_is_pending ()) return

	if (DEBUG_SHOWER) print *, "Insert partons in shower"
	call shower%set_next_color_nr (1 + max_color_nr)
	if (allocated (data)) then
	select type (data)
	type is (ckkw_matching_data_t)
	call shower%add_interaction_2ton_CKKW (parton_pointers, &
	data%ckkw_weights)
	class default
	call shower%add_interaction_2ton (parton_pointers)
	end select
	else
	call shower%add_interaction_2ton (parton_pointers)
	end if
	if (signal_is_pending ()) return

	<<Activate multiple interactions>>
	if (signal_is_pending ()) return

	if (shower%settings%ckkw_matching .and. allocated (matching_settings) &
	.and. allocated (data)) then
	if (DEBUG_SHOWER) print *, "Apply CKKW matching"
	select type (matching_settings)
	type is (ckkw_matching_settings_t)
	select type (data)
	type is (ckkw_matching_data_t)
	call ckkw_matching_apply (shower%partons, &
	matching_settings, &
	data%ckkw_weights, shower%rng, vetoed)
	if (vetoed) then
	return
	end if
	class default
	call msg_fatal ("CKKW matching called with wrong data.")
	end select
	class default
	call msg_fatal ("CKKW matching called with wrong data.")
	end select
	end if

	if (shower%settings%isr_active) then
	if (DEBUG_SHOWER) print *, "Generate ISR with FSR"
	i = 0
	BRANCHINGS: do
	i = i+1
	if (signal_is_pending ()) return
	if (shower%settings%muli_active) then
	call mi%generate_gev2_pt2 &
	(shower%get_ISR_scale (), mi_scale)
	else
	mi_scale = 0.0
	end if

	!!! Shower: debugging
	!!! shower%generate_next_isr_branching returns a pointer to
	!!! the parton with the next ISR-branching, this parton's
	!!! scale is the scale of the next branching
	! temppp=shower%generate_next_isr_branching_veto ()
	temppp = shower%generate_next_isr_branching ()

	if (.not. associated (temppp%p) .and. &
	mi_scale < shower%settings%d_min_t) then
	exit BRANCHINGS
	end if
	!!! check if branching or interaction occurs next
	if (associated (temppp%p)) then
	ps_scale = abs(temppp%p%t)
	else
	ps_scale = 0._default
	end if
	if (mi_scale > ps_scale) then
	!!! discard branching evolution lower than mi_scale
	call shower%set_max_ISR_scale (mi_scale)
	if (associated (temppp%p)) &
	call temppp%p%set_simulated (.false.)

	!!! execute new interaction
	deallocate (partons)
	deallocate (parton_pointers)
	allocate (partons(1:4))
	allocate (parton_pointers(1:4))
	do j = 1, 4
	partons(j)%nr = shower%get_next_free_nr ()
	partons(j)%belongstointeraction = .true.
	parton_pointers(j)%p => partons(j)
	end do
	call mi%generate_partons (partons(1)%nr, partons(2)%nr, &
	partons(1)%x, partons(2)%x, &
	partons(1)%type, partons(2)%type, &
	partons(3)%type, partons(4)%type)
	!!! calculate momenta
	shat = partons(1)%x partons(2)%x &
	shower_interaction_get_s (shower%interactions(1)%i)
	partons(1)%momentum = [0.5_default * sqrt(shat), &
	zero, zero, 0.5_default*sqrt(shat)]
	partons(2)%momentum = [0.5_default * sqrt(shat), &
	zero, zero, -0.5_default*sqrt(shat)]
	call parton_set_initial (partons(1), &
	shower%interactions(1)%i%partons(1)%p%initial)
	call parton_set_initial (partons(2), &
	shower%interactions(1)%i%partons(2)%p%initial)
	partons(1)%belongstoFSR = .false.
	partons(2)%belongstoFSR = .false.
	!!! calculate color connection
	call mi%get_color_correlations &
	(shower%get_next_color_nr (), &
	max_color_nr,color_corr)
	call shower%set_next_color_nr (max_color_nr)

	partons(1)%c1 = color_corr(1,1)
	partons(1)%c2 = color_corr(2,1)
	partons(2)%c1 = color_corr(1,2)
	partons(2)%c2 = color_corr(2,2)
	partons(3)%c1 = color_corr(1,3)
	partons(3)%c2 = color_corr(2,3)
	partons(4)%c1 = color_corr(1,4)
	partons(4)%c2 = color_corr(2,4)

	call shower%rng%generate (phi)
	phi = 2 * pi * phi
	partons(3)%momentum = [0.5_default*sqrt(shat), &
	sqrt(mi_scale)*cos(phi), &
	sqrt(mi_scale)*sin(phi), &
	sqrt(0.25_default*shat - mi_scale)]
	partons(4)%momentum = [ 0.5_default*sqrt(shat), &
	-sqrt(mi_scale)*cos(phi), &
	-sqrt(mi_scale)*sin(phi), &
	-sqrt(0.25_default*shat - mi_scale)]
	partons(3)%belongstoFSR = .true.
	partons(4)%belongstoFSR = .true.

	call shower%add_interaction_2ton (parton_pointers)
	n_int = size (shower%interactions)
	do k = 1, 2
	call mi%replace_parton &
	(shower%interactions(n_int)%i%partons(k)%p%initial%nr, &
	shower%interactions(n_int)%i%partons(k)%p%nr, &
	shower%interactions(n_int)%i%partons(k)%p%parent%nr, &
	shower%interactions(n_int)%i%partons(k)%p%type, &
	shower%interactions(n_int)%i%partons(k)%p%x, &
	mi_scale)
	end do
	else
	!!! execute the next branching 'found' in the previous step
	call shower%execute_next_isr_branching (temppp)
	if (shower%settings%muli_active) then
	call mi%replace_parton (temppp%p%initial%nr, &
	temppp%p%child1%nr, temppp%p%nr, &
	temppp%p%type, temppp%p%x, ps_scale)
	end if

	end if
	end do BRANCHINGS

	call shower%generate_fsr_for_isr_partons ()
	else
	if (signal_is_pending ()) return
	if (DEBUG_SHOWER) print *, 'Generate FSR without ISR'
	call shower%simulate_no_isr_shower ()
	end if

	!!! some bookkeeping, needed after the shower is done
	call shower%boost_to_labframe ()
	call shower%generate_primordial_kt ()
	call shower%update_beamremnants ()

	if (shower%settings%fsr_active) then
	do i = 1, size (shower%interactions)
	if (signal_is_pending ()) return
	call shower%interaction_generate_fsr_2ton &
	(shower%interactions(i)%i)
	end do
	else
	call shower%simulate_no_fsr_shower ()
	end if
	if (DEBUG_SHOWER) then
	write (*, "(A)") "SHOWER FINISHED: "
	call shower%write ()
	end if

	if (shower%settings%mlm_matching .and. allocated (data)) then
	!!! transfer momenta of the partons in the final state of
	!!! the hard initeraction
	if (signal_is_pending ()) return
	select type (data)
	type is (mlm_matching_data_t)
	if (allocated (data%P_ME)) deallocate (data%P_ME)
	call shower%get_final_colored_ME_partons (final_ME_partons)
	if (allocated (final_ME_partons)) then
	allocate (data%P_ME(1:size (final_ME_partons)))
	do i = 1, size (final_ME_partons)
	!!! transfer
	data%P_ME(i) = final_ME_partons(i)%p%momentum
	end do
	deallocate (final_ME_partons)
	end if
	class default
	call msg_fatal ("MLM matching called with wrong data.")
	end select
	end if

	u_S2W = free_unit ()
	if (DEBUG_SHOWER .and. TO_FILE) then
	open (unit=u_S2W, file="showerout.lhe", &
	status="replace", action="readwrite")
	else
	open (unit=u_S2W, status="scratch", action="readwrite")
	end if
	!call shower%write_lhef (u_S2W)
	!call combine_lhef_with_particle_set &
	!(particle_set, u_S2W, model, model_hadrons)
	call shower%combine_with_particle_set (particle_set, model, &
	model_hadrons)
	close (u_S2W)

	!!! move the particle data to the PYTHIA COMMON BLOCKS in case
	!!! hadronization is active
	if (shower%settings%hadronization_active) then
	if (signal_is_pending ()) return
	call shower_converttopythia (shower)
	end if
	deallocate (partons)
	deallocate (parton_pointers)
	exit TRY_SHOWER
	end do TRY_SHOWER

	call shower%final ()
	!!! clean-up muli: we should finalize the muli pdf sets
	!!! when _all_ runs are done. Not after every event if possible
	! call mi%finalize()
	return
	end subroutine shower_generate_emissions

	@ %def shower_generate_emissions
	@
	<<Copy hadrons from [[particle_set]] to hadrons>>=
	j = 0
	if (n_hadrons > 0) then
	if (DEBUG_SHOWER) print *, "Copy hadrons from particle_set to hadrons"
	do i = 1, n_tot
	particle = particle_set%get_particle (i)
	if (particle%get_status () == PRT_BEAM) then
	j = j + 1
	hadrons(j)%nr = shower%get_next_free_nr ()
	hadrons(j)%momentum = particle%get_momentum ()
	hadrons(j)%t = hadrons(j)%momentum**2
	hadrons(j)%type = particle_set%prt(i)%get_pdg ()
	col_array = particle%get_color ()
	hadrons(j)%c1 = col_array(1)
	hadrons(j)%c2 = col_array(2)
	max_color_nr = max (max_color_nr, abs(hadrons(j)%c1), &
	abs(hadrons(j)%c2))
	hadrons(j)%interactionnr = 1
	connections(i) = j
	end if
	end do
	end if
	@
	<<Copy incoming partons from [[particle_set]] to partons>>=
	j = 0
	if (DEBUG_SHOWER) print *, "Copy incoming partons from particle_set to partons"
	do i = 1, n_tot
	particle = particle_set%get_particle (i)
	if (particle%get_status () == PRT_INCOMING) then
	j = j+1
	partons(j)%settings => shower%settings
	partons(j)%nr = shower%get_next_free_nr ()
	partons(j)%momentum = particle%get_momentum ()
	partons(j)%t = partons(j)%momentum**2
	partons(j)%type = particle%get_pdg ()
	col_array = particle%get_color ()
	partons(j)%c1 = col_array (1)
	partons(j)%c2 = col_array (2)
	parton_pointers(j)%p => partons(j)
	max_color_nr = max (max_color_nr, abs (partons(j)%c1), &
	abs (partons(j)%c2))
	connections(i) = j
	!!! insert dependencies on hadrons
	if (particle%get_n_parents () == 1) then
	parent = particle%get_parents ()
	partons(j)%initial => hadrons (connections (parent(1)))
	partons(j)%x = space_part_norm (partons(j)%momentum) / &
	space_part_norm (partons(j)%initial%momentum)
	end if
	end if
	end do
	@
	<<Copy outgoing partons from [[particle_set]] to partons>>=
	if (DEBUG_SHOWER) print *, "Copy outgoing partons from particle_set to partons"
	do i = 1, n_tot
	particle = particle_set%get_particle (i)
	if (particle%get_status () == PRT_OUTGOING) then
	j = j + 1
	partons(j)%settings => shower%settings
	partons(j)%nr = shower%get_next_free_nr ()
	partons(j)%momentum = particle%get_momentum ()
	partons(j)%t = partons(j)%momentum**2
	partons(j)%type = particle%get_pdg ()
	col_array = particle%get_color ()
	partons(j)%c1 = col_array(1)
	partons(j)%c2 = col_array(2)
	parton_pointers(j)%p => partons(j)
	max_color_nr = max (max_color_nr, abs &
	(partons(j)%c1), abs (partons(j)%c2))
	connections(i) = j
	end if
	end do
	@
	<<Activate multiple interactions>>=
	if (shower%settings%muli_active) then
	!!! Initialize muli pdf sets, unless initialized
	if (mi%is_initialized ()) then
	call mi%restart ()
	else
	call mi%initialize (&
	GeV2_scale_cutoff=shower%settings%d_min_t, &
	GeV2_s=shower_interaction_get_s &
	(shower%interactions(1)%i), &
	muli_dir=char(os_data%whizard_mulipath))
	end if

	!!! initial interaction
	call mi%apply_initial_interaction ( &
	GeV2_s=shower_interaction_get_s(shower%interactions(1)%i), &
	x1=shower%interactions(1)%i%partons(1)%p%parent%x, &
	x2=shower%interactions(1)%i%partons(2)%p%parent%x, &
	pdg_f1=shower%interactions(1)%i%partons(1)%p%parent%type, &
	pdg_f2=shower%interactions(1)%i%partons(2)%p%parent%type, &
	n1=shower%interactions(1)%i%partons(1)%p%parent%nr, &
	n2=shower%interactions(1)%i%partons(2)%p%parent%nr)
	end if
	@
	<<Shower core: public>>=
	public :: matching_transfer_PS
	<<Shower core: procedures>>=
	subroutine matching_transfer_PS &
	(data, particle_set, settings)
	!!! transfer partons after parton shower to data%P_PS
	type(mlm_matching_data_t), intent(inout) :: data
	type(particle_set_t), intent(in) :: particle_set
	type(mlm_matching_settings_t), intent(in) :: settings
	integer :: i, j, n_jets_PS
	integer, dimension(2) :: col
	type(particle_t) :: tempprt
	real(double) :: eta
	type(vector4_t) :: p_tmp

	!!! loop over particles and extract final colored ones with eta<etamax
	n_jets_PS = 0
	do i = 1, particle_set%get_n_tot ()
	if (signal_is_pending ()) return
	tempprt = particle_set%get_particle (i)
	if (tempprt%get_status () /= PRT_OUTGOING) cycle
	col = tempprt%get_color ()
	if (all (col == 0)) cycle
	if (data%is_hadron_collision) then
	p_tmp = tempprt%get_momentum ()
	if (energy (p_tmp) - longitudinal_part (p_tmp) < 1.E-10_default .or. &
	energy (p_tmp) + longitudinal_part (p_tmp) < 1.E-10_default) then
	eta = pseudorapidity (p_tmp)
	else
	eta = rapidity (p_tmp)
	end if
	if (eta > settings%mlm_etaClusfactor * &
	settings%mlm_etamax) then
	if (DEBUG_SHOWER) then
	print *, "REJECTING"
	call tempprt%write ()
	end if
	cycle
	end if
	end if
	n_jets_PS = n_jets_PS + 1
	end do

	allocate (data%P_PS(1:n_jets_PS))
	if (DEBUG_SHOWER) write (*, "(A,1x,I0)") "n_jets_ps =", n_jets_ps

	j = 1
	do i = 1, particle_set%get_n_tot ()
	tempprt = particle_set%get_particle (i)
	if (tempprt%get_status () /= PRT_OUTGOING) cycle
	col = tempprt%get_color ()
	if (all(col == 0)) cycle
	if (data%is_hadron_collision) then
	p_tmp = tempprt%get_momentum ()
	if (energy (p_tmp) - longitudinal_part (p_tmp) < 1.E-10_default .or. &
	energy (p_tmp) + longitudinal_part (p_tmp) < 1.E-10_default) then
	eta = pseudorapidity (p_tmp)
	else
	eta = rapidity (p_tmp)
	end if
	if (eta > settings%mlm_etaClusfactor * &
	settings%mlm_etamax) cycle
	end if
	data%P_PS(j) = tempprt%get_momentum ()
	j = j + 1
	end do
	end subroutine matching_transfer_PS

	@ %def matching_transfer_PS
	@ The parameters of the shower module:
	<<Shower core: parameters>>=
	real(default), save :: alphasxpdfmax = 12._default

	@ %def alphasxpdfmax
	@
	<<Shower core: shower: TBP>>=
	procedure :: add_interaction_2ton => shower_add_interaction_2ton
	<<Shower core: procedures>>=
	subroutine shower_add_interaction_2ton (shower, partons)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t), intent(in), dimension(:), allocatable :: partons
	type(ckkw_pseudo_shower_weights_t) :: ckkw_pseudo_weights
	call shower%add_interaction_2ton_CKKW (partons, ckkw_pseudo_weights)
	end subroutine shower_add_interaction_2ton

	@ %def shower_add_interaction_2ton
	@ In this routine, [[y]] and [[ymin]] are the jet measures, [[w]] and
	[[wmax]] are weights, [[s]] is the kinematic energy squared of the
	interaction. The flag [[isr_is_possible_and_allowed]] checks whether the initial
	parton is set, lepton-hadron collisions are not implemented (yet). As
	a workaround: as WHIZARD can treat partons as massless, there might be
	partons with $E < m$: if such a parton is found, quarks will be
	treated massless.
	<<Shower core: shower: TBP>>=
	procedure :: add_interaction_2ton_CKKW => shower_add_interaction_2ton_CKKW
	<<Shower core: procedures>>=
	subroutine shower_add_interaction_2ton_CKKW &
	(shower, partons, ckkw_pseudo_weights)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t), intent(in), dimension(:), allocatable :: partons
	type(ckkw_pseudo_shower_weights_t), intent(in) :: ckkw_pseudo_weights

	integer :: n_partons, n_out
	integer :: i, j, imin, jmin
	real(default) :: y, ymin
	real(default) :: w, wmax
	real(default) :: random, sum
	type(parton_pointer_t), dimension(:), allocatable :: new_partons
	type(parton_t), pointer :: prt
	integer :: n_int
	type(shower_interaction_pointer_t), dimension(:), allocatable :: temp
	type(vector4_t) :: prtmomentum, childmomentum
	logical :: isr_is_possible_and_allowed
	type(lorentz_transformation_t) :: L

	if (signal_is_pending ()) return
	if (DEBUG_SHOWER) print *, "Add interaction2toN"
	n_partons = size (partons)
	n_out = n_partons - 2
	if (n_out < 2) then
	call msg_bug &
	("Shower core: trying to add a 2-> (something<2) interaction")
	end if

	isr_is_possible_and_allowed = (associated (partons(1)%p%initial) .and. &
	associated (partons(2)%p%initial)) .and. &
	shower%settings%isr_active
	if (DEBUG_SHOWER) print *, 'isr_is_possible_and_allowed = ', isr_is_possible_and_allowed

	if (associated (partons(1)%p%initial) .and. &
	parton_is_quark (partons(1)%p)) then
	if (partons(1)%p%momentum%p(0) < &
	two * parton_mass (partons(1)%p)) then
	if (abs(partons(1)%p%type) < 2) then
	treat_light_quarks_massless = .true.
	else
	treat_duscb_quarks_massless = .true.
	end if
	end if
	end if
	if (associated (partons(2)%p%initial) .and. &
	parton_is_quark (partons(2)%p)) then
	if (partons(2)%p%momentum%p(0) < &
	two * parton_mass (partons(2)%p)) then
	if (abs(partons(2)%p%type) < 2) then
	treat_light_quarks_massless = .true.
	else
	treat_duscb_quarks_massless = .true.
	end if
	end if
	end if

	<<Add a new interaction to [[shower%interactions]]>>

	if (associated (shower%interactions(n_int)%i%partons(1)%p%initial)) &
	call shower%interactions(n_int)%i%partons(1)%p%initial%set_simulated ()
	if (associated (shower%interactions(n_int)%i%partons(2)%p%initial)) &
	call shower%interactions(n_int)%i%partons(2)%p%initial%set_simulated ()
	if (isr_is_possible_and_allowed) then
	!!! boost to the CMFrame of the incoming partons
	L = boost (-(shower%interactions(n_int)%i%partons(1)%p%momentum + &
	shower%interactions(n_int)%i%partons(2)%p%momentum), &
	(shower%interactions(n_int)%i%partons(1)%p%momentum + &
	shower%interactions(n_int)%i%partons(2)%p%momentum)**1 )
	do i = 1, n_partons
	call parton_apply_lorentztrafo &
	(shower%interactions(n_int)%i%partons(i)%p, L)
	end do
	end if
	do i = 1, size (partons)
	if (signal_is_pending ()) return
	!!! partons are marked as belonging to the hard interaction
	shower%interactions(n_int)%i%partons(i)%p%belongstointeraction &
	= .true.
	shower%interactions(n_int)%i%partons(i)%p%belongstoFSR = i > 2

	shower%interactions(n_int)%i%partons(i)%p%interactionnr &
	= n_int
	!!! include a 2^(i - 1) number as a label for the ckkw clustering
	shower%interactions(n_int)%i%partons(i)%p%ckkwlabel = 2**(i - 1)
	end do

	<<Add partons from [[shower%interactions]] to [[shower%partons]]>>

	if (isr_is_possible_and_allowed) then
	if (isr_pt_ordered) then
	call shower_prepare_for_simulate_isr_pt &
	(shower, shower%interactions(size (shower%interactions))%i)
	else
	call shower_prepare_for_simulate_isr_ana_test &
	(shower, shower%interactions(n_int)%i%partons(1)%p, &
	shower%interactions(n_int)%i%partons(2)%p)
	end if
	end if

	!!! generate pseudo parton shower history and add all partons to
	!!! shower%partons-array
	!!! TODO initial -> initial + final branchings ??
	allocate (new_partons(1:(n_partons - 2)))
	do i = 1, size (new_partons)
	nullify (new_partons(i)%p)
	end do
	do i = 1, size (new_partons)
	new_partons(i)%p => shower%interactions(n_int)%i%partons(i + 2)%p
	end do
	imin = 0
	jmin = 0

	if (allocated (ckkw_pseudo_weights%weights)) then
	<<Perform clustering using the CKKW weights>>
	else
	<<Perform clustering in the usual way>>
	end if

	!!! set the FSR starting scale for all partons
	do i = 1, size (new_partons)
	!!! the imaginary mother is the only parton remaining in new_partons
	if (.not. associated (new_partons(i)%p)) cycle

	call set_starting_scale (new_partons(i)%p, &
	get_starting_scale (new_partons(i)%p))
	exit
	end do

	deallocate (new_partons)

	contains

	<<Procedures of [[shower_add_interaction_2ton_CKKW]]>>
	end subroutine shower_add_interaction_2ton_CKKW

	@ %def shower_add_interaction_2ton_CKKW
	@
	<<Add a new interaction to [[shower%interactions]]>>=
	if (allocated (shower%interactions)) then
	n_int = size (shower%interactions) + 1
	else
	n_int = 1
	end if
	allocate (temp (1:n_int))
	do i = 1, n_int - 1
	allocate (temp(i)%i)
	temp(i)%i = shower%interactions(i)%i
	end do
	allocate (temp(n_int)%i)
	allocate (temp(n_int)%i%partons(1:n_partons))
	do i = 1, n_partons
	allocate (temp(n_int)%i%partons(i)%p)
	call parton_copy (partons(i)%p, temp(n_int)%i%partons(i)%p)
	end do
	if (allocated (shower%interactions)) deallocate(shower%interactions)
	allocate (shower%interactions(1:n_int))
	do i = 1, n_int
	shower%interactions(i)%i => temp(i)%i
	end do
	deallocate (temp)
	@
	<<Add partons from [[shower%interactions]] to [[shower%partons]]>>=
	if (allocated (shower%partons)) then
	allocate (new_partons(1:size(shower%partons) + &
	size(shower%interactions(n_int)%i%partons)))
	do i = 1, size (shower%partons)
	new_partons(i)%p => shower%partons(i)%p
	end do
	do i = 1, size (shower%interactions(n_int)%i%partons)
	new_partons(size(shower%partons) + i)%p => &
	shower%interactions(n_int)%i%partons(i)%p
	end do
	deallocate (shower%partons)
	else
	allocate (new_partons(1:size(shower%interactions(n_int)%i%partons)))
	do i = 1, size (partons)
	new_partons(i)%p => shower%interactions(n_int)%i%partons(i)%p
	end do
	end if
	allocate (shower%partons(1:size (new_partons)))
	do i = 1, size (new_partons)
	shower%partons(i)%p => new_partons(i)%p
	end do
	deallocate (new_partons)
	@
	<<Perform clustering using the CKKW weights>>=
	CKKW_CLUSTERING: do
	!!! search for the combination with the highest weight
	wmax = zero
	CKKW_OUTER: do i = 1, size (new_partons)
	CKKW_INNER: do j = i + 1, size (new_partons)
	if (.not. associated (new_partons(i)%p)) cycle
	if (.not. associated (new_partons(j)%p)) cycle
	w = ckkw_pseudo_weights%weights(new_partons(i)%p%ckkwlabel + &
	new_partons(j)%p%ckkwlabel)
	if (w > wmax .or. vanishes(wmax)) then
	wmax = w
	imin = i
	jmin = j
	end if
	end do CKKW_INNER
	end do CKKW_OUTER
	if (wmax > zero) then
	call shower%add_parent (new_partons(imin)%p)
	call parton_set_child (new_partons(imin)%p%parent, &
	new_partons(jmin)%p, 2)
	call parton_set_parent (new_partons(jmin)%p, &
	new_partons(imin)%p%parent)
	prt => new_partons(imin)%p%parent
	prt%nr = shower_get_next_free_nr (shower)
	prt%type = INTERNAL

	prt%momentum = new_partons(imin)%p%momentum + &
	new_partons(jmin)%p%momentum
	prt%t = prt%momentum**2

	!!! auxilliary values for the ckkw matching
	!!! for now, randomly choose the type of the intermediate
	prt%ckkwlabel = new_partons(imin)%p%ckkwlabel + &
	new_partons(jmin)%p%ckkwlabel
	sum = zero
	call shower%rng%generate (random)
	CKKW_TYPE: do i = 0, 4
	if (sum + &
	ckkw_pseudo_weights%weights_by_type(prt%ckkwlabel, i) > &
	random * ckkw_pseudo_weights%weights(prt%ckkwlabel) ) then
	prt%ckkwtype = i
	exit ckkw_type
	end if
	sum = sum + &
	ckkw_pseudo_weights%weights_by_type(prt%ckkwlabel, i)
	end do CKKW_TYPE

	!!! TODO -> calculate costheta and store it for
	!!! later use in generate_ps

	if (space_part_norm(prt%momentum) > tiny_10) then
	prtmomentum = prt%momentum
	childmomentum = prt%child1%momentum
	prtmomentum = boost (- prt%get_beta() / &
	sqrt (one - &
	(prt%get_beta ())**2), space_part (prt%momentum) / &
	space_part_norm(prt%momentum)) * prtmomentum
	childmomentum = boost (- prt%get_beta () / &
	sqrt(one - &
	(prt%get_beta ())**2), space_part (prt%momentum) / &
	space_part_norm(prt%momentum)) * childmomentum
	prt%costheta = enclosed_angle_ct(prtmomentum, childmomentum)
	else
	prt%costheta = - one
	end if

	prt%belongstointeraction = .true.
	prt%belongstoFSR = &
	new_partons(imin)%p%belongstoFSR .and. &
	new_partons(jmin)%p%belongstoFSR

	nullify (new_partons(imin)%p)
	nullify (new_partons(jmin)%p)
	new_partons(imin)%p => prt
	else
	exit CKKW_CLUSTERING
	end if
	end do CKKW_CLUSTERING
	@
	<<Perform clustering in the usual way>>=
	CLUSTERING: do
	!!! search for the partons to be clustered together
	ymin = zero
	OUTER: do i = 1, size (new_partons)
	INNER: do j = i + 1, size (new_partons)
	!!! calculate the jet measure
	if (.not.associated (new_partons(i)%p)) cycle INNER
	if (.not.associated (new_partons(j)%p)) cycle INNER
	!if (.not. shower_clustering_allowed &
	!(shower, new_partons, i,j)) &
	!cycle inner
	!!! Durham jet-measure ! don't care about constants
	y = min (new_partons(i)%p%momentum%p(0), &
	new_partons(j)%p%momentum%p(0)) * &
	(one - enclosed_angle_ct &
	(new_partons(i)%p%momentum, &
	new_partons(j)%p%momentum))
	if (y < ymin .or. vanishes(ymin)) then
	ymin = y
	imin = i
	jmin = j
	end if
	end do INNER
	end do OUTER
	if (ymin > zero) then
	call shower%add_parent (new_partons(imin)%p)
	call parton_set_child &
	(new_partons(imin)%p%parent, new_partons(jmin)%p, 2)
	call parton_set_parent &
	(new_partons(jmin)%p, new_partons(imin)%p%parent)
	prt => new_partons(imin)%p%parent
	prt%nr = shower_get_next_free_nr (shower)
	prt%type = INTERNAL

	prt%momentum = new_partons(imin)%p%momentum + &
	new_partons(jmin)%p%momentum
	prt%t = prt%momentum**2
	!!! TODO -> calculate costheta and store it for
	!!! later use in generate_ps

	if (space_part_norm(prt%momentum) > tiny_10) then
	prtmomentum = prt%momentum
	childmomentum = prt%child1%momentum
	prtmomentum = boost (- prt%get_beta () / sqrt(one - &
	(prt%get_beta ())**2), space_part(prt%momentum) / &
	space_part_norm(prt%momentum)) * prtmomentum
	childmomentum = boost (- prt%get_beta() / &
	sqrt(one - &
	(prt%get_beta ())**2), space_part(prt%momentum) / &
	space_part_norm(prt%momentum)) * childmomentum
	prt%costheta = enclosed_angle_ct (prtmomentum, childmomentum)
	else
	prt%costheta = - one
	end if

	prt%belongstointeraction = .true.
	nullify (new_partons(imin)%p)
	nullify (new_partons(jmin)%p)
	new_partons(imin)%p => prt
	else
	exit CLUSTERING
	end if
	end do CLUSTERING
	@
	<<Procedures of [[shower_add_interaction_2ton_CKKW]]>>=
	recursive subroutine transfer_pointers (destiny, start, prt)
	type(parton_pointer_t), dimension(:), allocatable :: destiny
	integer, intent(inout) :: start
	type(parton_t), pointer :: prt
	destiny(start)%p => prt
	start = start + 1
	if (associated (prt%child1)) then
	call transfer_pointers (destiny, start, prt%child1)
	end if
	if (associated (prt%child2)) then
	call transfer_pointers (destiny, start, prt%child2)
	end if
	end subroutine transfer_pointers

	@
	<<Procedures of [[shower_add_interaction_2ton_CKKW]]>>=
	recursive function get_starting_scale (prt) result (scale)
	type(parton_t), pointer :: prt
	real(default) :: scale
	scale = huge (scale)
	if (associated (prt%child1) .and. associated (prt%child2)) then
	scale = min(scale, prt%t)
	end if
	if (associated (prt%child1)) then
	scale = min (scale, get_starting_scale (prt%child1))
	end if
	if (associated (prt%child2)) then
	scale = min (scale, get_starting_scale (prt%child2))
	end if
	end function get_starting_scale

	@
	<<Procedures of [[shower_add_interaction_2ton_CKKW]]>>=
	recursive subroutine set_starting_scale (prt, scale)
	type(parton_t), pointer :: prt
	real(default) :: scale
	if (prt%type /= INTERNAL) then
	if (scale > prt%settings%d_min_t + prt%mass_squared ()) then
	prt%t = scale
	else
	prt%t = prt%mass_squared ()
	call prt%set_simulated ()
	end if
	end if
	if (associated (prt%child1)) then
	call set_starting_scale (prt%child1, scale)
	end if
	if (associated (prt%child2)) then
	call set_starting_scale (prt%child2, scale)
	end if
	end subroutine set_starting_scale

	@
	<<Shower core: shower: TBP>>=
	procedure :: simulate_no_isr_shower => shower_simulate_no_isr_shower
	<<Shower core: procedures>>=
	subroutine shower_simulate_no_isr_shower (shower)
	class(shower_t), intent(inout) :: shower
	integer :: i, j
	type(parton_t), pointer :: prt
	do i = 1, size (shower%interactions)
	do j = 1, 2
	prt => shower%interactions(i)%i%partons(j)%p
	if (associated (prt%initial)) then
	!!! for virtuality ordered: remove unneeded partons
	if (associated (prt%parent)) then
	if (.not. parton_is_proton(prt%parent)) then
	if (associated (prt%parent%parent)) then
	if (.not. parton_is_proton (prt%parent)) then
	call shower_remove_parton_from_partons &
	(shower, prt%parent%parent)
	end if
	end if
	call shower_remove_parton_from_partons &
	(shower, prt%parent)
	end if
	end if
	call parton_set_parent (prt, prt%initial)
	call parton_set_child (prt%initial, prt, 1)
	if (associated (prt%initial%child2)) then
	call shower_remove_parton_from_partons &
	(shower,prt%initial%child2)
	deallocate (prt%initial%child2)
	end if
	call shower%add_child (prt%initial, 2)
	end if
	end do
	end do
	end subroutine shower_simulate_no_isr_shower

	@ %def shower_simulate_no_isr_shower
	@
	<<Shower core: shower: TBP>>=
	procedure :: simulate_no_fsr_shower => shower_simulate_no_fsr_shower
	<<Shower core: procedures>>=
	subroutine shower_simulate_no_fsr_shower (shower)
	class(shower_t), intent(inout) :: shower
	integer :: i, j
	type(parton_t), pointer :: prt
	do i = 1, size (shower%interactions)
	do j = 3, size (shower%interactions(i)%i%partons)
	prt => shower%interactions(i)%i%partons(j)%p
	call prt%set_simulated ()
	prt%scale = zero
	prt%t = prt%mass_squared ()
	end do
	end do
	end subroutine shower_simulate_no_fsr_shower

	@ %def shower_simulate_no_fsr_shower
	@
	<<Shower core: procedures>>=
	subroutine swap_pointers (prtp1, prtp2)
	type(parton_pointer_t), intent(inout) :: prtp1, prtp2
	type(parton_pointer_t) :: prtptemp
	prtptemp%p => prtp1%p
	prtp1%p => prtp2%p
	prtp2%p => prtptemp%p
	end subroutine swap_pointers

	@ %def swap_pointers
	@ This removes emitted timelike partons.
	<<Shower core: procedures>>=
	recursive subroutine shower_remove_parton_from_partons (shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), pointer :: prt
	integer :: i
	if (.not. prt%belongstoFSR .and. associated (prt%child2)) then
	call shower_remove_parton_from_partons_recursive (shower, prt%child2)
	end if
	do i = 1, size (shower%partons)
	if (associated (shower%partons(i)%p, prt)) then
	shower%partons(i)%p => null()
	exit
	end if
	if (ASSERT) then
	if (i == size (shower%partons)) then
	print *, "shower_remove_parton_from_partons: parton to be removed not found"
	stop 1
	end if
	end if
	end do
	end subroutine shower_remove_parton_from_partons

	@ %def shower_remove_parton_from_partons
	@ This removes the parton [[prt]] and all its children.
	<<Shower core: procedures>>=
	recursive subroutine shower_remove_parton_from_partons_recursive (shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), pointer :: prt
	if (associated (prt%child1)) then
	call shower_remove_parton_from_partons_recursive (shower, prt%child1)
	deallocate (prt%child1)
	end if
	if (associated (prt%child2)) then
	call shower_remove_parton_from_partons_recursive (shower, prt%child2)
	deallocate (prt%child2)
	end if
	call shower_remove_parton_from_partons (shower, prt)
	end subroutine shower_remove_parton_from_partons_recursive

	@ %def shower_remove_parton_from_partons_recursive
	@
	<<Shower core: shower: TBP>>=
	procedure :: sort_partons => shower_sort_partons
	<<Shower core: procedures>>=
	subroutine shower_sort_partons (shower)
	class(shower_t), intent(inout) :: shower
	integer :: i, j, maxsort, size_partons
	logical :: changed
	if (D_PRINT) print *, "D: shower_sort_partons"
	if (.not. allocated (shower%partons)) return
	size_partons = size (shower%partons)
	maxsort = 0
	do i = 1, size_partons
	if (associated (shower%partons(i)%p)) maxsort = i
	end do
	if (signal_is_pending ()) return
	size_partons = size (shower%partons)
	if (size_partons <= 1) return
	do i = 1, maxsort
	if (.not. associated (shower%partons(i)%p)) cycle
	if (.not. isr_pt_ordered) then
	!!! set unsimulated ISR partons to be "typeless" to prevent
	!!! influences from "wrong" masses
	if (.not. shower%partons(i)%p%belongstoFSR .and. &
	.not. shower%partons(i)%p%simulated .and. &
	.not. shower%partons(i)%p%belongstointeraction) then
	shower%partons(i)%p%type = 0
	end if
	end if
	end do
	if (signal_is_pending ()) return
	!!! Just a Bubblesort
	!!! Different algorithms needed for t-ordered and pt^2-ordered shower
	!!! Pt-ordered:
	if (isr_pt_ordered) then
	OUTERDO_PT: do i = 1, maxsort - 1
	changed = .false.
	INNERDO_PT: do j = 1, maxsort - i
	if (.not. associated (shower%partons(j + 1)%p)) cycle
	if (.not. associated (shower%partons(j)%p)) then
	!!! change if j + 1 ist assoaciated and j is not
	call swap_pointers (shower%partons(j), shower%partons(j + 1))
	changed = .true.
	else if (shower%partons(j)%p%scale < &
	shower%partons(j + 1)%p%scale) then
	call swap_pointers (shower%partons(j), shower%partons(j + 1))
	changed = .true.
	else if (nearly_equal(shower%partons(j)%p%scale, &
	shower%partons(j + 1)%p%scale)) then
	if (shower%partons(j)%p%nr > shower%partons(j + 1)%p%nr) then
	call swap_pointers (shower%partons(j), shower%partons(j + 1))
	changed = .true.
	end if
	end if
	end do INNERDO_PT
	if (.not. changed) exit OUTERDO_PT
	end do outerdo_pt
	!!! \|t\|-ordered
	else
	OUTERDO_T: do i = 1, maxsort - 1
	changed = .false.
	INNERDO_T: do j = 1, maxsort - i
	if (.not. associated (shower%partons(j + 1)%p)) cycle
	if (.not. associated (shower%partons(j)%p)) then
	!!! change if j+1 is associated and j isn't
	call swap_pointers (shower%partons(j), shower%partons(j + 1))
	changed = .true.
	else if (.not. shower%partons(j)%p%belongstointeraction .and. &
	shower%partons(j + 1)%p%belongstointeraction) then
	!!! move partons belonging to the interaction to the front
	call swap_pointers (shower%partons(j), shower%partons(j + 1))
	changed = .true.
	else if (.not. shower%partons(j)%p%belongstointeraction .and. &
	.not. shower%partons(j + 1)%p%belongstointeraction ) then
	if (abs (shower%partons(j)%p%t) - &
	shower%partons(j)%p%mass_squared () < &
	abs(shower%partons(j + 1)%p%t) - &
	shower%partons(j + 1)%p%mass_squared ()) then
	call swap_pointers (shower%partons(j), shower%partons(j + 1))
	changed = .true.
	else
	if (nearly_equal(abs (shower%partons(j)%p%t) - &
	shower%partons(j)%p%mass_squared (), &
	abs(shower%partons(j + 1)%p%t) - &
	shower%partons(j + 1)%p%mass_squared ())) then
	if (shower%partons(j)%p%nr > &
	shower%partons(j + 1)%p%nr) then
	call swap_pointers (shower%partons(j), &
	shower%partons(j + 1))
	changed = .true.
	end if
	end if
	end if
	end if
	end do INNERDO_T
	if (.not. changed) exit OUTERDO_T
	end do OUTERDO_T
	end if
	if (signal_is_pending ()) return
	if (D_PRINT) print *, "D: shower_sort_partons: finished"
	end subroutine shower_sort_partons

	@ %def shower_sort_partons
	@ Creation and finalization. Note that we do not overwrite PDF data.
	<<Shower core: shower: TBP>>=
	procedure :: create => shower_create
	<<Shower core: procedures>>=
	subroutine shower_create (shower)
	class(shower_t), intent(inout), target :: shower
	shower%next_free_nr = 1
	shower%next_color_nr = 1
	if (ASSERT) then
	if (allocated (shower%interactions)) then
	call msg_bug ("Shower: creating new shower while old one " // &
	"is still associated (interactions)")
	end if
	if (allocated (shower%partons)) then
	call msg_bug ("Shower: creating new shower while old one " // &
	"is still associated (partons)")
	end if
	end if
	treat_light_quarks_massless = .true.
	treat_duscb_quarks_massless = .false.
	shower%valid = .true.
	end subroutine shower_create

	@ %def shower_create
	@ Deallocate the interaction pointers.
	<<Shower core: shower: TBP>>=
	procedure :: final => shower_final
	<<Shower core: procedures>>=
	subroutine shower_final (shower)
	class(shower_t), intent(inout) :: shower
	integer :: i
	if (.not. allocated (shower%interactions)) return
	do i = 1, size (shower%interactions)
	if (allocated (shower%interactions(i)%i%partons)) &
	deallocate (shower%interactions(i)%i%partons)
	deallocate (shower%interactions(i)%i)
	end do
	deallocate (shower%interactions)
	deallocate (shower%partons)
	end subroutine shower_final

	@ %def shower_final
	@ Bookkeeping functions.
	<<Shower core: shower: TBP>>=
	procedure :: get_next_free_nr => shower_get_next_free_nr
	<<Shower core: procedures>>=
	function shower_get_next_free_nr (shower) result (next_number)
	class(shower_t), intent(inout) :: shower
	integer :: next_number
	next_number = shower%next_free_nr
	shower%next_free_nr = shower%next_free_nr + 1
	end function shower_get_next_free_nr

	@ %def shower_get_next_free_nr
	@
	<<Shower core: shower: TBP>>=
	procedure :: set_next_color_nr => shower_set_next_color_nr
	<<Shower core: procedures>>=
	subroutine shower_set_next_color_nr (shower, index)
	class(shower_t), intent(inout) :: shower
	integer, intent(in) :: index
	if (index < shower%next_color_nr) then
	call msg_error ("in shower_set_next_color_nr")
	else
	shower%next_color_nr = max(shower%next_color_nr, index)
	end if
	end subroutine shower_set_next_color_nr

	@ %def shower_set_next_color_nr
	@
	<<Shower core: shower: TBP>>=
	procedure :: get_next_color_nr => shower_get_next_color_nr
	<<Shower core: procedures>>=
	function shower_get_next_color_nr (shower) result (next_color)
	class(shower_t), intent(inout) :: shower
	integer :: next_color
	next_color = shower%next_color_nr
	shower%next_color_nr = shower%next_color_nr + 1
	end function shower_get_next_color_nr

	@ %def shower_get_next_color_nr
	@
	<<Shower core: procedures>>=
	subroutine shower_enlarge_partons_array (shower, custom_length)
	type(shower_t), intent(inout) :: shower
	integer, intent(in), optional :: custom_length
	integer :: i, length, oldlength
	type(parton_pointer_t), dimension(:), allocatable :: tmp_partons
	if (D_PRINT) print *, "D: shower_enlarge_partons_array"
	if (present(custom_length)) then
	length = custom_length
	else
	length = 10
	end if
	if (ASSERT) then
	if (length < 1) then
	call msg_bug ("Shower: no parton_pointers added in shower%partons")
	end if
	end if
	if (allocated (shower%partons)) then
	oldlength = size (shower%partons)
	allocate (tmp_partons(1:oldlength))
	do i = 1, oldlength
	tmp_partons(i)%p => shower%partons(i)%p
	end do
	deallocate (shower%partons)
	else
	oldlength = 0
	end if
	allocate (shower%partons(1:oldlength + length))
	do i = 1, oldlength
	shower%partons(i)%p => tmp_partons(i)%p
	end do
	do i = oldlength + 1, oldlength + length
	shower%partons(i)%p => null()
	end do
	end subroutine shower_enlarge_partons_array

	@ %def shower_enlarge_partons_array
	@
	<<Shower core: shower: TBP>>=
	procedure :: add_child => shower_add_child
	<<Shower core: procedures>>=
	subroutine shower_add_child (shower, prt, child)
	class(shower_t), intent(inout) :: shower
	type(parton_t), pointer :: prt
	integer, intent(in) :: child
	integer :: i, lastfree
	type(parton_pointer_t) :: newprt
	if (child /= 1 .and. child /= 2) then
	call msg_bug ("Shower: Adding child in nonexisting place")
	end if
	allocate (newprt%p)
	newprt%p%nr = shower%get_next_free_nr ()
	!!! add new parton as child
	if (child == 1) then
	prt%child1 => newprt%p
	else
	prt%child2 => newprt%p
	end if
	newprt%p%parent => prt
	newprt%p%interactionnr = prt%interactionnr
	!!! add new parton to shower%partons list
	if (associated (shower%partons (size(shower%partons))%p)) then
	call shower_enlarge_partons_array (shower)
	end if
	!!! find last free pointer and let it point to the new parton
	lastfree = 0
	do i = size (shower%partons), 1, -1
	if (.not. associated (shower%partons(i)%p)) then
	lastfree = i
	end if
	end do
	if (lastfree == 0) then
	call msg_bug ("Shower: no free pointers found")
	end if
	shower%partons(lastfree)%p => newprt%p
	end subroutine shower_add_child

	@ %def shower_add_child
	@
	<<Shower core: shower: TBP>>=
	procedure :: add_parent => shower_add_parent
	<<Shower core: procedures>>=
	subroutine shower_add_parent (shower, prt)
	class(shower_t), intent(inout) :: shower
	type(parton_t), intent(inout), target :: prt
	integer :: i, lastfree
	type(parton_pointer_t) :: newprt
	if (D_PRINT) print *, "D: shower_add_parent: for parton ", prt%nr
	allocate (newprt%p)
	newprt%p%nr = shower%get_next_free_nr ()
	!!! add new parton as parent
	newprt%p%child1 => prt
	prt%parent => newprt%p
	newprt%p%interactionnr = prt%interactionnr
	!!! add new parton to shower%partons list
	if (.not. allocated (shower%partons) .or. &
	associated (shower%partons(size(shower%partons))%p)) then
	call shower_enlarge_partons_array (shower)
	end if
	!!! find last free pointer and let it point to the new parton
	lastfree = 0
	do i = size(shower%partons), 1, -1
	if (.not. associated (shower%partons(i)%p)) then
	lastfree = i
	end if
	end do
	if (ASSERT) then
	if (lastfree == 0) then
	call msg_bug ("Shower: no free pointers found")
	end if
	end if
	shower%partons(lastfree)%p => newprt%p
	end subroutine shower_add_parent

	@ %def shower_add_parent
	@ For debugging:
	<<Shower core: procedures>>=
	pure function shower_get_total_momentum (shower) result (mom)
	type(shower_t), intent(in) :: shower
	type(vector4_t) :: mom
	integer :: i
	if (.not. allocated (shower%partons)) return
	mom = vector4_null
	do i = 1, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	if (parton_is_final (shower%partons(i)%p)) then
	mom = mom + shower%partons(i)%p%momentum
	end if
	end do
	end function shower_get_total_momentum

	@ %def shower_get_total_momentum
	@ Count the number of partons by going through [[shower%partons]]
	whereby you can require a minimum energy [[mine]] and specify whether to
	[[include_remnants]], which is done if not given.
	<<Shower core: shower: TBP>>=
	procedure :: get_nr_of_partons => shower_get_nr_of_partons
	<<Shower core: procedures>>=
	function shower_get_nr_of_partons (shower, mine, &
	include_remnants, no_hard_prts, only_colored) result (nr)
	class(shower_t), intent(in) :: shower
	real(default), intent(in), optional :: mine
	logical, intent(in), optional :: include_remnants, no_hard_prts, &
	only_colored
	logical :: no_hard, only_col, include_rem
	integer :: nr, i
	nr = 0
	no_hard = .false.; if (present (no_hard_prts)) &
	no_hard = no_hard_prts
	only_col = .false.; if (present (only_colored)) &
	only_col = only_colored
	include_rem = .true.; if (present (include_remnants)) &
	include_rem = include_remnants
	do i = 1, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	associate (prt => shower%partons(i)%p)
	if (.not. parton_is_final (prt)) cycle
	if (present (only_colored)) then
	if (only_col) then
	if (.not. prt%is_colored ()) cycle
	else
	if (prt%is_colored ()) cycle
	end if
	end if
	if (no_hard) then
	if (shower%partons(i)%p%belongstointeraction) cycle
	end if
	if (.not. include_rem) then
	if (prt%type == BEAM_REMNANT) cycle
	end if
	if (present(mine)) then
	if (prt%momentum%p(0) < mine) cycle
	end if
	nr = nr + 1
	end associate
	end do
	end function shower_get_nr_of_partons

	@ %def shower_get_nr_of_partons
	@
	<<Shower core: procedures>>=
	function shower_get_nr_of_final_colored_ME_partons (shower) result (nr)
	type(shower_t), intent(in) :: shower
	integer :: nr
	integer :: i, j
	type(parton_t), pointer :: prt
	nr = 0
	do i = 1, size (shower%interactions)
	do j = 1, size (shower%interactions(i)%i%partons)
	prt => shower%interactions(i)%i%partons(j)%p
	if (.not. associated (prt)) cycle
	if (.not. prt%is_colored ()) cycle
	if (prt%belongstointeraction .and. prt%belongstoFSR .and. &
	(prt%type /= INTERNAL)) then
	nr = nr +1
	end if
	end do
	end do
	end function shower_get_nr_of_final_colored_ME_partons

	@ %def shower_get_nr_of_final_colored_ME_partons
	@
	<<Shower core: shower: TBP>>=
	procedure :: get_final_colored_ME_partons => &
	shower_get_final_colored_ME_partons
	<<Shower core: procedures>>=
	subroutine shower_get_final_colored_ME_partons (shower, partons)
	class(shower_t), intent(in) :: shower
	type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: partons
	integer :: i, j, index, s
	type(parton_t), pointer :: prt
	if (allocated(partons)) deallocate(partons)
	s = shower_get_nr_of_final_colored_ME_partons (shower)
	if (s == 0) return
	allocate (partons(1:s))
	index = 0
	do i = 1, size (shower%interactions)
	do j = 1, size (shower%interactions(i)%i%partons)
	prt => shower%interactions(i)%i%partons(j)%p
	if (.not. associated (prt)) cycle
	if (.not. prt%is_colored ()) cycle
	if (prt%belongstointeraction .and. prt%belongstoFSR .and. &
	(prt%type /= INTERNAL)) then
	index = index + 1
	partons(index)%p => prt
	end if
	end do
	end do
	end subroutine shower_get_final_colored_ME_partons

	@ %def shower_get_final_colored_ME_partons
	@
	<<Shower core: procedures>>=
	recursive function interaction_fsr_is_finished_for_parton(prt) result (finished)
	type(parton_t), intent(in) :: prt
	logical :: finished
	if (prt%belongstoFSR) then
	!!! FSR partons
	if (associated (prt%child1)) then
	finished = interaction_fsr_is_finished_for_parton (prt%child1) &
	.and. interaction_fsr_is_finished_for_parton (prt%child2)
	else
	finished = prt%t <= prt%mass_squared ()
	end if
	else
	!!! search for emitted timelike partons in ISR shower
	if (.not. associated (prt%initial)) then
	!!! no inital -> no ISR
	finished = .true.
	else if (.not. associated (prt%parent)) then
	finished = .false.
	else
	if (.not. parton_is_proton (prt%parent)) then
	if (associated (prt%child2)) then
	finished = interaction_fsr_is_finished_for_parton (prt%parent) .and. &
	interaction_fsr_is_finished_for_parton (prt%child2)
	else
	finished = interaction_fsr_is_finished_for_parton (prt%parent)
	end if
	else
	if (associated (prt%child2)) then
	finished = interaction_fsr_is_finished_for_parton (prt%child2)
	else
	!!! only second partons can come here -> if that happens FSR
	!!! evolution is not existing
	finished = .true.
	end if
	end if
	end if
	end if
	end function interaction_fsr_is_finished_for_parton

	@ %def interaction_fsr_is_finished_for_parton
	@
	<<Shower core: procedures>>=
	function interaction_fsr_is_finished (interaction) result (finished)
	type(shower_interaction_t), intent(in) :: interaction
	logical :: finished
	integer :: i
	finished = .true.
	if (.not. allocated (interaction%partons)) return
	do i = 1, size (interaction%partons)
	if (.not. interaction_fsr_is_finished_for_parton &
	(interaction%partons(i)%p)) then
	finished = .false.
	exit
	end if
	end do
	end function interaction_fsr_is_finished

	@ %def interaction_fsr_is_finished
	@
	<<Shower core: public>>=
	public :: shower_interaction_get_s
	<<Shower core: procedures>>=
	function shower_interaction_get_s (interaction) result (s)
	type(shower_interaction_t), intent(in) :: interaction
	real(default) :: s
	s = (interaction%partons(1)%p%initial%momentum + &
	interaction%partons(2)%p%initial%momentum)**2
	end function shower_interaction_get_s

	@ %def shower_interaction_get_s
	@
	<<Shower core: procedures>>=
	function shower_fsr_is_finished (shower) result (finished)
	type(shower_t), intent(in) :: shower
	logical :: finished
	integer :: i
	finished = .true.
	if (.not.allocated (shower%interactions)) return
	do i = 1, size(shower%interactions)
	if (.not. interaction_fsr_is_finished (shower%interactions(i)%i)) then
	finished = .false.
	exit
	end if
	end do
	end function shower_fsr_is_finished

	@ %def shower_fsr_is_finished
	@
	<<Shower core: procedures>>=
	function shower_isr_is_finished (shower) result (finished)
	type(shower_t), intent(in) :: shower
	logical :: finished
	integer :: i
	type(parton_t), pointer :: prt
	finished = .true.
	if (.not.allocated (shower%partons)) return
	do i = 1, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	prt => shower%partons(i)%p
	if (isr_pt_ordered) then
	if (.not. prt%belongstoFSR .and. .not. prt%simulated &
	.and. prt%scale > zero) then
	finished = .false.
	exit
	end if
	else
	if (.not. prt%belongstoFSR .and. .not. prt%simulated &
	.and. prt%t < zero) then
	finished = .false.
	exit
	end if
	end if
	end do
	end function shower_isr_is_finished

	@ %def shower_isr_is_finished
	@
	<<Shower core: procedures>>=
	subroutine interaction_find_partons_nearest_to_hadron (interaction, prt1, prt2)
	type(shower_interaction_t), intent(in) :: interaction
	type(parton_t), pointer :: prt1, prt2
	prt1 => null ()
	prt2 => null ()
	prt1 => interaction%partons(1)%p
	do
	if (associated (prt1%parent)) then
	if (parton_is_proton (prt1%parent)) then
	exit
	else if ((.not. isr_pt_ordered .and. .not. prt1%parent%simulated) &
	.or. (isr_pt_ordered .and. .not. prt1%simulated)) then
	exit
	else
	prt1 => prt1%parent
	end if
	else
	exit
	end if
	end do
	prt2 => interaction%partons(2)%p
	do
	if (associated (prt2%parent)) then
	if (parton_is_proton (prt2%parent)) then
	exit
	else if ((.not. isr_pt_ordered .and. .not. prt2%parent%simulated) &
	.or. (isr_pt_ordered .and. .not. prt2%simulated)) then
	exit
	else
	prt2 => prt2%parent
	end if
	else
	exit
	end if
	end do
	end subroutine interaction_find_partons_nearest_to_hadron

	@ %def interaction_find_partons_nearest_to_hadron
	@
	<<Shower core: shower: TBP>>=
	procedure :: update_beamremnants => shower_update_beamremnants
	<<Shower core: procedures>>=
	subroutine shower_update_beamremnants (shower)
	class(shower_t), intent(inout) :: shower
	type(parton_t), pointer :: hadron, remnant
	integer :: i
	real(default) :: random
	!!! only proton in first interaction !!?
	!!! currently only first beam-remnant will be updated
	do i = 1,2
	if (associated (shower%interactions(1)%i%partons(i)%p%initial)) then
	hadron => shower%interactions(1)%i%partons(i)%p%initial
	else
	cycle
	end if
	remnant => hadron%child2
	if (associated (remnant)) then
	remnant%momentum = hadron%momentum - hadron%child1%momentum
	end if
	!!! generate flavor of the beam-remnant if beam was proton
	if (abs (hadron%type) == PROTON .and. associated (hadron%child1)) then
	if (parton_is_quark (hadron%child1)) then
	!!! decide if valence (u,d) or sea quark (s,c,b)
	if ((abs (hadron%child1%type) <= 2) .and. &
	(hadron%type * hadron%child1%type > zero)) then
	!!! valence quark
	if (abs (hadron%child1%type) == 1) then
	!!! if d then remaining diquark is uu_1
	remnant%type = sign (UU1, hadron%type)
	else
	call shower%rng%generate (random)
	!!! if u then remaining diquark is ud_0 or ud_1
	if (random < 0.75_default) then
	remnant%type = sign (UD0, hadron%type)
	else
	remnant%type = sign (UD1, hadron%type)
	end if
	end if
	remnant%c1 = hadron%child1%c2
	remnant%c2 = hadron%child1%c1
	else if ((hadron%type * hadron%child1%type) < zero) then
	!!! antiquark
	if (.not. associated (remnant%child1)) then
	call shower%add_child (remnant, 1)
	end if
	if (.not. associated (remnant%child2)) then
	call shower%add_child (remnant, 2)
	end if
	call shower%rng%generate (random)
	if (random < 0.6666_default) then
	!!! 2/3 into udq + u
	if (abs (hadron%child1%type) == 1) then
	remnant%child1%type = sign (NEUTRON, hadron%type)
	else if (abs (hadron%child1%type) == 2) then
	remnant%child1%type = sign (PROTON, hadron%type)
	else if (abs (hadron%child1%type) == 3) then
	remnant%child1%type = sign (SIGMA0, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (SIGMACPLUS, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (SIGMAB0, hadron%type)
	end if
	remnant%child2%type = sign (2, hadron%type)
	else
	!!! 1/3 into uuq + d
	if (abs (hadron%child1%type) == 1) then
	remnant%child1%type = sign (PROTON, hadron%type)
	else if (abs (hadron%child1%type) == 2) then
	remnant%child1%type = sign (DELTAPLUSPLUS, hadron%type)
	else if (abs (hadron%child1%type) == 3) then
	remnant%child1%type = sign (SIGMAPLUS, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (SIGMACPLUSPLUS, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (SIGMABPLUS, hadron%type)
	end if
	remnant%child2%type = sign (1, hadron%type)
	end if
	remnant%c1 = hadron%child1%c2
	remnant%c2 = hadron%child1%c1
	remnant%child1%c1 = 0
	remnant%child1%c2 = 0
	remnant%child2%c1 = remnant%c1
	remnant%child2%c2 = remnant%c2
	else
	!!! sea quark
	if (.not. associated (remnant%child1)) then
	call shower%add_child (remnant, 1)
	end if
	if (.not. associated (remnant%child2)) then
	call shower%add_child (remnant, 2)
	end if
	call shower%rng%generate (random)
	if (random < 0.5_default) then
	!!! 1/2 into usbar + ud_0
	if (abs (hadron%child1%type) == 3) then
	remnant%child1%type = sign (KPLUS, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (D0, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (BPLUS, hadron%type)
	end if
	remnant%child2%type = sign (UD0, hadron%type)
	else if (random < 0.6666_default) then
	!!! 1/6 into usbar + ud_1
	if (abs (hadron%child1%type) == 3) then
	remnant%child1%type = sign (KPLUS, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (D0, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (BPLUS, hadron%type)
	end if
	remnant%child2%type = sign (UD1, hadron%type)
	else
	!!! 1/3 into dsbar + uu_1
	if (abs (hadron%child1%type) == 3) then
	remnant%child1%type = sign (K0, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (DPLUS, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (B0, hadron%type)
	end if
	remnant%child2%type = sign (UU1, hadron%type)
	end if
	remnant%c1 = hadron%child1%c2
	remnant%c2 = hadron%child1%c1
	remnant%child1%c1 = 0
	remnant%child1%c2 = 0
	remnant%child2%c1 = remnant%c1
	remnant%child2%c2 = remnant%c2
	end if
	else if (parton_is_gluon (hadron%child1)) then
	if (.not.associated (remnant%child1)) then
	call shower%add_child (remnant, 1)
	end if
	if (.not.associated (remnant%child2)) then
	call shower%add_child (remnant, 2)
	end if
	call shower%rng%generate (random)
	if (random < 0.5_default) then
	!!! 1/2 into u + ud_0
	remnant%child1%type = sign (2, hadron%type)
	remnant%child2%type = sign (UD0, hadron%type)
	else if (random < 0.6666_default) then
	!!! 1/6 into u + ud_1
	remnant%child1%type = sign (2, hadron%type)
	remnant%child2%type = sign (UD1, hadron%type)
	else
	!!! 1/3 into d + uu_1
	remnant%child1%type = sign (1, hadron%type)
	remnant%child2%type = sign (UU1, hadron%type)
	end if
	remnant%c1 = hadron%child1%c2
	remnant%c2 = hadron%child1%c1
	if (hadron%type > 0) then
	remnant%child1%c1 = remnant%c1
	remnant%child2%c2 = remnant%c2
	else
	remnant%child1%c2 = remnant%c2
	remnant%child2%c1 = remnant%c1
	end if
	end if
	remnant%initial => hadron
	if (associated (remnant%child1)) then
	remnant%child1%initial => hadron
	remnant%child2%initial => hadron
	!!! don't care about on-shellness for now
	remnant%child1%momentum = 0.5_default * remnant%momentum
	remnant%child2%momentum = 0.5_default * remnant%momentum
	!!! but care about on-shellness for baryons
	if (mod (remnant%child1%type, 100) >= 10) then
	!!! check if the third quark is set -> meson or baryon
	remnant%child1%t = remnant%child1%mass_squared ()
	remnant%child1%momentum = [remnant%child1%momentum%p(0), &
	(remnant%child1%momentum%p(1:3) / &
	remnant%child1%momentum%p(1:3)*1) &
	sqrt (remnant%child1%momentum%p(0)**2 - remnant%child1%t)]
	remnant%child2%momentum = remnant%momentum &
	- remnant%child1%momentum
	end if
	end if
	end if
	end do
	end subroutine shower_update_beamremnants

	@ %def shower_update_beamremnants
	@
	<<Shower core: procedures>>=
	subroutine interaction_apply_lorentztrafo (interaction, L)
	type(shower_interaction_t), intent(inout) :: interaction
	type(lorentz_transformation_t), intent(in) :: L
	type(parton_t), pointer :: prt
	integer :: i
	!!! ISR part
	do i = 1,2
	prt => interaction%partons(i)%p
	!!! loop over ancestors
	MOTHERS: do
	!!! boost parton
	call parton_apply_lorentztrafo (prt, L)
	if (associated (prt%child2)) then
	!!! boost emitted timelike parton (and daughters)
	call parton_apply_lorentztrafo_recursive (prt%child2, L)
	end if
	if (associated (prt%parent)) then
	if (.not. parton_is_proton (prt%parent)) then
	prt => prt%parent
	else
	exit
	end if
	else
	exit
	end if
	end do MOTHERS
	end do
	!!! FSR part
	if (associated (interaction%partons(3)%p%parent)) then
	!!! pseudo Parton-Shower histora has been generated -> find
	!!! mother and go on from there recursively
	prt => interaction%partons(3)%p
	do while (associated (prt%parent))
	prt => prt%parent
	end do
	call parton_apply_lorentztrafo_recursive (prt, L)
	else
	do i = 3, size (interaction%partons)
	call parton_apply_lorentztrafo (interaction%partons(i)%p, L)
	end do
	end if
	end subroutine interaction_apply_lorentztrafo

	@ %def interaction_apply_lorentztrafo
	@
	<<Shower core: procedures>>=
	subroutine shower_apply_lorentztrafo (shower, L)
	type(shower_t), intent(inout) :: shower
	type(lorentz_transformation_t), intent(in) :: L
	integer :: i
	do i = 1, size (shower%interactions)
	call interaction_apply_lorentztrafo (shower%interactions(i)%i, L)
	end do
	end subroutine shower_apply_lorentztrafo

	@ %def shower_apply_lorentztrafo
	@ This boosts partons belonging to the interaction to the
	center-of-mass frame of its partons nearest to the hadron.
	<<Shower core: procedures>>=
	subroutine interaction_boost_to_CMframe (interaction)
	type(shower_interaction_t), intent(inout) :: interaction
	type(vector4_t) :: beta
	type(parton_t), pointer :: prt1, prt2
	call interaction_find_partons_nearest_to_hadron (interaction, prt1, prt2)
	beta = prt1%momentum + prt2%momentum
	beta = beta / beta%p(0)
	if (ASSERT) then
	if (beta**2 > one) then
	call msg_error ("Shower: boost to CM frame: beta > 1")
	return
	end if
	end if
	if (space_part(beta)**2 > tiny_13) then
	call interaction_apply_lorentztrafo(interaction, &
	boost(space_part(beta)**1 / &
	sqrt (one - space_part(beta)**2), -direction(beta)))
	end if
	end subroutine interaction_boost_to_CMframe

	@ %def interaction_boost_to_CMframe
	@ This boosts every interaction to the center-of-mass-frame of its
	partons nearest to the hadron.
	<<Shower core: procedures>>=
	subroutine shower_boost_to_CMframe (shower)
	type(shower_t), intent(inout) :: shower
	integer :: i
	do i = 1, size (shower%interactions)
	call interaction_boost_to_CMframe (shower%interactions(i)%i)
	end do
	! TODO: (bcn 2015-03-23) this shouldnt be here !
	call shower%update_beamremnants ()
	end subroutine shower_boost_to_CMframe

	@ %def shower_boost_to_CMframe
	@ This boost all partons so that initial partons have their assigned
	$x$-value.
	<<Shower core: shower: TBP>>=
	procedure :: boost_to_labframe => shower_boost_to_labframe
	<<Shower core: procedures>>=
	subroutine shower_boost_to_labframe (shower)
	class(shower_t), intent(inout) :: shower
	integer :: i
	do i = 1, size (shower%interactions)
	call interaction_boost_to_labframe (shower%interactions(i)%i)
	end do
	end subroutine shower_boost_to_labframe

	@ %def shower_boost_to_labframe
	@ This boosts all partons so that initial partons have their
	assigned $x$-value.
	<<Shower core: procedures>>=
	subroutine interaction_boost_to_labframe (interaction)
	type(shower_interaction_t), intent(inout) :: interaction
	type(parton_t), pointer :: prt1, prt2
	type(vector3_t) :: beta
	call interaction_find_partons_nearest_to_hadron (interaction, prt1, prt2)
	if (.not. associated (prt1%initial) .or. .not. associated (prt2%initial)) then
	return
	end if
	!!! transform partons to overall labframe.
	beta = vector3_canonical(3) * &
	((prt1%x * prt2%momentum%p(0) - &
	prt2%x * prt1%momentum%p(0)) / &
	(prt1%x * prt2%momentum%p(3) - &
	prt2%x * prt1%momentum%p(3)))
	if (beta**1 > tiny_10) &
	call interaction_apply_lorentztrafo (interaction, &
	boost (beta1 / sqrt(one - beta2), -direction(beta)))
	end subroutine interaction_boost_to_labframe

	@ %def interaction_boost_to_labframe
	@ Only rotate to z if inital hadrons are given (and they are assumed
	to be aligned along the z-axis).
	<<Shower core: procedures>>=
	subroutine interaction_rotate_to_z (interaction)
	type(shower_interaction_t), intent(inout) :: interaction
	type(parton_t), pointer :: prt1, prt2
	call interaction_find_partons_nearest_to_hadron (interaction, prt1, prt2)
	if (associated (prt1%initial)) then
	call interaction_apply_lorentztrafo (interaction, &
	rotation_to_2nd (space_part (prt1%momentum), &
	vector3_canonical(3) * sign (one, &
	prt1%initial%momentum%p(3))))
	end if
	end subroutine interaction_rotate_to_z

	@ %def interaction_rotate_to_z
	@ Rotate initial partons to lie along $\pm z$ axis.
	<<Shower core: procedures>>=
	subroutine shower_rotate_to_z (shower)
	type(shower_t), intent(inout) :: shower
	integer :: i
	do i = 1, size (shower%interactions)
	call interaction_rotate_to_z (shower%interactions(i)%i)
	end do
	! TODO: (bcn 2015-03-23) this shouldnt be here !
	call shower%update_beamremnants ()
	end subroutine shower_rotate_to_z

	@ %def shower_rotate_to_z
	@
	<<Shower core: procedures>>=
	subroutine interaction_generate_primordial_kt (interaction, rng)
	type(shower_interaction_t), intent(inout) :: interaction
	class(rng_t), intent(inout), allocatable :: rng
	type(parton_t), pointer :: had1, had2
	type(vector4_t) :: momenta(2)
	type(vector3_t) :: beta
	real(default) :: pt (2), phi(2)
	real(default) :: shat
	real(default) :: btheta, bphi
	integer :: i
	if (vanishes(primordial_kt_width)) return
	!!! Return if there are no initials, electron-hadron collision not implemented
	if (.not. associated (interaction%partons(1)%p%initial) .or. &
	.not. associated (interaction%partons(2)%p%initial)) then
	return
	end if
	had1 => interaction%partons(1)%p%initial
	had2 => interaction%partons(2)%p%initial
	!!! copy momenta and energy
	momenta(1) = had1%child1%momentum
	momenta(2) = had2%child1%momentum
	GENERATE_PT_PHI: do i = 1, 2
	!!! generate transverse momentum and phi
	GENERATE_PT: do
	call rng%generate (pt (i))
	pt(i) = primordial_kt_width * sqrt(-log(pt(i)))
	if (pt(i) < primordial_kt_cutoff) exit
	end do GENERATE_PT
	call rng%generate (phi (i))
	phi(i) = twopi * phi(i)
	end do GENERATE_PT_PHI
	!!! adjust momenta
	shat = (momenta(1) + momenta(2))**2
	momenta(1) = [momenta(1)%p(0), &
	pt(1) * cos(phi(1)), &
	pt(1) * sin(phi(1)), &
	momenta(1)%p(3)]
	momenta(2) = [momenta(2)%p(0), &
	pt(2) * cos(phi(2)), &
	pt(2) * sin(phi(2)), &
	momenta(2)%p(3)]
	beta = [momenta(1)%p(1) + momenta(2)%p(1), &
	momenta(1)%p(2) + momenta(2)%p(2), zero] / sqrt(shat)
	momenta(1) = boost (beta1 / sqrt(one - beta2), -direction(beta)) * momenta(1)
	bphi = azimuthal_angle (momenta(1))
	btheta = polar_angle (momenta(1))
	call interaction_apply_lorentztrafo (interaction, &
	rotation (cos(bphi), sin(bphi), 3) * rotation(cos(btheta), &
	sin(btheta), 2) * rotation(cos(-bphi), sin(-bphi), 3))
	call interaction_apply_lorentztrafo (interaction, &
	boost (beta1 / sqrt(one - beta2), -direction(beta)))
	end subroutine interaction_generate_primordial_kt

	@ %def interaction_generate_primordial_kt
	@
	<<Shower core: shower: TBP>>=
	procedure :: generate_primordial_kt => shower_generate_primordial_kt
	<<Shower core: procedures>>=
	subroutine shower_generate_primordial_kt (shower)
	class(shower_t), intent(inout) :: shower
	integer :: i
	do i = 1, size (shower%interactions)
	call interaction_generate_primordial_kt &
	(shower%interactions(i)%i, shower%rng)
	end do
	! TODO: (bcn 2015-03-23) this shouldnt be here !
	call shower%update_beamremnants ()
	end subroutine shower_generate_primordial_kt

	@ %def shower_generate_primordial_kt
	@ Output.
	<<Shower core: procedures>>=
	subroutine interaction_write (interaction, unit)
	type(shower_interaction_t), intent(in) :: interaction
	integer, intent(in), optional :: unit
	integer :: i, u
	u = given_output_unit (unit); if (u < 0) return
	if (associated (interaction%partons(1)%p)) then
	if (associated (interaction%partons(1)%p%initial)) &
	call parton_write (interaction%partons(1)%p%initial, u)
	end if
	if (associated (interaction%partons(2)%p)) then
	if (associated (interaction%partons(2)%p%initial)) &
	call parton_write (interaction%partons(2)%p%initial, u)
	end if
	if (allocated (interaction%partons)) then
	do i = 1, size (interaction%partons)
	call parton_write (interaction%partons(i)%p, u)
	end do
	end if
	write (u, "(A)")
	end subroutine interaction_write

	@ %def interaction_write
	@
	<<Shower core: shower: TBP>>=
	procedure :: write => shower_write
	<<Shower core: procedures>>=
	subroutine shower_write (shower, unit)
	class(shower_t), intent(in) :: shower
	integer, intent(in), optional :: unit
	integer :: i, u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "------------------------------"
	write (u, "(1x,A)") "WHIZARD internal parton shower"
	write (u, "(1x,A)") "------------------------------"
	call shower%pdf_data%write (u)
	write (u, "(3x,A,L1)") "ISR: angular ordered = ", &
	shower%isr_angular_ordered
	write (u, "(3x,A,ES19.12)") "ISR: maxz_isr = ", shower%maxz_isr
	write (u, "(3x,A,ES19.12)") "ISR: min. energy/timelike emission = ", &
	shower%minenergy_timelike
	write (u, "(3x,A,ES19.12)") "ISR: first scale = ", shower%tscalefactor_isr
	write (u, "(3x,A,ES19.12)") "ISR: 1st integral suppression factor = ", &
	shower%first_integral_suppression_factor
	write (u, "(3x,A,L1)") "ISR: partons only onshell = ", &
	shower%isr_only_onshell_emitted_partons
	if (size (shower%interactions) > 0) then
	write (u, "(3x,A)") "Interactions: "
	do i = 1, size (shower%interactions)
	write (u, "(4x,A,I0)") "Interaction number ", i
	if (.not. associated (shower%interactions(i)%i)) then
	call msg_fatal ("Shower: missing interaction in shower")
	end if
	call interaction_write (shower%interactions(i)%i, u)
	end do
	else
	write (u, "(3x,A)") "[no interactions in shower]"
	end if
	write (u, "(A)")
	if (allocated (shower%partons)) then
	write (u, "(5x,A)") "Partons:"
	do i = 1, size (shower%partons)
	if (associated (shower%partons(i)%p)) then
	call parton_write(shower%partons(i)%p, u)
	if (i < size (shower%partons)) then
	if (associated (shower%partons(i + 1)%p)) then
	if (shower%partons(i)%p%belongstointeraction .and. &
	.not. shower%partons(i + 1)%p%belongstointeraction) then
	write (u, "(A)") &
	"-------------------------------------------------------"
	end if
	end if
	end if
	end if
	end do
	else
	write (u, "(5x,A)") "[no partons in shower]"
	end if
	write (u, "(4x,A)") "Total Momentum: "
	call vector4_write (shower_get_total_momentum (shower))
	write (u, "(1x,A,L1)") "ISR finished: ", shower_isr_is_finished (shower)
	write (u, "(1x,A,L1)") "FSR finished: ", shower_fsr_is_finished (shower)
	end subroutine shower_write

	@ %def shower_write
	@ We combine the [[particle_set]] from the hard interaction with the
	partons of the shower. For simplicity, we do not maintain the
	mother-daughter-relations of the shower. Hadronic [[beam_remnants]] of
	the old [[particle_set]] are removed as they are provided, including
	proper flavor information, by the ISR shower. We assume that beam
	remnants come after initials such that we don't have to update the MDRs
	of the hard final state.
	<<Shower core: shower: TBP>>=
	procedure :: combine_with_particle_set => shower_combine_with_particle_set
	<<Shower core: procedures>>=
	subroutine shower_combine_with_particle_set (shower, particle_set, &
	model_in, model_hadrons)
	class(shower_t), intent(in) :: shower
	type(particle_set_t), intent(inout) :: particle_set
	type(particle_t), dimension(:), allocatable :: particles
	integer, dimension(:), allocatable :: hard_colored_ids, shower_partons_ids
	class(model_data_t), intent(in), target :: model_in
	class(model_data_t), intent(in), target :: model_hadrons
	class(model_data_t), pointer :: model
	logical, dimension(size(particle_set%prt)) :: no_hadronic_remnants
	logical, dimension(:), allocatable :: hard_colored_mask
	integer, dimension(:), allocatable :: children, new_children
	integer :: n_shower_partons, n_remnants, i, n_hard
	if (signal_is_pending ()) return

	call remove_hadronic_remnants_and_pack_in_particles ()
	call count_and_allocate ()
	do i = 1, n_hard
	call set_hard_colored_as_virtual_parents_for_shower ()
	call remove_hadronic_remnant_children_of_beam ()
	end do
	call add_to_pset (n_hard, .true.)
	call add_to_pset (n_hard + n_remnants, .false.)
	call particle_set%replace (particles)

	contains

	<<Shower core: shower combine with particle set: procedures>>

	end subroutine shower_combine_with_particle_set

	@ %def shower_combine_with_particle_set
	<<Shower core: shower combine with particle set: procedures>>=
	subroutine remove_hadronic_remnants_and_pack_in_particles ()
	no_hadronic_remnants = .not. (particle_set%prt%is_hadronic_beam_remnant ())
	n_hard = count (no_hadronic_remnants)
	n_shower_partons = shower%get_nr_of_partons (only_colored = &
	.true., no_hard_prts = .true.)
	n_remnants = shower%get_nr_of_partons (only_colored = .false., &
	no_hard_prts = .true.)
	allocate (particles (n_hard + n_shower_partons + n_remnants))
	particles (1:n_hard) = pack (particle_set%prt, no_hadronic_remnants)
	end subroutine remove_hadronic_remnants_and_pack_in_particles

	@
	<<Shower core: shower combine with particle set: procedures>>=
	subroutine count_and_allocate ()
	allocate (hard_colored_mask (n_hard))
	hard_colored_mask = (particles%get_status () == PRT_INCOMING .or. &
	particles%get_status () == PRT_OUTGOING) .and. &
	particles%is_colored ()
	allocate (hard_colored_ids (count (hard_colored_mask)))
	hard_colored_ids = pack ([(i, i=1, size (particles))], hard_colored_mask)
	allocate (shower_partons_ids (n_shower_partons))
	shower_partons_ids = [(n_hard + n_remnants + i, i=1, n_shower_partons)]
	end subroutine count_and_allocate

	@
	<<Shower core: shower combine with particle set: procedures>>=
	subroutine set_hard_colored_as_virtual_parents_for_shower ()
	if (hard_colored_mask (i)) then
	call particles(i)%set_children (shower_partons_ids)
	if (particles(i)%get_status () == PRT_OUTGOING) then
	call particles(i)%set_status (PRT_VIRTUAL)
	end if
	end if
	end subroutine set_hard_colored_as_virtual_parents_for_shower

	@
	<<Shower core: shower combine with particle set: procedures>>=
	subroutine remove_hadronic_remnant_children_of_beam ()
	if (particles(i)%get_status () == PRT_BEAM .and. &
	n_remnants > 0) then
	children = particles(i)%get_children ()
	allocate (new_children (count &
	(.not. particle_set%prt(children)%is_hadronic_beam_remnant ())))
	new_children = pack (children, &
	.not. particle_set%prt(children)%is_hadronic_beam_remnant ())
	call particles(i)%set_children (new_children)
	deallocate (new_children)
	end if
	end subroutine remove_hadronic_remnant_children_of_beam

	@
	<<Shower core: shower combine with particle set: procedures>>=
	subroutine add_to_pset (offset, remnants)
	integer, intent(in) :: offset
	logical, intent(in) :: remnants
	integer :: i, j
	j = offset
	do i = 1, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	associate (prt => shower%partons(i)%p)
	if (.not. parton_is_final (prt) .or. &
	prt%belongstointeraction) cycle
	if (remnants) then
	if (prt%is_colored ()) cycle
	else
	if (.not. (prt%is_colored ())) cycle
	end if
	j = j + 1
	call find_model (model, prt%type, model_in, model_hadrons)
	particles (j) = prt%to_particle (model)
	if (remnants) then
	call particles(j)%set_parents ([prt%initial%nr])
	call particles(prt%initial%nr)%add_child (j)
	else
	call particles(j)%set_parents (hard_colored_ids)
	end if
	end associate
	end do
	end subroutine add_to_pset

	@
	<<Shower core: procedures>>=
	subroutine find_model (model, PDG, model_in, model_hadrons)
	class(model_data_t), pointer, intent(out) :: model
	integer, intent(in) :: PDG
	class(model_data_t), intent(in), target :: model_in
	class(model_data_t), intent(in), target :: model_hadrons
	character(len=5) :: buffer
	if (model_in%test_field (PDG)) then
	model => model_in
	else if (model_hadrons%test_field (PDG)) then
	model => model_hadrons
	else
	write (buffer, "(I5)") PDG
	call msg_fatal ("Parton " // buffer // &
	" found neither in given model file nor in SM_hadrons")
	end if
	end subroutine find_model

	@ %def find_model
	@
	<<Shower core: shower: TBP>>=
	procedure :: write_lhef => shower_write_lhef
	<<Shower core: procedures>>=
	subroutine shower_write_lhef (shower, unit)
	class(shower_t), intent(in) :: shower
	integer, intent(in), optional :: unit
	integer :: u
	integer :: i
	integer :: c1, c2
	u = given_output_unit (unit); if (u < 0) return
	write(u,'(A)') '<LesHouchesEvents version="1.0">'
	write(u,'(A)') '<-- not a complete lhe file - just one event -->'
	write(u,'(A)') '<event>'
	write(u, *) 2 + shower%get_nr_of_partons (), 1, 1.0, 1.0, 1.0, 1.0
	!!! write incoming partons
	do i = 1, 2
	if (abs (shower%partons(i)%p%type) < 1000) then
	c1 = 0
	c2 = 0
	if (shower%partons(i)%p%is_colored ()) then
	if (shower%partons(i)%p%c1 /= 0) c1 = 500 + shower%partons(i)%p%c1
	if (shower%partons(i)%p%c2 /= 0) c2 = 500 + shower%partons(i)%p%c2
	end if
	write(u,*) shower%partons(i)%p%type, -1, 0, 0, c1, c2, &
	shower%partons(i)%p%momentum%p(1), &
	shower%partons(i)%p%momentum%p(2), &
	shower%partons(i)%p%momentum%p(3), &
	shower%partons(i)%p%momentum%p(0), &
	shower%partons(i)%p%momentum**2, zero, 9.0
	else
	write(u,*) shower%partons(i)%p%type, -9, 0, 0, 0, 0, &
	shower%partons(i)%p%momentum%p(1), &
	shower%partons(i)%p%momentum%p(2), &
	shower%partons(i)%p%momentum%p(3), &
	shower%partons(i)%p%momentum%p(0), &
	shower%partons(i)%p%momentum**2, zero, 9.0
	end if
	end do
	!!! write outgoing partons
	do i = 3, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	if (.not. parton_is_final (shower%partons(i)%p)) cycle
	c1 = 0
	c2 = 0
	if (shower%partons(i)%p%is_colored ()) then
	if (shower%partons(i)%p%c1 .ne. 0) c1 = 500 + shower%partons(i)%p%c1
	if (shower%partons(i)%p%c2 .ne. 0) c2 = 500 + shower%partons(i)%p%c2
	end if
	write(u,*) shower%partons(i)%p%type, 1, 1, 2, c1, c2, &
	shower%partons(i)%p%momentum%p(1), &
	shower%partons(i)%p%momentum%p(2), &
	shower%partons(i)%p%momentum%p(3), &
	shower%partons(i)%p%momentum%p(0), &
	shower%partons(i)%p%momentum**2, zero, 9.0
	end do
	write(u,'(A)') '</event>'
	write(u,'(A)') '</LesHouchesEvents>'
	end subroutine shower_write_lhef

	@ %def shower_write_lhef

	@
	<<Shower core: procedures>>=
	subroutine shower_replace_parent_by_hadron (shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), intent(inout), target :: prt
	type(parton_t), pointer :: remnant => null()
	if (associated (prt%parent)) then
	call shower_remove_parton_from_partons (shower, prt%parent)
	deallocate (prt%parent)
	end if
	if (.not. associated (prt%initial%child2)) then
	call shower%add_child (prt%initial, 2)
	end if
	prt%parent => prt%initial
	prt%parent%child1 => prt
	! make other child to be a beam-remnant
	remnant => prt%initial%child2
	remnant%type = BEAM_REMNANT
	remnant%momentum = prt%parent%momentum - prt%momentum
	remnant%x = one - prt%x
	remnant%parent => prt%initial
	remnant%t = zero
	end subroutine shower_replace_parent_by_hadron

	@ %def shower_replace_parent_by_hadron
	@
	<<Shower core: procedures>>=
	subroutine shower_get_first_ISR_scale_for_parton (shower, prt, tmax)
	type(shower_t), intent(inout), target :: shower
	type(parton_t), intent(inout), target :: prt
	real(default), intent(in), optional :: tmax
	real(default) :: t, tstep, random, integral, temp1
	real(default) :: temprand
	if (present(tmax)) then
	t = max (max (-shower%tscalefactor_isr * prt%momentum%p(0)**2, &
	-abs(tmax)), prt%t)
	else
	t = max (-shower%tscalefactor_isr * prt%momentum%p(0)**2, prt%t)
	end if
	call shower%rng%generate (random)
	random = -twopi * log(random)
	!!! compare Integral and log(random) instead of random and exp(-Integral)
	random = random / shower%first_integral_suppression_factor
	integral = zero
	call prt%set_simulated (.false.)
	do
	call shower%rng%generate (temprand)
	tstep = max (abs (0.01_default * t) * temprand, 0.1_default * &
	shower%settings%d_min_t)
	if (t + 0.5_default * tstep > - shower%settings%d_min_t) then
	prt%t = prt%mass_squared ()
	call prt%set_simulated ()
	exit
	end if
	prt%t = t + 0.5_default * tstep
	temp1 = integral_over_z_simple (prt, (random - integral) / tstep)
	integral = integral + tstep * temp1
	if (integral > random) then
	prt%t = t + 0.5_default * tstep
	exit
	end if
	t = t + tstep
	end do
	if (prt%t > - shower%settings%d_min_t) then
	call shower_replace_parent_by_hadron (shower, prt)
	end if

	contains

	function integral_over_z_simple (prt, final) result (integral)
	type(parton_t), intent(inout) :: prt
	real(default), intent(in) :: final
	real(default) :: integral

	real(default), parameter :: zstepfactor = one
	real(default), parameter :: zstepmin = 0.0001_default
	real(default) :: z, zstep, minz, maxz
	real(default) :: pdfsum
	integer :: quark

	integral = zero
	if (D_PRINT) then
	print *, "D: integral_over_z_simple: t = ", prt%t
	end if
	minz = prt%x
	! maxz = maxzz(shat, s, shower%maxz_isr, shower%minenergy_timelike)
	maxz = shower%maxz_isr
	z = minz
	!!! TODO -> Adapt zstep to structure of divergencies
	if (parton_is_gluon (prt%child1)) then
	!!! gluon coming from g->gg
	do
	call shower%rng%generate (temprand)
	zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
	zstep = min(zstep, maxz - z)
	integral = integral + zstep * (D_alpha_s_isr ((one - &
	(z + 0.5_default * zstep)) * abs(prt%t), &
	shower%settings%d_min_t) / (abs(prt%t))) * &
	P_ggg (z + 0.5_default * zstep) * &
	shower%get_pdf (prt%initial%type, &
	prt%x / (z + 0.5_default * zstep), abs(prt%t), GLUON)
	if (integral > final) then
	exit
	end if
	z = z + zstep
	if (z >= maxz) then
	exit
	end if
	end do
	!!! gluon coming from q->qg ! correctly implemented yet?
	if (integral < final) then
	z = minz
	do
	call shower%rng%generate (temprand)
	zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
	zstep = min(zstep, maxz - z)
	pdfsum = zero
	do quark = -D_Nf, D_Nf
	if (quark == 0) cycle
	pdfsum = pdfsum + shower%get_pdf (prt%initial%type, &
	prt%x / (z + 0.5_default * zstep), abs(prt%t), quark)
	end do
	integral = integral + zstep * (D_alpha_s_isr &
	((z + 0.5_default * zstep) * abs(prt%t), &
	shower%settings%d_min_t) / (abs(prt%t))) * &
	P_qqg (one - (z + 0.5_default * zstep)) * pdfsum
	if (integral > final) then
	exit
	end if
	z = z + zstep
	if (z >= maxz) then
	exit
	end if
	end do
	end if
	else if (parton_is_quark (prt%child1)) then
	!!! quark coming from q->qg
	do
	call shower%rng%generate(temprand)
	zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
	zstep = min(zstep, maxz - z)
	integral = integral + zstep * (D_alpha_s_isr ((one - &
	(z + 0.5_default * zstep)) * abs(prt%t), &
	shower%settings%d_min_t) / (abs(prt%t))) * &
	P_qqg (z + 0.5_default * zstep) * &
	shower%get_pdf (prt%initial%type, &
	prt%x / (z + 0.5_default * zstep), abs(prt%t), prt%type)
	if (integral > final) then
	exit
	end if
	z = z + zstep
	if (z >= maxz) then
	exit
	end if
	end do
	!!! quark coming from g->qqbar
	if (integral < final) then
	z = minz
	do
	call shower%rng%generate (temprand)
	zstep = max(zstepmin, temprand * zstepfactor * z*(one - z))
	zstep = min(zstep, maxz - z)
	integral = integral + zstep * (D_alpha_s_isr &
	((one - (z + 0.5_default * zstep)) * abs(prt%t), &
	shower%settings%d_min_t) / (abs(prt%t))) * &
	P_gqq (z + 0.5_default * zstep) * &
	shower%get_pdf (prt%initial%type, &
	prt%x / (z + 0.5_default * zstep), abs(prt%t), GLUON)
	if (integral > final) then
	exit
	end if
	z = z + zstep
	if (z >= maxz) then
	exit
	end if
	end do
	end if

	end if
	integral = integral / shower%get_pdf (prt%initial%type, prt%x, &
	abs(prt%t), prt%type)
	end function integral_over_z_simple

	end subroutine shower_get_first_ISR_scale_for_parton

	@ %def shower_get_first_ISR_scale_for_parton
	@
	<<Shower core: procedures>>=
	subroutine shower_prepare_for_simulate_isr_pt (shower, interaction)
	type(shower_t), intent(inout) :: shower
	type(shower_interaction_t), intent(inout) :: interaction
	real(default) :: s
	s = (interaction%partons(1)%p%momentum + &
	interaction%partons(2)%p%momentum)**2
	interaction%partons(1)%p%scale = shower%tscalefactor_isr * 0.25_default * s
	interaction%partons(2)%p%scale = shower%tscalefactor_isr * 0.25_default * s
	end subroutine shower_prepare_for_simulate_isr_pt

	@ %def shower_prepare_for_simulate_isr_pt
	@
	<<Shower core: procedures>>=
	subroutine shower_prepare_for_simulate_isr_ana_test (shower, prt1, prt2)
	type(shower_t), intent(inout) :: shower
	type(parton_t), intent(inout), target :: prt1, prt2
	type(parton_t), pointer :: prt, prta, prtb
	real(default) :: scale, factor, E
	integer :: i
	if (.not. associated (prt1%initial) .or. .not. associated (prt2%initial)) then
	return
	end if
	scale = - (prt1%momentum + prt2%momentum) ** 2
	call prt1%set_simulated ()
	call prt2%set_simulated ()
	call shower%add_parent (prt1)
	call shower%add_parent (prt2)
	factor = sqrt (energy (prt1%momentum)**2 - scale) / &
	space_part_norm(prt1%momentum)
	prt1%parent%type = prt1%type
	prt1%parent%z = one
	prt1%parent%momentum = prt1%momentum
	prt1%parent%t = scale
	prt1%parent%x = prt1%x
	prt1%parent%initial => prt1%initial
	prt1%parent%belongstoFSR = .false.
	prt1%parent%c1 = prt1%c1
	prt1%parent%c2 = prt1%c2

	prt2%parent%type= prt2%type
	prt2%parent%z = one
	prt2%parent%momentum = prt2%momentum
	prt2%parent%t = scale
	prt2%parent%x = prt2%x
	prt2%parent%initial => prt2%initial
	prt2%parent%belongstoFSR = .false.
	prt2%parent%c1 = prt2%c1
	prt2%parent%c2 = prt2%c2

	do
	call shower_get_first_ISR_scale_for_parton (shower, prt1%parent)
	call shower_get_first_ISR_scale_for_parton (shower, prt2%parent)

	!!! redistribute energy among first partons
	prta => prt1%parent
	prtb => prt2%parent

	E = energy (prt1%momentum + prt2%momentum)
	prta%momentum%p(0) = (E*2 - prtb%t + prta%t) / (two E)
	prtb%momentum%p(0) = E - prta%momentum%p(0)

	exit
	end do

	call prt1%parent%set_simulated ()
	call prt2%parent%set_simulated ()
	!!! rescale momenta
	do i = 1, 2
	if (i == 1) then
	prt => prt1%parent
	else
	prt => prt2%parent
	end if
	factor = sqrt (energy (prt%momentum)**2 - prt%t) &
	/ space_part_norm (prt%momentum)
	prt%momentum = vector4_moving (energy (prt%momentum), &
	factor * space_part (prt%momentum))
	end do

	if (prt1%parent%t < zero) then
	call shower%add_parent (prt1%parent)
	prt1%parent%parent%momentum = prt1%parent%momentum
	prt1%parent%parent%t = prt1%parent%t
	prt1%parent%parent%x = prt1%parent%x
	prt1%parent%parent%initial => prt1%parent%initial
	prt1%parent%parent%belongstoFSR = .false.
	call shower%add_child (prt1%parent%parent, 2)
	end if

	if (prt2%parent%t < zero) then
	call shower%add_parent (prt2%parent)
	prt2%parent%parent%momentum = prt2%parent%momentum
	prt2%parent%parent%t = prt2%parent%t
	prt2%parent%parent%x = prt2%parent%x
	prt2%parent%parent%initial => prt2%parent%initial
	prt2%parent%parent%belongstoFSR = .false.
	call shower%add_child (prt2%parent%parent, 2)
	end if

	end subroutine shower_prepare_for_simulate_isr_ana_test

	@ %def shower_prepare_for_simulate_isr_ana_test
	@
	<<Shower core: procedures>>=
	subroutine shower_add_children_of_emitted_timelike_parton (shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), pointer :: prt

	if (prt%t > prt%mass_squared () + shower%settings%d_min_t) then
	if (parton_is_quark (prt)) then
	!!! q -> qg
	call shower%add_child (prt, 1)
	prt%child1%type = prt%type
	prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
	prt%child1%t = prt%t
	call shower%add_child (prt, 2)
	prt%child2%type = GLUON
	prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
	prt%child2%t = prt%t
	else
	if (int (prt%x) > 0) then
	call shower%add_child (prt, 1)
	prt%child1%type = int (prt%x)
	prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
	prt%child1%t = prt%t
	call shower%add_child (prt, 2)
	prt%child2%type = -int (prt%x)
	prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
	prt%child2%t= prt%t
	else
	call shower%add_child (prt, 1)
	prt%child1%type = GLUON
	prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
	prt%child1%t = prt%t
	call shower%add_child (prt, 2)
	prt%child2%type = GLUON
	prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
	prt%child2%t = prt%t
	end if
	end if
	end if
	end subroutine shower_add_children_of_emitted_timelike_parton

	@ %def shower_add_children_of_emitted_timelike_parton
	@
	<<Shower core: procedures>>=
	subroutine shower_simulate_children_ana (shower,prt)
	type(shower_t), intent(inout), target :: shower
	type(parton_t), intent(inout) :: prt
	real(default), dimension(1:2) :: t, random, integral
	integer, dimension(1:2) :: gtoqq
	integer :: daughter
	type(parton_t), pointer :: daughterprt
	integer :: n_loop

	if (signal_is_pending ()) return
	gtoqq = 0

	if (D_PRINT) print *, "D: shower_simulate_children_ana: for parton " , prt%nr

	if (.not. associated (prt%child1) .or. .not. associated (prt%child2)) then
	call msg_error ("Shower: error in simulate_children_ana: no children.")
	return
	end if

	<<Set beam-remnants and internal partons as simulated>>

	integral = zero

	!!! impose constraints by angular ordering -> cf. (26) of Gaining analytic control
	!!! check if no branchings are possible
	if (.not. prt%child1%simulated) then
	prt%child1%t = min (prt%child1%t, &
	0.5_default * prt%child1%momentum%p(0)*2 (one - &
	prt%get_costheta ()))
	if (.not. associated (prt%child1%settings)) &
	prt%child1%settings => shower%settings
	if (min (prt%child1%t, prt%child1%momentum%p(0)**2) < &
	prt%child1%mass_squared () + &
	prt%child1%settings%d_min_t) then
	prt%child1%t = prt%child1%mass_squared ()
	call prt%child1%set_simulated ()
	end if
	end if
	if (.not. prt%child2%simulated) then
	prt%child2%t = min (prt%child2%t, &
	0.5_default * prt%child2%momentum%p(0)*2 (one - &
	prt%get_costheta ()))
	if (.not. associated (prt%child2%settings)) &
	prt%child2%settings => shower%settings
	if (min (prt%child2%t, prt%child2%momentum%p(0)**2) < &
	prt%child2%mass_squared () + &
	prt%child2%settings%d_min_t) then
	prt%child2%t = prt%child2%mass_squared ()
	call prt%child2%set_simulated ()
	end if
	end if

	call shower%rng%generate (random)

	n_loop = 0
	do
	if (signal_is_pending ()) return
	n_loop = n_loop + 1
	if (n_loop > 900) then
	!!! try with massless quarks
	treat_duscb_quarks_massless = .true.
	end if
	if (n_loop > 1000) then
	call shower%write ()
	call msg_message (" simulate_children_ana failed for parton ", prt%nr)
	call msg_error ("BUG: too many loops in simulate_children_ana (?)")
	shower%valid = .false.
	return
	end if

	t(1) = prt%child1%t
	t(2) = prt%child2%t

	!!! check if a branching in the range t(i) to t(i) - tstep(i) occurs

	!!! check for child1
	if (.not. prt%child1%simulated) then
	call parton_simulate_stept &
	(prt%child1, shower%rng, integral(1), random(1), gtoqq(1))
	end if
	!!! check for child2
	if (.not. prt%child2%simulated) then
	call parton_simulate_stept &
	(prt%child2, shower%rng, integral(2), random(2), gtoqq(2))
	end if

	if (prt%child1%simulated .and. &
	prt%child2%simulated) then
	if (sqrt (prt%t) <= sqrt (prt%child1%t) + sqrt (prt%child2%t)) then
	<<Repeat the simulation for the parton with the lower virtuality>>
	else
	exit
	end if
	end if
	end do

	call parton_apply_costheta (prt, shower%rng)

	<<Add children>>
	call shower_parton_update_color_connections (shower, prt)
	end subroutine shower_simulate_children_ana

	@ %def shower_simulate_children_ana
	@
	<<Set beam-remnants and internal partons as simulated>>=
	if (HADRON_REMNANT <= abs (prt%type) .and. abs (prt%type) <= HADRON_REMNANT_OCTET) then
	!!! prt is beam-remnant
	call prt%set_simulated ()
	return
	end if

	!!! check if partons are "internal" -> fixed scale
	if (prt%child1%type == INTERNAL) then
	call prt%child1%set_simulated ()
	end if
	if (prt%child2%type == INTERNAL) then
	call prt%child2%set_simulated ()
	end if
	@
	<<Repeat the simulation for the parton with the lower virtuality>>=
	!!! virtuality : t - m**2 (assuming it's not fixed)
	if (prt%child1%type == INTERNAL .and. prt%child2%type == INTERNAL) then
	call msg_fatal &
	("Shower: both partons fixed, but momentum not conserved")
	else if (prt%child1%type == INTERNAL) then
	!!! reset child2
	call prt%child2%set_simulated (.false.)
	prt%child2%t = min (prt%child1%t, (sqrt (prt%t) - &
	sqrt (prt%child1%t))**2)
	integral(2) = zero
	call shower%rng%generate (random(2))
	else if (prt%child2%type == INTERNAL) then
	! reset child1
	call prt%child1%set_simulated (.false.)
	prt%child1%t = min (prt%child2%t, (sqrt (prt%t) - &
	sqrt (prt%child2%t))**2)
	integral(1) = zero
	call shower%rng%generate (random(1))
	else if (prt%child1%t - prt%child1%mass_squared () > &
	prt%child2%t - prt%child2%mass_squared ()) then
	!!! reset child2
	call prt%child2%set_simulated (.false.)
	prt%child2%t = min (prt%child1%t, (sqrt (prt%t) - &
	sqrt (prt%child1%t))**2)
	integral(2) = zero
	call shower%rng%generate (random(2))
	else
	!!! reset child1 ! TODO choose child according to their t
	call prt%child1%set_simulated (.false.)
	prt%child1%t = min (prt%child2%t, (sqrt (prt%t) - &
	sqrt (prt%child2%t))**2)
	integral(1) = zero
	call shower%rng%generate (random(1))
	end if
	@
	<<Add children>>=
	if (.not. associated (prt%child1%settings)) &
	prt%child1%settings => shower%settings
	if (.not. associated (prt%child2%settings)) &
	prt%child2%settings => shower%settings
	do daughter = 1, 2
	if (signal_is_pending ()) return
	if (daughter == 1) then
	daughterprt => prt%child1
	else
	daughterprt => prt%child2
	end if
	if (daughterprt%t < daughterprt%mass_squared () + &
	daughterprt%settings%d_min_t) then
	cycle
	end if
	if (.not. (parton_is_quark (daughterprt) .or. &
	parton_is_gluon (daughterprt))) then
	cycle
	end if
	if (parton_is_quark (daughterprt)) then
	!!! q -> qg
	call shower%add_child (daughterprt, 1)
	daughterprt%child1%type = daughterprt%type
	daughterprt%child1%momentum%p(0) = daughterprt%z * &
	daughterprt%momentum%p(0)
	daughterprt%child1%t = daughterprt%t
	call shower%add_child (daughterprt, 2)
	daughterprt%child2%type = GLUON
	daughterprt%child2%momentum%p(0) = (one - daughterprt%z) * &
	daughterprt%momentum%p(0)
	daughterprt%child2%t = daughterprt%t
	else if (parton_is_gluon (daughterprt)) then
	if (gtoqq(daughter) > 0) then
	call shower%add_child (daughterprt, 1)
	daughterprt%child1%type = gtoqq (daughter)
	daughterprt%child1%momentum%p(0) = &
	daughterprt%z * daughterprt%momentum%p(0)
	daughterprt%child1%t = daughterprt%t
	call shower%add_child (daughterprt, 2)
	daughterprt%child2%type = - gtoqq (daughter)
	daughterprt%child2%momentum%p(0) = (one - &
	daughterprt%z) * daughterprt%momentum%p(0)
	daughterprt%child2%t = daughterprt%t
	else
	call shower%add_child (daughterprt, 1)
	daughterprt%child1%type = GLUON
	daughterprt%child1%momentum%p(0) = &
	daughterprt%z * daughterprt%momentum%p(0)
	daughterprt%child1%t = daughterprt%t
	call shower%add_child (daughterprt, 2)
	daughterprt%child2%type = GLUON
	daughterprt%child2%momentum%p(0) = (one - &
	daughterprt%z) * daughterprt%momentum%p(0)
	daughterprt%child2%t = daughterprt%t
	end if
	end if
	end do
	@
	@ The recoiler is [[otherprt]]. Instead of the random number and the
	exponential of the integral, we compare the logarithm of the random
	number and the integral.
	<<Shower core: procedures>>=
	subroutine shower_isr_step_pt (shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), target, intent(inout) :: prt
	type(parton_t), pointer :: otherprt

	real(default) :: scale, scalestep
	real(default) :: integral, random, factor
	real(default) :: temprand1, temprand2

	otherprt => shower_find_recoiler (shower, prt)

	scale = prt%scale
	call shower%rng%generate (temprand1)
	call shower%rng%generate (temprand2)
	scalestep = max (abs (scalefactor1 * scale) * temprand1, &
	scalefactor2 * temprand2 * D_Min_scale)
	call shower%rng%generate (random)
	random = - twopi * log(random)
	integral = zero

	if (scale - 0.5_default * scalestep < D_Min_scale) then
	!!! close enough to cut-off scale -> ignore
	prt%scale = zero
	prt%t = prt%mass_squared ()
	call prt%set_simulated ()
	else
	prt%scale = scale - 0.5_default * scalestep
	factor = scalestep * (D_alpha_s_isr (prt%scale, &
	shower%settings%d_min_t) / (prt%scale * &
	shower%get_pdf (prt%initial%type, prt%x, prt%scale, prt%type)))
	integral = integral + factor * integral_over_z_isr_pt &
	(prt, otherprt, (random - integral) / factor)
	if (integral > random) then
	!!! prt%scale set above and prt%z set in integral_over_z_isr_pt
	call prt%set_simulated ()
	prt%t = - prt%scale / (one - prt%z)
	else
	prt%scale = scale - scalestep
	end if
	end if

	contains

	function integral_over_z_isr_pt (prt, otherprt, final) &
	result (integral)
	type(parton_t), intent(inout) :: prt, otherprt
	real(default), intent(in) :: final
	real(default) :: integral
	real(default) :: mbr, r
	real(default) :: zmin, zmax, z, zstep
	integer :: n_bin
	integer, parameter :: n_total_bins = 100
	real(default) :: quarkpdfsum
	real(default) :: temprand
	integer :: quark

	quarkpdfsum = zero
	if (D_PRINT) then
	print *, "D: integral_over_z_isr_pt: for scale = ", prt%scale
	end if

	integral = zero
	mbr = (prt%momentum + otherprt%momentum)**1
	zmin = prt%x
	zmax = min (one - (sqrt (prt%scale) / mbr) * &
	(sqrt(one + 0.25_default * prt%scale / mbr**2) - &
	0.25_default * sqrt(prt%scale) / mbr), shower%maxz_isr)
	zstep = (zmax - zmin) / n_total_bins

	if (ASSERT) then
	if (zmin > zmax) then
	call msg_bug(" error in integral_over_z_isr_pt: zmin > zmax ")
	integral = zero
	end if
	end if

	!!! divide the range [zmin:zmax] in n_total_bins
	BINS: do n_bin = 1, n_total_bins
	z = zmin + zstep * (n_bin - 0.5_default)
	!!! z-value in the middle of the bin

	if (parton_is_gluon (prt)) then
	QUARKS: do quark = -D_Nf, D_Nf
	if (quark == 0) cycle quarks
	quarkpdfsum = quarkpdfsum + shower%get_pdf &
	(prt%initial%type, prt%x / z, prt%scale, quark)
	end do QUARKS
	!!! g -> gg or q -> gq
	integral = integral + (zstep / z) * ((P_ggg (z) + &
	P_ggg (one - z)) * shower%get_pdf (prt%initial%type, &
	prt%x / z, prt%scale, GLUON) + P_qqg (one - z) * quarkpdfsum)
	else if (parton_is_quark (prt)) then
	!!! q -> qg or g -> qq
	integral = integral + (zstep / z) * ( P_qqg (z) * &
	shower%get_pdf (prt%initial%type, prt%x / z, prt%scale, prt%type) + &
	P_gqq(z) * shower%get_pdf (prt%initial%type, prt%x / z, prt%scale, GLUON))
	else
	! call msg_fatal ("Bug neither quark nor gluon in" &
	! // " integral_over_z_isr_pt")
	end if
	if (integral > final) then
	prt%z = z
	call shower%rng%generate (temprand)
	!!! decide type of father partons
	if (parton_is_gluon (prt)) then
	if (temprand > (P_qqg (one - z) * quarkpdfsum) / &
	((P_ggg (z) + P_ggg (one - z)) * shower%get_pdf &
	(prt%initial%type, prt%x / z, prt%scale, GLUON) &
	+ P_qqg (one - z) * quarkpdfsum)) then
	!!! gluon => gluon + gluon
	prt%aux_pt = GLUON
	else
	!!! quark => quark + gluon
	!!! decide which quark flavor the parent is
	r = temprand * quarkpdfsum
	WHICH_QUARK: do quark = -D_Nf, D_Nf
	if (quark == 0) cycle WHICH_QUARK
	if (r > quarkpdfsum - shower%get_pdf (prt%initial%type, &
	prt%x / z, prt%scale, quark)) then
	prt%aux_pt = quark
	exit WHICH_QUARK
	else
	quarkpdfsum = quarkpdfsum - shower%get_pdf &
	(prt%initial%type, prt%x / z, prt%scale, quark)
	end if
	end do WHICH_QUARK
	end if

	else if (parton_is_quark (prt)) then
	if (temprand > (P_qqg (z) * shower%get_pdf (prt%initial%type, &
	prt%x / z, prt%scale, prt%type)) / &
	(P_qqg (z) * shower%get_pdf (prt%initial%type, prt%x / z, &
	prt%scale, prt%type) + &
	P_gqq (z) * shower%get_pdf (prt%initial%type, prt%x / z, &
	prt%scale, GLUON))) then
	!!! gluon => quark + antiquark
	prt%aux_pt = GLUON
	else
	!!! quark => quark + gluon
	prt%aux_pt = prt%type
	end if
	end if
	exit BINS
	end if
	end do BINS
	end function integral_over_z_isr_pt
	end subroutine shower_isr_step_pt

	@ %def shower_isr_step_pt
	@ This function returns a pointer to the parton with the next ISR
	branching, while FSR branchings are ignored.
	<<Shower core: shower: TBP>>=
	procedure :: generate_next_isr_branching_veto => &
	shower_generate_next_isr_branching_veto
	<<Shower core: procedures>>=
	function shower_generate_next_isr_branching_veto &
	(shower) result (next_brancher)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t) :: next_brancher
	integer :: i
	type(parton_t), pointer :: prt
	real(default) :: random
	!!! pointers to branchable partons
	type(parton_pointer_t), dimension(:), allocatable :: partons
	integer :: n_partons
	real(default) :: weight
	real(default) :: temp1, temp2, temp3, E3

	if (signal_is_pending ()) return

	if (isr_pt_ordered) then
	next_brancher = shower%generate_next_isr_branching ()
	return
	end if
	next_brancher%p => null()
	!!! branchable partons
	n_partons = 0
	do i = 1,size (shower%partons)
	prt => shower%partons(i)%p
	if (signal_is_pending ()) return
	if (.not. associated (prt)) cycle
	if (prt%belongstoFSR) cycle
	if (parton_is_final (prt)) cycle
	if (.not. prt%belongstoFSR .and. prt%simulated) cycle
	n_partons = n_partons + 1
	end do
	if (n_partons == 0) then
	return
	end if
	allocate (partons(1:n_partons))
	n_partons = 1
	do i = 1, size (shower%partons)
	prt => shower%partons(i)%p
	if (.not. associated (prt)) cycle
	if (prt%belongstoFSR) cycle
	if (parton_is_final (prt)) cycle
	if (.not. prt%belongstoFSR .and. prt%simulated) cycle
	if (signal_is_pending ()) return
	partons(n_partons)%p => shower%partons(i)%p
	n_partons = n_partons + 1
	end do
	!!! generate initial trial scales
	do i = 1, size (partons)
	if (signal_is_pending ()) return
	call generate_next_trial_scale (partons(i)%p)
	end do

	do
	!!! search for parton with the highest trial scale
	prt => partons(1)%p
	do i = 1, size (partons)
	if (prt%t >= zero) cycle
	if (abs (partons(i)%p%t) > abs (prt%t)) then
	prt => partons(i)%p
	end if
	end do

	if (prt%t >= zero) then
	next_brancher%p => null()
	exit
	end if
	!!! generate trial z and type of mother prt
	call generate_trial_z_and_typ (prt)

	!!! weight with pdf and alpha_s
	temp1 = (D_alpha_s_isr ((one - prt%z) * abs(prt%t), &
	shower%settings%d_min_t) / sqrt (alphasxpdfmax))
	temp2 = shower%get_xpdf (prt%initial%type, prt%x, prt%t, &
	prt%type) / sqrt (alphasxpdfmax)
	temp3 = shower%get_xpdf (prt%initial%type, prt%child1%x, prt%child1%t, &
	prt%child1%type) / &
	shower%get_xpdf (prt%initial%type, prt%child1%x, prt%t, prt%child1%type)
	! TODO: (bcn 2015-02-19) ???
	if (temp1 * temp2 * temp3 > one) then
	print *, "weights:", temp1, temp2, temp3
	end if
	weight = (D_alpha_s_isr ((one - prt%z) * abs(prt%t), &
	shower%settings%d_min_t)) * &
	shower%get_xpdf (prt%initial%type, prt%x, prt%t, prt%type) * &
	shower%get_xpdf (prt%initial%type, prt%child1%x, prt%child1%t, &
	prt%child1%type) / &
	shower%get_xpdf &
	(prt%initial%type, prt%child1%x, prt%t, prt%child1%type)
	if (weight > alphasxpdfmax) then
	print *, "Setting alphasxpdfmax from ", alphasxpdfmax, " to ", weight
	alphasxpdfmax = weight
	end if
	weight = weight / alphasxpdfmax
	call shower%rng%generate (random)
	if (weight < random) then
	!!! discard branching
	call generate_next_trial_scale (prt)
	cycle
	end if
	!!! branching accepted so far
	!!! generate emitted parton
	prt%child2%t = abs(prt%t)
	prt%child2%momentum%p(0) = sqrt (abs(prt%t))
	if (shower%isr_only_onshell_emitted_partons) then
	prt%child2%t = prt%child2%mass_squared ()
	else
	call parton_next_t_ana (prt%child2, shower%rng)
	end if

	if (thetabar (prt, shower_find_recoiler (shower, prt), &
	shower%isr_angular_ordered, E3)) then
	prt%momentum%p(0) = E3
	prt%child2%momentum%p(0) = E3 - prt%child1%momentum%p(0)

	!!! found branching
	call parton_generate_ps_ini (prt, shower%rng)
	next_brancher%p => prt
	call prt%set_simulated ()
	exit
	else
	call generate_next_trial_scale (prt)
	cycle
	end if
	end do
	if (.not. associated (next_brancher%p)) then
	!!! no further branching found -> all partons emitted by hadron
	print *, "--all partons emitted by hadrons---"
	do i = 1, size(partons)
	call shower_replace_parent_by_hadron (shower, partons(i)%p%child1)
	end do
	end if
	!!! some bookkeeping
	call shower%sort_partons ()
	! call shower_boost_to_CMframe(shower) ! really necessary?
	! call shower_rotate_to_z(shower) ! really necessary?
	contains

	subroutine generate_next_trial_scale(prt)
	type(parton_t), pointer, intent(inout) :: prt
	real(default) :: random, F
	real(default) :: zmax = 0.99_default !! ??
	call shower%rng%generate (random)
	F = one !!! TODO
	F = alphasxpdfmax / (two * pi)
	if (parton_is_quark (prt%child1)) then
	F = F * (integral_over_P_gqq (prt%child1%x, zmax) + &
	integral_over_P_qqg (prt%child1%x, zmax))
	else if (parton_is_gluon (prt%child1)) then
	F = F * (integral_over_P_ggg (prt%child1%x, zmax) + &
	two * D_Nf * &
	integral_over_P_qqg (one - zmax, one - prt%child1%x))
	else
	call msg_bug("neither quark nor gluon in generate_next_trial_scale")
	end if
	F = F / shower%get_xpdf (prt%child1%initial%type, prt%child1%x, &
	prt%child1%t, prt%child1%type)
	prt%t = prt%t * random**(one / F)
	if (abs (prt%t) - prt%mass_squared () < &
	prt%settings%d_min_t) then
	prt%t = prt%mass_squared ()
	end if
	end subroutine generate_next_trial_scale

	subroutine generate_trial_z_and_typ(prt)
	type(parton_t), pointer, intent(inout) :: prt
	real(default) :: random
	real(default) :: z, zstep, zmin, integral
	real(default) :: zmax = 0.99_default !! ??
	if (D_PRINT) print *, "D: generate generate_trial_z_and_typ"
	call shower%rng%generate (random)
	integral = zero
	!!! decide which branching a->bc occurs
	if (parton_is_quark (prt%child1)) then
	if (random < integral_over_P_qqg (prt%child1%x, zmax) / &
	(integral_over_P_qqg (prt%child1%x, zmax) + &
	integral_over_P_gqq(prt%child1%x, zmax))) then
	prt%type = prt%child1%type
	prt%child2%type = GLUON
	integral = integral_over_P_qqg (prt%child1%x, zmax)
	else
	prt%type = GLUON
	prt%child2%type = - prt%child1%type
	integral = integral_over_P_gqq (prt%child1%x, zmax)
	end if
	else if (parton_is_gluon (prt%child1)) then
	if (random < integral_over_P_ggg (prt%child1%x, zmax) / &
	(integral_over_P_ggg (prt%child1%x, zmax) + two * D_Nf * &
	integral_over_P_qqg (one - zmax, &
	one - prt%child1%x))) then
	prt%type = GLUON
	prt%child2%type = GLUON
	integral = integral_over_P_ggg (prt%child1%x, zmax)
	else
	call shower%rng%generate (random)
	prt%type = 1 + floor(random * D_Nf)
	call shower%rng%generate (random)
	if (random > 0.5_default) prt%type = - prt%type
	prt%child2%type = prt%type
	integral = integral_over_P_qqg (one - zmax, &
	one - prt%child1%x)
	end if
	else
	call msg_bug("neither quark nor gluon in generate_next_trial_scale")
	end if
	!!! generate the z-value
	!!! z between prt%child1%x and zmax
	! prt%z = one - random * (one - prt%child1%x) ! TODO

	call shower%rng%generate (random)
	zmin = prt%child1%x
	zstep = max(0.1_default, 0.5_default * (zmax - zmin))
	z = zmin
	if (zmin > zmax) then
	print *, " zmin = ", zmin, " zmax = ", zmax
	call msg_fatal ("Shower: zmin greater than zmax")
	end if
	!!! procedure pointers would be helpful here
	if (parton_is_quark (prt) .and. parton_is_quark (prt%child1)) then
	do
	zstep = min(zstep, 0.5_default * (zmax - z))
	if (abs(zstep) < 0.00001) exit
	if (integral_over_P_qqg (zmin, z) < random * integral) then
	if (integral_over_P_qqg (zmin, min(z + zstep, zmax)) &
	< random * integral) then
	z = min (z + zstep, zmax)
	cycle
	else
	zstep = zstep * 0.5_default
	cycle
	end if
	end if
	end do
	else if (parton_is_quark (prt) .and. parton_is_gluon (prt%child1)) then
	do
	zstep = min(zstep, 0.5_default * (zmax - z))
	if (abs(zstep) < 0.00001) exit
	if (integral_over_P_qqg (zmin, z) < random * integral) then
	if (integral_over_P_qqg (zmin, min(z + zstep, zmax)) &
	< random * integral) then
	z = min(z + zstep, zmax)
	cycle
	else
	zstep = zstep * 0.5_default
	cycle
	end if
	end if
	end do
	else if (parton_is_gluon (prt) .and. parton_is_quark (prt%child1)) then
	do
	zstep = min(zstep, 0.5_default * (zmax - z))
	if (abs (zstep) < 0.00001) exit
	if (integral_over_P_gqq (zmin, z) < random * integral) then
	if (integral_over_P_gqq (zmin, min(z + zstep, zmax)) &
	< random * integral) then
	z = min (z + zstep, zmax)
	cycle
	else
	zstep = zstep * 0.5_default
	cycle
	end if
	end if
	end do
	else if (parton_is_gluon (prt) .and. parton_is_gluon (prt%child1)) then
	do
	zstep = min(zstep, 0.5_default * (zmax - z))
	if (abs (zstep) < 0.00001) exit
	if (integral_over_P_ggg(zmin, z) < random * integral) then
	if (integral_over_P_ggg (zmin, min(z + zstep, zmax)) &
	< random * integral) then
	z = min(z + zstep, zmax)
	cycle
	else
	zstep = zstep * 0.5_default
	cycle
	end if
	end if
	end do
	else
	end if
	prt%z = z
	prt%x = prt%child1%x / prt%z
	end subroutine generate_trial_z_and_typ
	end function shower_generate_next_isr_branching_veto

	@ %def shower_generate_next_isr_branching_veto
	@
	<<Shower core: procedures>>=
	function shower_find_recoiler (shower, prt) result(recoiler)
	type(shower_t), intent(inout) :: shower
	type(parton_t), intent(inout), target :: prt
	type(parton_t), pointer :: recoiler
	type(parton_t), pointer :: otherprt1, otherprt2
	integer :: n_int
	otherprt1 => null()
	otherprt2 => null()
	DO_INTERACTIONS: do n_int = 1, size(shower%interactions)
	otherprt1=>shower%interactions(n_int)%i%partons(1)%p
	otherprt2=>shower%interactions(n_int)%i%partons(2)%p
	PARTON1: do
	if (associated (otherprt1%parent)) then
	if (.not. parton_is_proton (otherprt1%parent) .and. &
	otherprt1%parent%simulated) then
	otherprt1 => otherprt1%parent
	if (associated (otherprt1, prt)) then
	exit PARTON1
	end if
	else
	exit PARTON1
	end if
	else
	exit PARTON1
	end if
	end do PARTON1
	PARTON2: do
	if (associated (otherprt2%parent)) then
	if (.not. parton_is_proton (otherprt2%parent) .and. &
	otherprt2%parent%simulated) then
	otherprt2 => otherprt2%parent
	if (associated (otherprt2, prt)) then
	exit PARTON2
	end if
	else
	exit PARTON2
	end if
	else
	exit PARTON2
	end if
	end do PARTON2

	if (associated (otherprt1, prt) .or. associated (otherprt2, prt)) then
	exit DO_INTERACTIONS
	end if
	if (associated (otherprt1%parent, prt) .or. &
	associated (otherprt2%parent, prt)) then
	exit DO_INTERACTIONS
	end if
	end do DO_INTERACTIONS

	recoiler => null()
	if (associated (otherprt1%parent, prt)) then
	recoiler => otherprt2
	else if (associated (otherprt2%parent, prt)) then
	recoiler => otherprt1
	else if (associated (otherprt1, prt)) then
	recoiler => otherprt2
	else if (associated (otherprt2, prt)) then
	recoiler => otherprt1
	else
	call shower%write ()
	call parton_write (prt)
	call msg_error ("Shower: no otherparton found")
	end if
	end function shower_find_recoiler

	@ %def shower_find_recoiler
	@
	<<Shower core: procedures>>=
	subroutine shower_isr_step (shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), target, intent(inout) :: prt
	type(parton_t), pointer :: otherprt => null()
	real(default) :: t, tstep
	real(default) :: integral, random
	real(default) :: temprand1, temprand2
	otherprt => shower_find_recoiler(shower, prt)
	! if (.not. otherprt%child1%belongstointeraction) then
	! otherprt => otherprt%child1
	! end if

	if (signal_is_pending ()) return
	t = max(prt%t, prt%child1%t)
	call shower%rng%generate (random)
	! compare Integral and log(random) instead of random and exp(-Integral)
	random = - twopi * log(random)
	integral = zero
	call shower%rng%generate (temprand1)
	call shower%rng%generate (temprand2)
	tstep = max (abs (0.02_default * t) * temprand1, &
	0.02_default * temprand2 * shower%settings%d_min_t)
	if (t + 0.5_default * tstep > - shower%settings%d_min_t) then
	prt%t = prt%mass_squared ()
	call prt%set_simulated ()
	else
	prt%t = t + 0.5_default * tstep
	integral = integral + tstep * &
	integral_over_z_isr (prt, otherprt,(random - integral) / tstep)
	if (integral > random) then
	prt%t = t + 0.5_default * tstep
	prt%x = prt%child1%x / prt%z
	call prt%set_simulated ()
	else
	prt%t = t + tstep
	end if
	end if

	contains

	function integral_over_z_isr (prt, otherprt, final) result (integral)
	type(parton_t), intent(inout) :: prt, otherprt
	real(default), intent(in) :: final
	real(default) integral
	real(default) :: minz, maxz, z, shat,s
	integer :: quark

	!!! calculate shat -> s of parton-parton system
	shat= (otherprt%momentum + prt%child1%momentum)**2
	!!! calculate s -> s of hadron-hadron system
	s= (otherprt%initial%momentum + prt%initial%momentum)**2
	integral = zero
	minz = prt%child1%x
	maxz = maxzz (shat, s, shower%maxz_isr, shower%minenergy_timelike)

	!!! for gluon
	if (parton_is_gluon (prt%child1)) then
	!!! 1: g->gg
	prt%type = GLUON
	prt%child2%type = GLUON
	z = minz
	prt%child2%t = abs(prt%t)
	call integral_over_z_part_isr &
	(prt, otherprt, shat, minz, maxz, integral, final)
	if (integral > final) then
	return
	end if
	!!! 2: q->gq
	do quark = -D_Nf, D_Nf
	if (quark == 0) cycle
	prt%type = quark
	prt%child2%type = quark
	z = minz
	prt%child2%t = abs(prt%t)
	call integral_over_z_part_isr &
	(prt, otherprt, shat, minz, maxz, integral, final)
	if (integral > final) then
	return
	end if
	end do
	else if (parton_is_quark (prt%child1)) then
	!!! 1: q->qg
	prt%type = prt%child1%type
	prt%child2%type = GLUON
	z = minz
	prt%child2%t = abs(prt%t)
	call integral_over_z_part_isr &
	(prt,otherprt, shat, minz, maxz, integral, final)
	if (integral > final) then
	return
	end if
	!!! 2: g->qqbar
	prt%type = GLUON
	prt%child2%type = -prt%child1%type
	z = minz
	prt%child2%t = abs(prt%t)
	call integral_over_z_part_isr &
	(prt,otherprt, shat, minz, maxz, integral, final)
	if (integral > final) then
	return
	end if
	end if
	end function integral_over_z_isr

	subroutine integral_over_z_part_isr &
	(prt, otherprt, shat ,minz, maxz, retvalue, final)
	type(parton_t), intent(inout) :: prt, otherprt
	real(default), intent(in) :: shat, minz, maxz, final
	real(default), intent(inout) :: retvalue
	real(default) :: z, zstep
	real(default) :: r1,r3,s1,s3
	real(default) :: pdf_divisor
	real(default) :: temprand
	real(default), parameter :: zstepfactor = 0.1_default
	real(default), parameter :: zstepmin = 0.0001_default
	if (D_PRINT) print *, "D: integral_over_z_part_isr"
	pdf_divisor = shower%get_pdf &
	(prt%initial%type, prt%child1%x, prt%t, prt%child1%type)
	z = minz
	s1 = shat + abs(otherprt%t) + abs(prt%child1%t)
	r1 = sqrt (s1*2 - four abs(otherprt%t * prt%child1%t))
	ZLOOP: do
	if (signal_is_pending ()) return
	if (z >= maxz) then
	exit
	end if
	call shower%rng%generate (temprand)
	if (parton_is_gluon (prt%child1)) then
	if (parton_is_gluon (prt)) then
	!!! g-> gg -> divergencies at z->0 and z->1
	zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
	else
	!!! q-> gq -> divergencies at z->0
	zstep = max(zstepmin, temprand * zstepfactor * (one - z))
	end if
	else
	if (parton_is_gluon (prt)) then
	!!! g-> qqbar -> no divergencies
	zstep = max(zstepmin, temprand * zstepfactor)
	else
	!!! q-> qg -> divergencies at z->1
	zstep = max(zstepmin, temprand * zstepfactor * (one - z))
	end if
	end if
	zstep = min(zstep, maxz - z)
	prt%z = z + 0.5_default * zstep
	s3 = shat / prt%z + abs(otherprt%t) + abs(prt%t)
	r3 = sqrt (s3*2 - four abs(otherprt%t * prt%t))
	!!! TODO: WHY is this if needed?
	if (abs(otherprt%t) > eps0) then
	prt%child2%t = min ((s1 * s3 - r1 * r3) / &
	(two * abs(otherprt%t)) - abs(prt%child1%t) - &
	abs(prt%t), abs(prt%child1%t))
	else
	prt%child2%t = abs(prt%child1%t)
	end if
	do
	prt%child2%momentum%p(0) = sqrt (abs(prt%child2%t))
	if (shower%isr_only_onshell_emitted_partons) then
	prt%child2%t = prt%child2%mass_squared ()
	else
	call parton_next_t_ana (prt%child2, shower%rng)
	end if
	!!! take limits by recoiler into account
	prt%momentum%p(0) = (shat / prt%z + &
	abs(otherprt%t) - abs(prt%child1%t) - &
	prt%child2%t) / (two * sqrt(shat))
	prt%child2%momentum%p(0) = &
	prt%momentum%p(0) - prt%child1%momentum%p(0)
	!!! check if E and t of prt%child2 are consistent
	if (prt%child2%momentum%p(0)**2 < prt%child2%t &
	.and. prt%child2%t > prt%child2%mass_squared ()) then
	!!! E is too small to have p_T^2 = E^2 - t > 0
	!!! -> cycle to find another solution
	cycle
	else
	!!! E is big enough -> exit
	exit
	end if
	end do
	if (thetabar (prt, otherprt, shower%isr_angular_ordered) &
	.and. pdf_divisor > zero &
	.and. prt%child2%momentum%p(0) > zero) then
	retvalue = retvalue + (zstep / prt%z) * &
	(D_alpha_s_isr ((one - prt%z) * prt%t, &
	shower%settings%d_min_t) * &
	P_prt_to_child1 (prt) * &
	shower%get_pdf (prt%initial%type, prt%child1%x / prt%z, &
	prt%t, prt%type)) / (abs(prt%t) * pdf_divisor)
	end if
	if (retvalue > final) then
	exit
	else
	z = z + zstep
	end if
	end do ZLOOP
	end subroutine integral_over_z_part_isr
	end subroutine shower_isr_step

	@ %def shower_isr_step
	@ This returns a pointer to the parton with the next ISR branching, again
	FSR branchings are ignored.
	<<Shower core: shower: TBP>>=
	procedure :: generate_next_isr_branching => &
	shower_generate_next_isr_branching
	<<Shower core: procedures>>=
	function shower_generate_next_isr_branching &
	(shower) result (next_brancher)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t) :: next_brancher
	integer i, index
	type(parton_t), pointer :: prt
	real(default) :: maxscale
	next_brancher%p => null()
	do
	if (signal_is_pending ()) return
	if (shower_isr_is_finished (shower)) exit
	!!! find mother with highest \|t\| or pt to be simulated
	index = 0
	maxscale = zero
	call shower%sort_partons ()
	do i = 1,size (shower%partons)
	prt => shower%partons(i)%p
	if (.not. associated (prt)) cycle
	if (.not. isr_pt_ordered) then
	if (prt%belongstointeraction) cycle
	end if
	if (prt%belongstoFSR) cycle
	if (parton_is_final (prt)) cycle
	if (.not. prt%belongstoFSR .and. prt%simulated) cycle
	index = i
	exit
	end do
	if (ASSERT) then
	if (index == 0) then
	call msg_fatal(" no branchable partons found")
	return
	end if
	end if

	prt => shower%partons(index)%p

	!!! ISR simulation
	if (isr_pt_ordered) then
	call shower_isr_step_pt (shower, prt)
	else
	call shower_isr_step (shower, prt)
	end if
	if (prt%simulated) then
	if (prt%t < zero) then
	next_brancher%p => prt
	if (.not. isr_pt_ordered) &
	call parton_generate_ps_ini (prt, shower%rng)
	exit
	else
	if (.not. isr_pt_ordered) then
	call shower_replace_parent_by_hadron (shower, prt%child1)
	else
	call shower_replace_parent_by_hadron (shower, prt)
	end if
	end if
	end if
	end do

	!!! some bookkeeping
	call shower%sort_partons ()
	call shower_boost_to_CMframe (shower) !!! really necessary?
	call shower_rotate_to_z (shower) !!! really necessary?
	end function shower_generate_next_isr_branching

	@ %def shower_generate_next_isr_branching
	@ This is a loop which searches for all emitted and branched partons.
	<<Shower core: shower: TBP>>=
	procedure :: generate_fsr_for_isr_partons => &
	shower_generate_fsr_for_partons_emitted_in_ISR
	<<Shower core: procedures>>=
	subroutine shower_generate_fsr_for_partons_emitted_in_ISR (shower)
	class(shower_t), intent(inout) :: shower
	integer :: n_int, i
	type(parton_t), pointer :: prt
	if (shower%isr_only_onshell_emitted_partons) return
	if (D_PRINT) print *, "D: shower_generate_fsr_for_partons_emitted_in_ISR"
	INTERACTIONS_LOOP: do n_int = 1, size (shower%interactions)
	INCOMING_PARTONS_LOOP: do i = 1, 2
	if (signal_is_pending ()) return
	prt => shower%interactions(n_int)%i%partons(i)%p
	PARENT_PARTONS_LOOP: do
	if (associated (prt%parent)) then
	if (.not. parton_is_proton (prt%parent)) then
	prt => prt%parent
	else
	exit
	end if
	else
	exit
	end if
	if (associated (prt%child2)) then
	if (parton_is_branched (prt%child2)) then
	call shower_parton_generate_fsr (shower, prt%child2)
	end if
	else
	! call msg_fatal ("Shower: no child2 associated?")
	end if
	end do PARENT_PARTONS_LOOP
	end do INCOMING_PARTONS_LOOP
	end do INTERACTIONS_LOOP
	end subroutine shower_generate_fsr_for_partons_emitted_in_ISR

	@ %def shower_generate_fsr_for_partons_emitted_in_ISR
	@ This executes the branching generated by
	[[shower_generate_next_isr_branching]], that means it generates the
	flavors, momenta, etc.
	<<Shower core: shower: TBP>>=
	procedure :: execute_next_isr_branching => shower_execute_next_isr_branching
	<<Shower core: procedures>>=
	subroutine shower_execute_next_isr_branching (shower, prtp)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t), intent(inout) :: prtp
	type(parton_t), pointer :: prt, otherprt
	type(parton_t), pointer :: prta, prtb, prtc, prtr
	real(default) :: mar, mbr
	real(default) :: phirand
	if (D_PRINT) print *, "D: shower_execute_next_isr_branching"
	if (.not. associated (prtp%p)) then
	call msg_fatal ("Shower: prtp not associated")
	end if

	prt => prtp%p

	if ((.not. isr_pt_ordered .and. prt%t > - shower%settings%d_min_t) .or. &
	(isr_pt_ordered .and. prt%scale < D_Min_scale)) then
	call msg_error ("Shower: no branching to be executed.")
	end if

	otherprt => shower_find_recoiler (shower, prt)
	if (isr_pt_ordered) then
	!!! get the recoiler
	otherprt => shower_find_recoiler (shower, prt)
	if (associated (otherprt%parent)) then
	!!! Why only for pt ordered
	if (.not. parton_is_proton (otherprt%parent) .and. &
	isr_pt_ordered) otherprt => otherprt%parent
	end if
	if (.not. associated (prt%parent)) then
	call shower%add_parent (prt)
	end if
	prt%parent%belongstoFSR = .false.
	if (.not. associated (prt%parent%child2)) then
	call shower%add_child (prt%parent, 2)
	end if

	prta => prt%parent !!! new parton a with branching a->bc
	prtb => prt !!! former parton
	prtc => prt%parent%child2 !!! emitted parton
	prtr => otherprt !!! recoiler

	mbr = (prtb%momentum + prtr%momentum)**1
	mar = mbr / sqrt(prt%z)

	!!! 1. assume you are in the restframe
	!!! 2. rotate by random phi
	call shower%rng%generate (phirand)
	phirand = twopi * phirand
	call shower_apply_lorentztrafo (shower, &
	rotation(cos(phirand), sin(phirand),vector3_canonical(3)))
	!!! 3. Put the b off-shell
	!!! and
	!!! 4. construct the massless a
	!!! and the parton (eventually emitted by a)

	!!! generate the flavor of the parent (prta)
	if (prtb%aux_pt /= 0) prta%type = prtb%aux_pt
	if (parton_is_quark (prtb)) then
	if (prta%type == prtb%type) then
	!!! (anti)-quark -> (anti-)quark + gluon
	prta%type = prtb%type ! quarks have same flavor
	prtc%type = GLUON ! emitted gluon
	else
	!!! gluon -> quark + antiquark
	prta%type = GLUON
	prtc%type = - prtb%type
	end if
	else if (parton_is_gluon (prtb)) then
	prta%type = GLUON
	prtc%type = GLUON
	else
	! STOP "Bug in shower_execute_next_branching: neither quark nor gluon"
	end if

	prta%initial => prtb%initial
	prta%belongstoFSR = .false.
	prta%scale = prtb%scale
	prta%x = prtb%x / prtb%z

	prtb%momentum = vector4_moving ((mbr*2 + prtb%t) / (two mbr), &
	vector3_canonical(3) * &
	sign ((mbr*2 - prtb%t) / (two mbr), &
	prtb%momentum%p(3)))
	prtr%momentum = vector4_moving ((mbr*2 - prtb%t) / (two mbr), &
	vector3_canonical(3) * &
	sign( (mbr*2 - prtb%t) / (two mbr), &
	prtr%momentum%p(3)))

	prta%momentum = vector4_moving ((0.5_default / mbr) * &
	((mbr**2 / prtb%z) + prtb%t - prtc%mass_squared ()), &
	vector3_null)
	prta%momentum = vector4_moving (prta%momentum%p(0), &
	vector3_canonical(3) * &
	(0.5_default / prtb%momentum%p(3)) * &
	((mbr**2 / prtb%z) - two &
	* prtr%momentum%p(0) * prta%momentum%p(0) ) )
	if (prta%momentum%p(0)2 - prta%momentum%p(3)2 - &
	prtc%mass_squared () > zero) then
	!!! This SHOULD be always fulfilled???
	prta%momentum = vector4_moving (prta%momentum%p(0), &
	vector3_moving([sqrt (prta%momentum%p(0)**2 - &
	prta%momentum%p(3)**2 - &
	prtc%mass_squared ()), zero, &
	prta%momentum%p(3)]))
	end if
	prtc%momentum = prta%momentum - prtb%momentum

	!!! 5. rotate to have a along z-axis
	call shower_boost_to_CMframe (shower)
	call shower_rotate_to_z (shower)
	!!! 6. rotate back in phi
	call shower_apply_lorentztrafo (shower, rotation &
	(cos(-phirand), sin(-phirand), vector3_canonical(3)))
	else
	if (prt%child2%t > prt%child2%mass_squared ()) then
	call shower_add_children_of_emitted_timelike_parton &
	(shower, prt%child2)
	call prt%child2%set_simulated ()
	end if

	call shower%add_parent (prt)
	call shower%add_child (prt%parent, 2)

	prt%parent%momentum = prt%momentum
	prt%parent%t = prt%t
	prt%parent%x = prt%x
	prt%parent%initial => prt%initial
	prt%parent%belongstoFSR = .false.

	prta => prt
	prtb => prt%child1
	prtc => prt%child2
	end if
	if (signal_is_pending ()) return
	if (isr_pt_ordered) then
	call parton_generate_ps_ini (prt%parent, shower%rng)
	else
	call parton_generate_ps_ini (prt, shower%rng)
	end if

	!!! add color connections
	if (parton_is_quark (prtb)) then

	if (prta%type == prtb%type) then
	if (prtb%type > 0) then
	!!! quark -> quark + gluon
	prtc%c2 = prtb%c1
	prtc%c1 = shower%get_next_color_nr ()
	prta%c1 = prtc%c1
	else
	!!! antiquark -> antiquark + gluon
	prtc%c1 = prtb%c2
	prtc%c2 = shower%get_next_color_nr ()
	prta%c2 = prtc%c2
	end if
	else
	!!! gluon -> quark + antiquark
	if (prtb%type > 0) then
	!!! gluon -> quark + antiquark
	prta%c1 = prtb%c1
	prtc%c1 = 0
	prtc%c2 = shower%get_next_color_nr ()
	prta%c2 = prtc%c2
	else
	!!! gluon -> antiquark + quark
	prta%c2 = prtb%c2
	prtc%c1 = shower%get_next_color_nr ()
	prtc%c2 = 0
	prta%c1 = prtc%c1
	end if
	end if
	else if (parton_is_gluon (prtb)) then
	if (parton_is_gluon (prta)) then
	!!! g -> gg
	prtc%c2 = prtb%c1
	prtc%c1 = shower%get_next_color_nr ()
	prta%c1 = prtc%c1
	prta%c2 = prtb%c2
	else if (parton_is_quark (prta)) then
	if (prta%type > 0) then
	prta%c1 = prtb%c1
	prta%c2 = 0
	prtc%c1 = prtb%c2
	prtc%c2 = 0
	else
	prta%c1 = 0
	prta%c2 = prtb%c2
	prtc%c1 = 0
	prtc%c2 = prtb%c1
	end if
	end if
	end if

	call shower%sort_partons ()
	call shower_boost_to_CMframe (shower)
	call shower_rotate_to_z (shower)

	end subroutine shower_execute_next_isr_branching

	@ %def shower_execute_next_isr_branching
	@
	<<Shower core: procedures>>=
	subroutine shower_remove_parents_and_stuff (shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), intent(inout), target :: prt
	type(parton_t), pointer :: actprt, nextprt
	nextprt => prt%parent
	actprt => null()
	!!! remove children of emitted timelike parton
	if (associated (prt%child2)) then
	if (associated (prt%child2%child1)) then
	call shower_remove_parton_from_partons_recursive &
	(shower, prt%child2%child1)
	end if
	prt%child2%child1 => null()
	if (associated (prt%child2%child2)) then
	call shower_remove_parton_from_partons_recursive &
	(shower, prt%child2%child2)
	end if
	prt%child2%child2 => null()
	end if
	do
	actprt => nextprt
	if (.not. associated (actprt)) then
	exit
	else if (parton_is_proton (actprt)) then
	!!! remove beam-remnant
	call shower_remove_parton_from_partons (shower, actprt%child2)
	exit
	end if
	if (associated (actprt%parent)) then
	nextprt => actprt%parent
	else
	nextprt => null()
	end if
	call shower_remove_parton_from_partons_recursive &
	(shower, actprt%child2)
	call shower_remove_parton_from_partons (shower, actprt)

	end do
	prt%parent=>null()

	end subroutine shower_remove_parents_and_stuff

	@ %def shower_remove_parents_and_stuff
	@
	<<Shower core: shower: TBP>>=
	procedure :: get_ISR_scale => shower_get_ISR_scale
	<<Shower core: procedures>>=
	function shower_get_ISR_scale (shower) result (scale)
	class(shower_t), intent(in) :: shower
	real(default) :: scale
	type(parton_t), pointer :: prt1, prt2
	integer :: i
	scale = zero
	do i = 1, size (shower%interactions)
	call interaction_find_partons_nearest_to_hadron &
	(shower%interactions(i)%i, prt1, prt2)
	if (.not. prt1%simulated .and. abs(prt1%scale) > scale) &
	scale = abs(prt1%scale)
	if (.not. prt1%simulated .and. abs(prt2%scale) > scale) &
	scale = abs(prt2%scale)
	end do
	end function shower_get_ISR_scale

	@ %def shower_get_ISR_scale
	@
	<<Shower core: shower: TBP>>=
	procedure :: set_max_isr_scale => shower_set_max_isr_scale
	<<Shower core: procedures>>=
	subroutine shower_set_max_isr_scale (shower, newscale)
	class(shower_t), intent(inout) :: shower
	real(default), intent(in) :: newscale
	real(default) :: scale
	type(parton_t), pointer :: prt
	integer :: i,j
	print *, "shower_set_max_isr_scale", newscale
	call shower%write ()

	if (isr_pt_ordered) then
	scale = newscale
	else
	scale = -abs(newscale)
	end if

	INTERACTIONS: do i = 1, size (shower%interactions)
	PARTONS: do j = 1, 2
	prt => shower%interactions(i)%i%partons(j)%p
	do
	if (.not. isr_pt_ordered) then
	if (prt%belongstointeraction) prt => prt%parent
	end if
	if (prt%t < scale) then
	if (associated (prt%parent)) then
	prt => prt%parent
	else
	exit !!! unresolved prt found
	end if
	else
	exit !!! prt with scale above newscale found
	end if
	end do
	if (.not. isr_pt_ordered) then
	if (prt%child1%belongstointeraction .or. &
	parton_is_proton (prt)) then
	!!! don't reset scales of "first" spacelike partons
	!!! in virtuality ordered shower or hadrons
	cycle
	end if
	else
	if (parton_is_proton (prt)) then
	!!! don't reset scales of hadrons
	cycle
	end if
	end if
	if (isr_pt_ordered) then
	prt%scale = scale
	else
	prt%t = scale
	end if
	call prt%set_simulated (.false.)
	call shower_remove_parents_and_stuff (shower, prt)
	end do PARTONS
	end do INTERACTIONS

	call shower%write ()
	print *, "shower_set_max_isr_scale finished"
	end subroutine shower_set_max_isr_scale

	@ %def shower_set_max_isr_scale
	@
	<<Shower core: shower: TBP>>=
	procedure :: interaction_generate_fsr_2ton => &
	shower_interaction_generate_fsr_2ton
	@
	<<Shower core: procedures>>=
	subroutine shower_interaction_generate_fsr_2ton (shower, interaction)
	class(shower_t), intent(inout) :: shower
	type(shower_interaction_t), intent(inout) :: interaction
	type(parton_t), pointer :: prt
	prt => interaction%partons(3)%p
	do
	if (.not. associated (prt%parent)) exit
	prt => prt%parent
	end do
	call shower_parton_generate_fsr (shower, prt)
	call shower_parton_update_color_connections (shower, prt)
	end subroutine shower_interaction_generate_fsr_2ton

	@ %def shower_interaction_generate_fsr_2ton
	@ Perform the FSR for one parton, it is assumed, that the parton
	already branched. Hence, its children are to be simulated. This
	procedure is intended for branched FSR-partons emitted in the ISR.
	<<Shower core: procedures>>=
	subroutine shower_parton_generate_fsr (shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), intent(inout), target :: prt
	type(parton_pointer_t), dimension(:), allocatable :: partons
	logical :: single_emission = .false.
	if (D_PRINT) print *, 'D: shower_parton_generate_fsr'
	if (signal_is_pending ()) return
	if (ASSERT) then
	if (.not. parton_is_branched (prt)) then
	print *, " error in shower_parton_generate_fsr:", &
	"parton not branched"
	return
	end if
	if (prt%child1%simulated .or. &
	prt%child2%simulated) then
	print *, " error in shower_parton_generate_fsr:", &
	"children already simulated for parton ", prt%nr
	call shower%write ()
	return
	end if
	end if

	allocate (partons(1))
	partons(1)%p => prt
	if (single_emission) then
	call shower%parton_pointer_array_generate_fsr (partons, partons)
	else
	call shower%parton_pointer_array_generate_fsr_recursive (partons)
	end if

	end subroutine shower_parton_generate_fsr

	@ %def shower_parton_generate_fsr
	@
	<<Shower core: shower: TBP>>=
	procedure :: parton_pointer_array_generate_fsr_recursive => &
	shower_parton_pointer_array_generate_fsr_recursive
	@
	<<Shower core: procedures>>=
	recursive subroutine shower_parton_pointer_array_generate_fsr_recursive &
	(shower, partons)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: &
	partons
	type(parton_pointer_t), dimension(:), allocatable :: partons_new
	if (D_PRINT) print *, 'D: shower_parton_pointer_array_generate_fsr_recursive'
	if (signal_is_pending ()) return
	if (size (partons) == 0) return
	call shower%parton_pointer_array_generate_fsr (partons, partons_new)
	call shower%parton_pointer_array_generate_fsr_recursive (partons_new)
	end subroutine shower_parton_pointer_array_generate_fsr_recursive
	@
	<<Shower core: shower: TBP>>=
	procedure :: parton_pointer_array_generate_fsr => &
	shower_parton_pointer_array_generate_fsr
	@
	<<Shower core: procedures>>=
	subroutine shower_parton_pointer_array_generate_fsr &
	(shower, partons, partons_new)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: &
	partons
	type(parton_pointer_t), dimension(:), allocatable, intent(out) :: partons_new
	integer :: i, size_partons, size_partons_new
	if (D_PRINT) print *, 'D: shower_parton_pointer_array_generate_fsr'
	!!! simulate highest/first parton
	call shower_simulate_children_ana (shower, partons(1)%p)
	!!! check for new daughters to be included in new_partons
	size_partons = size (partons)
	size_partons_new = size_partons - 1 !!! partons(1) not needed anymore
	if (parton_is_branched (partons(1)%p%child1)) &
	size_partons_new = size_partons_new + 1
	if (parton_is_branched (partons(1)%p%child2)) &
	size_partons_new = size_partons_new + 1

	allocate (partons_new (1:size_partons_new))

	if (size_partons > 1) then
	do i = 2, size_partons
	partons_new (i - 1)%p => partons(i)%p
	end do
	end if
	if (parton_is_branched (partons(1)%p%child1)) &
	partons_new (size_partons)%p => partons(1)%p%child1
	if (parton_is_branched (partons(1)%p%child2)) then
	!!! check if child1 is already included
	if (size_partons_new == size_partons) then
	partons_new (size_partons)%p => partons(1)%p%child2
	else if (size_partons_new == size_partons + 1) then
	partons_new (size_partons + 1)%p => partons(1)%p%child2
	else
	call msg_fatal ("Shower: wrong sizes in" &
	// "shower_parton_pointer_array_generate_fsr")
	end if
	end if
	deallocate(partons)

	end subroutine shower_parton_pointer_array_generate_fsr

	@ %def shower_parton_pointer_array_generate_fsr
	@
	<<Shower core: procedures>>=
	recursive subroutine shower_parton_update_color_connections &
	(shower, prt)
	type(shower_t), intent(inout) :: shower
	type(parton_t), intent(inout) :: prt
	real(default) :: temprand
	if (.not. associated (prt%child1) .or. &
	.not. associated (prt%child2)) return

	if (signal_is_pending ()) return
	if (parton_is_gluon (prt)) then
	if (parton_is_quark (prt%child1)) then
	!!! give the quark the colorpartner and the antiquark
	!!! the anticolorpartner
	if (prt%child1%type > 0) then
	!!! child1 is quark, child2 is antiquark
	prt%child1%c1 = prt%c1
	prt%child2%c2 = prt%c2
	else
	!!! child1 is antiquark, child2 is quark
	prt%child1%c2 = prt%c2
	prt%child2%c1 = prt%c1
	end if
	else
	!!! g -> gg splitting -> random choosing of partners
	call shower%rng%generate (temprand)
	if (temprand > 0.5_default) then
	prt%child1%c1 = prt%c1
	prt%child1%c2 = shower%get_next_color_nr ()
	prt%child2%c1 = prt%child1%c2
	prt%child2%c2 = prt%c2
	else
	prt%child1%c2 = prt%c2
	prt%child2%c1 = prt%c1
	prt%child2%c2 = shower%get_next_color_nr ()
	prt%child1%c1 = prt%child2%c2
	end if
	end if
	else if (parton_is_quark (prt)) then
	if (parton_is_quark (prt%child1)) then
	if (prt%child1%type > 0) then
	!!! q -> q + g
	prt%child2%c1 = prt%c1
	prt%child2%c2 = shower%get_next_color_nr ()
	prt%child1%c1 = prt%child2%c2
	else
	!!! qbar -> qbar + g
	prt%child2%c2 = prt%c2
	prt%child2%c1 = shower%get_next_color_nr ()
	prt%child1%c2 = prt%child2%c1
	end if
	else
	if (prt%child2%type > 0) then
	!!! q -> g + q
	prt%child1%c1 = prt%c1
	prt%child1%c2 = shower%get_next_color_nr ()
	prt%child2%c1 = prt%child1%c2
	else
	!!! qbar -> g + qbar
	prt%child1%c2 = prt%c2
	prt%child1%c1 = shower%get_next_color_nr ()
	prt%child2%c2 = prt%child1%c1
	end if
	end if
	end if

	call shower_parton_update_color_connections (shower, prt%child1)
	call shower_parton_update_color_connections (shower, prt%child2)
	end subroutine shower_parton_update_color_connections

	@ %def shower_parton_update_color_connections
	@ The next two routines are for PDFs. Wrapper function to return
	parton densities.
	<<Shower core: shower: TBP>>=
	procedure :: get_pdf => shower_get_pdf
	<<Shower core: procedures>>=
	function shower_get_pdf (shower, mother, x, Q2, daughter) result (pdf)
	<<get pdf>>
	if (x > eps0) then
	pdf = pdf / x
	end if
	end function shower_get_pdf

	@ %def shower_get_pdf
	<<Shower core: shower: TBP>>=
	procedure :: get_xpdf => shower_get_xpdf
	<<Shower core: procedures>>=
	function shower_get_xpdf (shower, mother, x, Q2, daughter) result (pdf)
	<<get pdf>>
	end function shower_get_xpdf

	@ %def shower_get_xpdf
	@
	<<get pdf>>=
	class(shower_t), intent(inout), target :: shower
	integer, intent(in) :: mother, daughter
	real(default), intent(in) :: x, Q2
	real(default) :: pdf
	real(double), save :: f(-6:6) = 0._double
	real(double), save :: lastx, lastQ2 = 0._double
	if (ASSERT) then
	if (abs (mother) /= PROTON) then
	pdf = zero
	print *, "mother = ", mother
	call msg_fatal ("Shower: pdf only implemented for (anti-)proton")
	end if
	if (.not. (abs (daughter) >= 1 .and. abs (daughter) <= 6 .or. &
	daughter == GLUON)) then
	pdf = zero
	print *, "daughter = ", daughter
	call msg_fatal ("Shower: error in pdf, unknown daughter")
	end if
	end if
	if (x > zero .and. x < one) then
	if ((dble(Q2) - lastQ2) > eps0 .or. (dble(x) - lastx) > eps0) then
	call shower%pdf_data%evolve &
	(dble(x), sqrt (abs (dble(Q2))), f)
	end if
	if (abs (daughter) >= 1 .and. abs (daughter) <= 6) then
	pdf = max (f(daughter * sign (1,mother)), tiny_10)
	else
	pdf = max (f(0), tiny_10)
	end if
	else
	pdf = zero
	end if
	lastQ2 = dble(Q2)
	lastx = dble(x)
	@
	@
	<<Shower core: public>>=
	public :: shower_converttopythia
	@
	<<Shower core: procedures>>=
	subroutine shower_converttopythia (shower)
	IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	IMPLICIT INTEGER(I-N)
	!!! C... Commonblocks.
	COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/

	type(shower_t), intent(in) :: shower
	type(parton_t), pointer :: pp, ppparent
	integer :: i, j, nz

	!!! currently only works for one interaction

	do i = 1, 2
	!!! get history of the event
	pp => shower%interactions(1)%i%partons(i)%p
	!!! add these partons to the event record
	if (associated (pp%initial)) then
	!!! add hadrons
	K(i,1) = GLUON
	K(i,2) = pp%initial%type
	K(i,3) = 0
	P(i,1) = pp%initial%momentum%p(1)
	P(i,2) = pp%initial%momentum%p(2)
	P(i,3) = pp%initial%momentum%p(3)
	P(i,4) = pp%initial%momentum%p(0)
	P(I,5) = pp%initial%momentum**2
	!!! add partons emitted by the hadron
	ppparent => pp
	do while (associated (ppparent%parent))
	if (parton_is_proton (ppparent%parent)) then
	exit
	else
	ppparent => ppparent%parent
	end if
	end do
	K(i+2,1) = GLUON
	K(i+2,2) = ppparent%type
	K(i+2,3) = i
	P(i+2,1) = ppparent%momentum%p(1)
	P(i+2,2) = ppparent%momentum%p(2)
	P(i+2,3) = ppparent%momentum%p(3)
	P(i+2,4) = ppparent%momentum%p(0)
	P(I+2,5) = ppparent%momentum**2
	!!! add partons in the initial state of the ME
	K(i+4,1) = GLUON
	K(i+4,2) = pp%type
	K(i+4,3) = i
	P(i+4,1) = pp%momentum%p(1)
	P(i+4,2) = pp%momentum%p(2)
	P(i+4,3) = pp%momentum%p(3)
	P(i+4,4) = pp%momentum%p(0)
	P(I+4,5) = pp%momentum**2
	else
	!!! for e+e- without ISR all entries are the same
	K(i,1) = GLUON
	K(i,2) = pp%type
	K(i,3) = 0
	P(i,1) = pp%momentum%p(1)
	P(i,2) = pp%momentum%p(2)
	P(i,3) = pp%momentum%p(3)
	P(i,4) = pp%momentum%p(0)
	P(I,5) = pp%momentum**2
	do j = 1, 5
	P(i+2,j) = P(1,j)
	K(i+2,j) = K(1,j)
	K(i+2,3) = i
	P(i+4,j) = P(1,j)
	K(i+4,j) = K(1,j)
	K(i+4,3) = i
	end do
	P(i+4,5) = 0.
	end if
	end do
	N = 6
	!!! create intermediate (fake) Z-Boson
	K(7,1) = GLUON
	K(7,2) = 23
	K(7,3) = 0
	P(7,1) = P(5,1) + P(6,1)
	P(7,2) = P(5,2) + P(6,2)
	P(7,3) = P(5,3) + P(6,3)
	P(7,4) = P(5,4) + P(6,4)
	P(7,5) = P(7,4)2 - P(7,3)2 - P(7,2)2 - P(7,1)2
	N = 7
	!!! include partons in the final state of the hard matrix element
	do i = 1, size (shower%interactions(1)%i%partons) - 2
	!!! get partons that are in the final state of the hard matrix element
	pp => shower%interactions(1)%i%partons(2+i)%p
	!!! add these partons to the event record
	K(7+I,1) = GLUON
	K(7+I,2) = pp%type
	K(7+I,3) = 7
	P(7+I,1) = pp%momentum%p(1)
	P(7+I,2) = pp%momentum%p(2)
	P(7+I,3) = pp%momentum%p(3)
	P(7+I,4) = pp%momentum%p(0)
	P(7+I,5) = P(7+I,4)2 - P(7+I,3)2 - P(7+I,2)2 - P(7+I,1)2
	N = 7 + I
	end do
	!!! include "Z" (again)
	N = N + 1
	K(N,1) = 11
	K(N,2) = 23
	K(N,3) = 7
	P(N,1) = P(7,1)
	P(N,2) = P(7,2)
	P(N,3) = P(7,3)
	P(N,4) = P(7,4)
	P(N,5) = P(7,5)
	nz = N
	!!! include partons from the final state of the parton shower
	call shower_transfer_final_partons_to_pythia (shower, 8)
	!!! set "children" of "Z"
	K(nz,4) = 11
	K(nz,5) = N
	!!! mark spacers
	MSTU(73) = N
	MSTU(74) = N

	!!! be sure to remove the next partons (=first obsolete partons)
	K(N+1,1) = 0
	K(N+1,2) = 0
	K(N+1,3) = 0
	K(N+2,1) = 0
	K(N+2,2) = 0
	K(N+2,3) = 0
	K(N+3,1) = 0
	K(N+3,2) = 0
	K(N+3,3) = 0
	!!! otherwise they might be interpreted as thrust information
	end subroutine shower_converttopythia

	@ %def shower_converttopythia
	@
	<<Shower core: procedures>>=
	subroutine shower_transfer_final_partons_to_pythia (shower, first)
	IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	IMPLICIT INTEGER(I-N)
	! C... Commonblocks.
	COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
	COMMON/PYDAT3/MDCY(500,3),MDME(8000,2),BRAT(8000),KFDP(8000,5)
	COMMON/PYSUBS/MSEL,MSELPD,MSUB(500),KFIN(2,-40:40),CKIN(200)
	COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	SAVE /PYJETS/,/PYDAT1/,/PYDAT2/,/PYDAT3/,/PYSUBS/,/PYPARS/

	type(shower_t), intent(in) :: shower
	integer, intent(in) :: first
	type(parton_t), pointer :: prt
	integer :: i, j, n_finals
	type(parton_t), dimension(:), allocatable :: final_partons
	type(parton_t) :: temp_parton
	integer :: minindex, maxindex

	prt => null()

	!!! get total number of final partons
	n_finals = 0
	do i = 1, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	prt => shower%partons(i)%p
	if (.not. prt%belongstoFSR) cycle
	if (associated (prt%child1)) cycle
	n_finals = n_finals + 1
	end do

	allocate (final_partons(1:n_finals))
	j = 1
	do i = 1, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	prt => shower%partons(i)%p
	if (.not. prt%belongstoFSR) cycle
	if (associated (prt%child1)) cycle
	final_partons(j) = shower%partons(i)%p
	j = j + 1
	end do

	!!! move quark to front as beginning of color string
	minindex = 1
	maxindex = size (final_partons)
	FIND_Q: do i = minindex, maxindex
	if (final_partons(i)%type >= 1 .and. final_partons(i)%type <= 6) then
	temp_parton = final_partons(minindex)
	final_partons(minindex) = final_partons(i)
	final_partons(i) = temp_parton
	exit FIND_Q
	end if
	end do FIND_Q

	!!! sort so that connected partons are next to each other, don't care about zeros
	do i = 1, size (final_partons)
	!!! ensure that final_partnons begins with a color (not an anticolor)
	if (final_partons(i)%c1 > 0 .and. final_partons(i)%c2 == 0) then
	if (i == 1) then
	exit
	else
	temp_parton = final_partons(1)
	final_partons(1) = final_partons(i)
	final_partons(i) = temp_parton
	exit
	end if
	end if
	end do

	do i = 1, size (final_partons) - 1
	!!! search for color partner and move it to i + 1
	PARTNERS: do j = i + 1, size (final_partons)
	if (final_partons(j)%c2 == final_partons(i)%c1) exit PARTNERS
	end do PARTNERS
	if (j > size (final_partons)) then
	print *, "no color connected parton found" !WRONG???
	print *, "particle: ", final_partons(i)%nr, " index: ", &
	final_partons(i)%c1
	exit
	end if
	temp_parton = final_partons(i + 1)
	final_partons(i + 1) = final_partons(j)
	final_partons(j) = temp_parton
	end do

	!!! transfering partons
	do i = 1, size (final_partons)
	prt = final_partons(i)
	N = N + 1
	K(N,1) = 2
	if (prt%c1 == 0) K(N,1) = 1 !!! end of color string
	K(N,2) = prt%type
	K(N,3) = first
	K(N,4) = 0
	K(N,5) = 0
	P(N,1) = prt%momentum%p(1)
	P(N,2) = prt%momentum%p(2)
	P(N,3) = prt%momentum%p(3)
	P(N,4) = prt%momentum%p(0)
	P(N,5) = prt%momentum**2
	end do
	deallocate (final_partons)
	end subroutine shower_transfer_final_partons_to_pythia

	@ %def shower_transfer_final_partons_to_pythia
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Interface to PYTHIA}
	<<[[shower_pythia6.f90]]>>=
	<<File header>>

	module shower_pythia6

	<<Use kinds with double>>
	<<Use strings>>
	use io_units
	use physics_defs
	use diagnostics
	use system_defs, only: LF
	use os_interface
	use lorentz
	use mlm_matching
	use shower_base
	use particles
	use model_data
	use hep_common

	<<Standard module head>>

	<<Shower PYTHIA6: public>>

	<<Shower PYTHIA6: variables>>

	<<Shower PYTHIA6: types>>

	contains

	<<Shower PYTHIA6: procedures>>

	end module shower_pythia6

	@ %def shower_topythia
	@ The PYTHIA6 shower type.
	<<Shower PYTHIA6: public>>=
	public :: shower_pythia6_t
	<<Shower PYTHIA6: types>>=
	type, extends (shower_base_t) :: shower_pythia6_t
	integer :: initialized_for_NPRUP = 0
	logical :: warning_given = .false.
	contains
	<<Shower PYTHIA6: shower PYTHIA6: TBP>>
	end type shower_pythia6_t

	@ %def shower_pythia6_t
	<<Shower PYTHIA6: variables>>=
	logical, parameter :: DEBUG_SHOWER = .false.
	logical, parameter :: TO_FILE = .false.

	@ %def DEBUG_SHOWER TO_FILE
	@
	@ Initialize the PYTHIA6 shower.
	<<Shower PYTHIA6: shower PYTHIA6: TBP>>=
	procedure :: init => shower_pythia6_init
	<<Shower PYTHIA6: procedures>>=
	subroutine shower_pythia6_init (shower, settings, pdf_data)
	class(shower_pythia6_t), intent(out) :: shower
	type(shower_settings_t), intent(in) :: settings
	type(pdf_data_t), intent(in) :: pdf_data
	if (DEBUG_SHOWER) print *, &
	"Transfer settings from shower_settings to shower"
	shower%settings = settings
	call pythia6_set_verbose (settings%verbose)
	call shower%pdf_data%init (pdf_data)
	shower%name = "PYTHIA6"
	call shower%write_msg ()
	end subroutine shower_pythia6_init

	@ %def shower_pythia6_init
	@
	<<Shower PYTHIA6: shower PYTHIA6: TBP>>=
	procedure :: generate_emissions => shower_pythia6_generate_emissions
	<<Shower PYTHIA6: procedures>>=
	subroutine shower_pythia6_generate_emissions ( &
	shower, particle_set, model, model_hadrons, &
	os_data, matching_settings, data, valid, vetoed, number_of_emissions)
	class(shower_pythia6_t), intent(inout), target :: shower
	type(particle_set_t), intent(inout) :: particle_set
	class(model_data_t), intent(in), target :: model
	class(model_data_t), intent(in), target :: model_hadrons
	class(matching_settings_t), intent(in), allocatable :: matching_settings
	class(matching_data_t), intent(inout), allocatable :: data
	type(os_data_t), intent(in) :: os_data
	logical, intent(inout) :: valid
	logical, intent(inout) :: vetoed
	integer, optional, intent(in) :: number_of_emissions
	character(len=10) :: buffer
	type(particle_set_t) :: pset_reduced
	!!! Units for transfer from WHIZARD to PYTHIA and back
	integer :: u_W2P, u_P2W
	real(default) :: rand

	if (signal_is_pending ()) return
	if (DEBUG_SHOWER) then
	print *, "debugging the shower"
	print *, IDBMUP(1), IDBMUP(2)
	print *, EBMUP, PDFGUP, PDFSUP, IDWTUP
	print *, "NPRUP = ", NPRUP
	end if

	!!! Check if the beam particles are quarks
	if (any (abs(IDBMUP) <= 8)) then
	!!! PYTHIA doesn't support these settings
	if (.not. shower%warning_given) then
	call msg_error ("PYTHIA doesn't support quarks as beam particles," &
	// LF // " neglecting ISR, FSR and hadronization")
	shower%warning_given = .true.
	end if
	return
	end if

	call particle_set%reduce (pset_reduced)
	call hepeup_from_particle_set (pset_reduced)
	call hepeup_set_event_parameters (proc_id=1)

	u_W2P = free_unit ()
	if (DEBUG_SHOWER .and. TO_FILE) then
	open (unit=u_W2P, status="replace", &
	file="whizardout1.lhe", action="readwrite")
	else
	open (unit=u_W2P, status="scratch", action="readwrite")
	end if
	call w2p_write_lhef_event (u_W2P)
	rewind (u_W2P)
	if (signal_is_pending ()) return
	write (buffer, "(I10)") u_W2P
	call PYGIVE ("MSTP(161)=" // buffer)
	call PYGIVE ("MSTP(162)=" // buffer)
	if (DEBUG_SHOWER) write (*, "(A)") buffer
	if (shower%settings%isr_active) then
	call PYGIVE ("MSTP(61)=1")
	else
	call PYGIVE ("MSTP(61)=0") !!! switch off ISR
	end if
	if (shower%settings%fsr_active) then
	call PYGIVE ("MSTP(71)=1")
	else
	call PYGIVE ("MSTP(71)=0") !!! switch off FSR
	end if
	call PYGIVE ("MSTP(111)=0") !!! switch off hadronization

	if (shower%initialized_for_NPRUP >= NPRUP) then
	if (DEBUG_SHOWER) print *, "calling upinit"
	call upinit
	if (DEBUG_SHOWER) print *, "returned from upinit"
	else
	write (buffer, "(F10.5)") sqrt (abs (shower%settings%d_min_t))
	call PYGIVE ("PARJ(82)=" // buffer)
	write (buffer, "(F10.5)") shower%settings%isr_tscalefactor
	call PYGIVE ("PARP(71)=" // buffer)

	write (buffer, "(F10.5)") shower%settings%fsr_lambda
	call PYGIVE ("PARP(72)=" // buffer)
	write(buffer, "(F10.5)") shower%settings%isr_lambda
	call PYGIVE ("PARP(61)=" // buffer)
	write (buffer, "(I10)") shower%settings%max_n_flavors
	call PYGIVE ("MSTJ(45)=" // buffer)
	if (shower%settings%isr_alpha_s_running) then
	call PYGIVE ("MSTP(64)=2")
	else
	call PYGIVE ("MSTP(64)=0")
	end if
	if (shower%settings%fsr_alpha_s_running) then
	call PYGIVE ("MSTJ(44)=2")
	else
	call PYGIVE ("MSTJ(44)=0")
	end if
	write (buffer, "(F10.5)") shower%settings%fixed_alpha_s
	call PYGIVE ("PARU(111)=" // buffer)
	write (buffer, "(F10.5)") shower%settings%isr_primordial_kt_width
	call PYGIVE ("PARP(91)=" // buffer)
	write (buffer, "(F10.5)") shower%settings%isr_primordial_kt_cutoff
	call PYGIVE ("PARP(93)=" // buffer)
	write (buffer, "(F10.5)") 1._double - shower%settings%isr_z_cutoff
	call PYGIVE ("PARP(66)=" // buffer)
	write (buffer, "(F10.5)") shower%settings%isr_minenergy
	call PYGIVE ("PARP(65)=" // buffer)
	if (shower%settings%isr_only_onshell_emitted_partons) then
	call PYGIVE ("MSTP(63)=0")
	else
	call PYGIVE ("MSTP(63)=2")
	end if
	if (shower%settings%mlm_matching) then
	CALL PYGIVE ("MSTP(62)=2")
	CALL PYGIVE ("MSTP(67)=0")
	end if
	if (DEBUG_SHOWER) print *, "calling pyinit"
	call PYINIT ("USER", "", "", 0D0)

	call shower%rng%generate (rand)
	write (buffer, "(I10)") floor (rand*900000000)
	call PYGIVE ("MRPY(1)=" // buffer)
	call PYGIVE ("MRPY(2)=0")

	call pythia6_set_config (shower%settings%pythia6_pygive)

	shower%initialized_for_NPRUP = NPRUP

	end if

	call PYEVNT ()
	if (DEBUG_SHOWER) write (*, "(A)") "called pyevnt"

	u_P2W = free_unit ()
	write (buffer, "(I10)") u_P2W
	call PYGIVE ("MSTP(163)="//buffer)
	if (DEBUG_SHOWER .and. TO_FILE) then
	open (unit = u_P2W, file="pythiaout.lhe", status="replace", &
	action="readwrite")
	else
	open (unit = u_P2W, status="scratch", action="readwrite")
	end if
	if (DEBUG_SHOWER) write (*, "(A)") "calling PYLHEO"
	if (signal_is_pending ()) return
	call pylheo (u_P2W)
	call combine_lhef_with_particle_set &
	(particle_set, u_P2W, model, model_hadrons)
	!call shower%combine_with_particle_set (particle_set, model, model_hadrons)
	close (unit=u_P2W)

	!!! Transfer momenta of the partons in the final state of
	!!! the hard initeraction
	if (shower%settings%mlm_matching .and. allocated (data)) then
	select type (data)
	type is (mlm_matching_data_t)
	call get_ME_momenta_from_PYTHIA (data%P_ME)
	class default
	call msg_fatal ("MLM matching called with wrong data.")
	end select
	end if

	if (pythia6_get_error () > 0) then
	call pythia6_set_error (0)
	valid = .false.
	end if
	close (unit=u_W2P)

	end subroutine shower_pythia6_generate_emissions

	@ %def shower_pythia6_generate_emissions
	@ Has to be available for hadrons?
	<<Shower PYTHIA6: shower pythia6: TBP>>=
	procedure :: combine_with_particle_set => &
	shower_pythia6_combine_with_particle_set
	<<Shower PYTHIA6: procedures>>=
	subroutine shower_pythia6_combine_with_particle_set &
	(shower, particle_set, model, model_hadrons)
	class(shower_pythia6_t), intent(inout) :: shower
	type(particle_set_t), intent(inout) :: particle_set
	class(model_data_t), intent(in), target :: model
	class(model_data_t), intent(in), target :: model_hadrons

	common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5)
	save /PYJETS/

	!C...User process initialization commonblock.
	!C...User process event common block.
	integer, parameter :: MAXPUP = 100, MAXNUP = 500
	integer :: IDBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP, LPRUP
	integer :: NUP, IDPRUP, IDUP, ISTUP, MOTHUP, ICOLUP
	real(double) :: EBMUP, XSECUP, XERRUP, XMAXUP
	real(double) :: XWGTUP, SCALUP, AQEDUP, AQCDUP, PUP, VTIMUP, SPINUP
	integer, parameter :: KSUSY1 = 1000000, KSUSY2 = 2000000
	common /HEPRUP/ &
	IDBMUP(2), EBMUP(2), PDFGUP(2), PDFSUP(2), IDWTUP, NPRUP, &
	XSECUP(MAXPUP), XERRUP(MAXPUP), XMAXUP(MAXPUP), LPRUP(MAXPUP)
	save /HEPRUP/
	common /HEPEUP/ &
	NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP, IDUP(MAXNUP), &
	ISTUP(MAXNUP), MOTHUP(2,MAXNUP), ICOLUP(2,MAXNUP), &
	PUP(5,MAXNUP), VTIMUP(MAXNUP), SPINUP(MAXNUP)
	save /HEPEUP/

	real(double) :: P, V
	integer :: dangling_col, dangling_anti_col, color, anti_color
	integer :: i, j, k, n, nentries, next_color, npad

	if (signal_is_pending ()) return
	if (DEBUG_SHOWER) print *, 'Combine PYTHIA6 with particle set'
	if (DEBUG_SHOWER) call pylist ()

	!!! Find the numbers of entries of the <event block>
	NENTRIES = 0
	do I = 1, N
	if (K(I,1) == 1 .or. K(I,1) == 2 .or. K(I,1) == 21) then
	NENTRIES = NENTRIES + 1
	end if
	end do

	print *, NENTRIES, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP

	dangling_col = 0
	dangling_anti_col = 0
	next_color = 1 ! TODO find next free color number ??
	do I = 1, N
	call assign_colors (color, anti_color)
	print *, K(I,2), K(I,1), K(I,3), K(I,3), &
	color, anti_color, (P(I,J),J=1,5), 0, -9
	end do

	stop
	contains

	<<Shower PYTHIA6: combine with particle set: procedures>>

	end subroutine shower_pythia6_combine_with_particle_set

	@ %def shower_pythia6_combine_with_particle_set
	<<Shower PYTHIA6: combine with particle set: procedures>>=
	subroutine assign_colors (color, anti_color)
	integer, intent(out) :: color, anti_color
	if ((K(I,1) >= 1 .and. K(I,1) <= 15) .or. (K(I,1) == 21)) then
	if ((K(I,2) == 21) .or. (IABS(K(I,2)) <= 8) .or. &
	(abs (K(I,2)) >= KSUSY1+1 .and. abs (K(I,2)) <= KSUSY1+8) &
	.or. &
	(abs (K(I,2)) >= KSUSY2+1 .and. abs (K(I,2)) <= KSUSY2+8) .or. &
	(abs (K(I,2)) >= 1000 .and. abs (K(I,2)) <= 9999) ) then
	if (dangling_col == 0 .and. dangling_anti_col == 0) then
	! new color string
	! Gluon and gluino only color octets implemented so far
	if (K(I,2).eq.21 .or. K(I,2).eq.1000021) then
	color = next_color
	dangling_col = color
	next_color = next_color + 1
	anti_color = next_color
	dangling_anti_col = anti_color
	next_color = next_color + 1
	else if (K(I,2) .gt. 0) then ! particles to have color
	color = next_color
	dangling_col = color
	anti_color = 0
	next_color = next_color + 1
	else if (K(I,2) .lt. 0) then ! antiparticles to have anticolor
	anti_color = next_color
	dangling_anti_col = anti_color
	color = 0
	next_color = next_color + 1
	end if
	else if(K(I,1).eq.1) then
	! end of string
	color = dangling_anti_col
	anti_color = dangling_col
	dangling_col = 0
	dangling_anti_col = 0
	else
	! inside the string
	if(dangling_col /= 0) then
	anti_color = dangling_col
	color = next_color
	dangling_col = next_color
	next_color = next_color +1
	else if(dangling_anti_col /= 0) then
	color = dangling_anti_col
	anti_color = next_color
	dangling_anti_col = next_color
	next_color = next_color +1
	else
	call msg_bug("ERROR IN PYLHEO")
	end if
	end if
	end if
	else
	color = 0
	anti_color = 0
	end if
	end subroutine assign_colors
	@
	<<Shower PYTHIA6: procedures>>=
	subroutine get_ME_momenta_from_PYTHIA (JETS_ME)
	IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	IMPLICIT INTEGER(I-N)
	COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
	SAVE /PYJETS/

	type(vector4_t), dimension(:), allocatable :: JETS_ME
	real(kind=default), dimension(:,:), allocatable :: pdum
	integer :: i, j, n_jets

	if (allocated (JETS_ME)) deallocate (JETS_ME)
	if (allocated (pdum)) deallocate (pdum)

	if (signal_is_pending ()) return
	!!! final ME partons start in 7th row of event record
	i = 7
	!!! find number of jets
	n_jets = 0
	do
	if (K(I,1) /= 21) exit
	if ((K(I,2) == 21) .or. (abs(K(I,2)) <= 6)) then
	n_jets = n_jets + 1
	end if
	i = i + 1
	end do

	if (n_jets == 0) return
	allocate (JETS_ME(1:n_jets))
	allocate (pdum(1:n_jets,4))

	!!! transfer jets
	i = 7
	j = 1
	pdum = p
	do
	if (K(I,1) /= 21) exit
	if ((K(I,2) == 21) .or. (abs(K(I,2)).le.6)) then
	JETS_ME(j)= vector4_moving (pdum(I,4), &
	vector3_moving ( [pdum(I,1),pdum(I,2),pdum(I,3)] ))
	j = j + 1
	end if
	i = i + 1
	end do
	end subroutine get_ME_momenta_from_PYTHIA

	@ %def get_ME_momenta_from_PYTHIA
	@
	<<Shower PYTHIA6: public>>=
	public :: pylheo
	<<Shower PYTHIA6: procedures>>=
	!!!!!!!!!!PYTHIA STYLE!!!!!!!!!!!!!
	!!! originally PYLHEF subroutine from PYTHIA 6.4.22

	!C...Write out the showered event to a Les Houches Event File.

	subroutine pylheo (u_P2W)

	!C...Double precision and integer declarations.
	IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	IMPLICIT INTEGER(I-N)
	integer, intent(in) :: u_P2W

	!C...PYTHIA commonblock: only used to provide read/write units and version.
	common /PYPARS/ MSTP(200), PARP(200), MSTI(200), PARI(200)
	common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5)
	save /PYPARS/
	save /PYJETS/

	!C...User process initialization commonblock.
	!C...User process event common block.
	integer, parameter :: MAXPUP = 100, MAXNUP = 500
	integer :: IDBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP, LPRUP
	integer :: NUP, IDPRUP, IDUP, ISTUP, MOTHUP, ICOLUP
	real(double) :: EBMUP, XSECUP, XERRUP, XMAXUP
	real(double) :: XWGTUP, SCALUP, AQEDUP, AQCDUP, PUP, VTIMUP, SPINUP
	integer, parameter :: KSUSY1 = 1000000, KSUSY2 = 2000000
	common /HEPRUP/ &
	IDBMUP(2), EBMUP(2), PDFGUP(2), PDFSUP(2), IDWTUP, NPRUP, &
	XSECUP(MAXPUP), XERRUP(MAXPUP), XMAXUP(MAXPUP), LPRUP(MAXPUP)
	save /HEPRUP/
	common /HEPEUP/ &
	NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP, IDUP(MAXNUP), &
	ISTUP(MAXNUP), MOTHUP(2,MAXNUP), ICOLUP(2,MAXNUP), &
	PUP(5,MAXNUP), VTIMUP(MAXNUP), SPINUP(MAXNUP)
	save /HEPEUP/

	!C...Lines to read in assumed never longer than 200 characters.
	PARAMETER (MAXLEN=200)
	character(len=maxlen) :: string

	integer :: LEN, ndangling_color, ndangling_antic, ncolor

	!C...Format for reading lines.
	character(len=6) :: strfmt
	STRFMT='(A000)'
	write (STRFMT(3:5),'(I3)') MAXLEN

	!C...Rewind initialization and event files.
	rewind MSTP(161)
	rewind MSTP(162)

	!C...Write header info.
	write (u_P2W, "(A)") '<LesHouchesEvents version="1.0">'
	write (u_P2W, "(A)") "<!--"
	write (u_P2W, "(A,I1,A1,I3)") "File generated with PYTHIA ", &
	MSTP(181), ".", MSTP(182)
	write (u_P2W, "(A)") " and the WHIZARD2 interface"
	write (u_P2W, "(A)") "-->"

	!C...Loop until finds line beginning with "<init>" or "<init ".
	100 READ(MSTP(161),STRFMT,END=400,ERR=400) STRING
	IBEG=0
	110 IBEG=IBEG+1
	!C...Allow indentation.
	IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
	IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100

	!C...Read first line of initialization info and get number of processes.
	READ(MSTP(161),'(A)',END=400,ERR=400) STRING
	READ(STRING,*,ERR=400) IDBMUP(1),IDBMUP(2),EBMUP(1),EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP

	!C...Copy initialization lines, omitting trailing blanks.
	!C...Embed in <init> ... </init> block.
	WRITE(u_P2W,'(A)') '<init>'
	do IPR = 0, NPRUP
	IF(IPR.GT.0) READ(MSTP(161),'(A)',END=400,ERR=400) STRING
	LEN=MAXLEN+1
	120 LEN=LEN-1
	IF(LEN.GT.1.AND.STRING(LEN:LEN).EQ.' ') GOTO 120
	WRITE(u_P2W,'(A)',ERR=400) STRING(1:LEN)
	end DO
	write (u_P2W, "(A)") "</init>"

	!!! Find the numbers of entries of the <event block>
	NENTRIES = 0
	do I = 1, N
	if (K(I,1) == 1 .or. K(I,1) == 2 .or. K(I,1) == 21) then
	NENTRIES = NENTRIES + 1
	end if
	end do

	!C...Begin an <event> block. Copy event lines, omitting trailing blanks.
	write (u_P2W, "(A)") "<event>"
	write (u_P2W, *) NENTRIES, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP

	ndangling_color = 0
	ncolor = 0
	ndangling_antic = 0
	NANTIC = 0
	NNEXTC = 1 ! TODO find next free color number ??
	do I = 1, N
	if (signal_is_pending ()) return
	if ((K(I,1) >= 1 .and. K(I,1) <= 15) .or. (K(I,1) == 21)) then
	if ((K(I,2).eq.21) .or. (IABS(K(I,2)) <= 8) .or. &
	(IABS(K(I,2)) >= KSUSY1+1 .and. IABS(K(I,2)) <= KSUSY1+8) &
	.or. &
	(IABS(K(I,2)) >= KSUSY2+1 .and. IABS(K(I,2)) <= KSUSY2+8) .or. &
	(IABS(K(I,2)) >= 1000 .and. IABS(K(I,2)) <= 9999) ) then
	if (ndangling_color.eq.0 .and. ndangling_antic.eq.0) then
	! new color string
	! Gluon and gluino only color octets implemented so far
	if (K(I,2).eq.21 .or. K(I,2).eq.1000021) then
	ncolor = NNEXTC
	ndangling_color = ncolor
	NNEXTC = NNEXTC + 1
	NANTIC = NNEXTC
	ndangling_antic = NANTIC
	NNEXTC = NNEXTC + 1
	else if (K(I,2) .gt. 0) then ! particles to have color
	ncolor = NNEXTC
	ndangling_color = ncolor
	NANTIC = 0
	NNEXTC = NNEXTC + 1
	else if (K(I,2) .lt. 0) then ! antiparticles to have anticolor
	NANTIC = NNEXTC
	ndangling_antic = NANTIC
	ncolor = 0
	NNEXTC = NNEXTC + 1
	end if
	else if(K(I,1).eq.1) then
	! end of string
	ncolor = ndangling_antic
	NANTIC = ndangling_color
	ndangling_color = 0
	ndangling_antic = 0
	else
	! inside the string
	if(ndangling_color .ne. 0) then
	NANTIC = ndangling_color
	ncolor = NNEXTC
	ndangling_color = NNEXTC
	NNEXTC = NNEXTC +1
	else if(ndangling_antic .ne. 0) then
	ncolor = ndangling_antic
	NANTIC = NNEXTC
	ndangling_antic = NNEXTC
	NNEXTC = NNEXTC +1
	else
	print *, "ERROR IN PYLHEO"
	end if
	end if
	else
	ncolor = 0
	NANTIC = 0
	end if
	!!! As no intermediate are given out here, assume the
	!!! incoming partons to be the mothers
	write (u_P2W,*) K(I,2), K(I,1), K(I,3), K(I,3), &
	ncolor, NANTIC, (P(I,J),J=1,5), 0, -9
	end if
	end do

	!C..End the <event> block. Loop back to look for next event.
	write (MSTP(163), "(A)") "</event>"

	!C...Successfully reached end of event loop: write closing tag
	!C...and remove temporary intermediate files (unless asked not to).
	write (MSTP(163), "(A)") "</LesHouchesEvents>"
	return

	!!C...Error exit.
	400 write(,) ' PYLHEO file joining failed!'

	return
	end subroutine pylheo

	@ %def pylheo
	@
	<<Shower PYTHIA6: public>>=
	public :: pythia6_setup_lhe_io_units
	<<Shower PYTHIA6: procedures>>=
	subroutine pythia6_setup_lhe_io_units (u_W2P, u_P2W)
	integer, intent(out) :: u_W2P, u_P2W
	logical, parameter :: debug = .false., to_file = .false.
	character(len=10) :: buffer
	u_W2P = free_unit ()
	if (debug) then
	open (unit=u_W2P, status="replace", file="whizardout.lhe", &
	action="readwrite")
	else
	open (unit=u_W2P, status="scratch", action="readwrite")
	end if
	call w2p_write_lhef_event (u_W2P)
	rewind (u_W2P)
	write (buffer, "(I10)") u_W2P
	call PYGIVE ("MSTP(161)=" // buffer) !!! Unit for PYUPIN (LHA)
	call PYGIVE ("MSTP(162)=" // buffer) !!! Unit for PYUPEV (LHA)
	u_P2W = free_unit ()
	write (buffer, "(I10)") u_P2W
	call PYGIVE ("MSTP(163)=" // buffer)
	if (debug .and. to_file) then
	open (unit=u_P2W, file="pythiaout2.lhe", status="replace", &
	action="readwrite")
	else
	open (unit=u_P2W, status="scratch", action="readwrite")
	end if
	end subroutine pythia6_setup_lhe_io_units

	@ %def pythia6_setup_lhe_io_units
	@
	<<Shower PYTHIA6: public>>=
	public :: pythia6_set_config
	<<Shower PYTHIA6: procedures>>=
	subroutine pythia6_set_config (pygive_all)
	type(string_t), intent(in) :: pygive_all
	type(string_t) :: pygive_remaining, pygive_partial
	if (len (pygive_all) > 0) then
	pygive_remaining = pygive_all
	do while (len (pygive_remaining)>0)
	call split (pygive_remaining, pygive_partial, ";")
	call PYGIVE (char (pygive_partial))
	end do
	if (pythia6_get_error() /= 0) then
	call msg_fatal &
	(" PYTHIA6 did not recognize ps_PYTHIA_PYGIVE setting.")
	end if
	end if
	end subroutine pythia6_set_config

	@ %def pythia_6_set_config
	@ Exchanging error messages with PYTHIA6.
	<<Shower PYTHIA6: public>>=
	public :: pythia6_set_error
	<<Shower PYTHIA6: procedures>>=
	subroutine pythia6_set_error (mstu23)
	IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	IMPLICIT INTEGER(I-N)
	COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	SAVE/PYDAT1/
	integer, intent(in) :: mstu23
	MSTU(23) = mstu23
	end subroutine pythia6_set_error

	@ %def pythia6_set_error
	@
	<<Shower PYTHIA6: public>>=
	public :: pythia6_get_error
	<<Shower PYTHIA6: procedures>>=
	function pythia6_get_error () result (mstu23)
	IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	IMPLICIT INTEGER(I-N)
	COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	SAVE/PYDAT1/
	integer :: mstu23
	mstu23 = MSTU(23)
	end function pythia6_get_error

	@ %def pythia6_get_error
	@
	<<Shower PYTHIA6: public>>=
	public :: pythia6_set_verbose
	<<Shower PYTHIA6: procedures>>=
	subroutine pythia6_set_verbose (verbose)
	logical, intent(in) :: verbose
	if (verbose) then
	call PYGIVE ('MSTU(13)=1')
	else
	call PYGIVE ('MSTU(12)=12345') !!! No title page is written
	call PYGIVE ('MSTU(13)=0') !!! No information is written
	end if
	end subroutine pythia6_set_verbose

	@ %def pythia6_set_verbose
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	<<[[pythia6_up.f]]>>=
	C*********************************************************************
	C*********************************************************************
	C* **
	C* Mar 2011 **
	C* **
	C* The Lund Monte Carlo **
	C* **
	C* PYTHIA version 6.4 **
	C* **
	C* Torbjorn Sjostrand **
	C* Department of Theoretical Physics **
	C* Lund University **
	C* Solvegatan 14A, S-223 62 Lund, Sweden **
	C* E-mail torbjorn@thep.lu.se **
	C* **
	C* SUSY and Technicolor parts by **
	C* Stephen Mrenna **
	C* Computing Division **
	C* Generators and Detector Simulation Group **
	C* Fermi National Accelerator Laboratory **
	C* MS 234, Batavia, IL 60510, USA **
	C* phone + 1 - 630 - 840 - 2556 **
	C* E-mail mrenna@fnal.gov **
	C* **
	C* New multiple interactions and more SUSY parts by **
	C* Peter Skands **
	C* CERN/PH, CH-1211 Geneva, Switzerland **
	C* phone +41 - 22 - 767 2447 **
	C* E-mail peter.skands@cern.ch **
	C* **
	C* Several parts are written by Hans-Uno Bengtsson **
	C* PYSHOW is written together with Mats Bengtsson **
	C* PYMAEL is written by Emanuel Norrbin **
	C* advanced popcorn baryon production written by Patrik Eden **
	C* code for virtual photons mainly written by Christer Friberg **
	C* code for low-mass strings mainly written by Emanuel Norrbin **
	C* Bose-Einstein code mainly written by Leif Lonnblad **
	C* CTEQ parton distributions are by the CTEQ collaboration **
	C* GRV 94 parton distributions are by Glueck, Reya and Vogt **
	C* SaS photon parton distributions together with Gerhard Schuler **
	C* g + g and q + qbar -> t + tbar + H code by Zoltan Kunszt **
	C* MSSM Higgs mass calculation code by M. Carena, **
	C* J.R. Espinosa, M. Quiros and C.E.M. Wagner **
	C* UED implementation by M. Elkacimi, D. Goujdami, H. Przysiezniak **
	C* PYGAUS adapted from CERN library (K.S. Kolbig) **
	C* NRQCD/colour octet production of onium by S. Wolf **
	C* **
	C* The latest program version and documentation is found on WWW **
	C* http://www.thep.lu.se/~torbjorn/Pythia.html **
	C* **
	C* Copyright Torbjorn Sjostrand, Lund 2010 **
	C* **
	C*********************************************************************
	C*********************************************************************

	C...UPINIT
	C...Dummy routine, to be replaced by a user implementing external
	C...processes. Is supposed to fill the HEPRUP commonblock with info
	C...on incoming beams and allowed processes.

	C...New example: handles a standard Les Houches Events File.

	SUBROUTINE UPINIT

	C...Double precision and integer declarations.
	IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	IMPLICIT INTEGER(I-N)

	C...PYTHIA commonblock: only used to provide read unit MSTP(161).
	COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	SAVE /PYPARS/

	C...User process initialization commonblock.
	INTEGER MAXPUP
	PARAMETER (MAXPUP=100)
	INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
	DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
	COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
	&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
	&LPRUP(MAXPUP)
	SAVE /HEPRUP/

	C...Lines to read in assumed never longer than 200 characters.
	PARAMETER (MAXLEN=200)
	CHARACTER*(MAXLEN) STRING

	C...Format for reading lines.
	CHARACTER(len=6) STRFMT
	STRFMT='(A000)'
	WRITE(STRFMT(3:5),'(I3)') MAXLEN

	C...Loop until finds line beginning with "<init>" or "<init ".
	100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
	IBEG=0
	110 IBEG=IBEG+1
	C...Allow indentation.
	IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
	IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
	&STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100

	C...Read first line of initialization info.
	READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
	&EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP

	C...Read NPRUP subsequent lines with information on each process.
	DO 120 IPR=1,NPRUP
	READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
	& XMAXUP(IPR),LPRUP(IPR)
	120 CONTINUE
	RETURN

	C...Error exit: give up if initalization does not work.
	130 WRITE(,) ' Failed to read LHEF initialization information.'
	WRITE(,) ' Event generation will be stopped.'
	CALL PYSTOP(12)

	RETURN
	END

	C...Old example: handles a simple Pythia 6.4 initialization file.

	c SUBROUTINE UPINIT

	C...Double precision and integer declarations.
	c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	c IMPLICIT INTEGER(I-N)

	C...Commonblocks.
	c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	c SAVE /PYDAT1/,/PYPARS/

	C...User process initialization commonblock.
	c INTEGER MAXPUP
	c PARAMETER (MAXPUP=100)
	c INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
	c DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
	c COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
	c &IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
	c &LPRUP(MAXPUP)
	c SAVE /HEPRUP/

	C...Read info from file.
	c IF(MSTP(161).GT.0) THEN
	c READ(MSTP(161),*,END=110,ERR=110) IDBMUP(1),IDBMUP(2),EBMUP(1),
	c & EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
	c DO 100 IPR=1,NPRUP
	c READ(MSTP(161),*,END=110,ERR=110) XSECUP(IPR),XERRUP(IPR),
	c & XMAXUP(IPR),LPRUP(IPR)
	c 100 CONTINUE
	c RETURN
	C...Error or prematurely reached end of file.
	c 110 WRITE(MSTU(11),5000)
	c STOP

	C...Else not implemented.
	c ELSE
	c WRITE(MSTU(11),5100)
	c STOP
	c ENDIF

	C...Format for error printout.
	c 5000 FORMAT(1X,'Error: UPINIT routine failed to read information'/
	c &1X,'Execution stopped!')
	c 5100 FORMAT(1X,'Error: You have not implemented UPINIT routine'/
	c &1X,'Dummy routine in PYTHIA file called instead.'/
	c &1X,'Execution stopped!')

	c RETURN
	c END

	C*********************************************************************

	C...UPEVNT
	C...Dummy routine, to be replaced by a user implementing external
	C...processes. Depending on cross section model chosen, it either has
	C...to generate a process of the type IDPRUP requested, or pick a type
	C...itself and generate this event. The event is to be stored in the
	C...HEPEUP commonblock, including (often) an event weight.

	C...New example: handles a standard Les Houches Events File.

	SUBROUTINE UPEVNT

	C...Double precision and integer declarations.
	IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	IMPLICIT INTEGER(I-N)

	C...PYTHIA commonblock: only used to provide read unit MSTP(162).
	COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	SAVE /PYPARS/

	C...Added by WHIZARD
	COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	SAVE/PYDAT1/

	C...User process event common block.
	INTEGER MAXNUP
	PARAMETER (MAXNUP=500)
	INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	&ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	&VTIMUP(MAXNUP),SPINUP(MAXNUP)
	SAVE /HEPEUP/

	C...Lines to read in assumed never longer than 200 characters.
	PARAMETER (MAXLEN=200)
	CHARACTER*(MAXLEN) STRING

	C...Format for reading lines.
	CHARACTER(len=6) STRFMT
	STRFMT='(A000)'
	WRITE(STRFMT(3:5),'(I3)') MAXLEN

	C...Loop until finds line beginning with "<event>" or "<event ".
	100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
	IBEG=0
	110 IBEG=IBEG+1
	C...Allow indentation.
	IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
	IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
	&STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100

	C...Read first line of event info.
	READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
	&AQEDUP,AQCDUP

	C...Read NUP subsequent lines with information on each particle.
	DO 120 I=1,NUP
	READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
	& MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
	& (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
	120 CONTINUE
	RETURN

	C...Error exit, typically when no more events.
	130 CONTINUE
	C WRITE(,) ' Failed to read LHEF event information.'
	C WRITE(,) ' Will assume end of file has been reached.'
	NUP=0
	MSTI(51)=1
	C...Added by WHIZARD, mark these failed events
	MSTU(23)=1

	RETURN
	END

	C...Old example: handles a simple Pythia 6.4 event file.

	c SUBROUTINE UPEVNT

	C...Double precision and integer declarations.
	c IMPLICIT DOUBLE PRECISION(A-H, O-Z)
	c IMPLICIT INTEGER(I-N)

	C...Commonblocks.
	c COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
	c COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
	c SAVE /PYDAT1/,/PYPARS/

	C...User process event common block.
	c INTEGER MAXNUP
	c PARAMETER (MAXNUP=500)
	c INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
	c DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
	c COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
	c &ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
	c &VTIMUP(MAXNUP),SPINUP(MAXNUP)
	c SAVE /HEPEUP/

	C...Read info from file.
	c IF(MSTP(162).GT.0) THEN
	c READ(MSTP(162),*,END=110,ERR=110) NUP,IDPRUP,XWGTUP,SCALUP,
	c & AQEDUP,AQCDUP
	c DO 100 I=1,NUP
	c READ(MSTP(162),*,END=110,ERR=110) IDUP(I),ISTUP(I),
	c & MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
	c & (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
	c 100 CONTINUE
	c RETURN
	C...Special when reached end of file or other error.
	c 110 NUP=0

	C...Else not implemented.
	c ELSE
	c WRITE(MSTU(11),5000)
	c STOP
	c ENDIF

	C...Format for error printout.
	c 5000 FORMAT(1X,'Error: You have not implemented UPEVNT routine'/
	c &1X,'Dummy routine in PYTHIA file called instead.'/
	c &1X,'Execution stopped!')

	c RETURN
	c END

	C*********************************************************************

	C...UPVETO
	C...Dummy routine, to be replaced by user, to veto event generation
	C...on the parton level, after parton showers but before multiple
	C...interactions, beam remnants and hadronization is added.
	C...If resonances like W, Z, top, Higgs and SUSY particles are handed
	C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
	C...be undecayed at this stage; if decayed their decay products will
	C...have been allowed to shower.

	C...All partons at the end of the shower phase are stored in the
	C...HEPEVT commonblock. The interesting information is
	C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
	C...IDHEP(I) = the particle ID code according to PDG conventions,
	C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
	C...All ISTHEP entries are 1, while the rest is zeroed.

	C...The user decision is to be conveyed by the IVETO value.
	C...IVETO = 0 : retain current event and generate in full;
	C... = 1 : abort generation of current event and move to next.

	SUBROUTINE UPVETO(IVETO)

	C...HEPEVT commonblock.
	PARAMETER (NMXHEP=4000)
	COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
	&JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
	DOUBLE PRECISION PHEP,VHEP
	SAVE /HEPEVT/

	C...Next few lines allow you to see what info PYVETO extracted from
	C...the full event record for the first two events.
	C...Delete if you don't want it.
	DATA NLIST/0/
	SAVE NLIST
	IF(NLIST.LE.2) THEN
	WRITE(,) ' Full event record at time of UPVETO call:'
	CALL PYLIST(1)
	WRITE(,) ' Part of event record made available to UPVETO:'
	CALL PYLIST(5)
	NLIST=NLIST+1
	ENDIF

	C...Make decision here.
	IVETO = 0

	RETURN
	END

	@ %def pythia6_up.f
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Matching}
	\subsection{MLM matching}
	<<[[mlm_matching.f90]]>>=
	<<File header>>

	module mlm_matching

	<<Use kinds with double>>
	<<Use strings>>
	use io_units
	use constants
	use format_utils, only: write_separator
	use diagnostics
	use file_utils
	use lorentz
	use shower_base
	use variables

	<<Standard module head>>

	<<MLM matching: public>>

	<<MLM matching: types>>

	contains

	<<MLM matching: procedures>>

	end module mlm_matching
	@ %def mlm_matching
	<<MLM matching: public>>=
	public :: mlm_matching_settings_t
	<<MLM matching: types>>=
	type, extends (matching_settings_t) :: mlm_matching_settings_t
	real(default) :: mlm_Qcut_ME = one
	real(default) :: mlm_Qcut_PS = one
	real(default) :: mlm_ptmin, mlm_etamax, mlm_Rmin, mlm_Emin
	real(default) :: mlm_ETclusfactor = 0.2_default
	real(default) :: mlm_ETclusminE = five
	real(default) :: mlm_etaclusfactor = one
	real(default) :: mlm_Rclusfactor = one
	real(default) :: mlm_Eclusfactor = one
	integer :: kt_imode_hadronic = 4313
	integer :: kt_imode_leptonic = 1111
	integer :: mlm_nmaxMEjets = 0
	contains
	<<MLM matching: MLM matching: TBP>>
	end type mlm_matching_settings_t

	@ %def mlm_matching_settings_t
	@
	<<MLM matching: MLM matching: TBP>>=
	procedure :: init => mlm_matching_settings_init
	<<MLM matching: procedures>>=
	subroutine mlm_matching_settings_init (settings, var_list)
	class(mlm_matching_settings_t), intent(out) :: settings
	type(var_list_t), intent(in) :: var_list
	settings%mlm_Qcut_ME = &
	var_list%get_rval (var_str ("mlm_Qcut_ME"))
	settings%mlm_Qcut_PS = &
	var_list%get_rval (var_str ("mlm_Qcut_PS"))
	settings%mlm_ptmin = &
	var_list%get_rval (var_str ("mlm_ptmin"))
	settings%mlm_etamax = &
	var_list%get_rval (var_str ("mlm_etamax"))
	settings%mlm_Rmin = &
	var_list%get_rval (var_str ("mlm_Rmin"))
	settings%mlm_Emin = &
	var_list%get_rval (var_str ("mlm_Emin"))
	settings%mlm_nmaxMEjets = &
	var_list%get_ival (var_str ("mlm_nmaxMEjets"))

	settings%mlm_ETclusfactor = &
	var_list%get_rval (var_str ("mlm_ETclusfactor"))
	settings%mlm_ETclusminE = &
	var_list%get_rval (var_str ("mlm_ETclusminE"))
	settings%mlm_etaclusfactor = &
	var_list%get_rval (var_str ("mlm_etaclusfactor"))
	settings%mlm_Rclusfactor = &
	var_list%get_rval (var_str ("mlm_Rclusfactor"))
	settings%mlm_Eclusfactor = &
	var_list%get_rval (var_str ("mlm_Eclusfactor"))
	end subroutine mlm_matching_settings_init

	@ %def mlm_matching_settings_init
	@
	<<MLM matching: MLM matching: TBP>>=
	procedure :: write => mlm_matching_settings_write
	<<MLM matching: procedures>>=
	subroutine mlm_matching_settings_write (settings, unit)
	class(mlm_matching_settings_t), intent(in) :: settings
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(3x,A,ES19.12)") &
	"mlm_Qcut_ME = ", settings%mlm_Qcut_ME
	write (u, "(3x,A,ES19.12)") &
	"mlm_Qcut_PS = ", settings%mlm_Qcut_PS
	write (u, "(3x,A,ES19.12)") &
	"mlm_ptmin = ", settings%mlm_ptmin
	write (u, "(3x,A,ES19.12)") &
	"mlm_etamax = ", settings%mlm_etamax
	write (u, "(3x,A,ES19.12)") &
	"mlm_Rmin = ", settings%mlm_Rmin
	write (u, "(3x,A,ES19.12)") &
	"mlm_Emin = ", settings%mlm_Emin
	write (u, "(3x,A,1x,I0)") &
	"mlm_nmaxMEjets = ", settings%mlm_nmaxMEjets
	write (u, "(3x,A,ES19.12)") &
	"mlm_ETclusfactor (D=0.2) = ", settings%mlm_ETclusfactor
	write (u, "(3x,A,ES19.12)") &
	"mlm_ETclusminE (D=5.0) = ", settings%mlm_ETclusminE
	write (u, "(3x,A,ES19.12)") &
	"mlm_etaclusfactor (D=1.0) = ", settings%mlm_etaClusfactor
	write (u, "(3x,A,ES19.12)") &
	"mlm_Rclusfactor (D=1.0) = ", settings%mlm_RClusfactor
	write (u, "(3x,A,ES19.12)") &
	"mlm_Eclusfactor (D=1.0) = ", settings%mlm_EClusfactor
	end subroutine mlm_matching_settings_write

	@ %def mlm_matching_settings_write
	@ This is a container for the (colored) parton momenta as well as the
	jet momenta.
	<<MLM matching: public>>=
	public :: mlm_matching_data_t
	<<MLM matching: types>>=
	type, extends (matching_data_t) :: mlm_matching_data_t
	type(vector4_t), dimension(:), allocatable, public :: P_ME
	type(vector4_t), dimension(:), allocatable, public :: P_PS
	type(vector4_t), dimension(:), allocatable, private :: JETS_ME
	type(vector4_t), dimension(:), allocatable, private :: JETS_PS
	end type mlm_matching_data_t

	@ %def mlm_matching_data_t
	@
	<<MLM matching: public>>=
	public :: mlm_matching_data_write
	<<MLM matching: procedures>>=
	subroutine mlm_matching_data_write (data, unit)
	type(mlm_matching_data_t), intent(in) :: data
	integer, intent(in), optional :: unit
	integer :: i
	integer :: u
	u = given_output_unit (unit); if (u < 0) return

	write (u, "(1x,A)") "MLM matching data:"
	write (u, "(3x,A)") "Momenta of ME partons:"
	if (allocated (data%P_ME)) then
	do i = 1, size (data%P_ME)
	write (u, "(4x)", advance = "no")
	call vector4_write (data%P_ME(i), unit = u)
	end do
	else
	write (u, "(5x,A)") "[empty]"
	end if
	call write_separator (u)
	write (u, "(3x,A)") "Momenta of ME jets:"
	if (allocated (data%JETS_ME)) then
	do i = 1, size (data%JETS_ME)
	write (u, "(4x)", advance = "no")
	call vector4_write (data%JETS_ME(i), unit = u)
	end do
	else
	write (u, "(5x,A)") "[empty]"
	end if
	call write_separator (u)
	write(u, "(3x,A)") "Momenta of shower partons:"
	if (allocated (data%P_PS)) then
	do i = 1, size (data%P_PS)
	write (u, "(4x)", advance = "no")
	call vector4_write (data%P_PS(i), unit = u)
	end do
	else
	write (u, "(5x,A)") "[empty]"
	end if
	call write_separator (u)
	write (u, "(3x,A)") "Momenta of shower jets:"
	if (allocated (data%JETS_PS)) then
	do i = 1, size (data%JETS_PS)
	write (u, "(4x)", advance = "no")
	call vector4_write (data%JETS_PS(i), unit = u)
	end do
	else
	write (u, "(5x,A)") "[empty]"
	end if
	call write_separator (u)
	end subroutine mlm_matching_data_write

	@ %def mlm_matching_data_write
	@
	<<MLM matching: public>>=
	public :: mlm_matching_data_final
	<<MLM matching: procedures>>=
	subroutine mlm_matching_data_final (data)
	type(mlm_matching_data_t), intent(inout) :: data
	! if (allocated (data%P_ME)) deallocate(data%P_ME)
	if (allocated (data%P_PS)) deallocate (data%P_PS)
	if (allocated (data%JETS_ME)) deallocate(data%JETS_ME)
	if (allocated (data%JETS_PS)) deallocate(data%JETS_PS)
	end subroutine mlm_matching_data_final

	@ %def mlm_matching_data_final
	@
	<<MLM matching: public>>=
	public :: mlm_matching_apply
	<<MLM matching: procedures>>=
	subroutine mlm_matching_apply (data, settings, vetoed)
	type(mlm_matching_data_t), intent(inout) :: data
	type(mlm_matching_settings_t), intent(in) :: settings
	logical, intent(out) :: vetoed

	integer :: i, j
	integer :: n_jets_ME, n_jets_PS, n_jets_PS_atycut
	real(double) :: ycut
	real(double), dimension(:, :), allocatable :: PP
	real(double), dimension(:), allocatable :: Y
	real(double), dimension(:,:), allocatable :: P_JETS
	real(double), dimension(:,:), allocatable :: P_ME
	integer, dimension(:), allocatable :: JET
	integer :: NJET, NSUB
	integer :: imode
	!!! TODO: (bcn 2014-03-26) Why is ECUT hard coded to 1?
	!!! It is the denominator of the KT measure. Candidate for removal
	real(double) :: ECUT = 1._double
	integer :: ip1,ip2

	! KTCLUS COMMON BLOCK
	INTEGER NMAX,NUM,HIST
	PARAMETER (NMAX=512)
	DOUBLE PRECISION P,KT,KTP,KTS,ETOT,RSQ,KTLAST
	COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
	KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM

	vetoed = .true.
	if (signal_is_pending ()) return

	<<Set [[n_jets_ME/PS]] from [[data]] (or equal zero)>>

	<<Jet clustering for partons after matrix element>>

	<<Jet clustering for partons after shower>>

	<<Veto: too many or not enough jets after PS>>

	<<Cluster ME jets with PS jets one at a time>>

	vetoed = .false.
	999 continue
	end subroutine mlm_matching_apply

	@ %def mlm_matching_apply
	@
	<<Set [[n_jets_ME/PS]] from [[data]] (or equal zero)>>=
	if (allocated (data%P_ME)) then
	! print *, "number of partons after ME: ", size(data%P_ME)
	n_jets_ME = size (data%P_ME)
	else
	n_jets_ME = 0
	end if
	if (allocated (data%p_PS)) then
	! print *, "number of partons after PS: ", size(data%p_PS)
	n_jets_PS = size (data%p_PS)
	else
	n_jets_PS = 0
	end if
	@
	<<Jet clustering for partons after matrix element>>=
	if (n_jets_ME > 0) then
	ycut = (settings%mlm_ptmin)**2
	allocate (PP(1:4, 1:N_jets_ME))
	do i = 1, n_jets_ME
	PP(1:3,i) = data%p_ME(i)%p(1:3)
	PP(4,i) = data%p_ME(i)%p(0)
	end do

	<<Set [[imode]] for lepton or hadron collisions>>

	allocate (P_ME(1:4,1:n_jets_ME))
	allocate (JET(1:n_jets_ME))
	allocate (Y(1:n_jets_ME))

	if (signal_is_pending ()) return
	call KTCLUR (imode, PP, n_jets_ME, &
	dble (settings%mlm_Rclusfactor * settings%mlm_Rmin), ECUT, y, *999)
	call KTRECO (1, PP, n_jets_ME, ECUT, ycut, ycut, P_ME, JET, &
	NJET, NSUB, *999)

	n_jets_ME = NJET
	if (NJET > 0) then
	allocate (data%JETS_ME (1:NJET))
	do i = 1, NJET
	data%JETS_ME(i) = vector4_moving (REAL(P_ME(4,i), default), &
	vector3_moving([REAL(P_ME(1,i), default), &
	REAL(P_ME(2,i), default), REAL(P_ME(3,i), default)]))
	end do
	end if
	deallocate (P_ME)
	deallocate (JET)
	deallocate (Y)
	deallocate (PP)
	end if
	@
	<<Jet clustering for partons after shower>>=
	if (n_jets_PS > 0) then
	ycut = (settings%mlm_ptmin + max (settings%mlm_ETclusminE, &
	settings%mlm_ETclusfactor * settings%mlm_ptmin))**2
	allocate (PP(1:4, 1:n_jets_PS))
	do i = 1, n_jets_PS
	PP(1:3,i) = data%p_PS(i)%p(1:3)
	PP(4,i) = data%p_PS(i)%p(0)
	end do

	<<Set [[imode]] for lepton or hadron collisions>>

	allocate (P_JETS(1:4,1:n_jets_PS))
	allocate (JET(1:n_jets_PS))
	allocate (Y(1:n_jets_PS))

	if (signal_is_pending ()) return
	call KTCLUR (imode, PP, n_jets_PS, &
	dble (settings%mlm_Rclusfactor * settings%mlm_Rmin), &
	ECUT, y, *999)
	call KTRECO (1, PP, n_jets_PS, ECUT, ycut, ycut, P_JETS, JET, &
	NJET, NSUB, *999)
	n_jets_PS_atycut = NJET
	if (n_jets_ME == settings%mlm_nmaxMEjets .and. NJET > 0) then
	! print *, " resetting ycut to ", Y(settings%mlm_nmaxMEjets)
	ycut = y(settings%mlm_nmaxMEjets)
	call KTRECO (1, PP, n_jets_PS, ECUT, ycut, ycut, P_JETS, JET, &
	NJET, NSUB, *999)
	end if

	! !Sample of code for a FastJet interface
	! palg = 1d0 ! 1.0d0 = kt, 0.0d0 = Cam/Aachen, -1.0d0 = anti-kt
	! R = 0.7_double ! radius parameter
	! f = 0.75_double ! overlap threshold
	! !call fastjetppgenkt(PP,n,R,palg,P_JETS,NJET) ! KT-Algorithm
	! !call fastjetsiscone(PP,n,R,f,P_JETS,NJET) ! SiSCone-Algorithm

	if (NJET > 0) then
	allocate (data%JETS_PS(1:NJET))
	do i = 1, NJET
	data%JETS_PS(i) = vector4_moving (REAL(P_JETS(4,i), default), &
	vector3_moving([REAL(P_JETS(1,i), default), &
	REAL(P_JETS(2,i), default), REAL(P_JETS(3,i), default)]))
	end do
	end if

	deallocate (P_JETS)
	deallocate (JET)
	deallocate (Y)
	else
	n_jets_PS_atycut = 0
	end if
	@
	<<Set [[imode]] for lepton or hadron collisions>>=
	if (data%is_hadron_collision) then
	imode = settings%kt_imode_hadronic
	else
	imode = settings%kt_imode_leptonic
	end if
	@
	<<Veto: too many or not enough jets after PS>>=
	if (n_jets_PS_atycut < n_jets_ME) then
	! print *, "DISCARDING: Not enough PS jets: ", n_jets_PS_atycut
	return
	end if
	if (n_jets_PS_atycut > n_jets_ME .and. n_jets_ME /= settings%mlm_nmaxMEjets) then
	! print *, "DISCARDING: Too many PS jets: ", n_jets_PS_atycut
	return
	end if
	@
	<<Cluster ME jets with PS jets one at a time>>=
	if (allocated(data%JETS_PS)) then
	! print *, "number of jets after PS: ", size(data%JETS_PS)
	n_jets_PS = size (data%JETS_PS)
	else
	n_jets_PS = 0
	end if
	if (n_jets_ME > 0 .and. n_jets_PS > 0) then
	n_jets_PS = size (data%JETS_PS)
	if (allocated (PP)) deallocate(PP)
	allocate (PP(1:4, 1:n_jets_PS + 1))
	do i = 1, n_jets_PS
	if (signal_is_pending ()) return
	PP(1:3,i) = data%JETS_PS(i)%p(1:3)
	PP(4,i) = data%JETS_PS(i)%p(0)
	end do
	if (allocated (Y)) deallocate(Y)
	allocate (Y(1:n_jets_PS + 1))
	y = zero
	do i = 1, n_jets_ME
	PP(1:3,n_jets_PS + 2 - i) = data%JETS_ME(i)%p(1:3)
	PP(4,n_jets_PS + 2 - i) = data%JETS_ME(i)%p(0)
	!!! This makes more sense than hardcoding
	! call KTCLUS (4313, PP, (n_jets_PS + 2 - i), 1.0_double, Y, *999)
	call KTCLUR (imode, PP, (n_jets_PS + 2 - i), &
	dble (settings%mlm_Rclusfactor * settings%mlm_Rmin), &
	ECUT, y, *999)
	if (0.99 * y(n_jets_PS + 1 - (i - 1)).gt.ycut) then
	! print *, "DISCARDING: Jet ", i, " not clusterd"
	return
	end if
	!!! search for and remove PS jet clustered with ME Jet
	ip1 = HIST(n_jets_PS + 2 - i) / NMAX
	ip2 = mod(hist(n_jets_PS + 2 - i), NMAX)
	if ((ip2 /= n_jets_PS + 2 - i) .or. (ip1 <= 0)) then
	! print *, "DISCARDING: Jet ", i, " not clustered ", ip1, ip2, &
	! hist(n_jets_PS + 2 - i)
	return
	else
	! print *, "PARTON clustered", ip1, ip2, hist(n_jets_PS + 2 - i)
	PP(:,IP1) = zero
	do j = IP1, n_jets_PS - i
	PP(:, j) = PP(:,j + 1)
	end do
	end if
	end do
	end if
	@
	<<MLM matching: procedures>>=
	!C-----------------------------------------------------------------------
	!C-----------------------------------------------------------------------
	!C-----------------------------------------------------------------------
	!C KTCLUS: written by Mike Seymour, July 1992.
	!C Last modified November 2000.
	!C Please send comments or suggestions to Mike.Seymour@rl.ac.uk
	!C
	!C This is a general-purpose kt clustering package.
	!C It can handle ee, ep and pp collisions.
	!C It is loosely based on the program of Siggi Bethke.
	!C
	!C The time taken (on a 10MIP machine) is (0.2microsec)N*3
	!C where N is the number of particles.
	!C Over 90 percent of this time is used in subroutine KTPMIN, which
	!C simply finds the minimum member of a one-dimensional array.
	!C It is well worth thinking about optimization: on the SPARCstation
	!C a factor of two increase was obtained simply by increasing the
	!C optimization level from its default value.
	!C
	!C The approach is to separate the different stages of analysis.
	!C KTCLUS does all the clustering and records a merging history.
	!C It returns a simple list of the y values at which each merging
	!C occured. Then the following routines can be called to give extra
	!C information on the most recently analysed event.
	!C KTCLUR is identical but includes an R parameter, see below.
	!C KTYCUT gives the number of jets at each given YCUT value.
	!C KTYSUB gives the number of sub-jets at each given YCUT value.
	!C KTBEAM gives same info as KTCLUS but only for merges with the beam
	!C KTJOIN gives same info as KTCLUS but for merges of sub-jets.
	!C KTRECO reconstructs the jet momenta at a given value of YCUT.
	!C It also gives information on which jets at scale YCUT belong to
	!C which macro-jets at scale YMAC, for studying sub-jet properties.
	!C KTINCL reconstructs the jet momenta according to the inclusive jet
	!C definition of Ellis and Soper.
	!C KTISUB, KTIJOI and KTIREC are like KTYSUB, KTJOIN and KTRECO,
	!C except that they only apply to one inclusive jet at a time,
	!C with the pt of that jet automatically used for ECUT.
	!C KTWICH gives a list of which particles ended up in which jets.
	!C KTWCHS gives the same thing, but only for subjets.
	!C Note that the numbering of jets used by these two routines is
	!C guaranteed to be the same as that used by KTRECO.
	!C
	!C The collision type and analysis type are indicated by the first
	!C argument of KTCLUS. IMODE=<TYPE><ANGLE><MONO><RECOM> where
	!C TYPE: 1=>ee, 2=>ep with p in -z direction, 3=>pe, 4=>pp
	!C ANGLE: 1=>angular kt def., 2=>DeltaR, 3=>f(DeltaEta,DeltaPhi)
	!C where f()=2(cosh(eta)-cos(phi)) is the QCD emission metric
	!C MONO: 1=>derive relative pseudoparticle angles from jets
	!C 2=>monotonic definitions of relative angles
	!C RECOM: 1=>E recombination scheme, 2=>pt scheme, 3=>pt**2 scheme
	!C
	!C There are also abbreviated forms for the most common combinations:
	!C IMODE=1 => E scheme in e+e- (=1111)
	!C 2 => E scheme in ep (=2111)
	!C 3 => E scheme in pe (=3111)
	!C 4 => E scheme in pp (=4111)
	!C 5 => covariant E scheme in pp (=4211)
	!C 6 => covariant pt-scheme in pp (=4212)
	!C 7 => covariant monotonic pt**2-scheme in pp (=4223)
	!C
	!C KTRECO no longer needs to reconstruct the momenta according to the
	!C same recombination scheme in which they were clustered. Its first
	!C argument gives the scheme, taking the same values as RECOM above.
	!C
	!C Note that unlike previous versions, all variables which hold y
	!C values have been named in a consistent way:
	!C Y() is the output scale at which jets were merged,
	!C YCUT is the input scale at which jets should be counted, and
	!C jet-momenta reconstructed etc,
	!C YMAC is the input macro-jet scale, used in determining whether
	!C or not each jet is a sub-jet.
	!C The original scheme defined in our papers is equivalent to always
	!C setting YMAC=1.
	!C Whenever a YCUT or YMAC variable is used, it is rounded down
	!C infinitesimally, so that for example, setting YCUT=Y(2) refers
	!C to the scale where the event is 2-jet, even if rounding errors
	!C have shifted its value slightly.
	!C
	!C An R parameter can be used in hadron-hadron collisions by
	!C calling KTCLUR instead of KTCLUS. This is as suggested by
	!C Ellis and Soper, but implemented slightly differently,
	!C as in M.H. Seymour, LU TP 94/2 (submitted to Nucl. Phys. B.).
	!C R**2 multiplies the single Kt everywhere it is used.
	!C Calling KTCLUR with R=1 is identical to calling KTCLUS.
	!C R plays a similar role to the jet radius in a cone-type algorithm,
	!C but is scaled up by about 40% (ie R=0.7 in a cone algorithm is
	!C similar to this algorithm with R=1).
	!C Note that R.EQ.1 must be used for the e+e- and ep versions,
	!C and is strongly recommended for the hadron-hadron version.
	!C However, R values smaller than 1 have been found to be useful for
	!C certain applications, particularly the mass reconstruction of
	!C highly-boosted colour-singlets such as high-pt hadronic Ws,
	!C as in M.H. Seymour, LU TP 93/8 (to appear in Z. Phys. C.).
	!C Situations in which R<1 is useful are likely to also be those in
	!C which the inclusive reconstruction method is more useful.
	!C
	!C Also included is a set of routines for doing Lorentz boosts:
	!C KTLBST finds the boost matrix to/from the cm frame of a 4-vector
	!C KTRROT finds the rotation matrix from one vector to another
	!C KTMMUL multiplies together two matrices
	!C KTVMUL multiplies a vector by a matrix
	!C KTINVT inverts a transformation matrix (nb NOT a general 4 by 4)
	!C KTFRAM boosts a list of vectors between two arbitrary frames
	!C KTBREI boosts a list of vectors between the lab and Breit frames
	!C KTHADR boosts a list of vectors between the lab and hadronic cmf
	!C The last two need the momenta in the +z direction of the lepton
	!C and hadron beams, and the 4-momentum of the outgoing lepton.
	!C
	!C The main reference is:
	!C S. Catani, Yu.L. Dokshitzer, M.H. Seymour and B.R. Webber,
	!C Nucl.Phys.B406(1993)187.
	!C The ep version was proposed in:
	!C S. Catani, Yu.L. Dokshitzer and B.R. Webber,
	!C Phys.Lett.285B(1992)291.
	!C The inclusive reconstruction method was proposed in:
	!C S.D. Ellis and D.E. Soper,
	!C Phys.Rev.D48(1993)3160.
	!C
	!C-----------------------------------------------------------------------
	!C-----------------------------------------------------------------------
	!C-----------------------------------------------------------------------
	<<MLM matching: procedures>>=
	SUBROUTINE KTCLUR(IMODE,PP,NN,R,ECUT,Y,*)
	IMPLICIT NONE
	!C---DO CLUSTER ANALYSIS OF PARTICLES IN PP
	!C
	!C IMODE = INPUT : DESCRIBED ABOVE
	!C PP(I,J) = INPUT : 4-MOMENTUM OF Jth PARTICLE: I=1,4 => PX,PY,PZ,E
	!C NN = INPUT : NUMBER OF PARTICLES
	!C R = INPUT : ELLIS AND SOPER'S R PARAMETER, SEE ABOVE.
	!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
	!C Y(J) = OUTPUT : VALUE OF Y FOR WHICH EVENT CHANGES FROM BEING
	!C J JET TO J-1 JET
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED (MOST LIKELY DUE TO TOO MANY PARTICLES)
	!C
	!C NOTE THAT THE MOMENTA ARE DECLARED DOUBLE PRECISION,
	!C AND ALL OTHER FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER NMAX,IM,IMODE,TYPE,ANGL,MONO,RECO,N,I,J,NN, &
	IMIN,JMIN,KMIN,NUM,HIST,INJET,IABBR,NABBR
	PARAMETER (NMAX=512,NABBR=7)
	DOUBLE PRECISION PP(4,*)
	integer :: u
	!CHANGE DOUBLE PRECISION R,ECUT,Y(*),P,KT,ETOT,RSQ,KTP,KTS,KTPAIR,KTSING, &
	DOUBLE PRECISION R,ECUT,Y(*),P,KT,ETOT,RSQ,KTP,KTS, &
	KTMIN,ETSQ,KTLAST,KTMAX,KTTMP
	LOGICAL FIRST
	CHARACTER TITLE(4,4)*10
	!C---KT RECORDS THE KT**2 OF EACH MERGING.
	!C---KTLAST RECORDS FOR EACH MERGING, THE HIGHEST ECUT**2 FOR WHICH THE
	!C RESULT IS NOT MERGED WITH THE BEAM (COULD BE LARGER THAN THE
	!C KT**2 AT WHICH IT WAS MERGED IF THE KT VALUES ARE NOT MONOTONIC).
	!C THIS MAY SOUND POINTLESS, BUT ITS USEFUL FOR DETERMINING WHETHER
	!C SUB-JETS SURVIVED TO SCALE Y=YMAC OR NOT.
	!C---HIST RECORDS MERGING HISTORY:
	!C N=>DELETED TRACK N, M*NMAX+N=>MERGED TRACKS M AND N (M<N).
	COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
	KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
	DIMENSION INJET(NMAX),IABBR(NABBR)
	DATA FIRST,TITLE,IABBR/.TRUE., &
	'e+e- ','ep ','pe ','pp ', &
	'angle ','DeltaR ','f(DeltaR) ','**********', &
	'no ','yes ','********','********', &
	'E ','Pt ','Pt2 ','********', &
	1111,2111,3111,4111,4211,4212,4223/
	!C---CHECK INPUT
	IM=IMODE
	IF (IM.GE.1.AND.IM.LE.NABBR) IM=IABBR(IM)
	TYPE=MOD(IM/1000,10)
	ANGL=MOD(IM/100 ,10)
	MONO=MOD(IM/10 ,10)
	RECO=MOD(IM ,10)
	IF (NN.GT.NMAX) CALL KTWARN('KT-MAX',100,*999)
	IF (NN.LT.1) CALL KTWARN('KT-LT1',100,*999)
	IF (NN.LT.2.AND.TYPE.EQ.1) CALL KTWARN('KT-LT2',100,*999)
	IF (TYPE.LT.1.OR.TYPE.GT.4.OR.ANGL.LT.1.OR.ANGL.GT.4.OR. &
	MONO.LT.1.OR.MONO.GT.2.OR.RECO.LT.1.OR.RECO.GT.3) CALL KTWARN('KTCLUS',101,*999)
	u = given_output_unit ()
	IF (FIRST) THEN
	WRITE (u,'(/,1X,54(''*'')/A)') &
	' KTCLUS: written by Mike Seymour, July 1992.'
	WRITE (u,'(A)') &
	' Last modified November 2000.'
	WRITE (u,'(A)') &
	' Please send comments or suggestions to Mike.Seymour@rl.ac.uk'
	WRITE (u,'(/A,I2,2A)') &
	' Collision type =',TYPE,' = ',TITLE(TYPE,1)
	WRITE (u,'(A,I2,2A)') &
	' Angular variable =',ANGL,' = ',TITLE(ANGL,2)
	WRITE (u,'(A,I2,2A)') &
	' Monotonic definition =',MONO,' = ',TITLE(MONO,3)
	WRITE (u,'(A,I2,2A)') &
	' Recombination scheme =',RECO,' = ',TITLE(RECO,4)
	IF (R.NE.1) THEN
	WRITE (u,'(A,F5.2)') &
	' Radius parameter =',R
	IF (TYPE.NE.4) WRITE (u,'(A)') &
	' R.NE.1 is strongly discouraged for this collision type!'
	ENDIF
	WRITE (u,'(1X,54(''*'')/)')
	FIRST=.FALSE.
	ENDIF
	!C---COPY PP TO P
	N=NN
	NUM=NN
	CALL KTCOPY(PP,N,P,(RECO.NE.1))
	ETOT=0
	DO I=1,N
	ETOT=ETOT+P(4,I)
	END DO
	IF (ETOT.EQ.0) CALL KTWARN('KTCLUS',102,*999)
	IF (ECUT.EQ.0) THEN
	ETSQ=1/ETOT**2
	ELSE
	ETSQ=1/ECUT**2
	ENDIF
	RSQ=R**2
	!C---CALCULATE ALL PAIR KT's
	DO I=1,N-1
	DO J=I+1,N
	KTP(J,I)=-1
	KTP(I,J)=KTPAIR(ANGL,P(1,I),P(1,J),KTP(J,I))
	END DO
	END DO
	!C---CALCULATE ALL SINGLE KT's
	DO I=1,N
	KTS(I)=KTSING(ANGL,TYPE,P(1,I))
	END DO
	KTMAX=0
	!C---MAIN LOOP
	300 CONTINUE
	!C---FIND MINIMUM MEMBER OF KTP
	CALL KTPMIN(KTP,NMAX,N,IMIN,JMIN)
	!C---FIND MINIMUM MEMBER OF KTS
	CALL KTSMIN(KTS,NMAX,N,KMIN)
	!C---STORE Y VALUE OF TRANSITION FROM N TO N-1 JETS
	KTMIN=KTP(IMIN,JMIN)
	KTTMP=RSQ*KTS(KMIN)
	IF ((TYPE.GE.2.AND.TYPE.LE.4).AND. &
	(KTTMP.LE.KTMIN.OR.N.EQ.1)) &
	KTMIN=KTTMP
	KT(N)=KTMIN
	Y(N)=KT(N)*ETSQ
	!C---IF MONO.GT.1, SEQUENCE IS SUPPOSED TO BE MONOTONIC, IF NOT, WARN
	IF (KTMIN.LT.KTMAX.AND.MONO.GT.1) CALL KTWARN('KTCLUS',1,*999)
	IF (KTMIN.GE.KTMAX) KTMAX=KTMIN
	!C---IF LOWEST KT IS TO A BEAM, THROW IT AWAY AND MOVE LAST ENTRY UP
	IF (KTMIN.EQ.KTTMP) THEN
	CALL KTMOVE(P,KTP,KTS,NMAX,N,KMIN,1)
	!C---UPDATE HISTORY AND CROSS-REFERENCES
	HIST(N)=KMIN
	INJET(N)=KMIN
	DO I=N,NN
	IF (INJET(I).EQ.KMIN) THEN
	KTLAST(I)=KTMAX
	INJET(I)=0
	ELSEIF (INJET(I).EQ.N) THEN
	INJET(I)=KMIN
	ENDIF
	END DO
	!C---OTHERWISE MERGE JETS IMIN AND JMIN AND MOVE LAST ENTRY UP
	ELSE
	CALL KTMERG(P,KTP,KTS,NMAX,IMIN,JMIN,N,TYPE,ANGL,MONO,RECO)
	CALL KTMOVE(P,KTP,KTS,NMAX,N,JMIN,1)
	!C---UPDATE HISTORY AND CROSS-REFERENCES
	HIST(N)=IMIN*NMAX+JMIN
	INJET(N)=IMIN
	DO I=N,NN
	IF (INJET(I).EQ.JMIN) THEN
	INJET(I)=IMIN
	ELSEIF (INJET(I).EQ.N) THEN
	INJET(I)=JMIN
	ENDIF
	END DO
	ENDIF
	!C---THATS ALL THERE IS TO IT
	N=N-1
	IF (N.GT.1 .OR. N.GT.0.AND.(TYPE.GE.2.AND.TYPE.LE.4)) GOTO 300
	IF (N.EQ.1) THEN
	KT(N)=1D20
	Y(N)=KT(N)*ETSQ
	ENDIF
	RETURN
	999 RETURN 1
	END SUBROUTINE KTCLUR
	!C-----------------------------------------------------------------------
	<<MLM matching: procedures>>=
	!C-----------------------------------------------------------------------
	SUBROUTINE KTRECO(RECO,PP,NN,ECUT,YCUT,YMAC,PJET,JET,NJET,NSUB,*)
	IMPLICIT NONE
	!C---RECONSTRUCT KINEMATICS OF JET SYSTEM, WHICH HAS ALREADY BEEN
	!C ANALYSED BY KTCLUS. NOTE THAT NO CONSISTENCY CHECK IS MADE: USER
	!C IS TRUSTED TO USE THE SAME PP VALUES AS FOR KTCLUS
	!C
	!C RECO = INPUT : RECOMBINATION SCHEME (NEED NOT BE SAME AS KTCLUS)
	!C PP(I,J) = INPUT : 4-MOMENTUM OF Jth PARTICLE: I=1,4 => PX,PY,PZ,E
	!C NN = INPUT : NUMBER OF PARTICLES
	!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
	!C YCUT = INPUT : Y VALUE AT WHICH TO RECONSTRUCT JET MOMENTA
	!C YMAC = INPUT : Y VALUE USED TO DEFINE MACRO-JETS, TO DETERMINE
	!C WHICH JETS ARE SUB-JETS
	!C PJET(I,J)=OUTPUT : 4-MOMENTUM OF Jth JET AT SCALE YCUT
	!C JET(J) =OUTPUT : THE MACRO-JET WHICH CONTAINS THE Jth JET,
	!C SET TO ZERO IF JET IS NOT A SUB-JET
	!C NJET =OUTPUT : THE NUMBER OF JETS
	!C NSUB =OUTPUT : THE NUMBER OF SUB-JETS (EQUAL TO THE NUMBER OF
	!C NON-ZERO ENTRIES IN JET())
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT THE MOMENTA ARE DECLARED DOUBLE PRECISION,
	!C AND ALL OTHER FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER NMAX,RECO,NUM,N,NN,NJET,NSUB,JET(*),HIST,IMIN,JMIN,I,J
	PARAMETER (NMAX=512)
	DOUBLE PRECISION PP(4,),PJET(4,)
	DOUBLE PRECISION ECUT,P,KT,KTP,KTS,ETOT,RSQ,ETSQ,YCUT,YMAC,KTLAST, &
	ROUND
	PARAMETER (ROUND=0.99999D0)
	COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
	KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
	!C---CHECK INPUT
	if (signal_is_pending ()) return
	IF (RECO.LT.1.OR.RECO.GT.3) THEN
	PRINT *,'RECO=',RECO
	CALL KTWARN('KTRECO',100,*999)
	ENDIF
	!C---COPY PP TO P
	N=NN
	IF (NUM.NE.NN) CALL KTWARN('KTRECO',101,*999)
	CALL KTCOPY(PP,N,P,(RECO.NE.1))
	IF (ECUT.EQ.0) THEN
	ETSQ=1/ETOT**2
	ELSE
	ETSQ=1/ECUT**2
	ENDIF
	!C---KEEP MERGING UNTIL YCUT
	100 IF (ETSQKT(N).LT.ROUNDYCUT) THEN
	IF (HIST(N).LE.NMAX) THEN
	CALL KTMOVE(P,KTP,KTS,NMAX,N,HIST(N),0)
	ELSE
	IMIN=HIST(N)/NMAX
	JMIN=HIST(N)-IMIN*NMAX
	CALL KTMERG(P,KTP,KTS,NMAX,IMIN,JMIN,N,0,0,0,RECO)
	CALL KTMOVE(P,KTP,KTS,NMAX,N,JMIN,0)
	ENDIF
	N=N-1
	IF (N.GT.0) GOTO 100
	ENDIF
	!C---IF YCUT IS TOO LARGE THERE ARE NO JETS
	NJET=N
	NSUB=N
	IF (N.EQ.0) RETURN
	!C---SET UP OUTPUT MOMENTA
	DO I=1,NJET
	IF (RECO.EQ.1) THEN
	DO J=1,4
	PJET(J,I)=P(J,I)
	END DO
	ELSE
	PJET(1,I)=P(6,I)*COS(P(8,I))
	PJET(2,I)=P(6,I)*SIN(P(8,I))
	PJET(3,I)=P(6,I)*SINH(P(7,I))
	PJET(4,I)=P(6,I)*COSH(P(7,I))
	ENDIF
	JET(I)=I
	END DO
	!C---KEEP MERGING UNTIL YMAC TO FIND THE FATE OF EACH JET
	300 IF (ETSQKT(N).LT.ROUNDYMAC) THEN
	IF (HIST(N).LE.NMAX) THEN
	IMIN=0
	JMIN=HIST(N)
	NSUB=NSUB-1
	ELSE
	IMIN=HIST(N)/NMAX
	JMIN=HIST(N)-IMIN*NMAX
	IF (ETSQKTLAST(N).LT.ROUNDYMAC) NSUB=NSUB-1
	ENDIF
	DO I=1,NJET
	IF (JET(I).EQ.JMIN) JET(I)=IMIN
	IF (JET(I).EQ.N) JET(I)=JMIN
	END DO
	N=N-1
	IF (N.GT.0) GOTO 300
	ENDIF
	RETURN
	999 RETURN 1
	END SUBROUTINE KTRECO
	!C-----------------------------------------------------------------------
	<<MLM matching: procedures>>=
	!C-----------------------------------------------------------------------
	FUNCTION KTPAIR(ANGL,P,Q,ANGLE)
	IMPLICIT NONE
	!C---CALCULATE LOCAL KT OF PAIR, USING ANGULAR SCHEME:
	!C 1=>ANGULAR, 2=>DeltaR, 3=>f(DeltaEta,DeltaPhi)
	!C WHERE f(eta,phi)=2(COSH(eta)-COS(phi)) IS THE QCD EMISSION METRIC
	!C---IF ANGLE<0, IT IS SET TO THE ANGULAR PART OF THE LOCAL KT ON RETURN
	!C IF ANGLE>0, IT IS USED INSTEAD OF THE ANGULAR PART OF THE LOCAL KT
	INTEGER ANGL
	! CHANGE DOUBLE PRECISION P(9),Q(9),KTPAIR,R,KTMDPI,ANGLE,ETA,PHI,ESQ
	DOUBLE PRECISION P(9),Q(9),KTPAIR,R,ANGLE,ETA,PHI,ESQ
	!C---COMPONENTS OF MOMENTA ARE PX,PY,PZ,E,1/P,PT,ETA,PHI,PT**2
	R=ANGLE
	IF (ANGL.EQ.1) THEN
	IF (R.LE.0) R=2(1-(P(1)Q(1)+P(2)Q(2)+P(3)Q(3))(P(5)Q(5)))
	ESQ=MIN(P(4),Q(4))**2
	ELSEIF (ANGL.EQ.2.OR.ANGL.EQ.3) THEN
	IF (R.LE.0) THEN
	ETA=P(7)-Q(7)
	PHI=KTMDPI(P(8)-Q(8))
	IF (ANGL.EQ.2) THEN
	R=ETA2+PHI2
	ELSE
	R=2*(COSH(ETA)-COS(PHI))
	ENDIF
	ENDIF
	ESQ=MIN(P(9),Q(9))
	ELSEIF (ANGL.EQ.4) THEN
	ESQ=(1d0/(P(5)Q(5))-P(1)Q(1)-P(2)*Q(2)- &
	P(3)Q(3))2D0/(P(5)Q(5))/(0.0001D0+1d0/P(5)+1d0/Q(5))*2
	R=1d0
	ELSE
	CALL KTWARN('KTPAIR',200,*999)
	STOP
	ENDIF
	KTPAIR=ESQ*R
	IF (ANGLE.LT.0) ANGLE=R
	999 END FUNCTION KTPAIR
	!C-----------------------------------------------------------------------
	FUNCTION KTSING(ANGL,TYPE,P)
	IMPLICIT NONE
	!C---CALCULATE KT OF PARTICLE, USING ANGULAR SCHEME:
	!C 1=>ANGULAR, 2=>DeltaR, 3=>f(DeltaEta,DeltaPhi)
	!C---TYPE=1 FOR E+E-, 2 FOR EP, 3 FOR PE, 4 FOR PP
	!C FOR EP, PROTON DIRECTION IS DEFINED AS -Z
	!C FOR PE, PROTON DIRECTION IS DEFINED AS +Z
	INTEGER ANGL,TYPE
	DOUBLE PRECISION P(9),KTSING,COSTH,R,SMALL
	DATA SMALL/1D-4/
	IF (ANGL.EQ.1.OR.ANGL.EQ.4) THEN
	COSTH=P(3)*P(5)
	IF (TYPE.EQ.2) THEN
	COSTH=-COSTH
	ELSEIF (TYPE.EQ.4) THEN
	COSTH=ABS(COSTH)
	ELSEIF (TYPE.NE.1.AND.TYPE.NE.3) THEN
	CALL KTWARN('KTSING',200,*999)
	STOP
	ENDIF
	R=2*(1-COSTH)
	!C---IF CLOSE TO BEAM, USE APPROX 2(1-COS(THETA))=SIN*2(THETA)
	IF (R.LT.SMALL) R=(P(1)2+P(2)2)P(5)*2
	KTSING=P(4)*2R
	ELSEIF (ANGL.EQ.2.OR.ANGL.EQ.3) THEN
	KTSING=P(9)
	ELSE
	CALL KTWARN('KTSING',201,*999)
	STOP
	ENDIF
	999 END FUNCTION KTSING
	!C-----------------------------------------------------------------------
	SUBROUTINE KTPMIN(A,NMAX,N,IMIN,JMIN)
	IMPLICIT NONE
	!C---FIND THE MINIMUM MEMBER OF A(NMAX,NMAX) WITH IMIN < JMIN <= N
	INTEGER NMAX,N,IMIN,JMIN,KMIN,I,J,K
	!C---REMEMBER THAT A(X+(Y-1)*NMAX)=A(X,Y)
	!C THESE LOOPING VARIABLES ARE J=Y-2, I=X+(Y-1)*NMAX
	DOUBLE PRECISION A(*),AMIN
	K=1+NMAX
	KMIN=K
	AMIN=A(KMIN)
	DO J=0,N-2
	DO I=K,K+J
	IF (A(I).LT.AMIN) THEN
	KMIN=I
	AMIN=A(KMIN)
	ENDIF
	END DO
	K=K+NMAX
	END DO
	JMIN=KMIN/NMAX+1
	IMIN=KMIN-(JMIN-1)*NMAX
	END SUBROUTINE KTPMIN
	!C-----------------------------------------------------------------------
	SUBROUTINE KTSMIN(A,NMAX,N,IMIN)
	IMPLICIT NONE
	!C---FIND THE MINIMUM MEMBER OF A
	INTEGER N,NMAX,IMIN,I
	DOUBLE PRECISION A(NMAX)
	IMIN=1
	DO I=1,N
	IF (A(I).LT.A(IMIN)) IMIN=I
	END DO
	END SUBROUTINE KTSMIN
	!C-----------------------------------------------------------------------
	SUBROUTINE KTCOPY(A,N,B,ONSHLL)
	IMPLICIT NONE
	!C---COPY FROM A TO B. 5TH=1/(3-MTM), 6TH=PT, 7TH=ETA, 8TH=PHI, 9TH=PT**2
	!C IF ONSHLL IS .TRUE. PARTICLE ENTRIES ARE PUT ON-SHELL BY SETTING E=P
	INTEGER I,N
	DOUBLE PRECISION A(4,N)
	LOGICAL ONSHLL
	DOUBLE PRECISION B(9,N),ETAMAX,SINMIN,EPS
	DATA ETAMAX,SINMIN,EPS/10,0,1D-6/
	!C---SINMIN GETS CALCULATED ON FIRST CALL
	IF (SINMIN.EQ.0) SINMIN=1/COSH(ETAMAX)
	DO I=1,N
	B(1,I)=A(1,I)
	B(2,I)=A(2,I)
	B(3,I)=A(3,I)
	B(4,I)=A(4,I)
	B(5,I)=SQRT(A(1,I)2+A(2,I)2+A(3,I)**2)
	IF (ONSHLL) B(4,I)=B(5,I)
	IF (B(5,I).EQ.0) B(5,I)=1D-10
	B(5,I)=1/B(5,I)
	B(9,I)=A(1,I)2+A(2,I)2
	B(6,I)=SQRT(B(9,I))
	B(7,I)=B(6,I)*B(5,I)
	IF (B(7,I).GT.SINMIN) THEN
	B(7,I)=A(4,I)2-A(3,I)2
	IF (B(7,I).LE.EPSB(4,I)*2.OR.ONSHLL) B(7,I)=B(9,I)
	B(7,I)=LOG((B(4,I)+ABS(B(3,I)))**2/B(7,I))/2
	ELSE
	B(7,I)=ETAMAX+2
	ENDIF
	B(7,I)=SIGN(B(7,I),B(3,I))
	IF (A(1,I).EQ.0 .AND. A(2,I).EQ.0) THEN
	B(8,I)=0
	ELSE
	B(8,I)=ATAN2(A(2,I),A(1,I))
	ENDIF
	END DO
	END SUBROUTINE KTCOPY
	!C-----------------------------------------------------------------------
	SUBROUTINE KTMERG(P,KTP,KTS,NMAX,I,J,N,TYPE,ANGL,MONO,RECO)
	IMPLICIT NONE
	!C---MERGE THE Jth PARTICLE IN P INTO THE Ith PARTICLE
	!C J IS ASSUMED GREATER THAN I. P CONTAINS N PARTICLES BEFORE MERGING.
	!C---ALSO RECALCULATING THE CORRESPONDING KTP AND KTS VALUES IF MONO.GT.0
	!C FROM THE RECOMBINED ANGULAR MEASURES IF MONO.GT.1
	!C---NOTE THAT IF MONO.LE.0, TYPE AND ANGL ARE NOT USED
	INTEGER ANGL,RECO,TYPE,I,J,K,N,NMAX,MONO
	DOUBLE PRECISION P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX),PT,PTT, &
	! CHANGE KTMDPI,KTUP,PI,PJ,ANG,KTPAIR,KTSING,ETAMAX,EPS
	KTUP,PI,PJ,ANG,ETAMAX,EPS
	KTUP(I,J)=KTP(MAX(I,J),MIN(I,J))
	DATA ETAMAX,EPS/10,1D-6/
	IF (J.LE.I) CALL KTWARN('KTMERG',200,*999)
	!C---COMBINE ANGULAR MEASURES IF NECESSARY
	IF (MONO.GT.1) THEN
	DO K=1,N
	IF (K.NE.I.AND.K.NE.J) THEN
	IF (RECO.EQ.1) THEN
	PI=P(4,I)
	PJ=P(4,J)
	ELSEIF (RECO.EQ.2) THEN
	PI=P(6,I)
	PJ=P(6,J)
	ELSEIF (RECO.EQ.3) THEN
	PI=P(9,I)
	PJ=P(9,J)
	ELSE
	CALL KTWARN('KTMERG',201,*999)
	STOP
	ENDIF
	IF (PI.EQ.0.AND.PJ.EQ.0) THEN
	PI=1
	PJ=1
	ENDIF
	KTP(MAX(I,K),MIN(I,K))= &
	(PIKTUP(I,K)+PJKTUP(J,K))/(PI+PJ)
	ENDIF
	END DO
	ENDIF
	IF (RECO.EQ.1) THEN
	!C---VECTOR ADDITION
	P(1,I)=P(1,I)+P(1,J)
	P(2,I)=P(2,I)+P(2,J)
	P(3,I)=P(3,I)+P(3,J)
	!c P(4,I)=P(4,I)+P(4,J) ! JA
	P(5,I)=SQRT(P(1,I)2+P(2,I)2+P(3,I)**2)
	P(4,I)=P(5,I) ! JA (Massless scheme)
	IF (P(5,I).EQ.0) THEN
	P(5,I)=1
	ELSE
	P(5,I)=1/P(5,I)
	ENDIF
	ELSEIF (RECO.EQ.2) THEN
	!C---PT WEIGHTED ETA-PHI ADDITION
	PT=P(6,I)+P(6,J)
	IF (PT.EQ.0) THEN
	PTT=1
	ELSE
	PTT=1/PT
	ENDIF
	P(7,I)=(P(6,I)P(7,I)+P(6,J)P(7,J))*PTT
	P(8,I)=KTMDPI(P(8,I)+P(6,J)PTTKTMDPI(P(8,J)-P(8,I)))
	P(6,I)=PT
	P(9,I)=PT**2
	ELSEIF (RECO.EQ.3) THEN
	!C---PT**2 WEIGHTED ETA-PHI ADDITION
	PT=P(9,I)+P(9,J)
	IF (PT.EQ.0) THEN
	PTT=1
	ELSE
	PTT=1/PT
	ENDIF
	P(7,I)=(P(9,I)P(7,I)+P(9,J)P(7,J))*PTT
	P(8,I)=KTMDPI(P(8,I)+P(9,J)PTTKTMDPI(P(8,J)-P(8,I)))
	P(6,I)=P(6,I)+P(6,J)
	P(9,I)=P(6,I)**2
	ELSE
	CALL KTWARN('KTMERG',202,*999)
	STOP
	ENDIF
	!C---IF MONO.GT.0 CALCULATE NEW KT MEASURES. IF MONO.GT.1 USE ANGULAR ONES.
	IF (MONO.LE.0) RETURN
	!C---CONVERTING BETWEEN 4-MTM AND PT,ETA,PHI IF NECESSARY
	IF (ANGL.NE.1.AND.RECO.EQ.1) THEN
	P(9,I)=P(1,I)2+P(2,I)2
	P(7,I)=P(4,I)2-P(3,I)2
	IF (P(7,I).LE.EPSP(4,I)*2) P(7,I)=P(9,I)
	IF (P(7,I).GT.0) THEN
	P(7,I)=LOG((P(4,I)+ABS(P(3,I)))**2/P(7,I))/2
	IF (P(7,I).GT.ETAMAX) P(7,I)=ETAMAX+2
	ELSE
	P(7,I)=ETAMAX+2
	ENDIF
	P(7,I)=SIGN(P(7,I),P(3,I))
	IF (P(1,I).NE.0.AND.P(2,I).NE.0) THEN
	P(8,I)=ATAN2(P(2,I),P(1,I))
	ELSE
	P(8,I)=0
	ENDIF
	ELSEIF (ANGL.EQ.1.AND.RECO.NE.1) THEN
	P(1,I)=P(6,I)*COS(P(8,I))
	P(2,I)=P(6,I)*SIN(P(8,I))
	P(3,I)=P(6,I)*SINH(P(7,I))
	P(4,I)=P(6,I)*COSH(P(7,I))
	IF (P(4,I).NE.0) THEN
	P(5,I)=1/P(4,I)
	ELSE
	P(5,I)=1
	ENDIF
	ENDIF
	ANG=0
	DO K=1,N
	IF (K.NE.I.AND.K.NE.J) THEN
	IF (MONO.GT.1) ANG=KTUP(I,K)
	KTP(MIN(I,K),MAX(I,K))= &
	KTPAIR(ANGL,P(1,I),P(1,K),ANG)
	ENDIF
	END DO
	KTS(I)=KTSING(ANGL,TYPE,P(1,I))
	999 END SUBROUTINE KTMERG
	!C-----------------------------------------------------------------------
	SUBROUTINE KTMOVE(P,KTP,KTS,NMAX,N,J,IOPT)
	IMPLICIT NONE
	!C---MOVE THE Nth PARTICLE IN P TO THE Jth POSITION
	!C---ALSO MOVING KTP AND KTS IF IOPT.GT.0
	INTEGER I,J,N,NMAX,IOPT
	DOUBLE PRECISION P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX)
	DO I=1,9
	P(I,J)=P(I,N)
	END DO
	IF (IOPT.LE.0) RETURN
	DO I=1,J-1
	KTP(I,J)=KTP(I,N)
	KTP(J,I)=KTP(N,I)
	END DO
	DO I=J+1,N-1
	KTP(J,I)=KTP(I,N)
	KTP(I,J)=KTP(N,I)
	END DO
	KTS(J)=KTS(N)
	END SUBROUTINE KTMOVE
	!C-----------------------------------------------------------------------
	<<MLM matching: procedures>>=
	FUNCTION KTMDPI(PHI)
	IMPLICIT NONE
	!C---RETURNS PHI, MOVED ONTO THE RANGE [-PI,PI)
	DOUBLE PRECISION KTMDPI,PHI,PI,TWOPI,THRPI,EPS
	PARAMETER (PI=3.14159265358979324D0,TWOPI=6.28318530717958648D0, &
	THRPI=9.42477796076937972D0)
	PARAMETER (EPS=1D-15)
	KTMDPI=PHI
	IF (KTMDPI.LE.PI) THEN
	IF (KTMDPI.GT.-PI) THEN
	GOTO 100
	ELSEIF (KTMDPI.GT.-THRPI) THEN
	KTMDPI=KTMDPI+TWOPI
	ELSE
	KTMDPI=-MOD(PI-KTMDPI,TWOPI)+PI
	ENDIF
	ELSEIF (KTMDPI.LE.THRPI) THEN
	KTMDPI=KTMDPI-TWOPI
	ELSE
	KTMDPI=MOD(PI+KTMDPI,TWOPI)-PI
	ENDIF
	100 IF (ABS(KTMDPI).LT.EPS) KTMDPI=0
	END FUNCTION KTMDPI
	!C-----------------------------------------------------------------------
	SUBROUTINE KTWARN(SUBRTN,ICODE,*)
	!C DEALS WITH ERRORS DURING EXECUTION
	!C SUBRTN = NAME OF CALLING SUBROUTINE
	!C ICODE = ERROR CODE: - 99 PRINT WARNING & CONTINUE
	!C 100-199 PRINT WARNING & JUMP
	!C 200- PRINT WARNING & STOP DEAD
	!C-----------------------------------------------------------------------
	INTEGER ICODE
	CHARACTER(len=6) SUBRTN
	WRITE (6,10) SUBRTN,ICODE
	10 FORMAT(/' KTWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4/)
	IF (ICODE.LT.100) RETURN
	IF (ICODE.LT.200) RETURN 1
	STOP
	END SUBROUTINE KTWARN
	!C-----------------------------------------------------------------------
	!C-----------------------------------------------------------------------
	!C-----------------------------------------------------------------------

	@ %def ktclus ktclur ktycut ktysub
	@ %def ktbeam ktjoin ktreco ktincl
	@ %def ktisub ktijoi ktirec ktwich
	@ %def ktwchs ktfram ktbrei kthadr
	@ %def ktpair ktsing ktpmin ktsmin
	@ %def ktcopy ktmerg ktmove ktunit
	@ %def ktlbst ktrrot ktvmul ktmmul
	@ %def ktinvt ktmdpi ktwarn
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\subsubsection{CKKW settings, data and (pseudo) weights}

	This module contains the definitions for the basic settings for
	CKKW matching.

	The type [[ckkw_pseudo_shower_weights_t]] gives the (relative) weights
	for different clusterings of the final particles, as given in Eq.~(2.7) of
	hep-ph/0503281v1. Each particle has a binary labelling (power of 2)
	(first particle = 1, second particle = 2, third particle = 4,
	...). Each recombination therefore corresponds to an integer, that is
	not a power of 2. Fur multiple subsequent recombinations, no different
	weights for different sequences of clustering are stored. It is
	assumed that the weight of a multiply recombined state is a
	combination of the states with one fewer recombination and that these
	states' contributions are proportional to their weights. For a $2->n$
	event, the weights array thus has the size $2^{(2 + n) - 1}$. The
	[[weights_by_type]] array gives the weights depending on the type of
	the particle, the first index is the same as for weights, the second
	index gives the type of the new mother particle:
	\begin{itemize}
	\item[0:] uncolored ($\gamma$, $Z$, $W$, Higgs)
	\item[1:] colored (quark)
	\item[2:] gluon
	\item[3:] squark
	\item[4:] gluino
	\end{itemize}
	[[alphaS]] gives the value for $alpha_s$ used in the generation of the
	matrix element. This is needed for the reweighting using the values
	for a running $alpha_s$ at the scales of the clusterings.
	<<[[ckkw_base.f90]]>>=
	<<File header>>

	module ckkw_base

	<<Use kinds>>
	use io_units
	use constants
	use format_utils, only: write_separator
	use shower_base
	use variables

	<<Standard module head>>

	<<CKKW base: public>>

	<<CKKW base: types>>

	contains

	<<CKKW base: procedures>>

	end module ckkw_base
	@ %def ckkw_base
	@ The fundamental CKKW matching parameter are defined here:
	<<CKKW base: public>>=
	public :: ckkw_matching_settings_t
	<<CKKW base: types>>=
	type, extends (matching_settings_t) :: ckkw_matching_settings_t
	real(default) :: alphaS = 0.118_default
	real(default) :: Qmin = one
	integer :: n_max_jets = 0
	contains
	<<CKKW base: CKKW matching: TBP>>
	end type ckkw_matching_settings_t

	@ %def ckkw_matching_settings_t
	@ This is empty for the moment.
	<<CKKW base: CKKW matching: TBP>>=
	procedure :: init => ckkw_matching_settings_init
	@
	<<CKKW base: procedures>>=
	subroutine ckkw_matching_settings_init (settings, var_list)
	class(ckkw_matching_settings_t), intent(out) :: settings
	type(var_list_t), intent(in) :: var_list
	end subroutine ckkw_matching_settings_init

	@ %def ckkw_matching_settings_init
	@
	<<CKKW base: CKKW matching: TBP>>=
	procedure :: write => ckkw_matching_settings_write
	<<CKKW base: procedures>>=
	subroutine ckkw_matching_settings_write (settings, unit)
	class(ckkw_matching_settings_t), intent(in) :: settings
	integer, intent(in), optional :: unit
	integer :: u
	u = given_output_unit (unit); if (u < 0) return
	write (u, "(1x,A)") "CKKW matching settings:"
	call write_separator (u)
	write (u, "(3x,A,1x,ES19.12)") &
	"alphaS = ", settings%alphaS
	write (u, "(3x,A,1x,ES19.12)") &
	"Qmin = ", settings%Qmin
	write (u, "(3x,A,1x,I0)") &
	"n_max_jets = ", settings%n_max_jets
	end subroutine ckkw_matching_settings_write

	@ %def ckkw_matching_settings_write
	@
	<<CKKW base: public>>=
	public :: ckkw_pseudo_shower_weights_t
	<<CKKW base: types>>=
	type :: ckkw_pseudo_shower_weights_t
	real(default) :: alphaS
	real(default), dimension(:), allocatable :: weights
	real(default), dimension(:,:), allocatable :: weights_by_type
	end type ckkw_pseudo_shower_weights_t

	@ %def ckkw_pseudo_shower_weights_t
	@
	<<CKKW base: public>>=
	public :: ckkw_pseudo_shower_weights_init
	<<CKKW base: procedures>>=
	subroutine ckkw_pseudo_shower_weights_init (weights)
	type(ckkw_pseudo_shower_weights_t), intent(out) :: weights
	weights%alphaS = zero
	if (allocated (weights%weights)) deallocate(weights%weights)
	if (allocated (weights%weights_by_type)) &
	deallocate(weights%weights_by_type)
	end subroutine ckkw_pseudo_shower_weights_init

	@ %def ckkw_pseudo_shower_weights_init
	@
	<<CKKW base: public>>=
	public :: ckkw_pseudo_shower_weights_write
	<<CKKW base: procedures>>=
	subroutine ckkw_pseudo_shower_weights_write (weights, unit)
	type(ckkw_pseudo_shower_weights_t), intent(in) :: weights
	integer, intent(in), optional :: unit
	integer :: s, i, u
	u = given_output_unit (unit); if (u < 0) return
	s = size (weights%weights)
	write (u, "(1x,A)") "CKKW (pseudo) shower weights: "
	do i = 1, s
	write (u, "(3x,I0,2(ES19.12))") i, weights%weights(i), &
	weights%weights_by_type(i,:)
	end do
	write (u, "(3x,A,1x,I0)") "alphaS =", weights%alphaS
	end subroutine ckkw_pseudo_shower_weights_write

	@ %def ckkw_pseudo_shower_weights_write
	@
	<<CKKW base: public>>=
	public :: ckkw_matching_data_t
	<<CKKW base: types>>=
	type, extends (matching_data_t) :: ckkw_matching_data_t
	type(ckkw_pseudo_shower_weights_t) :: ckkw_weights
	end type ckkw_matching_data_t

	@ %def ckkw_matching_data_t
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\subsection{CKKW matching}
	<<[[ckkw_matching.f90]]>>=
	<<File header>>

	module ckkw_matching

	<<Use kinds with double>>
	use io_units
	use constants
	use format_utils, only: write_separator
	use diagnostics
	use physics_defs
	use lorentz
	use rng_base
	use shower_base
	use shower_partons
	use ckkw_base
	use variables

	<<Standard module head>>

	<<CKKW matching: public>>

	contains

	<<CKKW matching: procedures>>

	end module ckkw_matching
	@ %def ckkw_matching
	<<CKKW matching: public>>=
	public :: ckkw_matching_apply
	@
	<<CKKW matching: procedures>>=
	subroutine ckkw_matching_apply (partons, settings, weights, rng, veto)
	type(parton_pointer_t), dimension(:), intent(inout), allocatable :: &
	partons
	type(ckkw_matching_settings_t), intent(in) :: settings
	type(ckkw_pseudo_shower_weights_t), intent(in) :: weights
	class(rng_t), intent(inout), allocatable :: rng
	logical, intent(out) :: veto

	real(default), dimension(:), allocatable :: scales
	real(double) :: weight, sf
	real(default) :: rand
	integer :: i, n_partons

	if (signal_is_pending ()) return
	weight = one

	n_partons = size (partons)

	do i = 1, n_partons
	call parton_write (partons(i)%p)
	end do

	!!! the pseudo parton shower is already simulated by shower_add_interaction
	!!! get the respective clustering scales
	allocate (scales (1:n_partons))
	do i = 1, n_partons
	if (.not. associated (partons(i)%p)) cycle
	if (partons(i)%p%type == INTERNAL) then
	scales(i) = two * min (partons(i)%p%child1%momentum%p(0), &
	partons(i)%p%child2%momentum%p(0))*2 &
	(1.0 - (space_part (partons(i)%p%child1%momentum) * &
	space_part (partons(i)%p%child2%momentum)) / &
	(space_part (partons(i)%p%child1%momentum)*1 &
	space_part (partons(i)%p%child2%momentum)**1))
	scales(i) = sqrt (scales(i))
	partons(i)%p%ckkwscale = scales(i)
	print *, scales(i)
	end if
	end do

	print *, " scales finished"
	!!! if (highest multiplicity) -> reweight with PDF(mu_F) / PDF(mu_cut)
	do i = 1, n_partons
	call parton_write (partons(i)%p)
	end do

	!!! Reweight and possibly veto the whole event

	!!! calculate the relative alpha_S weight

	!! calculate the Sudakov weights for internal lines
	!! calculate the Sudakov weights for external lines
	do i = 1, n_partons
	if (signal_is_pending ()) return
	if (.not. associated (partons(i)%p)) cycle
	if (partons(i)%p%type == INTERNAL) then
	!!! get type
	!!! check that all particles involved are colored
	if ((partons(i)%p%is_colored () .or. &
	partons(i)%p%ckkwtype > 0) .and. &
	(partons(i)%p%child1%is_colored () .or. &
	partons(i)%p%child1%ckkwtype > 0) .and. &
	(partons(i)%p%child1%is_colored () .or. &
	partons(i)%p%child1%ckkwtype > 0)) then
	print *, "reweight with alphaS(" , partons(i)%p%ckkwscale, &
	") for particle ", partons(i)%p%nr
	if (partons(i)%p%belongstoFSR) then
	print *, "FSR"
	weight = weight * D_alpha_s_fsr (partons(i)%p%ckkwscale**2, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda) &
	/ settings%alphas
	else
	print *, "ISR"
	weight = weight * &
	D_alpha_s_isr (partons(i)%p%ckkwscale**2, &
	partons(i)%p%settings%d_min_t) &
	/ settings%alphas
	end if
	else
	print *, "no reweight with alphaS for ", partons(i)%p%nr
	end if
	if (partons(i)%p%child1%type == INTERNAL) then
	print *, "internal line from ", &
	partons(i)%p%child1%ckkwscale, &
	" to ", partons(i)%p%ckkwscale, &
	" for type ", partons(i)%p%child1%ckkwtype
	if (partons(i)%p%child1%ckkwtype == 0) then
	sf = 1.0
	else if (partons(i)%p%child1%ckkwtype == 1) then
	sf = SudakovQ (partons(i)%p%child1%ckkwscale, &
	partons(i)%p%ckkwscale, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda, .true., rng)
	print *, "SFQ = ", sf
	else if (partons(i)%p%child1%ckkwtype == 2) then
	sf = SudakovG (partons(i)%p%child1%ckkwscale, &
	partons(i)%p%ckkwscale, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda, .true., rng)
	print *, "SFG = ", sf
	else
	print *, "SUSY not yet implemented"
	end if
	weight = weight * min (one, sf)
	else
	print *, "external line from ", settings%Qmin, &
	partons(i)%p%ckkwscale
	if (parton_is_quark (partons(i)%p%child1)) then
	sf = SudakovQ (settings%Qmin, &
	partons(i)%p%ckkwscale, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda, .true., rng)
	print *, "SFQ = ", sf
	else if (parton_is_gluon (partons(i)%p%child1)) then
	sf = SudakovG (settings%Qmin, &
	partons(i)%p%ckkwscale, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda, .true., rng)
	print *, "SFG = ", sf
	else
	print *, "not yet implemented (", &
	partons(i)%p%child2%type, ")"
	sf = one
	end if
	weight = weight * min (one, sf)
	end if
	if (partons(i)%p%child2%type == INTERNAL) then
	print *, "internal line from ", partons(i)%p%child2%ckkwscale, &
	" to ", partons(i)%p%ckkwscale, &
	" for type ", partons(i)%p%child2%ckkwtype
	if (partons(i)%p%child2%ckkwtype == 0) then
	sf = 1.0
	else if (partons(i)%p%child2%ckkwtype == 1) then
	sf = SudakovQ (partons(i)%p%child2%ckkwscale, &
	partons(i)%p%ckkwscale, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda, .true., rng)
	print *, "SFQ = ", sf
	else if (partons(i)%p%child2%ckkwtype == 2) then
	sf = SudakovG (partons(i)%p%child2%ckkwscale, &
	partons(i)%p%ckkwscale, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda, .true., rng)
	print *, "SFG = ", sf
	else
	print *, "SUSY not yet implemented"
	end if
	weight = weight * min (one, sf)
	else
	print *, "external line from ", settings%Qmin, &
	partons(i)%p%ckkwscale
	if (parton_is_quark (partons(i)%p%child2)) then
	sf = SudakovQ (settings%Qmin, &
	partons(i)%p%ckkwscale, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda, .true., rng)
	print *, "SFQ = ", sf
	else if (parton_is_gluon (partons(i)%p%child2)) then
	sf = SudakovG (settings%Qmin, &
	partons(i)%p%ckkwscale, &
	partons(i)%p%settings%d_min_t, &
	partons(i)%p%settings%fsr_lambda, .true., rng)
	print *, "SFG = ", sf
	else
	print *, "not yet implemented (", &
	partons(i)%p%child2%type, ")"
	sf = one
	end if
	weight = weight * min (one, sf)
	end if
	end if
	end do

	call rng%generate (rand)

	print *, "final weight: ", weight

	!!!!!!! WRONG
	veto = .false.
	veto = (rand > weight)
	if (veto) then
	return
	end if

	!!! finally perform the parton shower
	!!! veto emissions that are too hard

	deallocate (scales)
	end subroutine ckkw_matching_apply

	@ %def ckkw_matching_apply
	@
	<<CKKW matching: procedures>>=
	function GammaQ (smallq, largeq, d_min_t, d_lambda_fsr, fsr) result (gamma)
	real(default), intent(in) :: smallq, largeq, d_min_t, d_lambda_fsr
	logical, intent(in) :: fsr
	real(default) :: gamma
	gamma = (8._default / three) / (pi * smallq)
	gamma = gamma * (log(largeq / smallq) - 0.75)
	if (fsr) then
	gamma = gamma * D_alpha_s_fsr (smallq**2, d_min_t, d_lambda_fsr)
	else
	gamma = gamma * D_alpha_s_isr (smallq**2, d_min_t)
	end if
	end function GammaQ

	@ %def GammaQ
	@
	<<CKKW matching: procedures>>=
	function GammaG (smallq, largeq, d_min_t, d_lambda_fsr, fsr) result (gamma)
	real(default), intent(in) :: smallq, largeq, d_min_t, d_lambda_fsr
	logical, intent(in) :: fsr
	real(default) :: gamma
	gamma = 6._default / (pi * smallq)
	gamma = gamma *( log(largeq / smallq) - 11.0 / 12.0)
	if (fsr) then
	gamma = gamma * D_alpha_s_fsr(smallq**2, d_min_t, d_lambda_fsr)
	else
	gamma = gamma * D_alpha_s_isr(smallq**2, d_min_t)
	end if
	end function GammaG

	@ %def GammaG
	@
	<<CKKW matching: procedures>>=
	function GammaF (smallq, d_min_t, d_lambda_fsr, fsr) result (gamma)
	real(default), intent(in) :: smallq, d_min_t, d_lambda_fsr
	logical, intent(in) :: fsr
	real(default) :: gamma
	gamma = number_of_flavors (smallq, d_min_t) / &
	(three * pi * smallq)
	if (fsr) then
	gamma = gamma * D_alpha_s_fsr (smallq**2, d_min_t, d_lambda_fsr)
	else
	gamma = gamma * D_alpha_s_isr (smallq**2, d_min_t)
	end if
	end function GammaF

	@ %def GammaF
	@
	<<CKKW matching: procedures>>=
	function SudakovQ (Q1, Q, d_min_t, d_lambda_fsr, fsr, rng) result (sf)
	real(default), intent(in) :: Q1, Q, d_min_t, d_lambda_fsr
	class(rng_t), intent(inout), allocatable :: rng
	logical, intent(in) :: fsr
	real(default) :: sf
	real(default) :: integral
	integer, parameter :: NTRIES = 100
	integer :: i
	real(default) :: rand
	integral = zero
	do i = 1, NTRIES
	call rng%generate (rand)
	integral = integral + GammaQ (Q1 + rand * (Q - Q1), Q, &
	d_min_t, d_lambda_fsr, fsr)
	end do
	integral = integral / NTRIES
	sf = exp (-integral)
	end function SudakovQ

	@ %def SudakovQ
	@
	<<CKKW matching: procedures>>=
	function SudakovG (Q1, Q, d_min_t, d_lambda_fsr, fsr, rng) result (sf)
	real(default), intent(in) :: Q1, Q, d_min_t, d_lambda_fsr
	logical, intent(in) :: fsr
	real(default) :: sf
	real(default) :: integral
	class(rng_t), intent(inout), allocatable :: rng
	integer, parameter :: NTRIES = 100
	integer :: i
	real(default) :: rand
	integral = zero
	do i = 1, NTRIES
	call rng%generate (rand)
	integral = integral + GammaG (Q1 + rand * (Q - Q1), Q, &
	d_min_t, d_lambda_fsr, fsr) + &
	GammaF (Q1 + rand * (Q - Q1), d_min_t, d_lambda_fsr, fsr)
	end do
	integral = integral / NTRIES
	sf = exp (-integral)
	end function SudakovG

	@ %def SudakovG
	@

File Metadata

Mime Type: text/x-tex
Expires: Wed, May 14, 10:34 AM (1 d, 11 h)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 5111194
Default Alt Text: shower.nw (334 KB)

shower.nwNo OneTemporaryActions

shower.nwView Options

File Metadata

Event Timeline

shower.nw
No OneTemporary
Actions

shower.nw
View Options