shower.nw
No OneTemporary
Actions

Size

340 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 hadronization}

	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.

	<<Version>>=
	2.2.0
	<<Date>>=
	Mar 03 2014

	<<File header>>=
	! WHIZARD <<Version>> <<Date>>
	!
	! Copyright (C) 1999-2014 by
	! Wolfgang Kilian <kilian@physik.uni-siegen.de>
	! Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
	! Juergen Reuter <juergen.reuter@desy.de>
	!
	! with contributions from
	! Christian Speckner <cnspeckn@googlemail.com>
	! and Fabian Bach, Felix Braam, Sebastian Schmidt, Daniel Wiesler
	!
	! WHIZARD is free software; you can redistribute it and/or modify it
	! under the terms of the GNU General Public License as published by
	! the Free Software Foundation; either version 2, or (at your option)
	! any later version.
	!
	! WHIZARD is distributed in the hope that it will be useful, but
	! WITHOUT ANY WARRANTY; without even the implied warranty of
	! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	! GNU General Public License for more details.
	!
	! You should have received a copy of the GNU General Public License
	! along with this program; if not, write to the Free Software
	! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	! This file has been stripped of most comments. For documentation, refer
	! to the source 'shower.nw'
	@
	We are strict with our names:
	<<Standard module head>>=
	implicit none
	private
	@ This is the way to envoke the kinds module (not contained in this source)
	<<Use kinds>>=
	use kinds, only: default !NODEP!
	@ %def default
	@ And we make heavy use of variable-length strings
	<<Use strings>>=
	use iso_varying_string, string_t => varying_string !NODEP!
	@ %def string_t
	@
	\section{Basics of the shower}
	<<[[shower_base.f90]]>>=
	<<File header>>

	module shower_base

	<<Use kinds>>
	use constants !NODEP!
	use tao_random_numbers !NODEP!

	<<Standard module head>>

	<<Shower base: public>>

	<<Shower base: parameters>>

	<<Shower base: interfaces>>

	contains

	<<Shower base: procedures>>

	end module shower_base
	@ %def shower_base
	@
	\subsection{PDF Interface of the shower}
	<<Shower base: public>>=
	public :: shower_pdf
	<<Shower base: interfaces>>=
	interface
	subroutine shower_pdf (set, x, q, ff)
	integer, intent(in) :: set
	double precision, intent(in) :: x, q
	double precision, dimension(-6:6), intent(out) :: ff
	end subroutine shower_pdf
	end interface

	@ %def shower_pdf
	@
	\subsection{Parameters}
	This decides whether to print out additional information.
	<<Shower base: parameters>>=
	logical, parameter, public :: D_print = .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_t = one
	real(default), public :: D_min_scale = 0.5_default
	real(default), public :: D_Lambda_fsr = 0.29_default
	real(default), public :: D_Lambda_isr = 0.29_default
	@ %def D_Min_t D_min_scale
	@ %def D_Lambda_fsr D_Lambda_isr
	@
	The parameter [[MSTJ(45)]] gives the maximum number of flavours 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 :: isr_pt_ordered = .false.
	@ %def D_running_alpha_s_fsr
	@ %def D_running_alpha_s_isr
	@ %def D_constantalpha_s
	@ %def isr_pt_ordered
	@
	This flag sets emitted timelike partons in the spacelike shower on
	shell, true corresponds to [[MSTP(63)]] = 0.
	<<Shower base: parameters>>=
	logical, public :: isr_only_onshell_emitted_partons = .true.
	@ %def isr_only_onshell_emitted_partons
	@
	Flag whether ISR is angular ordered ([[MSTP(62)]]).
	<<Shower base: parameters>>=
	logical, public :: isr_angular_ordered = .true.
	@ %def isr_angular_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
	@
	The parameter [[PARP(66)]], the minimal energy of the emitted timelike
	parton in the ISR ([[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.
	<<Shower base: parameters>>=
	real(default), public :: maxz_isr = 0.999_default
	real(default), public :: minenergy_timelike = one
	real(default), public :: tscalefactor_isr = one
	real(default), public :: first_integral_suppression_factor = one
	@ %def maxz_isr minenergy_timelike
	@ %def tscalefactor_isr first_integral_suppression_factor
	@
	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
	@
	Then, there are the variables for the PDF functions:
	<<Shower base: parameters>>=
	integer, public :: shower_pdf_set = 0
	@ %def shower_pdf_set
	@
	And the PDF function itself, as a procedure pointer:
	<<Shower base: parameters>>=
	procedure(shower_pdf), pointer, public :: shower_pdf_func

	@ %def shower_pdf_func
	@
	<<Shower base: procedures>>=
	subroutine randomseed (seed)
	integer, intent(in), optional :: seed
	integer :: clock

	if (present (seed)) then
	clock = seed
	else
	call system_clock (count = clock)
	end if
	call tao_random_seed (clock)
	end subroutine randomseed

	@ %def randomseed
	@
	<<Shower base: public>>=
	public :: D_alpha_s_isr
	public :: D_alpha_s_fsr
	<<Shower base: procedures>>=
	function D_alpha_s_isr (tin) result(alpha_s)
	real(default), intent(in) :: tin
	real(default) :: b, t
	real(default) :: alpha_s

	! arbitrary lower cut off for scale
	! t = MAX(max(one * D_Min_t, 1.1_default * D_Lambda_isr**2), ABS(tin))
	t = max (max (0.1_default * D_Min_t, &
	1.1_default * D_Lambda_isr**2), abs(tin))

	if (D_running_alpha_s_isr) then
	b = (33._default - two * number_of_flavors(t)) / (12._default * pi)
	alpha_s = one / (b * log(t / (D_Lambda_isr**2)))
	else
	alpha_s = D_constalpha_s
	end if
	end function D_alpha_s_isr

	function D_alpha_s_fsr (tin) result(alpha_s)
	real(default), intent(in) :: tin
	real(default) :: b, t
	real(default) :: alpha_s

	! arbitrary lower cut off for scale
	! t= max( max (one * D_Min_t, 1.1_default * D_Lambda**2), ABS(tin))
	t = max (max (0.1_default * D_Min_t, &
	1.1_default * D_Lambda_fsr**2), abs(tin))

	if (D_running_alpha_s_fsr) then
	b = (33._default - two * number_of_flavors(t)) / (12._default * pi)
	alpha_s = one / (b * log(t / (D_Lambda_fsr**2)))
	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>>=
	function mass_type (type) result (mass)
	integer, intent(in) :: type
	real(default) :: mass
	mass = sqrt (mass_squared_type (type))
	end function mass_type

	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 (21)
	mass2 = zero
	case (2112) ! Neutron
	mass2 = 0.939565_default**2
	case (2212) ! Proton
	mass2 = 0.93827_default**2
	case (411) ! D+
	mass2 = 1.86960_default**2
	case (421) ! D0
	mass2 = 1.86483_default**2
	case (511) ! B0
	mass2 = 5.27950_default**2
	case (521) ! B+
	mass2 = 5.27917_default**2
	case (2224) !Delta++
	mass2 = 1.232_default**2
	case (3212) !Sigma0
	mass2 = 1.192642_default**2
	case (3222) !Sigma+
	mass2 = 1.18937_default**2
	case (4212) ! Sigma_c+
	mass2 = 2.4529_default**2
	case (4222) ! Sigma_c++
	mass2 = 2.45402_default**2
	case (5212) ! Sigma_b0
	mass2 = 5.8152_default**2
	case (5222) ! Sigma_b+
	mass2 = 5.8078_default**2
	case (0) ! I take 0 to be partons whose type is not yet clear
	mass2 = zero
	case (9999) ! 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 flavours allowed in an actual $g \to qq$ splitting.
	<<Shower base: public>>=
	public :: number_of_flavors
	<<Shower base: procedures>>=
	function number_of_flavors (t) result (nr)
	real(default), intent(in) :: t
	integer :: nr
	integer :: i
	nr = 0
	if (t < 0.25_default * D_Min_t) return ! arbitrary cut off ?WRONG?
	do i = 1, min (D_Nf, 3)
	! 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
	@ Splitting functions. They are also defined in [[sm_physics]]. This
	should be unified at some point.
	<<Shower base: public>>=
	public :: P_qqg
	public :: P_gqq
	public :: P_ggg
	<<Shower base: procedures>>=
	function P_qqg (z) result (P)
	!!! quark => quark + gluon
	real(default), intent(in) :: z
	real(default) :: P
	P = (four / three) * (one + z**2) / (one - z)
	end function P_qqg

	function P_gqq (z) result (P)
	!!! gluon => quark + antiquark
	real(default), intent(in) :: z
	real(default) :: P
	P = 0.5_default * (z2 + (one - z)2)
	!!! anti-symmetrized version -> needs change of first and second daughter
	!!! in 50% of branchings
	! P = (one - z)**2
	end function P_gqq

	function P_ggg (z) result (P)
	!!! gluon => gluon + gluon
	real(default), intent(in) :: z
	real(default) :: P
	P = three * ((one - z) / z + z / (one - z) + z * (one - z))
	!!! anti-symmetrized version -> needs to by symmetrized in color connections
	! P = three * ( two * z / (one - z) + z * (one - z) )
	end function P_ggg

	@ %def P_qqg P_gqq P_ggg
	@ Analytically integrated splitting kernels.
	<<Shower base: public>>=
	public :: integral_over_P_gqq
	public :: integral_over_P_ggg
	public :: integral_over_P_qqg
	<<Shower base: procedures>>=
	function integral_over_P_gqq (zmin, zmax) result (integral)
	real(default), intent(in) :: zmin, zmax
	real(default) :: integral
	integral = 0.5_default * ((two / three) * &
	(zmax3 - zmin3) - (zmax2 - zmin2) + (zmax - zmin))
	end function integral_over_P_gqq

	function integral_over_P_ggg (zmin, zmax) result (integral)
	real(default), intent(in) :: zmin, zmax
	real(default) :: integral
	integral = three * ((log(zmax) - two * zmax - &
	log(one - zmax) + zmax2 / two - zmax3 / three) - &
	(log(zmin) - zmin - zmin - log(one - zmin) + zmin**2 &
	/ two - zmin**3 / three) )
	end function integral_over_P_ggg

	function integral_over_P_qqg (zmin, zmax) result (integral)
	real(default), intent(in) :: zmin, zmax
	real(default) :: integral
	integral = (two / three) * ( - zmax2 + zmin2 - &
	two * (zmax - zmin) + four * &
	log((one - zmin) / (one - zmax)))
	end function integral_over_P_qqg

	@ %def integral_over_P_gqq integral_over_P_ggg integral_over_P_qqg
	@ Methods to set parameters, once there should be a better interface.
	<<Shower base: public>>=
	public :: shower_set_D_min_t
	public :: shower_set_D_lambda_fsr
	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_isr_angular_ordered
	public :: shower_set_primordial_kt_width
	public :: shower_set_primordial_kt_cutoff
	public :: shower_set_maxz_isr
	public :: shower_set_minenergy_timelike
	public :: shower_set_tscalefactor_isr
	public :: shower_set_isr_only_onshell_emitted_partons
	public :: shower_set_pdf_func
	public :: shower_set_pdf_set
	<<Shower base: procedures>>=
	subroutine shower_set_D_Min_t (input)
	real(default) :: input
	D_Min_t = input
	end subroutine shower_set_D_Min_t

	subroutine shower_set_D_Lambda_fsr (input)
	real(default) :: input
	D_Lambda_fsr = input
	end subroutine shower_set_D_Lambda_fsr

	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_isr_angular_ordered (input)
	logical :: input
	isr_angular_ordered = input
	end subroutine shower_set_isr_angular_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

	subroutine shower_set_maxz_isr (input)
	real(default) :: input
	maxz_isr = input
	end subroutine shower_set_maxz_isr

	subroutine shower_set_minenergy_timelike (input)
	real(default) :: input
	minenergy_timelike = input
	end subroutine shower_set_minenergy_timelike

	subroutine shower_set_tscalefactor_isr (input)
	real(default) :: input
	tscalefactor_isr = input
	end subroutine shower_set_tscalefactor_isr

	subroutine shower_set_isr_only_onshell_emitted_partons (input)
	logical :: input
	isr_only_onshell_emitted_partons = input
	end subroutine shower_set_isr_only_onshell_emitted_partons

	subroutine shower_set_pdf_func (func)
	procedure(shower_pdf), pointer, intent(in) :: func
	shower_pdf_func => func
	end subroutine shower_set_pdf_func

	subroutine shower_set_pdf_set (set)
	integer, intent(in) :: set
	shower_pdf_set = set
	end subroutine shower_set_pdf_set

	@ %def shower_set_D_Min_t shower_set_D_Lambda_fsr
	@ %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_isr_angular_ordered
	@ %def shower_set_primordial_kt_width
	@ %def shower_set_primordial_kt_cutoff
	@ %def shower_set_maxz_isr shower_set_minenergy_timelike
	@ %def shower_set_tscalefactor_isr
	@ %def shower_set_isr_only_onshell_emitted_partons
	@ %def shower_set_pdf_func
	@ %def shower_set_pdf_set
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Parton module for the shower}
	<<[[shower_partons.f90]]>>=
	<<File header>>

	module shower_partons

	<<Use kinds>>
	use io_units !NODEP!
	use constants !NODEP!
	use limits, only: TAB !NODEP!
	use diagnostics !NODEP!
	use tao_random_numbers !NODEP!
	use lorentz !NODEP!
	use shower_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]].
	<<Shower partons: public>>=
	public :: parton_t
	<<Shower partons: types>>=
	type :: parton_t
	integer :: nr = 0
	integer :: type = 0
	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
	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: public>>=
	public :: parton_copy
	<<Shower partons: procedures>>=
	subroutine parton_copy (prt1, prt2)
	type(parton_t), intent(in) :: prt1
	type(parton_t), intent(out) :: prt2
	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: public>>=
	public :: parton_get_costheta
	<<Shower partons: procedures>>=
	function parton_get_costheta (prt) result (costheta)
	type(parton_t), intent(in) :: prt
	real(default) :: costheta
	if (prt%z * (one - prt%z) * parton_get_energy(prt)**2 > zero) then
	costheta = one - prt%t / (two * prt%z * (one - prt%z) * &
	parton_get_energy(prt)**2)
	else
	costheta = - one
	end if
	end function parton_get_costheta

	@ %def parton_get_costheta
	@ The same for massive daughters.
	<<Shower partons: public>>=
	public :: parton_get_costheta_correct
	@
	<<Shower partons: procedures>>=
	function parton_get_costheta_correct (prt) result (costheta)
	type(parton_t), intent(in) :: prt
	real(default) :: costheta
	if (parton_is_branched (prt)) then
	if (parton_is_simulated (prt%child1) .and. &
	parton_is_simulated (prt%child2) .and. &
	sqrt (max (zero, (prt%z)*2 parton_get_energy(prt)**2 &
	- prt%child1%t)) * &
	sqrt (max (zero, (1.-prt%z)*2 parton_get_energy(prt)**2 &
	- prt%child2%t)) > zero) then
	costheta = &
	(prt%t - prt%child1%t - prt%child2%t - 2. * prt%z * &
	(1.-prt%z) * parton_get_energy(prt)**2) / &
	(-2.* sqrt((prt%z)*2 parton_get_energy(prt)**2 &
	- prt%child1%t) * &
	sqrt( (1.-prt%z)*2 parton_get_energy(prt)**2 - prt%child2%t))
	else
	costheta = parton_get_costheta (prt)
	end if
	else
	costheta = parton_get_costheta (prt)
	end if
	end function parton_get_costheta_correct

	@ %def parton_get_costheta_correct
	@ This function returns the angle between the momentum vectors of the
	parton and first daughter.
	<<Shower partons: public>>=
	public :: parton_get_costheta_motherfirst
	<<Shower partons: procedures>>=
	function parton_get_costheta_motherfirst (prt) result (costheta)
	type(parton_t), intent(in) :: prt
	real(default) :: costheta
	if (parton_is_branched (prt)) then
	if ((parton_is_simulated (prt%child1) .or. parton_is_final (prt%child1) &
	.or. parton_is_branched (prt%child1)) .and. &
	(parton_is_simulated (prt%child2) .or. &
	parton_is_final (prt%child2) &
	.or. parton_is_branched (prt%child2)) .and. &
	(space_part_norm (prt%momentum) * space_part_norm &
	(prt%child1%momentum) > zero)) then
	costheta = (space_part (prt%momentum) * &
	space_part(prt%child1%momentum)) / &
	(space_part_norm (prt%momentum) * &
	space_part_norm (prt%child1%momentum))
	else
	costheta = -two
	end if
	else
	costheta = -two
	end if
	end function parton_get_costheta_motherfirst

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

	function parton_get_beta (prt) result (beta)
	type(parton_t), intent(in) :: prt
	real(default) :: beta
	beta = get_beta (prt%t, vector4_get_component (prt%momentum, 0))
	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,4A)", advance ="no") "Shower parton <nr>", &
	TAB, "<type>", TAB
	write (u, "(1x,3A)") "<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
	else
	write (u, "('[',I5,']',A)", advance = "no") prt%type, TAB
	end if
	if (associated (prt%parent)) then
	write (u, "(I5,2A)", advance = "no") prt%parent%nr, TAB, TAB
	else
	write (u, "(5x,2A)", advance = "no") TAB, TAB
	end if
	write (u, "(4(ES12.5,A))") &
	vector4_get_component (prt%momentum, 0), TAB, &
	vector4_get_component (prt%momentum, 1), TAB, &
	vector4_get_component (prt%momentum, 2), TAB, &
	vector4_get_component (prt%momentum, 3)
	write (u, "(1x,5A)", advance = "no") "<p4square>", TAB, TAB, "<t>", TAB
	write (u, "(1x,7A)") TAB, "<scale>", TAB, TAB, "<c1>", TAB, "<c2>"
	write (u, "(3(ES12.5,A))", advance = "no") &
	parton_p4square(prt), TAB, prt%t, TAB // 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, "(3x,5(ES8.5,1x),A1)", advance = "no") &
	parton_get_costheta (prt), &
	parton_get_costheta_correct (prt), prt%costheta, prt%z, &
	parton_get_costheta_motherfirst (prt), 'b'
	else
	write(u, "(3x,5(ES8.5,1x),A1)", advance = "no") prt%z, prt%x, &
	parton_get_costheta_correct (prt), prt%costheta, &
	parton_get_costheta_motherfirst (prt), 'b'
	end if
	else
	if (prt%belongstoFSR) then
	write (u, "(43x)", advance = "no")
	else
	write (u, "(9x,ES8.5,26x)", advance = "no") 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 (parton_is_simulated (prt)) 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 children: ", prt%child1%nr, ", "
	end if
	if (prt%belongstointeraction) then
	write (u, "(A,I2)") "belongs to ", &
	prt%interactionnr
	else
	write (u, "(A,I2)") "does not belong to ", &
	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>>=
	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>>=
	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: public>>=
	public :: parton_set_simulated
	<<Shower partons: procedures>>=
	subroutine parton_set_simulated (prt, sim)
	type(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_is_simulated
	<<Shower partons: procedures>>=
	function parton_is_simulated (prt) result (is_simulated)
	type(parton_t), intent(in) :: prt
	logical :: is_simulated
	is_simulated = prt%simulated
	end function parton_is_simulated

	@ %def parton_is_simulated
	@
	<<Shower partons: public>>=
	public :: parton_get_momentum
	<<Shower partons: procedures>>=
	function parton_get_momentum (prt, i) result (mom)
	type(parton_t), intent(in) :: prt
	integer, intent(in) :: i
	real(default) :: mom
	select case (i)
	case (0)
	mom = vector4_get_component (prt%momentum,0)
	case (1)
	mom = vector4_get_component (prt%momentum,1)
	case (2)
	mom = vector4_get_component (prt%momentum,2)
	case (3)
	mom = vector4_get_component (prt%momentum,3)
	case default
	mom = 0
	end select
	end function parton_get_momentum

	@ %def parton_get_momentum
	@
	<<Shower partons: public>>=
	public :: parton_set_momentum
	<<Shower partons: procedures>>=
	subroutine parton_set_momentum (prt, EE, ppx, ppy, ppz)
	type(parton_t), intent(inout) :: prt
	real(default), intent(in) :: EE, ppx, ppy, ppz
	prt%momentum = vector4_moving &
	(EE, vector3_moving ([ppx, ppy, ppz]))
	end subroutine parton_set_momentum

	@ %def parton_set_momentum
	@
	<<Shower partons: public>>=
	public :: parton_set_energy
	<<Shower partons: procedures>>=
	subroutine parton_set_energy (prt, E)
	type(parton_t), intent(inout) :: prt
	real(default), intent(in) :: E
	call vector4_set_component (prt%momentum, 0, E)
	end subroutine parton_set_energy

	@ %def parton_set_energy
	@
	<<Shower partons: public>>=
	public :: parton_get_energy
	<<Shower partons: procedures>>=
	function parton_get_energy (prt) result (E)
	type(parton_t), intent(in) :: prt
	real(default) :: E
	E = vector4_get_component (prt%momentum, 0)
	end function parton_get_energy

	@ %def parton_get_energy
	@
	<<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), intent(in) :: prt
	integer, intent(in) :: i
	type(parton_t), pointer :: child
	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>>=
	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>>=
	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
	@
	<<Shower partons: public>>=
	public :: parton_is_gluon
	<<Shower partons: procedures>>=
	function parton_is_gluon (prt) result (is_gluon)
	type(parton_t), intent(in) :: prt
	logical :: is_gluon
	is_gluon = prt%type == 21 .or. prt%type == 9
	end function parton_is_gluon

	@ %def parton_is_gluon
	<<Shower partons: public>>=
	public :: parton_is_gluino
	<<Shower partons: procedures>>=
	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
	@ Only the proton is implemented yet.
	<<Shower partons: public>>=
	public :: parton_is_hadron
	<<Shower partons: procedures>>=
	function parton_is_hadron (prt) result (is_hadron)
	type(parton_t), intent(in) :: prt
	logical :: is_hadron
	is_hadron = abs (prt%type) == 2212
	end function parton_is_hadron

	@ %def parton_is_hadron
	@ TODO: SUSY partons.
	<<Shower partons: public>>=
	public :: parton_is_colored
	<<Shower partons: procedures>>=
	function parton_is_colored (prt) result (is_colored)
	type(parton_t), intent(in) ::prt
	logical :: is_colored
	is_colored = parton_is_quark (prt) .or. parton_is_gluon (prt)
	end function parton_is_colored

	@ %def parton_is_colored
	@
	<<Shower partons: public>>=
	public :: parton_p4square
	<<Shower partons: procedures>>=
	function parton_p4square (prt) result (p4square)
	type(parton_t), intent(in) :: prt
	real(default) :: p4square
	p4square = prt%momentum**2
	end function parton_p4square

	@ %def parton_p4square
	@
	<<Shower partons: public>>=
	public :: parton_p3square
	<<Shower partons: procedures>>=
	function parton_p3square (prt) result (p3square)
	type(parton_t), intent(in) :: prt
	real(default) :: p3square
	p3square = parton_p3abs (prt)**2
	end function parton_p3square

	@ %def parton_p3square
	@
	<<Shower partons: public>>=
	public :: parton_p3abs
	<<Shower partons: procedures>>=
	function parton_p3abs (prt) result (p3abs)
	type(parton_t), intent(in) :: prt
	real(default) :: p3abs
	p3abs = space_part_norm (prt%momentum)
	end function parton_p3abs

	@ %def parton_p3abs
	@
	<<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: public>>=
	public :: parton_mass_squared
	<<Shower partons: procedures>>=
	function parton_mass_squared (prt) result (mass_squared)
	type(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, E3out) result (retvalue)
	type(parton_t), intent(inout) :: prt
	type(parton_t), intent(in) :: recoiler
	real(default), intent(out), optional :: E3out
	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 - &
	parton_mass_squared (prt%child2)) / 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 (parton_get_energy (prt%child1)**2 - prt%child1%t)
	p4 = sqrt (max (zero, (E3 - parton_get_energy (prt%child1))**2 &
	- prt%child2%t))
	if (p3 > zero) then
	retvalue = ((p1 + p4 >= p3) .and. (p3 >= abs(p1 - p4)) )
	if (retvalue .and. isr_angular_ordered) 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 = (parton_get_energy (prt%child1)**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 *, "old z:", prt%z , " new z: ", newz
	prt%z = newz
	if (associated (prt%child1) .and. associated (prt%child2)) then
	call parton_set_energy (prt%child1, newz * parton_get_energy (prt))
	call parton_apply_z (prt%child1, prt%child1%z)
	call parton_set_energy (prt%child2, (1.-newz) * parton_get_energy (prt))
	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)
	type(parton_t), intent(inout) :: prt
	prt%z = 0.5_default * (one + parton_get_beta (prt) * prt%costheta)
	if (associated (prt%child1) .and. associated (prt%child2) ) then
	if (parton_is_simulated (prt%child1) .and. &
	parton_is_simulated (prt%child2)) then
	prt%z = 0.5_default * (one + (prt%child1%t - prt%child2%t) / &
	prt%t + parton_get_beta (prt) * prt%costheta * &
	sqrt((prt%t - prt%child1%t - prt%child2%t)**2 - &
	4 * prt%child1%t * prt%child2%t) / prt%t)
	if (prt%type /= 94) then
	call parton_set_energy (prt%child1, &
	prt%z * parton_get_energy (prt))
	call parton_set_energy (prt%child2, (one - prt%z) * &
	parton_get_energy (prt))
	end if
	call parton_generate_ps (prt)
	call parton_apply_costheta (prt%child1)
	call parton_apply_costheta (prt%child2)
	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 /= 2212 .and. prt%type /= 9999) 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 ((parton_p3abs(prt%child1) == zero) .and. &
	(parton_p3abs(prt%child2) == zero) .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.
	<<Shower partons: public>>=
	public :: parton_generate_ps
	<<Shower partons: procedures>>=
	subroutine parton_generate_ps (prt)
	type(parton_t), intent(inout) :: prt
	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 *, " generate_ps for parton " , prt%nr
	if (.not. (associated (prt%child1) .and. associated (prt%child2))) then
	print *, "no children for generate_ps"
	return
	end if
	!!! test if parton is a virtual parton from the imagined parton shower history
	if (prt%type == 94) 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
	call parton_set_energy (prt%child1, (parton_get_energy (prt)**2- &
	prt%child2%t + prt%child1%t) / (two * parton_get_energy (prt)))
	call parton_set_energy (prt%child2, parton_get_energy (prt) - &
	parton_get_energy (prt%child1))

	! rescale momenta and set momenta to be along z-axis
	prt%child1%momentum = vector4_moving (parton_get_energy (prt%child1), &
	vector3_canonical(3) * sqrt(parton_get_energy (prt%child1)**2 - &
	prt%child1%t))
	prt%child2%momentum = vector4_moving (parton_get_energy (prt%child2), &
	vector3_canonical(3) * (-sqrt(parton_get_energy (prt%child2)**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 (parton_p3abs (prt) == zero) return
	do i = 1, 3
	directions(1,i) = parton_get_momentum (prt,i) / parton_p3abs (prt)
	end do
	!!! directions(2,:) and directions(3,:) -> two random directions
	!!! perpendicular to the direction of the parent parton
	do i = 1, 3
	do j = 2, 3
	call tao_random_number (directions(j,i))
	end do
	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 = parton_p3abs(prt)
	if ((parton_get_energy (prt%child1)**2 - prt%child1%t < 0) .or. &
	(parton_get_energy (prt%child2)**2 - prt%child2%t < 0)) then
	if (D_print) print *, "err: error at generate_ps(), E^2 < t"
	return
	end if
	p1abs = sqrt (parton_get_energy (prt%child1)**2 - prt%child1%t)
	p2abs = sqrt (parton_get_energy (prt%child2)**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 *,"error at generate_ps, Dreiecksungleichung for parton ", &
	prt%nr, " ", parton_p3abs(prt)," ",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 tao_random_number (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
	call parton_set_momentum (prt%child1, parton_get_energy (prt%child1), &
	momentum(1), momentum(2), momentum(3))
	do i = 1, 3
	momentum(i) = (parton_p3abs(prt) - x) * directions(1,i) - &
	ptabs * (cos(phi) * directions(2,i) + sin(phi) * directions(3,i))
	end do
	call parton_set_momentum (prt%child2, parton_get_energy (prt%child2), &
	momentum(1), momentum(2), momentum(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,1) = - directions(3,1)
	directions(3,2) = - directions(3,2)
	directions(3,3) = - directions(3,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)
	type(parton_t), intent(inout) :: prt
	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 *, " generate_ps_ini for parton " , prt%nr
	if (.not. (associated(prt%child1) .and. associated(prt%child2))) then
	print *, "error in parton_generate_ps_ini"
	return
	end if

	if (parton_is_hadron(prt) .eqv. .false.) then
	!!! generate ps for normal partons
	do i = 1, 3
	directions(1,i) = parton_get_momentum (prt%child1,i) / &
	parton_p3abs(prt%child1)
	end do
	do i = 1, 3
	do j = 2, 3
	call tao_random_number (directions(j,i))
	end do
	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 = parton_p3abs (prt%child1)
	p1abs = sqrt (parton_get_energy (prt)**2 - prt%t)
	p2abs = sqrt (max(zero, parton_get_energy (prt%child2)**2 - &
	prt%child2%t))

	x = (pabs2 + p1abs2 - p2abs*2) / (two pabs)
	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)
	return
	end if
	if (D_print) print *, "x:",x
	ptabs = sqrt (p1abs * p1abs - x**2)
	call tao_random_number (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
	call parton_set_momentum (prt, parton_get_energy(prt), &
	momentum(1), momentum(2), momentum(3))
	do i = 1, 3
	momentum(i) = (x - pabs) * directions(1,i) + ptabs * (cos(phi) * &
	directions(2,i) + sin(phi) * directions(3,i))
	end do
	call parton_set_momentum (prt%child2, parton_get_energy(prt%child2), &
	momentum(1), momentum(2), momentum(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)
	type(parton_t), intent(inout) :: prt
	integer :: gtoqq
	real(default) :: integral, random

	if (signal_is_pending ()) return
	if (D_print) then
	print *, "next_t_ana for parton " , prt%nr
	end if

	! check if branchings are possible at all
	if (min (prt%t, parton_get_energy(prt)**2) < &
	parton_mass_squared(prt) + D_Min_t) then
	prt%t = parton_mass_squared (prt)
	call parton_set_simulated (prt)
	return
	end if

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

	@ %def parton_next_t_ana
	@
	<<Shower partons: procedures>>=
	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 = parton_get_costheta (prt%parent)
	cma = min (0.99999_default, sqrt( max(zero, one - t/ &
	(parton_get_beta(prt) parton_get_energy(prt))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, integral, random, gtoqq, lookatsister)
	type(parton_t), intent(inout) :: prt
	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 parton_set_simulated (prt, .false.)

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

	tmin = D_Min_t + parton_mass_squared (prt)
	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 = parton_mass_squared (prt)
	call parton_set_simulated (prt)
	return
	end if

	if (associated (sister)) then
	if (sqrt(prt%t) > sqrt(prt%parent%t) - &
	sqrt(parton_mass_squared (sister))) then
	prt%t = (sqrt (prt%parent%t) - sqrt (parton_mass_squared (sister)))**2
	end if
	end if
	if (prt%t > parton_get_energy(prt)**2) then
	prt%t = parton_get_energy(prt)**2
	end if

	if (prt%t <= tmin) then
	prt%t = parton_mass_squared (prt)
	call parton_set_simulated (prt)
	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, parton_get_energy (prt)) * c
	if (parton_is_gluon (prt)) then
	P(3) = P_ggg (z(3)) + P_gqq (z(3)) * number_of_flavors (prt%t)
	else
	P(3) = P_qqg (z(3))
	end if
	a(3) = D_alpha_s_fsr (z(3) * (one - z(3)) * prt%t) * 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, parton_get_energy (prt)) * &
	(c + 0.5_default * cstep)
	z(3) = 0.5_default + 0.5_default * get_beta &
	(prt%t - 0.5_default * tstep, parton_get_energy (prt)) * (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)
	P(3) = P_ggg(z(3)) + P_gqq(z(3)) * number_of_flavors (prt%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) * P(2) / &
	(prt%t - 0.5_default * tstep)
	a(3) = D_alpha_s_fsr(z(3) * (one - z(3)) * prt%t) * 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 tao_random_number (temprand)
	prt%t = prt%t - temprand * tstep
	call tao_random_number (temprand)
	prt%costheta = c + (0.5_default - temprand) * cstep
	call parton_set_simulated (prt)

	if (prt%t < D_Min_t + parton_mass_squared(prt)) then
	prt%t = parton_mass_squared (prt)
	end if
	if (prt%costheta.lt.-cmax_t .or. prt%costheta.gt.cmax_t) then
	! reject branching due to violation of costheta-limits
	call tao_random_number (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 parton_set_simulated (prt, .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 tao_random_number (temprand)
	if (P_ggg(z(1)) > temprand * (P_ggg (z(1)) + P_gqq (z(1)) * &
	number_of_flavors(prt%t))) then
	gtoqq = 0
	else
	call tao_random_number (temprand)
	gtoqq = 1 + temprand * number_of_flavors (prt%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 < D_Min_t + parton_mass_squared (prt)) then
	prt%t = parton_mass_squared (prt)
	call parton_set_simulated(prt)
	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) result (maxz)
	real(default), intent(in) :: shat,s
	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>>
	use io_units !NODEP!
	use constants !NODEP!
	use limits !NODEP!
	use lorentz !NODEP!
	use diagnostics !NODEP!
	use tao_random_numbers !NODEP!
	use shower_base
	use shower_partons
	use ckkw_pseudo_weights

	<<Standard module head>>

	<<Shower core: public>>

	<<Shower core: parameters>>

	<<Shower core: types>>

	contains

	<<Shower core: procedures>>

	end module shower_core
	@ %def shower_core
	@
	<<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
	@ The main type of [[shower_core]]:
	<<Shower core: public>>=
	public :: shower_t
	<<Shower core: types>>=
	type :: 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
	contains
	<<Shower core: shower: TBP>>
	end type shower_t

	@ %def shower_t
	@ The parameters of the shower module:
	<<Shower core: parameters>>=
	! real(default), parameter :: alphasmax = one
	! real(default), parameter :: xpdfmax = 10._default
	real(default), save :: alphasxpdfmax = 12._default

	@ %def alphasmax xpdfmax 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]] 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, n_partons_shower
	integer :: i, j, imin, jmin
	real(default) :: y, ymin
	real(default) :: w, wmax
	real(default) :: random, sum
	! real(default) :: s
	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
	type(lorentz_transformation_t) :: L

	if (signal_is_pending ()) return
	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
	! print *, " adding a 2-> ", n_out, " interaction"

	isr_is_possible = associated (partons(1)%p%initial) .and. &
	associated (partons(2)%p%initial)

	if (associated (partons(1)%p%initial) .and. &
	parton_is_quark (partons(1)%p)) then
	if (parton_get_energy (partons(1)%p) < &
	2._double * 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 (parton_get_energy (partons(2)%p) < &
	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 parton_set_simulated &
	(shower%interactions(n_int)%i%partons(1)%p%initial)
	if (associated (shower%interactions(n_int)%i%partons(2)%p%initial)) &
	call parton_set_simulated &
	(shower%interactions(n_int)%i%partons(2)%p%initial)
	if (isr_is_possible) 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
	!!! ensure that partons are marked as belonging to the hard interaction
	shower%interactions(n_int)%i%partons(i)%p%belongstointeraction &
	= .true.
	!!! ensure that incoming partons are marked as belonging to ISR
	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) 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

	!!! add all partons to the shower
	<<Count number of associated [[shower%partons(i)%p]]>>

	!!! 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)

	!!! call shower%write ()
	!!! print *, "end of shower_interactionadd2ton"

	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)
	!!! call shower%write ()
	@
	<<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. wmax == zero) 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 = 94
	!!! something for internal use needed, 81-100 should be reserved
	!!! for internal purposes

	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 tao_random_number (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) > 1E-10_default) then
	prtmomentum = prt%momentum
	childmomentum = prt%child1%momentum
	prtmomentum = boost (-parton_get_beta(prt) / &
	sqrt (one - &
	(parton_get_beta(prt))**2), space_part (prt%momentum) / &
	space_part_norm(prt%momentum)) * prtmomentum
	childmomentum = boost (-parton_get_beta(prt) / &
	sqrt(one - &
	(parton_get_beta(prt))**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 (parton_get_energy (new_partons(i)%p), &
	parton_get_energy (new_partons(j)%p)) * &
	(one - enclosed_angle_ct &
	(new_partons(i)%p%momentum, &
	new_partons(j)%p%momentum))
	if (y < ymin .or. ymin == zero) 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 = 94
	!!! something for internal use needed, 81-100 should be
	!!! reserved for internal purposes

	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) > 1E-10_default) then
	prtmomentum = prt%momentum
	childmomentum = prt%child1%momentum
	prtmomentum = boost (-parton_get_beta(prt) / sqrt(one - &
	(parton_get_beta(prt))**2), space_part(prt%momentum) / &
	space_part_norm(prt%momentum)) * prtmomentum
	childmomentum = boost (-parton_get_beta(prt) / &
	sqrt(one - &
	(parton_get_beta(prt))**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
	@
	<<Count number of associated [[shower%partons(i)%p]]>>=
	n_partons_shower = 0
	if (allocated (shower%partons)) then
	do i = 1, size (shower%partons)
	if (associated (shower%partons(i)%p)) &
	n_partons_shower = n_partons_shower + 1
	end do
	end if
	@
	<<Procedures of [[shower_add_interaction_2ton_CKKW]]>>=
	function shower_clustering_allowed (shower, partons, i, j) result (allowed)
	type(shower_t), intent(inout) :: shower
	logical :: allowed
	type(parton_pointer_t), intent(in), dimension(:), allocatable :: partons
	integer, intent(in) :: i, j
	!!! TODO implement checking if clustering is allowed, e.g.
	!!! in e+e- -> qqg don't cluster the quarks together first
	allowed = .true.
	end function shower_clustering_allowed

	@
	<<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 /= 94) then
	if (scale > D_Min_t + parton_mass_squared (prt)) then
	prt%t = scale
	else
	prt%t = parton_mass_squared (prt)
	call parton_set_simulated (prt)
	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_hadron(prt%parent)) then
	if (associated (prt%parent%parent)) then
	if (.not. parton_is_hadron (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 parton_set_simulated (prt)
	prt%scale = 0._double
	prt%t = parton_mass_squared (prt)
	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 (i == size (shower%partons)) then
	! call msg_bug ("Shower core: parton to be removed not found")
	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
	!!! print *, " shower_sort_partons"
	if (.not. allocated (shower%partons)) return
	size_partons = size (shower%partons)
	maxsort = 0
	do i = 1, size_partons
	if (signal_is_pending ()) return
	if (associated (shower%partons(i)%p)) maxsort = i
	end do
	size_partons = size (shower%partons)
	if (size_partons <= 1) return
	do i = 1, maxsort
	if (signal_is_pending ()) return
	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. parton_is_simulated (shower%partons(i)%p) .and. &
	.not. shower%partons(i)%p%belongstointeraction) then
	shower%partons(i)%p%type = 0
	end if
	end if
	end do
	!!! 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 (signal_is_pending ()) return
	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 (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 (signal_is_pending ()) return
	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 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) - parton_mass_squared &
	(shower%partons(j)%p) < &
	abs(shower%partons(j + 1)%p%t) - parton_mass_squared &
	(shower%partons(j + 1)%p)) then
	call swap_pointers (shower%partons(j), shower%partons(j + 1))
	changed = .true.
	else
	if (abs (shower%partons(j)%p%t) - parton_mass_squared &
	(shower%partons(j)%p) == &
	abs(shower%partons(j + 1)%p%t) - parton_mass_squared &
	(shower%partons(j + 1)%p)) 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
	!!! print *, " shower_sort_partons finished"
	end subroutine shower_sort_partons

	@ %def shower_sort_partons
	@ Creation and finalization.
	<<Shower core: shower: TBP>>=
	procedure :: create => shower_create
	<<Shower core: procedures>>=
	subroutine shower_create (shower)
	class(shower_t), intent(inout) :: shower
	shower%next_free_nr = 1
	shower%next_color_nr = 1
	if (allocated (shower%interactions)) then
	call msg_bug ("Shower: creating new shower while old one " // &
	"still associated (interactions)")
	end if
	if (allocated (shower%partons)) then
	call msg_bug ("Shower: creating new shower while old one " // &
	"still associated (partons)")
	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, length)
	type(shower_t), intent(inout) :: shower
	integer, intent(in) :: length
	integer :: i, oldlength
	type(parton_pointer_t), dimension(:), allocatable :: new_partons
	!!! print *, "shower_enlarge_partons_array ", length
	if (length > 0) then
	if (allocated (shower%partons)) then
	oldlength = size (shower%partons)
	allocate (new_partons(1:oldlength))
	do i = 1, oldlength
	new_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 => new_partons(i)%p
	end do
	do i = oldlength + 1, oldlength + length
	shower%partons(i)%p => null()
	end do
	else
	call msg_bug ("Shower: no parton_pointers added in shower%partons")
	end if
	!!! print *, " shower_enlarge_partons_array finished"
	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
	!!! type(parton_t), intent(inout), target :: prt
	integer, intent(in) :: child
	integer :: i, lastfree
	type(parton_pointer_t) :: newprt
	!!! print *, " shower_add_child for parton ", prt%nr
	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, 10)
	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
	!!! print *, " 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)) then
	call shower_enlarge_partons_array (shower, 10)
	else if (associated (shower%partons(size(shower%partons))%p)) then
	call shower_enlarge_partons_array (shower, 10)
	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
	! print *, " shower_add_parent finished"
	end subroutine shower_add_parent

	@ %def shower_add_parent
	@
	<<Shower core: procedures>>=
	function shower_get_total_momentum (shower, c) result (mom)
	type(shower_t), intent(in) :: shower
	integer, intent(in) :: c
	real(default) :: mom
	integer :: i
	mom = zero
	if (.not. allocated (shower%partons)) return
	do i = 1, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	if (parton_is_final (shower%partons(i)%p)) then
	select case (c)
	case (0)
	mom = mom + vector4_get_component(shower%partons(i)%p%momentum, 0)
	case (1)
	mom = mom + vector4_get_component(shower%partons(i)%p%momentum, 1)
	case (2)
	mom = mom + vector4_get_component(shower%partons(i)%p%momentum, 2)
	case (3)
	mom = mom + vector4_get_component(shower%partons(i)%p%momentum, 3)
	case default
	call msg_error ("Shower: wrong component of 4momentum")
	end select
	end if
	end do
	end function shower_get_total_momentum

	@ %def shower_get_total_momentum
	@
	<<Shower core: procedures>>=
	function shower_get_nr_of_partons (shower, mine, include_remnants) &
	result (nr)
	type(shower_t), intent(in) :: shower
	real(default), intent(in), optional :: mine
	logical, intent(in), optional :: include_remnants
	integer :: nr
	integer :: i
	type(parton_t), pointer :: prt
	real(default) :: minenergy
	nr = 0
	if (present (mine)) then
	minenergy = mine
	else
	minenergy = zero
	end if
	do i = 1, size (shower%partons)
	prt => shower%partons(i)%p
	if (.not. associated (prt)) cycle
	if (.not. parton_is_final (prt)) cycle
	if (prt%type == 9999) then
	if (present (include_remnants)) then
	if (.not. include_remnants) cycle
	end if
	end if
	if (present(mine)) then
	if (parton_get_energy (prt) > mine) then
	nr = nr + 1
	end if
	else
	nr = nr +1
	end if
	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. parton_is_colored (prt)) cycle
	if (prt%belongstointeraction .and. prt%belongstoFSR .and. &
	(prt%type /= 94)) 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. parton_is_colored (prt)) cycle
	if (prt%belongstointeraction .and. prt%belongstoFSR .and. &
	(prt%type /= 94)) 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: public>>=
	public :: shower_get_final_partons
	<<Shower core: procedures>>=
	subroutine shower_get_final_partons (shower, partons, include_remnants)
	type(shower_t), intent(in) :: shower
	type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: partons
	logical, intent(in), optional :: include_remnants
	integer :: i, j
	type(parton_t), pointer :: prt
	if (allocated (partons)) deallocate (partons)
	allocate (partons(1:shower_get_nr_of_partons(shower, &
	include_remnants = include_remnants)))
	j = 0
	do i = 1, size (shower%partons)
	prt => shower%partons(i)%p
	if (.not. associated (prt)) cycle
	if (.not. parton_is_final (prt)) cycle
	!!! remnant
	if (prt%type == 9999) then
	if (present (include_remnants)) then
	if (.not. include_remnants) cycle
	end if
	end if
	j = j + 1
	partons(j)%p => prt
	end do
	end subroutine shower_get_final_partons

	@ %def shower_get_final_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 <= parton_mass_squared(prt)
	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_hadron (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_shat
	<<Shower core: procedures>>=
	function shower_interaction_get_shat (interaction) result (shat)
	type(shower_interaction_t), intent(in) :: interaction
	real(default) :: shat
	shat = (interaction%partons(1)%p%momentum + &
	interaction%partons(2)%p%momentum)**2
	end function shower_interaction_get_shat

	@ %def shower_interaction_get_shat
	@
	<<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. parton_is_simulated (prt) &
	.and. prt%scale > zero) then
	finished = .false.
	exit
	end if
	else
	if (.not. prt%belongstoFSR .and. .not. parton_is_simulated (prt) &
	.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>>=
	function shower_is_finished (shower) result (finished)
	type(shower_t), intent(in) :: shower
	logical :: finished
	finished = shower_isr_is_finished (shower) .and. &
	shower_fsr_is_finished(shower)
	end function shower_is_finished

	@ %def shower_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_hadron (prt1%parent)) then
	exit
	else if ((.not. isr_pt_ordered .and. .not. parton_is_simulated (prt1%parent)) &
	.or. (isr_pt_ordered .and. .not. parton_is_simulated (prt1))) 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_hadron (prt2%parent)) then
	exit
	else if ((.not. isr_pt_ordered .and. .not. parton_is_simulated (prt2%parent)) &
	.or. (isr_pt_ordered .and. .not. parton_is_simulated (prt2))) 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) == 2212 .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 (2203, hadron%type)
	else
	call tao_random_number (random)
	!!! if u then remaining diqaurk is either
	if (random < 0.75_default) then
	!!! with 75% a ud_0
	remnant%type = sign (2101, hadron%type)
	else
	!!! with 25% a ud_1
	remnant%type = sign (2103, 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 tao_random_number (random)
	if (random < 0.6666_default) then
	!!! 2/3 into udq + u
	if (abs (hadron%child1%type) == 1) then
	remnant%child1%type = sign (2112, hadron%type)
	else if (abs (hadron%child1%type) == 2) then
	remnant%child1%type = sign (2212, hadron%type)
	else if (abs (hadron%child1%type) == 3) then
	remnant%child1%type = sign(3212, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (4212, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (5212, hadron%type)
	end if
	remnant%child2%type = sign (2, hadron%type)
	else
	!!! 1/3 into uuq + d
	if (abs (hadron%child1%type).eq.1) then
	remnant%child1%type = sign (2212, hadron%type)
	else if (abs (hadron%child1%type).eq.2) then
	remnant%child1%type = sign (2224, hadron%type)
	else if (abs (hadron%child1%type).eq.3) then
	remnant%child1%type = sign (3222, hadron%type)
	else if (abs (hadron%child1%type).eq.4) then
	remnant%child1%type = sign (4222, hadron%type)
	else if (abs (hadron%child1%type).eq.5) then
	remnant%child1%type = sign (5222, 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 tao_random_number (random)
	if (random < 0.5_default) then
	!!! 1/2 into usbar + ud_0
	if (abs (hadron%child1%type) == 3) then
	remnant%child1%type = sign (321, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (421, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (521, hadron%type)
	end if
	remnant%child2%type = sign (2101, 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 (321, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (421, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (521, hadron%type)
	end if
	remnant%child2%type = sign (2103, hadron%type)
	else
	!!! 1/3 into dsbar + uu_1
	if (abs (hadron%child1%type) == 3) then
	remnant%child1%type = sign (311, hadron%type)
	else if (abs (hadron%child1%type) == 4) then
	remnant%child1%type = sign (411, hadron%type)
	else if (abs (hadron%child1%type) == 5) then
	remnant%child1%type = sign (511, hadron%type)
	end if
	remnant%child2%type = sign (2203, hadron%type)
	end if
	remnant%c1 = hadron%child1%c2
	remnant%c2 = hadron%child1%c1
	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 tao_random_number (random)
	if (random < 0.5_default) then
	!!! 1/2 into u + ud_0
	remnant%child1%type = sign (2, hadron%type)
	remnant%child2%type = sign (2101, 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 (2103, hadron%type)
	else
	!!! 1/3 into d + uu_1
	remnant%child1%type = sign (1, hadron%type)
	remnant%child2%type = sign (2203, hadron%type)
	end if
	remnant%c1 = hadron%child1%c2
	remnant%c2 = hadron%child1%c1
	if (sign (1,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
	if (associated (remnant%child1)) then
	!!! 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 = parton_mass_squared(remnant%child1)
	remnant%child1%momentum = vector4_moving( &
	energy(remnant%child1%momentum), &
	( space_part(remnant%child1%momentum) / &
	space_part_norm(remnant%child1%momentum) ) *sqrt( &
	energy(remnant%child1%momentum)**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_hadron (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
	!!! print *, " end interaction_apply_lorentztrafo"
	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 / vector4_get_component(beta,0)
	if (beta**2 > one) then
	call msg_error ("Shower, boost to CM frame: beta > 1")
	return
	end if
	if (space_part(beta)**2 > 1E-14_default) 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
	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
	!!! if no branching at all occured, take original partons
	! if (prt1%child1%belongstointeraction .and. prt2%child1%belongstointeraction) then
	! prt1 => prt1%child1
	! prt2 => prt2%child1
	! end if
	!!! transform partons to overall labframe.
	beta = vector3_canonical(3) * &
	((prt1%x * vector4_get_component (prt2%momentum, 0) - &
	prt2%x * vector4_get_component (prt1%momentum, 0)) / &
	(prt1%x * vector4_get_component (prt2%momentum, 3) - &
	prt2%x * vector4_get_component (prt1%momentum, 3)))
	if (beta**1 > 1E-10_default) &
	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, &
	vector4_get_component(prt1%initial%momentum,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
	call shower%update_beamremnants ()
	end subroutine shower_rotate_to_z

	@ %def shower_rotate_to_z
	@
	<<Shower core: procedures>>=
	subroutine interaction_generate_primordial_kt (interaction)
	type(shower_interaction_t), intent(inout) :: interaction
	type(parton_t), pointer :: had1, had2
	type(vector4_t) :: momenta(2)
	type(vector3_t) :: beta
	real(default) :: pt (2), phi(2)
	real(default) :: shat
	!!! variables for boosting and rotating
	real(default) :: btheta, bphi
	integer :: i
	if (primordial_kt_width == zero) return
	!!! print *, "interaction_generate_primordial_kt"
	!!! 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 tao_random_number (pt (i))
	pt(i) = primordial_kt_width * sqrt(-log(pt(i)))
	if (pt(i) < primordial_kt_cutoff) exit
	end do GENERATE_PT
	call tao_random_number (phi (i))
	phi(i) = twopi * phi(i)
	end do GENERATE_PT_PHI
	!!! adjust momenta
	shat = (momenta(1) + momenta(2))**2
	momenta(1) = vector4_moving (vector4_get_component (momenta(1),0), &
	vector3_moving ([pt(1) * cos(phi(1)), pt(1) * sin(phi(1)), &
	vector4_get_component (momenta(1), 3)]))
	momenta(2) = vector4_moving (vector4_get_component (momenta(2),0), &
	vector3_moving ([pt(2) * cos(phi(2)), pt(2) * sin(phi(2)), &
	vector4_get_component (momenta(2), 3)]))
	beta = vector3_moving ([vector4_get_component (momenta(1), 1) + &
	vector4_get_component (momenta(2), 1) , &
	vector4_get_component (momenta(1), 2) + &
	vector4_get_component (momenta(2), 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
	! print *, "shower_generate_primordial_kt"
	! call shower%write ()
	do i = 1, size (shower%interactions)
	call interaction_generate_primordial_kt (shower%interactions(i)%i)
	end do
	call shower%update_beamremnants ()
	! call shower%write ()
	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
	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)
	! print *, " i = ", i
	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)") &
	"-------------------------------------------------------"
	! stop "END"
	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,4(ES12.5,A))") "Total Momentum [0:3]: ", &
	shower_get_total_momentum (shower, 0), TAB, &
	shower_get_total_momentum (shower, 1), TAB, &
	shower_get_total_momentum (shower, 2), TAB, &
	shower_get_total_momentum (shower, 3), TAB
	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
	@
	<<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 (shower), 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 (parton_is_colored (shower%partons(i)%p)) 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, &
	vector4_get_component (shower%partons(i)%p%momentum, 1), &
	vector4_get_component (shower%partons(i)%p%momentum, 2), &
	vector4_get_component (shower%partons(i)%p%momentum, 3), &
	vector4_get_component (shower%partons(i)%p%momentum, 0), &
	shower%partons(i)%p%momentum**2, zero, 9.0
	else
	write(u,*) shower%partons(i)%p%type, -9, 0, 0, 0, 0, &
	vector4_get_component (shower%partons(i)%p%momentum, 1), &
	vector4_get_component (shower%partons(i)%p%momentum, 2), &
	vector4_get_component (shower%partons(i)%p%momentum, 3), &
	vector4_get_component (shower%partons(i)%p%momentum, 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 (parton_is_colored (shower%partons(i)%p)) 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, &
	vector4_get_component (shower%partons(i)%p%momentum, 1), &
	vector4_get_component (shower%partons(i)%p%momentum, 2), &
	vector4_get_component (shower%partons(i)%p%momentum, 3), &
	vector4_get_component (shower%partons(i)%p%momentum, 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()
	! print *, " shower_replace_parent_by_hadron for parton ", prt%nr
	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 = 9999
	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) :: 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 (-tscalefactor_isr * parton_get_energy (prt)**2, &
	-abs(tmax)), prt%t)
	else
	t = max (-tscalefactor_isr * parton_get_energy (prt)**2, prt%t)
	end if
	call tao_random_number (random)
	random = -twopi * log(random)
	!!! compare Integral and log(random) instead of random and exp(-Integral)
	random = random / first_integral_suppression_factor
	integral = zero
	call parton_set_simulated (prt, .false.)
	do
	call tao_random_number (temprand)
	tstep = max (abs (0.01_default * t) * temprand, 0.1_default * D_Min_t)
	if (t + 0.5_default * tstep > - D_Min_t) then
	prt%t = parton_mass_squared (prt)
	call parton_set_simulated (prt)
	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 > - D_Min_t) then
	call shower_replace_parent_by_hadron (shower, prt)
	end if
	! print *, " shower_get_first_ISR_scale_for_parton finished"

	contains

	function integral_over_z_simple (prt, final) result (integral)
	type(parton_t), intent(inout) :: prt
	! real(default), intent(in) :: shat, s,
	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 *, "integral_over_z_simple for t = ", prt%t
	end if
	minz = prt%x
	! maxz = maxzz(shat, s)
	maxz = 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 tao_random_number (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)) / (abs(prt%t))) * &
	P_ggg (z + 0.5_default * zstep) * get_pdf (prt%initial%type, &
	prt%x / (z + 0.5_default * zstep), abs(prt%t), 21)
	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 tao_random_number (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 + 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)) / (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 tao_random_number(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)) / (abs(prt%t))) * &
	P_qqg (z + 0.5_default * zstep) * 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 tao_random_number (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)) / (abs(prt%t))) * &
	P_gqq (z + 0.5_default * zstep) * get_pdf (prt%initial%type, &
	prt%x / (z + 0.5_default * zstep), abs(prt%t), 21)
	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 / 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
	! print *, " shower_prepare_for_simulate_isr_pt"
	!!! get sqrts of interaction
	s = (interaction%partons(1)%p%momentum + &
	interaction%partons(2)%p%momentum)**2
	interaction%partons(1)%p%scale = tscalefactor_isr * 0.25_default * s
	interaction%partons(2)%p%scale = tscalefactor_isr * 0.25_default * s
	! call shower%add_parent (interaction%partons(1)%p)
	! call shower$add_parent (interaction%partons(2)%p)
	!
	! interaction%partons(1)%p%parent%scale = 0.5_default * sqrts
	! interaction%partons(1)%p%parent%momentum = &
	! interaction%partons(1)%p%momentum
	! interaction%partons(1)%p%parent%belongstoFSR = .false.
	! interaction%partons(1)%p%parent%initial => &
	! interaction%partons(1)%p%initial
	! interaction%partons(2)%p%parent%scale = 0.5_default * sqrts
	! interaction%partons(2)%p%parent%momentum = &
	! interaction%partons(2)%p%momentum
	! interaction%partons(2)%p%parent%belongstoFSR = .false.
	! interaction%partons(2)%p%parent%initial => &
	! interaction%partons(2)%p%initial
	!
	! call shower%add_child (interaction%partons(1)%p%parent, 2)
	! call shower%add_child (interaction%partons(2)%p%parent, 2)
	! print *, " shower_prepare_for_simulate_isr_pt finished"
	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) :: pini(0:3), scale, factor
	integer :: i
	! print *, " shower_prepare_for_simulate_isr_ana"
	if (.not. associated (prt1%initial) .or. .not. associated (prt2%initial)) then
	return
	end if
	do i = 0, 3
	pini(i) = parton_get_momentum (prt1,i) + parton_get_momentum (prt2,i)
	end do
	scale = - (pini(0)2 - pini(1)2 - pini(2)2 - pini(3)2)
	call parton_set_simulated (prt1)
	call parton_set_simulated (prt2)
	call shower%add_parent (prt1)
	call shower%add_parent (prt2)
	factor = sqrt (vector4_get_component (prt1%momentum, 0)**2 - scale) / &
	space_part_norm(prt1%momentum)
	prt1%parent%type = prt1%type
	prt1%parent%z = 1._double
	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 = 1._double
	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

	do i = 0, 3
	pini(i) = parton_get_momentum (prt1,i) + parton_get_momentum (prt2,i)
	end do
	call parton_set_energy (prta, (pini(0)**2 - prtb%t + prta%t) &
	/ (two * pini(0)))
	call parton_set_energy (prtb, pini(0) &
	- vector4_get_component (prta%momentum, 0))

	! if (abs( (prt1%parent%x * vector4_get_component(prt2%parent%momentum, 0)-&
	! prt2%parent%x * vector4_get_component(prt1%parent%momentum, 0))/ &
	! (prt1%parent%x * vector4_get_component(prt2%parent%momentum, 3)-&
	! prt2%parent%x * vector4_get_component(prt1%parent%momentum, 3)) ).gt. 1._double) then
	! print , "cycle", abs( (prt1%parent%x vector4_get_component(prt2%parent%momentum, 0)-&
	! prt2%parent%x * vector4_get_component(prt1%parent%momentum, 0))/ &
	! (prt1%parent%x * vector4_get_component(prt2%parent%momentum, 3)-&
	! prt2%parent%x * vector4_get_component(prt1%parent%momentum, 3)) )
	! cycle
	! else
	exit
	! end if
	end do
	! print , "BETA+", (prt1%parent%x vector4_get_component(prt2%parent%momentum, 0)-&
	! prt2%parent%x * vector4_get_component(prt1%parent%momentum, 0))/ &
	! (prt1%parent%x * vector4_get_component(prt2%parent%momentum, 3)-&
	! prt2%parent%x * vector4_get_component(prt1%parent%momentum, 3))
	!!! TODO check the code above
	call parton_set_simulated (prt1%parent)
	call parton_set_simulated (prt2%parent)
	!!! rescale momenta
	do i = 1, 2
	if (i == 1) then
	prt => prt1%parent
	else
	prt => prt2%parent
	end if
	factor = sqrt (vector4_get_component (prt%momentum,0)**2 - prt%t) &
	/ space_part_norm (prt%momentum)
	prt%momentum = vector4_moving (vector4_get_component (prt%momentum, 0), &
	factor * space_part (prt%momentum))
	end do

	if (prt1%parent%t < 0._double) 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 < 0._double) 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
	! print *, "after isr_ana_test"
	! call shower%write ()
	! print *, "BETA:"
	! call vector3_write(vector3_canonical(3) * &
	! ( (prt1%parent%x * vector4_get_component(prt2%parent%momentum, 0)-&
	! prt2%parent%x * vector4_get_component(prt1%parent%momentum, 0))/ &
	! (prt1%parent%x * vector4_get_component(prt2%parent%momentum, 3)-&
	! prt2%parent%x * vector4_get_component(prt1%parent%momentum, 3)) ) )

	! print *, "after isr_ana_test finished"

	end subroutine shower_prepare_for_simulate_isr_ana_test

	@ %def shower_prepare_for_simulate_isr_ana_test
	@
	<<Shower core: procedures>>=
	subroutine shower_prepare_for_simulate_isr_ana (shower, prt1, prt2)
	type(shower_t), intent(inout) :: shower
	type(parton_t), intent(inout), target :: prt1, prt2
	type(parton_t), pointer :: prt
	real(default) :: pini(0:3), scale, factor
	real(default) :: oldscales(1:2)
	type(parton_pointer_t) :: temppp
	integer :: i

	if (signal_is_pending ()) return
	! print *, " shower_prepare_for_simulate_isr_ana"

	if (.not. associated (prt1%initial) .or. &
	.not. associated (prt2%initial)) then
	return
	end if

	do i = 0,3
	pini(i) = parton_get_momentum (prt1,i) + parton_get_momentum (prt2,i)
	end do
	scale = - (pini(0)2 - pini(1)2 - pini(2)2 - pini(3)2)

	prt1%t = -tscalefactor_isr * abs(scale)
	prt2%t = -tscalefactor_isr * abs(scale)
	!!! rescale momenta
	do i = 1, 2
	if (i == 1) then
	prt => prt1
	else
	prt => prt2
	end if

	factor = sqrt (parton_get_energy (prt)**2 - prt%t) / &
	space_part_norm(prt%momentum)

	prt%momentum = vector4_moving (parton_get_energy (prt), &
	factor * space_part (prt%momentum))
	end do

	!!! ensure that belongstointeraction bits are set correctly
	prt1%belongstointeraction = .true.
	prt2%belongstointeraction = .true.

	call shower%add_parent (prt1)
	call shower%add_parent (prt2)

	call parton_set_simulated (prt1)
	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
	call shower%add_child (prt1%parent, 2)

	call parton_set_simulated (prt2)
	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
	call shower%add_child (prt2%parent, 2)

	FIRST_BRANCHINGS: do
	if (signal_is_pending ()) return
	oldscales(1) = prt1%parent%t
	oldscales(2) = prt2%parent%t
	if (abs(prt1%parent%t) > abs(prt2%parent%t)) then
	temppp%p => prt1%parent
	else
	temppp%p => prt2%parent
	end if
	if (.not. parton_is_simulated(temppp%p) .and. .not. parton_is_hadron &
	(temppp%p)) then
	call shower_isr_step (shower, temppp%p)
	if (parton_is_simulated(temppp%p)) then
	! call parton_generate_ps_ini(prt2%parent)
	if (temppp%p%t < zero) then
	call shower%execute_next_isr_branching (temppp)
	! call shower%write ()
	else
	call shower_replace_parent_by_hadron (shower, temppp%p%child1)
	end if
	end if
	end if

	if (oldscales(1) == prt1%parent%t .and. &
	oldscales(2) == prt2%parent%t) then
	exit FIRST_BRANCHINGS
	end if
	end do FIRST_BRANCHINGS

	! print *, " shower_prepare_for_simulate_isr_ana finished"
	end subroutine shower_prepare_for_simulate_isr_ana

	@ %def shower_prepare_for_simulate_isr_ana
	@
	<<Shower core: procedures>>=
	!! subroutine shower_prepare_for_simulate_fsr_ana (shower, prt1, prt2)
	!! type(shower_t), intent(inout) :: shower
	!! type(parton_t), pointer :: prt1, prt2
	!! real(default) :: pini(4)
	!! integer i
	!!
	!! ! print *, "shower_prepare_for_simulate_fsr_ana"
	!!
	!! !!! Define imagined single initiator of shower
	!! call shower%add_child (prt1, 1)
	!! do i = 1, 4
	!! pini(i) = parton_get_momentum (prt1,i - 1) + parton_get_momentum (prt2, i - 1)
	!! end do
	!! call parton_set_simulated (prt1)
	!! call parton_set_child (prt1, prt1%child1, 1)
	!! call parton_set_child (prt1, prt1%child1, 2)
	!! call parton_set_simulated (prt2)
	!! call parton_set_child (prt2, prt1%child1, 1)
	!! call parton_set_child (prt2, prt1%child1, 2)
	!!
	!! prt1%child1%type = 94
	!! prt1%child1%z = parton_get_energy (prt1) / &
	!! (parton_get_energy (prt1) + parton_get_energy (prt2))
	!! call parton_set_simulated (prt1%child1)
	!! call parton_set_parent (prt1%child1, prt1)
	!! call parton_set_momentum (prt1%child1, pini(1), pini(2), pini(3), pini(4))
	!! prt1%child1%t = parton_p4square(prt1%child1)
	!! prt1%child1%costheta = -one
	!!
	!! call shower%add_child (prt1%child1, 1)
	!! call shower%add_child (prt1%child1, 2)
	!!
	!! prt1%child1%child1%typ = prt1%typ
	!! prt1%child1%child1%momentum = prt1%momentum
	!! prt1%child1%child1%t = prt1%child1%t
	!! call parton_set_parent (prt1%child1%child1, prt1%child1)
	!! prt1%child1%child1%c1 = prt1%c1
	!! prt1%child1%child1%c2 = prt1%c2
	!!
	!! prt1%child1%child2%typ = prt2%typ
	!! prt1%child1%child2%momentum = prt2%momentum
	!! prt1%child1%child2%t = prt2%child1%t
	!! call parton_set_parent (prt1%child1%child2, prt1%child1)
	!! prt1%child1%child2%c1 = prt2%c1
	!! prt1%child1%child2%c2 = prt2%c2
	!!
	!! ! print *, " shower_prepare_for_simulate_fsr_ana finished"
	!! end subroutine shower_prepare_for_simulate_fsr_ana

	@ %def shower_prepare_for_simulate_fsr_ana
	@
	<<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 > parton_mass_squared (prt) + D_Min_t) then
	if (parton_is_quark (prt)) then
	!!! q -> qg
	call shower%add_child (prt, 1)
	prt%child1%type = prt%type
	call parton_set_energy (prt%child1, prt%z * parton_get_energy (prt))
	prt%child1%t = prt%t
	call shower%add_child (prt, 2)
	prt%child2%type = 21
	call parton_set_energy (prt%child2, (one - prt%z) * &
	parton_get_energy (prt))
	prt%child2%t = prt%t
	else
	if (int (prt%x) > 0) then
	call shower%add_child (prt, 1)
	prt%child1%type = int (prt%x)
	call parton_set_energy (prt%child1, prt%z * parton_get_energy (prt))
	prt%child1%t = prt%t
	call shower%add_child (prt, 2)
	prt%child2%type = -int (prt%x)
	call parton_set_energy (prt%child2, (one - prt%z) * &
	parton_get_energy (prt))
	prt%child2%t= prt%t
	else
	call shower%add_child (prt, 1)
	prt%child1%type = 21
	call parton_set_energy (prt%child1, prt%z * parton_get_energy (prt))
	prt%child1%t = prt%t
	call shower%add_child (prt, 2)
	prt%child2%type = 21
	call parton_set_energy (prt%child2, (one - prt%z) * &
	parton_get_energy (prt))
	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) :: 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 *, " 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 * parton_get_energy (prt%child1)*2 (one - &
	parton_get_costheta (prt)))
	if (min (prt%child1%t, parton_get_energy (prt%child1)**2) < &
	parton_mass_squared (prt%child1) + D_Min_t) then
	prt%child1%t = parton_mass_squared (prt%child1)
	call parton_set_simulated (prt%child1)
	end if
	end if
	if (.not. prt%child2%simulated) then
	prt%child2%t = min (prt%child2%t, &
	0.5_default * parton_get_energy (prt%child2)*2 (one - &
	parton_get_costheta (prt)))
	if (min (prt%child2%t, parton_get_energy (prt%child2)**2) < &
	parton_mass_squared (prt%child2) + D_Min_t) then
	prt%child2%t = parton_mass_squared (prt%child2)
	call parton_set_simulated (prt%child2)
	end if
	end if

	call tao_random_number (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. parton_is_simulated (prt%child1)) then
	call parton_simulate_stept &
	(prt%child1, integral(1), random(1), gtoqq(1))
	end if
	!!! check for child2
	if (.not. parton_is_simulated(prt%child2)) then
	call parton_simulate_stept &
	(prt%child2, integral(2), random(2), gtoqq(2))
	end if

	if (parton_is_simulated (prt%child1) .and. &
	parton_is_simulated (prt%child2)) 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)

	<<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 (abs (prt%type) >= 90 .and. abs (prt%type) <= 93) then
	!!! prt is beam-remnant
	call parton_set_simulated (prt)
	return
	end if

	!!! check if partons are "internal" -> fixed scale
	if (prt%child1%type == 94) then
	call parton_set_simulated (prt%child1)
	end if
	if (prt%child2%type == 94) then
	call parton_set_simulated (prt%child2)
	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 == 94 .and. prt%child2%type == 94) then
	call msg_fatal &
	("Shower: both partons fixed, but momentum not conserved")
	else if (prt%child1%type == 94) then
	!!! reset child2
	call parton_set_simulated (prt%child2, .false.)
	prt%child2%t = min (prt%child1%t, (sqrt (prt%t) - &
	sqrt (prt%child1%t))**2)
	integral(2) = zero
	call tao_random_number (random(2))
	else if (prt%child2%type.eq.94) then
	! reset child1
	call parton_set_simulated (prt%child1, .false.)
	prt%child1%t = min (prt%child2%t, (sqrt (prt%t) - &
	sqrt (prt%child2%t))**2)
	integral(1) = zero
	call tao_random_number (random(1))
	else if (prt%child1%t - parton_mass_squared (prt%child1) > &
	prt%child2%t - parton_mass_squared (prt%child2)) then
	!!! reset child2
	call parton_set_simulated (prt%child2, .false.)
	prt%child2%t = min (prt%child1%t, (sqrt (prt%t) - &
	sqrt (prt%child1%t))**2)
	integral(2) = zero
	call tao_random_number (random(2))
	else
	!!! reset child1 ! TODO choose child according to their t
	call parton_set_simulated (prt%child1, .false.)
	prt%child1%t = min (prt%child2%t, (sqrt (prt%t) - &
	sqrt (prt%child2%t))**2)
	integral(1) = zero
	call tao_random_number (random(1))
	end if
	@
	<<Add children>>=
	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 < parton_mass_squared (daughterprt) + 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
	call parton_set_energy (daughterprt%child1, &
	daughterprt%z * parton_get_energy (daughterprt))
	daughterprt%child1%t = daughterprt%t
	call shower%add_child (daughterprt, 2)
	daughterprt%child2%type = 21
	call parton_set_energy (daughterprt%child2, (one - &
	daughterprt%z) * parton_get_energy (daughterprt))
	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)
	call parton_set_energy (daughterprt%child1, &
	daughterprt%z * parton_get_energy (daughterprt))
	daughterprt%child1%t = daughterprt%t
	call shower%add_child (daughterprt, 2)
	daughterprt%child2%type = - gtoqq (daughter)
	call parton_set_energy (daughterprt%child2, (one - &
	daughterprt%z) * parton_get_energy (daughterprt))
	daughterprt%child2%t = daughterprt%t
	else
	call shower%add_child (daughterprt, 1)
	daughterprt%child1%type = 21
	call parton_set_energy (daughterprt%child1, &
	daughterprt%z * parton_get_energy (daughterprt))
	daughterprt%child1%t = daughterprt%t
	call shower%add_child (daughterprt, 2)
	daughterprt%child2%type = 21
	call parton_set_energy (daughterprt%child2, (one - &
	daughterprt%z) * parton_get_energy (daughterprt))
	daughterprt%child2%t = daughterprt%t
	end if
	end if
	end do
	@
	<<Shower core: procedures>>=
	subroutine shower_generate_next_fsr_branchings (shower)
	type(shower_t), intent(inout) :: shower
	integer i, index
	type(parton_t), pointer :: prt

	!!! find mother with highest t to be simulated
	index = 0
	do i = 1, size (shower%partons)
	prt => shower%partons(i)%p
	if (.not. prt%belongstoFSR) cycle
	if (prt%belongstointeraction) cycle
	if (associated(prt%child1) .and. associated(prt%child2)) then
	if (parton_is_simulated (prt%child1) .and. &
	parton_is_simulated (prt%child2)) cycle
	end if
	if (parton_is_final (prt)) cycle

	index = i
	exit
	end do

	if (index.eq.0) then
	call msg_message ("Shower: no branchable partons found")
	return
	end if

	prt => shower%partons(index)%p
	call shower_simulate_children_ana(shower, prt)

	end subroutine shower_generate_next_fsr_branchings

	@ %def shower_generate_next_fsr_branchings
	@ 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 tao_random_number (temprand1)
	call tao_random_number (temprand2)
	scalestep = max (abs (scalefactor1 * scale) * temprand1, &
	scalefactor2 * temprand2 * D_Min_scale)
	call tao_random_number (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 = parton_mass_squared (prt)
	call parton_set_simulated (prt)
	else
	prt%scale = scale - 0.5_default * scalestep
	factor = scalestep * (D_alpha_s_isr (prt%scale) / (prt%scale * &
	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 parton_set_simulated (prt)
	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 *, "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), maxz_isr)
	zstep = (zmax - zmin) / n_total_bins

	if (zmin > zmax) then
	!!! print *, " error in integral_over_z_isr_pt: zmin > zmax ", &
	!!! zmin, zmax, prt%scale, mbr
	integral = zero
	return
	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 + 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)) * get_pdf (prt%initial%type, &
	prt%x / z, prt%scale, 21) + P_qqg (one - z) * quarkpdfsum)
	else if (parton_is_quark (prt)) then
	!!! q -> qg or g -> qq
	integral = integral + (zstep / z) * ( P_qqg (z) * &
	get_pdf (prt%initial%type, prt%x / z, prt%scale, prt%type) + &
	P_gqq(z) * get_pdf (prt%initial%type, prt%x / z, prt%scale, 21))
	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 tao_random_number (temprand)
	!!! decide typ of father partons
	if (parton_is_gluon (prt)) then
	if (temprand > (P_qqg (one - z) * quarkpdfsum) / &
	((P_ggg (z) + P_ggg (one - z)) * get_pdf &
	(prt%initial%type, prt%x / z, prt%scale, 21) &
	+ P_qqg (one - z) * quarkpdfsum)) then
	!!! gluon => gluon + gluon
	prt%aux_pt = 21
	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 - get_pdf (prt%initial%type, &
	prt%x / z, prt%scale, quark)) then
	prt%aux_pt = quark
	exit WHICH_QUARK
	else
	quarkpdfsum = quarkpdfsum - 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) * get_pdf (prt%initial%type, &
	prt%x / z, prt%scale, prt%type)) / &
	(P_qqg (z) * get_pdf (prt%initial%type, prt%x / z, &
	prt%scale, prt%type) + &
	P_gqq (z) * get_pdf (prt%initial%type, prt%x / z, &
	prt%scale, 21))) then
	!!! gluon => quark + antiquark
	prt%aux_pt = 21
	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. parton_is_simulated (prt)) cycle
	n_partons = n_partons + 1
	end do
	!!! print *, "n_partons = ", n_partons
	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. parton_is_simulated (prt)) cycle
	if (signal_is_pending ()) return
	partons(n_partons)%p => shower%partons(i)%p
	n_partons = n_partons + 1
	end do
	! print *, "trials"
	!!! generate initial trial scales
	do i = 1, size (partons)
	if (signal_is_pending ()) return
	call generate_next_trial_scale (partons(i)%p)
	end do
	! print *, "trials finished"

	do
	! call shower%write ()
	!!! 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)) &
	/ sqrt (alphasxpdfmax))
	temp2 = get_xpdf (prt%initial%type, prt%x, prt%t, &
	prt%type) / sqrt (alphasxpdfmax)
	temp3 = get_xpdf (prt%initial%type, prt%child1%x, prt%child1%t, &
	prt%child1%type) / &
	get_xpdf (prt%initial%type, prt%child1%x, prt%t, prt%child1%type)
	if (temp1 * temp2 * temp3 > one) then
	print *, "weights:", temp1, temp2, temp3
	end if
	weight = (D_alpha_s_isr ((one - prt%z) * abs(prt%t))) * &
	get_xpdf (prt%initial%type, prt%x, prt%t, prt%type) * &
	get_xpdf (prt%initial%type, prt%child1%x, prt%child1%t, &
	prt%child1%type) / &
	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 tao_random_number (random)
	! print *, weight , ">", 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)
	call parton_set_energy (prt%child2, sqrt (abs(prt%t)))
	if (isr_only_onshell_emitted_partons) then
	prt%child2%t = parton_mass_squared(prt%child2)
	else
	call parton_next_t_ana (prt%child2)
	end if

	if (thetabar (prt, shower_find_recoiler (shower, prt), E3)) then
	!!! setting energies
	call parton_set_energy (prt, E3)
	call parton_set_energy (prt%child2, &
	E3 - parton_get_energy (prt%child1))

	!!! found branching
	call parton_generate_ps_ini (prt)
	next_brancher%p => prt
	call parton_set_simulated (prt)
	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 !! ??
	! print *, "generate next_trial"
	call tao_random_number (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
	print *, "neither quark nor gluon in generate_next_trial_scale"
	end if
	F = F / 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) - parton_mass_squared (prt) < D_Min_t) then
	prt%t = parton_mass_squared (prt)
	end if
	! print *, "generate next_trial finished"
	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 !! ??
	! print *, "generate next_z"
	call tao_random_number(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 = 21
	integral = integral_over_P_qqg (prt%child1%x, zmax)
	else
	prt%type = 21
	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 = 21
	prt%child2%type = 21
	integral = integral_over_P_ggg (prt%child1%x, zmax)
	else
	call tao_random_number (random)
	prt%type = 1 + floor(random * D_Nf)
	call tao_random_number (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
	print *, "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 tao_random_number(random)
	zmin = prt%child1%x
	zstep = max(0.1_default, 0.5_default * (zmax - zmin))
	z = zmin
	! print *, zmin, z
	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
	! print *, 1, z, zstep, zmin, zmax
	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
	! print *, 2, z, zstep
	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
	! print *, 3, z, zstep
	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
	! print *, 4, z, zstep
	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
	! print *, "generate next_z finished"
	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
	logical :: goon
	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_hadron(otherprt1%parent) .and. &
	parton_is_simulated (otherprt1%parent)) 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_hadron(otherprt2%parent) .and. &
	parton_is_simulated (otherprt2%parent)) 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
	! print *, "shower_isr_step for parton ", prt%nr
	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 tao_random_number(random)
	! compare Integral and log(random) instead of random and exp(-Integral)
	random = - twopi * log(random)
	integral = zero
	call tao_random_number (temprand1)
	call tao_random_number (temprand2)
	tstep = max (abs (0.02_default * t) * temprand1, &
	0.02_default * temprand2 * D_Min_t)
	if (t + 0.5_default * tstep > - D_Min_t) then
	prt%t = parton_mass_squared (prt)
	call parton_set_simulated (prt)
	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 parton_set_simulated (prt)
	else
	prt%t = t + tstep
	end if
	end if

	! print *, " shower_isr_step finished"

	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)

	!!! for gluon
	if (parton_is_gluon (prt%child1)) then
	!!! 1: g->gg
	prt%type = 21
	prt%child2%type = 21
	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
	! print *, "prt%type = ", prt%type
	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
	! print *, "prt%type = ", prt%type
	return
	end if
	end do
	else if (parton_is_quark (prt%child1)) then
	!!! 1: q->qg
	prt%type = prt%child1%type
	prt%child2%type = 21
	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
	! print *, "prt%type = ", prt%type
	return
	end if
	!!! 2: g->qqbar
	prt%type = 21
	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
	! print *, "prt%type = ", prt%type
	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 *, "integral_over_z_part_isr"
	pdf_divisor = 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 tao_random_number (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 (otherprt%t /= zero) 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
	call parton_set_energy (prt%child2, sqrt (abs(prt%child2%t)))
	if (isr_only_onshell_emitted_partons) then
	prt%child2%t = parton_mass_squared (prt%child2)
	else
	call parton_next_t_ana (prt%child2)
	end if
	!!! take limits by recoiler into account
	call parton_set_energy (prt, (shat / prt%z + &
	abs(otherprt%t) - abs(prt%child1%t) - &
	prt%child2%t) / (two * sqrt(shat)))
	call parton_set_energy (prt%child2, &
	parton_get_energy (prt) - parton_get_energy (prt%child1))
	!!! check if E and t of prt%child2 are consistent
	if (parton_get_energy (prt%child2)**2 < prt%child2%t &
	.and. prt%child2%t > parton_mass_squared (prt%child2)) 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) .and. pdf_divisor > zero &
	.and. parton_get_energy (prt%child2) > zero) then
	retvalue = retvalue + (zstep / prt%z) * &
	(D_alpha_s_isr ((one - prt%z) * prt%t) * &
	P_prt_to_child1 (prt) * &
	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. parton_is_simulated (prt)) cycle
	index = i
	exit
	end do
	if (index == 0) then
	! print *, " no branchable partons found"
	return
	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 (parton_is_simulated (prt)) then
	if (prt%t < zero) then
	next_brancher%p => prt
	if (.not. isr_pt_ordered) call parton_generate_ps_ini (prt)
	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?
	! print *, "shower_generate_next_isr_branching finished"
	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 (isr_only_onshell_emitted_partons) return

	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_hadron (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
	flavours, 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
	! print *, "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 > - 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_hadron (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 tao_random_number (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 flavour 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 flavour
	prtc%type = 21 ! emitted gluon
	else
	!!! gluon -> quark + antiquark
	prta%type = 21
	prtc%type = - prtb%type
	end if
	else if (parton_is_gluon (prtb)) then
	prta%type = 21
	prtc%type = 21
	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), &
	vector4_get_component (prtb%momentum, 3)))
	prtr%momentum = vector4_moving ((mbr*2 - prtb%t) / (two mbr), &
	vector3_canonical(3) * &
	sign( (mbr*2 - prtb%t) / (two mbr), &
	vector4_get_component(prtr%momentum, 3)))

	prta%momentum = vector4_moving ((0.5_default / mbr) * &
	((mbr**2 / prtb%z) + prtb%t - parton_mass_squared(prtc)), &
	vector3_null)
	prta%momentum = vector4_moving (parton_get_energy (prta), &
	vector3_canonical(3) * &
	(0.5_default / vector4_get_component (prtb%momentum, 3)) * &
	((mbr**2 / prtb%z) - two &
	* parton_get_energy(prtr) * parton_get_energy(prta) ) )
	if (parton_get_energy(prta)**2 - vector4_get_component &
	(prta%momentum,3)**2 - parton_mass_squared (prtc) &
	> zero) then
	!!! This SHOULD be always fulfilled???
	prta%momentum = vector4_moving (parton_get_energy (prta), &
	vector3_moving([sqrt (parton_get_energy(prta)**2 - &
	vector4_get_component (prta%momentum, 3)**2 - &
	parton_mass_squared (prtc)), zero, &
	vector4_get_component(prta%momentum, 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 > parton_mass_squared(prt%child2)) then
	call shower_add_children_of_emitted_timelike_parton &
	(shower, prt%child2)
	call parton_set_simulated (prt%child2)
	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)
	else
	call parton_generate_ps_ini (prt)
	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
	else
	! STOP "Bug in shower_execute_nexT_branching:
	! neither quark nor gluon"
	end if

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

	! print *, " shower_execute_next_isr_branching finished"
	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
	! print *, " shower_remove_parents for parton ", prt%nr
	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_hadron (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
	! print *, " removing parton ", actprt%child2%nr
	call shower_remove_parton_from_partons_recursive &
	(shower, actprt%child2)
	! print *, " removing parton ", actprt%nr
	call shower_remove_parton_from_partons (shower, actprt)

	end do
	prt%parent=>null()

	! print *, " shower_remove_parents for parton finished"
	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>>=
	!!! MERGIND: not sure which function is the right one
	!!! 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 = (10._default)**10
	!!! do i = 1, size(shower%interactions)
	!!! call interaction_find_partons_nearest_to_hadron(shower%interactions(i)%i, &
	!!! prt1, prt2)
	!!! call shower%write ()
	!!! call parton_write(prt1)
	!!! call parton_write(prt2)
	!!!
	!!! if (isr_pt_ordered) then
	!!! if ((parton_is_hadron(prt1%parent).eqv..false.).and.(abs(prt1%parent%scale).gt.scale)) scale = abs(prt1%parent%scale)
	!!! if ((parton_is_hadron(prt1%parent).eqv..false.).and.(abs(prt2%parent%scale).gt.scale)) scale = abs(prt2%parent%scale)
	!!! else
	!!! if ((parton_is_simulated(prt1)).and.(abs(prt1%t).lt.scale)) scale = abs(prt1%t)
	!!! if ((parton_is_simulated(prt2)).and.(abs(prt2%t).lt.scale)) scale = abs(prt2%t)
	!!!! if ((parton_is_hadron(prt1%parent).eqv..false.).and.(abs(prt2%parent%t).gt.scale)) scale = abs(prt2%parent%t)
	!!! end if
	!!! end do
	!!! print *, "returning: ", scale
	!!!! pause
	!!! end function shower_get_ISR_scale

	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. parton_is_simulated (prt1) .and. abs(prt1%scale) > scale) &
	scale = abs(prt1%scale)
	if (.not. parton_is_simulated (prt1) .and. abs(prt2%scale) > scale) &
	scale = abs(prt2%scale)
	end do
	! call shower%write ()
	! call parton_write(prt1)
	! call parton_write(prt2)
	! print *, "returning: ", scale
	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_hadron (prt)) then
	!!! don't reset scales of "first" spacelike partons
	!!! in virtuality ordered shower or hadrons
	cycle
	end if
	else
	if (parton_is_hadron (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 parton_set_simulated (prt, .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>>=
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!!!! new version
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	!!! subroutine shower_interaction_generate_fsr(shower, interaction)
	!!! type(shower_t), intent(inout) :: shower
	!!! type(shower_interaction_t), intent(inout) :: interaction
	!!! type(parton_pointer_t), dimension(:), allocatable :: partons ! array of partons whose children are to be evolved
	!!!
	!!! ! arrange partons to be included in <partons>
	!!! ! for qqbar state: include imaginary mother + first branching
	!!! call shower_prepare_for_simulate_fsr_ana(shower, interaction%out1%p, interaction%out2%p)
	!!!
	!!! allocate(partons(1:1))
	!!! partons(1)%p => interaction%out1%p%child1
	!!! call shower_parton_pointer_array_generate_fsr(shower, partons)
	!!! call shower_parton_update_color_connections(shower, interaction%out1%p%child1%child1)
	!!! call shower_parton_update_color_connections(shower, interaction%out1%p%child1%child2)
	!!! end subroutine shower_interaction_generate_fsr

	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
	if (signal_is_pending ()) return
	if (.not. parton_is_branched (prt)) then
	print *, " error in shower_parton_generate_fsr: parton not branched"
	return
	end if
	if (parton_is_simulated (prt%child1) .or. &
	parton_is_simulated (prt%child2)) then
	! print *, " error in shower_parton_generate_fsr: children
	! already simulated for parton ", prt%nr
	! call shower%write ()
	return
	end if

	allocate (partons(1:1))
	partons(1)%p => prt
	call shower_parton_pointer_array_generate_fsr (shower, partons)

	end subroutine shower_parton_generate_fsr

	@ %def shower_parton_generate_fsr
	@
	<<Shower core: procedures>>=
	recursive subroutine shower_parton_pointer_array_generate_fsr &
	(shower, partons)
	type(shower_t), intent(inout) :: shower
	type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: &
	partons
	type(parton_pointer_t), dimension(:), allocatable :: partons_new
	integer :: i, size_partons, size_partons_new
	size_partons = size (partons)
	if (signal_is_pending ()) return
	if (size_partons == 0) return
	!!! sort partons -> necessary ?? -> probably not
	!!! 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_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)

	! print *, "end subroutine shower_parton_pointer_array_generate_fsr"
	call shower_parton_pointer_array_generate_fsr (shower, partons_new)

	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 tao_random_number (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. Note that the arguments for [[evolvepdf]] need to be
	defined as [[double]] explicitly.
	<<Shower core: procedures>>=
	function get_pdf (mother, x, Q2, daughter) result (pdf)
	! type(shower_t), intent(in), pointer :: 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 (abs (mother) /= 2212) then
	call msg_fatal ("Shower: pdf only implemented for (anti-)proton")
	else
	if (x > zero .and. x < one) then
	if (dble(Q2) /= lastQ2 .or. dble(x) /= lastx) then
	! call evolvePDF(DBLE(x),sqrt(abs(DBLE(Q2))),f) !! LHAPDF
	call shower_pdf_func &
	(shower_pdf_set, 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)), 1E-10_default) / x
	else if (daughter == 21) then
	pdf = max (f(0), 1E-10_default) / x
	else
	print *, "error in pdf, unknown daughter", daughter
	pdf = zero
	end if
	else
	pdf = zero
	end if
	end if
	lastQ2 = dble(Q2)
	lastx = dble(x)
	end function get_pdf

	@ %def get_pdf
	@ Wrapper function to return momentum densities. The arguments for
	[[evolvepdf]] need to be defined as [[double]] explicitly.
	<<Shower core: procedures>>=
	function get_xpdf (mother, x, Q2, daughter) result (pdf)
	! type(shower_t), intent(in), pointer :: 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 (abs (mother) /= 2212) then
	call msg_fatal ("Shower: pdf only implemented for (anti-)proton")
	else
	if (x > zero .and. x < one) then
	if (dble(Q2) /= lastQ2 .or. dble(x) /= lastx) then
	! call evolvePDF(DBLE(x),sqrt(abs(DBLE(Q2))),f) !! LHAPDF
	call shower_pdf_func &
	(shower_pdf_set, 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)), 1E-10_default)
	else if (daughter == 21) then
	pdf = max(f(0), 1E-10_default)
	else
	print *, "error in pdf, unknown daughter", daughter
	pdf = zero
	end if
	else
	pdf = zero
	end if
	end if
	lastQ2 = dble(Q2)
	lastx = dble(x)
	end function get_xpdf

	@ %def get_xpdf
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Talking to PYTHIA}
	<<[[shower_topythia.f90]]>>=
	<<File header>>

	module shower_topythia

	<<Use kinds>>
	use lorentz !NODEP!
	use shower_base
	use shower_partons
	use shower_core

	<<Standard module head>>

	<<Shower2pythia: public>>

	contains

	<<Shower2pythia: procedures>>

	end module shower_topythia

	@ %def shower_topythia
	@
	<<Shower2pythia: public>>=
	public :: shower_converttopythia
	@
	<<Shower2pythia: 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) = 21
	K(i,2) = pp%initial%type
	K(i,3) = 0
	P(i,1) = vector4_get_component (pp%initial%momentum,1)
	P(i,2) = vector4_get_component (pp%initial%momentum,2)
	P(i,3) = vector4_get_component (pp%initial%momentum,3)
	P(i,4) = vector4_get_component (pp%initial%momentum,0)
	P(I,5) = pp%initial%momentum**2
	!!! add partons emitted by the hadron
	ppparent => pp
	do while (associated (ppparent%parent))
	if (parton_is_hadron (ppparent%parent)) then
	exit
	else
	ppparent => ppparent%parent
	end if
	end do
	K(i+2,1) = 21
	K(i+2,2) = ppparent%type
	K(i+2,3) = i
	P(i+2,1) = vector4_get_component (ppparent%momentum,1)
	P(i+2,2) = vector4_get_component (ppparent%momentum,2)
	P(i+2,3) = vector4_get_component (ppparent%momentum,3)
	P(i+2,4) = vector4_get_component (ppparent%momentum,0)
	P(I+2,5) = ppparent%momentum**2
	!!! add partons in the initial state of the ME
	K(i+4,1) = 21
	K(i+4,2) = pp%type
	K(i+4,3) = i
	P(i+4,1) = vector4_get_component (pp%momentum,1)
	P(i+4,2) = vector4_get_component (pp%momentum,2)
	P(i+4,3) = vector4_get_component (pp%momentum,3)
	P(i+4,4) = vector4_get_component (pp%momentum,0)
	P(I+4,5) = pp%momentum**2
	else
	!!! for e+e- without ISR all entries are the same
	K(i,1) = 21
	K(i,2) = pp%type
	K(i,3) = 0
	P(i,1) = vector4_get_component (pp%momentum,1)
	P(i,2) = vector4_get_component (pp%momentum,2)
	P(i,3) = vector4_get_component (pp%momentum,3)
	P(i,4) = vector4_get_component (pp%momentum,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) = 21
	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) = 21
	K(7+I,2) = pp%type
	K(7+I,3) = 7
	P(7+I,1) = vector4_get_component (pp%momentum, 1)
	P(7+I,2) = vector4_get_component (pp%momentum, 2)
	P(7+I,3) = vector4_get_component (pp%momentum, 3)
	P(7+I,4) = vector4_get_component (pp%momentum, 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
	@
	<<Shower2pythia: 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()

	!!! !!! old version using (anti-)colorpartner pointers
	!!!
	!!! partons: do i = 1, size(shower%partons)
	!!! ! loop over partons to find quarks = beginnings of color strings
	!!! if (.not. associated(shower%partons(i)%p)) cycle
	!!! prt=> shower%partons(i)%p
	!!! if (associated(prt%child1)) cycle
	!!! if (.not. parton_is_quark(prt)) cycle
	!!! if (.not. prt%type > 0 ) cycle
	!!!
	!!! color_string: do
	!!! ! transfer prt to PYHIA
	!!! N = N+1
	!!! K(N,1) = 2
	!!! K(N,2) = prt%type
	!!! K(N,3) = first
	!!! K(N,4) = 0
	!!! K(N,5) = 0
	!!! P(N,1) = vector4_get_component(prt%momentum, 1)
	!!! P(N,2) = vector4_get_component(prt%momentum, 2)
	!!! P(N,3) = vector4_get_component(prt%momentum, 3)
	!!! P(N,4) = vector4_get_component(prt%momentum, 0)
	!!! P(N,5) = prt%t
	!!!
	!!! if (associated(prt%colorpartner)) then
	!!! prt=>prt%colorpartner
	!!! cycle color_string
	!!! else
	!!! K(N,1) = 1 !mark end of string
	!!! exit color_string
	!!! end if
	!!! end do color_string
	!!! end do partons

	!!! new version using color indices

	!!! 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
	!!! print *, "n_finals=", n_finals

	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) = vector4_get_component (prt%momentum, 1)
	P(N,2) = vector4_get_component (prt%momentum, 2)
	P(N,3) = vector4_get_component (prt%momentum, 3)
	P(N,4) = vector4_get_component (prt%momentum, 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
	@
	<<Shower2pythia: procedures>>=
	recursive subroutine shower_topythia_recursive_weighted (prt, mode, 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(parton_t), intent(in), target :: prt
	integer, intent(in) :: mode, first
	integer :: n_emissions
	type(parton_t), pointer :: tempprt, finalprt
	real(default), dimension(:), allocatable :: costhetas
	type(parton_pointer_t), dimension(:), allocatable :: emittedpartons
	integer :: i, max
	real(default) :: maxcostheta

	n_emissions = 0

	if (parton_is_final(prt)) then
	N = N + 1
	K(N,1) = 2
	if (parton_is_quark(prt)) then
	! check if quark is end of a color connection
	if (prt%type < 0) then
	K(N,1) = 1
	end if
	end if
	K(N,2) = prt%type
	K(N,3) = first
	K(N,4) = 0
	K(N,5) = 0
	P(N,1) = vector4_get_component (prt%momentum, 1)
	P(N,2) = vector4_get_component (prt%momentum, 2)
	P(N,3) = vector4_get_component (prt%momentum, 3)
	P(N,4) = vector4_get_component (prt%momentum, 0)
	P(N,5) = prt%t
	else
	!!! search for following final partons
	if (parton_is_gluon (prt)) then
	if (parton_is_gluon(prt%child1)) then
	!!! g-> gg so sequence is unimportant
	call shower_topythia_recursive_weighted (prt%child1, 1, first)
	call shower_topythia_recursive_weighted (prt%child2, 1, first)
	else
	!!! g-> qqbar -> use antiquark first,
	!!! so that color flow is given correctly
	if (prt%child1%type < 0) then
	call shower_topythia_recursive_weighted (prt%child1, 1, first)
	call shower_topythia_recursive_weighted (prt%child2, 2, first)
	else
	call shower_topythia_recursive_weighted (prt%child2, 2, first)
	call shower_topythia_recursive_weighted (prt%child1, 1, first)
	end if
	end if
	else
	!!! parton is quark
	!!! find the emitted gluons and order them by the emission angle
	n_emissions = 0
	tempprt = prt
	do
	!!! calculate how many emissions there are
	if (associated (tempprt%child1)) then
	tempprt => tempprt%child1
	n_emissions = n_emissions +1
	cycle
	else
	exit
	end if
	end do

	allocate (costhetas(1:n_emissions))
	allocate (emittedpartons(1:n_emissions))

	tempprt => prt
	n_emissions = 1
	do
	if (associated (tempprt%child1)) then
	costhetas(n_emissions) = parton_get_costheta_correct (tempprt)
	emittedpartons(n_emissions)%p => tempprt%child2
	n_emissions = n_emissions +1
	tempprt => tempprt%child1
	cycle
	else
	finalprt=>tempprt
	exit
	end if
	end do

	!!! if mode .eq. 1 write quark first
	if (mode == 1) &
	call shower_topythia_recursive_weighted (finalprt, 1, first)

	!!! if mode .eq. 2 write out gluons in recursive order <= replace
	!!! costheta by 1- costheta
	if (mode == 2) then
	do i = 1, size (costhetas)
	costhetas(i) = one - costhetas(i)
	end do
	end if

	do
	max = 0
	maxcostheta = zero
	do i = 1, size (costhetas)
	if (costhetas(i) > maxcostheta) then
	maxcostheta = costhetas(i)
	max = i
	end if
	end do
	if (maxcostheta == zero) then
	exit
	end if

	call shower_topythia_recursive_weighted &
	(emittedpartons(max)%p, mode, first)
	costhetas(max) = zero
	end do

	!!! if mode .eq. 2 write quark last
	if (mode .eq. 2) then
	call shower_topythia_recursive_weighted (finalprt, 2, first)
	end if

	! if (mode == 1) then
	! call shower_topythia_recursive_weighted (prt%child1, 1, first)
	! call shower_topythia_recursive_weighted (prt%child2, 1, first)
	! else
	! call shower_topythia_recursive_weighted (prt%child2, 2, first)
	! call shower_topythia_recursive_weighted (prt%child1, 2, first)
	! end if
	end if
	end if
	end subroutine shower_topythia_recursive_weighted

	@ %def shower_topythia_recursive_weighted
	@
	<<Shower2pythia: procedures>>=
	recursive subroutine shower_topythia_recursive (prt, mode,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(parton_t), intent(in) :: prt
	integer, intent(in) :: mode, first

	if (parton_is_final (prt)) then
	N = N + 1
	K(N,1) = 2
	if (parton_is_quark(prt)) then
	!!! check if quark is end of a color connection
	if (prt%type < 0) then
	K(N,1) = 1
	end if
	end if
	K(N,2) = prt%type
	K(N,3) = first
	K(N,4) = 0
	K(N,5) = 0
	P(N,1) = vector4_get_component (prt%momentum, 1)
	P(N,2) = vector4_get_component (prt%momentum, 2)
	P(N,3) = vector4_get_component (prt%momentum, 3)
	P(N,4) = vector4_get_component (prt%momentum, 0)
	P(N,5) = prt%t
	else
	!!! search for following final partons
	if (parton_is_gluon (prt)) then
	if (parton_is_gluon (prt%child1)) then
	!!! g-> gg so sequence is unimportant
	call shower_topythia_recursive (prt%child1, 1, first)
	call shower_topythia_recursive (prt%child2, 1, first)
	else
	!!! g-> qqbar -> use antiquark first, so that color flow
	!!! is given correctly
	if (prt%child1%type < 0) then
	call shower_topythia_recursive (prt%child1, 1, first)
	call shower_topythia_recursive (prt%child2, 2, first)
	else
	call shower_topythia_recursive (prt%child2, 2, first)
	call shower_topythia_recursive (prt%child1, 1, first)
	end if
	endif
	else
	if (mode == 1) then
	call shower_topythia_recursive (prt%child1, 1, first)
	call shower_topythia_recursive (prt%child2, 1, first)
	else
	call shower_topythia_recursive (prt%child2, 2, first)
	call shower_topythia_recursive (prt%child1, 2, first)
	end if
	end if
	end if
	end subroutine shower_topythia_recursive

	@ %def shower_topythia_recursive
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	<<[[pythia_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*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*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 pythia_up.f
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\section{Matching}
	\subsection{MLM matching}
	<<[[mlm_matching.f90]]>>=
	<<File header>>

	module mlm_matching

	<<Use kinds>>
	use kinds, only: double !NODEP!
	use io_units !NODEP!
	use constants !NODEP!
	use diagnostics !NODEP!
	use file_utils !NODEP!
	use lorentz !NODEP!

	<<Standard module head>>

	<<MLM matching: public>>

	<<MLM matching: types>>

	contains

	<<MLM matching: procedures>>

	end module mlm_matching
	@ %def mlm_matching
	@ 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 :: mlm_matching_data_t
	logical :: is_hadron_collision = .false.
	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_settings_t
	<<MLM matching: types>>=
	type :: 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
	end type mlm_matching_settings_t

	@ %def mlm_matching_settings_t
	@
	<<MLM matching: public>>=
	public :: mlm_matching_settings_write
	<<MLM matching: procedures>>=
	subroutine mlm_matching_settings_write (settings, unit)
	type(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
	@
	<<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>>

	! call data_write(data)

	<<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
	! ycut = settings%mlm_Qcut_ME**2
	allocate (PP(1:4, 1:N_jets_ME))
	do i = 1, n_jets_ME
	PP(1,i) = vector4_get_component (data%p_ME(i), 1)
	PP(2,i) = vector4_get_component (data%p_ME(i), 2)
	PP(3,i) = vector4_get_component (data%p_ME(i), 3)
	PP(4,i) = vector4_get_component (data%p_ME(i), 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))

	!!! TODO: (bcn 2014-03-26) has he forgotten mlm_Rclusfactor here? #
	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
	! ycut = settings%mlm_Qcut_PS**2
	allocate (PP(1:4, 1:n_jets_PS))
	do i = 1, n_jets_PS
	PP(1,i) = vector4_get_component (data%p_PS(i), 1)
	PP(2,i) = vector4_get_component (data%p_PS(i), 2)
	PP(3,i) = vector4_get_component (data%p_PS(i), 3)
	PP(4,i) = vector4_get_component (data%p_PS(i), 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
	! call vector4_write(data%jets_PS(i))
	PP(1,i) = vector4_get_component (data%JETS_PS(i), 1)
	PP(2,i) = vector4_get_component (data%JETS_PS(i), 2)
	PP(3,i) = vector4_get_component (data%JETS_PS(i), 3)
	PP(4,i) = vector4_get_component (data%JETS_PS(i), 0)
	end do
	if (allocated (Y)) deallocate(Y)
	allocate (Y(1:n_jets_PS + 1))
	y = zero
	do i = 1, n_jets_ME
	! print *, "ME JET"
	! call vector4_write(data%jets_ME(i))
	PP(1,n_jets_PS + 2 - i) = vector4_get_component (data%JETS_ME(i), 1)
	PP(2,n_jets_PS + 2 - i) = vector4_get_component (data%JETS_ME(i), 2)
	PP(3,n_jets_PS + 2 - i) = vector4_get_component (data%JETS_ME(i), 3)
	PP(4,n_jets_PS + 2 - i) = vector4_get_component (data%JETS_ME(i), 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)
	! print *, " Y=" , y
	! print *, y(n_jets_PS + 1 - i), " " , ycut
	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
	! print *, "i=", i, n_jets_PS, n_jets_ME
	! do j = 1, n_jets_PS + 2 - i
	! print *, PP(1,j), PP(2,j), PP(3,j), PP(4,j)
	! end do
	! print *, " n_jets_PS=", n_jets_PS
	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-----------------------------------------------------------------------
	SUBROUTINE KTCLUS(IMODE,PP,NN,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 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 IMODE,NN
	DOUBLE PRECISION PP(4,*)
	DOUBLE PRECISION ECUT,Y(*),ONE
	ONE=1
	CALL KTCLUR(IMODE,PP,NN,ONE,ECUT,Y,*999)
	RETURN
	999 RETURN 1
	END SUBROUTINE KTCLUS
	!C-----------------------------------------------------------------------
	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-----------------------------------------------------------------------
	SUBROUTINE KTYCUT(ECUT,NY,YCUT,NJET,*)
	IMPLICIT NONE
	!C---COUNT THE NUMBER OF JETS AT EACH VALUE OF YCUT, FOR EVENT WHICH HAS
	!C ALREADY BEEN ANALYSED BY KTCLUS.
	!C
	!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
	!C NY = INPUT : NUMBER OF YCUT VALUES
	!C YCUT(J) = INPUT : Y VALUES AT WHICH NUMBERS OF JETS ARE COUNTED
	!C NJET(J) =OUTPUT : NUMBER OF JETS AT YCUT(J)
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT ALL FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER NY,NJET(NY),NMAX,HIST,I,J,NUM
	PARAMETER (NMAX=512)
	DOUBLE PRECISION YCUT(NY),ETOT,RSQ,P,KT,KTP,KTS,ETSQ,ECUT,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
	IF (ETOT.EQ.0) CALL KTWARN('KTYCUT',100,*999)
	IF (ECUT.EQ.0) THEN
	ETSQ=1/ETOT**2
	ELSE
	ETSQ=1/ECUT**2
	ENDIF
	DO I=1,NY
	NJET(I)=0
	END DO
	DO I=NUM,1,-1
	DO J=1,NY
	IF (NJET(J).EQ.0.AND.KT(I)ETSQ.GE.ROUNDYCUT(J)) NJET(J)=I
	END DO
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTYCUT
	!C-----------------------------------------------------------------------
	SUBROUTINE KTYSUB(ECUT,NY,YCUT,YMAC,NSUB,*)
	IMPLICIT NONE
	!C---COUNT THE NUMBER OF SUB-JETS AT EACH VALUE OF YCUT, FOR EVENT WHICH
	!C HAS ALREADY BEEN ANALYSED BY KTCLUS.
	!C REMEMBER THAT A SUB-JET IS DEFINED AS A JET AT Y=YCUT WHICH HAS NOT
	!C YET BEEN MERGED WITH THE BEAM AT Y=YMAC.
	!C
	!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
	!C NY = INPUT : NUMBER OF YCUT VALUES
	!C YCUT(J) = INPUT : Y VALUES AT WHICH NUMBERS OF SUB-JETS ARE COUNTED
	!C YMAC = INPUT : Y VALUE USED TO DEFINE MACRO-JETS, TO DETERMINE
	!C WHICH JETS ARE SUB-JETS
	!C NSUB(J) =OUTPUT : NUMBER OF SUB-JETS AT YCUT(J)
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT ALL FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER NY,NSUB(NY),NMAX,HIST,I,J,NUM
	PARAMETER (NMAX=512)
	DOUBLE PRECISION YCUT(NY),YMAC,ETOT,RSQ,P,KT,KTP,KTS,ETSQ,ECUT, &
	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
	IF (ETOT.EQ.0) CALL KTWARN('KTYSUB',100,*999)
	IF (ECUT.EQ.0) THEN
	ETSQ=1/ETOT**2
	ELSE
	ETSQ=1/ECUT**2
	ENDIF
	DO I=1,NY
	NSUB(I)=0
	END DO
	DO I=NUM,1,-1
	DO J=1,NY
	IF (NSUB(J).EQ.0.AND.KT(I)ETSQ.GE.ROUNDYCUT(J)) NSUB(J)=I
	IF (NSUB(J).NE.0.AND.KTLAST(I)ETSQ.LT.ROUNDYMAC) &
	NSUB(J)=NSUB(J)-1
	END DO
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTYSUB
	!C-----------------------------------------------------------------------
	SUBROUTINE KTBEAM(ECUT,Y,*)
	IMPLICIT NONE
	!C---GIVE SAME INFORMATION AS LAST CALL TO KTCLUS EXCEPT THAT ONLY
	!C TRANSITIONS WHERE A JET WAS MERGED WITH THE BEAM JET ARE RECORDED
	!C
	!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
	!C Y(J) =OUTPUT : Y VALUE WHERE Jth HARDEST JET WAS MERGED WITH BEAM
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT ALL FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER NMAX,HIST,NUM,I,J
	PARAMETER (NMAX=512)
	DOUBLE PRECISION ETOT,RSQ,P,KT,KTP,KTS,ECUT,ETSQ,Y(*),KTLAST
	COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
	KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
	IF (ETOT.EQ.0) CALL KTWARN('KTBEAM',100,*999)
	IF (ECUT.EQ.0) THEN
	ETSQ=1/ETOT**2
	ELSE
	ETSQ=1/ECUT**2
	ENDIF
	J=1
	DO I=1,NUM
	IF (HIST(I).LE.NMAX) THEN
	Y(J)=ETSQ*KT(I)
	J=J+1
	ENDIF
	END DO
	DO I=J,NUM
	Y(I)=0
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTBEAM
	!C-----------------------------------------------------------------------
	SUBROUTINE KTJOIN(ECUT,YMAC,Y,*)
	IMPLICIT NONE
	!C---GIVE SAME INFORMATION AS LAST CALL TO KTCLUS EXCEPT THAT ONLY
	!C TRANSITIONS WHERE TWO SUB-JETS WERE JOINED ARE RECORDED
	!C REMEMBER THAT A SUB-JET IS DEFINED AS A JET AT Y=YCUT WHICH HAS NOT
	!C YET BEEN MERGED WITH THE BEAM AT Y=YMAC.
	!C
	!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
	!C YMAC = INPUT : VALUE OF Y USED TO DEFINE MACRO-JETS
	!C Y(J) =OUTPUT : Y VALUE WHERE EVENT CHANGED FROM HAVING
	!C N+J SUB-JETS TO HAVING N+J-1, WHERE N IS
	!C THE NUMBER OF MACRO-JETS AT SCALE YMAC
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT ALL FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER NMAX,HIST,NUM,I,J
	PARAMETER (NMAX=512)
	DOUBLE PRECISION ETOT,RSQ,P,KT,KTP,KTS,ECUT,ETSQ,Y(*),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
	IF (ETOT.EQ.0) CALL KTWARN('KTJOIN',100,*999)
	IF (ECUT.EQ.0) THEN
	ETSQ=1/ETOT**2
	ELSE
	ETSQ=1/ECUT**2
	ENDIF
	J=1
	DO I=1,NUM
	IF (HIST(I).GT.NMAX.AND.ETSQKTLAST(I).GE.ROUNDYMAC) THEN
	Y(J)=ETSQ*KT(I)
	J=J+1
	ENDIF
	END DO
	DO I=J,NUM
	Y(I)=0
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTJOIN
	!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-----------------------------------------------------------------------
	SUBROUTINE KTINCL(RECO,PP,NN,PJET,JET,NJET,*)
	IMPLICIT NONE
	!C---RECONSTRUCT KINEMATICS OF JET SYSTEM, WHICH HAS ALREADY BEEN
	!C ANALYSED BY KTCLUS ACCORDING TO THE INCLUSIVE JET DEFINITION. NOTE
	!C THAT NO CONSISTENCY CHECK IS MADE: USER IS TRUSTED TO USE THE SAME
	!C 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 PJET(I,J)=OUTPUT : 4-MOMENTUM OF Jth JET AT SCALE YCUT
	!C JET(J) =OUTPUT : THE JET WHICH CONTAINS THE Jth PARTICLE
	!C NJET =OUTPUT : THE NUMBER OF JETS
	!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,JET(*),HIST,IMIN,JMIN,I,J
	PARAMETER (NMAX=512)
	DOUBLE PRECISION PP(4,),PJET(4,)
	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
	!C---CHECK INPUT
	IF (RECO.LT.1.OR.RECO.GT.3) CALL KTWARN('KTINCL',100,*999)
	!C---COPY PP TO P
	N=NN
	IF (NUM.NE.NN) CALL KTWARN('KTINCL',101,*999)
	CALL KTCOPY(PP,N,P,(RECO.NE.1))
	!C---INITIALLY EVERY PARTICLE IS IN ITS OWN JET
	DO I=1,NN
	JET(I)=I
	END DO
	!C---KEEP MERGING TO THE BITTER END
	NJET=0
	200 IF (N.GT.0) THEN
	IF (HIST(N).LE.NMAX) THEN
	IMIN=0
	JMIN=HIST(N)
	NJET=NJET+1
	IF (RECO.EQ.1) THEN
	DO J=1,4
	PJET(J,NJET)=P(J,JMIN)
	END DO
	ELSE
	PJET(1,NJET)=P(6,JMIN)*COS(P(8,JMIN))
	PJET(2,NJET)=P(6,JMIN)*SIN(P(8,JMIN))
	PJET(3,NJET)=P(6,JMIN)*SINH(P(7,JMIN))
	PJET(4,NJET)=P(6,JMIN)*COSH(P(7,JMIN))
	ENDIF
	CALL KTMOVE(P,KTP,KTS,NMAX,N,JMIN,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
	DO I=1,NN
	IF (JET(I).EQ.JMIN) JET(I)=IMIN
	IF (JET(I).EQ.N) JET(I)=JMIN
	IF (JET(I).EQ.0) JET(I)=-NJET
	END DO
	N=N-1
	GOTO 200
	ENDIF
	!C---FINALLY EVERY PARTICLE MUST BE IN AN INCLUSIVE JET
	DO I=1,NN
	!C---IF THERE ARE ANY UNASSIGNED PARTICLES SOMETHING MUST HAVE GONE WRONG
	IF (JET(I).GE.0) CALL KTWARN('KTINCL',102,*999)
	JET(I)=-JET(I)
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTINCL
	!C-----------------------------------------------------------------------
	SUBROUTINE KTISUB(N,NY,YCUT,NSUB,*)
	IMPLICIT NONE
	!C---COUNT THE NUMBER OF SUB-JETS IN THE Nth INCLUSIVE JET OF AN EVENT
	!C THAT HAS ALREADY BEEN ANALYSED BY KTCLUS.
	!C
	!C N = INPUT : WHICH INCLUSIVE JET TO USE
	!C NY = INPUT : NUMBER OF YCUT VALUES
	!C YCUT(J) = INPUT : Y VALUES AT WHICH NUMBERS OF SUB-JETS ARE COUNTED
	!C NSUB(J) =OUTPUT : NUMBER OF SUB-JETS AT YCUT(J)
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT ALL FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER N,NY,NSUB(NY),NMAX,HIST,I,J,NUM,NM
	PARAMETER (NMAX=512)
	DOUBLE PRECISION YCUT(NY),ETOT,RSQ,P,KT,KTP,KTS,KTLAST,ROUND,EPS
	PARAMETER (ROUND=0.99999D0)
	COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
	KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
	DATA EPS/1D-6/
	DO I=1,NY
	NSUB(I)=0
	END DO
	!C---FIND WHICH MERGING CORRESPONDS TO THE NTH INCLUSIVE JET
	NM=0
	J=0
	DO I=NUM,1,-1
	IF (HIST(I).LE.NMAX) J=J+1
	IF (J.EQ.N) THEN
	NM=I
	GOTO 120
	ENDIF
	END DO
	120 CONTINUE
	!C---GIVE UP IF THERE ARE LESS THAN N INCLUSIVE JETS
	IF (NM.EQ.0) CALL KTWARN('KTISUB',100,*999)
	DO I=NUM,1,-1
	DO J=1,NY
	IF (NSUB(J).EQ.0.AND.RSQKT(I).GE.ROUNDYCUT(J)*KT(NM)) &
	NSUB(J)=I
	IF (NSUB(J).NE.0.AND.ABS(KTLAST(I)-KTLAST(NM)).GT.EPS) &
	NSUB(J)=NSUB(J)-1
	END DO
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTISUB
	!C-----------------------------------------------------------------------
	SUBROUTINE KTIJOI(N,Y,*)
	IMPLICIT NONE
	!C---GIVE SAME INFORMATION AS LAST CALL TO KTCLUS EXCEPT THAT ONLY
	!C MERGES OF TWO SUB-JETS INSIDE THE Nth INCLUSIVE JET ARE RECORDED
	!C
	!C N = INPUT : WHICH INCLUSIVE JET TO USE
	!C Y(J) =OUTPUT : Y VALUE WHERE JET CHANGED FROM HAVING
	!C J+1 SUB-JETS TO HAVING J
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT ALL FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER NMAX,HIST,NUM,I,J,N,NM
	PARAMETER (NMAX=512)
	DOUBLE PRECISION ETOT,RSQ,P,KT,KTP,KTS,Y(*),KTLAST,EPS
	COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
	KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
	DATA EPS/1D-6/
	!C---FIND WHICH MERGING CORRESPONDS TO THE NTH INCLUSIVE JET
	NM=0
	J=0
	DO I=NUM,1,-1
	IF (HIST(I).LE.NMAX) J=J+1
	IF (J.EQ.N) THEN
	NM=I
	GOTO 105
	ENDIF
	END DO
	105 CONTINUE
	!C---GIVE UP IF THERE ARE LESS THAN N INCLUSIVE JETS
	IF (NM.EQ.0) CALL KTWARN('KTIJOI',100,*999)
	J=1
	DO I=1,NUM
	IF (HIST(I).GT.NMAX.AND.ABS(KTLAST(I)-KTLAST(NM)).LT.EPS) THEN
	Y(J)=RSQ*KT(I)/KT(NM)
	J=J+1
	ENDIF
	END DO
	DO I=J,NUM
	Y(I)=0
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTIJOI
	!C-----------------------------------------------------------------------
	SUBROUTINE KTIREC(RECO,PP,NN,N,YCUT,PSUB,NSUB,*)
	IMPLICIT NONE
	!C---RECONSTRUCT KINEMATICS OF SUB-JET SYSTEM IN THE Nth INCLUSIVE JET
	!C OF AN EVENT THAT HAS ALREADY BEEN ANALYSED BY 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 N = INPUT : WHICH INCLUSIVE JET TO USE
	!C YCUT = INPUT : Y VALUE AT WHICH TO RECONSTRUCT JET MOMENTA
	!C PSUB(I,J)=OUTPUT : 4-MOMENTUM OF Jth SUB-JET AT SCALE YCUT
	!C NSUB =OUTPUT : THE NUMBER OF SUB-JETS
	!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,NN,NJET,NSUB,JET,HIST,I,J,N,NM
	PARAMETER (NMAX=512)
	DOUBLE PRECISION PP(4,),PSUB(4,)
	DOUBLE PRECISION ECUT,P,KT,KTP,KTS,ETOT,RSQ,YCUT,YMAC,KTLAST
	COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
	KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
	DIMENSION JET(NMAX)
	!C---FIND WHICH MERGING CORRESPONDS TO THE NTH INCLUSIVE JET
	NM=0
	J=0
	DO I=NUM,1,-1
	IF (HIST(I).LE.NMAX) J=J+1
	IF (J.EQ.N) THEN
	NM=I
	GOTO 110
	ENDIF
	END DO
	110 CONTINUE
	!C---GIVE UP IF THERE ARE LESS THAN N INCLUSIVE JETS
	IF (NM.EQ.0) CALL KTWARN('KTIREC',102,*999)
	!C---RECONSTRUCT THE JETS AT THE APPROPRIATE SCALE
	ECUT=SQRT(KT(NM)/RSQ)
	YMAC=RSQ
	CALL KTRECO(RECO,PP,NN,ECUT,YCUT,YMAC,PSUB,JET,NJET,NSUB,*999)
	!C---GET RID OF THE ONES THAT DO NOT END UP IN THE JET WE WANT
	NSUB=0
	DO I=1,NJET
	IF (JET(I).EQ.HIST(NM)) THEN
	NSUB=NSUB+1
	DO J=1,4
	PSUB(J,NSUB)=PSUB(J,I)
	END DO
	ENDIF
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTIREC
	!C-----------------------------------------------------------------------
	SUBROUTINE KTWICH(ECUT,YCUT,JET,NJET,*)
	IMPLICIT NONE
	!C---GIVE A LIST OF WHICH JET EACH ORIGINAL PARTICLE ENDED UP IN AT SCALE
	!C YCUT, TOGETHER WITH THE NUMBER OF JETS AT THAT SCALE.
	!C
	!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
	!C YCUT = INPUT : Y VALUE AT WHICH TO DEFINE JETS
	!C JET(J) =OUTPUT : THE JET WHICH CONTAINS THE Jth PARTICLE,
	!C SET TO ZERO IF IT WAS PUT INTO THE BEAM JETS
	!C NJET =OUTPUT : THE NUMBER OF JETS AT SCALE YCUT (SO JET()
	!C ENTRIES WILL BE IN THE RANGE 0 -> NJET)
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT ALL FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER JET(*),NJET,NTEMP
	DOUBLE PRECISION ECUT,YCUT
	CALL KTWCHS(ECUT,YCUT,YCUT,JET,NJET,NTEMP,*999)
	RETURN
	999 RETURN 1
	END SUBROUTINE KTWICH
	!C-----------------------------------------------------------------------
	SUBROUTINE KTWCHS(ECUT,YCUT,YMAC,JET,NJET,NSUB,*)
	IMPLICIT NONE
	!C---GIVE A LIST OF WHICH SUB-JET EACH ORIGINAL PARTICLE ENDED UP IN AT
	!C SCALE YCUT, WITH MACRO-JET SCALE YMAC, TOGETHER WITH THE NUMBER OF
	!C JETS AT SCALE YCUT AND THE NUMBER OF THEM WHICH ARE SUB-JETS.
	!C
	!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
	!C YCUT = INPUT : Y VALUE AT WHICH TO DEFINE JETS
	!C YMAC = INPUT : Y VALUE AT WHICH TO DEFINE MACRO-JETS
	!C JET(J) =OUTPUT : THE JET WHICH CONTAINS THE Jth PARTICLE,
	!C SET TO ZERO IF IT WAS PUT INTO THE BEAM JETS
	!C NJET =OUTPUT : THE NUMBER OF JETS AT SCALE YCUT (SO JET()
	!C ENTRIES WILL BE IN THE RANGE 0 -> NJET)
	!C NSUB =OUTPUT : THE NUMBER OF SUB-JETS AT SCALE YCUT, WITH
	!C MACRO-JETS DEFINED AT SCALE YMAC (SO ONLY NSUB
	!C OF THE JETS 1 -> NJET WILL APPEAR 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 ALL FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
	!C
	INTEGER NMAX,JET(*),NJET,NSUB,HIST,NUM,I,J,JSUB
	PARAMETER (NMAX=512)
	DOUBLE PRECISION P1(4,NMAX),P2(4,NMAX)
	DOUBLE PRECISION ECUT,YCUT,YMAC,ZERO,ETOT,RSQ,P,KTP,KTS,KT,KTLAST
	COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
	KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
	DIMENSION JSUB(NMAX)
	!C---THE MOMENTA HAVE TO BEEN GIVEN LEGAL VALUES,
	!C EVEN THOUGH THEY WILL NEVER BE USED
	DATA ((P1(J,I),I=1,NMAX),J=1,4),ZERO &
	/NMAX1,NMAX0,NMAX0,NMAX1,0/
	!C---FIRST GET A LIST OF WHICH PARTICLE IS IN WHICH JET AT YCUT
	CALL KTRECO(1,P1,NUM,ECUT,ZERO,YCUT,P2,JET,NJET,NSUB,*999)
	!C---THEN FIND OUT WHICH JETS ARE SUBJETS
	CALL KTRECO(1,P1,NUM,ECUT,YCUT,YMAC,P2,JSUB,NJET,NSUB,*999)
	!C---AND MODIFY JET() ACCORDINGLY
	DO I=1,NUM
	IF (JET(I).NE.0) THEN
	IF (JSUB(JET(I)).EQ.0) JET(I)=0
	ENDIF
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTWCHS
	!C-----------------------------------------------------------------------
	SUBROUTINE KTFRAM(IOPT,CMF,SIGN,Z,XZ,N,P,Q,*)
	IMPLICIT NONE
	!C---BOOST PARTICLES IN P TO/FROM FRAME GIVEN BY CMF, Z, XZ.
	!C---IN THIS FRAME CMZ IS STATIONARY,
	!C Z IS ALONG THE (SIGN)Z-AXIS (SIGN=+ OR -)
	!C XZ IS IN THE X-Z PLANE (WITH POSITIVE X COMPONENT)
	!C---IF Z HAS LENGTH ZERO, OR SIGN=0, NO ROTATION IS PERFORMED
	!C---IF XZ HAS ZERO COMPONENT PERPENDICULAR TO Z IN THAT FRAME,
	!C NO AZIMUTHAL ROTATION IS PERFORMED
	!C
	!C IOPT = INPUT : 0=TO FRAME, 1=FROM FRAME
	!C CMF(I) = INPUT : 4-MOMENTUM WHICH IS STATIONARY IN THE FRAME
	!C SIGN = INPUT : DIRECTION OF Z IN THE FRAME, NOTE THAT
	!C ONLY ITS SIGN IS USED, NOT ITS MAGNITUDE
	!C Z(I) = INPUT : 4-MOMENTUM WHICH LIES ON THE (SIGN)Z-AXIS
	!C XZ(I) = INPUT : 4-MOMENTUM WHICH LIES IN THE X-Z PLANE
	!C N = INPUT : NUMBER OF PARTICLES IN P
	!C P(I,J) = INPUT : 4-MOMENTUM OF JTH PARTICLE BEFORE
	!C Q(I,J) = OUTPUT : 4-MOMENTUM OF JTH PARTICLE AFTER
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED
	!C
	!C NOTE THAT ALL MOMENTA ARE DOUBLE PRECISION
	!C
	!C NOTE THAT IT IS SAFE TO CALL WITH P=Q
	!C
	INTEGER IOPT,I,N
	DOUBLE PRECISION CMF(4),SIGN,Z(4),XZ(4),P(4,N),Q(4,N), &
	R(4,4),NEW(4),OLD(4)
	IF (IOPT.LT.0.OR.IOPT.GT.1) CALL KTWARN('KTFRAM',200,*999)
	!C---FIND BOOST TO GET THERE FROM LAB
	CALL KTUNIT(R)
	CALL KTLBST(0,R,CMF,*999)
	!C---FIND ROTATION TO PUT BOOSTED Z ON THE (SIGN)Z AXIS
	IF (SIGN.NE.0) THEN
	CALL KTVMUL(R,Z,OLD)
	IF (OLD(1).NE.0.OR.OLD(2).NE.0.OR.OLD(3).NE.0) THEN
	NEW(1)=0
	NEW(2)=0
	NEW(3)=SIGN
	NEW(4)=ABS(SIGN)
	CALL KTRROT(R,OLD,NEW,*999)
	!C---FIND ROTATION TO PUT BOOSTED AND ROTATED XZ INTO X-Z PLANE
	CALL KTVMUL(R,XZ,OLD)
	IF (OLD(1).NE.0.OR.OLD(2).NE.0) THEN
	NEW(1)=1
	NEW(2)=0
	NEW(3)=0
	NEW(4)=1
	OLD(3)=0
	!C---NOTE THAT A POTENTIALLY AWKWARD SPECIAL CASE IS AVERTED, BECAUSE IF
	!C OLD AND NEW ARE EXACTLY BACK-TO-BACK, THE ROTATION AXIS IS UNDEFINED
	!C BUT IN THAT CASE KTRROT WILL USE THE Z AXIS, AS REQUIRED
	CALL KTRROT(R,OLD,NEW,*999)
	ENDIF
	ENDIF
	ENDIF
	!C---INVERT THE TRANSFORMATION IF NECESSARY
	IF (IOPT.EQ.1) CALL KTINVT(R,R)
	!C---APPLY THE RESULT TO ALL THE VECTORS
	DO I=1,N
	CALL KTVMUL(R,P(1,I),Q(1,I))
	END DO
	RETURN
	999 RETURN 1
	END SUBROUTINE KTFRAM
	!C-----------------------------------------------------------------------
	SUBROUTINE KTBREI(IOPT,PLEP,PHAD,POUT,N,P,Q,*)
	IMPLICIT NONE
	!C---BOOST PARTICLES IN P TO/FROM BREIT FRAME
	!C
	!C IOPT = INPUT : 0/2=TO BREIT FRAME, 1/3=FROM BREIT FRAME
	!C 0/1=NO AZIMUTHAL ROTATION AFTERWARDS
	!C 2/3=LEPTON PLANE ROTATED INTO THE X-Z PLANE
	!C PLEP = INPUT : MOMENTUM OF INCOMING LEPTON IN +Z DIRECTION
	!C PHAD = INPUT : MOMENTUM OF INCOMING HADRON IN +Z DIRECTION
	!C POUT(I) = INPUT : 4-MOMENTUM OF OUTGOING LEPTON
	!C N = INPUT : NUMBER OF PARTICLES IN P
	!C P(I,J) = INPUT : 4-MOMENTUM OF JTH PARTICLE BEFORE
	!C Q(I,J) = OUTPUT : 4-MOMENTUM OF JTH PARTICLE AFTER
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
	!C COULD NOT BE PROCESSED (MOST LIKELY DUE TO PARTICLES HAVING SMALLER
	!C ENERGY THAN MOMENTUM)
	!C
	!C NOTE THAT ALL MOMENTA ARE DOUBLE PRECISION
	!C
	!C NOTE THAT IT IS SAFE TO CALL WITH P=Q
	!C
	INTEGER IOPT,N
	DOUBLE PRECISION PLEP,PHAD,POUT(4),P(4,N),Q(4,N), &
	CMF(4),Z(4),XZ(4),DOT,QDQ
	!C---CHECK INPUT
	IF (IOPT.LT.0.OR.IOPT.GT.3) CALL KTWARN('KTBREI',200,*999)
	!C---FIND 4-MOMENTUM OF BREIT FRAME (TIMES AN ARBITRARY FACTOR)
	DOT=ABS(PHAD)(ABS(PLEP)-POUT(4))-PHAD(PLEP-POUT(3))
	QDQ=(ABS(PLEP)-POUT(4))2-(PLEP-POUT(3))2-POUT(2)2-POUT(1)2
	CMF(1)=DOT*( -POUT(1))
	CMF(2)=DOT*( -POUT(2))
	CMF(3)=DOT( PLEP -POUT(3))-QDQ PHAD
	CMF(4)=DOT(ABS(PLEP)-POUT(4))-QDQABS(PHAD)
	!C---FIND ROTATION TO PUT INCOMING HADRON BACK ON Z-AXIS
	Z(1)=0
	Z(2)=0
	Z(3)=PHAD
	Z(4)=ABS(PHAD)
	XZ(1)=0
	XZ(2)=0
	XZ(3)=0
	XZ(4)=0
	!C---DO THE BOOST
	IF (IOPT.LE.1) THEN
	CALL KTFRAM(IOPT,CMF,PHAD,Z,XZ,N,P,Q,*999)
	ELSE
	CALL KTFRAM(IOPT-2,CMF,PHAD,Z,POUT,N,P,Q,*999)
	ENDIF
	RETURN
	999 RETURN 1
	END SUBROUTINE KTBREI
	!C-----------------------------------------------------------------------
	SUBROUTINE KTHADR(IOPT,PLEP,PHAD,POUT,N,P,Q,*)
	IMPLICIT NONE
	!C---BOOST PARTICLES IN P TO/FROM HADRONIC CMF
	!C
	!C ARGUMENTS ARE EXACTLY AS FOR KTBREI
	!C
	!C NOTE THAT ALL MOMENTA ARE DOUBLE PRECISION
	!C
	!C NOTE THAT IT IS SAFE TO CALL WITH P=Q
	!C
	INTEGER IOPT,N
	DOUBLE PRECISION PLEP,PHAD,POUT(4),P(4,N),Q(4,N), &
	CMF(4),Z(4),XZ(4)
	!C---CHECK INPUT
	IF (IOPT.LT.0.OR.IOPT.GT.3) CALL KTWARN('KTHADR',200,*999)
	!C---FIND 4-MOMENTUM OF HADRONIC CMF
	CMF(1)= -POUT(1)
	CMF(2)= -POUT(2)
	CMF(3)= PLEP -POUT(3)+ PHAD
	CMF(4)=ABS(PLEP)-POUT(4)+ABS(PHAD)
	!C---FIND ROTATION TO PUT INCOMING HADRON BACK ON Z-AXIS
	Z(1)=0
	Z(2)=0
	Z(3)=PHAD
	Z(4)=ABS(PHAD)
	XZ(1)=0
	XZ(2)=0
	XZ(3)=0
	XZ(4)=0
	!C---DO THE BOOST
	IF (IOPT.LE.1) THEN
	CALL KTFRAM(IOPT,CMF,PHAD,Z,XZ,N,P,Q,*999)
	ELSE
	CALL KTFRAM(IOPT-2,CMF,PHAD,Z,POUT,N,P,Q,*999)
	ENDIF
	RETURN
	999 RETURN 1
	END SUBROUTINE KTHADR
	!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,I
	! 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-----------------------------------------------------------------------
	SUBROUTINE KTUNIT(R)
	IMPLICIT NONE
	!C SET R EQUAL TO THE 4 BY 4 IDENTITY MATRIX
	DOUBLE PRECISION R(4,4)
	INTEGER I,J
	DO I=1,4
	DO J=1,4
	R(I,J)=0
	IF (I.EQ.J) R(I,J)=1
	END DO
	END DO
	END SUBROUTINE KTUNIT
	!C-----------------------------------------------------------------------
	SUBROUTINE KTLBST(IOPT,R,A,*)
	IMPLICIT NONE
	!C PREMULTIPLY R BY THE 4 BY 4 MATRIX TO
	!C LORENTZ BOOST TO/FROM THE CM FRAME OF A
	!C IOPT=0 => TO
	!C IOPT=1 => FROM
	!C
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF A IS NOT TIME-LIKE
	!C
	INTEGER IOPT,I,J
	DOUBLE PRECISION R(4,4),A(4),B(4),C(4,4),M
	DO I=1,4
	B(I)=A(I)
	END DO
	M=B(4)2-B(1)2-B(2)2-B(3)2
	IF (M.LE.0) CALL KTWARN('KTLBST',100,*999)
	M=SQRT(M)
	B(4)=B(4)+M
	M=1/(M*B(4))
	IF (IOPT.EQ.0) THEN
	B(4)=-B(4)
	ELSEIF (IOPT.NE.1) THEN
	CALL KTWARN('KTLBST',200,*999)
	STOP
	ENDIF
	DO I=1,4
	DO J=1,4
	C(I,J)=B(I)B(J)M
	IF (I.EQ.J) C(I,J)=C(I,J)+1
	END DO
	END DO
	C(4,4)=C(4,4)-2
	CALL KTMMUL(C,R,R)
	RETURN
	999 RETURN 1
	END SUBROUTINE KTLBST
	!C-----------------------------------------------------------------------
	SUBROUTINE KTRROT(R,A,B,*)
	IMPLICIT NONE
	!C PREMULTIPLY R BY THE 4 BY 4 MATRIX TO
	!C ROTATE FROM VECTOR A TO VECTOR B BY THE SHORTEST ROUTE
	!C IF THEY ARE EXACTLY BACK-TO-BACK, THE ROTATION AXIS IS THE VECTOR
	!C WHICH IS PERPENDICULAR TO THEM AND THE X AXIS, UNLESS THEY ARE
	!C PERPENDICULAR TO THE Y AXIS, WHEN IT IS THE VECTOR WHICH IS
	!C PERPENDICULAR TO THEM AND THE Y AXIS.
	!C NOTE THAT THESE CONDITIONS GUARANTEE THAT IF BOTH ARE PERPENDICULAR
	!C TO THE Z AXIS, IT WILL BE USED AS THE ROTATION AXIS.
	!C
	!C LAST ARGUMENT IS LABEL TO JUMP TO IF EITHER HAS LENGTH ZERO
	!C
	DOUBLE PRECISION R(4,4),M(4,4),A(4),B(4),C(4),D(4),AL,BL,CL,DL,EPS
	!C---SQRT(2*EPS) IS THE ANGLE IN RADIANS OF THE SMALLEST ALLOWED ROTATION
	!C NOTE THAT IF YOU CONVERT THIS PROGRAM TO SINGLE PRECISION, YOU WILL
	!C NEED TO INCREASE EPS TO AROUND 0.5E-4
	PARAMETER (EPS=0.5D-6)
	AL=A(1)2+A(2)2+A(3)**2
	BL=B(1)2+B(2)2+B(3)**2
	IF (AL.LE.0.OR.BL.LE.0) CALL KTWARN('KTRROT',100,*999)
	AL=1/SQRT(AL)
	BL=1/SQRT(BL)
	CL=(A(1)B(1)+A(2)B(2)+A(3)B(3))AL*BL
	!C---IF THEY ARE COLLINEAR, DON'T NEED TO DO ANYTHING
	IF (CL.GE.1-EPS) THEN
	RETURN
	!C---IF THEY ARE BACK-TO-BACK, USE THE AXIS PERP TO THEM AND X AXIS
	ELSEIF (CL.LE.-1+EPS) THEN
	IF (ABS(B(2)).GT.EPS) THEN
	C(1)= 0
	C(2)=-B(3)
	C(3)= B(2)
	!C---UNLESS THEY ARE PERPENDICULAR TO THE Y AXIS,
	ELSE
	C(1)= B(3)
	C(2)= 0
	C(3)=-B(1)
	ENDIF
	!C---OTHERWISE FIND ROTATION AXIS
	ELSE
	C(1)=A(2)B(3)-A(3)B(2)
	C(2)=A(3)B(1)-A(1)B(3)
	C(3)=A(1)B(2)-A(2)B(1)
	ENDIF
	CL=C(1)2+C(2)2+C(3)**2
	IF (CL.LE.0) CALL KTWARN('KTRROT',101,*999)
	CL=1/SQRT(CL)
	!C---FIND ROTATION TO INTERMEDIATE AXES FROM A
	D(1)=A(2)C(3)-A(3)C(2)
	D(2)=A(3)C(1)-A(1)C(3)
	D(3)=A(1)C(2)-A(2)C(1)
	DL=AL*CL
	M(1,1)=A(1)*AL
	M(1,2)=A(2)*AL
	M(1,3)=A(3)*AL
	M(1,4)=0
	M(2,1)=C(1)*CL
	M(2,2)=C(2)*CL
	M(2,3)=C(3)*CL
	M(2,4)=0
	M(3,1)=D(1)*DL
	M(3,2)=D(2)*DL
	M(3,3)=D(3)*DL
	M(3,4)=0
	M(4,1)=0
	M(4,2)=0
	M(4,3)=0
	M(4,4)=1
	CALL KTMMUL(M,R,R)
	!C---AND ROTATION FROM INTERMEDIATE AXES TO B
	D(1)=B(2)C(3)-B(3)C(2)
	D(2)=B(3)C(1)-B(1)C(3)
	D(3)=B(1)C(2)-B(2)C(1)
	DL=BL*CL
	M(1,1)=B(1)*BL
	M(2,1)=B(2)*BL
	M(3,1)=B(3)*BL
	M(1,2)=C(1)*CL
	M(2,2)=C(2)*CL
	M(3,2)=C(3)*CL
	M(1,3)=D(1)*DL
	M(2,3)=D(2)*DL
	M(3,3)=D(3)*DL
	CALL KTMMUL(M,R,R)
	RETURN
	999 RETURN 1
	END SUBROUTINE KTRROT
	!C-----------------------------------------------------------------------
	SUBROUTINE KTVMUL(M,A,B)
	IMPLICIT NONE
	!C 4 BY 4 MATRIX TIMES 4 VECTOR: B=M*A.
	!C ALL ARE DOUBLE PRECISION
	!C IT IS SAFE TO CALL WITH B=A
	!C FIRST SUBSCRIPT=ROWS, SECOND=COLUMNS
	DOUBLE PRECISION M(4,4),A(4),B(4),C(4)
	INTEGER I,J
	DO I=1,4
	C(I)=0
	DO J=1,4
	C(I)=C(I)+M(I,J)*A(J)
	END DO
	END DO
	DO I=1,4
	B(I)=C(I)
	END DO
	END SUBROUTINE KTVMUL
	!C-----------------------------------------------------------------------
	SUBROUTINE KTMMUL(A,B,C)
	IMPLICIT NONE
	!C 4 BY 4 MATRIX MULTIPLICATION: C=A*B.
	!C ALL ARE DOUBLE PRECISION
	!C IT IS SAFE TO CALL WITH C=A OR B.
	!C FIRST SUBSCRIPT=ROWS, SECOND=COLUMNS
	DOUBLE PRECISION A(4,4),B(4,4),C(4,4),D(4,4)
	INTEGER I,J,K
	DO I=1,4
	DO J=1,4
	D(I,J)=0
	DO K=1,4
	D(I,J)=D(I,J)+A(I,K)*B(K,J)
	END DO
	END DO
	END DO
	DO I=1,4
	DO J=1,4
	C(I,J)=D(I,J)
	END DO
	END DO
	END SUBROUTINE KTMMUL
	!C-----------------------------------------------------------------------
	SUBROUTINE KTINVT(A,B)
	IMPLICIT NONE
	!C---INVERT TRANSFORMATION MATRIX A
	!C
	!C A = INPUT : 4 BY 4 TRANSFORMATION MATRIX
	!C B = OUTPUT : INVERTED TRANSFORMATION MATRIX
	!C
	!C IF A IS NOT A TRANSFORMATION MATRIX YOU WILL GET STRANGE RESULTS
	!C
	!C NOTE THAT IT IS SAFE TO CALL WITH A=B
	!C
	DOUBLE PRECISION A(4,4),B(4,4),C(4,4)
	INTEGER I,J
	!C---TRANSPOSE
	DO I=1,4
	DO J=1,4
	C(I,J)=A(J,I)
	END DO
	END DO
	!C---NEGATE ENERGY-MOMENTUM MIXING TERMS
	DO I=1,3
	C(4,I)=-C(4,I)
	C(I,4)=-C(I,4)
	END DO
	!C---OUTPUT
	DO I=1,4
	DO J=1,4
	B(I,J)=C(I,J)
	END DO
	END DO
	END SUBROUTINE KTINVT
	!C-----------------------------------------------------------------------
	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*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
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\subsection{CKKW matching}
	<<[[ckkw_matching.f90]]>>=
	<<File header>>

	module ckkw_matching

	<<Use kinds>>
	use kinds, only: double !NODEP!
	use constants !NODEP!
	use lorentz !NODEP!
	use io_units !NODEP!
	use diagnostics !NODEP!
	use tao_random_numbers !NODEP!
	use shower_base
	use shower_partons
	use shower_core
	use ckkw_pseudo_weights

	<<Standard module head>>

	<<CKKW matching: public>>

	<<CKKW matching: types>>

	contains

	<<CKKW matching: procedures>>

	end module ckkw_matching
	@ %def ckkw_matching
	@
	<<CKKW matching: public>>=
	public :: ckkw_matching_settings_t
	<<CKKW matching: types>>=
	type :: ckkw_matching_settings_t
	real(default) :: alphaS = 0.118_default
	real(default) :: Qmin = one
	integer :: n_max_jets = 0
	end type ckkw_matching_settings_t

	@ %def ckkw_matching_settings_t
	@
	<<CKKW matching: public>>=
	public :: ckkw_matching_apply
	@
	<<CKKW matching: procedures>>=
	subroutine ckkw_matching_apply (shower, settings, weights, veto)
	type(shower_t), intent(inout) :: shower
	type(ckkw_matching_settings_t), intent(in) :: settings
	type(ckkw_pseudo_shower_weights_t), intent(in) :: weights
	logical, intent(out) :: veto

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

	if (signal_is_pending ()) return
	weight = 1.0

	call shower%write ()

	!!! the pseudo parton shower is already simulated by shower_add_interaction
	!!! get the respective clustering scales
	allocate (scales(1:size(shower%partons)))
	do i = 1, size (shower%partons)
	if (.not. associated (shower%partons(i)%p)) cycle
	if (shower%partons(i)%p%type == 94) then
	scales(i) = 2.0 * min (parton_get_energy (shower%partons(i)%p%child1), &
	parton_get_energy (shower%partons(i)%p%child2))*2 &
	(1.0 - (space_part (shower%partons(i)%p%child1%momentum) * &
	space_part (shower%partons(i)%p%child2%momentum)) / &
	(space_part (shower%partons(i)%p%child1%momentum)*1 &
	space_part (shower%partons(i)%p%child2%momentum)**1))
	scales(i) = sqrt (scales(i))
	shower%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)
	call shower%write ()

	!!! 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, size (shower%partons)
	if (signal_is_pending ()) return
	if (.not. associated (shower%partons(i)%p)) cycle
	if (shower%partons(i)%p%type == 94) then
	!!! get type
	!!! check that all particles involved are colored
	if ((parton_is_colored (shower%partons(i)%p) .or. &
	shower%partons(i)%p%ckkwtype > 0) .and. &
	(parton_is_colored (shower%partons(i)%p%child1) .or. &
	shower%partons(i)%p%child1%ckkwtype > 0) .and. &
	(parton_is_colored (shower%partons(i)%p%child1) .or. &
	shower%partons(i)%p%child1%ckkwtype > 0)) then
	print *, "reweight with alphaS(" , shower%partons(i)%p%ckkwscale, &
	") for particle ", shower%partons(i)%p%nr
	if (shower%partons(i)%p%belongstoFSR) then
	print *, "FSR"
	weight = weight * D_alpha_s_fsr (shower%partons(i)%p%ckkwscale**2) &
	/ settings%alphas
	else
	print *, "ISR"
	weight = weight * &
	D_alpha_s_isr (shower%partons(i)%p%ckkwscale**2) &
	/ settings%alphas
	end if
	else
	print *, "no reweight with alphaS for ", shower%partons(i)%p%nr
	end if
	if (shower%partons(i)%p%child1%type == 94) then
	print *, "internal line from ", &
	shower%partons(i)%p%child1%ckkwscale, &
	" to ", shower%partons(i)%p%ckkwscale, &
	" for type ", shower%partons(i)%p%child1%ckkwtype
	if (shower%partons(i)%p%child1%ckkwtype == 0) then
	sf = 1.0
	else if (shower%partons(i)%p%child1%ckkwtype == 1) then
	sf = SudakovQ (shower%partons(i)%p%child1%ckkwscale, &
	shower%partons(i)%p%ckkwscale, .true.)
	print *, "SFQ = ", sf
	else if (shower%partons(i)%p%child1%ckkwtype == 2) then
	sf = SudakovG (shower%partons(i)%p%child1%ckkwscale, &
	shower%partons(i)%p%ckkwscale, .true.)
	print *, "SFG = ", sf
	else
	print *, "SUSY not yet implemented"
	end if
	weight = weight * min (one, sf)
	else
	print *, "external line from ", settings%Qmin, &
	shower%partons(i)%p%ckkwscale
	if (parton_is_quark (shower%partons(i)%p%child1)) then
	sf = SudakovQ (settings%Qmin, &
	shower%partons(i)%p%ckkwscale, .true.)
	print *, "SFQ = ", sf
	else if (parton_is_gluon (shower%partons(i)%p%child1)) then
	sf = SudakovG (settings%Qmin, &
	shower%partons(i)%p%ckkwscale, .true.)
	print *, "SFG = ", sf
	else
	print *, "not yet implemented (", &
	shower%partons(i)%p%child2%type, ")"
	sf = one
	end if
	weight = weight * min (one, sf)
	end if
	if (shower%partons(i)%p%child2%type == 94) then
	print *, "internal line from ", shower%partons(i)%p%child2%ckkwscale, &
	" to ", shower%partons(i)%p%ckkwscale, &
	" for type ", shower%partons(i)%p%child2%ckkwtype
	if (shower%partons(i)%p%child2%ckkwtype == 0) then
	sf = 1.0
	else if (shower%partons(i)%p%child2%ckkwtype == 1) then
	sf = SudakovQ (shower%partons(i)%p%child2%ckkwscale, &
	shower%partons(i)%p%ckkwscale, .true.)
	print *, "SFQ = ", sf
	else if (shower%partons(i)%p%child2%ckkwtype == 2) then
	sf = SudakovG (shower%partons(i)%p%child2%ckkwscale, &
	shower%partons(i)%p%ckkwscale, .true.)
	print *, "SFG = ", sf
	else
	print *, "SUSY not yet implemented"
	end if
	weight = weight * min (one, sf)
	else
	print *, "external line from ", settings%Qmin, &
	shower%partons(i)%p%ckkwscale
	if (parton_is_quark (shower%partons(i)%p%child2)) then
	sf = SudakovQ (settings%Qmin, &
	shower%partons(i)%p%ckkwscale, .true.)
	print *, "SFQ = ", sf
	else if (parton_is_gluon (shower%partons(i)%p%child2)) then
	sf = SudakovG (settings%Qmin, &
	shower%partons(i)%p%ckkwscale, .true.)
	print *, "SFG = ", sf
	else
	print *, "not yet implemented (", &
	shower%partons(i)%p%child2%type, ")"
	sf = one
	end if
	weight = weight * min (one, sf)
	end if
	end if
	end do

	call tao_random_number(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, fsr) result (gamma)
	real(default), intent(in) :: smallq, largeq
	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)
	else
	gamma = gamma * D_alpha_s_isr (smallq**2)
	end if
	end function GammaQ

	@ %def GammaQ
	@
	<<CKKW matching: procedures>>=
	function GammaG(smallq, largeq, fsr) result(gamma)
	real(default), intent(in) :: smallq, largeq
	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)
	else
	gamma = gamma * D_alpha_s_isr(smallq**2)
	end if
	end function GammaG

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

	@ %def GammaF
	@
	<<CKKW matching: procedures>>=
	function SudakovQ (Q1, Q, fsr) result (sf)
	real(default), intent(in) :: Q1, Q
	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 tao_random_number (rand)
	integral = integral + GammaQ (Q1 + rand * (Q - Q1), Q, fsr)
	end do
	integral = integral / NTRIES
	sf = exp (-integral)
	end function SudakovQ

	@ %def SudakovQ
	@
	<<CKKW matching: procedures>>=
	function SudakovG (Q1, Q, fsr) result (sf)
	real(default), intent(in) :: Q1, Q
	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 tao_random_number (rand)
	integral = integral + GammaG (Q1 + rand * (Q - Q1), Q, fsr) + &
	GammaF (Q1 +rand * (Q - Q1), fsr)
	end do
	integral = integral / NTRIES
	sf = exp (-integral)
	end function SudakovG

	@ %def SudakovG
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	\subsubsection{CKKW (pseudo) weights}

	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_pseudo_weights.f90]]>>=
	<<File header>>

	module ckkw_pseudo_weights

	<<Use kinds>>
	use io_units !NODEP!
	use constants !NODEP!

	<<Standard module head>>

	<<CKKW pseudo weights: public>>

	<<CKKW pseudo weights: types>>

	contains

	<<CKKW pseudo weights: procedures>>

	end module ckkw_pseudo_weights
	@ %def ckkw_pseudo_weights
	@
	<<CKKW pseudo weights: public>>=
	public :: ckkw_pseudo_shower_weights_t
	<<CKKW pseudo weights: 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 pseudo weights: public>>=
	public :: ckkw_pseudo_shower_weights_init
	<<CKKW pseudo weights: 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 pseudo weights: public>>=
	public :: ckkw_pseudo_shower_weights_write
	<<CKKW pseudo weights: 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
	@
	%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	@
	This is a collection of dummy replacement routines.
	<<[[shower_dummy.f90]]>>=
	module pythia_dummy
	public :: pyinit
	public :: pygive
	public :: pylist
	public :: pyevnt
	public :: pyp
	public :: upinit
	contains
	subroutine pylist (i)
	integer, intent(in) :: i
	<<Shower dummy: error message>>
	end subroutine pylist

	subroutine pyinit (frame, beam, target, win)
	character(), intent(in) :: frame, beam, target
	double precision, intent(in) :: win
	<<Shower dummy: error message>>
	end subroutine pyinit
	subroutine upinit
	<<Shower dummy: error message>>
	end subroutine upinit
	subroutine pygive (chin)
	character chin()
	<<Shower dummy: error message>>
	end subroutine pygive
	subroutine pyevnt()
	<<Shower dummy: error message>>
	end subroutine pyevnt
	subroutine pyexec()
	<<Shower dummy: error message>>
	end subroutine pyexec
	function pyp(I,J)
	integer, intent(in) :: i,j
	double precision :: pyp
	<<Shower dummy: error message>>
	end function pyp
	end module pythia_dummy


	module ckkw_pseudo_weights
	use kinds, only: default, double !NODEP!

	implicit none

	public :: ckkw_pseudo_shower_weights_t
	public :: ckkw_pseudo_shower_weights_write
	public :: ckkw_pseudo_shower_weights_init

	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

	contains

	subroutine ckkw_pseudo_shower_weights_init (weights)
	type(ckkw_pseudo_shower_weights_t), intent(out) :: weights
	<<Shower dummy: error message>>
	end subroutine ckkw_pseudo_shower_weights_init

	subroutine ckkw_pseudo_shower_weights_write (weights)
	type(ckkw_pseudo_shower_weights_t), intent(in) :: weights
	<<Shower dummy: error message>>
	end subroutine ckkw_pseudo_shower_weights_write

	end module ckkw_pseudo_weights


	module shower_base
	use kinds, only: default !NODEP!
	use constants !NODEP!
	public :: shower_set_minenergy_timelike
	public :: shower_set_d_min_t
	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_lambda_fsr
	public :: shower_set_d_lambda_isr
	public :: shower_set_d_constantalpha_s
	public :: shower_set_maxz_isr
	public :: shower_set_isr_pt_ordered
	public :: shower_set_isr_angular_ordered
	public :: shower_set_primordial_kt_width
	public :: shower_set_primordial_kt_cutoff
	public :: shower_set_tscalefactor_isr
	public :: shower_set_isr_only_onshell_emitted_partons
	public :: shower_set_pdf_func
	public :: shower_set_pdf_set
	public :: shower_pdf

	real(default), public :: D_Min_t = one

	interface
	subroutine shower_pdf (set, x, q, ff)
	integer, intent(in) :: set
	double precision, intent(in) :: x, q
	double precision, dimension(-6:6), intent(out) :: ff
	end subroutine shower_pdf
	end interface
	contains
	subroutine shower_set_minenergy_timelike (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_minenergy_timelike
	subroutine shower_set_d_min_t (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_d_min_t
	subroutine shower_set_d_nf (input)
	integer, intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_d_nf
	subroutine shower_set_isr_pt_ordered (input)
	logical, intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_isr_pt_ordered
	subroutine shower_set_isr_angular_ordered (input)
	logical, intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_isr_angular_ordered
	subroutine shower_set_d_lambda_fsr (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_d_lambda_fsr
	subroutine shower_set_d_lambda_isr (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_d_lambda_isr
	subroutine shower_set_d_running_alpha_s_fsr (input)
	logical, intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_d_running_alpha_s_fsr
	subroutine shower_set_d_running_alpha_s_isr (input)
	logical, intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_d_running_alpha_s_isr
	subroutine shower_set_d_constantalpha_s (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_d_constantalpha_s
	subroutine shower_set_maxz_isr (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_maxz_isr
	subroutine shower_set_primordial_kt_width (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_primordial_kt_width
	subroutine shower_set_primordial_kt_cutoff (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_primordial_kt_cutoff
	subroutine shower_set_tscalefactor_isr (input)
	real(default), intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_tscalefactor_isr
	subroutine shower_set_isr_only_onshell_emitted_partons (input)
	logical, intent(in) :: input
	<<Shower dummy: error message>>
	end subroutine shower_set_isr_only_onshell_emitted_partons
	subroutine shower_set_pdf_func(func)
	procedure(shower_pdf), pointer, intent(in) :: func
	<<Shower dummy: error message>>
	end subroutine shower_set_pdf_func

	subroutine shower_set_pdf_set(set)
	integer, intent(in) :: set
	<<Shower dummy: error message>>
	end subroutine shower_set_pdf_set
	end module shower_base

	module shower_partons
	use kinds, only: default !NODEP!
	use constants !NODEP!
	use lorentz !NODEP!

	<<Shower partons: public>>

	<<Shower partons: types>>

	contains
	subroutine parton_set_simulated (prt, sim)
	type(parton_t), intent(inout) :: prt
	logical, intent(in), optional :: sim
	<<Shower dummy: error message>>
	end subroutine parton_set_simulated
	subroutine parton_set_momentum (prt, EE, ppx, ppy, ppz)
	type(parton_t), intent(inout) :: prt
	real(default), intent(in) :: EE, ppx, ppy, ppz
	<<Shower dummy: error message>>
	end subroutine parton_set_momentum
	subroutine parton_set_initial (prt, initial)
	type(parton_t), intent(inout) :: prt
	type(parton_t), intent(in) , target :: initial
	<<Shower dummy: error message>>
	end subroutine parton_set_initial
	end module shower_partons

	module shower_core
	use kinds, only: default
	use shower_base
	use shower_partons
	use ckkw_pseudo_weights
	use pythia_dummy

	<<Shower core: public>>

	<<Shower core: types>>

	<<Shower core: parameters>>

	contains
	function shower_get_next_free_nr (shower) result(next_number)
	class(shower_t), intent(inout) :: shower
	integer :: next_number
	<<Shower dummy: error message>>
	end function shower_get_next_free_nr
	function shower_generate_next_isr_branching (shower) result (next_brancher)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t) :: next_brancher
	<<Shower dummy: error message>>
	end function shower_generate_next_isr_branching
	function shower_generate_next_isr_branching_veto (shower) &
	result (next_brancher)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t) :: next_brancher
	<<Shower dummy: error message>>
	end function shower_generate_next_isr_branching_veto
	subroutine shower_generate_fsr_for_partons_emitted_in_isr (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_generate_fsr_for_partons_emitted_in_isr
	subroutine interaction_generate_primordial_kt (interaction)
	type(shower_interaction_t), intent(inout) :: interaction
	<<Shower dummy: error message>>
	end subroutine interaction_generate_primordial_kt
	subroutine shower_generate_primordial_kt (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_generate_primordial_kt
	subroutine shower_interaction_generate_fsr_2ton (shower, interaction)
	class(shower_t), intent(inout) :: shower
	type(shower_interaction_t), intent(inout) :: interaction
	<<Shower dummy: error message>>
	end subroutine shower_interaction_generate_fsr_2ton
	subroutine shower_execute_next_isr_branching (shower, prtp)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t), intent(inout) :: prtp
	<<Shower dummy: error message>>
	end subroutine shower_execute_next_isr_branching
	subroutine shower_boost_to_labframe (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_boost_to_labframe
	subroutine shower_get_final_colored_ME_partons(shower, partons)
	class(shower_t), intent(in) :: shower
	type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: &
	partons
	<<Shower dummy: error message>>
	end subroutine shower_get_final_colored_ME_partons
	subroutine shower_get_final_partons (shower, partons, include_remnants)
	type(shower_t), intent(in) :: shower
	type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: partons
	logical, intent(in), optional :: include_remnants
	<<Shower dummy: error message>>
	end subroutine shower_get_final_partons
	subroutine shower_write (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_write
	subroutine shower_sort_partons (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_sort_partons
	subroutine shower_add_interaction_2ton (shower, partons)
	class(shower_t), intent(inout) :: shower
	type(parton_pointer_t), intent(inout), dimension(:), allocatable :: &
	partons
	<<Shower dummy: error message>>
	end subroutine shower_add_interaction_2ton
	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
	<<Shower dummy: error message>>
	end subroutine shower_add_interaction_2ton_CKKW
	subroutine shower_simulate_no_isr_shower (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_simulate_no_isr_shower
	subroutine shower_simulate_no_fsr_shower (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_simulate_no_fsr_shower
	subroutine shower_update_beamremnants (shower)
	class(shower_t), intent(in) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_update_beamremnants
	subroutine shower_set_next_color_nr (shower, index)
	class(shower_t), intent(in) :: shower
	integer, intent(in) :: index
	<<Shower dummy: error message>>
	end subroutine shower_set_next_color_nr
	subroutine shower_create (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_create
	subroutine shower_final (shower)
	class(shower_t), intent(inout) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_final
	subroutine shower_write_lhef (shower, unit)
	class(shower_t), intent(in) :: shower
	integer, intent(in), optional :: unit
	<<Shower dummy: error message>>
	end subroutine shower_write_lhef
	function shower_interaction_get_s (interaction) result(s)
	type(shower_interaction_t), intent(in) :: interaction
	real(default) :: s
	<<Shower dummy: error message>>
	end function shower_interaction_get_s
	function shower_get_ISR_scale (shower) result (scale)
	class(shower_t), intent(in) :: shower
	real(default) :: scale
	<<Shower dummy: error message>>
	end function shower_get_ISR_scale
	function shower_get_next_color_nr (shower) result(next_color)
	class(shower_t), intent(inout) :: shower
	integer :: next_color
	<<Shower dummy: error message>>
	end function shower_get_next_color_nr
	subroutine shower_set_max_isr_scale (shower, newscale)
	class(shower_t), intent(inout) :: shower
	real(default), intent(in) :: newscale
	<<Shower dummy: error message>>
	end subroutine shower_set_max_isr_scale
	subroutine shower_add_child (shower, prt, child)
	class(shower_t), intent(inout) :: shower
	type(parton_t), intent(in) :: prt
	integer, intent(in) :: child
	<<Shower dummy: error message>>
	end subroutine shower_add_child
	subroutine shower_add_parent (shower, prt)
	class(shower_t), intent(inout) :: shower
	type(parton_t), intent(in) :: prt
	<<Shower dummy: error message>>
	end subroutine shower_add_parent
	end module shower_core

	module shower_topythia
	<<Use kinds>>
	use shower_base
	use shower_partons
	use shower_core
	<<Shower2pythia: public>>
	contains
	subroutine shower_converttopythia (shower)
	type(shower_t), intent(in) :: shower
	<<Shower dummy: error message>>
	end subroutine shower_converttopythia
	end module shower_topythia

	module mlm_matching
	<<Use kinds>>
	use kinds, only: double !NODEP!
	use constants !NODEP!
	use lorentz !NODEP!

	<<MLM matching: public>>

	<<MLM matching: types>>

	contains

	subroutine mlm_matching_settings_write (settings, unit)
	type(mlm_matching_settings_t), intent(in) :: settings
	integer, intent(in), optional :: unit
	<<Shower dummy: error message>>
	end subroutine mlm_matching_settings_write

	subroutine mlm_matching_data_final (data)
	type(mlm_matching_data_t), intent(inout) :: data
	<<Shower dummy: error message>>
	end subroutine mlm_matching_data_final

	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
	<<Shower dummy: error message>>
	end subroutine mlm_matching_apply
	end module mlm_matching



	module ckkw_matching
	<<Use kinds>>
	use kinds, only: double !NODEP!
	use shower_core
	use ckkw_pseudo_weights

	<<Standard module head>>

	<<CKKW matching: public>>

	<<CKKW matching: types>>

	contains

	subroutine ckkw_matching_apply (shower, settings, weights, veto)
	type(shower_t), intent(inout) :: shower
	type(ckkw_matching_settings_t), intent(in) :: settings
	type(ckkw_pseudo_shower_weights_t), intent(in) :: weights
	logical, intent(out) :: veto
	veto = .false.
	<<Shower dummy: error message>>
	end subroutine ckkw_matching_apply

	end module ckkw_matching
	@ %def shower_dummy
	@
	<<Shower dummy: error message>>=
	write (0, "(A)") "**************************************************************"
	write (0, "(A)") "* Error: Shower has not been enabled, WHIZARD terminates *"
	write (0, "(A)") "**************************************************************"
	stop
	@
	@

File Metadata

Mime Type: text/x-tex
Expires: Sun, Feb 23, 2:55 PM (1 d, 7 h)
Storage Engine: blob
Storage Format: Raw Data
Storage Handle: 4486736
Default Alt Text: shower.nw (340 KB)

shower.nwNo OneTemporaryActions

shower.nwView Options

File Metadata

Event Timeline

shower.nw
No OneTemporary
Actions

shower.nw
View Options