Page MenuHomeHEPForge
Files F19250540

No OneTemporary
Actions

Size
341 KB
Referenced Files
None
Subscribers
None

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
Index: trunk/src/shower/shower.nw
===================================================================
--- trunk/src/shower/shower.nw (revision 7594)
+++ trunk/src/shower/shower.nw (revision 7595)
@@ -1,8159 +1,8159 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD shower code as NOWEB source
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Parton shower and interface to PYTHIA6}
This is the code for the \whizard\ QCD parton shower for final state
radiation (FSR) and initial state radiation (ISR) as well as the interface
to the \pythia\ module for showering and hadronization.
\section{Basics of the shower}
<<[[shower_base.f90]]>>=
<<File header>>
module shower_base
<<Use kinds with double>>
<<Use strings>>
use io_units
use constants
use diagnostics
use format_utils, only: write_separator
use lorentz
use particles
use os_interface
use rng_base
use physics_defs
use sm_physics, only: running_as_lam
use particles
use variables
use model_data
use pdf
use tauola_interface
<<Standard module head>>
<<Shower base: parameters>>
<<Shower base: public>>
<<Shower base: types>>
<<Shower base: interfaces>>
contains
<<Shower base: procedures>>
end module shower_base
@ %def shower_base
@
\subsection{Shower implementations}
<<Shower base: public>>=
public :: PS_WHIZARD, PS_PYTHIA6, PS_PYTHIA8, PS_UNDEFINED
<<Shower base: parameters>>=
integer, parameter :: PS_WHIZARD = 1
integer, parameter :: PS_PYTHIA6 = 2
integer, parameter :: PS_PYTHIA8 = 3
integer, parameter :: PS_UNDEFINED = 17
@ %def PS_WHIZARD PS_PYTHIA6 PS_PYTHIA8 PS_UNDEFINED
@ A dictionary
<<Shower base: public>>=
public :: shower_method_of_string
<<Shower base: procedures>>=
elemental function shower_method_of_string (string) result (i)
integer :: i
type(string_t), intent(in) :: string
select case (char(string))
case ("WHIZARD")
i = PS_WHIZARD
case ("PYTHIA6")
i = PS_PYTHIA6
case ("PYTHIA8")
i = PS_PYTHIA8
case default
i = PS_UNDEFINED
end select
end function shower_method_of_string
@ %def shower_method_of_string
@
<<Shower base: public>>=
public :: shower_method_to_string
<<Shower base: procedures>>=
elemental function shower_method_to_string (i) result (string)
type(string_t) :: string
integer, intent(in) :: i
select case (i)
case (PS_WHIZARD)
string = "WHIZARD"
case (PS_PYTHIA6)
string = "PYTHIA6"
case (PS_PYTHIA8)
string = "PYTHIA8"
case default
string = "UNDEFINED"
end select
end function shower_method_to_string
@ %def shower_method_to_string
@
\subsection{Shower settings}
These the general shower settings, the settings and parameters for the
matching are defined in the corresponding matching modules. The width
and the cutoff of the Gaussian primordial $k_t$ distribution,
[[PARP(91)]] and [[PARP(93)]], in GeV, are called
[[isr_primordial_kt_width]] and [[isr_primordial_kt_cutoff]] in \whizard.
The parameter [[MSTJ(45)]] gives the maximum number of flavors in
gluon decay to quarks, and is here called [[max_n_flavors]].
The two parameters [[isr_alpha_s_running] and [[fsr_alpha_s_running]]
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
parameter, [[fixed_alpha_s]] is the parameter [[PARU(111)]], which
sets the value for constant $\alpha_s$, and the flag whether to use
$P_t$-ordered ISR is [[isr_pt_ordered]].
<<Shower base: public>>=
public :: shower_settings_t
<<Shower base: types>>=
type :: shower_settings_t
logical :: active = .false.
logical :: isr_active = .false.
logical :: fsr_active = .false.
logical :: muli_active = .false.
logical :: tau_dec = .false.
logical :: verbose = .false.
integer :: method = PS_UNDEFINED
logical :: hadronization_active = .false.
logical :: hadron_collision = .false.
logical :: mlm_matching = .false.
logical :: ckkw_matching = .false.
logical :: powheg_matching = .false.
type(string_t) :: pythia6_pygive
!!! values present in PYTHIA and WHIZARDs PS,
!!! comments denote corresponding PYTHIA values
real(default) :: min_virtuality = 1._default ! PARJ(82)^2
real(default) :: fsr_lambda = 0.29_default ! PARP(72)
real(default) :: isr_lambda = 0.29_default ! PARP(61)
integer :: max_n_flavors = 5 ! MSTJ(45)
logical :: isr_alpha_s_running = .true. ! MSTP(64)
logical :: fsr_alpha_s_running = .true. ! MSTJ(44)
real(default) :: fixed_alpha_s = 0.2_default ! PARU(111)
logical :: alpha_s_fudged = .true.
logical :: isr_pt_ordered = .false.
logical :: isr_angular_ordered = .true. ! MSTP(62)
real(default) :: isr_primordial_kt_width = 1.5_default ! PARP(91)
real(default) :: isr_primordial_kt_cutoff = 5._default ! PARP(93)
real(default) :: isr_z_cutoff = 0.999_default ! 1-PARP(66)
real(default) :: isr_minenergy = 2._default ! PARP(65)
real(default) :: isr_tscalefactor = 1._default
logical :: isr_only_onshell_emitted_partons = .true. ! MSTP(63)
contains
<<Shower base: shower settings: TBP>>
end type shower_settings_t
@ %def shower_settings_t
@ Read in the shower settings (and flags whether matching and
hadronization are switched on).
<<Shower base: shower settings: TBP>>=
procedure :: init => shower_settings_init
<<Shower base: procedures>>=
subroutine shower_settings_init (shower_settings, var_list)
class(shower_settings_t), intent(out) :: shower_settings
type(var_list_t), intent(in) :: var_list
shower_settings%fsr_active = &
var_list%get_lval (var_str ("?ps_fsr_active"))
shower_settings%isr_active = &
var_list%get_lval (var_str ("?ps_isr_active"))
shower_settings%tau_dec = &
var_list%get_lval (var_str ("?ps_taudec_active"))
shower_settings%muli_active = &
var_list%get_lval (var_str ("?muli_active"))
shower_settings%hadronization_active = &
var_list%get_lval (var_str ("?hadronization_active"))
shower_settings%mlm_matching = &
var_list%get_lval (var_str ("?mlm_matching"))
shower_settings%ckkw_matching = &
var_list%get_lval (var_str ("?ckkw_matching"))
shower_settings%powheg_matching = &
var_list%get_lval (var_str ("?powheg_matching"))
shower_settings%method = shower_method_of_string ( &
var_list%get_sval (var_str ("$shower_method")))
!!! We have to split off hadronization settings at some point.
shower_settings%active = shower_settings%isr_active .or. &
shower_settings%fsr_active .or. &
shower_settings%powheg_matching .or. &
shower_settings%muli_active .or. &
shower_settings%hadronization_active
if (.not. shower_settings%active) return
shower_settings%verbose = &
var_list%get_lval (var_str ("?shower_verbose"))
shower_settings%pythia6_pygive = &
var_list%get_sval (var_str ("$ps_PYTHIA_PYGIVE"))
shower_settings%min_virtuality = &
(var_list%get_rval (var_str ("ps_mass_cutoff"))**2)
shower_settings%fsr_lambda = &
var_list%get_rval (var_str ("ps_fsr_lambda"))
shower_settings%isr_lambda = &
var_list%get_rval (var_str ("ps_isr_lambda"))
shower_settings%max_n_flavors = &
var_list%get_ival (var_str ("ps_max_n_flavors"))
shower_settings%isr_alpha_s_running = &
var_list%get_lval (var_str ("?ps_isr_alpha_s_running"))
shower_settings%fsr_alpha_s_running = &
var_list%get_lval (var_str ("?ps_fsr_alpha_s_running"))
shower_settings%fixed_alpha_s = &
var_list%get_rval (var_str ("ps_fixed_alpha_s"))
shower_settings%isr_pt_ordered = &
var_list%get_lval (var_str ("?ps_isr_pt_ordered"))
shower_settings%isr_angular_ordered = &
var_list%get_lval (var_str ("?ps_isr_angular_ordered"))
shower_settings%isr_primordial_kt_width = &
var_list%get_rval (var_str ("ps_isr_primordial_kt_width"))
shower_settings%isr_primordial_kt_cutoff = &
var_list%get_rval (var_str ("ps_isr_primordial_kt_cutoff"))
shower_settings%isr_z_cutoff = &
var_list%get_rval (var_str ("ps_isr_z_cutoff"))
shower_settings%isr_minenergy = &
var_list%get_rval (var_str ("ps_isr_minenergy"))
shower_settings%isr_tscalefactor = &
var_list%get_rval (var_str ("ps_isr_tscalefactor"))
shower_settings%isr_only_onshell_emitted_partons = &
var_list%get_lval (&
var_str ("?ps_isr_only_onshell_emitted_partons"))
end subroutine shower_settings_init
@ %def shower_settings_init
@
<<Shower base: shower settings: TBP>>=
procedure :: write => shower_settings_write
<<Shower base: procedures>>=
subroutine shower_settings_write (settings, unit)
class(shower_settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "Shower settings:"
call write_separator (u)
write (u, "(1x,A)") "Master switches:"
write (u, "(3x,A,1x,L1)") &
"ps_isr_active = ", settings%isr_active
write (u, "(3x,A,1x,L1)") &
"ps_fsr_active = ", settings%fsr_active
write (u, "(3x,A,1x,L1)") &
"ps_tau_dec = ", settings%tau_dec
write (u, "(3x,A,1x,L1)") &
"muli_active = ", settings%muli_active
write (u, "(1x,A)") "General settings:"
if (settings%isr_active .or. settings%fsr_active) then
write (u, "(3x,A)") &
"shower_method = " // &
char (shower_method_to_string (settings%method))
write (u, "(3x,A,1x,L1)") &
"shower_verbose = ", settings%verbose
write (u, "(3x,A,ES19.12)") &
"ps_mass_cutoff = ", &
sqrt (abs (settings%min_virtuality))
write (u, "(3x,A,1x,I1)") &
"ps_max_n_flavors = ", settings%max_n_flavors
else
write (u, "(3x,A)") " [ISR and FSR off]"
end if
if (settings%isr_active) then
write (u, "(1x,A)") "ISR settings:"
write (u, "(3x,A,1x,L1)") &
"ps_isr_pt_ordered = ", settings%isr_pt_ordered
write (u, "(3x,A,ES19.12)") &
"ps_isr_lambda = ", settings%isr_lambda
write (u, "(3x,A,1x,L1)") &
"ps_isr_alpha_s_running = ", settings%isr_alpha_s_running
write (u, "(3x,A,ES19.12)") &
"ps_isr_primordial_kt_width = ", settings%isr_primordial_kt_width
write (u, "(3x,A,ES19.12)") &
"ps_isr_primordial_kt_cutoff = ", &
settings%isr_primordial_kt_cutoff
write (u, "(3x,A,ES19.12)") &
"ps_isr_z_cutoff = ", settings%isr_z_cutoff
write (u, "(3x,A,ES19.12)") &
"ps_isr_minenergy = ", settings%isr_minenergy
write (u, "(3x,A,ES19.12)") &
"ps_isr_tscalefactor = ", settings%isr_tscalefactor
else if (settings%fsr_active) then
write (u, "(3x,A)") " [ISR off]"
end if
if (settings%fsr_active) then
write (u, "(1x,A)") "FSR settings:"
write (u, "(3x,A,ES19.12)") &
"ps_fsr_lambda = ", settings%fsr_lambda
write (u, "(3x,A,1x,L1)") &
"ps_fsr_alpha_s_running = ", settings%fsr_alpha_s_running
else if (settings%isr_active) then
write (u, "(3x,A)") " [FSR off]"
end if
write (u, "(1x,A)") "Hadronization settings:"
write (u, "(3x,A,1x,L1)") &
"hadronization_active = ", settings%hadronization_active
write (u, "(1x,A)") "Matching Settings:"
write (u, "(3x,A,1x,L1)") &
"mlm_matching = ", settings%mlm_matching
write (u, "(3x,A,1x,L1)") &
"ckkw_matching = ", settings%ckkw_matching
write (u, "(1x,A)") "PYTHIA6 specific settings:"
write (u, "(3x,A,A,A)") &
"ps_PYTHIA_PYGIVE = '", &
char(settings%pythia6_pygive), "'"
end subroutine shower_settings_write
@ %def shower_settings_write
@
\subsection{Abstract Shower Type}
Any parton shower implementation will use random numbers to generate
emissions.
<<Shower base: public>>=
public :: shower_base_t
<<Shower base: types>>=
type, abstract :: shower_base_t
class(rng_t), allocatable :: rng
type(string_t) :: name
type(pdf_data_t) :: pdf_data
type(shower_settings_t) :: settings
type(taudec_settings_t) :: taudec_settings
contains
<<Shower base: shower base: TBP>>
end type shower_base_t
@ %def shower_base_t
@
<<Shower base: shower base: TBP>>=
procedure :: write_msg => shower_base_write_msg
<<Shower base: procedures>>=
subroutine shower_base_write_msg (shower)
class(shower_base_t), intent(inout) :: shower
call msg_message ("Shower: Using " // char(shower%name) // " shower")
end subroutine shower_base_write_msg
@ %def shower_base_write_msg
@
<<Shower base: shower base: TBP>>=
procedure :: import_rng => shower_base_import_rng
<<Shower base: procedures>>=
pure subroutine shower_base_import_rng (shower, rng)
class(shower_base_t), intent(inout) :: shower
class(rng_t), intent(inout), allocatable :: rng
call move_alloc (from = rng, to = shower%rng)
end subroutine shower_base_import_rng
@ %def shower_base_import_rng
@ Shower implementations need to know the overall settings as well as
[[pdf_data_t]] if ISR needs to be simulated.
<<Shower base: shower base: TBP>>=
procedure (shower_base_init), deferred :: init
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_init (shower, settings, taudec_settings, pdf_data)
import
class(shower_base_t), intent(out) :: shower
type(shower_settings_t), intent(in) :: settings
type(taudec_settings_t), intent(in) :: taudec_settings
type(pdf_data_t), intent(in) :: pdf_data
end subroutine shower_base_init
end interface
@ %def shower_base_init
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_prepare_new_event), deferred :: prepare_new_event
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_prepare_new_event &
(shower)
import
class(shower_base_t), intent(inout) :: shower
end subroutine shower_base_prepare_new_event
end interface
@ %def shower_base_prepare_new_event
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_import_particle_set), deferred :: import_particle_set
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_import_particle_set &
(shower, particle_set, os_data)
import
class(shower_base_t), target, intent(inout) :: shower
type(particle_set_t), intent(in) :: particle_set
type(os_data_t), intent(in) :: os_data
end subroutine shower_base_import_particle_set
end interface
@ %def shower_base_import_particle_set
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_generate_emissions), deferred :: generate_emissions
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_generate_emissions &
(shower, valid, number_of_emissions)
import
class(shower_base_t), intent(inout), target :: shower
logical, intent(out) :: valid
integer, optional, intent(in) :: number_of_emissions
end subroutine shower_base_generate_emissions
end interface
@ %def shower_base_generate_emissions
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_make_particle_set), deferred :: make_particle_set
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_make_particle_set &
(shower, particle_set, model, model_hadrons)
import
class(shower_base_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model
class(model_data_t), intent(in), target :: model_hadrons
end subroutine shower_base_make_particle_set
end interface
@ %def shower_base_make_particle_set
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_get_final_colored_ME_momenta), deferred :: &
get_final_colored_ME_momenta
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_get_final_colored_ME_momenta &
(shower, momenta)
import
class(shower_base_t), intent(in) :: shower
type(vector4_t), dimension(:), allocatable, intent(out) :: momenta
end subroutine shower_base_get_final_colored_ME_momenta
end interface
@ %def shower_base_get_final_colored_ME_momenta
@
\subsection{Additional parameters}
These parameters are the cut-off scale $t_{\text{cut}}$, given in
GeV$^2$ ([[PARJ(82)]]), the cut-off scale for the $P_t^2$-ordered
shower in GeV$^2$, and the two shower parameters [[PARP(72)]] and
[[PARP(61)]], respectively.
<<Shower base: parameters>>=
real(default), public :: D_min_scale = 0.5_default
@ %def D_min_scale
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
Temporary parameters for the $P_t$-ordered shower:
<<Shower base: parameters>>=
real(default), public :: scalefactor1 = 0.02_default
real(default), public :: scalefactor2 = 0.02_default
@ %def scalefactor1 scalefactor2
@
<<Shower base: public>>=
public :: D_alpha_s_isr
public :: D_alpha_s_fsr
<<Shower base: procedures>>=
function D_alpha_s_isr (tin, settings) result (alpha_s)
real(default), intent(in) :: tin
type(shower_settings_t), intent(in) :: settings
real(default) :: min_virtuality, d_constalpha_s, d_lambda_isr
integer :: d_nf
real(default) :: t
real(default) :: alpha_s
min_virtuality = settings%min_virtuality
d_lambda_isr = settings%isr_lambda
d_constalpha_s = settings%fixed_alpha_s
d_nf = settings%max_n_flavors
if (settings%alpha_s_fudged) then
t = max (max (0.1_default * min_virtuality, &
1.1_default * d_lambda_isr**2), abs(tin))
else
t = abs(tin)
end if
if (settings%isr_alpha_s_running) then
alpha_s = running_as_lam (number_of_flavors(t, d_nf, min_virtuality), &
sqrt(t), d_lambda_isr, 0)
else
alpha_s = d_constalpha_s
end if
end function D_alpha_s_isr
function D_alpha_s_fsr (tin, settings) result (alpha_s)
real(default), intent(in) :: tin
type(shower_settings_t), intent(in) :: settings
real(default) :: min_virtuality, d_lambda_fsr, d_constalpha_s
integer :: d_nf
real(default) :: t
real(default) :: alpha_s
min_virtuality = settings%min_virtuality
d_lambda_fsr = settings%fsr_lambda
d_constalpha_s = settings%fixed_alpha_s
d_nf = settings%max_n_flavors
if (settings%alpha_s_fudged) then
t = max (max (0.1_default * min_virtuality, &
1.1_default * d_lambda_fsr**2), abs(tin))
else
t = abs(tin)
end if
if (settings%fsr_alpha_s_running) then
alpha_s = running_as_lam (number_of_flavors (t, d_nf, min_virtuality), &
sqrt(t), d_lambda_fsr, 0)
else
alpha_s = d_constalpha_s
end if
end function D_alpha_s_fsr
@ %def D_alpha_s_isr D_alpha_s_fsr
@ Mass and mass squared selection functions. All masses are in
GeV. Light quarks are assumed to be ordered, $m_1 < m_2 < m_3 \ldots$,
and they get current masses, not elementary ones. Mesons and baryons
other than proton and neutron are needed as beam-remnants. Particles
with PDG number zero are taken massless, as well as proper beam
remnants and any other particles.
<<Shower base: public>>=
public :: mass_type
public :: mass_squared_type
<<Shower base: procedures>>=
elemental function mass_type (type, m2_default) result (mass)
integer, intent(in) :: type
real(default), intent(in) :: m2_default
real(default) :: mass
mass = sqrt (mass_squared_type (type, m2_default))
end function mass_type
elemental function mass_squared_type (type, m2_default) result (mass2)
integer, intent(in) :: type
real(default), intent(in) :: m2_default
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 (GLUON)
!!! mass2 = zero
case (NEUTRON)
mass2 = 0.939565_default**2
case (PROTON)
mass2 = 0.93827_default**2
case (DPLUS)
mass2 = 1.86960_default**2
case (D0)
mass2 = 1.86483_default**2
case (B0)
mass2 = 5.27950_default**2
case (BPLUS)
mass2 = 5.27917_default**2
case (DELTAPLUSPLUS)
mass2 = 1.232_default**2
case (SIGMA0)
mass2 = 1.192642_default**2
case (SIGMAPLUS)
mass2 = 1.18937_default**2
case (SIGMACPLUS)
mass2 = 2.4529_default**2
case (SIGMACPLUSPLUS)
mass2 = 2.45402_default**2
case (SIGMAB0)
mass2 = 5.8152_default**2
case (SIGMABPLUS)
mass2 = 5.8078_default**2
case (BEAM_REMNANT)
mass2 = zero !!! don't know how to handle the beamremnant
case default
mass2 = m2_default
end select
end function mass_squared_type
@ %def mass_type mass_squared_type
@ The number of flavors active at a certain scale (virtuality) $t$.
<<Shower base: public>>=
public :: number_of_flavors
<<Shower base: procedures>>=
elemental function number_of_flavors (t, d_nf, min_virtuality) result (nr)
real(default), intent(in) :: t, min_virtuality
integer, intent(in) :: d_nf
real(default) :: nr
integer :: i
nr = 0
if (t < min_virtuality) return ! arbitrary cut off
! TODO: do i = 1, min (max (3, d_nf), 6)
do i = 1, min (3, d_nf)
!!! to do: take heavier quarks(-> cuts on allowed costheta in g->qq)
!!! into account
if ((four * mass_squared_type (i, zero) + min_virtuality) < t ) then
nr = i
else
exit
end if
end do
end function number_of_flavors
@ %def number_of_flavors
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Parton module for the shower}
<<[[shower_partons.f90]]>>=
<<File header>>
module shower_partons
<<Use kinds with double>>
use io_units
use constants
use system_defs, only: TAB
use diagnostics
use physics_defs
use lorentz
use sm_physics
use particles
use flavors
use colors
use subevents
use model_data
use shower_base
use rng_base
<<Standard module head>>
<<Shower partons: public>>
<<Shower partons: types>>
contains
<<Shower partons: procedures>>
end module shower_partons
@ %def shower_partons
@
\subsection{The basic type defintions}
The type [[parton_t]] defines a parton for the shower. The [[x]] value
of the parton is only needed for spacelike showers. The pointer
[[initial]] is only needed for partons in initial showers, it points to
the hadron the parton is coming from. An auxiliary value for the
$P_t$-ordered ISR is [[aux_pt]]. Then, there are two auxiliary entries
for the clustering of CKKW pseudo weights and CKKW matching,
[[ckkwlabel]] and [[ckkwscale]]. In order to make shower settings
available to all operations on the shower partons, we endow the
[[parton_t]] type with a pointer to [[shower_settings_t]].
<<Shower partons: public>>=
public :: parton_t
<<Shower partons: types>>=
type :: parton_t
integer :: nr = 0
integer :: type = 0
type(shower_settings_t), pointer :: settings => null()
type(vector4_t) :: momentum = vector4_null
real(default) :: t = zero
real(default) :: mass2 = zero
real(default) :: scale = zero
real(default) :: z = zero
real(default) :: costheta = zero
real(default) :: x = zero
logical :: simulated = .false.
logical :: belongstoFSR = .true.
logical :: belongstointeraction = .false.
type(parton_t), pointer :: parent => null ()
type(parton_t), pointer :: child1 => null ()
type(parton_t), pointer :: child2 => null ()
type(parton_t), pointer :: initial => null ()
integer :: c1 = 0, c2 = 0
integer :: aux_pt = 0
integer :: ckkwlabel = 0
real(default) :: ckkwscale = zero
integer :: ckkwtype = -1
integer :: interactionnr = 0
contains
<<Shower partons: parton: TBP>>
end type parton_t
@ %def parton_t
@
<<Shower partons: public>>=
public :: parton_pointer_t
<<Shower partons: types>>=
type :: parton_pointer_t
type(parton_t), pointer :: p => null ()
end type parton_pointer_t
@ %def parton_pointer_t
@
\subsection{Routines}
<<Shower partons: parton: TBP>>=
procedure :: to_particle => parton_to_particle
<<Shower partons: procedures>>=
function parton_to_particle (parton, model, from_hard_int) result (particle)
type(particle_t) :: particle
class(parton_t), intent(in) :: parton
class(model_data_t), pointer, intent(in) :: model
logical, intent(in), optional :: from_hard_int
integer :: col, anti_col
call parton%to_color (col, anti_col, from_hard_int)
call particle%init (parton%to_status (from_hard_int), parton%type, &
model, col, anti_col, parton%momentum)
end function parton_to_particle
@ %def parton_to_particle
@
<<Shower partons: public>>=
public :: parton_of_particle
<<Shower partons: procedures>>=
! pure
function parton_of_particle (particle, nr) result (parton)
type(parton_t) :: parton
type(particle_t), intent(in) :: particle
integer, intent(in) :: nr
integer, dimension(2) :: col_array
parton%nr = nr
parton%momentum = particle%p
parton%t = particle%p2
parton%type = particle%flv%get_pdg ()
col_array = particle%get_color ()
parton%c1 = col_array (1)
parton%c2 = col_array (2)
parton%interactionnr = 1
parton%mass2 = particle%flv%get_mass () ** 2
end function parton_of_particle
@ %def parton_of_particle
@
<<Shower partons: parton: TBP>>=
procedure :: to_status => parton_to_status
<<Shower partons: procedures>>=
pure function parton_to_status (parton, from_hard_int) result (status)
integer :: status
class(parton_t), intent(in) :: parton
logical, intent(in), optional :: from_hard_int
logical :: fhi
fhi = .false.; if (present (from_hard_int)) fhi = from_hard_int
if (fhi .or. parton%is_colored ()) then
if (associated (parton%initial) .and. .not. parton%belongstoFSR) then
status = PRT_INCOMING
else
status = PRT_OUTGOING
end if
else
status = PRT_BEAM_REMNANT
end if
end function parton_to_status
@ %def parton_to_status
@
<<Shower partons: parton: TBP>>=
procedure :: to_color => parton_to_color
<<Shower partons: procedures>>=
pure subroutine parton_to_color (parton, c1, c2, from_hard_int)
class(parton_t), intent(in) :: parton
integer, intent(out) :: c1, c2
logical, intent(in), optional :: from_hard_int
logical :: fhi
fhi = .false.; if (present (from_hard_int)) fhi = from_hard_int
c1 = 0
c2 = 0
if (parton%is_colored ()) then
if (fhi) then
if (parton%c1 /= 0) c1 = parton%c1
if (parton%c2 /= 0) c2 = parton%c2
else
if (parton%c1 /= 0) c1 = 500 + parton%c1
if (parton%c2 /= 0) c2 = 500 + parton%c2
end if
end if
end subroutine parton_to_color
@ %def parton_to_color
<<Shower partons: public>>=
public :: parton_copy
<<Shower partons: procedures>>=
subroutine parton_copy (prt1, prt2)
type(parton_t), intent(in) :: prt1
type(parton_t), intent(out) :: prt2
if (associated (prt1%settings)) prt2%settings => prt1%settings
prt2%nr = prt1%nr
prt2%type = prt1%type
prt2%momentum = prt1%momentum
prt2%t = prt1%t
prt2%mass2 = prt1%mass2
prt2%scale = prt1%scale
prt2%z = prt1%z
prt2%costheta = prt1%costheta
prt2%x = prt1%x
prt2%simulated = prt1%simulated
prt2%belongstoFSR = prt1%belongstoFSR
prt2%belongstointeraction = prt1%belongstointeraction
prt2%interactionnr = prt1%interactionnr
if (associated (prt1%parent)) prt2%parent => prt1%parent
if (associated (prt1%child1)) prt2%child1 => prt1%child1
if (associated (prt1%child2)) prt2%child2 => prt1%child2
if (associated (prt1%initial)) prt2%initial => prt1%initial
prt2%c1 = prt1%c1
prt2%c2 = prt1%c2
prt2%aux_pt = prt1%aux_pt
end subroutine parton_copy
@ %def parton_copy
@ This returns the angle between the daughters assuming them to be
massless.
<<Shower partons: parton: TBP>>=
procedure :: get_costheta => parton_get_costheta
<<Shower partons: procedures>>=
elemental function parton_get_costheta (prt) result (costheta)
class(parton_t), intent(in) :: prt
real(default) :: costheta
real(default) :: denom
denom = two * prt%z * (one - prt%z) * prt%momentum%p(0)**2
if (denom > eps0) then
costheta = one - prt%t / denom
else
costheta = - one
end if
end function parton_get_costheta
@ %def parton_get_costheta
@ The same for massive daughters.
<<Shower partons: parton: TBP>>=
procedure :: get_costheta_mass => parton_get_costheta_mass
<<Shower partons: procedures>>=
elemental function parton_get_costheta_mass (prt) result (costheta)
class(parton_t), intent(in) :: prt
real(default) :: costheta, sqrt12
if (prt%is_branched ()) then
if (prt%child1%simulated .and. &
prt%child2%simulated) then
sqrt12 = sqrt (max (zero, (prt%z)**2 * prt%momentum%p(0)**2 &
- prt%child1%t)) * &
sqrt (max (zero, (one - prt%z)**2 * prt%momentum%p(0)**2 &
- prt%child2%t))
if (sqrt12 > eps0) then
costheta = (prt%t - prt%child1%t - prt%child2%t - &
two * prt%z * (one - prt%z) * prt%momentum%p(0)**2) / &
(- two * sqrt12)
return
end if
end if
end if
costheta = prt%get_costheta ()
end function parton_get_costheta_mass
@ %def parton_get_costheta_mass
@ This function returns the angle between the momentum vectors of the
parton and first daughter. This is only used for debugging.
<<Shower partons: parton: TBP>>=
procedure :: get_costheta_motherfirst => parton_get_costheta_motherfirst
<<Shower partons: procedures>>=
elemental function parton_get_costheta_motherfirst (prt) result (costheta)
class(parton_t), intent(in) :: prt
real(default) :: costheta
if (prt%is_branched ()) then
if ((prt%child1%simulated .or. &
prt%child1%is_final () .or. &
prt%child1%is_branched ()) .and. &
(prt%child2%simulated .or. &
prt%child2%is_final () .or. &
prt%child2%is_branched ())) then
costheta = enclosed_angle_ct (prt%momentum, prt%child1%momentum)
return
end if
end if
costheta = - two
end function parton_get_costheta_motherfirst
@ %def parton_get_costheta_motherfirst
@ Get the parton velocities.
<<Shower partons: parton: TBP>>=
procedure :: get_beta => parton_get_beta
@
<<Shower partons: procedures>>=
pure function get_beta (t,E) result (beta)
real(default), intent(in) :: t,E
real(default) :: beta
beta = sqrt (max (tiny_07, one - t /(E**2)))
end function get_beta
elemental function parton_get_beta (prt) result (beta)
class(parton_t), intent(in) :: prt
real(default) :: beta
beta = sqrt (max (tiny_07, one - prt%t / prt%momentum%p(0)**2))
end function parton_get_beta
@ %def get_beta parton_get_beta
@ Write routine.
<<Shower partons: parton: TBP>>=
procedure :: write => parton_write
<<Shower partons: procedures>>=
subroutine parton_write (prt, unit)
class(parton_t), intent(in) :: prt
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,7A)") "Shower parton <nr>", TAB, "<type>", TAB // TAB, &
"<parent>", TAB, "<mom(0:3)>"
write (u, "(2x,I5,3A)", advance = "no") prt%nr, TAB, TAB, TAB
if (prt%is_final ()) then
write (u, "(1x,I5,1x,A)", advance = "no") prt%type, TAB // TAB
else
write (u, "('[',I5,']',A)", advance = "no") prt%type, TAB // TAB
end if
if (associated (prt%parent)) then
write (u, "(I5,A)", advance = "no") prt%parent%nr, TAB // TAB
else
write (u, "(5x,2A)", advance = "no") TAB, TAB
end if
write (u, "(4(ES12.5,A))") prt%momentum%p(0), TAB, &
prt%momentum%p(1), TAB, &
prt%momentum%p(2), TAB, &
prt%momentum%p(3)
write (u, "(1x,9A)") "<p4square>", TAB // TAB, "<t>", TAB // TAB, &
"<scale>", TAB // TAB, "<c1>", TAB, "<c2>", TAB, "<mass2>"
write (u, "(1x,3(ES12.5,A))", advance = "no") &
prt%momentum ** 2, TAB // TAB, prt%t, TAB, prt%scale, TAB, prt%mass2
write (u, "(2(I4,A))") prt%c1, TAB, prt%c2, TAB
if (prt%is_branched ()) then
if (prt%belongstoFSR) then
write (u, "(1x,9A)") "costheta(prt)", TAB, &
"costheta_correct(prt)", TAB, &
"prt%costheta", TAB, "prt%z", TAB, &
"costheta_motherfirst(prt)"
write (u, "(1X,5(ES12.5,A))") &
prt%get_costheta (), TAB, &
prt%get_costheta_mass (), TAB // TAB, &
prt%costheta, TAB, prt%z, TAB, &
prt%get_costheta_motherfirst (), TAB
else
write (u, "(1x,9A)") "prt%z", TAB, "prt%x", TAB, &
"costheta_correct(prt)", TAB, &
"prt%costheta", TAB, &
"costheta_motherfirst(prt)"
write (u, "(1X,5(ES12.5,A))") &
prt%z, TAB, prt%x, TAB, &
prt%get_costheta_mass (), TAB, &
prt%costheta, TAB, &
prt%get_costheta_motherfirst (), TAB
end if
else
if (prt%belongstoFSR) then
write (u, "(1X,A)") "not branched."
else
write (u, "(1X,A,ES12.5)") "not branched. x = ", prt%x
end if
end if
write (u, "(A)", advance = "no") " Parton"
if (prt%belongstoFSR) then
write (u, "(A)", advance = "no") " is FSR,"
else
if (associated (prt%initial)) then
write (u, "(A,I1)", advance = "no") " from hadron,", prt%initial%nr
else
write (u, "(A)", advance = "no") ""
end if
end if
if (prt%is_final ()) then
write (u, "(A)", advance = "no") " is final,"
else
write (u, "(A)", advance = "no") ""
end if
if (prt%simulated) then
write (u, "(A)", advance = "no") " is simulated,"
else
write (u, "(A)", advance = "no") ""
end if
if (associated (prt%child1) .and. associated (prt%child2)) then
write (u, "(A,2(I5),A)", advance = "no") &
" has children: ", prt%child1%nr, prt%child2%nr, ","
else if (associated (prt%child1)) then
write (u, "(A,1(I5),A)", advance = "no") &
" has one child: ", prt%child1%nr, ", "
end if
if (prt%belongstointeraction) then
write (u, "(A,I2)") " belongs to interaction ", &
prt%interactionnr
else
write (u, "(A,I2)") " does not belong to interaction ", &
prt%interactionnr
end if
write (u,"(A)") TAB
end subroutine parton_write
@ %def parton_write
@
<<Shower partons: parton: TBP>>=
procedure :: is_final => parton_is_final
<<Shower partons: procedures>>=
elemental function parton_is_final (prt) result (is_final)
class(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: parton: TBP>>=
procedure :: is_branched => parton_is_branched
<<Shower partons: procedures>>=
elemental function parton_is_branched (prt) result (is_branched)
class(parton_t), intent(in) :: prt
logical :: is_branched
is_branched = associated (prt%child1) .and. associated (prt%child2)
end function parton_is_branched
@ %def parton_is_branched
@
<<Shower partons: parton: TBP>>=
procedure :: set_simulated => parton_set_simulated
<<Shower partons: procedures>>=
pure subroutine parton_set_simulated (prt, sim)
class(parton_t), intent(inout) :: prt
logical, intent(in), optional :: sim
if (present (sim)) then
prt%simulated = sim
else
prt%simulated = .true.
end if
end subroutine parton_set_simulated
@ %def parton_set_simulated
@
<<Shower partons: public>>=
public :: parton_set_parent
<<Shower partons: procedures>>=
subroutine parton_set_parent (prt, parent)
type(parton_t), intent(inout) :: prt
type(parton_t), intent(in) , target :: parent
prt%parent => parent
end subroutine parton_set_parent
@ %def parton_set_parent
@
<<Shower partons: public>>=
public :: parton_get_parent
<<Shower partons: procedures>>=
function parton_get_parent (prt) result (parent)
type(parton_t), intent(in) :: prt
type(parton_t), pointer :: parent
parent => prt%parent
end function parton_get_parent
@ %def parton_get_parent
@
<<Shower partons: public>>=
public :: parton_set_initial
<<Shower partons: procedures>>=
subroutine parton_set_initial (prt, initial)
type(parton_t), intent(inout) :: prt
type(parton_t), intent(in) , target :: initial
prt%initial => initial
end subroutine parton_set_initial
@ %def parton_set_initial
@
<<Shower partons: public>>=
public :: parton_get_initial
<<Shower partons: procedures>>=
function parton_get_initial (prt) result (initial)
type(parton_t), intent(in) :: prt
type(parton_t), pointer :: initial
initial => prt%initial
end function parton_get_initial
@ %def parton_get_initial
@
<<Shower partons: public>>=
public :: parton_set_child
<<Shower partons: procedures>>=
subroutine parton_set_child (prt, child, i)
type(parton_t), intent(inout) :: prt
type(parton_t), intent(in), target :: child
integer, intent(in) :: i
if (i == 1) then
prt%child1 => child
else
prt%child2 => child
end if
end subroutine parton_set_child
@ %def parton_set_child
@
<<Shower partons: public>>=
public :: parton_get_child
<<Shower partons: procedures>>=
function parton_get_child (prt, i) result (child)
type(parton_t), pointer :: child
type(parton_t), intent(in) :: prt
integer, intent(in) :: i
child => null ()
if (i == 1) then
child => prt%child1
else
child => prt%child2
end if
end function parton_get_child
@ %def parton_get_child
@
<<Shower partons: parton: TBP>>=
procedure :: is_quark => parton_is_quark
<<Shower partons: procedures>>=
elemental function parton_is_quark (prt) result (is_quark)
class(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: parton: TBP>>=
procedure :: is_squark => parton_is_squark
<<Shower partons: procedures>>=
elemental function parton_is_squark (prt) result (is_squark)
class(parton_t), intent(in) ::prt
logical :: is_squark
is_squark = ((abs(prt%type) >= 1000001) .and. (abs(prt%type) <= 1000006)) &
.or. ((abs(prt%type) >= 2000001) .and. (abs(prt%type) <= 2000006))
end function parton_is_squark
@ %def parton_is_squark
@ 9 can be used for gluons in codes for glueballs
<<Shower partons: parton: TBP>>=
procedure :: is_gluon => parton_is_gluon
<<Shower partons: procedures>>=
elemental function parton_is_gluon (prt) result (is_gluon)
class(parton_t), intent(in) :: prt
logical :: is_gluon
is_gluon = prt%type == GLUON .or. prt%type == 9
end function parton_is_gluon
@ %def parton_is_gluon
@
<<Shower partons: parton: TBP>>=
procedure :: is_gluino => parton_is_gluino
<<Shower partons: procedures>>=
elemental function parton_is_gluino (prt) result (is_gluino)
class(parton_t), intent(in) :: prt
logical :: is_gluino
is_gluino = prt%type == 1000021
end function parton_is_gluino
@ %def parton_is_gluino
@
<<Shower partons: parton: TBP>>=
procedure :: is_proton => parton_is_proton
<<Shower partons: procedures>>=
elemental function parton_is_proton (prt) result (is_hadron)
class(parton_t), intent(in) :: prt
logical :: is_hadron
is_hadron = abs (prt%type) == PROTON
end function parton_is_proton
@ %def parton_is_proton
@ TODO: SUSY partons.
<<Shower partons: parton: TBP>>=
procedure :: is_colored => parton_is_colored
<<Shower partons: procedures>>=
pure function parton_is_colored (parton) result (is_colored)
logical :: is_colored
class(parton_t), intent(in) :: parton
is_colored = parton_is_quark (parton) .or. parton_is_gluon (parton)
end function parton_is_colored
@ %def parton_is_colored
@
<<Shower partons: parton: TBP>>=
procedure :: mass => parton_mass
<<Shower partons: procedures>>=
elemental function parton_mass (prt) result (mass)
class(parton_t), intent(in) :: prt
real(default) :: mass
mass = mass_type (prt%type, prt%mass2)
end function parton_mass
@ %def parton_mass
@
<<Shower partons: parton: TBP>>=
procedure :: mass_squared => parton_mass_squared
<<Shower partons: procedures>>=
elemental function parton_mass_squared (prt) result (mass_squared)
class(parton_t), intent(in) :: prt
real(default) :: mass_squared
mass_squared = mass_squared_type (prt%type, prt%mass2)
end function parton_mass_squared
@ %def parton_mass_squared
@
<<Shower partons: parton: TBP>>=
procedure :: momentum_to_pythia6 => parton_momentum_to_pythia6
<<Shower partons: procedures>>=
pure function parton_momentum_to_pythia6 (prt) result (p)
real(double), dimension(1:5) :: p
class(parton_t), intent(in) :: prt
real(default) :: mass
!!! gfortran 5.1 complains about 'ELEMENTAL procedure pointer
!!! component ‘mass’ is not allowed as an actual argument'
!!! p = prt%momentum%to_pythia6 (prt%mass ())
mass = prt%mass ()
p = prt%momentum%to_pythia6 (mass)
end function parton_momentum_to_pythia6
@ %def parton_momentum_to_pythia6
@
<<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 (prt%is_gluon ()) then
if (prt%child1%is_quark ()) then
retvalue = P_gqq (prt%z)
else if (prt%child1%is_gluon ()) then
retvalue = P_ggg (prt%z) + P_ggg (one - prt%z)
end if
else if (prt%is_quark ()) then
if (prt%child1%is_quark ()) then
retvalue = P_qqg (prt%z)
else if (prt%child1%is_gluon ()) then
retvalue = P_qqg (one - prt%z)
end if
end if
end function P_prt_to_child1
@ %def P_prt_to_child1
@ This function returns whether the kinematics of the branching of
parton [[prt]] into its daughters are allowed or not.
<<Shower partons: public>>=
public :: thetabar
<<Shower partons: procedures>>=
function thetabar (prt, recoiler, isr_ang, E3out) result (retvalue)
type(parton_t), intent(inout) :: prt
type(parton_t), intent(in) :: recoiler
real(default), intent(out), optional :: E3out
logical, intent(in) :: isr_ang
logical :: retvalue
real(default) :: ctheta, cthetachild1
real(default) p1, p4, p3, E3, shat
shat = (prt%child1%momentum + recoiler%momentum)**2
E3 = 0.5_default * (shat / prt%z -recoiler%t + prt%child1%t - &
prt%child2%mass_squared ()) / sqrt(shat)
if (present (E3out)) then
E3out = E3
end if
!!! absolute values of momenta in a 3 -> 1 + 4 branching
p3 = sqrt (E3**2 - prt%t)
p1 = sqrt (prt%child1%momentum%p(0)**2 - prt%child1%t)
p4 = sqrt (max (zero, (E3 - prt%child1%momentum%p(0))**2 &
- prt%child2%t))
if (p3 > zero) then
retvalue = ((p1 + p4 >= p3) .and. (p3 >= abs(p1 - p4)) )
if (retvalue .and. isr_ang) then
!!! check angular ordering
if (associated (prt%child1)) then
if (associated (prt%child1%child2)) then
ctheta = (E3**2 - p1**2 - p4**2 + prt%t) / (two * p1 * p4)
cthetachild1 = (prt%child1%momentum%p(0)**2 - &
space_part (prt%child1%child1%momentum)**2 &
- space_part (prt%child1%child2%momentum)**2 + prt%child1%t) &
/ (two * space_part (prt%child1%child1%momentum)**1 * &
space_part (prt%child1%child2%momentum)**1)
retvalue = (ctheta > cthetachild1)
end if
end if
end if
else
retvalue = .false.
end if
end function thetabar
@ %def thetabar
@
<<Shower partons: public>>=
public :: parton_apply_costheta
<<Shower partons: procedures>>=
recursive subroutine parton_apply_costheta (prt, rng)
type(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
if (debug2_active (D_SHOWER)) then
print *, "D: parton_apply_costheta for parton " , prt%nr
print *, 'prt%momentum%p = ', prt%momentum%p
call msg_debug2 (D_SHOWER, "prt%type", prt%type)
end if
prt%z = 0.5_default * (one + prt%get_beta () * prt%costheta)
if (associated (prt%child1) .and. associated (prt%child2)) then
if (prt%child1%simulated .and. prt%child2%simulated) then
prt%z = 0.5_default * (one + (prt%child1%t - prt%child2%t) / &
prt%t + prt%get_beta () * prt%costheta * &
sqrt((prt%t - prt%child1%t - prt%child2%t)**2 - &
4 * prt%child1%t * prt%child2%t) / prt%t)
if (prt%type /= INTERNAL) then
prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
end if
call prt%generate_ps (rng)
call parton_apply_costheta (prt%child1, rng)
call parton_apply_costheta (prt%child2, rng)
end if
end if
end subroutine parton_apply_costheta
@ %def parton_apply_costheta
@
<<Shower partons: public>>=
public :: parton_apply_lorentztrafo
<<Shower partons: procedures>>=
subroutine parton_apply_lorentztrafo (prt, L)
type(parton_t), intent(inout) :: prt
type(lorentz_transformation_t), intent(in) :: L
prt%momentum = L * prt%momentum
end subroutine parton_apply_lorentztrafo
@ %def parton_apply_lorentztrafo
@
<<Shower partons: public>>=
public :: parton_apply_lorentztrafo_recursive
<<Shower partons: procedures>>=
recursive subroutine parton_apply_lorentztrafo_recursive (prt, L)
type(parton_t), intent(inout) :: prt
type(lorentz_transformation_t) ,intent(in) :: L
if (prt%type /= PROTON .and. prt%type /= BEAM_REMNANT) then
!!! don't boost hadrons and beam-remnants
call parton_apply_lorentztrafo (prt, L)
end if
if (associated (prt%child1) .and. associated (prt%child2)) then
if ((space_part_norm (prt%child1%momentum) < eps0) .and. &
(space_part_norm (prt%child2%momentum) < eps0) .and. &
(.not. prt%child1%belongstointeraction) .and. &
(.not. prt%child2%belongstointeraction)) then
!!! don't boost unevolved timelike partons
else
call parton_apply_lorentztrafo_recursive (prt%child1, L)
call parton_apply_lorentztrafo_recursive (prt%child2, L)
end if
else
if (associated (prt%child1)) then
call parton_apply_lorentztrafo_recursive (prt%child1, L)
end if
if (associated (prt%child2)) then
call parton_apply_lorentztrafo_recursive (prt%child2, L)
end if
end if
end subroutine parton_apply_lorentztrafo_recursive
@ %def parton_apply_lorentztrafo_recursive
@ This takes the three-momentum of a parton and generates
three-momenta of its children given their energy and virtuality
<<Shower partons: parton: TBP>>=
procedure :: generate_ps => parton_generate_ps
<<Shower partons: procedures>>=
subroutine parton_generate_ps (prt, rng)
class(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
real(default), dimension(1:3, 1:3) :: directions
integer i,j
real(default) :: scproduct, pabs, p1abs, p2abs, x, ptabs, phi
real(default), dimension(1:3) :: momentum
type(vector3_t) :: pchild1_direction
type(lorentz_transformation_t) :: L, rotation
if (debug2_active (D_SHOWER)) print *, "D: parton_generate_ps for parton " , prt%nr
if (debug_active (D_SHOWER)) then
if (.not. (associated (prt%child1) .and. associated (prt%child2))) then
call msg_fatal ("no children for generate_ps")
end if
end if
!!! test if parton is a virtual parton from the imagined parton shower history
if (prt%type == INTERNAL) then
L = inverse (boost (prt%momentum, sqrt(prt%t)))
!!! boost to restframe of mother
call parton_apply_lorentztrafo (prt, L)
call parton_apply_lorentztrafo (prt%child1, L)
call parton_apply_lorentztrafo (prt%child2, L)
!!! Store child1's momenta
pchild1_direction = direction (space_part (prt%child1%momentum))
!!! Redistribute energy
prt%child1%momentum%p(0) = (prt%momentum%p(0)**2 - &
prt%child2%t + prt%child1%t) / (two * prt%momentum%p(0))
prt%child2%momentum%p(0) = prt%momentum%p(0) - &
prt%child1%momentum%p(0)
! rescale momenta and set momenta to be along z-axis
prt%child1%momentum = vector4_moving (prt%child1%momentum%p(0), &
vector3_canonical(3) * &
sqrt(prt%child1%momentum%p(0)**2 - prt%child1%t))
prt%child2%momentum = vector4_moving (prt%child2%momentum%p(0), &
- vector3_canonical(3) * &
sqrt(prt%child2%momentum%p(0)**2 - prt%child2%t))
!!! rotate so that total momentum is along former total momentum
rotation = rotation_to_2nd (space_part (prt%child1%momentum), &
pchild1_direction)
call parton_apply_lorentztrafo (prt%child1, rotation)
call parton_apply_lorentztrafo (prt%child2, rotation)
L = inverse (L) !!! inverse of the boost to restframe of mother
call parton_apply_lorentztrafo (prt, L)
call parton_apply_lorentztrafo (prt%child1, L)
call parton_apply_lorentztrafo (prt%child2, L)
else
!!! directions(1,:) -> direction of the parent parton
if (space_part_norm (prt%momentum) < eps0) return
directions(1,1:3) = prt%momentum%p(1:3) / space_part_norm (prt%momentum)
!!! directions(2,:) and directions(3,:) -> two random directions
!!! perpendicular to the direction of the parent parton
do j = 2, 3
call rng%generate (directions(j,:))
end do
do i = 2, 3
scproduct = zero
do j = 1, i - 1
scproduct = directions(i,1) * directions(j,1) + &
directions(i,2) * directions(j,2) + &
directions(i,3) * directions(j,3)
directions(i,1) = directions(i,1) - directions(j,1) * scproduct
directions(i,2) = directions(i,2) - directions(j,2) * scproduct
directions(i,3) = directions(i,3) - directions(j,3) * scproduct
end do
scproduct = directions(i,1)**2 + directions(i,2)**2 + &
directions(i,3)**2
do j = 1, 3
directions(i,j) = directions(i,j) / sqrt(scproduct)
end do
end do
<<Enforce right-handed system for [[directions]]>>
pabs = space_part_norm (prt%momentum)
if ((prt%child1%momentum%p(0)**2 - prt%child1%t < 0) .or. &
(prt%child2%momentum%p(0)**2 - prt%child2%t < 0)) then
call msg_debug(D_SHOWER, "generate_ps error at E^2 < t")
return
end if
p1abs = sqrt (prt%child1%momentum%p(0)**2 - prt%child1%t)
p2abs = sqrt (prt%child2%momentum%p(0)**2 - prt%child2%t)
x = (pabs**2 + p1abs**2 - p2abs**2) / (two * pabs)
if (pabs > p1abs + p2abs .or. &
pabs < abs(p1abs - p2abs)) then
if (debug_active (D_SHOWER)) then
print *, "D: parton_generate_ps Dreiecksungleichung error &
&for parton ", prt%nr, " ", &
space_part_norm (prt%momentum), " ", p1abs, " ", p2abs
call prt%write ()
call prt%child1%write ()
call prt%child2%write ()
end if
return
end if
!!! Due to numerical problems transverse momentum could be imaginary ->
!!! set transverse momentum to zero
ptabs = sqrt (max (p1abs * p1abs - x * x, zero))
call rng%generate (phi)
phi = twopi * phi
do i = 1, 3
momentum(i) = x * directions(1,i) + ptabs * &
(cos(phi) * directions(2,i) + sin(phi) * directions(3,i))
end do
prt%child1%momentum%p(1:3) = momentum(1:3)
do i = 1, 3
momentum(i) = (space_part_norm (prt%momentum) - x) * directions(1,i) - &
ptabs * (cos(phi) * directions(2,i) + sin(phi) * directions(3,i))
end do
prt%child2%momentum%p(1:3) = momentum(1:3)
end if
end subroutine parton_generate_ps
@ %def parton_generate_ps
@
<<Enforce right-handed system for [[directions]]>>=
if ((directions(1,1) * (directions(2,2) * directions(3,3) - &
directions(2,3) * directions(3,2)) + &
directions(1,2) * (directions(2,3) * directions(3,1) - &
directions(2,1) * directions(3,3)) + &
directions(1,3) * (directions(2,1) * directions(3,2) - &
directions(2,2) * directions(3,1))) < 0) then
directions(3,:) = - directions(3,:)
end if
@
This routine is similar to [[parton_generate_ps]], but now for the
ISR. It takes the three-momentum of a parton's first child as fixed and
generates the two remaining three-momenta.
<<Shower partons: parton: TBP>>=
procedure :: generate_ps_ini => parton_generate_ps_ini
<<Shower partons: procedures>>=
subroutine parton_generate_ps_ini (prt, rng)
class(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
real(default), dimension(1:3, 1:3) :: directions
integer :: i,j
real(default) :: scproduct, pabs, p1abs, p2abs, x, ptabs, phi
real(default), dimension(1:3) :: momentum
if (debug_active (D_SHOWER)) print *, "D: parton_generate_ps_ini: for parton " , prt%nr
if (debug_active (D_SHOWER)) then
if (.not. (associated (prt%child1) .and. associated (prt%child2))) then
call msg_fatal ("no children for generate_ps")
end if
end if
if (.not. prt%is_proton()) then
!!! generate ps for normal partons
do i = 1, 3
directions(1,i) = prt%child1%momentum%p(i) / &
space_part_norm(prt%child1%momentum)
end do
do j = 2, 3
call rng%generate (directions(j,:))
end do
do i = 2, 3
scproduct = zero
do j = 1, i - 1
scproduct = directions(i,1) * directions(j,1) + &
directions(i,2) * directions(j,2) + &
directions(i,3) * directions(j,3)
directions(i,1) = directions(i,1) - directions(j,1) * scproduct
directions(i,2) = directions(i,2) - directions(j,2) * scproduct
directions(i,3) = directions(i,3) - directions(j,3) * scproduct
end do
scproduct = directions(i,1)**2 + directions(i,2)**2 + &
directions(i,3)**2
do j = 1, 3
directions(i,j) = directions(i,j) / sqrt(scproduct)
end do
end do
<<Enforce right-handed system for [[directions]]>>
pabs = space_part_norm (prt%child1%momentum)
p1abs = sqrt (prt%momentum%p(0)**2 - prt%t)
p2abs = sqrt (max(zero, prt%child2%momentum%p(0)**2 - &
prt%child2%t))
x = (pabs**2 + p1abs**2 - p2abs**2) / (two * pabs)
if (debug_active (D_SHOWER)) then
if (pabs > p1abs + p2abs .or. pabs < abs(p1abs - p2abs)) then
print *, "error at generate_ps, Dreiecksungleichung for parton ", &
prt%nr, " ", pabs," ",p1abs," ",p2abs
call prt%write ()
call prt%child1%write ()
call prt%child2%write ()
call msg_fatal ("parton_generate_ps_ini: Dreiecksungleichung")
end if
end if
if (debug_active (D_SHOWER)) print *, "D: parton_generate_ps_ini: x = ", x
ptabs = sqrt (p1abs * p1abs - x**2)
call rng%generate (phi)
phi = twopi * phi
do i = 1,3
momentum(i) = x * directions(1,i) + ptabs * (cos(phi) * &
directions(2,i) + sin(phi) * directions(3,i))
end do
prt%momentum%p(1:3) = momentum
do i = 1, 3
momentum(i) = (x - pabs) * directions(1,i) + ptabs * (cos(phi) * &
directions(2,i) + sin(phi) * directions(3,i))
end do
prt%child2%momentum%p(1:3) = momentum(1:3)
else
!!! for first partons just set beam remnants momentum
prt%child2%momentum = prt%momentum - prt%child1%momentum
end if
end subroutine parton_generate_ps_ini
@ %def parton_generate_ps_ini
@
\subsection{The analytic FSR}
<<Shower partons: parton: TBP>>=
procedure :: next_t_ana => parton_next_t_ana
<<Shower partons: procedures>>=
subroutine parton_next_t_ana (prt, rng)
class(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
integer :: gtoqq
real(default) :: integral, random
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "next_t_ana")
! check if branchings are possible at all
if (min (prt%t, prt%momentum%p(0)**2) < &
prt%mass_squared () + prt%settings%min_virtuality) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
return
end if
integral = zero
call rng%generate (random)
do
call parton_simulate_stept (prt, rng, integral, random, gtoqq, .false.)
if (prt%simulated) then
if (prt%is_gluon ()) then
!!! Abusing the x-variable to store the information to which
!!! quark flavor the gluon branches (if any)
prt%x = one * gtoqq + 0.1_default
!!! x = gtoqq + 0.1 -> int(x) will be the quark flavor or
!!! zero for g -> gg
end if
exit
end if
end do
end subroutine parton_next_t_ana
@ %def parton_next_t_ana
@ The shower is actually sensitive to how close we go to the one here.
<<Shower partons: procedures>>=
function cmax (prt, tt) result (cmaxx)
type(parton_t), intent(in) :: prt
real(default), intent(in), optional :: tt
real(default) :: t, cost, cmaxx, radicand
t = prt%t; if (present (tt)) t = tt
if (associated (prt%parent)) then
cost = prt%parent%get_costheta ()
radicand = max(zero, one - &
t / (prt%get_beta () * prt%momentum%p(0))**2 * &
(one + cost) / (one - cost))
call msg_debug2 (D_SHOWER, "cmax: sqrt (radicand)", sqrt (radicand))
cmaxx = min (0.99999_default, sqrt (radicand))
else
cmaxx = 0.99999_default
end if
end function cmax
@ %def cmax
@ Simulation routine. The variable [[lookatsister]] takes constraints
from the sister parton into account, if not given it is assumed
[[.true.]]. [[a]] and [[x]] are three-dimensional arrays for values
used for the integration.
<<Shower partons: public>>=
public :: parton_simulate_stept
<<Shower partons: procedures>>=
subroutine parton_simulate_stept &
(prt, rng, integral, random, gtoqq, lookatsister)
type(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
real(default), intent(inout) :: integral
real(default), intent(inout) :: random
integer, intent(out) :: gtoqq
logical, intent(in), optional :: lookatsister
type(parton_t), pointer :: sister
real(default) :: tstep, tmin, oldt
real(default) :: c, cstep
real(default), dimension(3) :: z, P
real(default) :: to_integral
real(default) :: a11,a12,a13,a21,a22,a23
real(default) :: cmax_t
real(default) :: temprand
real(default), dimension(3) :: a, x
! higher values -> faster but coarser
real(default), parameter :: tstepfactor = 0.02_default
real(default), parameter :: tstepmin = 0.5_default
real(default), parameter :: cstepfactor = 0.8_default
real(default), parameter :: cstepmin = 0.03_default
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "parton_simulate_stept")
gtoqq = 111 ! illegal value
call prt%set_simulated (.false.)
<<Set [[sister]] if [[lookatsister]] is true or not given>>
tmin = prt%settings%min_virtuality + prt%mass_squared ()
if (prt%is_quark ()) then
to_integral = three *pi * log(one / random)
else if (prt%is_gluon ()) then
to_integral = four *pi * log(one / random)
else
prt%t = prt%mass_squared ()
call prt%set_simulated ()
return
end if
if (associated (sister)) then
if (sqrt(prt%t) > sqrt(prt%parent%t) - &
sqrt(sister%mass_squared ())) then
prt%t = (sqrt (prt%parent%t) - sqrt (sister%mass_squared ()))**2
end if
end if
if (prt%t > prt%momentum%p(0)**2) then
prt%t = prt%momentum%p(0)**2
end if
if (prt%t <= tmin) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
return
end if
! simulate the branchings between prt%t and prt%t - tstep
tstep = max(tstepfactor * (prt%t - 0.9_default * tmin), tstepmin)
cmax_t = cmax(prt)
c = - cmax_t ! take highest t -> minimal constraint
cstep = max(cstepfactor * (one - abs(c)), cstepmin)
! get values at border of "previous" bin -> to be used in first bin
z(3) = 0.5_default + 0.5_default * get_beta (prt%t - &
0.5_default * tstep, prt%momentum%p(0)) * c
if (prt%is_gluon ()) then
P(3) = P_ggg (z(3)) + P_gqq (z(3)) * number_of_flavors &
(prt%t, prt%settings%max_n_flavors, prt%settings%min_virtuality)
else
P(3) = P_qqg (z(3))
end if
a(3) = D_alpha_s_fsr (z(3) * (one - z(3)) * prt%t, &
prt%settings) * P(3) / (prt%t - 0.5_default * tstep)
do while (c < cmax_t .and. (integral < to_integral))
if (signal_is_pending ()) return
cmax_t = cmax (prt)
cstep = max (cstepfactor * (one - abs(c)**2), cstepmin)
if (c + cstep > cmax_t) then
cstep = cmax_t - c
end if
if (cstep < 1E-9_default) then
!!! reject too small bins
exit
end if
z(1) = z(3)
z(2) = 0.5_default + 0.5_default * get_beta &
(prt%t - 0.5_default * tstep, prt%momentum%p(0)) * &
(c + 0.5_default * cstep)
z(3) = 0.5_default + 0.5_default * get_beta &
(prt%t - 0.5_default * tstep, prt%momentum%p(0)) * (c + cstep)
P(1) = P(3)
if (prt%is_gluon ()) then
P(2) = P_ggg(z(2)) + P_gqq(z(2)) * number_of_flavors &
(prt%t, prt%settings%max_n_flavors, prt%settings%min_virtuality)
P(3) = P_ggg(z(3)) + P_gqq(z(3)) * number_of_flavors &
(prt%t, prt%settings%max_n_flavors, prt%settings%min_virtuality)
else
P(2) = P_qqg(z(2))
P(3) = P_qqg(z(3))
end if
! get values at borders of the intgral and in the middle
a(1) = a(3)
a(2) = D_alpha_s_fsr (z(2) * (one - z(2)) * prt%t, &
prt%settings) * P(2) / &
(prt%t - 0.5_default * tstep)
a(3) = D_alpha_s_fsr (z(3) * (one - z(3)) * prt%t, &
prt%settings) * P(3) / &
(prt%t - 0.5_default * tstep)
!!! a little tricky:
!!! fit x(1) + x(2)/(1 + c) + x(3)/(1 - c) to these values
a11 = (one+c+0.5_default*cstep) * (one-c-0.5_default*cstep) - &
(one-c) * (one+c+0.5_default*cstep)
a12 = (one-c-0.5_default*cstep) - (one+c+0.5_default*cstep) * &
(one-c) / (one+c)
a13 = a(2) * (one+c+0.5_default*cstep) * (one-c-0.5_default*cstep) - &
a(1) * (one-c) * (one+c+0.5_default*cstep)
a21 = (one+c+cstep) * (one-c-cstep) - (one+c+cstep) * (one-c)
a22 = (one-c-cstep) - (one+c+cstep) * (one-c) / (one+c)
a23 = a(3) * (one+c+cstep) * (one-c-cstep) - &
a(1) * (one-c) * (one+c+cstep)
x(2) = (a23 - a21 * a13 / a11) / (a22 - a12 * a21 / a11)
x(1) = (a13 - a12 * x(2)) / a11
x(3) = a(1) * (one - c) - x(1) * (one - c) - x(2) * (one - c) / (one + c)
integral = integral + tstep * (x(1) * cstep + x(2) * &
log((one + c + cstep) / (one + c)) - x(3) * &
log((one - c - cstep) / (one - c)))
if (integral > to_integral) then
oldt = prt%t
call rng%generate (temprand)
prt%t = prt%t - temprand * tstep
call rng%generate (temprand)
prt%costheta = c + (0.5_default - temprand) * cstep
call prt%set_simulated ()
if (prt%t < prt%settings%min_virtuality + prt%mass_squared ()) then
prt%t = prt%mass_squared ()
end if
if (abs(prt%costheta) > cmax_t) then
! reject branching due to violation of costheta-limits
call rng%generate (random)
if (prt%is_quark ()) then
to_integral = three * pi * log(one / random)
else if (prt%is_gluon ()) then
to_integral = four * pi * log(one / random)
end if
integral = zero
prt%t = oldt
call prt%set_simulated (.false.)
end if
if (prt%is_gluon ()) then
! decide between g->gg and g->qqbar splitting
z(1) = 0.5_default + 0.5_default * prt%costheta
call rng%generate (temprand)
if (P_ggg(z(1)) > temprand * (P_ggg (z(1)) + P_gqq (z(1)) * &
number_of_flavors(prt%t, prt%settings%max_n_flavors, &
prt%settings%min_virtuality))) then
gtoqq = 0
else
call rng%generate (temprand)
gtoqq = 1 + int (temprand * number_of_flavors &
(prt%t, prt%settings%max_n_flavors, &
prt%settings%min_virtuality))
end if
end if
else
c = c + cstep
end if
cmax_t = cmax (prt)
end do
if (integral <= to_integral) then
prt%t = prt%t - tstep
if (prt%t < prt%settings%min_virtuality + prt%mass_squared ()) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
end if
end if
end subroutine parton_simulate_stept
@ %def parton_simulate_stept
@
<<Set [[sister]] if [[lookatsister]] is true or not given>>=
sister => null()
SET_SISTER: do
if (present (lookatsister)) then
if (.not. lookatsister) then
exit SET_SISTER
end if
end if
if (prt%nr == prt%parent%child1%nr) then
sister => prt%parent%child2
else
sister => prt%parent%child1
end if
exit SET_SISTER
end do SET_SISTER
@
@ From the whole ISR algorithm all functionality has been moved to
[[shower_core.f90]]. Only [[maxzz]] remains here, because more than
one module needs to access it.
<<Shower partons: public>>=
public :: maxzz
<<Shower partons: procedures>>=
function maxzz (shat, s, maxz_isr, minenergy_timelike) result (maxz)
real(default), intent(in) :: shat, s, minenergy_timelike, maxz_isr
real(default) :: maxz
maxz = min (maxz_isr, one - (two * minenergy_timelike * sqrt(shat)) / s)
end function maxzz
@ %def maxzz
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Main shower module}
<<[[shower_core.f90]]>>=
<<File header>>
module shower_core
<<Use kinds with double>>
<<Use strings>>
use io_units
use constants
use format_utils, only: write_separator
use numeric_utils
use system_defs, only: TAB
use diagnostics
use physics_defs
use os_interface
use lorentz
use sm_physics
use particles
use model_data
use flavors
use colors
use subevents
use pdf
use rng_base
use shower_base
use shower_partons
use muli, only: muli_t
use hep_common
use tauola_interface
<<Standard module head>>
<<Shower core: public>>
<<Shower core: parameters>>
<<Shower core: types>>
<<Shower core: interfaces>>
contains
<<Shower core: procedures>>
end module shower_core
@ %def shower_core
@
<<Shower core: interfaces>>=
interface
subroutine evolvePDFM (set, x, q, ff)
integer, intent(in) :: set
double precision, intent(in) :: x, q
double precision, dimension(-6:6), intent(out) :: ff
end subroutine evolvePDFM
end interface
@ %def evolvePDFM
@
<<Shower core: public>>=
public :: shower_interaction_t
<<Shower core: types>>=
type :: shower_interaction_t
type(parton_pointer_t), dimension(:), allocatable :: partons
end type shower_interaction_t
type :: shower_interaction_pointer_t
type(shower_interaction_t), pointer :: i => null ()
end type shower_interaction_pointer_t
@ %def shower_interaction_t
@ %def shower_interaction_pointer_t
@ The WHIZARD internal shower. Flags distinguish between analytic and
$k_T$-ordered showers.
<<Shower core: public>>=
public :: shower_t
<<Shower core: types>>=
type, extends (shower_base_t) :: shower_t
type(shower_interaction_pointer_t), dimension(:), allocatable :: &
interactions
type(parton_pointer_t), dimension(:), allocatable :: partons
type(muli_t) :: mi
integer :: next_free_nr
integer :: next_color_nr
logical :: valid
contains
<<Shower core: shower: TBP>>
end type shower_t
@ %def shower_t
@
<<Shower core: shower: TBP>>=
procedure :: init => shower_init
<<Shower core: procedures>>=
subroutine shower_init (shower, settings, taudec_settings, pdf_data)
class(shower_t), intent(out) :: shower
type(shower_settings_t), intent(in) :: settings
type(taudec_settings_t), intent(in) :: taudec_settings
type(pdf_data_t), intent(in) :: pdf_data
call msg_debug (D_SHOWER, "shower_init")
shower%settings = settings
shower%taudec_settings = taudec_settings
call shower%pdf_data%init (pdf_data)
shower%name = "WHIZARD internal"
call shower%write_msg ()
end subroutine shower_init
@ %def shower_init
@
<<Shower core: shower: TBP>>=
procedure :: prepare_new_event => shower_prepare_new_event
<<Shower core: procedures>>=
subroutine shower_prepare_new_event (shower)
class(shower_t), intent(inout) :: shower
call shower%cleanup ()
shower%next_free_nr = 1
shower%next_color_nr = 1
if (debug_active (D_SHOWER)) then
if (allocated (shower%interactions)) then
call msg_bug ("Shower: creating new shower while old one " // &
"is still associated (interactions)")
end if
if (allocated (shower%partons)) then
call msg_bug ("Shower: creating new shower while old one " // &
"is still associated (partons)")
end if
end if
treat_light_quarks_massless = .true.
treat_duscb_quarks_massless = .false.
shower%valid = .true.
end subroutine shower_prepare_new_event
@ %def shower_prepare_new_event
@ It would be better to have the muli type outside of the shower.
<<Shower core: shower: TBP>>=
procedure :: activate_multiple_interactions => shower_activate_multiple_interactions
<<Shower core: procedures>>=
subroutine shower_activate_multiple_interactions (shower, os_data)
class(shower_t), intent(inout) :: shower
type(os_data_t), intent(in) :: os_data
if (shower%mi%is_initialized ()) then
call shower%mi%restart ()
else
call shower%mi%initialize (&
GeV2_scale_cutoff=shower%settings%min_virtuality, &
GeV2_s=shower_interaction_get_s &
(shower%interactions(1)%i), &
muli_dir=char(os_data%whizard_mulipath))
end if
call shower%mi%apply_initial_interaction ( &
GeV2_s=shower_interaction_get_s(shower%interactions(1)%i), &
x1=shower%interactions(1)%i%partons(1)%p%parent%x, &
x2=shower%interactions(1)%i%partons(2)%p%parent%x, &
pdg_f1=shower%interactions(1)%i%partons(1)%p%parent%type, &
pdg_f2=shower%interactions(1)%i%partons(2)%p%parent%type, &
n1=shower%interactions(1)%i%partons(1)%p%parent%nr, &
n2=shower%interactions(1)%i%partons(2)%p%parent%nr)
end subroutine shower_activate_multiple_interactions
@ %def shower_activate_multiple_interactions
@
@
<<Shower core: shower: TBP>>=
procedure :: import_particle_set => shower_import_particle_set
<<Shower core: procedures>>=
subroutine shower_import_particle_set (shower, particle_set, os_data)
class(shower_t), target, intent(inout) :: shower
type(particle_set_t), intent(in) :: particle_set
type(os_data_t), intent(in) :: os_data
!integer, dimension(:), allocatable :: connections
type(parton_t), dimension(:), allocatable, target, save :: partons, hadrons
type(parton_pointer_t), dimension(:), allocatable :: &
parton_pointers
integer :: n_beam, n_in, n_out, n_tot
integer :: i, j, nr, max_color_nr
call msg_debug (D_SHOWER, 'shower_import_particle_set')
call count_and_allocate ()
call setup_hadrons_from_particle_set ()
call setup_partons_from_particle_set ()
call shower%update_max_color_nr (1 + max_color_nr)
call shower%add_interaction_2ton (parton_pointers)
if (shower%settings%muli_active) then
call shower%activate_multiple_interactions (os_data)
end if
call msg_debug2 (D_SHOWER, 'shower%write() after shower_import_particle_set')
if (debug2_active (D_SHOWER)) then
call shower%write ()
end if
contains
<<Shower core: shower import particle set: procedures>>
end subroutine shower_import_particle_set
@ %def shower_import_particle_set
<<Shower core: shower import particle set: procedures>>=
subroutine count_and_allocate ()
max_color_nr = 0
n_beam = particle_set%get_n_beam ()
n_in = particle_set%get_n_in ()
n_out = particle_set%get_n_out ()
n_tot = particle_set%get_n_tot ()
if (allocated (partons)) deallocate (partons)
allocate (partons (n_in + n_out))
allocate (parton_pointers (n_in+n_out))
end subroutine count_and_allocate
@
<<Shower core: shower import particle set: procedures>>=
subroutine setup_hadrons_from_particle_set ()
j = 0
!!! !!! !!! Workaround for Portland 16.1 compiler bug
!!! if (n_beam > 0 .and. all (particle_set%prt(1:2)%flv%get_pdg_abs () > TAU)) then
if (n_beam > 0 .and. particle_set%prt(1)%flv%get_pdg_abs () > TAU .and. &
particle_set%prt(2)%flv%get_pdg_abs () > TAU) then
call msg_debug (D_SHOWER, 'Copy hadrons from particle_set to hadrons')
if (.not. allocated (hadrons)) allocate (hadrons (1:2))
do i = 1, n_tot
if (particle_set%prt(i)%status == PRT_BEAM) then
j = j + 1
nr = shower%get_next_free_nr ()
hadrons(j) = parton_of_particle (particle_set%prt(i), nr)
hadrons(j)%settings => shower%settings
max_color_nr = max (max_color_nr, abs(hadrons(j)%c1), &
abs(hadrons(j)%c2))
end if
end do
end if
end subroutine setup_hadrons_from_particle_set
@
<<Shower core: shower import particle set: procedures>>=
subroutine setup_partons_from_particle_set ()
integer, dimension(1) :: parent
j = 0
call msg_debug (D_SHOWER, "Copy partons from particle_set to partons")
do i = 1, n_tot
if (particle_set%prt(i)%get_status () == PRT_INCOMING .or. &
particle_set%prt(i)%get_status () == PRT_OUTGOING) then
j = j + 1
nr = shower%get_next_free_nr ()
partons(j) = parton_of_particle (particle_set%prt(i), nr)
partons(j)%settings => shower%settings
parton_pointers(j)%p => partons(j)
max_color_nr = max (max_color_nr, abs (partons(j)%c1), &
abs (partons(j)%c2))
if (particle_set%prt(i)%get_status () == PRT_INCOMING .and. &
particle_set%prt(i)%get_n_parents () == 1 .and. &
allocated (hadrons)) then
parent = particle_set%prt(i)%get_parents ()
partons(j)%initial => hadrons (parent(1))
partons(j)%x = space_part_norm (partons(j)%momentum) / &
space_part_norm (partons(j)%initial%momentum)
end if
end if
end do
end subroutine setup_partons_from_particle_set
@
<<Shower core: shower: TBP>>=
procedure :: generate_emissions => shower_generate_emissions
<<Shower core: procedures>>=
subroutine shower_generate_emissions &
(shower, valid, number_of_emissions)
class(shower_t), intent(inout), target :: shower
logical, intent(out) :: valid
integer, optional, intent(in) :: number_of_emissions
type(parton_t), dimension(:), allocatable, target :: partons
type(parton_pointer_t), dimension(:), allocatable :: &
parton_pointers
real(default) :: mi_scale, ps_scale, shat, phi
type(parton_pointer_t) :: temppp
integer :: i, j, k
integer :: n_int, max_color_nr
integer, dimension(2,4) :: color_corr
call msg_debug (D_SHOWER, "shower_generate_emissions")
if (shower%settings%isr_active) then
call msg_debug (D_SHOWER, "Generate ISR with FSR")
i = 0
BRANCHINGS: do
i = i+1
if (signal_is_pending ()) return
if (shower%settings%muli_active) then
call shower%mi%generate_gev2_pt2 &
(shower%get_ISR_scale (), mi_scale)
else
mi_scale = 0.0
end if
!!! Shower: debugging
!!! shower%generate_next_isr_branching returns a pointer to
!!! the parton with the next ISR-branching, this parton's
!!! scale is the scale of the next branching
! temppp=shower%generate_next_isr_branching_veto ()
temppp = shower%generate_next_isr_branching ()
if (.not. associated (temppp%p) .and. &
mi_scale < shower%settings%min_virtuality) then
exit BRANCHINGS
end if
!!! check if branching or interaction occurs next
if (associated (temppp%p)) then
ps_scale = abs(temppp%p%t)
else
ps_scale = 0._default
end if
if (mi_scale > ps_scale) then
!!! discard branching evolution lower than mi_scale
call shower%set_max_ISR_scale (mi_scale)
if (associated (temppp%p)) &
call temppp%p%set_simulated (.false.)
!!! execute new interaction
deallocate (partons)
deallocate (parton_pointers)
allocate (partons(1:4))
allocate (parton_pointers(1:4))
do j = 1, 4
partons(j)%nr = shower%get_next_free_nr ()
partons(j)%belongstointeraction = .true.
parton_pointers(j)%p => partons(j)
end do
call shower%mi%generate_partons (partons(1)%nr, partons(2)%nr, &
partons(1)%x, partons(2)%x, &
partons(1)%type, partons(2)%type, &
partons(3)%type, partons(4)%type)
!!! calculate momenta
shat = partons(1)%x *partons(2)%x * &
shower_interaction_get_s (shower%interactions(1)%i)
partons(1)%momentum = [0.5_default * sqrt(shat), &
zero, zero, 0.5_default*sqrt(shat)]
partons(2)%momentum = [0.5_default * sqrt(shat), &
zero, zero, -0.5_default*sqrt(shat)]
call parton_set_initial (partons(1), &
shower%interactions(1)%i%partons(1)%p%initial)
call parton_set_initial (partons(2), &
shower%interactions(1)%i%partons(2)%p%initial)
partons(1)%belongstoFSR = .false.
partons(2)%belongstoFSR = .false.
!!! calculate color connection
call shower%mi%get_color_correlations &
(shower%get_next_color_nr (), &
max_color_nr,color_corr)
call shower%update_max_color_nr (max_color_nr)
partons(1)%c1 = color_corr(1,1)
partons(1)%c2 = color_corr(2,1)
partons(2)%c1 = color_corr(1,2)
partons(2)%c2 = color_corr(2,2)
partons(3)%c1 = color_corr(1,3)
partons(3)%c2 = color_corr(2,3)
partons(4)%c1 = color_corr(1,4)
partons(4)%c2 = color_corr(2,4)
call shower%rng%generate (phi)
phi = 2 * pi * phi
partons(3)%momentum = [0.5_default*sqrt(shat), &
sqrt(mi_scale)*cos(phi), &
sqrt(mi_scale)*sin(phi), &
sqrt(0.25_default*shat - mi_scale)]
partons(4)%momentum = [ 0.5_default*sqrt(shat), &
-sqrt(mi_scale)*cos(phi), &
-sqrt(mi_scale)*sin(phi), &
-sqrt(0.25_default*shat - mi_scale)]
partons(3)%belongstoFSR = .true.
partons(4)%belongstoFSR = .true.
call shower%add_interaction_2ton (parton_pointers)
n_int = size (shower%interactions)
do k = 1, 2
call shower%mi%replace_parton &
(shower%interactions(n_int)%i%partons(k)%p%initial%nr, &
shower%interactions(n_int)%i%partons(k)%p%nr, &
shower%interactions(n_int)%i%partons(k)%p%parent%nr, &
shower%interactions(n_int)%i%partons(k)%p%type, &
shower%interactions(n_int)%i%partons(k)%p%x, &
mi_scale)
end do
else
!!! execute the next branching 'found' in the previous step
call shower%execute_next_isr_branching (temppp)
if (shower%settings%muli_active) then
call shower%mi%replace_parton (temppp%p%initial%nr, &
temppp%p%child1%nr, temppp%p%nr, &
temppp%p%type, temppp%p%x, ps_scale)
end if
end if
end do BRANCHINGS
call shower%generate_fsr_for_isr_partons ()
else
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "Generate FSR without ISR")
call shower%simulate_no_isr_shower ()
end if
!!! some bookkeeping, needed after the shower is done
call shower%boost_to_labframe ()
call shower%generate_primordial_kt ()
call shower%update_beamremnants ()
if (shower%settings%fsr_active) then
do i = 1, size (shower%interactions)
if (signal_is_pending ()) return
call shower%interaction_generate_fsr_2ton &
(shower%interactions(i)%i)
end do
else
call shower%simulate_no_fsr_shower ()
end if
call msg_debug (D_SHOWER, "Shower finished:")
if (debug_active (D_SHOWER)) call shower%write ()
valid = shower%valid
!!! clean-up muli: we should finalize the muli pdf sets
!!! when _all_ runs are done. Not after every event if possible
! call shower%mi%finalize()
end subroutine shower_generate_emissions
@ %def shower_generate_emissions
@
<<Shower core: shower: TBP>>=
procedure :: make_particle_set => shower_make_particle_set
<<Shower core: procedures>>=
subroutine shower_make_particle_set &
(shower, particle_set, model, model_hadrons)
class(shower_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model
class(model_data_t), intent(in), target :: model_hadrons
call shower%combine_with_particle_set (particle_set, model, &
model_hadrons)
if (shower%settings%hadronization_active) then
call shower%converttopythia ()
end if
end subroutine shower_make_particle_set
@ %def shower_make_particle_set
@ The parameters of the shower module:
<<Shower core: parameters>>=
real(default), save :: alphasxpdfmax = 12._default
@ %def alphasxpdfmax
@
@ In this routine, [[y]] and [[ymin]] are the jet measures, [[w]] and
[[wmax]] are weights, [[s]] is the kinematic energy squared of the
interaction. The flag [[isr_is_possible_and_allowed]] checks whether the initial
parton is set, lepton-hadron collisions are not implemented (yet).
% TODO: (bcn 2015-04-23) I dont understand the workaround
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 => 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), intent(in) :: ckkw_pseudo_weights
integer :: n_partons, n_out
integer :: i, j, imin, jmin
real(default) :: y, ymin
!real(default) :: w, wmax
!real(default) :: random, sum
type(parton_pointer_t), dimension(:), allocatable :: new_partons
type(parton_t), pointer :: prt
integer :: n_int
type(shower_interaction_pointer_t), dimension(:), allocatable :: temp
type(vector4_t) :: prtmomentum, childmomentum
logical :: isr_is_possible_and_allowed
type(lorentz_transformation_t) :: L
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "Add interaction2toN")
n_partons = size (partons)
n_out = n_partons - 2
if (n_out < 2) then
call msg_bug &
("Shower core: trying to add a 2-> (something<2) interaction")
end if
isr_is_possible_and_allowed = (associated (partons(1)%p%initial) &
.and. associated (partons(2)%p%initial)) .and. &
shower%settings%isr_active
call msg_debug (D_SHOWER, "isr_is_possible_and_allowed", &
isr_is_possible_and_allowed)
if (associated (partons(1)%p%initial) .and. &
partons(1)%p%is_quark ()) then
if (partons(1)%p%momentum%p(0) < &
two * partons(1)%p%mass()) 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. &
partons(2)%p%is_quark ()) then
if (partons(2)%p%momentum%p(0) < &
two * partons(2)%p%mass()) then
if (abs(partons(2)%p%type) < 2) then
treat_light_quarks_massless = .true.
else
treat_duscb_quarks_massless = .true.
end if
end if
end if
<<Add a new interaction to [[shower%interactions]]>>
if (associated (shower%interactions(n_int)%i%partons(1)%p%initial)) &
call shower%interactions(n_int)%i%partons(1)%p%initial%set_simulated ()
if (associated (shower%interactions(n_int)%i%partons(2)%p%initial)) &
call shower%interactions(n_int)%i%partons(2)%p%initial%set_simulated ()
if (isr_is_possible_and_allowed) then
!!! boost to the CMFrame of the incoming partons
L = boost (-(shower%interactions(n_int)%i%partons(1)%p%momentum + &
shower%interactions(n_int)%i%partons(2)%p%momentum), &
(shower%interactions(n_int)%i%partons(1)%p%momentum + &
shower%interactions(n_int)%i%partons(2)%p%momentum)**1 )
do i = 1, n_partons
call parton_apply_lorentztrafo &
(shower%interactions(n_int)%i%partons(i)%p, L)
end do
end if
do i = 1, size (partons)
if (signal_is_pending ()) return
!!! partons are marked as belonging to the hard interaction
shower%interactions(n_int)%i%partons(i)%p%belongstointeraction &
= .true.
shower%interactions(n_int)%i%partons(i)%p%belongstoFSR = i > 2
shower%interactions(n_int)%i%partons(i)%p%interactionnr = n_int
!!! include a 2^(i - 1) number as a label for the ckkw clustering
shower%interactions(n_int)%i%partons(i)%p%ckkwlabel = 2**(i - 1)
end do
<<Add partons from [[shower%interactions]] to [[shower%partons]]>>
if (isr_is_possible_and_allowed) then
if (shower%settings%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
! TODO: (bcn 2015-04-24) make this a clustering step of the matching
! if (allocated (ckkw_pseudo_weights%weights)) then
! !<Perform clustering using the CKKW weights>>
! else
<<Perform clustering in the usual way>>
! end if
!!! set the FSR starting scale for all partons
do i = 1, size (new_partons)
!!! the imaginary mother is the only parton remaining in new_partons
if (.not. associated (new_partons(i)%p)) cycle
call set_starting_scale (new_partons(i)%p, &
get_starting_scale (new_partons(i)%p))
exit
end do
contains
<<Procedures of [[shower_add_interaction_2ton]]>>
end subroutine shower_add_interaction_2ton
@ %def shower_add_interaction_2ton
@
<<Add a new interaction to [[shower%interactions]]>>=
if (allocated (shower%interactions)) then
n_int = size (shower%interactions) + 1
else
n_int = 1
end if
allocate (temp (1:n_int))
do i = 1, n_int - 1
allocate (temp(i)%i)
temp(i)%i = shower%interactions(i)%i
end do
allocate (temp(n_int)%i)
allocate (temp(n_int)%i%partons(1:n_partons))
do i = 1, n_partons
allocate (temp(n_int)%i%partons(i)%p)
call parton_copy (partons(i)%p, temp(n_int)%i%partons(i)%p)
end do
if (allocated (shower%interactions)) deallocate(shower%interactions)
allocate (shower%interactions(1:n_int))
do i = 1, n_int
shower%interactions(i)%i => temp(i)%i
end do
deallocate (temp)
@
<<Add partons from [[shower%interactions]] to [[shower%partons]]>>=
if (allocated (shower%partons)) then
allocate (new_partons(1:size(shower%partons) + &
size(shower%interactions(n_int)%i%partons)))
do i = 1, size (shower%partons)
new_partons(i)%p => shower%partons(i)%p
end do
do i = 1, size (shower%interactions(n_int)%i%partons)
new_partons(size(shower%partons) + i)%p => &
shower%interactions(n_int)%i%partons(i)%p
end do
deallocate (shower%partons)
else
allocate (new_partons(1:size(shower%interactions(n_int)%i%partons)))
do i = 1, size (partons)
new_partons(i)%p => shower%interactions(n_int)%i%partons(i)%p
end do
end if
allocate (shower%partons(1:size (new_partons)))
do i = 1, size (new_partons)
shower%partons(i)%p => new_partons(i)%p
end do
deallocate (new_partons)
@
<<Perform clustering using the CKKW weights>>=
CKKW_CLUSTERING: do
!!! search for the combination with the highest weight
wmax = zero
CKKW_OUTER: do i = 1, size (new_partons)
CKKW_INNER: do j = i + 1, size (new_partons)
if (.not. associated (new_partons(i)%p)) cycle
if (.not. associated (new_partons(j)%p)) cycle
w = ckkw_pseudo_weights%weights(new_partons(i)%p%ckkwlabel + &
new_partons(j)%p%ckkwlabel)
if (w > wmax .or. vanishes(wmax)) then
wmax = w
imin = i
jmin = j
end if
end do CKKW_INNER
end do CKKW_OUTER
if (wmax > zero) then
call shower%add_parent (new_partons(imin)%p)
call parton_set_child (new_partons(imin)%p%parent, &
new_partons(jmin)%p, 2)
call parton_set_parent (new_partons(jmin)%p, &
new_partons(imin)%p%parent)
prt => new_partons(imin)%p%parent
prt%nr = shower_get_next_free_nr (shower)
prt%type = INTERNAL
prt%momentum = new_partons(imin)%p%momentum + &
new_partons(jmin)%p%momentum
prt%t = prt%momentum**2
!!! auxilliary values for the ckkw matching
!!! for now, randomly choose the type of the intermediate
prt%ckkwlabel = new_partons(imin)%p%ckkwlabel + &
new_partons(jmin)%p%ckkwlabel
sum = zero
call shower%rng%generate (random)
CKKW_TYPE: do i = 0, 4
if (sum + &
ckkw_pseudo_weights%weights_by_type(prt%ckkwlabel, i) > &
random * ckkw_pseudo_weights%weights(prt%ckkwlabel) ) then
prt%ckkwtype = i
exit ckkw_type
end if
sum = sum + &
ckkw_pseudo_weights%weights_by_type(prt%ckkwlabel, i)
end do CKKW_TYPE
!!! TODO -> calculate costheta and store it for
!!! later use in generate_ps
if (space_part_norm(prt%momentum) > tiny_10) then
prtmomentum = prt%momentum
childmomentum = prt%child1%momentum
prtmomentum = boost (- prt%get_beta() / &
sqrt (one - &
(prt%get_beta ())**2), space_part (prt%momentum) / &
space_part_norm(prt%momentum)) * prtmomentum
childmomentum = boost (- prt%get_beta () / &
sqrt(one - &
(prt%get_beta ())**2), space_part (prt%momentum) / &
space_part_norm(prt%momentum)) * childmomentum
prt%costheta = enclosed_angle_ct(prtmomentum, childmomentum)
else
prt%costheta = - one
end if
prt%belongstointeraction = .true.
prt%belongstoFSR = &
new_partons(imin)%p%belongstoFSR .and. &
new_partons(jmin)%p%belongstoFSR
nullify (new_partons(imin)%p)
nullify (new_partons(jmin)%p)
new_partons(imin)%p => prt
else
exit CKKW_CLUSTERING
end if
end do CKKW_CLUSTERING
@
<<Perform clustering in the usual way>>=
CLUSTERING: do
!!! search for the partons to be clustered together
ymin = zero
OUTER: do i = 1, size (new_partons)
INNER: do j = i + 1, size (new_partons)
!!! calculate the jet measure
if (.not.associated (new_partons(i)%p)) cycle INNER
if (.not.associated (new_partons(j)%p)) cycle INNER
!if (.not. shower_clustering_allowed &
!(shower, new_partons, i,j)) &
!cycle inner
!!! Durham jet-measure ! don't care about constants
y = min (new_partons(i)%p%momentum%p(0), &
new_partons(j)%p%momentum%p(0)) * &
(one - enclosed_angle_ct &
(new_partons(i)%p%momentum, &
new_partons(j)%p%momentum))
if (y < ymin .or. vanishes(ymin)) then
ymin = y
imin = i
jmin = j
end if
end do INNER
end do OUTER
if (ymin > zero) then
call shower%add_parent (new_partons(imin)%p)
call parton_set_child &
(new_partons(imin)%p%parent, new_partons(jmin)%p, 2)
call parton_set_parent &
(new_partons(jmin)%p, new_partons(imin)%p%parent)
prt => new_partons(imin)%p%parent
prt%nr = shower_get_next_free_nr (shower)
prt%type = INTERNAL
prt%momentum = new_partons(imin)%p%momentum + &
new_partons(jmin)%p%momentum
prt%t = prt%momentum**2
!!! TODO -> calculate costheta and store it for
!!! later use in generate_ps
if (space_part_norm(prt%momentum) > tiny_10) then
prtmomentum = prt%momentum
childmomentum = prt%child1%momentum
prtmomentum = boost (- prt%get_beta () / sqrt(one - &
(prt%get_beta ())**2), space_part(prt%momentum) / &
space_part_norm(prt%momentum)) * prtmomentum
childmomentum = boost (- prt%get_beta() / &
sqrt(one - &
(prt%get_beta ())**2), space_part(prt%momentum) / &
space_part_norm(prt%momentum)) * childmomentum
prt%costheta = enclosed_angle_ct (prtmomentum, childmomentum)
else
prt%costheta = - one
end if
prt%belongstointeraction = .true.
nullify (new_partons(imin)%p)
nullify (new_partons(jmin)%p)
new_partons(imin)%p => prt
else
exit CLUSTERING
end if
end do CLUSTERING
@
<<Procedures of [[shower_add_interaction_2ton]]>>=
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]]>>=
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]]>>=
recursive subroutine set_starting_scale (prt, scale)
type(parton_t), pointer :: prt
real(default) :: scale
if (prt%type /= INTERNAL) then
if (scale > prt%settings%min_virtuality + prt%mass_squared ()) then
prt%t = scale
else
prt%t = prt%mass_squared ()
call prt%set_simulated ()
end if
end if
if (associated (prt%child1)) then
call set_starting_scale (prt%child1, scale)
end if
if (associated (prt%child2)) then
call set_starting_scale (prt%child2, scale)
end if
end subroutine set_starting_scale
@
<<Shower core: shower: TBP>>=
procedure :: simulate_no_isr_shower => shower_simulate_no_isr_shower
<<Shower core: procedures>>=
subroutine shower_simulate_no_isr_shower (shower)
class(shower_t), intent(inout) :: shower
integer :: i, j
type(parton_t), pointer :: prt
call msg_debug (D_SHOWER, "shower_simulate_no_isr_shower")
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. prt%parent%is_proton ()) then
if (associated (prt%parent%parent)) then
if (.not. prt%parent%is_proton ()) then
call shower_remove_parton_from_partons &
(shower, prt%parent%parent)
end if
end if
call shower_remove_parton_from_partons &
(shower, prt%parent)
end if
end if
call parton_set_parent (prt, prt%initial)
call parton_set_child (prt%initial, prt, 1)
if (associated (prt%initial%child2)) then
call shower_remove_parton_from_partons &
(shower,prt%initial%child2)
deallocate (prt%initial%child2)
end if
call shower%add_child (prt%initial, 2)
end if
end do
end do
end subroutine shower_simulate_no_isr_shower
@ %def shower_simulate_no_isr_shower
@
<<Shower core: shower: TBP>>=
procedure :: simulate_no_fsr_shower => shower_simulate_no_fsr_shower
<<Shower core: procedures>>=
subroutine shower_simulate_no_fsr_shower (shower)
class(shower_t), intent(inout) :: shower
integer :: i, j
type(parton_t), pointer :: prt
do i = 1, size (shower%interactions)
do j = 3, size (shower%interactions(i)%i%partons)
prt => shower%interactions(i)%i%partons(j)%p
call prt%set_simulated ()
prt%scale = zero
prt%t = prt%mass_squared ()
end do
end do
end subroutine shower_simulate_no_fsr_shower
@ %def shower_simulate_no_fsr_shower
@
<<Shower core: procedures>>=
subroutine swap_pointers (prtp1, prtp2)
type(parton_pointer_t), intent(inout) :: prtp1, prtp2
type(parton_pointer_t) :: prtptemp
prtptemp%p => prtp1%p
prtp1%p => prtp2%p
prtp2%p => prtptemp%p
end subroutine swap_pointers
@ %def swap_pointers
@ This removes emitted timelike partons.
<<Shower core: procedures>>=
recursive subroutine shower_remove_parton_from_partons (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), pointer :: prt
integer :: i
if (.not. prt%belongstoFSR .and. associated (prt%child2)) then
call shower_remove_parton_from_partons_recursive (shower, prt%child2)
end if
do i = 1, size (shower%partons)
if (associated (shower%partons(i)%p, prt)) then
shower%partons(i)%p => null()
! TODO: (bcn 2015-05-05) memory leak here? no deallocation?
exit
end if
if (debug_active (D_SHOWER)) then
if (i == size (shower%partons)) then
call msg_bug ("shower_remove_parton_from_partons: parton&
&to be removed not found")
end if
end if
end do
end subroutine shower_remove_parton_from_partons
@ %def shower_remove_parton_from_partons
@ This removes the parton [[prt]] and all its children.
<<Shower core: procedures>>=
recursive subroutine shower_remove_parton_from_partons_recursive (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), pointer :: prt
if (associated (prt%child1)) then
call shower_remove_parton_from_partons_recursive (shower, prt%child1)
deallocate (prt%child1)
end if
if (associated (prt%child2)) then
call shower_remove_parton_from_partons_recursive (shower, prt%child2)
deallocate (prt%child2)
end if
call shower_remove_parton_from_partons (shower, prt)
end subroutine shower_remove_parton_from_partons_recursive
@ %def shower_remove_parton_from_partons_recursive
@
<<Shower core: shower: TBP>>=
procedure :: sort_partons => shower_sort_partons
<<Shower core: procedures>>=
subroutine shower_sort_partons (shower)
class(shower_t), intent(inout) :: shower
integer :: i, j, maxsort, size_partons
logical :: changed
call msg_debug2 (D_SHOWER, "shower_sort_partons")
if (.not. allocated (shower%partons)) return
size_partons = size (shower%partons)
maxsort = 0
do i = 1, size_partons
if (associated (shower%partons(i)%p)) maxsort = i
end do
if (signal_is_pending ()) return
size_partons = size (shower%partons)
if (size_partons <= 1) return
do i = 1, maxsort
if (.not. associated (shower%partons(i)%p)) cycle
if (.not. shower%settings%isr_pt_ordered) then
!!! set unsimulated ISR partons to be "typeless" to prevent
!!! influences from "wrong" masses
if (.not. shower%partons(i)%p%belongstoFSR .and. &
.not. shower%partons(i)%p%simulated .and. &
.not. shower%partons(i)%p%belongstointeraction) then
shower%partons(i)%p%type = 0
end if
end if
end do
if (signal_is_pending ()) return
!!! Just a Bubblesort
!!! Different algorithms needed for t-ordered and pt^2-ordered shower
!!! Pt-ordered:
if (shower%settings%isr_pt_ordered) then
OUTERDO_PT: do i = 1, maxsort - 1
changed = .false.
INNERDO_PT: do j = 1, maxsort - i
if (.not. associated (shower%partons(j + 1)%p)) cycle
if (.not. associated (shower%partons(j)%p)) then
!!! change if j + 1 ist assoaciated and j is not
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else if (shower%partons(j)%p%scale < &
shower%partons(j + 1)%p%scale) then
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else if (nearly_equal(shower%partons(j)%p%scale, &
shower%partons(j + 1)%p%scale)) then
if (shower%partons(j)%p%nr > shower%partons(j + 1)%p%nr) then
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
end if
end if
end do INNERDO_PT
if (.not. changed) exit OUTERDO_PT
end do outerdo_pt
!!! |t|-ordered
else
OUTERDO_T: do i = 1, maxsort - 1
changed = .false.
INNERDO_T: do j = 1, maxsort - i
if (.not. associated (shower%partons(j + 1)%p)) cycle
if (.not. associated (shower%partons(j)%p)) then
!!! change if j+1 is associated and j isn't
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else if (.not. shower%partons(j)%p%belongstointeraction .and. &
shower%partons(j + 1)%p%belongstointeraction) then
!!! move partons belonging to the interaction to the front
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else if (.not. shower%partons(j)%p%belongstointeraction .and. &
.not. shower%partons(j + 1)%p%belongstointeraction ) then
if (abs (shower%partons(j)%p%t) - &
shower%partons(j)%p%mass_squared () < &
abs(shower%partons(j + 1)%p%t) - &
shower%partons(j + 1)%p%mass_squared ()) then
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else
if (nearly_equal(abs (shower%partons(j)%p%t) - &
shower%partons(j)%p%mass_squared (), &
abs(shower%partons(j + 1)%p%t) - &
shower%partons(j + 1)%p%mass_squared ())) then
if (shower%partons(j)%p%nr > &
shower%partons(j + 1)%p%nr) then
call swap_pointers (shower%partons(j), &
shower%partons(j + 1))
changed = .true.
end if
end if
end if
end if
end do INNERDO_T
if (.not. changed) exit OUTERDO_T
end do OUTERDO_T
end if
end subroutine shower_sort_partons
@ %def shower_sort_partons
@ Deallocate the interaction pointers.
<<Shower core: shower: TBP>>=
procedure :: cleanup => shower_cleanup
<<Shower core: procedures>>=
subroutine shower_cleanup (shower)
class(shower_t), intent(inout) :: shower
integer :: i
if (allocated (shower%interactions)) then
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)
end if
if (allocated (shower%partons)) deallocate (shower%partons)
end subroutine shower_cleanup
@ %def shower_cleanup
@ 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 :: update_max_color_nr => shower_update_max_color_nr
<<Shower core: procedures>>=
pure subroutine shower_update_max_color_nr (shower, index)
class(shower_t), intent(inout) :: shower
integer, intent(in) :: index
if (index > shower%next_color_nr) then
shower%next_color_nr = index
end if
end subroutine shower_update_max_color_nr
@ %def shower_update_max_color_nr
<<Shower core: shower: TBP>>=
procedure :: get_next_color_nr => shower_get_next_color_nr
<<Shower core: procedures>>=
function shower_get_next_color_nr (shower) result (next_color)
class(shower_t), intent(inout) :: shower
integer :: next_color
next_color = shower%next_color_nr
shower%next_color_nr = shower%next_color_nr + 1
end function shower_get_next_color_nr
@ %def shower_get_next_color_nr
@
<<Shower core: procedures>>=
subroutine shower_enlarge_partons_array (shower, custom_length)
type(shower_t), intent(inout) :: shower
integer, intent(in), optional :: custom_length
integer :: i, length, oldlength
type(parton_pointer_t), dimension(:), allocatable :: tmp_partons
call msg_debug (D_SHOWER, "shower_enlarge_partons_array")
if (present(custom_length)) then
length = custom_length
else
length = 10
end if
if (debug_active (D_SHOWER)) then
if (length < 1) then
call msg_bug ("Shower: no parton_pointers added in shower%partons")
end if
end if
if (allocated (shower%partons)) then
oldlength = size (shower%partons)
allocate (tmp_partons(1:oldlength))
do i = 1, oldlength
tmp_partons(i)%p => shower%partons(i)%p
end do
deallocate (shower%partons)
else
oldlength = 0
end if
allocate (shower%partons(1:oldlength + length))
do i = 1, oldlength
shower%partons(i)%p => tmp_partons(i)%p
end do
do i = oldlength + 1, oldlength + length
shower%partons(i)%p => null()
end do
end subroutine shower_enlarge_partons_array
@ %def shower_enlarge_partons_array
@
<<Shower core: shower: TBP>>=
procedure :: add_child => shower_add_child
<<Shower core: procedures>>=
subroutine shower_add_child (shower, prt, child)
class(shower_t), intent(inout) :: shower
type(parton_t), pointer :: prt
integer, intent(in) :: child
integer :: i, lastfree
type(parton_pointer_t) :: newprt
if (child /= 1 .and. child /= 2) then
call msg_bug ("Shower: Adding child in nonexisting place")
end if
allocate (newprt%p)
newprt%p%nr = shower%get_next_free_nr ()
!!! add new parton as child
if (child == 1) then
prt%child1 => newprt%p
else
prt%child2 => newprt%p
end if
newprt%p%parent => prt
if (associated (prt%settings)) then
newprt%p%settings => prt%settings
end if
newprt%p%interactionnr = prt%interactionnr
!!! add new parton to shower%partons list
if (associated (shower%partons (size(shower%partons))%p)) then
call shower_enlarge_partons_array (shower)
end if
!!! find last free pointer and let it point to the new parton
lastfree = 0
do i = size (shower%partons), 1, -1
if (.not. associated (shower%partons(i)%p)) then
lastfree = i
end if
end do
if (lastfree == 0) then
call msg_bug ("Shower: no free pointers found")
end if
shower%partons(lastfree)%p => newprt%p
end subroutine shower_add_child
@ %def shower_add_child
@
<<Shower core: shower: TBP>>=
procedure :: add_parent => shower_add_parent
<<Shower core: procedures>>=
subroutine shower_add_parent (shower, prt)
class(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
integer :: i, lastfree
type(parton_pointer_t) :: newprt
call msg_debug2 (D_SHOWER, "shower_add_parent: for parton nr", 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
if (associated (prt%settings)) then
newprt%p%settings => prt%settings
end if
newprt%p%interactionnr = prt%interactionnr
!!! add new parton to shower%partons list
if (.not. allocated (shower%partons) .or. &
associated (shower%partons(size(shower%partons))%p)) then
call shower_enlarge_partons_array (shower)
end if
!!! find last free pointer and let it point to the new parton
lastfree = 0
do i = size(shower%partons), 1, -1
if (.not. associated (shower%partons(i)%p)) then
lastfree = i
end if
end do
if (debug_active (D_SHOWER)) then
if (lastfree == 0) then
call msg_bug ("Shower: no free pointers found")
end if
end if
shower%partons(lastfree)%p => newprt%p
end subroutine shower_add_parent
@ %def shower_add_parent
@ For debugging:
<<Shower core: procedures>>=
pure function shower_get_total_momentum (shower) result (mom)
type(shower_t), intent(in) :: shower
type(vector4_t) :: mom
integer :: i
if (.not. allocated (shower%partons)) return
mom = vector4_null
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
if (shower%partons(i)%p%is_final ()) then
mom = mom + shower%partons(i)%p%momentum
end if
end do
end function shower_get_total_momentum
@ %def shower_get_total_momentum
@ Count the number of partons by going through [[shower%partons]]
whereby you can require a minimum energy [[mine]] and specify whether to
[[include_remnants]], which is done if not given.
<<Shower core: shower: TBP>>=
procedure :: get_nr_of_partons => shower_get_nr_of_partons
<<Shower core: procedures>>=
function shower_get_nr_of_partons (shower, mine, &
include_remnants, no_hard_prts, only_colored) result (nr)
class(shower_t), intent(in) :: shower
real(default), intent(in), optional :: mine
logical, intent(in), optional :: include_remnants, no_hard_prts, &
only_colored
logical :: no_hard, only_col, include_rem
integer :: nr, i
nr = 0
no_hard = .false.; if (present (no_hard_prts)) &
no_hard = no_hard_prts
only_col = .false.; if (present (only_colored)) &
only_col = only_colored
include_rem = .true.; if (present (include_remnants)) &
include_rem = include_remnants
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
associate (prt => shower%partons(i)%p)
if (.not. prt%is_final ()) cycle
if (present (only_colored)) then
if (only_col) then
if (.not. prt%is_colored ()) cycle
else
if (prt%is_colored ()) cycle
end if
end if
if (no_hard) then
if (shower%partons(i)%p%belongstointeraction) cycle
end if
if (.not. include_rem) then
if (prt%type == BEAM_REMNANT) cycle
end if
if (present(mine)) then
if (prt%momentum%p(0) < mine) cycle
end if
nr = nr + 1
end associate
end do
end function shower_get_nr_of_partons
@ %def shower_get_nr_of_partons
@
<<Shower core: procedures>>=
function shower_get_nr_of_final_colored_ME_partons (shower) result (nr)
type(shower_t), intent(in) :: shower
integer :: nr
integer :: i, j
type(parton_t), pointer :: prt
nr = 0
do i = 1, size (shower%interactions)
do j = 1, size (shower%interactions(i)%i%partons)
prt => shower%interactions(i)%i%partons(j)%p
if (.not. associated (prt)) cycle
if (.not. prt%is_colored ()) cycle
if (prt%belongstointeraction .and. prt%belongstoFSR .and. &
(prt%type /= INTERNAL)) then
nr = nr +1
end if
end do
end do
end function shower_get_nr_of_final_colored_ME_partons
@ %def shower_get_nr_of_final_colored_ME_partons
@
<<Shower core: shower: TBP>>=
procedure :: get_final_colored_ME_momenta => &
shower_get_final_colored_ME_momenta
<<Shower core: procedures>>=
subroutine shower_get_final_colored_ME_momenta (shower, momenta)
class(shower_t), intent(in) :: shower
type(vector4_t), dimension(:), allocatable, intent(out) :: momenta
type(parton_pointer_t), dimension(:), allocatable :: partons
integer :: i, j, index, s
type(parton_t), pointer :: prt
s = shower_get_nr_of_final_colored_ME_partons (shower)
if (s == 0) return
allocate (partons(1:s))
allocate (momenta(1:s))
index = 0
do i = 1, size (shower%interactions)
do j = 1, size (shower%interactions(i)%i%partons)
prt => shower%interactions(i)%i%partons(j)%p
if (.not. associated (prt)) cycle
if (.not. prt%is_colored ()) cycle
if (prt%belongstointeraction .and. prt%belongstoFSR .and. &
(prt%type /= INTERNAL)) then
index = index + 1
partons(index)%p => prt
end if
end do
end do
do i = 1, s ! pointers forbid array notation
momenta(i) = partons(i)%p%momentum
end do
end subroutine shower_get_final_colored_ME_momenta
@ %def shower_get_final_colored_ME_momenta
@
<<Shower core: procedures>>=
recursive function interaction_fsr_is_finished_for_parton &
(prt) result (finished)
type(parton_t), intent(in) :: prt
logical :: finished
if (prt%belongstoFSR) then
!!! FSR partons
if (associated (prt%child1)) then
finished = interaction_fsr_is_finished_for_parton (prt%child1) &
.and. interaction_fsr_is_finished_for_parton (prt%child2)
else
finished = prt%t <= prt%mass_squared ()
end if
else
!!! search for emitted timelike partons in ISR shower
if (.not. associated (prt%initial)) then
!!! no inital -> no ISR
finished = .true.
else if (.not. associated (prt%parent)) then
finished = .false.
else
if (.not. prt%parent%is_proton ()) then
if (associated (prt%child2)) then
finished = interaction_fsr_is_finished_for_parton (prt%parent) .and. &
interaction_fsr_is_finished_for_parton (prt%child2)
else
finished = interaction_fsr_is_finished_for_parton (prt%parent)
end if
else
if (associated (prt%child2)) then
finished = interaction_fsr_is_finished_for_parton (prt%child2)
else
!!! only second partons can come here -> if that happens FSR
!!! evolution is not existing
finished = .true.
end if
end if
end if
end if
end function interaction_fsr_is_finished_for_parton
@ %def interaction_fsr_is_finished_for_parton
@
<<Shower core: procedures>>=
function interaction_fsr_is_finished (interaction) result (finished)
type(shower_interaction_t), intent(in) :: interaction
logical :: finished
integer :: i
finished = .true.
if (.not. allocated (interaction%partons)) return
do i = 1, size (interaction%partons)
if (.not. interaction_fsr_is_finished_for_parton &
(interaction%partons(i)%p)) then
finished = .false.
exit
end if
end do
end function interaction_fsr_is_finished
@ %def interaction_fsr_is_finished
@
<<Shower core: public>>=
public :: shower_interaction_get_s
<<Shower core: procedures>>=
function shower_interaction_get_s (interaction) result (s)
type(shower_interaction_t), intent(in) :: interaction
real(default) :: s
s = (interaction%partons(1)%p%initial%momentum + &
interaction%partons(2)%p%initial%momentum)**2
end function shower_interaction_get_s
@ %def shower_interaction_get_s
@
<<Shower core: procedures>>=
function shower_fsr_is_finished (shower) result (finished)
type(shower_t), intent(in) :: shower
logical :: finished
integer :: i
finished = .true.
if (.not. allocated (shower%interactions)) return
do i = 1, size(shower%interactions)
if (.not. interaction_fsr_is_finished (shower%interactions(i)%i)) then
finished = .false.
exit
end if
end do
end function shower_fsr_is_finished
@ %def shower_fsr_is_finished
@
<<Shower core: procedures>>=
function shower_isr_is_finished (shower) result (finished)
type(shower_t), intent(in) :: shower
logical :: finished
integer :: i
type(parton_t), pointer :: prt
finished = .true.
if (.not.allocated (shower%partons)) return
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
prt => shower%partons(i)%p
if (shower%settings%isr_pt_ordered) then
if (.not. prt%belongstoFSR .and. .not. prt%simulated &
.and. prt%scale > zero) then
finished = .false.
exit
end if
else
if (.not. prt%belongstoFSR .and. .not. prt%simulated &
.and. prt%t < zero) then
finished = .false.
exit
end if
end if
end do
end function shower_isr_is_finished
@ %def shower_isr_is_finished
@
<<Shower core: procedures>>=
subroutine interaction_find_partons_nearest_to_hadron &
(interaction, prt1, prt2, isr_pt_ordered)
type(shower_interaction_t), intent(in) :: interaction
type(parton_t), pointer :: prt1, prt2
logical, intent(in) :: isr_pt_ordered
prt1 => null ()
prt2 => null ()
prt1 => interaction%partons(1)%p
do
if (associated (prt1%parent)) then
if (prt1%parent%is_proton ()) then
exit
else if ((.not. isr_pt_ordered .and. .not. prt1%parent%simulated) &
.or. (isr_pt_ordered .and. .not. prt1%simulated)) then
exit
else
prt1 => prt1%parent
end if
else
exit
end if
end do
prt2 => interaction%partons(2)%p
do
if (associated (prt2%parent)) then
if (prt2%parent%is_proton ()) then
exit
else if ((.not. isr_pt_ordered .and. .not. prt2%parent%simulated) &
.or. (isr_pt_ordered .and. .not. prt2%simulated)) then
exit
else
prt2 => prt2%parent
end if
else
exit
end if
end do
end subroutine interaction_find_partons_nearest_to_hadron
@ %def interaction_find_partons_nearest_to_hadron
@
<<Shower core: shower: TBP>>=
procedure :: update_beamremnants => shower_update_beamremnants
<<Shower core: procedures>>=
subroutine shower_update_beamremnants (shower)
class(shower_t), intent(inout) :: shower
type(parton_t), pointer :: hadron, remnant
integer :: i
real(default) :: random
!!! only proton in first interaction !!?
!!! currently only first beam-remnant will be updated
do i = 1,2
if (associated (shower%interactions(1)%i%partons(i)%p%initial)) then
hadron => shower%interactions(1)%i%partons(i)%p%initial
else
cycle
end if
remnant => hadron%child2
if (associated (remnant)) then
remnant%momentum = hadron%momentum - hadron%child1%momentum
end if
!!! generate flavor of the beam-remnant if beam was proton
if (abs (hadron%type) == PROTON .and. associated (hadron%child1)) then
if (hadron%child1%is_quark ()) then
!!! decide if valence (u,d) or sea quark (s,c,b)
if ((abs (hadron%child1%type) <= 2) .and. &
(hadron%type * hadron%child1%type > zero)) then
!!! valence quark
if (abs (hadron%child1%type) == 1) then
!!! if d then remaining diquark is uu_1
remnant%type = sign (UU1, hadron%type)
else
call shower%rng%generate (random)
!!! if u then remaining diquark is ud_0 or ud_1
if (random < 0.75_default) then
remnant%type = sign (UD0, hadron%type)
else
remnant%type = sign (UD1, hadron%type)
end if
end if
remnant%c1 = hadron%child1%c2
remnant%c2 = hadron%child1%c1
else if ((hadron%type * hadron%child1%type) < zero) then
!!! antiquark
if (.not. associated (remnant%child1)) then
call shower%add_child (remnant, 1)
end if
if (.not. associated (remnant%child2)) then
call shower%add_child (remnant, 2)
end if
call shower%rng%generate (random)
if (random < 0.6666_default) then
!!! 2/3 into udq + u
if (abs (hadron%child1%type) == 1) then
remnant%child1%type = sign (NEUTRON, hadron%type)
else if (abs (hadron%child1%type) == 2) then
remnant%child1%type = sign (PROTON, hadron%type)
else if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (SIGMA0, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (SIGMACPLUS, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (SIGMAB0, hadron%type)
end if
remnant%child2%type = sign (2, hadron%type)
else
!!! 1/3 into uuq + d
if (abs (hadron%child1%type) == 1) then
remnant%child1%type = sign (PROTON, hadron%type)
else if (abs (hadron%child1%type) == 2) then
remnant%child1%type = sign (DELTAPLUSPLUS, hadron%type)
else if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (SIGMAPLUS, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (SIGMACPLUSPLUS, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (SIGMABPLUS, hadron%type)
end if
remnant%child2%type = sign (1, hadron%type)
end if
remnant%c1 = hadron%child1%c2
remnant%c2 = hadron%child1%c1
remnant%child1%c1 = 0
remnant%child1%c2 = 0
remnant%child2%c1 = remnant%c1
remnant%child2%c2 = remnant%c2
else
!!! sea quark
if (.not. associated (remnant%child1)) then
call shower%add_child (remnant, 1)
end if
if (.not. associated (remnant%child2)) then
call shower%add_child (remnant, 2)
end if
call shower%rng%generate (random)
if (random < 0.5_default) then
!!! 1/2 into usbar + ud_0
if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (KPLUS, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (D0, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (BPLUS, hadron%type)
end if
remnant%child2%type = sign (UD0, hadron%type)
else if (random < 0.6666_default) then
!!! 1/6 into usbar + ud_1
if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (KPLUS, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (D0, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (BPLUS, hadron%type)
end if
remnant%child2%type = sign (UD1, hadron%type)
else
!!! 1/3 into dsbar + uu_1
if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (K0, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (DPLUS, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (B0, hadron%type)
end if
remnant%child2%type = sign (UU1, hadron%type)
end if
remnant%c1 = hadron%child1%c2
remnant%c2 = hadron%child1%c1
remnant%child1%c1 = 0
remnant%child1%c2 = 0
remnant%child2%c1 = remnant%c1
remnant%child2%c2 = remnant%c2
end if
else if (hadron%child1%is_gluon ()) then
if (.not.associated (remnant%child1)) then
call shower%add_child (remnant, 1)
end if
if (.not.associated (remnant%child2)) then
call shower%add_child (remnant, 2)
end if
call shower%rng%generate (random)
if (random < 0.5_default) then
!!! 1/2 into u + ud_0
remnant%child1%type = sign (2, hadron%type)
remnant%child2%type = sign (UD0, hadron%type)
else if (random < 0.6666_default) then
!!! 1/6 into u + ud_1
remnant%child1%type = sign (2, hadron%type)
remnant%child2%type = sign (UD1, hadron%type)
else
!!! 1/3 into d + uu_1
remnant%child1%type = sign (1, hadron%type)
remnant%child2%type = sign (UU1, hadron%type)
end if
remnant%c1 = hadron%child1%c2
remnant%c2 = hadron%child1%c1
if (hadron%type > 0) then
remnant%child1%c1 = remnant%c1
remnant%child2%c2 = remnant%c2
else
remnant%child1%c2 = remnant%c2
remnant%child2%c1 = remnant%c1
end if
end if
remnant%initial => hadron
if (associated (remnant%child1)) then
remnant%child1%initial => hadron
remnant%child2%initial => hadron
!!! don't care about on-shellness for now
remnant%child1%momentum = 0.5_default * remnant%momentum
remnant%child2%momentum = 0.5_default * remnant%momentum
!!! but care about on-shellness for baryons
if (mod (remnant%child1%type, 100) >= 10) then
!!! check if the third quark is set -> meson or baryon
remnant%child1%t = remnant%child1%mass_squared ()
remnant%child1%momentum = [remnant%child1%momentum%p(0), &
(remnant%child1%momentum%p(1:3) / &
remnant%child1%momentum%p(1:3)**1) * &
sqrt (remnant%child1%momentum%p(0)**2 - remnant%child1%t)]
remnant%child2%momentum = remnant%momentum &
- remnant%child1%momentum
end if
end if
end if
end do
end subroutine shower_update_beamremnants
@ %def shower_update_beamremnants
@
<<Shower core: procedures>>=
subroutine interaction_apply_lorentztrafo (interaction, L)
type(shower_interaction_t), intent(inout) :: interaction
type(lorentz_transformation_t), intent(in) :: L
type(parton_t), pointer :: prt
integer :: i
!!! ISR part
do i = 1,2
prt => interaction%partons(i)%p
!!! loop over ancestors
MOTHERS: do
!!! boost parton
call parton_apply_lorentztrafo (prt, L)
if (associated (prt%child2)) then
!!! boost emitted timelike parton (and daughters)
call parton_apply_lorentztrafo_recursive (prt%child2, L)
end if
if (associated (prt%parent)) then
if (.not. prt%parent%is_proton ()) then
prt => prt%parent
else
exit
end if
else
exit
end if
end do MOTHERS
end do
!!! FSR part
if (associated (interaction%partons(3)%p%parent)) then
!!! pseudo Parton-Shower histora has been generated -> find
!!! mother and go on from there recursively
prt => interaction%partons(3)%p
do while (associated (prt%parent))
prt => prt%parent
end do
call parton_apply_lorentztrafo_recursive (prt, L)
else
do i = 3, size (interaction%partons)
call parton_apply_lorentztrafo (interaction%partons(i)%p, L)
end do
end if
end subroutine interaction_apply_lorentztrafo
@ %def interaction_apply_lorentztrafo
@
<<Shower core: procedures>>=
subroutine shower_apply_lorentztrafo (shower, L)
type(shower_t), intent(inout) :: shower
type(lorentz_transformation_t), intent(in) :: L
integer :: i
do i = 1, size (shower%interactions)
call interaction_apply_lorentztrafo (shower%interactions(i)%i, L)
end do
end subroutine shower_apply_lorentztrafo
@ %def shower_apply_lorentztrafo
@ This boosts partons belonging to the interaction to the
center-of-mass frame of its partons nearest to the hadron.
<<Shower core: procedures>>=
subroutine interaction_boost_to_CMframe (interaction, isr_pt_ordered)
type(shower_interaction_t), intent(inout) :: interaction
logical, intent(in) :: isr_pt_ordered
type(vector4_t) :: beta
type(parton_t), pointer :: prt1, prt2
call interaction_find_partons_nearest_to_hadron &
(interaction, prt1, prt2, isr_pt_ordered)
beta = prt1%momentum + prt2%momentum
beta = beta / beta%p(0)
if (debug_active (D_SHOWER)) then
if (beta**2 > one) then
call msg_error ("Shower: boost to CM frame: beta > 1")
return
end if
end if
if (space_part(beta)**2 > tiny_13) then
call interaction_apply_lorentztrafo (interaction, &
boost(space_part(beta)**1 / &
sqrt (one - space_part(beta)**2), -direction(beta)))
end if
end subroutine interaction_boost_to_CMframe
@ %def interaction_boost_to_CMframe
@ This boosts every interaction to the center-of-mass-frame of its
partons nearest to the hadron.
<<Shower core: shower: TBP>>=
procedure :: boost_to_CMframe => shower_boost_to_CMframe
<<Shower core: procedures>>=
subroutine shower_boost_to_CMframe (shower)
class(shower_t), intent(inout) :: shower
integer :: i
do i = 1, size (shower%interactions)
call interaction_boost_to_CMframe &
(shower%interactions(i)%i, shower%settings%isr_pt_ordered)
end do
! TODO: (bcn 2015-03-23) this shouldnt be here !
call shower%update_beamremnants ()
end subroutine shower_boost_to_CMframe
@ %def shower_boost_to_CMframe
@ This boost all partons so that initial partons have their assigned
$x$-value.
<<Shower core: shower: TBP>>=
procedure :: boost_to_labframe => shower_boost_to_labframe
<<Shower core: procedures>>=
subroutine shower_boost_to_labframe (shower)
class(shower_t), intent(inout) :: shower
integer :: i
do i = 1, size (shower%interactions)
call interaction_boost_to_labframe &
(shower%interactions(i)%i, shower%settings%isr_pt_ordered)
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, isr_pt_ordered)
type(shower_interaction_t), intent(inout) :: interaction
logical, intent(in) :: isr_pt_ordered
type(parton_t), pointer :: prt1, prt2
type(vector3_t) :: beta
call interaction_find_partons_nearest_to_hadron &
(interaction, prt1, prt2, isr_pt_ordered)
if (.not. associated (prt1%initial) .or. .not. &
associated (prt2%initial)) then
return
end if
!!! transform partons to overall labframe.
beta = vector3_canonical(3) * &
((prt1%x * prt2%momentum%p(0) - &
prt2%x * prt1%momentum%p(0)) / &
(prt1%x * prt2%momentum%p(3) - &
prt2%x * prt1%momentum%p(3)))
if (beta**1 > tiny_10) &
call interaction_apply_lorentztrafo (interaction, &
boost (beta**1 / sqrt(one - beta**2), -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, isr_pt_ordered)
type(shower_interaction_t), intent(inout) :: interaction
logical, intent(in) :: isr_pt_ordered
type(parton_t), pointer :: prt1, prt2
call interaction_find_partons_nearest_to_hadron &
(interaction, prt1, prt2, isr_pt_ordered)
if (associated (prt1%initial)) then
call interaction_apply_lorentztrafo (interaction, &
rotation_to_2nd (space_part (prt1%momentum), &
vector3_canonical(3) * sign (one, &
prt1%initial%momentum%p(3))))
end if
end subroutine interaction_rotate_to_z
@ %def interaction_rotate_to_z
@ Rotate initial partons to lie along $\pm z$ axis.
<<Shower core: shower: TBP>>=
procedure :: rotate_to_z => shower_rotate_to_z
<<Shower core: procedures>>=
subroutine shower_rotate_to_z (shower)
class(shower_t), intent(inout) :: shower
integer :: i
do i = 1, size (shower%interactions)
call interaction_rotate_to_z &
(shower%interactions(i)%i, shower%settings%isr_pt_ordered)
end do
! TODO: (bcn 2015-03-23) this shouldnt be here !
call shower%update_beamremnants ()
end subroutine shower_rotate_to_z
@ %def shower_rotate_to_z
@ Return if there are no initials, electron-hadron collision not
implemented.
<<Shower core: procedures>>=
subroutine interaction_generate_primordial_kt &
(interaction, primordial_kt_width, primordial_kt_cutoff, rng)
type(shower_interaction_t), intent(inout) :: interaction
real(default), intent(in) :: primordial_kt_width, primordial_kt_cutoff
class(rng_t), intent(inout), allocatable :: rng
type(parton_t), pointer :: had1, had2
type(vector4_t) :: momenta(2)
type(vector3_t) :: beta
real(default) :: pt (2), phi(2)
real(default) :: shat
real(default) :: btheta, bphi
integer :: i
if (vanishes (primordial_kt_width)) return
if (.not. associated (interaction%partons(1)%p%initial) .or. &
.not. associated (interaction%partons(2)%p%initial)) then
return
end if
had1 => interaction%partons(1)%p%initial
had2 => interaction%partons(2)%p%initial
!!! copy momenta and energy
momenta(1) = had1%child1%momentum
momenta(2) = had2%child1%momentum
GENERATE_PT_PHI: do i = 1, 2
!!! generate transverse momentum and phi
GENERATE_PT: do
call rng%generate (pt (i))
pt(i) = primordial_kt_width * sqrt(-log(pt(i)))
if (pt(i) < primordial_kt_cutoff) exit
end do GENERATE_PT
call rng%generate (phi (i))
phi(i) = twopi * phi(i)
end do GENERATE_PT_PHI
!!! adjust momenta
shat = (momenta(1) + momenta(2))**2
momenta(1) = [momenta(1)%p(0), &
pt(1) * cos(phi(1)), &
pt(1) * sin(phi(1)), &
momenta(1)%p(3)]
momenta(2) = [momenta(2)%p(0), &
pt(2) * cos(phi(2)), &
pt(2) * sin(phi(2)), &
momenta(2)%p(3)]
beta = [momenta(1)%p(1) + momenta(2)%p(1), &
momenta(1)%p(2) + momenta(2)%p(2), zero] / sqrt(shat)
momenta(1) = boost (beta**1 / sqrt(one - beta**2), -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 (beta**1 / sqrt(one - beta**2), -direction(beta)))
end subroutine interaction_generate_primordial_kt
@ %def interaction_generate_primordial_kt
@
<<Shower core: shower: TBP>>=
procedure :: generate_primordial_kt => shower_generate_primordial_kt
<<Shower core: procedures>>=
subroutine shower_generate_primordial_kt (shower)
class(shower_t), intent(inout) :: shower
integer :: i
do i = 1, size (shower%interactions)
call interaction_generate_primordial_kt (shower%interactions(i)%i, &
shower%settings%isr_primordial_kt_width, &
shower%settings%isr_primordial_kt_cutoff, shower%rng)
end do
! TODO: (bcn 2015-03-23) this shouldnt be here !
call shower%update_beamremnants ()
end subroutine shower_generate_primordial_kt
@ %def shower_generate_primordial_kt
@ Output.
<<Shower core: procedures>>=
subroutine interaction_write (interaction, unit)
type(shower_interaction_t), intent(in) :: interaction
integer, intent(in), optional :: unit
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
if (associated (interaction%partons(1)%p)) then
if (associated (interaction%partons(1)%p%initial)) &
call interaction%partons(1)%p%initial%write (u)
end if
if (associated (interaction%partons(2)%p)) then
if (associated (interaction%partons(2)%p%initial)) &
call interaction%partons(2)%p%initial%write (u)
end if
if (allocated (interaction%partons)) then
do i = 1, size (interaction%partons)
call interaction%partons(i)%p%write (u)
end do
end if
write (u, "(A)")
end subroutine interaction_write
@ %def interaction_write
@
<<Shower core: shower: TBP>>=
procedure :: write => shower_write
<<Shower core: procedures>>=
subroutine shower_write (shower, unit)
class(shower_t), intent(in) :: shower
integer, intent(in), optional :: unit
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "------------------------------"
write (u, "(1x,A)") "WHIZARD internal parton shower"
write (u, "(1x,A)") "------------------------------"
call shower%pdf_data%write (u)
if (size (shower%interactions) > 0) then
write (u, "(3x,A)") "Interactions: "
do i = 1, size (shower%interactions)
write (u, "(4x,A,I0)") "Interaction number ", i
if (.not. associated (shower%interactions(i)%i)) then
call msg_fatal ("Shower: missing interaction in shower")
end if
call interaction_write (shower%interactions(i)%i, u)
end do
else
write (u, "(3x,A)") "[no interactions in shower]"
end if
write (u, "(A)")
if (allocated (shower%partons)) then
write (u, "(5x,A)") "Partons:"
do i = 1, size (shower%partons)
if (associated (shower%partons(i)%p)) then
call shower%partons(i)%p%write (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
call write_separator (u)
end if
end if
end if
end if
end do
else
write (u, "(5x,A)") "[no partons in shower]"
end if
write (u, "(4x,A)") "Total Momentum: "
call vector4_write (shower_get_total_momentum (shower))
write (u, "(1x,A,L1)") "ISR finished: ", shower_isr_is_finished (shower)
write (u, "(1x,A,L1)") "FSR finished: ", shower_fsr_is_finished (shower)
end subroutine shower_write
@ %def shower_write
@ We combine the [[particle_set]] from the hard interaction with the
partons of the shower. For simplicity, we do not maintain the
mother-daughter-relations of the shower. Hadronic [[beam_remnants]] of
the old [[particle_set]] are removed as they are provided, including
proper flavor information, by the ISR shower.
<<Shower core: shower: TBP>>=
procedure :: combine_with_particle_set => shower_combine_with_particle_set
<<Shower core: procedures>>=
subroutine shower_combine_with_particle_set (shower, particle_set, &
model_in, model_hadrons)
class(shower_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model_in
class(model_data_t), intent(in), target :: model_hadrons
type(particle_t), dimension(:), allocatable :: particles
integer, dimension(:), allocatable :: hard_colored_ids, &
shower_partons_ids, incoming_ids, outgoing_ids
class(model_data_t), pointer :: model
logical, dimension(:), allocatable :: hard_colored_mask
integer :: n_shower_partons, n_remnants, i, j
integer :: n_in, n_out, n_beam, n_tot_old
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "shower_combine_with_particle_set")
call msg_debug (D_SHOWER, "Particle set before replacing")
if (debug_active (D_SHOWER)) &
call particle_set%write (summary=.true., compressed=.true.)
n_shower_partons = shower%get_nr_of_partons (only_colored = &
.true., no_hard_prts = .true.)
n_remnants = shower%get_nr_of_partons (only_colored = .false., &
no_hard_prts = .true.)
if (n_shower_partons + n_remnants > 0) then
call particle_set%without_hadronic_remnants &
(particles, n_tot_old, n_shower_partons + n_remnants)
call count_and_allocate ()
call replace_outgoings ()
call set_hard_colored_as_resonant_parents_for_shower ()
call add_to_pset (n_tot_old, .true.)
call add_to_pset (n_tot_old + n_remnants, .false.)
call particle_set%replace (particles)
end if
call msg_debug (D_SHOWER, 'Particle set after replacing')
if (debug_active (D_SHOWER)) &
call particle_set%write (summary=.true., compressed=.true.)
contains
<<Shower core: shower combine with particle set: procedures>>
end subroutine shower_combine_with_particle_set
@ %def shower_combine_with_particle_set
<<Shower core: shower combine with particle set: procedures>>=
subroutine count_and_allocate ()
n_beam = particle_set%get_n_beam ()
n_in = particle_set%get_n_in ()
n_out = particle_set%get_n_out ()
allocate (hard_colored_mask (size (particles)))
!!! !!! !!! Workaround for ifort 16.0 standard-semantics bug
do i = 1, size (particles)
hard_colored_mask(i) = (particles(i)%get_status () == PRT_INCOMING .or. &
particles(i)%get_status () == PRT_OUTGOING) .and. &
particles(i)%is_colored ()
end do
!!! hard_colored_mask = (particles%get_status () == PRT_INCOMING .or. &
!!! particles%get_status () == PRT_OUTGOING) .and. &
!!! particles%is_colored ()
allocate (hard_colored_ids (count (hard_colored_mask)))
hard_colored_ids = pack ([(i, i=1, size (particles))], hard_colored_mask)
allocate (shower_partons_ids (n_shower_partons))
shower_partons_ids = [(n_tot_old + n_remnants + i, i=1, n_shower_partons)]
allocate (incoming_ids(n_in))
incoming_ids = [(n_beam + i, i=1, n_in)]
allocate (outgoing_ids(n_out))
outgoing_ids = [(n_tot_old - n_out + i, i=1, n_out )]
if (debug_active (D_SHOWER)) then
print *, 'n_remnants = ', n_remnants
print *, 'n_shower_partons = ', n_shower_partons
print *, 'n_tot_old = ', n_tot_old
print *, 'n_beam = ', n_beam
print *, 'n_in, n_out = ', n_in, n_out
end if
end subroutine count_and_allocate
@
<<Shower core: shower combine with particle set: procedures>>=
subroutine replace_outgoings ()
do i = 1, size (shower%interactions)
if (i > 1) then
call msg_bug ('shower_combine_with_particle_set assumes 1 interaction')
end if
associate (interaction => shower%interactions(i)%i)
do j = 3, size (interaction%partons)
if (associated (interaction%partons(j)%p)) then
call replace_parton_in_particles (j, interaction%partons(j)%p)
end if
end do
end associate
end do
end subroutine replace_outgoings
@
<<Shower core: shower combine with particle set: procedures>>=
subroutine replace_parton_in_particles (j, prt)
integer, intent(in) :: j
type(parton_t), intent(in) :: prt
integer :: idx
if (j <= 2) then
idx = n_beam + j
else
idx = n_tot_old - n_out - n_in + j
end if
call particles(idx)%set_momentum (prt%momentum)
end subroutine replace_parton_in_particles
@
<<Shower core: shower combine with particle set: procedures>>=
subroutine set_hard_colored_as_resonant_parents_for_shower ()
do i = 1, n_tot_old
if (hard_colored_mask (i)) then
if (has_splitted (i)) then
call particles(i)%add_children (shower_partons_ids)
if (particles(i)%get_status () == PRT_OUTGOING) then
call particles(i)%set_status (PRT_RESONANT)
end if
end if
end if
end do
end subroutine set_hard_colored_as_resonant_parents_for_shower
@
<<Shower core: shower combine with particle set: procedures>>=
function has_splitted (i) result (splitted)
logical :: splitted
integer, intent(in) :: i
splitted = .false.
do j = 1, size (shower%partons)
if (.not. associated (shower%partons(j)%p)) cycle
if (particles(i)%flv%get_pdg () == shower%partons(j)%p%type) then
if (all (nearly_equal (particles(i)%p%p, &
shower%partons(j)%p%momentum%p))) then
splitted = shower%partons(j)%p%is_branched ()
end if
end if
end do
end function has_splitted
@
<<Shower core: shower combine with particle set: procedures>>=
subroutine add_to_pset (offset, remnants)
integer, intent(in) :: offset
logical, intent(in) :: remnants
integer :: i, j
j = offset
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
associate (prt => shower%partons(i)%p)
if (.not. prt%is_final () .or. &
prt%belongstointeraction) cycle
if (remnants) then
if (prt%is_colored ()) cycle
else
if (.not. (prt%is_colored ())) cycle
end if
j = j + 1
call find_model (model, prt%type, model_in, model_hadrons)
particles (j) = prt%to_particle (model)
if (remnants) then
call particles(j)%set_parents ([prt%initial%nr])
call particles(prt%initial%nr)%add_child (j)
else
call particles(j)%set_parents (hard_colored_ids)
end if
end associate
end do
end subroutine add_to_pset
@
<<Shower core: shower: TBP>>=
procedure :: write_lhef => shower_write_lhef
<<Shower core: procedures>>=
subroutine shower_write_lhef (shower, unit)
class(shower_t), intent(in) :: shower
integer, intent(in), optional :: unit
integer :: u
integer :: i
integer :: c1, c2
u = given_output_unit (unit); if (u < 0) return
write(u,'(A)') '<LesHouchesEvents version="1.0">'
write(u,'(A)') '<-- not a complete lhe file - just one event -->'
write(u,'(A)') '<event>'
write(u, *) 2 + shower%get_nr_of_partons (), 1, 1.0, 1.0, 1.0, 1.0
!!! write incoming partons
do i = 1, 2
if (abs (shower%partons(i)%p%type) < 1000) then
c1 = 0
c2 = 0
if (shower%partons(i)%p%is_colored ()) then
if (shower%partons(i)%p%c1 /= 0) c1 = 500 + shower%partons(i)%p%c1
if (shower%partons(i)%p%c2 /= 0) c2 = 500 + shower%partons(i)%p%c2
end if
write (u,*) shower%partons(i)%p%type, -1, 0, 0, c1, c2, &
shower%partons(i)%p%momentum%p(1), &
shower%partons(i)%p%momentum%p(2), &
shower%partons(i)%p%momentum%p(3), &
shower%partons(i)%p%momentum%p(0), &
shower%partons(i)%p%momentum**2, zero, 9.0
else
write (u,*) shower%partons(i)%p%type, -9, 0, 0, 0, 0, &
shower%partons(i)%p%momentum%p(1), &
shower%partons(i)%p%momentum%p(2), &
shower%partons(i)%p%momentum%p(3), &
shower%partons(i)%p%momentum%p(0), &
shower%partons(i)%p%momentum**2, zero, 9.0
end if
end do
!!! write outgoing partons
do i = 3, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
if (.not. shower%partons(i)%p%is_final ()) cycle
c1 = 0
c2 = 0
if (shower%partons(i)%p%is_colored ()) then
if (shower%partons(i)%p%c1 /= 0) c1 = 500 + shower%partons(i)%p%c1
if (shower%partons(i)%p%c2 /= 0) c2 = 500 + shower%partons(i)%p%c2
end if
write (u,*) shower%partons(i)%p%type, 1, 1, 2, c1, c2, &
shower%partons(i)%p%momentum%p(1), &
shower%partons(i)%p%momentum%p(2), &
shower%partons(i)%p%momentum%p(3), &
shower%partons(i)%p%momentum%p(0), &
shower%partons(i)%p%momentum**2, zero, 9.0
end do
write(u,'(A)') '</event>'
write(u,'(A)') '</LesHouchesEvents>'
end subroutine shower_write_lhef
@ %def shower_write_lhef
@
<<Shower core: procedures>>=
subroutine shower_replace_parent_by_hadron (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
type(parton_t), pointer :: remnant => null()
if (associated (prt%parent)) then
call shower_remove_parton_from_partons (shower, prt%parent)
deallocate (prt%parent)
end if
if (.not. associated (prt%initial%child2)) then
call shower%add_child (prt%initial, 2)
end if
prt%parent => prt%initial
prt%parent%child1 => prt
! make other child to be a beam-remnant
remnant => prt%initial%child2
remnant%type = BEAM_REMNANT
remnant%momentum = prt%parent%momentum - prt%momentum
remnant%x = one - prt%x
remnant%parent => prt%initial
remnant%t = zero
end subroutine shower_replace_parent_by_hadron
@ %def shower_replace_parent_by_hadron
@
<<Shower core: procedures>>=
subroutine shower_get_first_ISR_scale_for_parton (shower, prt, tmax)
type(shower_t), intent(inout), target :: shower
type(parton_t), intent(inout), target :: prt
real(default), intent(in), optional :: tmax
real(default) :: t, tstep, random, integral, temp1
real(default) :: temprand
if (present(tmax)) then
t = max (max (-shower%settings%isr_tscalefactor * prt%momentum%p(0)**2, &
-abs(tmax)), prt%t)
else
t = max (-shower%settings%isr_tscalefactor * prt%momentum%p(0)**2, prt%t)
end if
call shower%rng%generate (random)
random = -twopi * log(random)
!!! compare Integral and log(random) instead of random and exp(-Integral)
integral = zero
call prt%set_simulated (.false.)
do
call shower%rng%generate (temprand)
tstep = max (abs (0.01_default * t) * temprand, 0.1_default * &
shower%settings%min_virtuality)
if (t + 0.5_default * tstep > - shower%settings%min_virtuality) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
exit
end if
prt%t = t + 0.5_default * tstep
temp1 = integral_over_z_simple (prt, (random - integral) / tstep)
integral = integral + tstep * temp1
if (integral > random) then
prt%t = t + 0.5_default * tstep
exit
end if
t = t + tstep
end do
if (prt%t > - shower%settings%min_virtuality) then
call shower_replace_parent_by_hadron (shower, prt)
end if
contains
function integral_over_z_simple (prt, final) result (integral)
type(parton_t), intent(inout) :: prt
real(default), intent(in) :: final
real(default) :: integral
real(default), parameter :: zstepfactor = one
real(default), parameter :: zstepmin = 0.0001_default
real(default) :: z, zstep, minz, maxz
real(default) :: pdfsum
integer :: quark, d_nf
integral = zero
if (debug2_active (D_SHOWER)) then
print *, "D: integral_over_z_simple: t = ", prt%t
end if
minz = prt%x
! maxz = maxzz(shat, s, shower%settings%isr_z_cutoff, shower%settings%isr_minenergy)
maxz = shower%settings%isr_z_cutoff
z = minz
d_nf = shower%settings%max_n_flavors
!!! TODO -> Adapt zstep to structure of divergencies
if (prt%child1%is_gluon ()) then
!!! gluon coming from g->gg
do
call shower%rng%generate (temprand)
zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
zstep = min(zstep, maxz - z)
integral = integral + zstep * (D_alpha_s_isr ((one - &
(z + 0.5_default * zstep)) * abs(prt%t), &
shower%settings) / (abs(prt%t))) * &
P_ggg (z + 0.5_default * zstep) * &
shower%get_pdf (prt%initial%type, &
prt%x / (z + 0.5_default * zstep), abs(prt%t), GLUON)
if (integral > final) then
exit
end if
z = z + zstep
if (z >= maxz) then
exit
end if
end do
!!! gluon coming from q->qg ! correctly implemented yet?
if (integral < final) then
z = minz
do
call shower%rng%generate (temprand)
zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
zstep = min(zstep, maxz - z)
pdfsum = zero
do quark = -d_nf, d_nf
if (quark == 0) cycle
pdfsum = pdfsum + shower%get_pdf (prt%initial%type, &
prt%x / (z + 0.5_default * zstep), abs(prt%t), quark)
end do
integral = integral + zstep * (D_alpha_s_isr &
((z + 0.5_default * zstep) * abs(prt%t), &
shower%settings) / (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 (prt%child1%is_quark ()) then
!!! quark coming from q->qg
do
call shower%rng%generate(temprand)
zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
zstep = min(zstep, maxz - z)
integral = integral + zstep * (D_alpha_s_isr ((one - &
(z + 0.5_default * zstep)) * abs(prt%t), &
shower%settings) / (abs(prt%t))) * &
P_qqg (z + 0.5_default * zstep) * &
shower%get_pdf (prt%initial%type, &
prt%x / (z + 0.5_default * zstep), abs(prt%t), prt%type)
if (integral > final) then
exit
end if
z = z + zstep
if (z >= maxz) then
exit
end if
end do
!!! quark coming from g->qqbar
if (integral < final) then
z = minz
do
call shower%rng%generate (temprand)
zstep = max(zstepmin, temprand * zstepfactor * z*(one - z))
zstep = min(zstep, maxz - z)
integral = integral + zstep * (D_alpha_s_isr &
((one - (z + 0.5_default * zstep)) * abs(prt%t), &
shower%settings) / (abs(prt%t))) * &
P_gqq (z + 0.5_default * zstep) * &
shower%get_pdf (prt%initial%type, &
prt%x / (z + 0.5_default * zstep), abs(prt%t), GLUON)
if (integral > final) then
exit
end if
z = z + zstep
if (z >= maxz) then
exit
end if
end do
end if
end if
integral = integral / shower%get_pdf (prt%initial%type, prt%x, &
abs(prt%t), prt%type)
end function integral_over_z_simple
end subroutine shower_get_first_ISR_scale_for_parton
@ %def shower_get_first_ISR_scale_for_parton
@
<<Shower core: procedures>>=
subroutine shower_prepare_for_simulate_isr_pt (shower, interaction)
type(shower_t), intent(inout) :: shower
type(shower_interaction_t), intent(inout) :: interaction
real(default) :: s
s = (interaction%partons(1)%p%momentum + &
interaction%partons(2)%p%momentum)**2
interaction%partons(1)%p%scale = shower%settings%isr_tscalefactor * 0.25_default * s
interaction%partons(2)%p%scale = shower%settings%isr_tscalefactor * 0.25_default * s
end subroutine shower_prepare_for_simulate_isr_pt
@ %def shower_prepare_for_simulate_isr_pt
@
<<Shower core: procedures>>=
subroutine shower_prepare_for_simulate_isr_ana_test (shower, prt1, prt2)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt1, prt2
type(parton_t), pointer :: prt, prta, prtb
real(default) :: scale, factor, E
integer :: i
if (.not. associated (prt1%initial) .or. .not. associated (prt2%initial)) then
return
end if
scale = - (prt1%momentum + prt2%momentum) ** 2
call prt1%set_simulated ()
call prt2%set_simulated ()
call shower%add_parent (prt1)
call shower%add_parent (prt2)
factor = sqrt (energy (prt1%momentum)**2 - scale) / &
space_part_norm(prt1%momentum)
prt1%parent%type = prt1%type
prt1%parent%z = one
prt1%parent%momentum = prt1%momentum
prt1%parent%t = scale
prt1%parent%x = prt1%x
prt1%parent%initial => prt1%initial
prt1%parent%belongstoFSR = .false.
prt1%parent%c1 = prt1%c1
prt1%parent%c2 = prt1%c2
prt2%parent%type= prt2%type
prt2%parent%z = one
prt2%parent%momentum = prt2%momentum
prt2%parent%t = scale
prt2%parent%x = prt2%x
prt2%parent%initial => prt2%initial
prt2%parent%belongstoFSR = .false.
prt2%parent%c1 = prt2%c1
prt2%parent%c2 = prt2%c2
do
call shower_get_first_ISR_scale_for_parton (shower, prt1%parent)
call shower_get_first_ISR_scale_for_parton (shower, prt2%parent)
!!! redistribute energy among first partons
prta => prt1%parent
prtb => prt2%parent
E = energy (prt1%momentum + prt2%momentum)
prta%momentum%p(0) = (E**2 - prtb%t + prta%t) / (two * E)
prtb%momentum%p(0) = E - prta%momentum%p(0)
exit
end do
call prt1%parent%set_simulated ()
call prt2%parent%set_simulated ()
!!! rescale momenta
do i = 1, 2
if (i == 1) then
prt => prt1%parent
else
prt => prt2%parent
end if
factor = sqrt (energy (prt%momentum)**2 - prt%t) &
/ space_part_norm (prt%momentum)
prt%momentum = vector4_moving (energy (prt%momentum), &
factor * space_part (prt%momentum))
end do
if (prt1%parent%t < zero) then
call shower%add_parent (prt1%parent)
prt1%parent%parent%momentum = prt1%parent%momentum
prt1%parent%parent%t = prt1%parent%t
prt1%parent%parent%x = prt1%parent%x
prt1%parent%parent%initial => prt1%parent%initial
prt1%parent%parent%belongstoFSR = .false.
call shower%add_child (prt1%parent%parent, 2)
end if
if (prt2%parent%t < zero) then
call shower%add_parent (prt2%parent)
prt2%parent%parent%momentum = prt2%parent%momentum
prt2%parent%parent%t = prt2%parent%t
prt2%parent%parent%x = prt2%parent%x
prt2%parent%parent%initial => prt2%parent%initial
prt2%parent%parent%belongstoFSR = .false.
call shower%add_child (prt2%parent%parent, 2)
end if
end subroutine shower_prepare_for_simulate_isr_ana_test
@ %def shower_prepare_for_simulate_isr_ana_test
@
<<Shower core: procedures>>=
subroutine shower_add_children_of_emitted_timelike_parton (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), pointer :: prt
if (prt%t > prt%mass_squared () + shower%settings%min_virtuality) then
if (prt%is_quark ()) then
!!! q -> qg
call shower%add_child (prt, 1)
prt%child1%type = prt%type
prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
prt%child1%t = prt%t
call shower%add_child (prt, 2)
prt%child2%type = GLUON
prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
prt%child2%t = prt%t
else
if (int (prt%x) > 0) then
call shower%add_child (prt, 1)
prt%child1%type = int (prt%x)
prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
prt%child1%t = prt%t
call shower%add_child (prt, 2)
prt%child2%type = -int (prt%x)
prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
prt%child2%t= prt%t
else
call shower%add_child (prt, 1)
prt%child1%type = GLUON
prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
prt%child1%t = prt%t
call shower%add_child (prt, 2)
prt%child2%type = GLUON
prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
prt%child2%t = prt%t
end if
end if
end if
end subroutine shower_add_children_of_emitted_timelike_parton
@ %def shower_add_children_of_emitted_timelike_parton
@
<<Shower core: procedures>>=
subroutine shower_simulate_children_ana (shower,prt)
type(shower_t), intent(inout), target :: shower
type(parton_t), intent(inout) :: prt
real(default), dimension(1:2) :: t, random, integral
integer, dimension(1:2) :: gtoqq
integer :: daughter
type(parton_t), pointer :: daughterprt
integer :: n_loop
if (signal_is_pending ()) return
if (debug2_active (D_SHOWER)) &
print *, "D: shower_simulate_children_ana: for parton " , prt%nr
gtoqq = 0
if (.not. associated (prt%child1) .or. .not. associated (prt%child2)) then
call msg_error ("Shower: error in simulate_children_ana: no children.")
return
end if
<<Set beam-remnants and internal partons as simulated>>
integral = zero
!!! impose constraints by angular ordering -> cf. (26) of Gaining analytic control
!!! check if no branchings are possible
if (.not. prt%child1%simulated) then
prt%child1%t = min (prt%child1%t, &
0.5_default * prt%child1%momentum%p(0)**2 * (one - &
prt%get_costheta ()))
if (.not. associated (prt%child1%settings)) &
prt%child1%settings => shower%settings
if (min (prt%child1%t, prt%child1%momentum%p(0)**2) < &
prt%child1%mass_squared () + &
prt%child1%settings%min_virtuality) then
prt%child1%t = prt%child1%mass_squared ()
call prt%child1%set_simulated ()
end if
end if
if (.not. prt%child2%simulated) then
prt%child2%t = min (prt%child2%t, &
0.5_default * prt%child2%momentum%p(0)**2 * (one - &
prt%get_costheta ()))
if (.not. associated (prt%child2%settings)) &
prt%child2%settings => shower%settings
if (min (prt%child2%t, prt%child2%momentum%p(0)**2) < &
prt%child2%mass_squared () + &
prt%child2%settings%min_virtuality) then
prt%child2%t = prt%child2%mass_squared ()
call prt%child2%set_simulated ()
end if
end if
call shower%rng%generate (random)
n_loop = 0
do
if (signal_is_pending ()) return
n_loop = n_loop + 1
if (n_loop > 900) then
!!! try with massless quarks
treat_duscb_quarks_massless = .true.
end if
if (n_loop > 1000) then
call msg_message ("simulate_children_ana failed for parton ", prt%nr)
call msg_warning ("too many loops in simulate_children_ana")
call shower%write ()
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
if (.not. prt%child1%simulated) then
call parton_simulate_stept &
(prt%child1, shower%rng, integral(1), random(1), gtoqq(1))
end if
if (.not. prt%child2%simulated) then
call parton_simulate_stept &
(prt%child2, shower%rng, integral(2), random(2), gtoqq(2))
end if
if (prt%child1%simulated .and. prt%child2%simulated) then
if (sqrt (prt%t) <= sqrt (prt%child1%t) + sqrt (prt%child2%t)) then
<<Repeat the simulation for the parton with the lower virtuality>>
else
exit
end if
end if
end do
call parton_apply_costheta (prt, shower%rng)
<<Add children>>
call shower_parton_update_color_connections (shower, prt)
end subroutine shower_simulate_children_ana
@ %def shower_simulate_children_ana
@
<<Set beam-remnants and internal partons as simulated>>=
if (HADRON_REMNANT <= abs (prt%type) .and. abs (prt%type) <= HADRON_REMNANT_OCTET) then
!!! prt is beam-remnant
call prt%set_simulated ()
return
end if
!!! check if partons are "internal" -> fixed scale
if (prt%child1%type == INTERNAL) then
call prt%child1%set_simulated ()
end if
if (prt%child2%type == INTERNAL) then
call prt%child2%set_simulated ()
end if
@
<<Repeat the simulation for the parton with the lower virtuality>>=
!!! virtuality : t - m**2 (assuming it's not fixed)
if (prt%child1%type == INTERNAL .and. prt%child2%type == INTERNAL) then
call msg_fatal &
("Shower: both partons fixed, but momentum not conserved")
else if (prt%child1%type == INTERNAL) then
!!! reset child2
call prt%child2%set_simulated (.false.)
prt%child2%t = min (prt%child1%t, (sqrt (prt%t) - &
sqrt (prt%child1%t))**2)
integral(2) = zero
call shower%rng%generate (random(2))
else if (prt%child2%type == INTERNAL) then
! reset child1
call prt%child1%set_simulated (.false.)
prt%child1%t = min (prt%child2%t, (sqrt (prt%t) - &
sqrt (prt%child2%t))**2)
integral(1) = zero
call shower%rng%generate (random(1))
else if (prt%child1%t - prt%child1%mass_squared () > &
prt%child2%t - prt%child2%mass_squared ()) then
!!! reset child2
call prt%child2%set_simulated (.false.)
prt%child2%t = min (prt%child1%t, (sqrt (prt%t) - &
sqrt (prt%child1%t))**2)
integral(2) = zero
call shower%rng%generate (random(2))
else
!!! reset child1 ! TODO choose child according to their t
call prt%child1%set_simulated (.false.)
prt%child1%t = min (prt%child2%t, (sqrt (prt%t) - &
sqrt (prt%child2%t))**2)
integral(1) = zero
call shower%rng%generate (random(1))
end if
@
<<Add children>>=
if (.not. associated (prt%child1%settings)) &
prt%child1%settings => shower%settings
if (.not. associated (prt%child2%settings)) &
prt%child2%settings => shower%settings
do daughter = 1, 2
if (signal_is_pending ()) return
if (daughter == 1) then
daughterprt => prt%child1
else
daughterprt => prt%child2
end if
if (daughterprt%t < daughterprt%mass_squared () + &
daughterprt%settings%min_virtuality) then
cycle
end if
if (.not. (daughterprt%is_quark () .or. daughterprt%is_gluon ())) then
cycle
end if
if (daughterprt%is_quark ()) then
!!! q -> qg
call shower%add_child (daughterprt, 1)
daughterprt%child1%type = daughterprt%type
daughterprt%child1%momentum%p(0) = daughterprt%z * &
daughterprt%momentum%p(0)
daughterprt%child1%t = daughterprt%t
call shower%add_child (daughterprt, 2)
daughterprt%child2%type = GLUON
daughterprt%child2%momentum%p(0) = (one - daughterprt%z) * &
daughterprt%momentum%p(0)
daughterprt%child2%t = daughterprt%t
else if (daughterprt%is_gluon ()) then
if (gtoqq(daughter) > 0) then
call shower%add_child (daughterprt, 1)
daughterprt%child1%type = gtoqq (daughter)
daughterprt%child1%momentum%p(0) = &
daughterprt%z * daughterprt%momentum%p(0)
daughterprt%child1%t = daughterprt%t
call shower%add_child (daughterprt, 2)
daughterprt%child2%type = - gtoqq (daughter)
daughterprt%child2%momentum%p(0) = (one - &
daughterprt%z) * daughterprt%momentum%p(0)
daughterprt%child2%t = daughterprt%t
else
call shower%add_child (daughterprt, 1)
daughterprt%child1%type = GLUON
daughterprt%child1%momentum%p(0) = &
daughterprt%z * daughterprt%momentum%p(0)
daughterprt%child1%t = daughterprt%t
call shower%add_child (daughterprt, 2)
daughterprt%child2%type = GLUON
daughterprt%child2%momentum%p(0) = (one - &
daughterprt%z) * daughterprt%momentum%p(0)
daughterprt%child2%t = daughterprt%t
end if
end if
end do
@
@ The recoiler is [[otherprt]]. Instead of the random number and the
exponential of the integral, we compare the logarithm of the random
number and the integral.
<<Shower core: procedures>>=
subroutine shower_isr_step_pt (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), target, intent(inout) :: prt
type(parton_t), pointer :: otherprt
real(default) :: scale, scalestep
real(default) :: integral, random, factor
real(default) :: temprand1, temprand2
otherprt => shower%find_recoiler (prt)
scale = prt%scale
call shower%rng%generate (temprand1)
call shower%rng%generate (temprand2)
scalestep = max (abs (scalefactor1 * scale) * temprand1, &
scalefactor2 * temprand2 * D_Min_scale)
call shower%rng%generate (random)
random = - twopi * log(random)
integral = zero
if (scale - 0.5_default * scalestep < D_Min_scale) then
!!! close enough to cut-off scale -> ignore
prt%scale = zero
prt%t = prt%mass_squared ()
call prt%set_simulated ()
else
prt%scale = scale - 0.5_default * scalestep
factor = scalestep * (D_alpha_s_isr (prt%scale, &
shower%settings) / (prt%scale * &
shower%get_pdf (prt%initial%type, prt%x, prt%scale, prt%type)))
integral = integral + factor * integral_over_z_isr_pt &
(prt, otherprt, (random - integral) / factor)
if (integral > random) then
!!! prt%scale set above and prt%z set in integral_over_z_isr_pt
call prt%set_simulated ()
prt%t = - prt%scale / (one - prt%z)
else
prt%scale = scale - scalestep
end if
end if
contains
function integral_over_z_isr_pt (prt, otherprt, final) &
result (integral)
type(parton_t), intent(inout) :: prt, otherprt
real(default), intent(in) :: final
real(default) :: integral
real(default) :: mbr, r
real(default) :: zmin, zmax, z, zstep
integer :: n_bin
integer, parameter :: n_total_bins = 100
real(default) :: quarkpdfsum
real(default) :: temprand
integer :: quark, d_nf
quarkpdfsum = zero
d_nf = shower%settings%max_n_flavors
if (debug2_active (D_SHOWER)) then
print *, "D: integral_over_z_isr_pt: for scale = ", prt%scale
end if
integral = zero
mbr = (prt%momentum + otherprt%momentum)**1
zmin = prt%x
zmax = min (one - (sqrt (prt%scale) / mbr) * &
(sqrt(one + 0.25_default * prt%scale / mbr**2) - &
0.25_default * sqrt(prt%scale) / mbr), shower%settings%isr_z_cutoff)
zstep = (zmax - zmin) / n_total_bins
if (debug_active (D_SHOWER)) then
if (zmin > zmax) then
call msg_bug(" error in integral_over_z_isr_pt: zmin > zmax ")
integral = zero
end if
end if
!!! divide the range [zmin:zmax] in n_total_bins
BINS: do n_bin = 1, n_total_bins
z = zmin + zstep * (n_bin - 0.5_default)
!!! z-value in the middle of the bin
if (prt%is_gluon ()) then
QUARKS: do quark = -d_nf, d_nf
if (quark == 0) cycle quarks
quarkpdfsum = quarkpdfsum + shower%get_pdf &
(prt%initial%type, prt%x / z, prt%scale, quark)
end do QUARKS
!!! g -> gg or q -> gq
integral = integral + (zstep / z) * ((P_ggg (z) + &
P_ggg (one - z)) * shower%get_pdf (prt%initial%type, &
prt%x / z, prt%scale, GLUON) + P_qqg (one - z) * quarkpdfsum)
else if (prt%is_quark ()) then
!!! q -> qg or g -> qq
integral = integral + (zstep / z) * ( P_qqg (z) * &
shower%get_pdf (prt%initial%type, prt%x / z, prt%scale, &
prt%type) + &
P_gqq(z) * shower%get_pdf (prt%initial%type, prt%x / z, &
prt%scale, GLUON))
else
! call msg_fatal ("Bug neither quark nor gluon in" &
! // " integral_over_z_isr_pt")
end if
if (integral > final) then
prt%z = z
call shower%rng%generate (temprand)
!!! decide type of father partons
if (prt%is_gluon ()) then
if (temprand > (P_qqg (one - z) * quarkpdfsum) / &
((P_ggg (z) + P_ggg (one - z)) * shower%get_pdf &
(prt%initial%type, prt%x / z, prt%scale, GLUON) &
+ P_qqg (one - z) * quarkpdfsum)) then
!!! gluon => gluon + gluon
prt%aux_pt = GLUON
else
!!! quark => quark + gluon
!!! decide which quark flavor the parent is
r = temprand * quarkpdfsum
WHICH_QUARK: do quark = -d_nf, d_nf
if (quark == 0) cycle WHICH_QUARK
if (r > quarkpdfsum - shower%get_pdf (prt%initial%type, &
prt%x / z, prt%scale, quark)) then
prt%aux_pt = quark
exit WHICH_QUARK
else
quarkpdfsum = quarkpdfsum - shower%get_pdf &
(prt%initial%type, prt%x / z, prt%scale, quark)
end if
end do WHICH_QUARK
end if
else if (prt%is_quark ()) then
if (temprand > (P_qqg (z) * shower%get_pdf (prt%initial%type, &
prt%x / z, prt%scale, prt%type)) / &
(P_qqg (z) * shower%get_pdf (prt%initial%type, prt%x / z, &
prt%scale, prt%type) + &
P_gqq (z) * shower%get_pdf (prt%initial%type, prt%x / z, &
prt%scale, GLUON))) then
!!! gluon => quark + antiquark
prt%aux_pt = GLUON
else
!!! quark => quark + gluon
prt%aux_pt = prt%type
end if
end if
exit BINS
end if
end do BINS
end function integral_over_z_isr_pt
end subroutine shower_isr_step_pt
@ %def shower_isr_step_pt
@ This function returns a pointer to the parton with the next ISR
branching, while FSR branchings are ignored.
<<Shower core: shower: TBP>>=
procedure :: generate_next_isr_branching_veto => &
shower_generate_next_isr_branching_veto
<<Shower core: procedures>>=
function shower_generate_next_isr_branching_veto &
(shower) result (next_brancher)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t) :: next_brancher
integer :: i
type(parton_t), pointer :: prt
real(default) :: random
!!! pointers to branchable partons
type(parton_pointer_t), dimension(:), allocatable :: partons
integer :: n_partons
real(default) :: weight
real(default) :: temp1, temp2, temp3, E3
if (signal_is_pending ()) return
if (shower%settings%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 (.not. associated (prt)) cycle
if (prt%belongstoFSR) cycle
if (prt%is_final ()) cycle
if (.not. prt%belongstoFSR .and. prt%simulated) cycle
n_partons = n_partons + 1
end do
if (n_partons == 0) then
return
end if
allocate (partons(1:n_partons))
n_partons = 1
do i = 1, size (shower%partons)
prt => shower%partons(i)%p
if (.not. associated (prt)) cycle
if (prt%belongstoFSR) cycle
if (prt%is_final ()) cycle
if (.not. prt%belongstoFSR .and. prt%simulated) cycle
partons(n_partons)%p => shower%partons(i)%p
n_partons = n_partons + 1
end do
!!! generate initial trial scales
do i = 1, size (partons)
if (signal_is_pending ()) return
call generate_next_trial_scale (partons(i)%p)
end do
do
!!! search for parton with the highest trial scale
prt => partons(1)%p
do i = 1, size (partons)
if (prt%t >= zero) cycle
if (abs (partons(i)%p%t) > abs (prt%t)) then
prt => partons(i)%p
end if
end do
if (prt%t >= zero) then
next_brancher%p => null()
exit
end if
!!! generate trial z and type of mother prt
call generate_trial_z_and_typ (prt)
!!! weight with pdf and alpha_s
temp1 = (D_alpha_s_isr ((one - prt%z) * abs(prt%t), &
shower%settings) / sqrt (alphasxpdfmax))
temp2 = shower%get_xpdf (prt%initial%type, prt%x, prt%t, &
prt%type) / sqrt (alphasxpdfmax)
temp3 = shower%get_xpdf (prt%initial%type, prt%child1%x, prt%child1%t, &
prt%child1%type) / &
shower%get_xpdf (prt%initial%type, prt%child1%x, prt%t, &
prt%child1%type)
! TODO: (bcn 2015-02-19) ???
if (temp1 * temp2 * temp3 > one) then
print *, "weights:", temp1, temp2, temp3
end if
weight = (D_alpha_s_isr ((one - prt%z) * abs(prt%t), &
shower%settings)) * &
shower%get_xpdf (prt%initial%type, prt%x, prt%t, prt%type) * &
shower%get_xpdf (prt%initial%type, prt%child1%x, prt%child1%t, &
prt%child1%type) / &
shower%get_xpdf &
(prt%initial%type, prt%child1%x, prt%t, prt%child1%type)
if (weight > alphasxpdfmax) then
print *, "Setting alphasxpdfmax from ", alphasxpdfmax, " to ", weight
alphasxpdfmax = weight
end if
weight = weight / alphasxpdfmax
call shower%rng%generate (random)
if (weight < random) then
!!! discard branching
call generate_next_trial_scale (prt)
cycle
end if
!!! branching accepted so far
!!! generate emitted parton
prt%child2%t = abs(prt%t)
prt%child2%momentum%p(0) = sqrt (abs(prt%t))
if (shower%settings%isr_only_onshell_emitted_partons) then
prt%child2%t = prt%child2%mass_squared ()
else
call prt%child2%next_t_ana (shower%rng)
end if
if (thetabar (prt, shower%find_recoiler (prt), &
shower%settings%isr_angular_ordered, E3)) then
prt%momentum%p(0) = E3
prt%child2%momentum%p(0) = E3 - prt%child1%momentum%p(0)
!!! found branching
call prt%generate_ps_ini (shower%rng)
next_brancher%p => prt
call prt%set_simulated ()
exit
else
call generate_next_trial_scale (prt)
cycle
end if
end do
if (.not. associated (next_brancher%p)) then
!!! no further branching found -> all partons emitted by hadron
print *, "--all partons emitted by hadrons---"
do i = 1, size(partons)
call shower_replace_parent_by_hadron (shower, partons(i)%p%child1)
end do
end if
!!! some bookkeeping
call shower%sort_partons ()
! call shower%boost_to_CMframe () ! really necessary?
! call shower%rotate_to_z () ! really necessary?
contains
subroutine generate_next_trial_scale (prt)
type(parton_t), pointer, intent(inout) :: prt
real(default) :: random, F
real(default) :: zmax = 0.99_default !! ??
call shower%rng%generate (random)
F = one !!! TODO
F = alphasxpdfmax / (two * pi)
if (prt%child1%is_quark ()) then
F = F * (integral_over_P_gqq (prt%child1%x, zmax) + &
integral_over_P_qqg (prt%child1%x, zmax))
else if (prt%child1%is_gluon ()) then
F = F * (integral_over_P_ggg (prt%child1%x, zmax) + &
two * shower%settings%max_n_flavors * &
integral_over_P_qqg (one - zmax, one - prt%child1%x))
else
call msg_bug("neither quark nor gluon in generate_next_trial_scale")
end if
F = F / shower%get_xpdf (prt%child1%initial%type, prt%child1%x, &
prt%child1%t, prt%child1%type)
prt%t = prt%t * random**(one / F)
if (abs (prt%t) - prt%mass_squared () < &
prt%settings%min_virtuality) then
prt%t = prt%mass_squared ()
end if
end subroutine generate_next_trial_scale
subroutine generate_trial_z_and_typ (prt)
type(parton_t), pointer, intent(inout) :: prt
real(default) :: random
real(default) :: z, zstep, zmin, integral
real(default) :: zmax = 0.99_default !! ??
call msg_debug (D_SHOWER, "generate_trial_z_and_typ")
call shower%rng%generate (random)
integral = zero
!!! decide which branching a->bc occurs
if (prt%child1%is_quark ()) then
if (random < integral_over_P_qqg (prt%child1%x, zmax) / &
(integral_over_P_qqg (prt%child1%x, zmax) + &
integral_over_P_gqq (prt%child1%x, zmax))) then
prt%type = prt%child1%type
prt%child2%type = GLUON
integral = integral_over_P_qqg (prt%child1%x, zmax)
else
prt%type = GLUON
prt%child2%type = - prt%child1%type
integral = integral_over_P_gqq (prt%child1%x, zmax)
end if
else if (prt%child1%is_gluon ()) then
if (random < integral_over_P_ggg (prt%child1%x, zmax) / &
(integral_over_P_ggg (prt%child1%x, zmax) + two * &
shower%settings%max_n_flavors * &
integral_over_P_qqg (one - zmax, &
one - prt%child1%x))) then
prt%type = GLUON
prt%child2%type = GLUON
integral = integral_over_P_ggg (prt%child1%x, zmax)
else
call shower%rng%generate (random)
prt%type = 1 + floor(random * shower%settings%max_n_flavors)
call shower%rng%generate (random)
if (random > 0.5_default) prt%type = - prt%type
prt%child2%type = prt%type
integral = integral_over_P_qqg (one - zmax, &
one - prt%child1%x)
end if
else
call msg_bug("neither quark nor gluon in generate_next_trial_scale")
end if
!!! generate the z-value
!!! z between prt%child1%x and zmax
! prt%z = one - random * (one - prt%child1%x) ! TODO
call shower%rng%generate (random)
zmin = prt%child1%x
zstep = max(0.1_default, 0.5_default * (zmax - zmin))
z = zmin
if (zmin > zmax) then
print *, " zmin = ", zmin, " zmax = ", zmax
call msg_fatal ("Shower: zmin greater than zmax")
end if
!!! procedure pointers would be helpful here
if (prt%is_quark () .and. prt%child1%is_quark ()) then
do
zstep = min(zstep, 0.5_default * (zmax - z))
if (abs(zstep) < 0.00001) exit
if (integral_over_P_qqg (zmin, z) < random * integral) then
if (integral_over_P_qqg (zmin, min(z + zstep, zmax)) &
< random * integral) then
z = min (z + zstep, zmax)
cycle
else
zstep = zstep * 0.5_default
cycle
end if
end if
end do
else if (prt%is_quark () .and. prt%child1%is_gluon ()) then
do
zstep = min(zstep, 0.5_default * (zmax - z))
if (abs(zstep) < 0.00001) exit
if (integral_over_P_qqg (zmin, z) < random * integral) then
if (integral_over_P_qqg (zmin, min(z + zstep, zmax)) &
< random * integral) then
z = min(z + zstep, zmax)
cycle
else
zstep = zstep * 0.5_default
cycle
end if
end if
end do
else if (prt%is_gluon () .and. prt%child1%is_quark ()) then
do
zstep = min(zstep, 0.5_default * (zmax - z))
if (abs (zstep) < 0.00001) exit
if (integral_over_P_gqq (zmin, z) < random * integral) then
if (integral_over_P_gqq (zmin, min(z + zstep, zmax)) &
< random * integral) then
z = min (z + zstep, zmax)
cycle
else
zstep = zstep * 0.5_default
cycle
end if
end if
end do
else if (prt%is_gluon () .and. prt%child1%is_gluon ()) then
do
zstep = min(zstep, 0.5_default * (zmax - z))
if (abs (zstep) < 0.00001) exit
if (integral_over_P_ggg (zmin, z) < random * integral) then
if (integral_over_P_ggg (zmin, min(z + zstep, zmax)) &
< random * integral) then
z = min(z + zstep, zmax)
cycle
else
zstep = zstep * 0.5_default
cycle
end if
end if
end do
else
end if
prt%z = z
prt%x = prt%child1%x / prt%z
end subroutine generate_trial_z_and_typ
end function shower_generate_next_isr_branching_veto
@ %def shower_generate_next_isr_branching_veto
@
<<Shower core: shower: TBP>>=
procedure :: find_recoiler => shower_find_recoiler
<<Shower core: procedures>>=
function shower_find_recoiler (shower, prt) result(recoiler)
class(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
type(parton_t), pointer :: recoiler
type(parton_t), pointer :: otherprt1, otherprt2
integer :: n_int
otherprt1 => null()
otherprt2 => null()
DO_INTERACTIONS: do n_int = 1, size(shower%interactions)
otherprt1 => shower%interactions(n_int)%i%partons(1)%p
otherprt2 => shower%interactions(n_int)%i%partons(2)%p
PARTON1: do
if (associated (otherprt1%parent)) then
if (.not. otherprt1%parent%is_proton () .and. &
otherprt1%parent%simulated) then
otherprt1 => otherprt1%parent
if (associated (otherprt1, prt)) then
exit PARTON1
end if
else
exit PARTON1
end if
else
exit PARTON1
end if
end do PARTON1
PARTON2: do
if (associated (otherprt2%parent)) then
if (.not. otherprt2%parent%is_proton () .and. &
otherprt2%parent%simulated) then
otherprt2 => otherprt2%parent
if (associated (otherprt2, prt)) then
exit PARTON2
end if
else
exit PARTON2
end if
else
exit PARTON2
end if
end do PARTON2
if (associated (otherprt1, prt) .or. associated (otherprt2, prt)) then
exit DO_INTERACTIONS
end if
if (associated (otherprt1%parent, prt) .or. &
associated (otherprt2%parent, prt)) then
exit DO_INTERACTIONS
end if
end do DO_INTERACTIONS
recoiler => null()
if (associated (otherprt1%parent, prt)) then
recoiler => otherprt2
else if (associated (otherprt2%parent, prt)) then
recoiler => otherprt1
else if (associated (otherprt1, prt)) then
recoiler => otherprt2
else if (associated (otherprt2, prt)) then
recoiler => otherprt1
else
call shower%write ()
call prt%write ()
call msg_error ("shower_find_recoiler: 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
integer :: d_nf
otherprt => shower%find_recoiler (prt)
! if (.not. otherprt%child1%belongstointeraction) then
! otherprt => otherprt%child1
! end if
if (signal_is_pending ()) return
t = max(prt%t, prt%child1%t)
call shower%rng%generate (random)
d_nf = shower%settings%max_n_flavors
! compare Integral and log(random) instead of random and exp(-Integral)
random = - twopi * log(random)
integral = zero
call shower%rng%generate (temprand1)
call shower%rng%generate (temprand2)
tstep = max (abs (0.02_default * t) * temprand1, &
0.02_default * temprand2 * shower%settings%min_virtuality)
if (t + 0.5_default * tstep > - shower%settings%min_virtuality) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
else
prt%t = t + 0.5_default * tstep
integral = integral + tstep * &
integral_over_z_isr (prt, otherprt,(random - integral) / tstep)
if (integral > random) then
prt%t = t + 0.5_default * tstep
prt%x = prt%child1%x / prt%z
call prt%set_simulated ()
else
prt%t = t + tstep
end if
end if
contains
function integral_over_z_isr (prt, otherprt, final) result (integral)
type(parton_t), intent(inout) :: prt, otherprt
real(default), intent(in) :: final
real(default) integral
real(default) :: minz, maxz, z, shat,s
integer :: quark
!!! calculate shat -> s of parton-parton system
shat = (otherprt%momentum + prt%child1%momentum)**2
!!! calculate s -> s of hadron-hadron system
s = (otherprt%initial%momentum + prt%initial%momentum)**2
integral = zero
minz = prt%child1%x
maxz = maxzz (shat, s, shower%settings%isr_z_cutoff, shower%settings%isr_minenergy)
!!! for gluon
if (prt%child1%is_gluon ()) then
!!! 1: g->gg
prt%type = GLUON
prt%child2%type = GLUON
z = minz
prt%child2%t = abs(prt%t)
call integral_over_z_part_isr &
(prt, otherprt, shat, minz, maxz, integral, final)
if (integral > final) then
return
end if
!!! 2: q->gq
do quark = -d_nf, d_nf
if (quark == 0) cycle
prt%type = quark
prt%child2%type = quark
z = minz
prt%child2%t = abs(prt%t)
call integral_over_z_part_isr &
(prt, otherprt, shat, minz, maxz, integral, final)
if (integral > final) then
return
end if
end do
else if (prt%child1%is_quark ()) then
!!! 1: q->qg
prt%type = prt%child1%type
prt%child2%type = GLUON
z = minz
prt%child2%t = abs(prt%t)
call integral_over_z_part_isr &
(prt,otherprt, shat, minz, maxz, integral, final)
if (integral > final) then
return
end if
!!! 2: g->qqbar
prt%type = GLUON
prt%child2%type = -prt%child1%type
z = minz
prt%child2%t = abs(prt%t)
call integral_over_z_part_isr &
(prt,otherprt, shat, minz, maxz, integral, final)
if (integral > final) then
return
end if
end if
end function integral_over_z_isr
subroutine integral_over_z_part_isr &
(prt, otherprt, shat ,minz, maxz, retvalue, final)
type(parton_t), intent(inout) :: prt, otherprt
real(default), intent(in) :: shat, minz, maxz, final
real(default), intent(inout) :: retvalue
real(default) :: z, zstep
real(default) :: r1,r3,s1,s3
real(default) :: pdf_divisor
real(default) :: temprand
real(default), parameter :: zstepfactor = 0.1_default
real(default), parameter :: zstepmin = 0.0001_default
call msg_debug2 (D_SHOWER, "integral_over_z_part_isr")
if (signal_is_pending ()) return
pdf_divisor = shower%get_pdf &
(prt%initial%type, prt%child1%x, prt%t, prt%child1%type)
z = minz
s1 = shat + abs(otherprt%t) + abs(prt%child1%t)
r1 = sqrt (s1**2 - four * abs(otherprt%t * prt%child1%t))
ZLOOP: do
if (signal_is_pending ()) return
if (z >= maxz) then
exit
end if
call shower%rng%generate (temprand)
if (prt%child1%is_gluon ()) then
if (prt%is_gluon ()) 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 (prt%is_gluon ()) then
!!! g-> qqbar -> no divergencies
zstep = max(zstepmin, temprand * zstepfactor)
else
!!! q-> qg -> divergencies at z->1
zstep = max(zstepmin, temprand * zstepfactor * (one - z))
end if
end if
zstep = min(zstep, maxz - z)
prt%z = z + 0.5_default * zstep
s3 = shat / prt%z + abs(otherprt%t) + abs(prt%t)
r3 = sqrt (s3**2 - four * abs(otherprt%t * prt%t))
!!! TODO: WHY is this if needed?
if (abs(otherprt%t) > eps0) then
prt%child2%t = min ((s1 * s3 - r1 * r3) / &
(two * abs(otherprt%t)) - abs(prt%child1%t) - &
abs(prt%t), abs(prt%child1%t))
else
prt%child2%t = abs(prt%child1%t)
end if
do
prt%child2%momentum%p(0) = sqrt (abs(prt%child2%t))
if (shower%settings%isr_only_onshell_emitted_partons) then
prt%child2%t = prt%child2%mass_squared ()
else
call prt%child2%next_t_ana (shower%rng)
end if
!!! take limits by recoiler into account
prt%momentum%p(0) = (shat / prt%z + &
abs(otherprt%t) - abs(prt%child1%t) - &
prt%child2%t) / (two * sqrt(shat))
prt%child2%momentum%p(0) = &
prt%momentum%p(0) - prt%child1%momentum%p(0)
!!! check if E and t of prt%child2 are consistent
if (prt%child2%momentum%p(0)**2 < prt%child2%t &
.and. prt%child2%t > prt%child2%mass_squared ()) then
!!! E is too small to have p_T^2 = E^2 - t > 0
!!! -> cycle to find another solution
cycle
else
!!! E is big enough -> exit
exit
end if
end do
if (thetabar (prt, otherprt, shower%settings%isr_angular_ordered) &
.and. pdf_divisor > zero &
.and. prt%child2%momentum%p(0) > zero) then
retvalue = retvalue + (zstep / prt%z) * &
(D_alpha_s_isr ((one - prt%z) * prt%t, &
shower%settings) * &
P_prt_to_child1 (prt) * &
shower%get_pdf (prt%initial%type, prt%child1%x / prt%z, &
prt%t, prt%type)) / (abs(prt%t) * pdf_divisor)
end if
if (retvalue > final) then
exit
else
z = z + zstep
end if
end do ZLOOP
end subroutine integral_over_z_part_isr
end subroutine shower_isr_step
@ %def shower_isr_step
@ This returns a pointer to the parton with the next ISR branching, again
FSR branchings are ignored.
<<Shower core: shower: TBP>>=
procedure :: generate_next_isr_branching => &
shower_generate_next_isr_branching
<<Shower core: procedures>>=
function shower_generate_next_isr_branching &
(shower) result (next_brancher)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t) :: next_brancher
integer i, index
type(parton_t), pointer :: prt
real(default) :: maxscale
next_brancher%p => null()
do
if (signal_is_pending ()) return
if (shower_isr_is_finished (shower)) exit
!!! find mother with highest |t| or pt to be simulated
index = 0
maxscale = zero
call shower%sort_partons ()
do i = 1,size (shower%partons)
prt => shower%partons(i)%p
if (.not. associated (prt)) cycle
if (.not. shower%settings%isr_pt_ordered) then
if (prt%belongstointeraction) cycle
end if
if (prt%belongstoFSR) cycle
if (prt%is_final ()) cycle
if (.not. prt%belongstoFSR .and. prt%simulated) cycle
index = i
exit
end do
if (debug_active (D_SHOWER)) then
if (index == 0) then
call msg_fatal(" no branchable partons found")
end if
end if
prt => shower%partons(index)%p
!!! ISR simulation
if (shower%settings%isr_pt_ordered) then
call shower_isr_step_pt (shower, prt)
else
call shower_isr_step (shower, prt)
end if
if (prt%simulated) then
if (prt%t < zero) then
next_brancher%p => prt
if (.not. shower%settings%isr_pt_ordered) &
call prt%generate_ps_ini (shower%rng)
exit
else
if (.not. shower%settings%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 () !!! really necessary?
call shower%rotate_to_z () !!! really necessary?
end function shower_generate_next_isr_branching
@ %def shower_generate_next_isr_branching
@ This is a loop which searches for all emitted and branched partons.
<<Shower core: shower: TBP>>=
procedure :: generate_fsr_for_isr_partons => &
shower_generate_fsr_for_partons_emitted_in_ISR
<<Shower core: procedures>>=
subroutine shower_generate_fsr_for_partons_emitted_in_ISR (shower)
class(shower_t), intent(inout) :: shower
integer :: n_int, i
type(parton_t), pointer :: prt
if (shower%settings%isr_only_onshell_emitted_partons) return
call msg_debug (D_SHOWER, "shower_generate_fsr_for_partons_emitted_in_ISR")
INTERACTIONS_LOOP: do n_int = 1, size (shower%interactions)
INCOMING_PARTONS_LOOP: do i = 1, 2
if (signal_is_pending ()) return
prt => shower%interactions(n_int)%i%partons(i)%p
PARENT_PARTONS_LOOP: do
if (associated (prt%parent)) then
if (.not. prt%parent%is_proton ()) then
prt => prt%parent
else
exit
end if
else
exit
end if
if (associated (prt%child2)) then
if (prt%child2%is_branched ()) then
call shower_parton_generate_fsr (shower, prt%child2)
end if
else
! call msg_fatal ("Shower: no child2 associated?")
end if
end do PARENT_PARTONS_LOOP
end do INCOMING_PARTONS_LOOP
end do INTERACTIONS_LOOP
end subroutine shower_generate_fsr_for_partons_emitted_in_ISR
@ %def shower_generate_fsr_for_partons_emitted_in_ISR
@ This executes the branching generated by
[[shower_generate_next_isr_branching]], that means it generates the
flavors, momenta, etc.
<<Shower core: shower: TBP>>=
procedure :: execute_next_isr_branching => shower_execute_next_isr_branching
<<Shower core: procedures>>=
subroutine shower_execute_next_isr_branching (shower, prtp)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t), intent(inout) :: prtp
type(parton_t), pointer :: prt, otherprt
type(parton_t), pointer :: prta, prtb, prtc, prtr
real(default) :: mar, mbr
real(default) :: phirand
call msg_debug (D_SHOWER, "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. shower%settings%isr_pt_ordered .and. &
prt%t > - shower%settings%min_virtuality) .or. &
(shower%settings%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 (prt)
if (shower%settings%isr_pt_ordered) then
!!! get the recoiler
otherprt => shower%find_recoiler (prt)
if (associated (otherprt%parent)) then
!!! Why only for pt ordered
if (.not. otherprt%parent%is_proton () .and. &
shower%settings%isr_pt_ordered) otherprt => otherprt%parent
end if
if (.not. associated (prt%parent)) then
call shower%add_parent (prt)
end if
prt%parent%belongstoFSR = .false.
if (.not. associated (prt%parent%child2)) then
call shower%add_child (prt%parent, 2)
end if
prta => prt%parent !!! new parton a with branching a->bc
prtb => prt !!! former parton
prtc => prt%parent%child2 !!! emitted parton
prtr => otherprt !!! recoiler
mbr = (prtb%momentum + prtr%momentum)**1
mar = mbr / sqrt(prt%z)
!!! 1. assume you are in the restframe
!!! 2. rotate by random phi
call shower%rng%generate (phirand)
phirand = twopi * phirand
call shower_apply_lorentztrafo (shower, &
rotation(cos(phirand), sin(phirand),vector3_canonical(3)))
!!! 3. Put the b off-shell
!!! and
!!! 4. construct the massless a
!!! and the parton (eventually emitted by a)
!!! generate the flavor of the parent (prta)
if (prtb%aux_pt /= 0) prta%type = prtb%aux_pt
if (prtb%is_quark ()) then
if (prta%type == prtb%type) then
!!! (anti)-quark -> (anti-)quark + gluon
prta%type = prtb%type ! quarks have same flavor
prtc%type = GLUON ! emitted gluon
else
!!! gluon -> quark + antiquark
prta%type = GLUON
prtc%type = - prtb%type
end if
else if (prtb%is_gluon ()) then
prta%type = GLUON
prtc%type = GLUON
else
! STOP "Bug in shower_execute_next_branching: neither quark nor gluon"
end if
prta%initial => prtb%initial
prta%belongstoFSR = .false.
prta%scale = prtb%scale
prta%x = prtb%x / prtb%z
prtb%momentum = vector4_moving ((mbr**2 + prtb%t) / (two * mbr), &
vector3_canonical(3) * &
sign ((mbr**2 - prtb%t) / (two * mbr), &
prtb%momentum%p(3)))
prtr%momentum = vector4_moving ((mbr**2 - prtb%t) / (two * mbr), &
vector3_canonical(3) * &
sign( (mbr**2 - prtb%t) / (two * mbr), &
prtr%momentum%p(3)))
prta%momentum = vector4_moving ((0.5_default / mbr) * &
((mbr**2 / prtb%z) + prtb%t - prtc%mass_squared ()), &
vector3_null)
prta%momentum = vector4_moving (prta%momentum%p(0), &
vector3_canonical(3) * &
(0.5_default / prtb%momentum%p(3)) * &
((mbr**2 / prtb%z) - two &
* prtr%momentum%p(0) * prta%momentum%p(0) ) )
if (prta%momentum%p(0)**2 - prta%momentum%p(3)**2 - &
prtc%mass_squared () > zero) then
!!! This SHOULD be always fulfilled???
prta%momentum = vector4_moving (prta%momentum%p(0), &
vector3_moving([sqrt (prta%momentum%p(0)**2 - &
prta%momentum%p(3)**2 - &
prtc%mass_squared ()), zero, &
prta%momentum%p(3)]))
end if
prtc%momentum = prta%momentum - prtb%momentum
!!! 5. rotate to have a along z-axis
call shower%boost_to_CMframe ()
call shower%rotate_to_z ()
!!! 6. rotate back in phi
call shower_apply_lorentztrafo (shower, rotation &
(cos(-phirand), sin(-phirand), vector3_canonical(3)))
else
if (prt%child2%t > prt%child2%mass_squared ()) then
call shower_add_children_of_emitted_timelike_parton &
(shower, prt%child2)
call prt%child2%set_simulated ()
end if
call shower%add_parent (prt)
call shower%add_child (prt%parent, 2)
prt%parent%momentum = prt%momentum
prt%parent%t = prt%t
prt%parent%x = prt%x
prt%parent%initial => prt%initial
prt%parent%belongstoFSR = .false.
prta => prt
prtb => prt%child1
prtc => prt%child2
end if
if (signal_is_pending ()) return
if (shower%settings%isr_pt_ordered) then
call prt%parent%generate_ps_ini (shower%rng)
else
call prt%generate_ps_ini (shower%rng)
end if
!!! add color connections
if (prtb%is_quark ()) 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 (prtb%is_gluon ()) then
if (prta%is_gluon ()) then
!!! g -> gg
prtc%c2 = prtb%c1
prtc%c1 = shower%get_next_color_nr ()
prta%c1 = prtc%c1
prta%c2 = prtb%c2
else if (prta%is_quark ()) then
if (prta%type > 0) then
prta%c1 = prtb%c1
prta%c2 = 0
prtc%c1 = prtb%c2
prtc%c2 = 0
else
prta%c1 = 0
prta%c2 = prtb%c2
prtc%c1 = 0
prtc%c2 = prtb%c1
end if
end if
end if
call shower%sort_partons ()
call shower%boost_to_CMframe ()
call shower%rotate_to_z ()
end subroutine shower_execute_next_isr_branching
@ %def shower_execute_next_isr_branching
@
<<Shower core: procedures>>=
subroutine shower_remove_parents_and_stuff (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
type(parton_t), pointer :: actprt, nextprt
nextprt => prt%parent
actprt => null()
!!! remove children of emitted timelike parton
if (associated (prt%child2)) then
if (associated (prt%child2%child1)) then
call shower_remove_parton_from_partons_recursive &
(shower, prt%child2%child1)
end if
prt%child2%child1 => null()
if (associated (prt%child2%child2)) then
call shower_remove_parton_from_partons_recursive &
(shower, prt%child2%child2)
end if
prt%child2%child2 => null()
end if
do
actprt => nextprt
if (.not. associated (actprt)) then
exit
else if (actprt%is_proton ()) then
!!! remove beam-remnant
call shower_remove_parton_from_partons (shower, actprt%child2)
exit
end if
if (associated (actprt%parent)) then
nextprt => actprt%parent
else
nextprt => null()
end if
call shower_remove_parton_from_partons_recursive &
(shower, actprt%child2)
call shower_remove_parton_from_partons (shower, actprt)
end do
prt%parent=>null()
end subroutine shower_remove_parents_and_stuff
@ %def shower_remove_parents_and_stuff
@
<<Shower core: shower: TBP>>=
procedure :: get_ISR_scale => shower_get_ISR_scale
<<Shower core: procedures>>=
function shower_get_ISR_scale (shower) result (scale)
class(shower_t), intent(in) :: shower
real(default) :: scale
type(parton_t), pointer :: prt1, prt2
integer :: i
scale = zero
do i = 1, size (shower%interactions)
call interaction_find_partons_nearest_to_hadron &
(shower%interactions(i)%i, prt1, prt2, &
shower%settings%isr_pt_ordered)
if (.not. prt1%simulated .and. abs(prt1%scale) > scale) &
scale = abs(prt1%scale)
if (.not. prt1%simulated .and. abs(prt2%scale) > scale) &
scale = abs(prt2%scale)
end do
end function shower_get_ISR_scale
@ %def shower_get_ISR_scale
@
<<Shower core: shower: TBP>>=
procedure :: set_max_isr_scale => shower_set_max_isr_scale
<<Shower core: procedures>>=
subroutine shower_set_max_isr_scale (shower, newscale)
class(shower_t), intent(inout) :: shower
real(default), intent(in) :: newscale
real(default) :: scale
type(parton_t), pointer :: prt
integer :: i,j
call msg_debug (D_SHOWER, "shower_set_max_isr_scale: newscale", &
newscale)
if (shower%settings%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. shower%settings%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. shower%settings%isr_pt_ordered) then
if (prt%child1%belongstointeraction .or. &
prt%is_proton ()) then
!!! don't reset scales of "first" spacelike partons
!!! in virtuality ordered shower or hadrons
cycle
end if
else
if (prt%is_proton ()) then
!!! don't reset scales of hadrons
cycle
end if
end if
if (shower%settings%isr_pt_ordered) then
prt%scale = scale
else
prt%t = scale
end if
call prt%set_simulated (.false.)
call shower_remove_parents_and_stuff (shower, prt)
end do PARTONS
end do INTERACTIONS
end subroutine shower_set_max_isr_scale
@ %def shower_set_max_isr_scale
@
<<Shower core: shower: TBP>>=
procedure :: interaction_generate_fsr_2ton => &
shower_interaction_generate_fsr_2ton
@
<<Shower core: procedures>>=
subroutine shower_interaction_generate_fsr_2ton (shower, interaction)
class(shower_t), intent(inout) :: shower
type(shower_interaction_t), intent(inout) :: interaction
type(parton_t), pointer :: prt
prt => interaction%partons(3)%p
do
if (.not. associated (prt%parent)) exit
prt => prt%parent
end do
call shower_parton_generate_fsr (shower, prt)
call shower_parton_update_color_connections (shower, prt)
end subroutine shower_interaction_generate_fsr_2ton
@ %def shower_interaction_generate_fsr_2ton
@ Perform the FSR for one parton, it is assumed, that the parton
already branched. Hence, its children are to be simulated. This
procedure is intended for branched FSR-partons emitted in the ISR.
<<Shower core: procedures>>=
subroutine shower_parton_generate_fsr (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
type(parton_pointer_t), dimension(:), allocatable :: partons
logical :: single_emission = .false.
call msg_debug (D_SHOWER, "shower_parton_generate_fsr")
if (signal_is_pending ()) return
if (debug_active (D_SHOWER)) then
if (.not. prt%is_branched ()) then
call msg_error ("shower_parton_generate_fsr: parton not branched")
return
end if
if (prt%child1%simulated .or. &
prt%child2%simulated) then
print *, "children already simulated for parton ", prt%nr
return
end if
end if
allocate (partons(1))
partons(1)%p => prt
if (single_emission) then
call shower%parton_pointer_array_generate_fsr (partons, partons)
else
call shower%parton_pointer_array_generate_fsr_recursive (partons)
end if
end subroutine shower_parton_generate_fsr
@ %def shower_parton_generate_fsr
@
<<Shower core: shower: TBP>>=
procedure :: parton_pointer_array_generate_fsr_recursive => &
shower_parton_pointer_array_generate_fsr_recursive
@
<<Shower core: procedures>>=
recursive subroutine shower_parton_pointer_array_generate_fsr_recursive &
(shower, partons)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: &
partons
type(parton_pointer_t), dimension(:), allocatable :: partons_new
call msg_debug (D_SHOWER, "shower_parton_pointer_array_generate_fsr_recursive")
if (signal_is_pending ()) return
if (size (partons) == 0) return
call shower%parton_pointer_array_generate_fsr (partons, partons_new)
call shower%parton_pointer_array_generate_fsr_recursive (partons_new)
end subroutine shower_parton_pointer_array_generate_fsr_recursive
@
<<Shower core: shower: TBP>>=
procedure :: parton_pointer_array_generate_fsr => &
shower_parton_pointer_array_generate_fsr
@
<<Shower core: procedures>>=
subroutine shower_parton_pointer_array_generate_fsr &
(shower, partons, partons_new)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: &
partons
type(parton_pointer_t), dimension(:), allocatable, intent(out) :: &
partons_new
integer :: i, size_partons, size_partons_new
call msg_debug (D_SHOWER, "shower_parton_pointer_array_generate_fsr")
!!! Simulate highest/first parton
call shower_simulate_children_ana (shower, partons(1)%p)
!!! check for new daughters to be included in new_partons
size_partons = size (partons)
size_partons_new = size_partons - 1 !!! partons(1) not needed anymore
if (partons(1)%p%child1%is_branched ()) &
size_partons_new = size_partons_new + 1
if (partons(1)%p%child2%is_branched ()) &
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 (partons(1)%p%child1%is_branched ()) &
partons_new (size_partons)%p => partons(1)%p%child1
if (partons(1)%p%child2%is_branched ()) then
!!! check if child1 is already included
if (size_partons_new == size_partons) then
partons_new (size_partons)%p => partons(1)%p%child2
else if (size_partons_new == size_partons + 1) then
partons_new (size_partons + 1)%p => partons(1)%p%child2
else
call msg_fatal ("Shower: wrong sizes in" &
// "shower_parton_pointer_array_generate_fsr")
end if
end if
deallocate (partons)
end subroutine shower_parton_pointer_array_generate_fsr
@ %def shower_parton_pointer_array_generate_fsr
@
<<Shower core: procedures>>=
recursive subroutine shower_parton_update_color_connections &
(shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout) :: prt
real(default) :: temprand
if (.not. associated (prt%child1) .or. &
.not. associated (prt%child2)) return
if (signal_is_pending ()) return
if (prt%is_gluon ()) then
if (prt%child1%is_quark ()) then
!!! give the quark the colorpartner and the antiquark
!!! the anticolorpartner
if (prt%child1%type > 0) then
!!! child1 is quark, child2 is antiquark
prt%child1%c1 = prt%c1
prt%child2%c2 = prt%c2
else
!!! child1 is antiquark, child2 is quark
prt%child1%c2 = prt%c2
prt%child2%c1 = prt%c1
end if
else
!!! g -> gg splitting -> random choosing of partners
call shower%rng%generate (temprand)
if (temprand > 0.5_default) then
prt%child1%c1 = prt%c1
prt%child1%c2 = shower%get_next_color_nr ()
prt%child2%c1 = prt%child1%c2
prt%child2%c2 = prt%c2
else
prt%child1%c2 = prt%c2
prt%child2%c1 = prt%c1
prt%child2%c2 = shower%get_next_color_nr ()
prt%child1%c1 = prt%child2%c2
end if
end if
else if (prt%is_quark ()) then
if (prt%child1%is_quark ()) then
if (prt%child1%type > 0) then
!!! q -> q + g
prt%child2%c1 = prt%c1
prt%child2%c2 = shower%get_next_color_nr ()
prt%child1%c1 = prt%child2%c2
else
!!! qbar -> qbar + g
prt%child2%c2 = prt%c2
prt%child2%c1 = shower%get_next_color_nr ()
prt%child1%c2 = prt%child2%c1
end if
else
if (prt%child2%type > 0) then
!!! q -> g + q
prt%child1%c1 = prt%c1
prt%child1%c2 = shower%get_next_color_nr ()
prt%child2%c1 = prt%child1%c2
else
!!! qbar -> g + qbar
prt%child1%c2 = prt%c2
prt%child1%c1 = shower%get_next_color_nr ()
prt%child2%c2 = prt%child1%c1
end if
end if
end if
call shower_parton_update_color_connections (shower, prt%child1)
call shower_parton_update_color_connections (shower, prt%child2)
end subroutine shower_parton_update_color_connections
@ %def shower_parton_update_color_connections
@ The next two routines are for PDFs. Wrapper function to return
parton densities.
<<Shower core: shower: TBP>>=
procedure :: get_pdf => shower_get_pdf
<<Shower core: procedures>>=
function shower_get_pdf (shower, mother, x, Q2, daughter) result (pdf)
<<get pdf>>
if (x > eps0) then
pdf = pdf / x
end if
end function shower_get_pdf
@ %def shower_get_pdf
<<Shower core: shower: TBP>>=
procedure :: get_xpdf => shower_get_xpdf
<<Shower core: procedures>>=
function shower_get_xpdf (shower, mother, x, Q2, daughter) result (pdf)
<<get pdf>>
end function shower_get_xpdf
@ %def shower_get_xpdf
@
<<get pdf>>=
class(shower_t), intent(inout), target :: shower
integer, intent(in) :: mother, daughter
real(default), intent(in) :: x, Q2
real(default) :: pdf
real(double), save :: f(-6:6) = 0._double
real(double), save :: lastx, lastQ2 = 0._double
pdf = zero
if (debug_active (D_SHOWER)) then
if (abs (mother) /= PROTON) then
call msg_debug (D_SHOWER, "mother", mother)
call msg_fatal ("Shower: pdf only implemented for (anti-)proton")
end if
if (.not. (abs (daughter) >= 1 .and. abs (daughter) <= 6 .or. &
daughter == GLUON)) then
call msg_debug (D_SHOWER, "daughter", daughter)
call msg_fatal ("Shower: error in pdf, unknown daughter")
end if
end if
if (x > zero .and. x < one) then
if ((dble(Q2) - lastQ2) > eps0 .or. (dble(x) - lastx) > eps0) then
call shower%pdf_data%evolve &
(dble(x), sqrt (abs (dble(Q2))), f)
end if
if (abs (daughter) >= 1 .and. abs (daughter) <= 6) then
pdf = max (f(daughter * sign (1,mother)), tiny_10)
else
pdf = max (f(0), tiny_10)
end if
end if
lastQ2 = dble(Q2)
lastx = dble(x)
@
@ Convert Whizard shower to Pythia6. Currently only works for one
interaction.
<<Shower core: shower: TBP>>=
procedure :: converttopythia => shower_converttopythia
<<Shower core: procedures>>=
subroutine shower_converttopythia (shower)
class(shower_t), intent(in) :: shower
<<PYJETS COMMON BLOCK>>
type(parton_t), pointer :: pp, ppparent
integer :: i
K = 0
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:5) = pp%initial%momentum_to_pythia6 ()
!!! add partons emitted by the hadron
ppparent => pp
do while (associated (ppparent%parent))
if (ppparent%parent%is_proton ()) 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:5) = ppparent%momentum_to_pythia6 ()
!!! 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:5) = pp%momentum_to_pythia6 ()
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:5) = pp%momentum_to_pythia6 ()
P(i+2,:) = P(1,:)
K(i+2,:) = K(1,:)
K(i+2,3) = i
P(i+4,:) = P(1,:)
K(i+4,:) = K(1,:)
K(i+4,3) = i
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:4) = P(5,1:4) + P(6,1: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:5) = pp%momentum_to_pythia6 ()
!N = 7 + I
N = 6 + I
end do
!!! include "Z" (again)
!N = N + 1
!K(N,1) = 11
!K(N,2) = 23
!K(N,3) = 7
!P(N,1:5) = P(7,1: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
!!! be sure to remove the next partons (=first obsolete partons)
!!! otherwise they might be interpreted as thrust information
K(N+1:N+3,1:3) = 0
end subroutine shower_converttopythia
@ %def shower_converttopythia
@
<<Shower core: procedures>>=
subroutine shower_transfer_final_partons_to_pythia (shower, first)
<<PYJETS COMMON BLOCK>>
type(shower_t), intent(in) :: shower
integer, intent(in) :: first
type(parton_t), pointer :: prt
integer :: i, j, n_finals
type(parton_t), dimension(:), allocatable :: final_partons
type(parton_t) :: temp_parton
integer :: minindex, maxindex
prt => null()
!!! get total number of final partons
n_finals = 0
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
prt => shower%partons(i)%p
if (.not. prt%belongstoFSR) cycle
if (associated (prt%child1)) cycle
n_finals = n_finals + 1
end do
allocate (final_partons(1:n_finals))
j = 1
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
prt => shower%partons(i)%p
if (.not. prt%belongstoFSR) cycle
if (associated (prt%child1)) cycle
final_partons(j) = shower%partons(i)%p
j = j + 1
end do
!!! move quark to front as beginning of color string
minindex = 1
maxindex = size (final_partons)
FIND_Q: do i = minindex, maxindex
if (final_partons(i)%type >= 1 .and. final_partons(i)%type <= 6) then
temp_parton = final_partons(minindex)
final_partons(minindex) = final_partons(i)
final_partons(i) = temp_parton
exit FIND_Q
end if
end do FIND_Q
!!! sort so that connected partons are next to each other, don't care about zeros
do i = 1, size (final_partons)
!!! ensure that final_partnons begins with a color (not an anticolor)
if (final_partons(i)%c1 > 0 .and. final_partons(i)%c2 == 0) then
if (i == 1) then
exit
else
temp_parton = final_partons(1)
final_partons(1) = final_partons(i)
final_partons(i) = temp_parton
exit
end if
end if
end do
do i = 1, size (final_partons) - 1
!!! search for color partner and move it to i + 1
PARTNERS: do j = i + 1, size (final_partons)
if (final_partons(j)%c2 == final_partons(i)%c1) exit PARTNERS
end do PARTNERS
if (j > size (final_partons)) then
print *, "no color connected parton found" !WRONG???
print *, "particle: ", final_partons(i)%nr, " index: ", &
final_partons(i)%c1
exit
end if
temp_parton = final_partons(i + 1)
final_partons(i + 1) = final_partons(j)
final_partons(j) = temp_parton
end do
!!! transfering partons
do i = 1, size (final_partons)
prt = final_partons(i)
N = N + 1
K(N,1) = 2
if (prt%c1 == 0) K(N,1) = 1 !!! end of color string
K(N,2) = prt%type
!K(N,3) = first
K(N,3) = 0
K(N,4) = 0
K(N,5) = 0
P(N,1:5) = prt%momentum_to_pythia6()
end do
deallocate (final_partons)
end subroutine shower_transfer_final_partons_to_pythia
@ %def shower_transfer_final_partons_to_pythia
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Interface to PYTHIA}
<<[[shower_pythia6.f90]]>>=
<<File header>>
module shower_pythia6
<<Use kinds with double>>
<<Use strings>>
use constants
use io_units
use physics_defs
use diagnostics
use os_interface
use lorentz
use subevents
use shower_base
use particles
use model_data
use hep_common
use pdf
use helicities
use tauola_interface
<<Standard module head>>
<<Shower pythia6: public>>
<<Shower pythia6: variables>>
<<Shower pythia6: types>>
contains
<<Shower pythia6: procedures>>
end module shower_pythia6
@ %def shower_topythia
<<PYJETS COMMON BLOCK>>=
integer :: N, NPAD, K
real(double) :: P, V
COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
SAVE /PYJETS/
@
<<Shower pythia6: variables>>=
integer :: N_old
@ %def N_old
@ The PYTHIA6 shower type.
<<Shower pythia6: public>>=
public :: shower_pythia6_t
<<Shower pythia6: types>>=
type, extends (shower_base_t) :: shower_pythia6_t
integer :: initialized_for_NPRUP = 0
logical :: warning_given = .false.
contains
<<Shower pythia6: shower pythia6: TBP>>
end type shower_pythia6_t
@ %def shower_pythia6_t
@ Initialize the PYTHIA6 shower.
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: init => shower_pythia6_init
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_init (shower, settings, taudec_settings, pdf_data)
class(shower_pythia6_t), intent(out) :: shower
type(shower_settings_t), intent(in) :: settings
type(taudec_settings_t), intent(in) :: taudec_settings
type(pdf_data_t), intent(in) :: pdf_data
call msg_debug (D_SHOWER, "shower_pythia6_init")
shower%settings = settings
shower%taudec_settings = taudec_settings
call pythia6_set_verbose (settings%verbose)
call shower%pdf_data%init (pdf_data)
shower%name = "PYTHIA6"
call shower%write_msg ()
end subroutine shower_pythia6_init
@ %def shower_pythia6_init
@
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: prepare_new_event => shower_pythia6_prepare_new_event
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_prepare_new_event (shower)
class(shower_pythia6_t), intent(inout) :: shower
end subroutine shower_pythia6_prepare_new_event
@ %def shower_pythia6_prepare_new_event
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: import_particle_set => shower_pythia6_import_particle_set
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_import_particle_set &
(shower, particle_set, os_data)
class(shower_pythia6_t), target, intent(inout) :: shower
type(particle_set_t), intent(in) :: particle_set
type(os_data_t), intent(in) :: os_data
type(particle_set_t) :: pset_reduced
call msg_debug (D_SHOWER, "shower_pythia6_import_particle_set")
if (debug_active (D_SHOWER)) then
print *, 'IDBMUP(1:2) = ', IDBMUP(1:2)
print *, 'EBMUP, PDFGUP = ', EBMUP, PDFGUP
print *, 'PDFSUP, IDWTUP = ', PDFSUP, IDWTUP
print *, "NPRUP = ", NPRUP
call particle_set%write (summary=.true., compressed=.true.)
end if
call particle_set%reduce (pset_reduced)
if (debug2_active (D_SHOWER)) then
print *, 'After particle_set%reduce: pset_reduced'
call pset_reduced%write (summary=.true., compressed=.true.)
end if
call hepeup_from_particle_set (pset_reduced, tauola_convention=.true.)
call hepeup_set_event_parameters (proc_id=1)
end subroutine shower_pythia6_import_particle_set
@ %def shower_pythia6_import_particle_set
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: generate_emissions => shower_pythia6_generate_emissions
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_generate_emissions &
(shower, valid, number_of_emissions)
class(shower_pythia6_t), intent(inout), target :: shower
logical, intent(out) :: valid
integer, optional, intent(in) :: number_of_emissions
integer :: N, NPAD, K
real(double) :: P, V
common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5)
save /PYJETS/
integer :: u_W2P
integer :: i
real(double) :: beta_z, pz_in, E_in
integer, parameter :: lower = 5
real(double), parameter :: beta_x = 0.0_double
real(double), parameter :: beta_y = 0.0_double
real(double), parameter :: theta = 0.0_double
real(double), parameter :: phi = 0.0_double
if (signal_is_pending ()) return
call pythia6_setup_lhe_io_units (u_W2P)
call w2p_write_lhef_event (u_W2P)
rewind (u_W2P)
call pythia6_set_last_treated_line(6)
call shower%transfer_settings ()
if (debug_active (D_SHOWER)) then
print *, ' Before pyevnt, before boosting :'
call pylist(2)
end if
call msg_debug (D_SHOWER, "calling pyevnt")
! TODO: (bcn 2015-04-24) doesnt change anything I think
! P(1,1:5) = pset_reduced%prt(1)%momentum_to_pythia6 ()
! P(2,1:5) = pset_reduced%prt(2)%momentum_to_pythia6 ()
call pyevnt ()
call pyedit(12)
do i = 1, n
if (K(i,1) == 14 .and. abs(K(i,2)) >= 11 .and. abs(K(i,2)) <= 16) then
if (K(i,4) > 0 .and. K(i,5) > 0 .and. K(i,4) < N .and. K(i,5) < N) then
K(i,1) = 11
K(i,4) = K(K(i,4),3)
K(i,5) = K(K(i,5),3)
end if
end if
end do
if (.not. shower%settings%hadron_collision) then
pz_in = pup(3,1) + pup(3,2)
E_in = pup(4,1) + pup(4,2)
beta_z = pz_in / E_in
call pyrobo (lower, N, theta, phi, beta_x, beta_y, beta_z)
end if
if (debug_active (D_SHOWER)) then
print *, ' After pyevnt, after boosting :'
call pylist(2)
end if
close (u_W2P)
valid = pythia6_handle_errors ()
end subroutine shower_pythia6_generate_emissions
@ %def shower_pythia6_generate_emissions
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: make_particle_set => shower_pythia6_make_particle_set
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_make_particle_set &
(shower, particle_set, model, model_hadrons)
class(shower_pythia6_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model
class(model_data_t), intent(in), target :: model_hadrons
call shower%combine_with_particle_set (particle_set, model, model_hadrons)
end subroutine shower_pythia6_make_particle_set
@ %def shower_pythia6_make_particle_set
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: transfer_settings => shower_pythia6_transfer_settings
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_transfer_settings (shower)
class(shower_pythia6_t), intent(inout) :: shower
character(len=10) :: buffer
real(default) :: rand
logical, save :: tauola_initialized = .false.
call msg_debug (D_SHOWER, "shower_pythia6_transfer_settings")
if (shower%initialized_for_NPRUP >= NPRUP) then
call msg_debug (D_SHOWER, "calling upinit")
call upinit ()
else
if (shower%settings%isr_active) then
call pygive ("MSTP(61)=1")
else
call pygive ("MSTP(61)=0") !!! switch off ISR
end if
if (shower%settings%fsr_active) then
call pygive ("MSTP(71)=1")
else
call pygive ("MSTP(71)=0") !!! switch off FSR
end if
call pygive ("MSTP(111)=1") !!! Allow hadronization and decays
call pygive ("MSTJ(1)=0") !!! No jet fragmentation
call pygive ("MSTJ(21)=1") !!! Allow decays but no jet fragmentation
call pygive ("MSTP(11)=0") !!! Disable Pythias QED-ISR per default
call pygive ("MSTP(171)=1") !!! Allow variable energies
write (buffer, "(F10.5)") sqrt (abs (shower%settings%min_virtuality))
call pygive ("PARJ(82)=" // buffer)
write (buffer, "(F10.5)") shower%settings%isr_tscalefactor
call pygive ("PARP(71)=" // buffer)
write (buffer, "(F10.5)") shower%settings%fsr_lambda
call pygive ("PARP(72)=" // buffer)
write(buffer, "(F10.5)") shower%settings%isr_lambda
call pygive ("PARP(61)=" // buffer)
write (buffer, "(I10)") shower%settings%max_n_flavors
call pygive ("MSTJ(45)=" // buffer)
if (shower%settings%isr_alpha_s_running) then
call pygive ("MSTP(64)=2")
else
call pygive ("MSTP(64)=0")
end if
if (shower%settings%fsr_alpha_s_running) then
call pygive ("MSTJ(44)=2")
else
call pygive ("MSTJ(44)=0")
end if
write (buffer, "(F10.5)") shower%settings%fixed_alpha_s
call pygive ("PARU(111)=" // buffer)
write (buffer, "(F10.5)") shower%settings%isr_primordial_kt_width
call pygive ("PARP(91)=" // buffer)
write (buffer, "(F10.5)") shower%settings%isr_primordial_kt_cutoff
call pygive ("PARP(93)=" // buffer)
write (buffer, "(F10.5)") 1._double - shower%settings%isr_z_cutoff
call pygive ("PARP(66)=" // buffer)
write (buffer, "(F10.5)") shower%settings%isr_minenergy
call pygive ("PARP(65)=" // buffer)
if (shower%settings%isr_only_onshell_emitted_partons) then
call pygive ("MSTP(63)=0")
else
call pygive ("MSTP(63)=2")
end if
if (shower%settings%mlm_matching) then
call pygive ("MSTP(62)=2")
call pygive ("MSTP(67)=0")
end if
call pythia6_set_config (shower%settings%pythia6_pygive)
call msg_debug (D_SHOWER, "calling pyinit")
call PYINIT ("USER", "", "", 0D0)
call shower%rng%generate (rand)
write (buffer, "(I10)") floor (rand*900000000)
call pygive ("MRPY(1)=" // buffer)
call pygive ("MRPY(2)=0")
call pythia6_set_config (shower%settings%pythia6_pygive)
shower%initialized_for_NPRUP = NPRUP
end if
if (shower%settings%tau_dec) then
call pygive ("MSTJ(28)=2")
end if
if (pythia6_tauola_active() .and. .not. tauola_initialized) then
- call ilc_tauola_init_call (shower%taudec_settings)
+ call wo_tauola_init_call (shower%taudec_settings)
tauola_initialized = .true.
end if
end subroutine shower_pythia6_transfer_settings
@ %def shower_pythia6_transfer_settings
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: combine_with_particle_set => &
shower_pythia6_combine_with_particle_set
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_combine_with_particle_set &
(shower, particle_set, model_in, model_hadrons)
class(shower_pythia6_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model_in
class(model_data_t), intent(in), target :: model_hadrons
call pythia6_combine_with_particle_set &
(particle_set, model_in, model_hadrons, shower%settings)
end subroutine shower_pythia6_combine_with_particle_set
@ %def shower_pythia6_combine_with_particle_set
@
\begin{tabular}{l l}
K(I,1) & pythia status code \\
& 1 = undecayed particle or unfragmented parton \\
& (single or last of parton system) \\
& 2 = unfragmented parton \\
& (followed by more partons in the same color singlet \\
& 3 = unfragmented parton (color info in K(I,4), K(I,5)) \\
& 11 = decayed particle or fragmented parton \\
& 12 = fragmented parton \\
& 13 = fragmented parton that has been removed \\
& 14 = branched parton with color info like 3 \\
& 21 = documentation lines \\
K(I,2) & PDG code \\
K(I,3) & Parent where known else 0. Unphysical to assign \\
& particles partons as parents \\
K(I,4) & Normally first daughter \\
K(I,5) & Normally last daughter
\end{tabular}
The first two particles are always the beams, in Pythia and Whizard.
We remove all beam remnants (including the ISR photons) since those are
added back in by Pythia.
@
<<Shower pythia6: public>>=
public :: pythia6_combine_with_particle_set
@
<<Shower pythia6: procedures>>=
subroutine pythia6_combine_with_particle_set (particle_set, model_in, &
model_hadrons, settings)
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model_in
class(model_data_t), intent(in), target :: model_hadrons
type(shower_settings_t), intent(in) :: settings
class(model_data_t), pointer :: model
type(vector4_t) :: momentum
type(particle_t), dimension(:), allocatable :: particles, beams
integer :: dangling_col, dangling_anti_col, color, anti_color
integer :: i, j, py_entries, next_color, n_tot_old, parent, real_parent
integer :: pdg, status, child, hadro_start, i_py, i_whz
integer, allocatable, dimension(:) :: py_index, whz_index
logical, allocatable, dimension(:) :: valid
real(default), parameter :: py_tiny = 1E-10_default
integer :: N, NPAD, K
real(double) :: P, V
common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5)
save /PYJETS/
integer, parameter :: KSUSY1 = 1000000, KSUSY2 = 2000000
if (signal_is_pending ()) return
if (debug_active (D_SHOWER)) then
call msg_debug (D_SHOWER, 'Combine PYTHIA6 with particle set')
call msg_debug (D_SHOWER, 'Particle set before replacing')
call particle_set%write (summary=.true., compressed=.true.)
call pylist (2)
call msg_debug (D_SHOWER, string = "settings%hadron_collision", &
value = settings%hadron_collision)
end if
if (settings%method == PS_PYTHIA6 .and. settings%hadron_collision) then
call pythia6_set_last_treated_line(2)
allocate (beams(2))
beams = particle_set%prt(1:2)
call particle_set%replace (beams)
if (debug_active (D_SHOWER)) then
call msg_debug (D_SHOWER, 'Resetting particle set to')
call particle_set%write (summary=.true., compressed=.true.)
end if
end if
call fill_hepevt_block_from_pythia ()
call count_valid_entries_in_pythia_record ()
call particle_set%without_hadronic_remnants &
(particles, n_tot_old, py_entries)
if (debug_active (D_SHOWER)) then
print *, 'n_tot_old = ', n_tot_old
print *, 'py_entries = ', py_entries
end if
call add_particles_of_pythia ()
call particle_set%replace (particles)
if (settings%hadron_collision) then
call set_parent_child_relations_from_K ()
call set_parent_child_relations_of_color_strings_to_hadrons ()
!!! call particle_set%remove_duplicates (py_tiny * 100.0_default)
else
call set_parent_child_relations_from_hepevt ()
end if
!call fix_nonemitting_outgoings ()
if (settings%method == PS_WHIZARD) then
call fudge_whizard_partons_in_hadro ()
end if
where ((particle_set%prt%status == PRT_OUTGOING .or. &
particle_set%prt%status == PRT_VIRTUAL .or. &
particle_set%prt%status == PRT_BEAM_REMNANT) .and. &
particle_set%prt%has_children ()) &
particle_set%prt%status = PRT_RESONANT
if (debug_active (D_SHOWER)) then
print *, 'Particle set after replacing'
call particle_set%write (summary=.true., compressed=.true.)
print *, ' pythia6_set_last_treated_line will set to: ', N
end if
call pythia6_set_last_treated_line(N)
contains
<<Shower pythia6: combine with particle set: procedures>>
end subroutine pythia6_combine_with_particle_set
@ %def pythia6_combine_with_particle_set
<<Shower pythia6: combine with particle set: procedures>>=
subroutine count_valid_entries_in_pythia_record ()
<<HEPEVT BLOCK>>
integer :: pset_idx
logical :: comes_from_cmshower, emitted_zero_momentum_photon, &
direct_decendent
integer, parameter :: cmshower = 94
hadro_start = 0
allocate (valid(N))
valid = .false.
FIND: do i_py = 5, N
!if (K(i_py,2) >= 91 .and. K(i_py,2) <= 94) then
if (K(i_py,2) >= 91 .and. K(i_py,2) <= 93) then
hadro_start = i_py
exit FIND
end if
end do FIND
do i_py = N, N_old+1, -1
status = K(i_py,1)
if (any (P(i_py,1:4) > 1E-8_default * P(1,4)) .and. &
(status >= 1 .and. status <= 21)) then
pset_idx = find_pythia_particle (i_py, more_fuzzy=.false.)
direct_decendent = IDHEP(JMOHEP(1,i_py)) == cmshower .and. &
JMOHEP(2,i_py) == 0
emitted_zero_momentum_photon = find_pythia_particle &
(JMOHEP(1,i_py), more_fuzzy=.false.) == pset_idx
comes_from_cmshower = status == 1 .and. &
(direct_decendent .or. emitted_zero_momentum_photon)
valid(i_py) = pset_idx == 0 .or. comes_from_cmshower
end if
end do
py_entries = count (valid)
allocate (py_index (py_entries))
allocate (whz_index (N))
whz_index = 0
end subroutine count_valid_entries_in_pythia_record
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine add_particles_of_pythia ()
integer :: whizard_status
integer :: pset_idx, start_in_py
integer :: ihelicity
type(helicity_t) :: hel
real(default) :: lifetime
type(vector4_t) :: vertex
dangling_col = 0
dangling_anti_col = 0
next_color = 500
i_whz = 1
if (settings%method == PS_PYTHIA6 .and. settings%hadron_collision) then
start_in_py = 3
else
start_in_py = 7
end if
do i_py = start_in_py, N
status = K(i_py,1)
if (valid(i_py)) then
call assign_colors (color, anti_color)
momentum = real ([P(i_py,4), P(i_py,1:3)], kind=default)
pdg = K(i_py,2)
parent = K(i_py,3)
call find_model (model, pdg, model_in, model_hadrons)
if (i_py <= 4) then
whizard_status = PRT_INCOMING
else
if (status <= 10) then
whizard_status = PRT_OUTGOING
else
whizard_status = PRT_VIRTUAL
end if
end if
call particles(n_tot_old+i_whz)%init &
(whizard_status, pdg, model, color, anti_color, momentum)
lifetime = V(i_py,5)
vertex = [real (V(i_py,4), kind=default), &
real (V(i_py,1), kind=default), &
real (V(i_py,2), kind=default), &
real (V(i_py,3), kind=default)]
if (lifetime /= 0) &
call particles(n_tot_old+i_whz)%set_lifetime (lifetime)
if (any (V(i_py,1:4) /= 0)) &
call particles(n_tot_old+i_whz)%set_vertex (vertex)
!!! Set tau helicity set by TAUOLA
if (abs (pdg) == 15) then
- call ilc_tauola_get_helicity (i_py, ihelicity)
+ call wo_tauola_get_helicity (i_py, ihelicity)
call hel%init (ihelicity)
call particles(n_tot_old+i_whz)%set_helicity(hel)
call particles(n_tot_old+i_whz)%set_polarization(PRT_DEFINITE_HELICITY)
end if
py_index(i_whz) = i_py
whz_index(i_py) = n_tot_old + i_whz
i_whz = i_whz + 1
else
pset_idx = find_pythia_particle (i_py, more_fuzzy=.true.)
whz_index(i_py) = pset_idx
end if
end do
end subroutine add_particles_of_pythia
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine assign_colors (color, anti_color)
integer, intent(out) :: color, anti_color
if ((K(i_py,2) == 21) .or. (abs (K(i_py,2)) <= 8) .or. &
(abs (K(i_py,2)) >= KSUSY1+1 .and. abs (K(i_py,2)) <= KSUSY1+8) .or. &
(abs (K(i_py,2)) >= KSUSY2+1 .and. abs (K(i_py,2)) <= KSUSY2+8) .or. &
(abs (K(i_py,2)) >= 1000 .and. abs (K(i_py,2)) <= 9999) .and. &
hadro_start == 0) then
if (dangling_col == 0 .and. dangling_anti_col == 0) then
! new color string
! Gluon and gluino only color octets implemented so far
if (K(i_py,2) == 21 .or. K(i_py,2) == 1000021) then
color = next_color
dangling_col = color
next_color = next_color + 1
anti_color = next_color
dangling_anti_col = anti_color
next_color = next_color + 1
else if (K(i_py,2) > 0) then ! particles have color
color = next_color
dangling_col = color
anti_color = 0
next_color = next_color + 1
else if (K(i_py,2) < 0) then ! antiparticles have anticolor
anti_color = next_color
dangling_anti_col = anti_color
color = 0
next_color = next_color + 1
end if
else if(status == 1) then
! end of string
color = dangling_anti_col
anti_color = dangling_col
dangling_col = 0
dangling_anti_col = 0
else
! inside the string
if(dangling_col /= 0) then
anti_color = dangling_col
color = next_color
dangling_col = next_color
next_color = next_color +1
else if(dangling_anti_col /= 0) then
color = dangling_anti_col
anti_color = next_color
dangling_anti_col = next_color
next_color = next_color +1
else
call msg_bug ("Couldn't assign colors")
end if
end if
else
color = 0
anti_color = 0
end if
end subroutine assign_colors
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine fill_hepevt_block_from_pythia ()
integer :: first_daughter, second_mother_of_first_daughter, i_hep
logical :: inconsistent_mother, more_than_one_points_to_first_daugther
<<HEPEVT BLOCK>>
call pyhepc(1)
do i_hep = 1, NHEP
first_daughter = JDAHEP(1,i_hep)
if (first_daughter > 0) then
more_than_one_points_to_first_daugther = &
count (JDAHEP(1,i_hep:NHEP) == first_daughter) > 1
if (more_than_one_points_to_first_daugther) then
second_mother_of_first_daughter = JMOHEP(2,first_daughter)
! Only entries with codes 91-94 should have a second mother
if (second_mother_of_first_daughter == 0) then
inconsistent_mother = JMOHEP(1,first_daughter) /= i_hep
if (inconsistent_mother) then
JMOHEP(1,first_daughter) = i_hep
do j = i_hep + 1, NHEP
if (JDAHEP(1,j) == first_daughter) then
JMOHEP(2,first_daughter) = j
end if
end do
end if
end if
end if
end if
end do
end subroutine fill_hepevt_block_from_pythia
<<HEPEVT BLOCK>>=
integer, parameter :: NMXHEP = 4000
integer :: NEVHEP
integer :: NHEP
integer, dimension(NMXHEP) :: ISTHEP
integer, dimension(NMXHEP) :: IDHEP
integer, dimension(2, NMXHEP) :: JMOHEP
integer, dimension(2, NMXHEP) :: JDAHEP
double precision, dimension(5, NMXHEP) :: PHEP
double precision, dimension(4, NMXHEP) :: VHEP
common /HEPEVT/ &
NEVHEP, NHEP, ISTHEP, IDHEP, &
JMOHEP, JDAHEP, PHEP, VHEP
save /HEPEVT/
@ Use HEPEVT for parent-child informations
<<Shower pythia6: combine with particle set: procedures>>=
subroutine set_parent_child_relations_from_hepevt ()
integer, allocatable, dimension(:) :: parents
<<HEPEVT BLOCK>>
integer:: parent2, parent1, npar
call msg_debug (D_SHOWER, &
"set_parent_child_relations_from_hepevt")
if (debug_active (D_SHOWER)) then
print *, 'NHEP, n, py_entries:' , NHEP, n, py_entries
end if
do i_whz = 1, py_entries
parent1 = JMOHEP(1,py_index(i_whz))
parent2 = parent1
if (JMOHEP(2,py_index(i_whz)) > 0) then
parent2 = JMOHEP(2,py_index(i_whz))
end if
allocate (parents(parent2-parent1+1))
parents = 0
child = n_tot_old + i_whz
npar = 0
do parent = parent1, parent2
if (parent > 0) then
if (parent <= 2) then
call particle_set%parent_add_child (parent, child)
else
if (whz_index(parent) > 0) then
npar = npar + 1
parents(npar) = whz_index(parent)
call particle_set%prt(whz_index(parent))%add_child (child)
end if
end if
end if
end do
parents = pack (parents, parents > 0)
if (npar > 0) call particle_set%prt(child)%set_parents (parents)
if (allocated (parents)) deallocate (parents)
end do
NHEP = 0
end subroutine set_parent_child_relations_from_hepevt
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine fix_nonemitting_outgoings ()
integer, dimension(1) :: child
integer, parameter :: cmshower = 94
do i = 1, size (particle_set%prt)
associate (p => particle_set%prt(i))
if (p%get_n_children () == 1) then
child = p%get_children ()
if (particle_set%prt(child(1))%get_pdg () == cmshower) then
j = particle_set%reverse_find_particle (p%get_pdg (), p%p)
if (j == i) then
deallocate (p%child)
p%status = PRT_OUTGOING
end if
end if
end if
end associate
end do
end subroutine fix_nonemitting_outgoings
<<Shower pythia6: combine with particle set: procedures>>=
subroutine set_parent_child_relations_from_K ()
do j = 1, py_entries
parent = K(py_index(j),3)
child = n_tot_old + j
if (parent > 0) then
if (parent >= 1 .and. parent <= 2) then
call particle_set%parent_add_child (parent, child)
else
real_parent = whz_index (parent)
if (real_parent > 0 .and. real_parent /= child) then
call particle_set%parent_add_child (real_parent, child)
end if
end if
end if
end do
end subroutine set_parent_child_relations_from_K
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine set_parent_child_relations_of_color_strings_to_hadrons ()
integer :: begin_string, end_string, old_start, next_start, real_child
integer, allocatable, dimension(:) :: parents
call msg_debug (D_SHOWER, "set_parent_child_relations_of_color_strings_to_hadrons")
call msg_debug (D_SHOWER, "hadro_start", hadro_start)
if (hadro_start > 0) then
old_start = hadro_start
do
next_start = 0
FIND: do i = old_start + 1, N
if (K(i,2) >= 91 .and. K(i,2) <= 94) then
next_start = i
exit FIND
end if
end do FIND
begin_string = K(old_start,3)
end_string = N
do i = begin_string, N
if (K(i,1) == 11) then
end_string = i
exit
end if
end do
allocate (parents (end_string - begin_string + 1))
parents = 0
real_child = whz_index (old_start)
do i = begin_string, end_string
real_parent = whz_index (i)
if (real_parent > 0) then
call particle_set%prt(real_parent)%add_child (real_child)
parents (i - begin_string + 1) = real_parent
end if
end do
call particle_set%prt(real_child)%set_parents (parents)
deallocate (parents)
if (next_start == 0) exit
old_start = next_start
end do
end if
end subroutine set_parent_child_relations_of_color_strings_to_hadrons
@ We allow to be [[more_fuzzy]] when finding particles for parent child
relations than when deciding whether we add particles or not.
<<Shower pythia6: combine with particle set: procedures>>=
function find_pythia_particle (i_py, more_fuzzy) result (j)
integer :: j
integer, intent(in) :: i_py
logical, intent(in) :: more_fuzzy
real(default) :: rel_small
pdg = K(i_py,2)
momentum = real([P(i_py,4), P(i_py,1:3)], kind=default)
if (more_fuzzy) then
rel_small = 1E-6_default
else
rel_small = 1E-10_default
end if
j = particle_set%reverse_find_particle (pdg, momentum, &
abs_smallness = py_tiny, &
rel_smallness = rel_small)
end function find_pythia_particle
@ Outgoing partons after hadronization shouldn't happen and is a dirty
fix to missing mother daughter relation. I suspect that it has to do
with the ordering of the color string but am not sure.
<<Shower pythia6: combine with particle set: procedures>>=
subroutine fudge_whizard_partons_in_hadro ()
do i = 1, size (particle_set%prt)
if (particle_set%prt(i)%status == PRT_OUTGOING .and. &
(particle_set%prt(i)%flv%get_pdg () == GLUON .or. &
particle_set%prt(i)%flv%get_pdg_abs () < 6) .or. &
particle_set%prt(i)%status == PRT_BEAM_REMNANT) then
particle_set%prt(i)%status = PRT_VIRTUAL
end if
end do
end subroutine fudge_whizard_partons_in_hadro
@ %def fudge_whizard_partons_in_hadro
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: get_final_colored_ME_momenta => shower_pythia6_get_final_colored_ME_momenta
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_get_final_colored_ME_momenta &
(shower, momenta)
class(shower_pythia6_t), intent(in) :: shower
type(vector4_t), dimension(:), allocatable, intent(out) :: momenta
<<PYJETS COMMON BLOCK>>
integer :: i, j, n_jets
if (signal_is_pending ()) return
i = 7 !!! final ME partons start in 7th row of event record
n_jets = 0
do
if (K(I,1) /= 21) exit
if ((K(I,2) == 21) .or. (abs(K(I,2)) <= 6)) then
n_jets = n_jets + 1
end if
i = i + 1
end do
if (n_jets == 0) return
allocate (momenta(1:n_jets))
i = 7
j = 1
do
if (K(I,1) /= 21) exit
if ((K(I,2) == 21) .or. (abs(K(I,2)) <= 6)) then
momenta(j) = real ([P(i,4), P(i,1:3)], kind=default)
j = j + 1
end if
i = i + 1
end do
end subroutine shower_pythia6_get_final_colored_ME_momenta
@ %def shower_pythia6_get_final_colored_ME_momenta
@
<<Shower pythia6: public>>=
public :: pythia6_setup_lhe_io_units
<<Shower pythia6: procedures>>=
subroutine pythia6_setup_lhe_io_units (u_W2P, u_P2W)
integer, intent(out) :: u_W2P
integer, intent(out), optional :: u_P2W
character(len=10) :: buffer
u_W2P = free_unit ()
if (debug_active (D_SHOWER)) then
open (unit=u_W2P, status="replace", file="whizardout.lhe", &
action="readwrite")
else
open (unit=u_W2P, status="scratch", action="readwrite")
end if
write (buffer, "(I10)") u_W2P
call pygive ("MSTP(161)=" // buffer) !!! Unit for PYUPIN (LHA)
call pygive ("MSTP(162)=" // buffer) !!! Unit for PYUPEV (LHA)
if (present (u_P2W)) then
u_P2W = free_unit ()
write (buffer, "(I10)") u_P2W
call pygive ("MSTP(163)=" // buffer)
if (debug_active (D_SHOWER)) then
open (unit=u_P2W, file="pythiaout2.lhe", status="replace", &
action="readwrite")
else
open (unit=u_P2W, status="scratch", action="readwrite")
end if
end if
end subroutine pythia6_setup_lhe_io_units
@ %def pythia6_setup_lhe_io_units
@
<<Shower pythia6: public>>=
public :: pythia6_set_config
<<Shower pythia6: procedures>>=
subroutine pythia6_set_config (pygive_all)
type(string_t), intent(in) :: pygive_all
type(string_t) :: pygive_remaining, pygive_partial
if (len (pygive_all) > 0) then
pygive_remaining = pygive_all
do while (len (pygive_remaining) > 0)
call split (pygive_remaining, pygive_partial, ";")
call pygive (char (pygive_partial))
end do
if (pythia6_get_error() /= 0) then
call msg_fatal &
(" PYTHIA6 did not recognize ps_PYTHIA_PYGIVE setting.")
end if
end if
end subroutine pythia6_set_config
@ %def pythia_6_set_config
@ Exchanging error messages with PYTHIA6.
<<Shower pythia6: public>>=
public :: pythia6_set_error
<<Shower pythia6: procedures>>=
subroutine pythia6_set_error (mstu23)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
integer, intent(in) :: mstu23
MSTU(23) = mstu23
end subroutine pythia6_set_error
@ %def pythia6_set_error
@
<<Shower pythia6: public>>=
public :: pythia6_get_error
<<Shower pythia6: procedures>>=
function pythia6_get_error () result (mstu23)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
integer :: mstu23
mstu23 = MSTU(23)
end function pythia6_get_error
@ %def pythia6_get_error
@
<<Shower pythia6: public>>=
public :: pythia6_tauola_active
<<Shower pythia6: procedures>>=
function pythia6_tauola_active () result (active)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
logical :: active
active = MSTJ(28) == 2
end function pythia6_tauola_active
@ %def pythia6_tauola_active
@
<<Shower pythia6: public>>=
public :: pythia6_handle_errors
<<Shower pythia6: procedures>>=
function pythia6_handle_errors () result (valid)
logical :: valid
valid = pythia6_get_error () == 0
if (.not. valid) then
call pythia6_set_error (0)
end if
end function pythia6_handle_errors
@ %def pythia6_handle_errors
@
<<Shower pythia6: public>>=
public :: pythia6_set_verbose
<<Shower pythia6: procedures>>=
subroutine pythia6_set_verbose (verbose)
logical, intent(in) :: verbose
if (verbose) then
call pygive ('MSTU(13)=1')
else
call pygive ('MSTU(12)=12345') !!! No title page is written
call pygive ('MSTU(13)=0') !!! No information is written
end if
end subroutine pythia6_set_verbose
@ %def pythia6_set_verbose
@
<<Shower pythia6: public>>=
public :: pythia6_set_last_treated_line
<<Shower pythia6: procedures>>=
subroutine pythia6_set_last_treated_line (last_line)
integer,intent(in) :: last_line
N_old = last_line
end subroutine pythia6_set_last_treated_line
@ %def pythia6_set_last_treated_line
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@
<<[[pythia6_up.f]]>>=
C...UPINIT
C...Is supposed to fill the HEPRUP commonblock with info
C...on incoming beams and allowed processes.
SUBROUTINE UPINIT
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...PYTHIA commonblock: only used to provide read unit MSTP(161).
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
SAVE /PYPARS/
C...User process initialization commonblock.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
SAVE /HEPRUP/
C...Lines to read in assumed never longer than 200 characters.
PARAMETER (MAXLEN=200)
CHARACTER*(MAXLEN) STRING
C...Format for reading lines.
CHARACTER(len=6) STRFMT
STRFMT='(A000)'
WRITE(STRFMT(3:5),'(I3)') MAXLEN
C...Loop until finds line beginning with "<init>" or "<init ".
100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
IBEG=0
110 IBEG=IBEG+1
C...Allow indentation.
IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
&STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
C...Read first line of initialization info.
READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
&EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
C...Read NPRUP subsequent lines with information on each process.
DO 120 IPR=1,NPRUP
READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
& XMAXUP(IPR),LPRUP(IPR)
120 CONTINUE
RETURN
C...Error exit: give up if initalization does not work.
130 WRITE(*,*) ' Failed to read LHEF initialization information.'
WRITE(*,*) ' Event generation will be stopped.'
CALL PYSTOP(12)
RETURN
END
@
<<[[pythia6_up.f]]>>=
C...UPEVNT
C...Dummy routine, to be replaced by a user implementing external
C...processes. Depending on cross section model chosen, it either has
C...to generate a process of the type IDPRUP requested, or pick a type
C...itself and generate this event. The event is to be stored in the
C...HEPEUP commonblock, including (often) an event weight.
C...New example: handles a standard Les Houches Events File.
SUBROUTINE UPEVNT
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...PYTHIA commonblock: only used to provide read unit MSTP(162).
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
SAVE /PYPARS/
C...Added by WHIZARD
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
C...User process event common block.
INTEGER MAXNUP
PARAMETER (MAXNUP=500)
INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
&ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
&VTIMUP(MAXNUP),SPINUP(MAXNUP)
SAVE /HEPEUP/
C...Lines to read in assumed never longer than 200 characters.
PARAMETER (MAXLEN=200)
CHARACTER*(MAXLEN) STRING
C...Format for reading lines.
CHARACTER(len=6) STRFMT
STRFMT='(A000)'
WRITE(STRFMT(3:5),'(I3)') MAXLEN
C...Loop until finds line beginning with "<event>" or "<event ".
100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
IBEG=0
110 IBEG=IBEG+1
C...Allow indentation.
IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
&STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
C...Read first line of event info.
READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
&AQEDUP,AQCDUP
C...Read NUP subsequent lines with information on each particle.
DO 120 I=1,NUP
READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
& MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
& (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
120 CONTINUE
RETURN
C...Error exit, typically when no more events.
130 CONTINUE
C WRITE(*,*) ' Failed to read LHEF event information.'
C WRITE(*,*) ' Will assume end of file has been reached.'
NUP=0
MSTI(51)=1
C...Added by WHIZARD, mark these failed events
MSTU(23)=1
RETURN
END
@
<<[[pythia6_up.f]]>>=
C...UPVETO
C...Dummy routine, to be replaced by user, to veto event generation
C...on the parton level, after parton showers but before multiple
C...interactions, beam remnants and hadronization is added.
C...If resonances like W, Z, top, Higgs and SUSY particles are handed
C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
C...be undecayed at this stage; if decayed their decay products will
C...have been allowed to shower.
C...All partons at the end of the shower phase are stored in the
C...HEPEVT commonblock. The interesting information is
C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
C...IDHEP(I) = the particle ID code according to PDG conventions,
C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
C...All ISTHEP entries are 1, while the rest is zeroed.
C...The user decision is to be conveyed by the IVETO value.
C...IVETO = 0 : retain current event and generate in full;
C... = 1 : abort generation of current event and move to next.
SUBROUTINE UPVETO(IVETO)
C...HEPEVT commonblock.
PARAMETER (NMXHEP=4000)
COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
&JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
DOUBLE PRECISION PHEP,VHEP
SAVE /HEPEVT/
C...Next few lines allow you to see what info PYVETO extracted from
C...the full event record for the first two events.
C...Delete if you don't want it.
DATA NLIST/0/
SAVE NLIST
IF(NLIST.LE.2) THEN
WRITE(*,*) ' Full event record at time of UPVETO call:'
CALL PYLIST(1)
WRITE(*,*) ' Part of event record made available to UPVETO:'
CALL PYLIST(5)
NLIST=NLIST+1
ENDIF
C...Make decision here.
IVETO = 0
RETURN
END
@ %def pythia6_up.f
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@
<<[[ktclus.f90]]>>=
<<File header>>
module ktclus
<<Use kinds>>
<<KTCLUS: public>>
contains
<<KTCLUS: procedures>>
end module ktclus
@ %def ktclus
<<KTCLUS: 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-----------------------------------------------------------------------
<<KTCLUS: public>>=
public :: ktclur
<<KTCLUS: procedures>>=
SUBROUTINE KTCLUR(IMODE,PP,NN,R,ECUT,Y,*)
use io_units
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 ','Pt**2 ','**********', &
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-----------------------------------------------------------------------
<<KTCLUS: public>>=
public :: ktreco
<<KTCLUS: procedures>>=
!C-----------------------------------------------------------------------
SUBROUTINE KTRECO(RECO,PP,NN,ECUT,YCUT,YMAC,PJET,JET,NJET,NSUB,*)
IMPLICIT NONE
!C---RECONSTRUCT KINEMATICS OF JET SYSTEM, WHICH HAS ALREADY BEEN
!C ANALYSED BY KTCLUS. NOTE THAT NO CONSISTENCY CHECK IS MADE: USER
!C IS TRUSTED TO USE THE SAME PP VALUES AS FOR KTCLUS
!C
!C RECO = INPUT : RECOMBINATION SCHEME (NEED NOT BE SAME AS KTCLUS)
!C PP(I,J) = INPUT : 4-MOMENTUM OF Jth PARTICLE: I=1,4 => PX,PY,PZ,E
!C NN = INPUT : NUMBER OF PARTICLES
!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
!C YCUT = INPUT : Y VALUE AT WHICH TO RECONSTRUCT JET MOMENTA
!C YMAC = INPUT : Y VALUE USED TO DEFINE MACRO-JETS, TO DETERMINE
!C WHICH JETS ARE SUB-JETS
!C PJET(I,J)=OUTPUT : 4-MOMENTUM OF Jth JET AT SCALE YCUT
!C JET(J) =OUTPUT : THE MACRO-JET WHICH CONTAINS THE Jth JET,
!C SET TO ZERO IF JET IS NOT A SUB-JET
!C NJET =OUTPUT : THE NUMBER OF JETS
!C NSUB =OUTPUT : THE NUMBER OF SUB-JETS (EQUAL TO THE NUMBER OF
!C NON-ZERO ENTRIES IN JET())
!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
!C COULD NOT BE PROCESSED
!C
!C NOTE THAT THE MOMENTA ARE DECLARED DOUBLE PRECISION,
!C AND ALL OTHER FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
!C
INTEGER NMAX,RECO,NUM,N,NN,NJET,NSUB,JET(*),HIST,IMIN,JMIN,I,J
PARAMETER (NMAX=512)
DOUBLE PRECISION PP(4,*),PJET(4,*)
DOUBLE PRECISION ECUT,P,KT,KTP,KTS,ETOT,RSQ,ETSQ,YCUT,YMAC,KTLAST, &
ROUND
PARAMETER (ROUND=0.99999D0)
COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
!C---CHECK INPUT
IF (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 (ETSQ*KT(N).LT.ROUND*YCUT) 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 (ETSQ*KT(N).LT.ROUND*YMAC) 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 (ETSQ*KTLAST(N).LT.ROUND*YMAC) 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-----------------------------------------------------------------------
<<KTCLUS: procedures>>=
!C-----------------------------------------------------------------------
FUNCTION KTPAIR(ANGL,P,Q,ANGLE)
IMPLICIT NONE
!C---CALCULATE LOCAL KT OF PAIR, USING ANGULAR SCHEME:
!C 1=>ANGULAR, 2=>DeltaR, 3=>f(DeltaEta,DeltaPhi)
!C WHERE f(eta,phi)=2(COSH(eta)-COS(phi)) IS THE QCD EMISSION METRIC
!C---IF ANGLE<0, IT IS SET TO THE ANGULAR PART OF THE LOCAL KT ON RETURN
!C IF ANGLE>0, IT IS USED INSTEAD OF THE ANGULAR PART OF THE LOCAL KT
INTEGER ANGL
! CHANGE DOUBLE PRECISION P(9),Q(9),KTPAIR,R,KTMDPI,ANGLE,ETA,PHI,ESQ
DOUBLE PRECISION P(9),Q(9),KTPAIR,R,ANGLE,ETA,PHI,ESQ
!C---COMPONENTS OF MOMENTA ARE PX,PY,PZ,E,1/P,PT,ETA,PHI,PT**2
R=ANGLE
IF (ANGL.EQ.1) THEN
IF (R.LE.0) R=2*(1-(P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3))*(P(5)*Q(5)))
ESQ=MIN(P(4),Q(4))**2
ELSEIF (ANGL.EQ.2.OR.ANGL.EQ.3) THEN
IF (R.LE.0) THEN
ETA=P(7)-Q(7)
PHI=KTMDPI(P(8)-Q(8))
IF (ANGL.EQ.2) THEN
R=ETA**2+PHI**2
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)**2*R
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.EPS*B(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))= &
(PI*KTUP(I,K)+PJ*KTUP(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)*PTT*KTMDPI(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)*PTT*KTMDPI(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.EPS*P(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-----------------------------------------------------------------------
<<KTCLUS: procedures>>=
FUNCTION KTMDPI(PHI)
IMPLICIT NONE
!C---RETURNS PHI, MOVED ONTO THE RANGE [-PI,PI)
DOUBLE PRECISION KTMDPI,PHI,PI,TWOPI,THRPI,EPS
PARAMETER (PI=3.14159265358979324D0,TWOPI=6.28318530717958648D0, &
THRPI=9.42477796076937972D0)
PARAMETER (EPS=1D-15)
KTMDPI=PHI
IF (KTMDPI.LE.PI) THEN
IF (KTMDPI.GT.-PI) THEN
GOTO 100
ELSEIF (KTMDPI.GT.-THRPI) THEN
KTMDPI=KTMDPI+TWOPI
ELSE
KTMDPI=-MOD(PI-KTMDPI,TWOPI)+PI
ENDIF
ELSEIF (KTMDPI.LE.THRPI) THEN
KTMDPI=KTMDPI-TWOPI
ELSE
KTMDPI=MOD(PI+KTMDPI,TWOPI)-PI
ENDIF
100 IF (ABS(KTMDPI).LT.EPS) KTMDPI=0
END FUNCTION KTMDPI
!C-----------------------------------------------------------------------
SUBROUTINE KTWARN(SUBRTN,ICODE,*)
!C DEALS WITH ERRORS DURING EXECUTION
!C SUBRTN = NAME OF CALLING SUBROUTINE
!C ICODE = ERROR CODE: - 99 PRINT WARNING & CONTINUE
!C 100-199 PRINT WARNING & JUMP
!C 200- PRINT WARNING & STOP DEAD
!C-----------------------------------------------------------------------
INTEGER ICODE
CHARACTER(len=6) SUBRTN
WRITE (6,10) SUBRTN,ICODE
10 FORMAT(/' KTWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4/)
IF (ICODE.LT.100) RETURN
IF (ICODE.LT.200) RETURN 1
STOP
END SUBROUTINE KTWARN
!C-----------------------------------------------------------------------
!C-----------------------------------------------------------------------
!C-----------------------------------------------------------------------
@ %def ktclus ktclur ktycut ktysub
@ %def ktbeam ktjoin ktreco ktincl
@ %def ktisub ktijoi ktirec ktwich
@ %def ktwchs ktfram ktbrei kthadr
@ %def ktpair ktsing ktpmin ktsmin
@ %def ktcopy ktmerg ktmove ktunit
@ %def ktlbst ktrrot ktvmul ktmmul
@ %def ktinvt ktmdpi ktwarn
Index: trunk/src/tauola/tauola_interface.f90
===================================================================
--- trunk/src/tauola/tauola_interface.f90 (revision 7594)
+++ trunk/src/tauola/tauola_interface.f90 (revision 7595)
@@ -1,935 +1,937 @@
!
! WHIZARD Tauola interface
! Adapted from ilc_tauola_mod.f90
! for Whizard1 developed by Timothy Barklow (SLAC)
!
! Akiya Miyamoto
!
module tauola_interface
use kinds
use io_units
use constants
use iso_varying_string, string_t => varying_string
use format_utils, only: write_separator
use diagnostics
use hep_common
use hepev4_aux
use variables
use model_data
implicit none
private
- public :: ilc_tauola_pytaud
+ public :: wo_tauola_pytaud
public :: tauspin_pyjets
- public :: ilc_tauola_get_helicity_mod
- public :: ilc_tauola_init_call
- public :: ilc_tauola_get_helicity
+ public :: wo_tauola_get_helicity_mod
+ public :: wo_tauola_init_call
+ public :: wo_tauola_get_helicity
public :: taudec_settings_t
public :: pyjets_spin_t
!!! THIS COMMON BLOCK IS USED FOR COMMUNICATION WITH TAUOLA
- common/taupos/np1,np2
- integer :: np1
- integer :: np2
+ common /taupos/ np1, np2
+ integer :: np1
+ integer :: np2
!!! THIS COMMON BLOCK IS USED FOR COMMUNICATION WITH TAUOLA
COMMON / MOMDEC / Q1,Q2,P1,P2,P3,P4
double precision Q1(4),Q2(4),P1(4),P2(4),P3(4),P4(4)
double precision, external :: wthiggs
logical, save, public :: trans_spin
logical, save, public :: tau_pol_vec
integer :: jtau2, jorig, jforig
integer :: nproducts
integer, parameter :: n_pyjets_max = 4000
integer, save :: max_dump = 0
integer, save :: nsub_call = 0
double precision :: spin_dexay
double precision, dimension(n_pyjets_max) :: tauspin_pyjets
double precision, dimension(4) :: pol
logical :: higgs_dec
!!! Probability of tau- to be left-handed in Z decays
double precision, parameter :: a_tau = 0.15
double precision, parameter :: prob_tau_left_z = (a_tau+1.) / 2.
type :: taudec_settings_t
logical :: photos
logical :: transverse
logical :: dec_rad_cor
integer :: dec_mode1
integer :: dec_mode2
real(default) :: mh
real(default) :: mix_angle
real(default) :: mtau
logical :: use_pol_vec
contains
procedure :: init => taudec_settings_init
procedure :: write => taudec_settings_write
end type taudec_settings_t
type :: pyjets_spin_t
- integer :: index_to_hepeup ! =-1, if no matching entry in hepeup
- double precision :: helicity ! copy of SPINUP
- integer :: pid ! particle ID
- integer :: id_orig ! pid of parent
- integer :: index_orig ! index of parent
- integer :: n_daughter ! number of daughter
+ integer :: index_to_hepeup ! =-1, if no matching entry in hepeup
+ double precision :: helicity ! copy of SPINUP
+ integer :: pid ! particle ID
+ integer :: id_orig ! pid of parent
+ integer :: index_orig ! index of parent
+ integer :: n_daughter ! number of daughter
integer, dimension(10) :: index_daughter ! index of daughter particles
end type pyjets_spin_t
type(pyjets_spin_t), dimension(n_pyjets_max), save :: pyjets_spin_data
integer :: last_event_number = -999
interface
function pyr(i_dum)
implicit none
double precision :: pyr
integer, intent(in) :: i_dum
end function pyr
end interface
contains
subroutine fill_pyjets_spin_data
integer :: ip
integer :: hepeup_index
integer :: iorig
integer :: idau1, idau2, n_doc_lines
integer, dimension(200) :: mstp
double precision, dimension(200) :: parp
integer, dimension(200) :: msti
double precision, dimension(200) :: pari
common/pypars/mstp,parp,msti,pari
save/pypars/
integer :: n
integer :: npad
integer, dimension(4000,5) :: k
double precision, dimension(4000,5) :: p
double precision, dimension(4000,5) :: v
common/pyjets/n,npad,k,p,v
save/pyjets/
!!! Set helicity information of document lines at the first call of
!!! this event
!!! MSTI(4) ; number of documentation lines
!!! MSTI(5) ; number of events generated
if (last_event_number == MSTI(5)) then
return
end if
do ip = 1, n_pyjets_max
pyjets_spin_data(ip)%index_to_hepeup = -100
pyjets_spin_data(ip)%helicity = 100
end do
ip = 1
hepeup_index = 0
do while (k(ip,1) == 21)
pyjets_spin_data(ip)%pid = k(ip,2)
pyjets_spin_data(ip)%id_orig = k(ip,3)
pyjets_spin_data(ip)%index_orig = ip
pyjets_spin_data(ip)%n_daughter = 0
iorig = k(ip,3)
if (iorig == 0) then
hepeup_index = hepeup_index + 1
pyjets_spin_data(ip)%index_to_hepeup = hepeup_index
pyjets_spin_data(ip)%helicity = spinup(hepeup_index)
else
pyjets_spin_data(ip)%index_to_hepeup = -1
pyjets_spin_data(ip)%helicity = 0
pyjets_spin_data(iorig)%n_daughter = &
pyjets_spin_data(iorig)%n_daughter + 1
pyjets_spin_data(iorig)%index_daughter(pyjets_spin_data(iorig)%n_daughter)=ip
end if
if (debug2_active (D_TAUOLA)) then
call msg_debug2 (D_TAUOLA, "TAUOLA interface: fill_pyjets_spin_data")
write (msg_buffer, "(A,I0,A,I0,A,I0,A,ES19.12)") &
"ip = ", ip, " iorig = ", iorig, " pid ", k(ip,2), &
" spin = ", pyjets_spin_data(ip)%helicity
call msg_message ()
end if
if (abs(k(ip,2)) == 15 .and. pyjets_spin_data(ip)%helicity == 9) then
if (nsub_call .lt. min(5, 2*max_dump)) then
write (msg_buffer, "(A)") &
"Subroutine fill_pyjets_spin_data: tau helicity information"
call msg_message ()
write (msg_buffer, "(A)") &
"is not set, though polarized tau decay was requested."
call msg_message ()
write (msg_buffer, "(A)") &
"Most likely, the SINDARIN file does not include polarized"
call msg_message ()
write (msg_buffer, "(A)") &
"for particles and/or not ?polarized_events=true"
call msg_message ()
write (msg_buffer, "(A,I0,A,I0,A,I0,A,I0)") &
"Number of calls:", nsub_call, " ip = ", ip, " iorig = ", &
iorig, " pid = ", k(ip,2), " spin = ", &
pyjets_spin_data(ip)%helicity
end if
end if
ip = ip + 1
end do
n_doc_lines = ip - 1
do ip = 1, n_doc_lines
if (pyjets_spin_data(ip)%n_daughter == 2) then
!!! h0/H0/A0 -> tau tau
if (pyjets_spin_data(ip)%pid == 25 .or. &
pyjets_spin_data(ip)%pid == 35 .or. &
pyjets_spin_data(ip)%pid == 36) then
idau1 = pyjets_spin_data(ip)%index_daughter(1)
idau2 = pyjets_spin_data(ip)%index_daughter(2)
if (abs(pyjets_spin_data(idau1)%pid) == 15 .and. &
(pyjets_spin_data(idau1)%pid + &
pyjets_spin_data(idau2)%pid) == 0) then
if (pyr(0) .lt. 0.5) then
pyjets_spin_data(idau1)%helicity = -1
pyjets_spin_data(idau2)%helicity = +1
else
pyjets_spin_data(idau1)%helicity = +1
pyjets_spin_data(idau2)%helicity = -1
end if
end if
!!! Z0 -> tau tau
else if (pyjets_spin_data(ip)%pid == 23) then
idau1 = pyjets_spin_data(ip)%index_daughter(1)
idau2 = pyjets_spin_data(ip)%index_daughter(2)
if (abs(pyjets_spin_data(idau1)%pid) == 15 .and. &
(pyjets_spin_data(idau1)%pid + &
pyjets_spin_data(idau2)%pid) == 0) then
if (((pyr(0) - prob_tau_left_z) * &
pyjets_spin_data(idau1)%pid) .gt. 0.0) then
pyjets_spin_data(idau1)%helicity = +1
pyjets_spin_data(idau2)%helicity = -1
else
pyjets_spin_data(idau1)%helicity = -1
pyjets_spin_data(idau2)%helicity = +1
end if
end if
!!! W+(24)/H+(37) -> tau+(-15) and neu_tau
else if ( pyjets_spin_data(ip)%pid == 24 .or. &
pyjets_spin_data(ip)%pid == 37) then
idau1 = pyjets_spin_data(ip)%index_daughter(1)
idau2 = pyjets_spin_data(ip)%index_daughter(2)
if ( pyjets_spin_data(idau1)%pid == -15 ) then
pyjets_spin_data(idau1)%helicity = 1
else if ( pyjets_spin_data(idau2)%pid == -15 ) then
pyjets_spin_data(idau2)%helicity = 1
end if
!!! W-(-24)/H-(-37) -> tau-(+15) and neu_tau_bar
else if (pyjets_spin_data(ip)%pid == -24 .or. &
pyjets_spin_data(ip)%pid == -37) then
idau1 = pyjets_spin_data(ip)%index_daughter(1)
idau2 = pyjets_spin_data(ip)%index_daughter(2)
if (pyjets_spin_data(idau1)%pid == 15) then
pyjets_spin_data(idau1)%helicity = -1
else if (pyjets_spin_data(idau2)%pid == 15) then
pyjets_spin_data(idau2)%helicity = -1
end if
end if
end if
end do
end subroutine fill_pyjets_spin_data
! =====================================================================
! Main interface to tauola.
! Called by PYTAUD and calls TAUOLA
! =====================================================================
- subroutine ilc_tauola_pytaud (itau, iorig, kforig, ndecay)
+ subroutine wo_tauola_pytaud (itau, iorig, kforig, ndecay)
!!! Line number in /JETSET/ where the tau is stored
integer, intent(in) :: itau
!!! Line number where the mother is stored. =0 if the mother is not stored
integer, intent(in) :: iorig
!!! Flavour code of the mother. 0 unknown. H0(25), W+-(+-24),
!!! gamma*/Z=23, H+-(+-37)
integer, intent(in) :: kforig
!!! Number of decay products to be given by user routine.
integer, intent(out) :: ndecay
double precision, dimension(5) :: p_dexay
integer :: id_dexay
integer :: ip
integer :: n
integer :: npad
integer, dimension(4000,5) :: k
double precision, dimension(4000,5) :: p
double precision, dimension(4000,5) :: v
common /pyjets/ n, npad, k, p, v
save /pyjets/
integer, dimension(200) :: mstp
double precision, dimension(200) :: parp
integer, dimension(200) :: msti
double precision, dimension(200) :: pari
common /pypars/ mstp, parp, msti, pari
save /pypars/
!!! TODO: (bcn 2016-03-11) this should only be
!!! called once per event (not per tau)
integer :: itau1, ktau, idau1, idau2
higgs_dec = .false.
if (kforig == 25 .or. kforig==35 .or. kforig== 36) then
higgs_dec = .true.
end if
!!! JRR: Tau decays are very sensitive to numerical noise, momenta
!!! should be, in principle, strictly on the z axis
if (abs (p(itau,1)) < 1.d-13) p(itau,1) = 0
if (abs (p(itau,2)) < 1.d-13) p(itau,2) = 0
!!! MSTI(4): number of documentation lines
!!! MSTI(5): number of events generated
if (last_event_number .ne. MSTI(5)) then
call fill_pyjets_spin_data
last_event_number = MSTI(5)
jtau2 = -1000
nsub_call = nsub_call + 1
end if
if (nsub_call .lt. max_dump) then
- write (msg_buffer, "(A)") "ilc_tauola_pytaud was called."
+ write (msg_buffer, "(A)") "wo_tauola_pytaud was called."
call msg_message ()
write (msg_buffer, "(A,I0,A,I0,A,I0,A,I0)") &
"ncall = ", nsub_call, "itau = ", itau, " iorig = ", iorig, &
" kforig = ", kforig
call msg_message ()
call pylist(2)
end if
jorig = iorig
jforig = kforig
!!! If tau origin is not known (tau is generated by parton generator with
!!! with full matrix elements), look for the parton information, which is
!!! stored as status code 21
if (iorig == 0) then
ip = itau
do while (k(ip,3) .ne. 0 .or. ip .le. 0)
ip = k(ip,3)
end do
id_dexay = k(itau,2)
p_dexay = p(itau,1:5)
pyjets_spin_data(itau)%helicity = pyjets_spin_data(ip)%helicity
spin_dexay = pyjets_spin_data(ip)%helicity
!!! If tau origin is known (iorig .ne. 0), decide tau helicity
!!! based on parent particle id (kforig)
!!! kforig = 25/35/36: 2 tau's spin must be generated: tau
else
id_dexay = k(itau,2)
p_dexay = p(itau,1:5)
!!! h0 or Z0 or W case
if (higgs_dec .or. kforig==23 .or. abs(kforig)==24) then
ip = k(itau,3)
if (k(ip,1)==21 .and. abs(k(ip,2))==15) then
pyjets_spin_data(itau)%helicity = pyjets_spin_data(ip)%helicity
end if
spin_dexay = pyjets_spin_data(itau)%helicity
!!! Fill momentum of second tau if kforig == 25 ( Higgs )
if (higgs_dec .and. trans_spin) then
idau1 = pyjets_spin_data(iorig)%index_daughter(1)
idau2 = pyjets_spin_data(iorig)%index_daughter(2)
!!! Parent Higgs is not in the documentation line (K(,1) != 21)
!!! Get pointer to daughter directly from JETSET
if (idau1 == 0) then
idau1 = k(iorig,4)
idau2 = k(iorig,5)
end if
if (idau1 .ne. itau) then
write (msg_buffer, "(A,I0,A,I0,A)") &
"idau1 = ", idau1, "itau = ", itau, " are not equal."
- call msg_fatal ("ilc_tauola_pytaud: " // &
+ call msg_fatal ("wo_tauola_pytaud: " // &
"Something is wrong in parent-daughter relation.")
end if
jtau2 = idau2
!!! Reset tau spin information because it is decided internally
pyjets_spin_data(itau)%helicity = 0
pyjets_spin_data(jtau2)%helicity = 0
end if
else
!!! Unknow decay mother
- call msg_warning ("ilc_tau_decay : Unknown decay modther of " // &
+ call msg_warning ("wo_tau_decay : Unknown decay modther of " // &
"tau, id = " // int2char (kforig) // ", tau is 50% right " // &
"or 50% left handed.")
if (pyr(0) .lt. 0.5) then
spin_dexay = -1
else
spin_dexay = +1
end if
pyjets_spin_data(itau)%helicity = spin_dexay
end if
end if
call do_dexay (itau, p_dexay, id_dexay, kforig)
ndecay = nproducts
- end subroutine ilc_tauola_pytaud
+ end subroutine wo_tauola_pytaud
subroutine do_dexay (itau, p_dexay, id_dexay, kforig)
!!! Main routine to call Tauola. Three type of tau decay:
!!! (A) Higgs to tau+tau-
!!! (B) single tau+ decay
!!! (C) single tau- decay, are treated separately
integer, intent(in) :: itau, id_dexay
double precision, dimension(5), intent(in) :: p_dexay
integer, intent(in) :: kforig
integer :: i, IFPHOT
logical :: ifpseudo, is_swapped
double precision, dimension(4) :: pol1, pol2
integer :: im, idx1, idx2, idsign
double precision :: rrr(1), wt
double precision :: hh1(4), hh2(4)
integer :: ion(3), np
common /PHOACT/ IFPHOT
integer :: n
integer :: npad
integer, dimension(4000,5) :: k
double precision, dimension(4000,5) :: p
double precision, dimension(4000,5) :: v
common /pyjets/ n, npad, k, p, v
save /pyjets/
- integer, save :: n_akiya = 0
- ! integer, save :: n_akiya = 1
- integer :: n1, n2
-
+ integer :: n1, n2
+
is_swapped = .false.
- n1 = n_akiya + 1
- n2 = n_akiya + 2
+ !!! For transverse spin of the Higgs, Higgs and the two taus
+ !!! have to be considered
+ if (trans_spin) then
+ n1 = 2
+ n2 = 3
+ nhep = 3
+ else
+ n1 = 1
+ n2 = 2
+ nhep = 2
+ end if
tauspin_pyjets(itau) = spin_dexay
- !!! change nhep from 2 -> 3 changes tauola_2 test output
- !!! plus changes of 1->2 and 2->3 in the next two blocks
- nhep = 2
!!! Does SPINHIGGS in tauface_jetset.f
ifpseudo = kforig == 36
isthep(n1) = 1
idhep(n1) = id_dexay
jmohep(:,n1) = 0
jdahep(:,n1) = 0
phep(:,n1) = p_dexay
isthep(n2) = 1
idhep(n2) = - id_dexay
jmohep(:,n2) = 0
jdahep(:,n2) = 0
- phep(1:3,n2) = - phep(1:3,1)
- phep(4:5,n2) = phep(4:5,1)
+ phep(1:3,n2) = - phep(1:3,n1)
+ phep(4:5,n2) = phep(4:5,n1)
!!! NOTE (Akiya Miyamoto, 25-March-2016)
!!! Higgs (h0/H0/A0) to tau+tau- decay is handled here
!!! in order to implement a transverse spin correlation.
!!! For this algorithm to work, photon emission from tau
!!! before decay should be turned off. Since photon emission
!!! from tau is handled by PYTHIA, photon emission from ALL tau
!!! should be turned off. It is done by setting MSTJ(39)=15.
!!! Instead, PHOTOS is called after tau decay and generate
!!! photons.
!!! ****************************************************************
!!! (A) Higgs to tau+ tau- decay .
!!! ****************************************************************
if (higgs_dec .and. trans_spin) then
if (idhep(2) .gt. 0) then
idhep(3) = id_dexay
idhep(2) = - id_dexay
is_swapped = .true.
end if
phep(:,n1) = p_dexay
phep(1:3,n2) = - phep(1:3,2)
phep(4:5,n2) = phep(4:5,2)
isthep(1) = 11
idhep(1) = kforig
jmohep(:,1) = 0
jdahep(1,1) = n1
jdahep(2,1) = n2
phep(:,1) = phep(:,2) + phep(:,3)
phep(5,1) = sqrt(phep(4,1)**2 - phep(1,1)**2 - phep(2,1)**2 - &
phep(3,1)**2)
jmohep(:,n1) = 1
jmohep(:,n2) = 1
p1=phep(1:4,np1) ! tau+ momentum
p2=phep(1:4,np2) ! tau- momentum
q1 = p1 + p2
im = 1
end if
!!! tau+ momentum should have positive Pz
!!! tau- momentum should have negative Pz
!!! ********************************************************
!!! (B) Single Tau+ decay
!!! ********************************************************
if (.not. trans_spin) then
check_tau_sign: if (idhep(n1) .lt. 0) then
np1 = n1
np2 = n2
pol = 0.
pol(3) = - spin_dexay
p1 = phep(1:4,n1)
p2 = phep(1:4,n2)
q1 = p1 + p2
if (nsub_call .lt. max_dump) then
call msg_message ("Tau+ decay with pol(3) = " // &
real2char (real (pol(3), kind=default)) // ".")
write (*, "(A,4(1x,ES19.12))") "Antiparticle decay, q1 = ", q1
write (*, "(A,4(1x,ES19.12))") "Antiparticle decay, p1 = ", p1
write (*, "(A,4(1x,ES19.12))") "Antiparticle decay, p2 = ", p2
end if
call msg_debug2 (D_TAUOLA, "TAUOLA is called here")
call dexay (1,pol)
- !!! TBD: check whether photos should be called here
- ! if (IFPHOT == 1) call photos (np1)
+ if (IFPHOT == 1) call photos (np1)
!!! ********************************************************
!!! (C) Single Tau- decay
!!! ********************************************************
else check_tau_sign
idhep(3) = id_dexay
idhep(2) = - id_dexay
np2 = n1
np1 = n2
pol = 0.
pol(3) = spin_dexay
!!! Akiya now has a relation with the negative spin_dexay
! pol(3) = - spin_dexay
p2 = phep(1:4,n1)
p1 = phep(1:4,n2)
q1 = p1 + p2
if (nsub_call .lt. max_dump) then
call msg_message ("Tau- decay with pol(3) = " // &
real2char (real (pol(3), kind=default)) // ".")
write (*, "(A,4(1x,ES19.12))") "Antiparticle decay, q1 = ", q1
write (*, "(A,4(1x,ES19.12))") "Antiparticle decay, p1 = ", p1
write (*, "(A,4(1x,ES19.12))") "Antiparticle decay, p2 = ", p2
end if
call msg_debug2 (D_TAUOLA, "TAUOLA is called here")
call dexay (2,pol)
- !!! TBD: check whether photos should be called here
- ! if (IFPHOT == 1) call photos(np2)
+ if (IFPHOT == 1) call photos (np2)
is_swapped = .true.
end if check_tau_sign
end if
!!! TODO (Akiya Miyamoto, 25-march-2016)
!!! In the following code, the tau helicity (polarization vector)
!!! information is not stored in pyjets_spin_data(jtau)%helicity
!!! and /HEPEV4/, because the tau polarization vector is determined
!!! here in order to have a transverse spin correlation between
!!! tau+ and tau-, but the decided polarization vectors are not
!!! calculated here. It would be possible to calculate them
!!! from the polarimetric vectors, hh1 and hh2, after
!!! the end of the rejection loop.
if (trans_spin) then
if (.not. tau_pol_vec) then
pol1 = 0
pol2 = 0
if (pyr(0) .gt. 0.5) then
pol1(3) = 1
pol2(3) = -1
else
pol1(3) = -1
pol2(3) = 1
end if
call dexay (1, pol1)
call dexay (2, pol2)
else
!!! Decide polarimetric vector to have a spin correlation
REJECTION: do
call ranmar (rrr, 1)
!!! tau+ decay
call dekay (1, hh1)
!!! tau- decay
call dekay (2, hh2)
wt = wthiggs (ifpseudo, hh1, hh2)
if (rrr(1) .lt. wt) exit REJECTION
end do REJECTION
ion = 0
call dekay(11, hh1)
call taupi0 (0, 1, ion)
call dekay(12, hh2)
call taupi0 (0, 2, ion)
end if
- if (IFPHOT == 1) call photos(im)
+ if (IFPHOT == 1) call photos (im)
end if
!!! **********************************************************
!!! Now copies /HEPEVT/ to /PYJETS/
!!! Higgs tau pair decay and single tau decay are treated
!!! separately.
!!! **********************************************************
nproducts = 0
np = nproducts
!!! =========================================================
!!! Higgs to tau pair decay case.
!!! =========================================================
if (higgs_dec .and. trans_spin .and. jtau2 .gt. 0) then
if (is_swapped) then
!!! invert all momentum
do i = n1, nhep
phep(1:3,i) = - phep(1:3,i)
end do
do i = n2+1, nhep
if (jmohep(1,i) == n1) then
jmohep(1,i) = n2
jmohep(2,i) = n2
else if (jmohep(1,i) == n2) then
jmohep(1,i) = n1
jmohep(2,i) = n1
end if
end do
end if
!!! Overwrite tau+ and tau- data in /PYJETS/, because tau+tau- momentum
!!! could have been changed due to photon emmision in Higgs --> tau+ tau-
!!! system. Their momentum should be boosted and rotate back to the lab frame
!!! in the calling routine, PYDCAY.
if (is_swapped) then
p(itau,:) = phep(:,3)
k(itau,4) = jdahep(1,3) - n2 + n
k(itau,5) = jdahep(2,3) - n2 + n
p(jtau2,:) = phep(:,2)
k(jtau2,4) = jdahep(1,2) - n2 + n
k(jtau2,5) = jdahep(2,2) - n2 + n
else
p(itau,:) = phep(:,2)
k(itau,4) = jdahep(1,2) - n2 + n
k(itau,5) = jdahep(2,2) - n2 + n
p(jtau2,:) = phep(:,3)
k(jtau2,4) = jdahep(1,3) - n2 + n
k(jtau2,5) = jdahep(2,3) - n2 + n
end if
k(itau, 1) = 11
k(jtau2, 1) = 11
k(itau, 3) = jorig
k(jtau2, 3) = jorig
!!! TODO : Akiya Miyamoto, 12-April-2016
!!! Reset daughter pointer of Higgs, because Higgs daughters
!!! increase when photons are emitted. This may not work well if
!!! additional particles exist after second tau.
k(jorig,4) = itau
k(jorig,5) = jtau2 ! jtau2 > jtau allways
if (jdahep(2,1)-jdahep(1,1)+1 .gt. 2) then
if (n .gt. jtau2) then
write (msg_buffer, "(A)") &
"Tau decay routine do_dexay: necessary to update " // &
"index of Higgs daughter in order to include photons " // &
"produced by PHOTOS."
call msg_message ()
write (msg_buffer, "(A)") &
"Run continues without modifying the 2nd daughter pointer."
call msg_message ()
else
k(jorig,5) = jdahep(2,1) - n2 + n
end if
end if
!!! Now, fill the information of tau daughters to /PYJETS/
nproducts = 0
loop_products_higgs: do i = n2+1, nhep
nproducts = nproducts + 1
p(n+nproducts,:) = phep(:,i)
k(n+nproducts,2) = idhep(i)
k(n+nproducts,3) = jmohep(1,i) - n2 + n
if (isthep(i) == 1) then
k(n+nproducts,1) = 1
k(n+nproducts,4) = 0
k(n+nproducts,5) = 0
else
k(n+nproducts,1) = 11
k(n+nproducts,4) = jdahep(1,i) - n2 + n
k(n+nproducts,5) = jdahep(2,i) - n2 + n
end if
end do loop_products_higgs
!!! ***************************************************************
!!! Single tau decay case.
!!! This case, parent tau daghter momentum is not over-wtitten
!!! ***************************************************************
else
loop_products_nohiggs: do i = n2+1, nhep
nproducts = nproducts + 1
p(n+nproducts,:) = phep(:,i)
if (isthep(i) == 1) then
k(n+nproducts,1) = 1
k(n+nproducts,4) = 0
k(n+nproducts,5) = 0
else
k(n+nproducts,1) = 11
k(n+nproducts,4) = jdahep(1,i) - n2 + n
k(n+nproducts,5) = jdahep(2,i) - n2 + n
end if
k(n+nproducts,2) = idhep(i)
if (abs(idhep(jmohep(1,i))) .ne. 15) then
k(n+nproducts,3) = jmohep(1,i) - n2 + n
else
k(n+nproducts,3) = itau
end if
end do loop_products_nohiggs
k(itau,4) = jdahep(1,2) - n2 + n
k(itau,5) = jdahep(2,2) - n2 + n
end if
if (nsub_call .lt. max_dump) then
call msg_message ("TAUOLA interface: PYLIST at the end of do_dexay")
n = n + nproducts
call pylist(2)
n = n - nproducts
end if
end subroutine do_dexay
subroutine taudec_settings_init (taudec_settings, var_list, model)
class(taudec_settings_t), intent(out) :: taudec_settings
type(var_list_t), intent(in) :: var_list
class(model_data_t), intent(in) :: model
type(field_data_t), pointer :: field
taudec_settings%photos = &
var_list%get_lval (var_str ("?ps_tauola_photos"))
taudec_settings%transverse = &
var_list%get_lval (var_str ("?ps_tauola_transverse"))
taudec_settings%dec_rad_cor = &
var_list%get_lval (var_str ("?ps_tauola_dec_rad_cor"))
taudec_settings%dec_mode1 = &
var_list%get_ival (var_str ("ps_tauola_dec_mode1"))
taudec_settings%dec_mode2 = &
var_list%get_ival (var_str ("ps_tauola_dec_mode2"))
taudec_settings%mh = &
var_list%get_rval (var_str ("ps_tauola_mh"))
taudec_settings%mix_angle = &
var_list%get_rval (var_str ("?ps_tauola_mix_angle"))
taudec_settings%use_pol_vec = &
var_list%get_lval (var_str ("?ps_tauola_pol_vector"))
select case (char (model%get_name ()))
case ("QCD", "Test")
call msg_fatal ("taudec_settings_init: Model has no tau.")
case default
field => model%get_field_ptr (15)
taudec_settings%mtau = field%get_mass ()
end select
end subroutine taudec_settings_init
subroutine taudec_settings_write (taudec_settings, unit)
class(taudec_settings_t), intent(in) :: taudec_settings
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u<0) return
write (u, "(1x,A)") "Tau decay settings:"
call write_separator (u)
write (u, "(3x,A,1x,L1)") &
"ps_tauola_photos = ", taudec_settings%photos
write (u, "(3x,A,1x,L1)") &
"ps_tauola_transverse = ", taudec_settings%transverse
write (u, "(3x,A,1x,L1)") &
"ps_tauola_dec_rad_cor = ", taudec_settings%dec_rad_cor
write (u, "(3x,A,1x,I2)") &
"ps_tauola_dec_mode1 = ", taudec_settings%dec_mode1
write (u, "(3x,A,1x,I2)") &
"ps_tauola_dec_mode2 = ", taudec_settings%dec_mode2
write (u, "(3x,A,1x,ES19.12)") &
"ps_tauola_mh = ", taudec_settings%mh
write (u, "(3x,A,1x,ES19.12)") &
"ps_tauola_mix_angle = ", taudec_settings%mix_angle
write (u, "(3x,A,1x,L1)") &
"ps_tauola_use_pol_vec = ", taudec_settings%use_pol_vec
end subroutine taudec_settings_write
- function ilc_tauola_get_helicity_mod (ip) result (the_helicity)
+ function wo_tauola_get_helicity_mod (ip) result (the_helicity)
integer, intent(in) :: ip
integer :: the_helicity
integer :: n, npad
integer, dimension(4000,5) :: k
double precision, dimension(4000,5) :: p
double precision, dimension(4000,5) :: v
common /pyjets/ n, npad, k, p, v
save /pyjets/
integer, dimension(200) :: mstu
double precision, dimension(200) :: paru
integer, dimension(200) :: mstj
double precision, dimension(200) :: parj
common /pydat1/ mstu, paru, mstj, parj
save /pydat1/
if ( MSTJ(28) .NE. 2 ) then
the_helicity=0
else
if ( ip .le. 0 .or. ip .gt. n ) then
the_helicity = 0
else
the_helicity = int(pyjets_spin_data(ip)%helicity)
end if
end if
- end function ilc_tauola_get_helicity_mod
+ end function wo_tauola_get_helicity_mod
- subroutine ilc_tauola_get_helicity (ip, the_helicity)
+ subroutine wo_tauola_get_helicity (ip, the_helicity)
integer, intent(in) :: ip
integer, intent(out) :: the_helicity
- the_helicity = ilc_tauola_get_helicity_mod(ip)
+ the_helicity = wo_tauola_get_helicity_mod(ip)
if ( abs(the_helicity) .gt. 1 ) then
write (msg_buffer, "(A,I0,A,I0,A)") &
"Stored helicity information is wrong: ", the_helicity, &
"for ip = ", ip, "."
call msg_warning ()
end if
- end subroutine ilc_tauola_get_helicity
+ end subroutine wo_tauola_get_helicity
- subroutine ilc_tauola_init_call (taudec_settings)
+ subroutine wo_tauola_init_call (taudec_settings)
!!! Tauola initialization.
!!! (default defined in rt_data)
!!! JAK1 ! (0) decay mode of first tau
!!! JAK2 ! (0) decay mode of second tau
!!! ITDKRC ! (1) switch on radiative corrections in decay
!!! IFPHOT ! (1) PHOTOS switch
type(taudec_settings_t), intent(in) :: taudec_settings
INTEGER JAK1, JAK2, JAKP, JAKM, KTOM
COMMON /JAKI/ JAK1, JAK2, JAKP, JAKM, KTOM
integer, dimension(200) :: MSTP
double precision, dimension(200) :: PARP
integer, dimension(200) :: MSTI
double precision, dimension(200) :: PARI
common /PYPARS/ MSTP, PARP, MSTI, PARI
save /PYPARS/
integer, dimension(200) :: MSTU
double precision, dimension(200) :: PARU
integer, dimension(200) :: MSTJ
double precision, dimension(200) :: PARJ
common /PYDAT1/ MSTU, PARU, MSTJ, PARJ
save /PYDAT1/
integer :: ITDKRC, IFPHOT
double precision :: psi, betah
double precision :: csc, ssc
common /pseudocoup/ csc, ssc
save /pseudocoup/
integer, dimension(3) :: ion
double precision, dimension(4) :: pol1x
JAK1 = taudec_settings%dec_mode1
JAK2 = taudec_settings%dec_mode2
if (taudec_settings%dec_rad_cor) then
ITDKRC = 1
else
ITDKRC = 0
end if
if (taudec_settings%photos) then
IFPHOT = 1
else
IFPHOT = 0
end if
trans_spin = taudec_settings%transverse
tau_pol_vec = taudec_settings%use_pol_vec
psi = dble (taudec_settings%mix_angle * degree)
betah = dble (sqrt (one - four * taudec_settings%mtau**2 / &
taudec_settings%mh**2))
csc = cos(psi) * betah
ssc = sin(psi)
if (trans_spin) then
if (mstj(39) .ne. 15) then
- call msg_warning ("ilc_tauola_init_call: transverse spin " // &
+ call msg_warning ("wo_tauola_init_call: transverse spin " // &
"correlation requested for H -> tau tau. Photon radiation " // &
"from PYTHIA will be switched off.")
mstj(39) = 15
end if
end if
call phoini
call inietc (JAK1, JAK2, ITDKRC, IFPHOT)
call inimas
call iniphx (0.01d0)
call initdk
! !!! Deactivation of pi0 and eta decays: (1) means on, (0) off
ion = 0
call taupi0 (-1, 1, ion)
call dekay (-1, pol1x)
if (debug2_active (D_TAUOLA)) then
call msg_debug2 (D_TAUOLA, "TAUOLA initialization")
call taudec_settings%write ()
call msg_debug2 (D_TAUOLA, " check if TAUOLA common block has been set")
call msg_debug2 (D_TAUOLA, "Tau decay modes set")
print *, " Tau decay modes: tau+(JAK1) = ", jak1, &
" tau-(JAK2) = ", JAK2
call msg_message (" JAK = 0 : All decay mode")
call msg_message (" JAK = 1 : electron mode")
call msg_message (" JAK = 2 : muon mode")
call msg_message (" JAK = 3 : pion mode")
call msg_message (" JAK = 4 : rho mode")
call msg_message (" JAK = 5 : a1 mode")
call msg_message (" JAK = 6 : K mode")
call msg_message (" JAK = 7 : K* mode")
call msg_message (" JAK = 8-13 : n pion modes")
call msg_message (" JAK = 14-19 : K K pi and K pi pi modes")
call msg_message (" JAK = 20-21 : eta pi pi; gamma pi pi modes")
call msg_debug2 (D_TAUOLA, "Radiative corrections in decay ON(1),Off(0)")
print *, " ITDKRC = ", ITDKRC
call msg_debug2 (D_TAUOLA, "PHOTOS switch: ON(1), OFF(0)")
print *, " IFPHOT = ", IFPHOT
end if
- end subroutine ilc_tauola_init_call
+ end subroutine wo_tauola_init_call
end module tauola_interface
!*********************************************************************
!...PYTAUD
!...Routine to handle the decay of a polarized tau lepton.
!...Input:
!...ITAU is the position where the decaying tau is stored in /PYJETS/.
!...IORIG is the position where the mother of the tau is stored;
!... is 0 when the mother is not stored.
!...KFORIG is the flavour of the mother of the tau;
!... is 0 when the mother is not known.
!...Note that IORIG=0 does not necessarily imply KFORIG=0;
!... e.g. in B hadron semileptonic decays the W propagator
!... is not explicitly stored but the W code is still unambiguous.
!...Output:
!...NDECAY is the number of decay products in the current tau decay.
!...These decay products should be added to the /PYJETS/ common block,
!...in positions N+1 through N+NDECAY. For each product I you must
!...give the flavour codes K(I,2) and the five-momenta P(I,1), P(I,2),
!...P(I,3), P(I,4) and P(I,5). The rest will be stored automatically.
subroutine pytaud (itau, iorig, kforig, ndecay)
use tauola_interface
implicit none
integer itau,iorig,kforig
integer ndecay
!print *,"###############################################"
!print *,"###### tauola pytaud was called ###############"
!print *," itau,iorig,kforig=",itau,iorig,kforig
!print *,"###############################################"
- call ilc_tauola_pytaud (itau, iorig, kforig, ndecay)
+ call wo_tauola_pytaud (itau, iorig, kforig, ndecay)
end subroutine pytaud

File Metadata

Mime Type
text/x-diff
Expires
Tue, Sep 30, 5:42 AM (1 h, 9 m)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
6566255
Default Alt Text
(341 KB)

Event Timeline

HEPForge.org · .