Index: trunk/src/phase_space/phase_space.nw
===================================================================
--- trunk/src/phase_space/phase_space.nw (revision 8877)
+++ trunk/src/phase_space/phase_space.nw (revision 8878)
@@ -1,31092 +1,31061 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: phase space
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Phase Space}
\includemodulegraph{phase_space}
The abstract representation of a type that parameterizes phase space,
with methods for construction and evaluation.
\begin{description}
\item[phs\_base]
Abstract phase-space representation.
\end{description}
A simple implementation:
\begin{description}
\item[phs\_none]
This implements a non-functional dummy module for the phase space.
A process which uses this module cannot be integrated. The purpose
of this module is to provide a placeholder for processes which do
not require phase-space evaluation. They may still allow for evaluating
matrix elements.
\item[phs\_single]
Parameterize the phase space of a single particle, i.e., the solid
angle. This is useful only for very restricted problems, but it
avoids the complexity of a generic approach in those trivial cases.
\end{description}
The standard implementation is called \emph{wood} phase space. It
consists of several auxiliary modules and the actual implementation
module.
\begin{description}
\item[mappings]
Generate invariant masses and decay angles from given
random numbers (or the inverse operation). Each mapping pertains to a
particular node in a phase-space tree. Different mappings account for
uniform distributions, resonances, zero-mass behavior, and so on.
\item[phs\_trees]
Phase space parameterizations for scattering
processes are defined recursively as if there was an initial particle
decaying. This module sets up a representation in terms of abstract
trees, where each node gets a unique binary number. Each tree is
stored as an array of branches, where integers indicate the
connections. This emulates pointers in a transparent way. Real
pointers would also be possible, but seem to be less efficient for
this particular case.
\item[phs\_forests]
The type defined by this module collects the
decay trees corresponding to a given process and the applicable
mappings. To set this up, a file is read which is either written by
the user or by the \textbf{cascades} module functions. The module
also contains the routines that evaluate phase space, i.e., generate
momenta from random numbers and back.
\item[cascades]
This module is a pseudo Feynman diagram generator with the
particular purpose of finding the phase space parameterizations best
suited for a given process. It uses a model file to set up the
possible vertices, generates all possible diagrams, identifies
resonances and singularities, and simplifies the list by merging
equivalent diagrams and dropping irrelevant ones. This process can be
controlled at several points by user-defined parameters. Note that it
depends on the particular values of particle masses, so it cannot be
done before reading the input file.
\item[phs\_wood]
Make the functionality available in form of an implementation of the
abstract phase-space type.
\item[phs\_fks]
Phase-space parameterization with modifications for the FKS scheme.
\end{description}
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Abstract phase-space module}
In this module we define an abstract base type (and a trivial test
implementation) for multi-channel phase-space parameterizations.
<<[[phs_base.f90]]>>=
<<File header>>
module phs_base
<<Use kinds>>
<<Use strings>>
use lorentz
use model_data
use flavors
use process_constants
<<Standard module head>>
<<PHS base: public>>
<<PHS base: types>>
<<PHS base: interfaces>>
interface
<<PHS base: sub interfaces>>
end interface
contains
<<PHS base: main procedures>>
end module phs_base
@ %def phs_base
@
<<[[phs_base_sub.f90]]>>=
<<File header>>
submodule (phs_base) phs_base_s
use io_units
use constants, only: TWOPI, TWOPI4
use string_utils, only: split_string
use format_defs, only: FMT_19
use numeric_utils
use diagnostics
use md5
use physics_defs
implicit none
contains
<<PHS base: procedures>>
end submodule phs_base_s
@ %def phs_base_s
@
\subsection{Phase-space channels}
The kinematics configuration may generate multiple parameterizations of phase
space. Some of those have specific properties, such as a resonance in the s
channel.
\subsubsection{Channel properties}
This is the abstract type for the channel properties. We need them as
a data transfer container, so everything is public and transparent.
<<PHS base: public>>=
public :: channel_prop_t
<<PHS base: types>>=
type, abstract :: channel_prop_t
contains
procedure (channel_prop_to_string), deferred :: to_string
generic :: operator (==) => is_equal
procedure (channel_eq), deferred :: is_equal
end type channel_prop_t
@ %def channel_prop_t
<<PHS base: interfaces>>=
abstract interface
function channel_prop_to_string (object) result (string)
import
class(channel_prop_t), intent(in) :: object
type(string_t) :: string
end function channel_prop_to_string
end interface
@ %def channel_prop_to_string
<<PHS base: interfaces>>=
abstract interface
function channel_eq (prop1, prop2) result (flag)
import
class(channel_prop_t), intent(in) :: prop1, prop2
logical :: flag
end function channel_eq
end interface
@ %def channel_prop_to_string
@
Here is a resonance as a channel property. Mass and width are stored
here in physical units.
<<PHS base: public>>=
public :: resonance_t
<<PHS base: types>>=
type, extends (channel_prop_t) :: resonance_t
real(default) :: mass = 0
real(default) :: width = 0
contains
procedure :: to_string => resonance_to_string
procedure :: is_equal => resonance_is_equal
end type resonance_t
@ %def resonance_t
@ Print mass and width.
<<PHS base: sub interfaces>>=
module function resonance_to_string (object) result (string)
class(resonance_t), intent(in) :: object
type(string_t) :: string
end function resonance_to_string
<<PHS base: procedures>>=
module function resonance_to_string (object) result (string)
class(resonance_t), intent(in) :: object
type(string_t) :: string
character(32) :: buffer
string = "resonant: m ="
write (buffer, "(" // FMT_19 // ")") object%mass
string = string // trim (buffer) // " GeV, w ="
write (buffer, "(" // FMT_19 // ")") object%width
string = string // trim (buffer) // " GeV"
end function resonance_to_string
@ %def resonance_to_string
@ Equality.
<<PHS base: sub interfaces>>=
module function resonance_is_equal (prop1, prop2) result (flag)
class(resonance_t), intent(in) :: prop1
class(channel_prop_t), intent(in) :: prop2
logical :: flag
end function resonance_is_equal
<<PHS base: procedures>>=
module function resonance_is_equal (prop1, prop2) result (flag)
class(resonance_t), intent(in) :: prop1
class(channel_prop_t), intent(in) :: prop2
logical :: flag
select type (prop2)
type is (resonance_t)
flag = prop1%mass == prop2%mass .and. prop1%width == prop2%width
class default
flag = .false.
end select
end function resonance_is_equal
@ %def resonance_is_equal
@
This is the limiting case of a resonance, namely an on-shell particle.
We just store the mass in physical units.
<<PHS base: public>>=
public :: on_shell_t
<<PHS base: types>>=
type, extends (channel_prop_t) :: on_shell_t
real(default) :: mass = 0
contains
procedure :: to_string => on_shell_to_string
procedure :: is_equal => on_shell_is_equal
end type on_shell_t
@ %def on_shell_t
@ Print mass and width.
<<PHS base: sub interfaces>>=
module function on_shell_to_string (object) result (string)
class(on_shell_t), intent(in) :: object
type(string_t) :: string
end function on_shell_to_string
<<PHS base: procedures>>=
module function on_shell_to_string (object) result (string)
class(on_shell_t), intent(in) :: object
type(string_t) :: string
character(32) :: buffer
string = "on shell: m ="
write (buffer, "(" // FMT_19 // ")") object%mass
string = string // trim (buffer) // " GeV"
end function on_shell_to_string
@ %def on_shell_to_string
@ Equality.
<<PHS base: sub interfaces>>=
module function on_shell_is_equal (prop1, prop2) result (flag)
class(on_shell_t), intent(in) :: prop1
class(channel_prop_t), intent(in) :: prop2
logical :: flag
end function on_shell_is_equal
<<PHS base: procedures>>=
module function on_shell_is_equal (prop1, prop2) result (flag)
class(on_shell_t), intent(in) :: prop1
class(channel_prop_t), intent(in) :: prop2
logical :: flag
select type (prop2)
type is (on_shell_t)
flag = prop1%mass == prop2%mass
class default
flag = .false.
end select
end function on_shell_is_equal
@ %def on_shell_is_equal
@
\subsubsection{Channel equivalences}
This type describes an equivalence. The current channel is equivalent
to channel [[c]]. The equivalence involves a permutation [[perm]] of
integration dimensions and, within each integration dimension, a
mapping [[mode]].
<<PHS base: types>>=
type :: phs_equivalence_t
integer :: c = 0
integer, dimension(:), allocatable :: perm
integer, dimension(:), allocatable :: mode
contains
<<PHS base: phs equivalence: TBP>>
end type phs_equivalence_t
@ %def phs_equivalence_t
@
The mapping modes are
<<PHS base: types>>=
integer, parameter, public :: &
EQ_IDENTITY = 0, EQ_INVERT = 1, EQ_SYMMETRIC = 2, EQ_INVARIANT = 3
@ %def EQ_IDENTITY EQ_INVERT EQ_SYMMETRIC
@ In particular, if a channel is equivalent to itself in the
[[EQ_SYMMETRIC]] mode, the integrand can be assumed to be symmetric
w.r.t.\ a reflection $x\to 1 - x$ of the correponding integration variable.
These are the associated tags, for output:
<<PHS base: types>>=
character, dimension(0:3), parameter :: TAG = ["+", "-", ":", "x"]
@ %def TAG
@ Write an equivalence.
<<PHS base: phs equivalence: TBP>>=
procedure :: write => phs_equivalence_write
<<PHS base: sub interfaces>>=
module subroutine phs_equivalence_write (object, unit)
class(phs_equivalence_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine phs_equivalence_write
<<PHS base: procedures>>=
module subroutine phs_equivalence_write (object, unit)
class(phs_equivalence_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, j
u = given_output_unit (unit)
write (u, "(5x,'=',1x,I0,1x)", advance = "no") object%c
if (allocated (object%perm)) then
write (u, "(A)", advance = "no") "("
do j = 1, size (object%perm)
if (j > 1) write (u, "(1x)", advance = "no")
write (u, "(I0,A1)", advance = "no") &
object%perm(j), TAG(object%mode(j))
end do
write (u, "(A)") ")"
else
write (u, "(A)")
end if
end subroutine phs_equivalence_write
@ %def phs_equivalence_write
@ Initialize an equivalence. This allocates the [[perm]] and [[mode]]
arrays with equal size.
<<PHS base: phs equivalence: TBP>>=
procedure :: init => phs_equivalence_init
<<PHS base: sub interfaces>>=
module subroutine phs_equivalence_init (eq, n_dim)
class(phs_equivalence_t), intent(out) :: eq
integer, intent(in) :: n_dim
end subroutine phs_equivalence_init
<<PHS base: procedures>>=
module subroutine phs_equivalence_init (eq, n_dim)
class(phs_equivalence_t), intent(out) :: eq
integer, intent(in) :: n_dim
allocate (eq%perm (n_dim), source = 0)
allocate (eq%mode (n_dim), source = EQ_IDENTITY)
end subroutine phs_equivalence_init
@ %def phs_equivalence_init
@
\subsubsection{Channel objects}
The channel entry holds (optionally) specific properties.
[[sf_channel]] is the structure-function channel that corresponds to this
phase-space channel. The structure-function channel may be set up with a
specific mapping that depends on the phase-space channel properties. (The
default setting is to leave the properties empty.)
<<PHS base: public>>=
public :: phs_channel_t
<<PHS base: types>>=
type :: phs_channel_t
class(channel_prop_t), allocatable :: prop
integer :: sf_channel = 1
type(phs_equivalence_t), dimension(:), allocatable :: eq
contains
<<PHS base: phs channel: TBP>>
end type phs_channel_t
@ %def phs_channel_t
@ Output.
<<PHS base: phs channel: TBP>>=
procedure :: write => phs_channel_write
<<PHS base: sub interfaces>>=
module subroutine phs_channel_write (object, unit)
class(phs_channel_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine phs_channel_write
<<PHS base: procedures>>=
module subroutine phs_channel_write (object, unit)
class(phs_channel_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, j
u = given_output_unit (unit)
write (u, "(1x,I0)", advance="no") object%sf_channel
if (allocated (object%prop)) then
write (u, "(1x,A)") char (object%prop%to_string ())
else
write (u, *)
end if
if (allocated (object%eq)) then
do j = 1, size (object%eq)
call object%eq(j)%write (u)
end do
end if
end subroutine phs_channel_write
@ %def phs_channel_write
@ Identify the channel with an s-channel resonance.
Gfortran 7/8/9 bug: has to remain in the main module.
<<PHS base: phs channel: TBP>>=
procedure :: set_resonant => channel_set_resonant
<<PHS base: main procedures>>=
subroutine channel_set_resonant (channel, mass, width)
class(phs_channel_t), intent(inout) :: channel
real(default), intent(in) :: mass, width
allocate (resonance_t :: channel%prop)
select type (prop => channel%prop)
type is (resonance_t)
prop%mass = mass
prop%width = width
end select
end subroutine channel_set_resonant
@ %def channel_set_resonant
@ Identify the channel with an on-shell particle.
Gfortran 7/8/9 bug: has to remain in the main module.
<<PHS base: phs channel: TBP>>=
procedure :: set_on_shell => channel_set_on_shell
<<PHS base: main procedures>>=
subroutine channel_set_on_shell (channel, mass)
class(phs_channel_t), intent(inout) :: channel
real(default), intent(in) :: mass
allocate (on_shell_t :: channel%prop)
select type (prop => channel%prop)
type is (on_shell_t)
prop%mass = mass
end select
end subroutine channel_set_on_shell
@ %def channel_set_on_shell
@
\subsection{Property collection}
We can set up a list of all distinct channel properties for a given
set of channels.
<<PHS base: public>>=
public :: phs_channel_collection_t
<<PHS base: types>>=
type :: prop_entry_t
integer :: i = 0
class(channel_prop_t), allocatable :: prop
type(prop_entry_t), pointer :: next => null ()
end type prop_entry_t
type :: phs_channel_collection_t
integer :: n = 0
type(prop_entry_t), pointer :: first => null ()
contains
<<PHS base: phs channel collection: TBP>>
end type phs_channel_collection_t
@ %def prop_entry_t
@ %def phs_channel_collection_t
@ Finalizer for the list.
<<PHS base: phs channel collection: TBP>>=
procedure :: final => phs_channel_collection_final
<<PHS base: sub interfaces>>=
module subroutine phs_channel_collection_final (object)
class(phs_channel_collection_t), intent(inout) :: object
end subroutine phs_channel_collection_final
<<PHS base: procedures>>=
module subroutine phs_channel_collection_final (object)
class(phs_channel_collection_t), intent(inout) :: object
type(prop_entry_t), pointer :: entry
do while (associated (object%first))
entry => object%first
object%first => entry%next
deallocate (entry)
end do
end subroutine phs_channel_collection_final
@ %def phs_channel_collection_final
@ Output.
<<PHS base: phs channel collection: TBP>>=
procedure :: write => phs_channel_collection_write
<<PHS base: sub interfaces>>=
module subroutine phs_channel_collection_write (object, unit)
class(phs_channel_collection_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine phs_channel_collection_write
<<PHS base: procedures>>=
module subroutine phs_channel_collection_write (object, unit)
class(phs_channel_collection_t), intent(in) :: object
integer, intent(in), optional :: unit
type(prop_entry_t), pointer :: entry
integer :: u
u = given_output_unit (unit)
entry => object%first
do while (associated (entry))
if (allocated (entry%prop)) then
write (u, "(1x,I0,1x,A)") entry%i, char (entry%prop%to_string ())
else
write (u, "(1x,I0)") entry%i
end if
entry => entry%next
end do
end subroutine phs_channel_collection_write
@ %def phs_channel_collection_write
@ Push a new property to the stack if it is not yet included.
Simultaneously, set the [[sf_channel]] entry in the phase-space
channel object to the index of the matching entry, or the new entry if
there was no match.
<<PHS base: phs channel collection: TBP>>=
procedure :: push => phs_channel_collection_push
<<PHS base: sub interfaces>>=
module subroutine phs_channel_collection_push (coll, channel)
class(phs_channel_collection_t), intent(inout) :: coll
type(phs_channel_t), intent(inout) :: channel
end subroutine phs_channel_collection_push
<<PHS base: procedures>>=
module subroutine phs_channel_collection_push (coll, channel)
class(phs_channel_collection_t), intent(inout) :: coll
type(phs_channel_t), intent(inout) :: channel
type(prop_entry_t), pointer :: entry, new
if (associated (coll%first)) then
entry => coll%first
do
if (allocated (entry%prop)) then
if (allocated (channel%prop)) then
if (entry%prop == channel%prop) then
channel%sf_channel = entry%i
return
end if
end if
else if (.not. allocated (channel%prop)) then
channel%sf_channel = entry%i
return
end if
if (associated (entry%next)) then
entry => entry%next
else
exit
end if
end do
allocate (new)
entry%next => new
else
allocate (new)
coll%first => new
end if
coll%n = coll%n + 1
new%i = coll%n
channel%sf_channel = new%i
if (allocated (channel%prop)) then
allocate (new%prop, source = channel%prop)
end if
end subroutine phs_channel_collection_push
@ %def phs_channel_collection_push
@ Return the number of collected distinct channels.
<<PHS base: phs channel collection: TBP>>=
procedure :: get_n => phs_channel_collection_get_n
<<PHS base: sub interfaces>>=
module function phs_channel_collection_get_n (coll) result (n)
class(phs_channel_collection_t), intent(in) :: coll
integer :: n
end function phs_channel_collection_get_n
<<PHS base: procedures>>=
module function phs_channel_collection_get_n (coll) result (n)
class(phs_channel_collection_t), intent(in) :: coll
integer :: n
n = coll%n
end function phs_channel_collection_get_n
@ %def phs_channel_collection_get_n
@ Return a specific channel (property object).
<<PHS base: phs channel collection: TBP>>=
procedure :: get_entry => phs_channel_collection_get_entry
<<PHS base: sub interfaces>>=
module subroutine phs_channel_collection_get_entry (coll, i, prop)
class(phs_channel_collection_t), intent(in) :: coll
integer, intent(in) :: i
class(channel_prop_t), intent(out), allocatable :: prop
end subroutine phs_channel_collection_get_entry
<<PHS base: procedures>>=
module subroutine phs_channel_collection_get_entry (coll, i, prop)
class(phs_channel_collection_t), intent(in) :: coll
integer, intent(in) :: i
class(channel_prop_t), intent(out), allocatable :: prop
type(prop_entry_t), pointer :: entry
integer :: k
if (i > 0 .and. i <= coll%n) then
entry => coll%first
do k = 2, i
entry => entry%next
end do
if (allocated (entry%prop)) then
if (allocated (prop)) deallocate (prop)
allocate (prop, source = entry%prop)
end if
else
call msg_bug ("PHS channel collection: get entry: illegal index")
end if
end subroutine phs_channel_collection_get_entry
@ %def phs_channel_collection_get_entry
@
\subsection{Kinematics configuration}
Here, we store the universal information that is specifically relevant
for phase-space generation. It is a subset of the process data,
supplemented by basic information on phase-space parameterization
channels.
A concrete implementation will contain more data, that describe the
phase space in detail.
MD5 sums: the phase space setup depends on the process, it depends on
the model parameters (the masses, that is), and on the configuration
parameters. (It does not depend on the QCD setup.)
<<PHS base: public>>=
public :: phs_config_t
<<PHS base: types>>=
type, abstract :: phs_config_t
! private
type(string_t) :: id
integer :: n_in = 0
integer :: n_out = 0
integer :: n_tot = 0
integer :: n_state = 0
integer :: n_par = 0
integer :: n_channel = 0
real(default) :: sqrts = 0
logical :: sqrts_fixed = .true.
logical :: lab_is_cm = .true.
logical :: azimuthal_dependence = .false.
integer, dimension(:), allocatable :: dim_flat
logical :: provides_equivalences = .false.
logical :: provides_chains = .false.
logical :: vis_channels = .false.
integer, dimension(:), allocatable :: chain
class(model_data_t), pointer :: model => null ()
type(flavor_t), dimension(:,:), allocatable :: flv
type(phs_channel_t), dimension(:), allocatable :: channel
character(32) :: md5sum_process = ""
character(32) :: md5sum_model_par = ""
character(32) :: md5sum_phs_config = ""
integer :: nlo_type
contains
<<PHS base: phs config: TBP>>
end type phs_config_t
@ %def phs_config_t
@ Finalizer, deferred.
<<PHS base: phs config: TBP>>=
procedure (phs_config_final), deferred :: final
<<PHS base: interfaces>>=
abstract interface
subroutine phs_config_final (object)
import
class(phs_config_t), intent(inout) :: object
end subroutine phs_config_final
end interface
@ %def phs_config_final
@ Output. We provide an implementation for the output of the base-type
contents and an interface for the actual write method.
<<PHS base: phs config: TBP>>=
procedure (phs_config_write), deferred :: write
procedure :: base_write => phs_config_write
<<PHS base: sub interfaces>>=
module subroutine phs_config_write (object, unit, include_id)
class(phs_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
end subroutine phs_config_write
<<PHS base: procedures>>=
module subroutine phs_config_write (object, unit, include_id)
class(phs_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
integer :: u, i, j
integer :: n_tot_flv
logical :: use_id
n_tot_flv = object%n_tot
u = given_output_unit (unit)
use_id = .true.; if (present (include_id)) use_id = include_id
if (use_id) write (u, "(3x,A,A,A)") "ID = '", char (object%id), "'"
write (u, "(3x,A,I0)") "n_in = ", object%n_in
write (u, "(3x,A,I0)") "n_out = ", object%n_out
write (u, "(3x,A,I0)") "n_tot = ", object%n_tot
write (u, "(3x,A,I0)") "n_state = ", object%n_state
write (u, "(3x,A,I0)") "n_par = ", object%n_par
write (u, "(3x,A,I0)") "n_channel = ", object%n_channel
write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", object%sqrts
write (u, "(3x,A,L1)") "s_fixed = ", object%sqrts_fixed
write (u, "(3x,A,L1)") "lab_is_cm = ", object%lab_is_cm
write (u, "(3x,A,L1)") "azim.dep. = ", object%azimuthal_dependence
if (allocated (object%dim_flat)) then
write (u, "(3x,A,I0)") "flat dim. = ", object%dim_flat
end if
write (u, "(1x,A)") "Flavor combinations:"
do i = 1, object%n_state
write (u, "(3x,I0,':')", advance="no") i
! do j = 1, object%n_tot
do j = 1, n_tot_flv
write (u, "(1x,A)", advance="no") char (object%flv(j,i)%get_name ())
end do
write (u, "(A)")
end do
if (allocated (object%channel)) then
write (u, "(1x,A)") "Phase-space / structure-function channels:"
do i = 1, object%n_channel
write (u, "(3x,I0,':')", advance="no") i
call object%channel(i)%write (u)
end do
end if
if (object%md5sum_process /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (process) = '", &
object%md5sum_process, "'"
end if
if (object%md5sum_model_par /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (model par) = '", &
object%md5sum_model_par, "'"
end if
if (object%md5sum_phs_config /= "") then
write (u, "(3x,A,A,A)") "MD5 sum (phs config) = '", &
object%md5sum_phs_config, "'"
end if
end subroutine phs_config_write
@ %def phs_config_write
@ Similarly, a basic initializer and an interface. The model pointer is taken
as an argument; we may verify that this has the expected model name.
The intent is [[inout]]. We want to be able to set parameters in advance.
<<PHS base: phs config: TBP>>=
procedure :: init => phs_config_init
<<PHS base: sub interfaces>>=
module subroutine phs_config_init (phs_config, data, model)
class(phs_config_t), intent(inout) :: phs_config
type(process_constants_t), intent(in) :: data
class(model_data_t), intent(in), target :: model
end subroutine phs_config_init
<<PHS base: procedures>>=
module subroutine phs_config_init (phs_config, data, model)
class(phs_config_t), intent(inout) :: phs_config
type(process_constants_t), intent(in) :: data
class(model_data_t), intent(in), target :: model
integer :: i, j
phs_config%id = data%id
phs_config%n_in = data%n_in
phs_config%n_out = data%n_out
phs_config%n_tot = data%n_in + data%n_out
phs_config%n_state = data%n_flv
if (data%model_name == model%get_name ()) then
phs_config%model => model
else
call msg_bug ("phs_config_init: model name mismatch")
end if
allocate (phs_config%flv (phs_config%n_tot, phs_config%n_state))
do i = 1, phs_config%n_state
do j = 1, phs_config%n_tot
call phs_config%flv(j,i)%init (data%flv_state(j,i), &
phs_config%model)
end do
end do
phs_config%md5sum_process = data%md5sum
end subroutine phs_config_init
@ %def phs_config_init
@
WK 2018-04-05: This procedure appears to be redundant?
<<XXX PHS base: phs config: TBP>>=
procedure :: set_component_index => phs_config_set_component_index
<<XXX PHS base: procedures>>=
subroutine phs_config_set_component_index (phs_config, index)
class(phs_config_t), intent(inout) :: phs_config
integer, intent(in) :: index
type(string_t), dimension(:), allocatable :: id
type(string_t) :: suffix
integer :: i, n
suffix = var_str ('i') // int2string (index)
call split_string (phs_config%id, var_str ('_'), id)
phs_config%id = var_str ('')
n = size (id) - 1
do i = 1, n
phs_config%id = phs_config%id // id(i) // var_str ('_')
end do
phs_config%id = phs_config%id // suffix
end subroutine phs_config_set_component_index
@ %def phs_config_set_component_index
@ This procedure should complete the phase-space configuration. We
need the [[sqrts]] value as overall scale, which is known only after
the beams have been defined. The procedure should determine the number of
channels, their properties (if any), and allocate and fill the [[channel]]
array accordingly.
<<PHS base: phs config: TBP>>=
procedure (phs_config_configure), deferred :: configure
<<PHS base: interfaces>>=
abstract interface
subroutine phs_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, ignore_mismatch, &
nlo_type, subdir)
import
class(phs_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
end subroutine phs_config_configure
end interface
@ %def phs_config_configure
@ Manually assign structure-function channel indices to the phase-space
channel objects. (Used by a test routine.)
<<PHS base: phs config: TBP>>=
procedure :: set_sf_channel => phs_config_set_sf_channel
<<PHS base: sub interfaces>>=
module subroutine phs_config_set_sf_channel (phs_config, sf_channel)
class(phs_config_t), intent(inout) :: phs_config
integer, dimension(:), intent(in) :: sf_channel
end subroutine phs_config_set_sf_channel
<<PHS base: procedures>>=
module subroutine phs_config_set_sf_channel (phs_config, sf_channel)
class(phs_config_t), intent(inout) :: phs_config
integer, dimension(:), intent(in) :: sf_channel
phs_config%channel%sf_channel = sf_channel
end subroutine phs_config_set_sf_channel
@ %def phs_config_set_sf_channel
@ Collect new channels not yet in the collection from this phase-space
configuration object. At the same time, assign structure-function channels.
<<PHS base: phs config: TBP>>=
procedure :: collect_channels => phs_config_collect_channels
<<PHS base: sub interfaces>>=
module subroutine phs_config_collect_channels (phs_config, coll)
class(phs_config_t), intent(inout) :: phs_config
type(phs_channel_collection_t), intent(inout) :: coll
end subroutine phs_config_collect_channels
<<PHS base: procedures>>=
module subroutine phs_config_collect_channels (phs_config, coll)
class(phs_config_t), intent(inout) :: phs_config
type(phs_channel_collection_t), intent(inout) :: coll
integer :: c
do c = 1, phs_config%n_channel
call coll%push (phs_config%channel(c))
end do
end subroutine phs_config_collect_channels
@ %def phs_config_collect_channels
@ Compute the MD5 sum. We abuse the [[write]] method. In
type implementations, [[write]] should only display information that is
relevant for the MD5 sum. The data include the process MD5 sum which is taken
from the process constants, and the MD5 sum of the model parameters. This may
change, so it is computed here.
<<PHS base: phs config: TBP>>=
procedure :: compute_md5sum => phs_config_compute_md5sum
<<PHS base: sub interfaces>>=
module subroutine phs_config_compute_md5sum (phs_config, include_id)
class(phs_config_t), intent(inout) :: phs_config
logical, intent(in), optional :: include_id
end subroutine phs_config_compute_md5sum
<<PHS base: procedures>>=
module subroutine phs_config_compute_md5sum (phs_config, include_id)
class(phs_config_t), intent(inout) :: phs_config
logical, intent(in), optional :: include_id
integer :: u
phs_config%md5sum_model_par = phs_config%model%get_parameters_md5sum ()
phs_config%md5sum_phs_config = ""
u = free_unit ()
open (u, status = "scratch", action = "readwrite")
call phs_config%write (u, include_id)
rewind (u)
phs_config%md5sum_phs_config = md5sum (u)
close (u)
end subroutine phs_config_compute_md5sum
@ %def phs_config_compute_md5sum
@ Print an informative message after phase-space configuration.
<<PHS base: phs config: TBP>>=
procedure (phs_startup_message), deferred :: startup_message
procedure :: base_startup_message => phs_startup_message
<<PHS base: sub interfaces>>=
module subroutine phs_startup_message (phs_config, unit)
class(phs_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
end subroutine phs_startup_message
<<PHS base: procedures>>=
module subroutine phs_startup_message (phs_config, unit)
class(phs_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
write (msg_buffer, "(A,3(1x,I0,1x,A))") &
"Phase space:", &
phs_config%n_channel, "channels,", &
phs_config%n_par, "dimensions"
call msg_message (unit = unit)
end subroutine phs_startup_message
@ %def phs_startup_message
@ This procedure should be implemented such that the phase-space
configuration object allocates a phase-space instance of matching type.
<<PHS base: phs config: TBP>>=
procedure (phs_config_allocate_instance), nopass, deferred :: &
allocate_instance
<<PHS base: interfaces>>=
abstract interface
subroutine phs_config_allocate_instance (phs)
import
class(phs_t), intent(inout), pointer :: phs
end subroutine phs_config_allocate_instance
end interface
@ %def phs_config_allocate_instance
@
\subsection{Extract data}
Return the number of MC input parameters.
<<PHS base: phs config: TBP>>=
procedure :: get_n_par => phs_config_get_n_par
<<PHS base: sub interfaces>>=
module function phs_config_get_n_par (phs_config) result (n)
class(phs_config_t), intent(in) :: phs_config
integer :: n
end function phs_config_get_n_par
<<PHS base: procedures>>=
module function phs_config_get_n_par (phs_config) result (n)
class(phs_config_t), intent(in) :: phs_config
integer :: n
n = phs_config%n_par
end function phs_config_get_n_par
@ %def phs_config_get_n_par
@ Return dimensions (parameter indices) for which the phase-space
dimension is flat, so integration and event generation can be simplified.
<<PHS base: phs config: TBP>>=
procedure :: get_flat_dimensions => phs_config_get_flat_dimensions
<<PHS base: sub interfaces>>=
module function phs_config_get_flat_dimensions &
(phs_config) result (dim_flat)
class(phs_config_t), intent(in) :: phs_config
integer, dimension(:), allocatable :: dim_flat
end function phs_config_get_flat_dimensions
<<PHS base: procedures>>=
module function phs_config_get_flat_dimensions &
(phs_config) result (dim_flat)
class(phs_config_t), intent(in) :: phs_config
integer, dimension(:), allocatable :: dim_flat
if (allocated (phs_config%dim_flat)) then
allocate (dim_flat (size (phs_config%dim_flat)))
dim_flat = phs_config%dim_flat
else
allocate (dim_flat (0))
end if
end function phs_config_get_flat_dimensions
@ %def phs_config_get_flat_dimensions
@ Return the number of phase-space channels.
<<PHS base: phs config: TBP>>=
procedure :: get_n_channel => phs_config_get_n_channel
<<PHS base: sub interfaces>>=
module function phs_config_get_n_channel (phs_config) result (n)
class(phs_config_t), intent(in) :: phs_config
integer :: n
end function phs_config_get_n_channel
<<PHS base: procedures>>=
module function phs_config_get_n_channel (phs_config) result (n)
class(phs_config_t), intent(in) :: phs_config
integer :: n
n = phs_config%n_channel
end function phs_config_get_n_channel
@ %def phs_config_get_n_channel
@ Return the structure-function channel that corresponds to the
phase-space channel [[c]]. If the channel array is not allocated (which
happens if there is no structure function), return zero.
<<PHS base: phs config: TBP>>=
procedure :: get_sf_channel => phs_config_get_sf_channel
<<PHS base: sub interfaces>>=
module function phs_config_get_sf_channel (phs_config, c) result (c_sf)
class(phs_config_t), intent(in) :: phs_config
integer, intent(in) :: c
integer :: c_sf
end function phs_config_get_sf_channel
<<PHS base: procedures>>=
module function phs_config_get_sf_channel (phs_config, c) result (c_sf)
class(phs_config_t), intent(in) :: phs_config
integer, intent(in) :: c
integer :: c_sf
if (allocated (phs_config%channel)) then
c_sf = phs_config%channel(c)%sf_channel
else
c_sf = 0
end if
end function phs_config_get_sf_channel
@ %def phs_config_get_sf_channel
@ Return the mass(es) of the incoming particle(s). We take the first flavor
combination in the array, assuming that masses must be degenerate among
flavors.
<<PHS base: phs config: TBP>>=
procedure :: get_masses_in => phs_config_get_masses_in
<<PHS base: sub interfaces>>=
module subroutine phs_config_get_masses_in (phs_config, m)
class(phs_config_t), intent(in) :: phs_config
real(default), dimension(:), intent(out) :: m
end subroutine phs_config_get_masses_in
<<PHS base: procedures>>=
module subroutine phs_config_get_masses_in (phs_config, m)
class(phs_config_t), intent(in) :: phs_config
real(default), dimension(:), intent(out) :: m
integer :: i
do i = 1, phs_config%n_in
m(i) = phs_config%flv(i,1)%get_mass ()
end do
end subroutine phs_config_get_masses_in
@ %def phs_config_get_masses_in
@ Return the MD5 sum of the configuration.
<<PHS base: phs config: TBP>>=
procedure :: get_md5sum => phs_config_get_md5sum
<<PHS base: sub interfaces>>=
module function phs_config_get_md5sum (phs_config) result (md5sum)
class(phs_config_t), intent(in) :: phs_config
character(32) :: md5sum
end function phs_config_get_md5sum
<<PHS base: procedures>>=
module function phs_config_get_md5sum (phs_config) result (md5sum)
class(phs_config_t), intent(in) :: phs_config
character(32) :: md5sum
md5sum = phs_config%md5sum_phs_config
end function phs_config_get_md5sum
@ %def phs_config_get_md5sum
@
\subsection{Phase-space point instance}
The [[phs_t]] object holds the workspace for phase-space generation.
In the base object, we have the MC input parameters [[r]] and the
Jacobian factor [[f]], for each channel, and the incoming and outgoing
momenta.
Note: The [[active_channel]] array is not used yet, all elements are
initialized with [[.true.]]. It should be touched by the integrator if it
decides to drop irrelevant channels.
<<PHS base: public>>=
public :: phs_t
<<PHS base: types>>=
type, abstract :: phs_t
class(phs_config_t), pointer :: config => null ()
logical :: r_defined = .false.
integer :: selected_channel = 0
logical, dimension(:), allocatable :: active_channel
real(default), dimension(:,:), allocatable :: r
real(default), dimension(:), allocatable :: f
real(default), dimension(:), allocatable :: m_in
real(default), dimension(:), allocatable :: m_out
real(default) :: flux = 0
real(default) :: volume = 0
type(lorentz_transformation_t) :: lt_cm_to_lab
logical :: p_defined = .false.
real(default) :: sqrts_hat = 0
type(vector4_t), dimension(:), allocatable :: p
logical :: q_defined = .false.
type(vector4_t), dimension(:), allocatable :: q
contains
<<PHS base: phs: TBP>>
end type phs_t
@ %def phs_t
@ Output. Since phase space may get complicated, we include a
[[verbose]] option for the abstract [[write]] procedure.
<<PHS base: phs: TBP>>=
procedure (phs_write), deferred :: write
<<PHS base: interfaces>>=
abstract interface
subroutine phs_write (object, unit, verbose)
import
class(phs_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine phs_write
end interface
@ %def phs_write
@ This procedure can be called to print the contents of the base type.
<<PHS base: phs: TBP>>=
procedure :: base_write => phs_base_write
<<PHS base: sub interfaces>>=
module subroutine phs_base_write (object, unit)
class(phs_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine phs_base_write
<<PHS base: procedures>>=
module subroutine phs_base_write (object, unit)
class(phs_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, c, i
u = given_output_unit (unit)
write (u, "(1x,A)", advance="no") "Partonic phase space: parameters"
if (object%r_defined) then
write (u, *)
else
write (u, "(1x,A)") "[undefined]"
end if
write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_in =", object%m_in
write (u, "(3x,A,999(1x," // FMT_19 // "))") "m_out =", object%m_out
write (u, "(3x,A," // FMT_19 // ")") "Flux = ", object%flux
write (u, "(3x,A," // FMT_19 // ")") "Volume = ", object%volume
if (allocated (object%f)) then
do c = 1, size (object%r, 2)
write (u, "(1x,A,I0,A)", advance="no") "Channel #", c, ":"
if (c == object%selected_channel) then
write (u, "(1x,A)") "[selected]"
else
write (u, *)
end if
write (u, "(3x,A)", advance="no") "r ="
do i = 1, size (object%r, 1)
write (u, "(1x,F9.7)", advance="no") object%r(i,c)
end do
write (u, *)
write (u, "(3x,A,1x,ES13.7)") "f =", object%f(c)
end do
end if
write (u, "(1x,A)") "Partonic phase space: momenta"
if (object%p_defined) then
write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", object%sqrts_hat
end if
write (u, "(1x,A)", advance="no") "Incoming:"
if (object%p_defined) then
write (u, *)
else
write (u, "(1x,A)") "[undefined]"
end if
if (allocated (object%p)) then
do i = 1, size (object%p)
call vector4_write (object%p(i), u)
end do
end if
write (u, "(1x,A)", advance="no") "Outgoing:"
if (object%q_defined) then
write (u, *)
else
write (u, "(1x,A)") "[undefined]"
end if
if (allocated (object%q)) then
do i = 1, size (object%q)
call vector4_write (object%q(i), u)
end do
end if
if (object%p_defined .and. .not. object%config%lab_is_cm) then
write (u, "(1x,A)") "Transformation c.m -> lab frame"
call lorentz_transformation_write (object%lt_cm_to_lab, u)
end if
end subroutine phs_base_write
@ %def phs_base_write
@ Finalizer. The base type does not need it, but extensions may.
<<PHS base: phs: TBP>>=
procedure (phs_final), deferred :: final
<<PHS base: interfaces>>=
abstract interface
subroutine phs_final (object)
import
class(phs_t), intent(inout) :: object
end subroutine phs_final
end interface
@ %def phs_final
@ Initializer. Everything should be contained in the [[process_data]]
configuration object, so we can require a universal interface.
<<PHS base: phs: TBP>>=
procedure (phs_init), deferred :: init
<<PHS base: interfaces>>=
abstract interface
subroutine phs_init (phs, phs_config)
import
class(phs_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
end subroutine phs_init
end interface
@ %def phs_init
@ The base version will just allocate the arrays. It should be called
at the beginning of the implementation of [[phs_init]].
<<PHS base: phs: TBP>>=
procedure :: base_init => phs_base_init
<<PHS base: sub interfaces>>=
module subroutine phs_base_init (phs, phs_config)
class(phs_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
end subroutine phs_base_init
<<PHS base: procedures>>=
module subroutine phs_base_init (phs, phs_config)
class(phs_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
phs%config => phs_config
allocate (phs%active_channel (phs%config%n_channel))
phs%active_channel = .true.
allocate (phs%r (phs%config%n_par, phs%config%n_channel)); phs%r = 0
allocate (phs%f (phs%config%n_channel)); phs%f = 0
allocate (phs%p (phs%config%n_in))
allocate (phs%m_in (phs%config%n_in), &
source = phs_config%flv(:phs_config%n_in, 1)%get_mass ())
allocate (phs%q (phs%config%n_out))
allocate (phs%m_out (phs%config%n_out), &
source = phs_config%flv(phs_config%n_in+1:, 1)%get_mass ())
call phs%compute_flux ()
end subroutine phs_base_init
@ %def phs_base_init
@ Manually select a channel.
<<PHS base: phs: TBP>>=
procedure :: select_channel => phs_base_select_channel
<<PHS base: sub interfaces>>=
module subroutine phs_base_select_channel (phs, channel)
class(phs_t), intent(inout) :: phs
integer, intent(in), optional :: channel
end subroutine phs_base_select_channel
<<PHS base: procedures>>=
module subroutine phs_base_select_channel (phs, channel)
class(phs_t), intent(inout) :: phs
integer, intent(in), optional :: channel
if (present (channel)) then
phs%selected_channel = channel
else
phs%selected_channel = 0
end if
end subroutine phs_base_select_channel
@ %def phs_base_select_channel
@ Set incoming momenta. Assume that array shapes match. If
requested, compute the Lorentz transformation from the c.m.\ to the
lab frame and apply that transformation to the incoming momenta.
In the c.m.\ frame, the sum of three-momenta is zero. In a scattering
process, the $z$ axis is the direction of the first beam, the second
beam is along the negative $z$ axis. The transformation from the
c.m.\ to the lab frame is a rotation from the $z$ axis to the boost
axis followed by a boost, such that the c.m.\ momenta are transformed
into the lab-frame momenta. In a decay process, we just boost along
the flight direction, without rotation.
<<PHS base: phs: TBP>>=
procedure :: set_incoming_momenta => phs_set_incoming_momenta
<<PHS base: sub interfaces>>=
module subroutine phs_set_incoming_momenta (phs, p)
class(phs_t), intent(inout) :: phs
type(vector4_t), dimension(:), intent(in) :: p
end subroutine phs_set_incoming_momenta
<<PHS base: procedures>>=
module subroutine phs_set_incoming_momenta (phs, p)
class(phs_t), intent(inout) :: phs
type(vector4_t), dimension(:), intent(in) :: p
type(vector4_t) :: p0, p1
type(lorentz_transformation_t) :: lt0
integer :: i
phs%p = p
if (phs%config%lab_is_cm) then
phs%sqrts_hat = phs%config%sqrts
phs%p = p
phs%lt_cm_to_lab = identity
else
p0 = sum (p)
if (phs%config%sqrts_fixed) then
phs%sqrts_hat = phs%config%sqrts
else
phs%sqrts_hat = p0 ** 1
end if
lt0 = boost (p0, phs%sqrts_hat)
select case (phs%config%n_in)
case (1)
phs%lt_cm_to_lab = lt0
case (2)
p1 = inverse (lt0) * p(1)
phs%lt_cm_to_lab = lt0 * rotation_to_2nd (3, space_part (p1))
end select
phs%p = inverse (phs%lt_cm_to_lab) * p
end if
phs%p_defined = .true.
end subroutine phs_set_incoming_momenta
@ %def phs_set_incoming_momenta
@ Set outgoing momenta. Assume that array shapes match. The incoming
momenta must be known, so we can apply the Lorentz transformation from
c.m.\ to lab (inverse) to the momenta.
<<PHS base: phs: TBP>>=
procedure :: set_outgoing_momenta => phs_set_outgoing_momenta
<<PHS base: sub interfaces>>=
module subroutine phs_set_outgoing_momenta (phs, q)
class(phs_t), intent(inout) :: phs
type(vector4_t), dimension(:), intent(in) :: q
end subroutine phs_set_outgoing_momenta
<<PHS base: procedures>>=
module subroutine phs_set_outgoing_momenta (phs, q)
class(phs_t), intent(inout) :: phs
type(vector4_t), dimension(:), intent(in) :: q
integer :: i
if (phs%p_defined) then
if (phs%config%lab_is_cm) then
phs%q = q
else
phs%q = inverse (phs%lt_cm_to_lab) * q
end if
phs%q_defined = .true.
end if
end subroutine phs_set_outgoing_momenta
@ %def phs_set_outgoing_momenta
@ Return outgoing momenta. Apply the c.m.\ to lab transformation if
necessary.
<<PHS base: phs: TBP>>=
procedure :: get_outgoing_momenta => phs_get_outgoing_momenta
<<PHS base: sub interfaces>>=
module subroutine phs_get_outgoing_momenta (phs, q)
class(phs_t), intent(in) :: phs
type(vector4_t), dimension(:), intent(out) :: q
end subroutine phs_get_outgoing_momenta
<<PHS base: procedures>>=
module subroutine phs_get_outgoing_momenta (phs, q)
class(phs_t), intent(in) :: phs
type(vector4_t), dimension(:), intent(out) :: q
if (phs%p_defined .and. phs%q_defined) then
if (phs%config%lab_is_cm) then
q = phs%q
else
q = phs%lt_cm_to_lab * phs%q
end if
else
q = vector4_null
end if
end subroutine phs_get_outgoing_momenta
@ %def phs_get_outgoing_momenta
@
<<PHS base: phs: TBP>>=
procedure :: lab_is_cm => phs_lab_is_cm
<<PHS base: sub interfaces>>=
module function phs_lab_is_cm (phs) result (lab_is_cm)
logical :: lab_is_cm
class(phs_t), intent(in) :: phs
end function phs_lab_is_cm
<<PHS base: procedures>>=
module function phs_lab_is_cm (phs) result (lab_is_cm)
logical :: lab_is_cm
class(phs_t), intent(in) :: phs
lab_is_cm = phs%config%lab_is_cm
end function phs_lab_is_cm
@ %def phs_lab_is_cm
@
<<PHS base: phs: TBP>>=
procedure :: get_n_tot => phs_get_n_tot
<<PHS base: sub interfaces>>=
elemental module function phs_get_n_tot (phs) result (n_tot)
integer :: n_tot
class(phs_t), intent(in) :: phs
end function phs_get_n_tot
<<PHS base: procedures>>=
elemental module function phs_get_n_tot (phs) result (n_tot)
integer :: n_tot
class(phs_t), intent(in) :: phs
n_tot = phs%config%n_tot
end function phs_get_n_tot
@ %def phs_get_n_tot
@
<<PHS base: phs: TBP>>=
procedure :: set_lorentz_transformation => phs_set_lorentz_transformation
<<PHS base: sub interfaces>>=
module subroutine phs_set_lorentz_transformation (phs, lt)
class(phs_t), intent(inout) :: phs
type(lorentz_transformation_t), intent(in) :: lt
end subroutine phs_set_lorentz_transformation
<<PHS base: procedures>>=
module subroutine phs_set_lorentz_transformation (phs, lt)
class(phs_t), intent(inout) :: phs
type(lorentz_transformation_t), intent(in) :: lt
phs%lt_cm_to_lab = lt
end subroutine phs_set_lorentz_transformation
@ %def phs_set_lorentz_transformation
@
<<PHS base: phs: TBP>>=
procedure :: get_lorentz_transformation => phs_get_lorentz_transformation
<<PHS base: sub interfaces>>=
module function phs_get_lorentz_transformation (phs) result (lt)
type(lorentz_transformation_t) :: lt
class(phs_t), intent(in) :: phs
end function phs_get_lorentz_transformation
<<PHS base: procedures>>=
module function phs_get_lorentz_transformation (phs) result (lt)
type(lorentz_transformation_t) :: lt
class(phs_t), intent(in) :: phs
lt = phs%lt_cm_to_lab
end function phs_get_lorentz_transformation
@ %def phs_get_lorentz_transformation
@ Return the input parameter array for a channel.
<<PHS base: phs: TBP>>=
procedure :: get_mcpar => phs_get_mcpar
<<PHS base: sub interfaces>>=
module subroutine phs_get_mcpar (phs, c, r)
class(phs_t), intent(in) :: phs
integer, intent(in) :: c
real(default), dimension(:), intent(out) :: r
end subroutine phs_get_mcpar
<<PHS base: procedures>>=
module subroutine phs_get_mcpar (phs, c, r)
class(phs_t), intent(in) :: phs
integer, intent(in) :: c
real(default), dimension(:), intent(out) :: r
if (phs%r_defined) then
r = phs%r(:,c)
else
r = 0
end if
end subroutine phs_get_mcpar
@ %def phs_get_mcpar
@ Return the Jacobian factor for a channel.
<<PHS base: phs: TBP>>=
procedure :: get_f => phs_get_f
<<PHS base: sub interfaces>>=
module function phs_get_f (phs, c) result (f)
class(phs_t), intent(in) :: phs
integer, intent(in) :: c
real(default) :: f
end function phs_get_f
<<PHS base: procedures>>=
module function phs_get_f (phs, c) result (f)
class(phs_t), intent(in) :: phs
integer, intent(in) :: c
real(default) :: f
if (phs%r_defined) then
f = phs%f(c)
else
f = 0
end if
end function phs_get_f
@ %def phs_get_f
@ Return the overall factor, which is the product of the flux factor for the
incoming partons and the phase-space volume for the outgoing partons.
<<PHS base: phs: TBP>>=
procedure :: get_overall_factor => phs_get_overall_factor
<<PHS base: sub interfaces>>=
module function phs_get_overall_factor (phs) result (f)
class(phs_t), intent(in) :: phs
real(default) :: f
end function phs_get_overall_factor
<<PHS base: procedures>>=
module function phs_get_overall_factor (phs) result (f)
class(phs_t), intent(in) :: phs
real(default) :: f
f = phs%flux * phs%volume
end function phs_get_overall_factor
@ %def phs_get_overall_factor
@ Compute flux factor. We do this during initialization (when the
incoming momenta [[p]] are undefined), unless [[sqrts]] is variable. We do
this again once for each phase-space point, but then we skip the calculation
if [[sqrts]] is fixed.
There are three different flux factors.
\begin{enumerate}
\item
For a decaying massive particle, the factor is
\begin{equation}
f = (2\pi)^4 / (2M)
\end{equation}
\item
For a $2\to n$ scattering process with $n>1$, the factor is
\begin{equation}
f = (2\pi)^4 / (2\sqrt{\lambda})
\end{equation}
where for massless incoming particles, $\sqrt{\lambda} = s$.
\item For a $2\to 1$ on-shell production process, the factor includes
an extra $1/(2\pi)^3$ factor and a $1/m^2$ factor from the
phase-space delta function $\delta (x_1x_2 - m^2/s)$, which
originate from the one-particle phase space that we integrate out.
\begin{equation}
f = 2\pi / (2s m^2)
\end{equation}
The delta function is handled by the structure-function
parameterization.
\end{enumerate}
<<PHS base: phs: TBP>>=
procedure :: compute_flux => phs_compute_flux
procedure :: compute_base_flux => phs_compute_flux
<<PHS base: sub interfaces>>=
module subroutine phs_compute_flux (phs)
class(phs_t), intent(inout) :: phs
end subroutine phs_compute_flux
<<PHS base: procedures>>=
module subroutine phs_compute_flux (phs)
class(phs_t), intent(inout) :: phs
real(default) :: s_hat, lda
select case (phs%config%n_in)
case (1)
if (.not. phs%p_defined) then
phs%flux = twopi4 / (2 * phs%m_in(1))
end if
case (2)
if (phs%p_defined) then
if (phs%config%sqrts_fixed) then
return
else
s_hat = sum (phs%p) ** 2
end if
else
if (phs%config%sqrts_fixed) then
s_hat = phs%config%sqrts ** 2
else
return
end if
end if
select case (phs%config%n_out)
case (2:)
lda = lambda (s_hat, phs%m_in(1) ** 2, phs%m_in(2) ** 2)
if (lda > 0) then
phs%flux = conv * twopi4 / (2 * sqrt (lda))
else
phs%flux = 0
end if
case (1)
phs%flux = conv * twopi &
/ (2 * phs%config%sqrts ** 2 * phs%m_out(1) ** 2)
case default
phs%flux = 0
end select
end select
end subroutine phs_compute_flux
@ %def phs_compute_flux
@ Evaluate the phase-space point for a particular channel and compute momenta,
Jacobian, and phase-space volume. This is, of course, deferred to
the implementation.
<<PHS base: phs: TBP>>=
procedure (phs_evaluate_selected_channel), deferred :: &
evaluate_selected_channel
<<PHS base: interfaces>>=
abstract interface
subroutine phs_evaluate_selected_channel (phs, c_in, r_in)
import
class(phs_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), dimension(:), intent(in) :: r_in
end subroutine phs_evaluate_selected_channel
end interface
@ %def phs_evaluate_selected_channel
@ Compute the inverse mappings to completely fill the [[r]] and [[f]] arrays,
for the non-selected channels.
<<PHS base: phs: TBP>>=
procedure (phs_evaluate_other_channels), deferred :: &
evaluate_other_channels
<<PHS base: interfaces>>=
abstract interface
subroutine phs_evaluate_other_channels (phs, c_in)
import
class(phs_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_evaluate_other_channels
end interface
@ %def phs_evaluate_other_channels
@ Inverse evaluation. If all momenta are known, we compute the
inverse mappings to fill the [[r]] and [[f]] arrays.
<<PHS base: phs: TBP>>=
procedure (phs_inverse), deferred :: inverse
<<PHS base: interfaces>>=
abstract interface
subroutine phs_inverse (phs)
import
class(phs_t), intent(inout) :: phs
end subroutine phs_inverse
end interface
@ %def phs_inverse
@
<<PHS base: phs: TBP>>=
procedure :: get_sqrts => phs_get_sqrts
<<PHS base: sub interfaces>>=
module function phs_get_sqrts (phs) result (sqrts)
real(default) :: sqrts
class(phs_t), intent(in) :: phs
end function phs_get_sqrts
<<PHS base: procedures>>=
module function phs_get_sqrts (phs) result (sqrts)
real(default) :: sqrts
class(phs_t), intent(in) :: phs
sqrts = phs%config%sqrts
end function phs_get_sqrts
@ %def phs_get_sqrts
@
\subsubsection{Uniform angular distribution}
These procedures implement the uniform angular distribution, generated
from two parameters $x_1$ and $x_2$:
\begin{equation}
\cos\theta = 1 - 2x_1, \qquad \phi = 2\pi x_2
\end{equation}
We generate a rotation (Lorentz transformation) which rotates the
positive $z$ axis into this point on the unit sphere. This rotation
is applied to the [[p]] momenta, which are assumed to be
back-to-back, on-shell, and with the correct mass.
We do not compute a Jacobian (constant). The uniform distribution is
assumed to be normalized.
<<PHS base: public>>=
public :: compute_kinematics_solid_angle
<<PHS base: sub interfaces>>=
module subroutine compute_kinematics_solid_angle (p, q, x)
type(vector4_t), dimension(2), intent(in) :: p
type(vector4_t), dimension(2), intent(out) :: q
real(default), dimension(2), intent(in) :: x
end subroutine compute_kinematics_solid_angle
<<PHS base: procedures>>=
module subroutine compute_kinematics_solid_angle (p, q, x)
type(vector4_t), dimension(2), intent(in) :: p
type(vector4_t), dimension(2), intent(out) :: q
real(default), dimension(2), intent(in) :: x
real(default) :: ct, st, phi
type(lorentz_transformation_t) :: rot
integer :: i
ct = 1 - 2*x(1)
st = sqrt (1 - ct**2)
phi = twopi * x(2)
rot = rotation (phi, 3) * rotation (ct, st, 2)
do i = 1, 2
q(i) = rot * p(i)
end do
end subroutine compute_kinematics_solid_angle
@ %def compute_kinematics_solid_angle
@ This is the inverse transformation. We assume that the outgoing
momenta are rotated versions of the incoming momenta, back-to-back.
Thus, we determine the angles from $q(1)$ alone. [[p]] is unused.
<<PHS base: public>>=
public :: inverse_kinematics_solid_angle
<<PHS base: sub interfaces>>=
module subroutine inverse_kinematics_solid_angle (p, q, x)
type(vector4_t), dimension(:), intent(in) :: p
type(vector4_t), dimension(2), intent(in) :: q
real(default), dimension(2), intent(out) :: x
end subroutine inverse_kinematics_solid_angle
<<PHS base: procedures>>=
module subroutine inverse_kinematics_solid_angle (p, q, x)
type(vector4_t), dimension(:), intent(in) :: p
type(vector4_t), dimension(2), intent(in) :: q
real(default), dimension(2), intent(out) :: x
real(default) :: ct, phi
ct = polar_angle_ct (q(1))
phi = azimuthal_angle (q(1))
x(1) = (1 - ct) / 2
x(2) = phi / twopi
end subroutine inverse_kinematics_solid_angle
@ %def inverse_kinematics_solid_angle
@
\subsection{Auxiliary stuff}
The [[pacify]] subroutine, which is provided by the Lorentz module,
has the purpose of setting numbers to zero which are (by comparing
with a [[tolerance]] parameter) considered equivalent with zero. This
is useful for numerical checks.
<<PHS base: public>>=
public :: pacify
<<PHS base: interfaces>>=
interface pacify
module procedure pacify_phs
end interface pacify
<<PHS base: sub interfaces>>=
module subroutine pacify_phs (phs)
class(phs_t), intent(inout) :: phs
end subroutine pacify_phs
<<PHS base: procedures>>=
module subroutine pacify_phs (phs)
class(phs_t), intent(inout) :: phs
if (phs%p_defined) then
call pacify (phs%p, 30 * epsilon (1._default) * phs%config%sqrts)
call pacify (phs%lt_cm_to_lab, 30 * epsilon (1._default))
end if
if (phs%q_defined) then
call pacify (phs%q, 30 * epsilon (1._default) * phs%config%sqrts)
end if
end subroutine pacify_phs
@ %def pacify
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[phs_base_ut.f90]]>>=
<<File header>>
module phs_base_ut
use unit_tests
use phs_base_uti
<<Standard module head>>
<<PHS base: public test>>
<<PHS base: public test auxiliary>>
contains
<<PHS base: test driver>>
end module phs_base_ut
@ %def phs_base_ut
@
<<[[phs_base_uti.f90]]>>=
<<File header>>
module phs_base_uti
<<Use kinds>>
<<Use strings>>
use diagnostics
use io_units
use format_defs, only: FMT_19
use physics_defs, only: BORN
use lorentz
use flavors
use model_data
use process_constants
use phs_base
<<Standard module head>>
<<PHS base: public test auxiliary>>
<<PHS base: test declarations>>
<<PHS base: test types>>
contains
<<PHS base: tests>>
<<PHS base: test auxiliary>>
end module phs_base_uti
@ %def phs_base_ut
@ API: driver for the unit tests below.
<<PHS base: public test>>=
public :: phs_base_test
<<PHS base: test driver>>=
subroutine phs_base_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS base: execute tests>>
end subroutine phs_base_test
@ %def phs_base_test
@
\subsubsection{Test process data}
We provide a procedure that initializes a test case for the process
constants. This set of process data contains just the minimal
contents that we need for the phase space. The rest is left
uninitialized.
<<PHS base: public test auxiliary>>=
public :: init_test_process_data
<<PHS base: test auxiliary>>=
subroutine init_test_process_data (id, data)
type(process_constants_t), intent(out) :: data
type(string_t), intent(in), optional :: id
if (present (id)) then
data%id = id
else
data%id = "testproc"
end if
data%model_name = "Test"
data%n_in = 2
data%n_out = 2
data%n_flv = 1
allocate (data%flv_state (data%n_in + data%n_out, data%n_flv))
data%flv_state = 25
end subroutine init_test_process_data
@ %def init_test_process_data
@ This is the variant for a decay process.
<<PHS base: public test auxiliary>>=
public :: init_test_decay_data
<<PHS base: test auxiliary>>=
subroutine init_test_decay_data (id, data)
type(process_constants_t), intent(out) :: data
type(string_t), intent(in), optional :: id
if (present (id)) then
data%id = id
else
data%id = "testproc"
end if
data%model_name = "Test"
data%n_in = 1
data%n_out = 2
data%n_flv = 1
allocate (data%flv_state (data%n_in + data%n_out, data%n_flv))
data%flv_state(:,1) = [25, 6, -6]
end subroutine init_test_decay_data
@ %def init_test_decay_data
@
\subsubsection{Test kinematics configuration}
This is a trivial implementation of the [[phs_config_t]] configuration object.
<<PHS base: public test auxiliary>>=
public :: phs_test_config_t
<<PHS base: test types>>=
type, extends (phs_config_t) :: phs_test_config_t
logical :: create_equivalences = .false.
contains
procedure :: final => phs_test_config_final
procedure :: write => phs_test_config_write
procedure :: configure => phs_test_config_configure
procedure :: startup_message => phs_test_config_startup_message
procedure, nopass :: allocate_instance => phs_test_config_allocate_instance
end type phs_test_config_t
@ %def phs_test_config_t
@ The finalizer is empty.
<<PHS base: test auxiliary>>=
subroutine phs_test_config_final (object)
class(phs_test_config_t), intent(inout) :: object
end subroutine phs_test_config_final
@ %def phs_test_config_final
@ The [[lab_is_cm]] parameter is not tested here; we defer this to the
[[phs_single]] implementation.
<<PHS base: test auxiliary>>=
subroutine phs_test_config_write (object, unit, include_id)
class(phs_test_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Partonic phase-space configuration:"
call object%base_write (unit)
end subroutine phs_test_config_write
subroutine phs_test_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_test_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
phs_config%n_channel = 2
phs_config%n_par = 2
phs_config%sqrts = sqrts
if (.not. present (nlo_type)) &
phs_config%nlo_type = BORN
if (present (sqrts_fixed)) then
phs_config%sqrts_fixed = sqrts_fixed
end if
if (present (lab_is_cm)) then
phs_config%lab_is_cm = lab_is_cm
end if
if (present (azimuthal_dependence)) then
phs_config%azimuthal_dependence = azimuthal_dependence
end if
if (allocated (phs_config%channel)) deallocate (phs_config%channel)
allocate (phs_config%channel (phs_config%n_channel))
if (phs_config%create_equivalences) then
call setup_test_equivalences (phs_config)
call setup_test_channel_props (phs_config)
end if
call phs_config%compute_md5sum ()
end subroutine phs_test_config_configure
@ %def phs_test_config_write
@ %def phs_test_config_configure
@ If requested, we make up an arbitrary set of equivalences.
<<PHS base: test auxiliary>>=
subroutine setup_test_equivalences (phs_config)
class(phs_test_config_t), intent(inout) :: phs_config
integer :: i
associate (channel => phs_config%channel(1))
allocate (channel%eq (2))
do i = 1, size (channel%eq)
call channel%eq(i)%init (phs_config%n_par)
end do
associate (eq => channel%eq(1))
eq%c = 1; eq%perm = [1, 2]; eq%mode = [EQ_IDENTITY, EQ_SYMMETRIC]
end associate
associate (eq => channel%eq(2))
eq%c = 2; eq%perm = [2, 1]; eq%mode = [EQ_INVARIANT, EQ_IDENTITY]
end associate
end associate
end subroutine setup_test_equivalences
@ %def setup_test_equivalences
@ Ditto, for channel properties.
<<PHS base: test auxiliary>>=
subroutine setup_test_channel_props (phs_config)
class(phs_test_config_t), intent(inout) :: phs_config
associate (channel => phs_config%channel(2))
call channel%set_resonant (140._default, 3.1415_default)
end associate
end subroutine setup_test_channel_props
@ %def setup_test_channel_props
@ Startup message
<<PHS base: test auxiliary>>=
subroutine phs_test_config_startup_message (phs_config, unit)
class(phs_test_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
call phs_config%base_startup_message (unit)
write (msg_buffer, "(A)") "Phase space: Test"
call msg_message (unit = unit)
end subroutine phs_test_config_startup_message
@ %def phs_test_config_startup_message
@ The instance type that matches [[phs_test_config_t]] is [[phs_test_t]].
<<PHS base: test auxiliary>>=
subroutine phs_test_config_allocate_instance (phs)
class(phs_t), intent(inout), pointer :: phs
allocate (phs_test_t :: phs)
end subroutine phs_test_config_allocate_instance
@ %def phs_test_config_allocate_instance
@
\subsubsection{Test kinematics implementation}
This implementation of kinematics generates a simple two-particle
configuration from the incoming momenta. The incoming momenta must be
in the c.m.\ system, all masses equal.
There are two channels: one generates $\cos\theta$ and $\phi$
uniformly, in the other channel we map the $r_1$ parameter which
belongs to $\cos\theta$.
We should store the mass parameter that we need.
<<PHS base: public test auxiliary>>=
public :: phs_test_t
<<PHS base: test types>>=
type, extends (phs_t) :: phs_test_t
real(default) :: m = 0
real(default), dimension(:), allocatable :: x
contains
<<PHS base: phs test: TBP>>
end type phs_test_t
@ %def phs_test_t
@ Output. The specific data are displayed only if [[verbose]] is set.
<<PHS base: phs test: TBP>>=
procedure :: write => phs_test_write
<<PHS base: test auxiliary>>=
subroutine phs_test_write (object, unit, verbose)
class(phs_test_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u
logical :: verb
u = given_output_unit (unit)
verb = .false.; if (present (verbose)) verb = verbose
if (verb) then
write (u, "(1x,A)") "Partonic phase space: data"
write (u, "(3x,A," // FMT_19 // ")") "m = ", object%m
end if
call object%base_write (u)
end subroutine phs_test_write
@ %def phs_test_write
@ The finalizer is empty.
<<PHS base: phs test: TBP>>=
procedure :: final => phs_test_final
<<PHS base: test auxiliary>>=
subroutine phs_test_final (object)
class(phs_test_t), intent(inout) :: object
end subroutine phs_test_final
@ %def phs_test_final
@ Initialization: set the mass value.
<<PHS base: phs test: TBP>>=
procedure :: init => phs_test_init
<<PHS base: test auxiliary>>=
subroutine phs_test_init (phs, phs_config)
class(phs_test_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
call phs%base_init (phs_config)
phs%m = phs%config%flv(1,1)%get_mass ()
allocate (phs%x (phs_config%n_par), source = 0._default)
end subroutine phs_test_init
@ %def phs_test_init
@ Evaluation. In channel 1, we uniformly generate $\cos\theta$ and
$\phi$, with Jacobian normalized to one. In channel 2, we prepend a
mapping $r_1 \to r_1^(1/3)$ with Jacobian $f=3r_1^2$.
The component [[x]] is allocated in the first subroutine, used and deallocated
in the second one.
<<PHS base: phs test: TBP>>=
procedure :: evaluate_selected_channel => phs_test_evaluate_selected_channel
procedure :: evaluate_other_channels => phs_test_evaluate_other_channels
<<PHS base: test auxiliary>>=
subroutine phs_test_evaluate_selected_channel (phs, c_in, r_in)
class(phs_test_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
if (phs%p_defined) then
call phs%select_channel (c_in)
phs%r(:,c_in) = r_in
select case (c_in)
case (1)
phs%x = r_in
case (2)
phs%x(1) = r_in(1) ** (1 / 3._default)
phs%x(2) = r_in(2)
end select
call compute_kinematics_solid_angle (phs%p, phs%q, phs%x)
phs%volume = 1
phs%q_defined = .true.
end if
end subroutine phs_test_evaluate_selected_channel
subroutine phs_test_evaluate_other_channels (phs, c_in)
class(phs_test_t), intent(inout) :: phs
integer, intent(in) :: c_in
integer :: c, n_channel
if (phs%p_defined) then
n_channel = phs%config%n_channel
do c = 1, n_channel
if (c /= c_in) then
call inverse_kinematics_solid_angle (phs%p, phs%q, phs%x)
select case (c)
case (1)
phs%r(:,c) = phs%x
case (2)
phs%r(1,c) = phs%x(1) ** 3
phs%r(2,c) = phs%x(2)
end select
end if
end do
phs%f(1) = 1
if (phs%r(1,2) /= 0) then
phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default))
else
phs%f(2) = 0
end if
phs%r_defined = .true.
end if
end subroutine phs_test_evaluate_other_channels
@ %def phs_test_evaluate_selected_channels
@ %def phs_test_evaluate_other_channels
@ Inverse evaluation.
<<PHS base: phs test: TBP>>=
procedure :: inverse => phs_test_inverse
<<PHS base: test auxiliary>>=
subroutine phs_test_inverse (phs)
class(phs_test_t), intent(inout) :: phs
integer :: c, n_channel
real(default), dimension(:), allocatable :: x
if (phs%p_defined .and. phs%q_defined) then
call phs%select_channel ()
n_channel = phs%config%n_channel
allocate (x (phs%config%n_par))
do c = 1, n_channel
call inverse_kinematics_solid_angle (phs%p, phs%q, x)
select case (c)
case (1)
phs%r(:,c) = x
case (2)
phs%r(1,c) = x(1) ** 3
phs%r(2,c) = x(2)
end select
end do
phs%f(1) = 1
if (phs%r(1,2) /= 0) then
phs%f(2) = 1 / (3 * phs%r(1,2) ** (2/3._default))
else
phs%f(2) = 0
end if
phs%volume = 1
phs%r_defined = .true.
end if
end subroutine phs_test_inverse
@ %def phs_test_inverse
@
\subsubsection{Phase-space configuration data}
Construct and display a test phase-space configuration object.
<<PHS base: execute tests>>=
call test (phs_base_1, "phs_base_1", &
"phase-space configuration", &
u, results)
<<PHS base: test declarations>>=
public :: phs_base_1
<<PHS base: tests>>=
subroutine phs_base_1 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
class(phs_config_t), allocatable :: phs_data
write (u, "(A)") "* Test output: phs_base_1"
write (u, "(A)") "* Purpose: initialize and display &
&test phase-space configuration data"
write (u, "(A)")
call model%init_test ()
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_base_1"), process_data)
allocate (phs_test_config_t :: phs_data)
call phs_data%init (process_data, model)
call phs_data%write (u)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_base_1"
end subroutine phs_base_1
@ %def phs_base_1
@
\subsubsection{Phase space evaluation}
Compute kinematics for given parameters, also invert the calculation.
<<PHS base: execute tests>>=
call test (phs_base_2, "phs_base_2", &
"phase-space evaluation", &
u, results)
<<PHS base: test declarations>>=
public :: phs_base_2
<<PHS base: tests>>=
subroutine phs_base_2 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(process_constants_t) :: process_data
real(default) :: sqrts, E
class(phs_config_t), allocatable, target :: phs_data
class(phs_t), pointer :: phs => null ()
type(vector4_t), dimension(2) :: p, q
write (u, "(A)") "* Test output: phs_base_2"
write (u, "(A)") "* Purpose: test simple two-channel phase space"
write (u, "(A)")
call model%init_test ()
call flv%init (25, model)
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_base_2"), process_data)
allocate (phs_test_config_t :: phs_data)
call phs_data%init (process_data, model)
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
select type (phs)
type is (phs_test_t)
call phs%init (phs_data)
end select
call phs%write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Set incoming momenta"
write (u, "(A)")
E = sqrts / 2
p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point in channel 1 &
&for x = 0.5, 0.125"
write (u, "(A)")
call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
call phs%evaluate_other_channels (1)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point in channel 2 &
&for x = 0.125, 0.125"
write (u, "(A)")
call phs%evaluate_selected_channel (2, [0.125_default, 0.125_default])
call phs%evaluate_other_channels (2)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
sqrts = 1000._default
select type (phs_data)
type is (phs_test_config_t)
call phs_data%configure (sqrts)
end select
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call phs%write (u)
call phs%final ()
deallocate (phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_base_2"
end subroutine phs_base_2
@ %def phs_base_2
@
\subsubsection{Phase-space equivalences}
Construct a test phase-space configuration which contains channel
equivalences.
<<PHS base: execute tests>>=
call test (phs_base_3, "phs_base_3", &
"channel equivalences", &
u, results)
<<PHS base: test declarations>>=
public :: phs_base_3
<<PHS base: tests>>=
subroutine phs_base_3 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
class(phs_config_t), allocatable :: phs_data
write (u, "(A)") "* Test output: phs_base_3"
write (u, "(A)") "* Purpose: construct phase-space configuration data &
&with equivalences"
write (u, "(A)")
call model%init_test ()
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_base_3"), process_data)
allocate (phs_test_config_t :: phs_data)
call phs_data%init (process_data, model)
select type (phs_data)
type is (phs_test_config_t)
phs_data%create_equivalences = .true.
end select
call phs_data%configure (1000._default)
call phs_data%write (u)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_base_3"
end subroutine phs_base_3
@ %def phs_base_3
@
\subsubsection{MD5 sum checks}
Construct a test phase-space configuration, compute and compare MD5 sums.
<<PHS base: execute tests>>=
call test (phs_base_4, "phs_base_4", &
"MD5 sum", &
u, results)
<<PHS base: test declarations>>=
public :: phs_base_4
<<PHS base: tests>>=
subroutine phs_base_4 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
class(phs_config_t), allocatable :: phs_data
write (u, "(A)") "* Test output: phs_base_4"
write (u, "(A)") "* Purpose: compute and compare MD5 sums"
write (u, "(A)")
call model%init_test ()
write (u, "(A)") "* Model parameters"
write (u, "(A)")
call model%write (unit = u, &
show_parameters = .true., &
show_particles = .false., show_vertices = .false.)
write (u, "(A)")
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_base_4"), process_data)
process_data%md5sum = "test_process_data_m6sum_12345678"
allocate (phs_test_config_t :: phs_data)
call phs_data%init (process_data, model)
call phs_data%compute_md5sum ()
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Modify model parameter"
write (u, "(A)")
call model%set_par (var_str ("ms"), 100._default)
call model%write (show_parameters = .true., &
show_particles = .false., show_vertices = .false.)
write (u, "(A)")
write (u, "(A)") "* PHS configuration"
write (u, "(A)")
call phs_data%compute_md5sum ()
call phs_data%write (u)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_base_4"
end subroutine phs_base_4
@ %def phs_base_4
@
\subsubsection{Phase-space channel collection}
Set up an array of various phase-space channels and collect them in a list.
<<PHS base: execute tests>>=
call test (phs_base_5, "phs_base_5", &
"channel collection", &
u, results)
<<PHS base: test declarations>>=
public :: phs_base_5
<<PHS base: tests>>=
subroutine phs_base_5 (u)
integer, intent(in) :: u
type(phs_channel_t), dimension(:), allocatable :: channel
type(phs_channel_collection_t) :: coll
integer :: i, n
write (u, "(A)") "* Test output: phs_base_5"
write (u, "(A)") "* Purpose: collect channel properties"
write (u, "(A)")
write (u, "(A)") "* Set up an array of channels"
write (u, "(A)")
n = 6
allocate (channel (n))
call channel(2)%set_resonant (75._default, 3._default)
call channel(4)%set_resonant (130._default, 1._default)
call channel(5)%set_resonant (75._default, 3._default)
call channel(6)%set_on_shell (33._default)
do i = 1, n
write (u, "(1x,I0)", advance="no") i
call channel(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Collect distinct properties"
write (u, "(A)")
do i = 1, n
call coll%push (channel(i))
end do
write (u, "(1x,A,I0)") "n = ", coll%get_n ()
write (u, "(A)")
call coll%write (u)
write (u, "(A)")
write (u, "(A)") "* Channel array with collection index assigned"
write (u, "(A)")
do i = 1, n
write (u, "(1x,I0)", advance="no") i
call channel(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call coll%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_base_5"
end subroutine phs_base_5
@ %def phs_base_5
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\clearpage
\section{Dummy phase space}
This module implements a dummy phase space module for cases where the
program structure demands the existence of a phase-space module, but
no phase space integration is performed.
<<[[phs_none.f90]]>>=
<<File header>>
module phs_none
<<Use kinds>>
<<Use strings>>
use phs_base, only: phs_config_t, phs_t
<<Standard module head>>
<<PHS none: public>>
<<PHS none: types>>
interface
<<PHS none: sub interfaces>>
end interface
contains
<<PHS none: main procedures>>
end module phs_none
@ %def phs_none
@
<<[[phs_none_sub.f90]]>>=
<<File header>>
submodule (phs_none) phs_none_s
use io_units, only: given_output_unit
use diagnostics, only: msg_message, msg_fatal
implicit none
contains
<<PHS none: procedures>>
end submodule phs_none_s
@ %def phs_none_s
@
\subsection{Configuration}
Nothing to configure, but we provide the type and methods.
<<PHS none: public>>=
public :: phs_none_config_t
<<PHS none: types>>=
type, extends (phs_config_t) :: phs_none_config_t
contains
<<PHS none: phs none config: TBP>>
end type phs_none_config_t
@ %def phs_none_config_t
@ The finalizer is empty.
<<PHS none: phs none config: TBP>>=
procedure :: final => phs_none_config_final
<<PHS none: sub interfaces>>=
module subroutine phs_none_config_final (object)
class(phs_none_config_t), intent(inout) :: object
end subroutine phs_none_config_final
<<PHS none: procedures>>=
module subroutine phs_none_config_final (object)
class(phs_none_config_t), intent(inout) :: object
end subroutine phs_none_config_final
@ %def phs_none_final
@ Output. No contents, just an informative line.
<<PHS none: phs none config: TBP>>=
procedure :: write => phs_none_config_write
<<PHS none: sub interfaces>>=
module subroutine phs_none_config_write (object, unit, include_id)
class(phs_none_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
end subroutine phs_none_config_write
<<PHS none: procedures>>=
module subroutine phs_none_config_write (object, unit, include_id)
class(phs_none_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") &
"Partonic phase-space configuration: non-functional dummy"
end subroutine phs_none_config_write
@ %def phs_none_config_write
@ Configuration: we have to implement this method, but it obviously
does nothing.
<<PHS none: phs none config: TBP>>=
procedure :: configure => phs_none_config_configure
<<PHS none: sub interfaces>>=
module subroutine phs_none_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_none_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
end subroutine phs_none_config_configure
<<PHS none: procedures>>=
module subroutine phs_none_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_none_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
end subroutine phs_none_config_configure
@ %def phs_none_config_configure
@ Startup message, after configuration is complete.
<<PHS none: phs none config: TBP>>=
procedure :: startup_message => phs_none_config_startup_message
<<PHS none: sub interfaces>>=
module subroutine phs_none_config_startup_message (phs_config, unit)
class(phs_none_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
end subroutine phs_none_config_startup_message
<<PHS none: procedures>>=
module subroutine phs_none_config_startup_message (phs_config, unit)
class(phs_none_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
call msg_message ("Phase space: none")
end subroutine phs_none_config_startup_message
@ %def phs_none_config_startup_message
@ Allocate an instance: the actual phase-space object.
Gfortran 7/8/9 bug: has to remain in the main module.
<<PHS none: phs none config: TBP>>=
procedure, nopass :: allocate_instance => phs_none_config_allocate_instance
<<PHS none: main procedures>>=
subroutine phs_none_config_allocate_instance (phs)
class(phs_t), intent(inout), pointer :: phs
allocate (phs_none_t :: phs)
end subroutine phs_none_config_allocate_instance
@ %def phs_none_config_allocate_instance
@
\subsection{Kinematics implementation}
This is considered as empty, but we have to implement the minimal set of methods.
<<PHS none: public>>=
public :: phs_none_t
<<PHS none: types>>=
type, extends (phs_t) :: phs_none_t
contains
<<PHS none: phs none: TBP>>
end type phs_none_t
@ %def phs_none_t
@ Output.
<<PHS none: phs none: TBP>>=
procedure :: write => phs_none_write
<<PHS none: sub interfaces>>=
module subroutine phs_none_write (object, unit, verbose)
class(phs_none_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine phs_none_write
<<PHS none: procedures>>=
module subroutine phs_none_write (object, unit, verbose)
class(phs_none_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u
u = given_output_unit (unit)
write (u, "(A)") "Partonic phase space: none"
end subroutine phs_none_write
@ %def phs_none_write
@ The finalizer is empty.
<<PHS none: phs none: TBP>>=
procedure :: final => phs_none_final
<<PHS none: sub interfaces>>=
module subroutine phs_none_final (object)
class(phs_none_t), intent(inout) :: object
end subroutine phs_none_final
<<PHS none: procedures>>=
module subroutine phs_none_final (object)
class(phs_none_t), intent(inout) :: object
end subroutine phs_none_final
@ %def phs_none_final
@ Initialization, trivial.
<<PHS none: phs none: TBP>>=
procedure :: init => phs_none_init
<<PHS none: sub interfaces>>=
module subroutine phs_none_init (phs, phs_config)
class(phs_none_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
end subroutine phs_none_init
<<PHS none: procedures>>=
module subroutine phs_none_init (phs, phs_config)
class(phs_none_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
call phs%base_init (phs_config)
end subroutine phs_none_init
@ %def phs_none_init
@ Evaluation. This must not be called at all.
<<PHS none: phs none: TBP>>=
procedure :: evaluate_selected_channel => phs_none_evaluate_selected_channel
procedure :: evaluate_other_channels => phs_none_evaluate_other_channels
<<PHS none: sub interfaces>>=
module subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in)
class(phs_none_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
end subroutine phs_none_evaluate_selected_channel
module subroutine phs_none_evaluate_other_channels (phs, c_in)
class(phs_none_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_none_evaluate_other_channels
<<PHS none: procedures>>=
module subroutine phs_none_evaluate_selected_channel (phs, c_in, r_in)
class(phs_none_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
call msg_fatal &
("Phase space: attempt to evaluate with the 'phs_none' method")
end subroutine phs_none_evaluate_selected_channel
module subroutine phs_none_evaluate_other_channels (phs, c_in)
class(phs_none_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_none_evaluate_other_channels
@ %def phs_none_evaluate_selected_channel
@ %def phs_none_evaluate_other_channels
@ Inverse evaluation, likewise.
<<PHS none: phs none: TBP>>=
procedure :: inverse => phs_none_inverse
<<PHS none: sub interfaces>>=
module subroutine phs_none_inverse (phs)
class(phs_none_t), intent(inout) :: phs
end subroutine phs_none_inverse
<<PHS none: procedures>>=
module subroutine phs_none_inverse (phs)
class(phs_none_t), intent(inout) :: phs
call msg_fatal ("Phase space: attempt to evaluate inverse " // &
"with the 'phs_none' method")
end subroutine phs_none_inverse
@ %def phs_none_inverse
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[phs_none_ut.f90]]>>=
<<File header>>
module phs_none_ut
use unit_tests
use phs_none_uti
<<Standard module head>>
<<PHS none: public test>>
contains
<<PHS none: test driver>>
end module phs_none_ut
@ %def phs_none_ut
@
<<[[phs_none_uti.f90]]>>=
<<File header>>
module phs_none_uti
<<Use kinds>>
<<Use strings>>
use flavors
use lorentz
use model_data
use process_constants
use phs_base
use phs_none
use phs_base_ut, only: init_test_process_data, init_test_decay_data
<<Standard module head>>
<<PHS none: test declarations>>
contains
<<PHS none: tests>>
end module phs_none_uti
@ %def phs_none_ut
@ API: driver for the unit tests below.
<<PHS none: public test>>=
public :: phs_none_test
<<PHS none: test driver>>=
subroutine phs_none_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS none: execute tests>>
end subroutine phs_none_test
@ %def phs_none_test
@
\subsubsection{Phase-space configuration data}
Construct and display a test phase-space configuration object. Also
check the [[azimuthal_dependence]] flag.
<<PHS none: execute tests>>=
call test (phs_none_1, "phs_none_1", &
"phase-space configuration dummy", &
u, results)
<<PHS none: test declarations>>=
public :: phs_none_1
<<PHS none: tests>>=
subroutine phs_none_1 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
class(phs_config_t), allocatable :: phs_data
real(default) :: sqrts
write (u, "(A)") "* Test output: phs_none_1"
write (u, "(A)") "* Purpose: display &
&phase-space configuration data"
write (u, "(A)")
allocate (phs_none_config_t :: phs_data)
call phs_data%init (process_data, model)
sqrts = 1000._default
call phs_data%configure (sqrts, azimuthal_dependence=.false.)
call phs_data%write (u)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_none_1"
end subroutine phs_none_1
@ %def phs_none_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\clearpage
\section{Single-particle phase space}
This module implements the phase space for a single particle, i.e., the solid
angle, in a straightforward parameterization with a single channel. The
phase-space implementation may be used either for $1\to 2$ decays or for $2\to
2$ scattering processes, so the number of incoming particles is the only free
parameter in the configuration. In the latter case, we should restrict its
use to non-resonant s-channel processes, because there is no mapping of the
scattering angle.
(We might extend this later to account for generic $2\to 2$ situations, e.g.,
account for a Coulomb singularity or detect an s-channel resonance structure
that requires matching structure-function mappings.)
This is derived from the [[phs_test]] implementation in the
[[phs_base]] module above, even more simplified, but intended for
actual use.
<<[[phs_single.f90]]>>=
<<File header>>
module phs_single
<<Use kinds>>
<<Use strings>>
use lorentz
use phs_base
<<Standard module head>>
<<PHS single: public>>
<<PHS single: types>>
interface
<<PHS single: sub interfaces>>
end interface
contains
<<PHS single: main procedures>>
end module phs_single
@ %def phs_single
@
<<[[phs_single_sub.f90]]>>=
<<File header>>
submodule (phs_single) phs_single_s
use io_units
use constants
use numeric_utils
use diagnostics
use physics_defs
implicit none
contains
<<PHS single: procedures>>
end submodule phs_single_s
@ %def phs_single_s
@
\subsection{Configuration}
<<PHS single: public>>=
public :: phs_single_config_t
<<PHS single: types>>=
type, extends (phs_config_t) :: phs_single_config_t
contains
<<PHS single: phs single config: TBP>>
end type phs_single_config_t
@ %def phs_single_config_t
@ The finalizer is empty.
<<PHS single: phs single config: TBP>>=
procedure :: final => phs_single_config_final
<<PHS single: sub interfaces>>=
module subroutine phs_single_config_final (object)
class(phs_single_config_t), intent(inout) :: object
end subroutine phs_single_config_final
<<PHS single: procedures>>=
module subroutine phs_single_config_final (object)
class(phs_single_config_t), intent(inout) :: object
end subroutine phs_single_config_final
@ %def phs_single_final
@ Output.
<<PHS single: phs single config: TBP>>=
procedure :: write => phs_single_config_write
<<PHS single: sub interfaces>>=
module subroutine phs_single_config_write (object, unit, include_id)
class(phs_single_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
end subroutine phs_single_config_write
<<PHS single: procedures>>=
module subroutine phs_single_config_write (object, unit, include_id)
class(phs_single_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Partonic phase-space configuration (single-particle):"
call object%base_write (unit)
end subroutine phs_single_config_write
@ %def phs_single_config_write
@ Configuration: there is only one channel and two parameters. The
second parameter is the azimuthal angle, which may be a flat dimension.
<<PHS single: phs single config: TBP>>=
procedure :: configure => phs_single_config_configure
<<PHS single: sub interfaces>>=
module subroutine phs_single_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_single_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
end subroutine phs_single_config_configure
<<PHS single: procedures>>=
module subroutine phs_single_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_single_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
if (.not. present (nlo_type)) &
phs_config%nlo_type = BORN
if (phs_config%n_out == 2) then
phs_config%n_channel = 1
phs_config%n_par = 2
phs_config%sqrts = sqrts
if (present (sqrts_fixed)) phs_config%sqrts_fixed = sqrts_fixed
if (present (lab_is_cm)) phs_config%lab_is_cm = lab_is_cm
if (present (azimuthal_dependence)) then
phs_config%azimuthal_dependence = azimuthal_dependence
if (.not. azimuthal_dependence) then
allocate (phs_config%dim_flat (1))
phs_config%dim_flat(1) = 2
end if
end if
if (allocated (phs_config%channel)) deallocate (phs_config%channel)
allocate (phs_config%channel (1))
call phs_config%compute_md5sum ()
else
call msg_fatal ("Single-particle phase space requires n_out = 2")
end if
end subroutine phs_single_config_configure
@ %def phs_single_config_configure
@ Startup message, after configuration is complete.
<<PHS single: phs single config: TBP>>=
procedure :: startup_message => phs_single_config_startup_message
<<PHS single: sub interfaces>>=
module subroutine phs_single_config_startup_message (phs_config, unit)
class(phs_single_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
end subroutine phs_single_config_startup_message
<<PHS single: procedures>>=
module subroutine phs_single_config_startup_message (phs_config, unit)
class(phs_single_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
call phs_config%base_startup_message (unit)
write (msg_buffer, "(A,2(1x,I0,1x,A))") &
"Phase space: single-particle"
call msg_message (unit = unit)
end subroutine phs_single_config_startup_message
@ %def phs_single_config_startup_message
@ Allocate an instance: the actual phase-space object.
Gfortran 7/8/9 bug, has to remain in the main module.
<<PHS single: phs single config: TBP>>=
procedure, nopass :: allocate_instance => phs_single_config_allocate_instance
<<PHS single: main procedures>>=
subroutine phs_single_config_allocate_instance (phs)
class(phs_t), intent(inout), pointer :: phs
allocate (phs_single_t :: phs)
end subroutine phs_single_config_allocate_instance
@ %def phs_single_config_allocate_instance
@
\subsection{Kinematics implementation}
We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle.
Note: The incoming momenta must be in the c.m. system.
<<PHS single: public>>=
public :: phs_single_t
<<PHS single: types>>=
type, extends (phs_t) :: phs_single_t
contains
<<PHS single: phs single: TBP>>
end type phs_single_t
@ %def phs_single_t
@ Output. The [[verbose]] setting is irrelevant, we just display the contents
of the base object.
<<PHS single: phs single: TBP>>=
procedure :: write => phs_single_write
<<PHS single: sub interfaces>>=
module subroutine phs_single_write (object, unit, verbose)
class(phs_single_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine phs_single_write
<<PHS single: procedures>>=
module subroutine phs_single_write (object, unit, verbose)
class(phs_single_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u
u = given_output_unit (unit)
call object%base_write (u)
end subroutine phs_single_write
@ %def phs_single_write
@ The finalizer is empty.
<<PHS single: phs single: TBP>>=
procedure :: final => phs_single_final
<<PHS single: sub interfaces>>=
module subroutine phs_single_final (object)
class(phs_single_t), intent(inout) :: object
end subroutine phs_single_final
<<PHS single: procedures>>=
module subroutine phs_single_final (object)
class(phs_single_t), intent(inout) :: object
end subroutine phs_single_final
@ %def phs_single_final
@ Initialization. We allocate arrays ([[base_init]]) and adjust the
phase-space volume. The massless two-particle phase space volume is
\begin{equation}
\Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5}
\end{equation}
For a decay with nonvanishing masses ($m_3$, $m_4$), there is a correction
factor
\begin{equation}
\Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s}
\lambda^{1/2}(\hat s, m_3^2, m_4^2).
\end{equation}
For a scattering process with nonvanishing masses, the correction
factor is
\begin{equation}
\Phi_2(m) / \Phi_2(0) = \frac{1}{\hat s ^ 2}
\lambda^{1/2}(\hat s, m_1^2, m_2^2)\,
\lambda^{1/2}(\hat s, m_3^2, m_4^2).
\end{equation}
If the energy is fixed, this is constant. Otherwise, we have to account for
varying $\hat s$.
<<PHS single: phs single: TBP>>=
procedure :: init => phs_single_init
<<PHS single: sub interfaces>>=
module subroutine phs_single_init (phs, phs_config)
class(phs_single_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
end subroutine phs_single_init
<<PHS single: procedures>>=
module subroutine phs_single_init (phs, phs_config)
class(phs_single_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
call phs%base_init (phs_config)
phs%volume = 1 / (4 * twopi5)
call phs%compute_factor ()
end subroutine phs_single_init
@ %def phs_single_init
@ Compute the correction factor for nonzero masses. We do this during
initialization (when the incoming momenta [[p]] are undefined), unless
[[sqrts]] is variable. We do this again once for each phase-space point, but
then we skip the calculation if [[sqrts]] is fixed.
<<PHS single: phs single: TBP>>=
procedure :: compute_factor => phs_single_compute_factor
<<PHS single: sub interfaces>>=
module subroutine phs_single_compute_factor (phs)
class(phs_single_t), intent(inout) :: phs
end subroutine phs_single_compute_factor
<<PHS single: procedures>>=
module subroutine phs_single_compute_factor (phs)
class(phs_single_t), intent(inout) :: phs
real(default) :: s_hat
select case (phs%config%n_in)
case (1)
if (.not. phs%p_defined) then
if (sum (phs%m_out) < phs%m_in(1)) then
s_hat = phs%m_in(1) ** 2
phs%f(1) = 1 / s_hat &
* sqrt (lambda (s_hat, phs%m_out(1)**2, phs%m_out(2)**2))
else
print *, "m_in = ", phs%m_in
print *, "m_out = ", phs%m_out
call msg_fatal ("Decay is kinematically forbidden")
end if
end if
case (2)
if (phs%config%sqrts_fixed) then
if (phs%p_defined) return
s_hat = phs%config%sqrts ** 2
else
if (.not. phs%p_defined) return
s_hat = sum (phs%p) ** 2
end if
if (sum (phs%m_in)**2 < s_hat .and. sum (phs%m_out)**2 < s_hat) then
phs%f(1) = 1 / s_hat * &
( lambda (s_hat, phs%m_in (1)**2, phs%m_in (2)**2) &
* lambda (s_hat, phs%m_out(1)**2, phs%m_out(2)**2) ) &
** 0.25_default
else
phs%f(1) = 0
end if
end select
end subroutine phs_single_compute_factor
@ %def phs_single_compute_factor
@ Evaluation. We uniformly generate $\cos\theta$ and
$\phi$, with Jacobian normalized to one.
There is only a single channel, so the second subroutine does nothing.
Note: the current implementation works for elastic scattering only.
<<PHS single: phs single: TBP>>=
procedure :: evaluate_selected_channel => phs_single_evaluate_selected_channel
procedure :: evaluate_other_channels => phs_single_evaluate_other_channels
<<PHS single: sub interfaces>>=
module subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in)
class(phs_single_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
end subroutine phs_single_evaluate_selected_channel
module subroutine phs_single_evaluate_other_channels (phs, c_in)
class(phs_single_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_single_evaluate_other_channels
<<PHS single: procedures>>=
module subroutine phs_single_evaluate_selected_channel (phs, c_in, r_in)
class(phs_single_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
if (phs%p_defined) then
call phs%select_channel (c_in)
phs%r(:,c_in) = r_in
select case (phs%config%n_in)
case (2)
if (all (phs%m_in == phs%m_out)) then
call compute_kinematics_solid_angle (phs%p, phs%q, r_in)
else
call msg_bug ("PHS single: inelastic scattering not implemented")
end if
case (1)
call compute_kinematics_solid_angle (phs%decay_p (), phs%q, r_in)
end select
call phs%compute_factor ()
phs%q_defined = .true.
phs%r_defined = .true.
end if
end subroutine phs_single_evaluate_selected_channel
module subroutine phs_single_evaluate_other_channels (phs, c_in)
class(phs_single_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_single_evaluate_other_channels
@ %def phs_single_evaluate_selected_channel
@ %def phs_single_evaluate_other_channels
@ Auxiliary: split a decaying particle at rest into the decay products,
aligned along the $z$ axis.
<<PHS single: phs single: TBP>>=
procedure :: decay_p => phs_single_decay_p
<<PHS single: sub interfaces>>=
module function phs_single_decay_p (phs) result (p)
class(phs_single_t), intent(in) :: phs
type(vector4_t), dimension(2) :: p
end function phs_single_decay_p
<<PHS single: procedures>>=
module function phs_single_decay_p (phs) result (p)
class(phs_single_t), intent(in) :: phs
type(vector4_t), dimension(2) :: p
real(default) :: k
real(default), dimension(2) :: E
k = sqrt (lambda (phs%m_in(1) ** 2, phs%m_out(1) ** 2, phs%m_out(2) ** 2)) &
/ (2 * phs%m_in(1))
E = sqrt (phs%m_out ** 2 + k ** 2)
p(1) = vector4_moving (E(1), k, 3)
p(2) = vector4_moving (E(2),-k, 3)
end function phs_single_decay_p
@ %def phs_single_decay_p
@ Inverse evaluation.
<<PHS single: phs single: TBP>>=
procedure :: inverse => phs_single_inverse
<<PHS single: sub interfaces>>=
module subroutine phs_single_inverse (phs)
class(phs_single_t), intent(inout) :: phs
end subroutine phs_single_inverse
<<PHS single: procedures>>=
module subroutine phs_single_inverse (phs)
class(phs_single_t), intent(inout) :: phs
real(default), dimension(:), allocatable :: x
if (phs%p_defined .and. phs%q_defined) then
call phs%select_channel ()
allocate (x (phs%config%n_par))
call inverse_kinematics_solid_angle (phs%p, phs%q, x)
phs%r(:,1) = x
call phs%compute_factor ()
phs%r_defined = .true.
end if
end subroutine phs_single_inverse
@ %def phs_single_inverse
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[phs_single_ut.f90]]>>=
<<File header>>
module phs_single_ut
use unit_tests
use phs_single_uti
<<Standard module head>>
<<PHS single: public test>>
contains
<<PHS single: test driver>>
end module phs_single_ut
@ %def phs_single_ut
@
<<[[phs_single_uti.f90]]>>=
<<File header>>
module phs_single_uti
<<Use kinds>>
<<Use strings>>
use flavors
use lorentz
use model_data
use process_constants
use phs_base
use phs_single
use phs_base_ut, only: init_test_process_data, init_test_decay_data
<<Standard module head>>
<<PHS single: test declarations>>
contains
<<PHS single: tests>>
end module phs_single_uti
@ %def phs_single_ut
@ API: driver for the unit tests below.
<<PHS single: public test>>=
public :: phs_single_test
<<PHS single: test driver>>=
subroutine phs_single_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS single: execute tests>>
end subroutine phs_single_test
@ %def phs_single_test
@
\subsubsection{Phase-space configuration data}
Construct and display a test phase-space configuration object. Also
check the [[azimuthal_dependence]] flag.
<<PHS single: execute tests>>=
call test (phs_single_1, "phs_single_1", &
"phase-space configuration", &
u, results)
<<PHS single: test declarations>>=
public :: phs_single_1
<<PHS single: tests>>=
subroutine phs_single_1 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
class(phs_config_t), allocatable :: phs_data
real(default) :: sqrts
write (u, "(A)") "* Test output: phs_single_1"
write (u, "(A)") "* Purpose: initialize and display &
&phase-space configuration data"
write (u, "(A)")
call model%init_test ()
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_single_1"), process_data)
allocate (phs_single_config_t :: phs_data)
call phs_data%init (process_data, model)
sqrts = 1000._default
call phs_data%configure (sqrts, azimuthal_dependence=.false.)
call phs_data%write (u)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_single_1"
end subroutine phs_single_1
@ %def phs_single_1
@
\subsubsection{Phase space evaluation}
Compute kinematics for given parameters, also invert the calculation.
<<PHS single: execute tests>>=
call test (phs_single_2, "phs_single_2", &
"phase-space evaluation", &
u, results)
<<PHS single: test declarations>>=
public :: phs_single_2
<<PHS single: tests>>=
subroutine phs_single_2 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(process_constants_t) :: process_data
real(default) :: sqrts, E
class(phs_config_t), allocatable, target :: phs_data
class(phs_t), pointer :: phs => null ()
type(vector4_t), dimension(2) :: p, q
write (u, "(A)") "* Test output: phs_single_2"
write (u, "(A)") "* Purpose: test simple two-channel phase space"
write (u, "(A)")
call model%init_test ()
call flv%init (25, model)
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_single_2"), process_data)
allocate (phs_single_config_t :: phs_data)
call phs_data%init (process_data, model)
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Set incoming momenta"
write (u, "(A)")
E = sqrts / 2
p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point &
&for x = 0.5, 0.125"
write (u, "(A)")
call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
call phs%evaluate_other_channels (1)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call phs%write (u)
call phs%final ()
deallocate (phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_single_2"
end subroutine phs_single_2
@ %def phs_single_2
@
\subsubsection{Phase space for non-c.m. system}
Compute kinematics for given parameters, also invert the calculation.
Since this will involve cancellations, we call [[pacify]] to eliminate
numerical noise.
<<PHS single: execute tests>>=
call test (phs_single_3, "phs_single_3", &
"phase-space evaluation in lab frame", &
u, results)
<<PHS single: test declarations>>=
public :: phs_single_3
<<PHS single: tests>>=
subroutine phs_single_3 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(process_constants_t) :: process_data
real(default) :: sqrts, E
class(phs_config_t), allocatable, target :: phs_data
class(phs_t), pointer :: phs => null ()
type(vector4_t), dimension(2) :: p, q
type(lorentz_transformation_t) :: lt
write (u, "(A)") "* Test output: phs_single_3"
write (u, "(A)") "* Purpose: test simple two-channel phase space"
write (u, "(A)") "* without c.m. kinematics assumption"
write (u, "(A)")
call model%init_test ()
call flv%init (25, model)
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_single_3"), process_data)
allocate (phs_single_config_t :: phs_data)
call phs_data%init (process_data, model)
sqrts = 1000._default
call phs_data%configure (sqrts, lab_is_cm=.false., sqrts_fixed=.false.)
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Set incoming momenta in lab system"
write (u, "(A)")
lt = boost (0.1_default, 1) * boost (0.3_default, 3)
E = sqrts / 2
p(1) = lt * vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
p(2) = lt * vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
call vector4_write (p(1), u)
call vector4_write (p(2), u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point &
&for x = 0.5, 0.125"
write (u, "(A)")
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
call phs%evaluate_other_channels (1)
call pacify (phs)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Extract outgoing momenta in lab system"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
call vector4_write (q(1), u)
call vector4_write (q(2), u)
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call pacify (phs)
call phs%write (u)
call phs%final ()
deallocate (phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_single_3"
end subroutine phs_single_3
@ %def phs_single_3
@
\subsubsection{Decay Phase space evaluation}
Compute kinematics for given parameters, also invert the calculation. This
time, implement a decay process.
<<PHS single: execute tests>>=
call test (phs_single_4, "phs_single_4", &
"decay phase-space evaluation", &
u, results)
<<PHS single: test declarations>>=
public :: phs_single_4
<<PHS single: tests>>=
subroutine phs_single_4 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(process_constants_t) :: process_data
class(phs_config_t), allocatable, target :: phs_data
class(phs_t), pointer :: phs => null ()
type(vector4_t), dimension(1) :: p
type(vector4_t), dimension(2) :: q
write (u, "(A)") "* Test output: phs_single_4"
write (u, "(A)") "* Purpose: test simple two-channel phase space"
write (u, "(A)")
call model%init_test ()
call model%set_par (var_str ("ff"), 0.4_default)
call model%set_par (var_str ("mf"), &
model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
call flv%init (25, model)
write (u, "(A)") "* Initialize a decay and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_decay_data (var_str ("phs_single_4"), process_data)
allocate (phs_single_config_t :: phs_data)
call phs_data%init (process_data, model)
call phs_data%configure (flv%get_mass ())
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Set incoming momenta"
write (u, "(A)")
p(1) = vector4_at_rest (flv%get_mass ())
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point &
&for x = 0.5, 0.125"
write (u, "(A)")
call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
call phs%evaluate_other_channels (1)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs_data%configure (flv%get_mass ())
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call phs%write (u)
call phs%final ()
deallocate (phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_single_4"
end subroutine phs_single_4
@ %def phs_single_4
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Flat RAMBO phase space}
This module implements the flat \texttt{RAMBO} phase space for
massless and massive particles using the minimal d.o.f $3n - 4$ in a
straightforward parameterization with a single channel.
We generate $n$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_{n} =
0$. We let each mass system decay $1 \rightarrow 2$ in a four-momentum
conserving way. The four-momenta of the two particles are generated
back-to-back where we map the d.o.f. to energy, azimuthal and polar
angle. The particle momenta are then boosted to CMS by an appriopriate
boost using the kinematics of the parent mass system.
<<[[phs_rambo.f90]]>>=
<<File header>>
module phs_rambo
<<Use kinds>>
<<Use strings>>
use lorentz
use phs_base
<<Standard module head>>
<<PHS rambo: types>>
<<PHS rambo: public>>
interface
<<PHS rambo: sub interfaces>>
end interface
contains
<<PHS rambo: main procedures>>
end module phs_rambo
@ %def phs_rambo
@
<<[[phs_rambo_sub.f90]]>>=
<<File header>>
submodule (phs_rambo) phs_rambo_s
use io_units
use constants
use numeric_utils
use format_defs, only: FMT_19
use permutations, only: factorial
use diagnostics
use physics_defs
implicit none
<<PHS rambo: parameters>>
contains
<<PHS rambo: procedures>>
end submodule phs_rambo_s
@ %def phs_rambo_s
@
\subsection{Configuration}
<<PHS rambo: public>>=
public :: phs_rambo_config_t
<<PHS rambo: types>>=
type, extends (phs_config_t) :: phs_rambo_config_t
contains
<<PHS rambo: phs rambo config: TBP>>
end type phs_rambo_config_t
@ %def phs_rambo_config_t
@ The finalizer is empty.
<<PHS rambo: phs rambo config: TBP>>=
procedure :: final => phs_rambo_config_final
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_config_final (object)
class(phs_rambo_config_t), intent(inout) :: object
end subroutine phs_rambo_config_final
<<PHS rambo: procedures>>=
module subroutine phs_rambo_config_final (object)
class(phs_rambo_config_t), intent(inout) :: object
end subroutine phs_rambo_config_final
@ %def phs_rambo_final
@ Output.
<<PHS rambo: phs rambo config: TBP>>=
procedure :: write => phs_rambo_config_write
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_config_write (object, unit, include_id)
class(phs_rambo_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
end subroutine phs_rambo_config_write
<<PHS rambo: procedures>>=
module subroutine phs_rambo_config_write (object, unit, include_id)
class(phs_rambo_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Partonic, flat phase-space configuration (RAMBO):"
call object%base_write (unit)
end subroutine phs_rambo_config_write
@ %def phs_rambo_config_write
@ Configuration: there is only one channel and $3n - 4$ parameters.
<<PHS rambo: phs rambo config: TBP>>=
procedure :: configure => phs_rambo_config_configure
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_rambo_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
end subroutine phs_rambo_config_configure
<<PHS rambo: procedures>>=
module subroutine phs_rambo_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_rambo_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
if (.not. present (nlo_type)) &
phs_config%nlo_type = BORN
if (phs_config%n_out < 2) then
call msg_fatal ("RAMBO phase space requires n_out >= 2")
end if
phs_config%n_channel = 1
phs_config%n_par = 3 * phs_config%n_out - 4
phs_config%sqrts = sqrts
if (present (sqrts_fixed)) phs_config%sqrts_fixed = sqrts_fixed
if (present (lab_is_cm)) phs_config%lab_is_cm = lab_is_cm
if (allocated (phs_config%channel)) deallocate (phs_config%channel)
allocate (phs_config%channel (1))
call phs_config%compute_md5sum ()
end subroutine phs_rambo_config_configure
@ %def phs_rambo_config_configure
@ Startup message, after configuration is complete.
<<PHS rambo: phs rambo config: TBP>>=
procedure :: startup_message => phs_rambo_config_startup_message
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_config_startup_message (phs_config, unit)
class(phs_rambo_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
end subroutine phs_rambo_config_startup_message
<<PHS rambo: procedures>>=
module subroutine phs_rambo_config_startup_message (phs_config, unit)
class(phs_rambo_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
call phs_config%base_startup_message (unit)
write (msg_buffer, "(A,2(1x,I0,1x,A))") &
"Phase space: flat (RAMBO)"
call msg_message (unit = unit)
end subroutine phs_rambo_config_startup_message
@ %def phs_rambo_config_startup_message
@ Allocate an instance: the actual phase-space object.
Gfortran 7/8/9 bug, has to remain in the main module.
<<PHS rambo: phs rambo config: TBP>>=
procedure, nopass :: allocate_instance => phs_rambo_config_allocate_instance
<<PHS rambo: main procedures>>=
subroutine phs_rambo_config_allocate_instance (phs)
class(phs_t), intent(inout), pointer :: phs
allocate (phs_rambo_t :: phs)
end subroutine phs_rambo_config_allocate_instance
@ %def phs_rambo_config_allocate_instance
@
\subsection{Kinematics implementation}
We generate $n - 2$ mass systems $M_i$ with $M_0 = \sqrt{s}$ and $M_n = 0$...
Note: The incoming momenta must be in the c.m. system.
<<PHS rambo: public>>=
public :: phs_rambo_t
<<PHS rambo: types>>=
type, extends (phs_t) :: phs_rambo_t
real(default), dimension(:), allocatable :: k
real(default), dimension(:), allocatable :: m
contains
<<PHS rambo: phs rambo: TBP>>
end type phs_rambo_t
@ %def phs_rambo_t
@ Output.
<<PHS rambo: phs rambo: TBP>>=
procedure :: write => phs_rambo_write
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_write (object, unit, verbose)
class(phs_rambo_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine phs_rambo_write
<<PHS rambo: procedures>>=
module subroutine phs_rambo_write (object, unit, verbose)
class(phs_rambo_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u
u = given_output_unit (unit)
call object%base_write (u)
write (u, "(1X,A)") "Intermediate masses (massless):"
write (u, "(3X,999(" // FMT_19 // "))") object%k
write (u, "(1X,A)") "Intermediate masses (massive):"
write (u, "(3X,999(" // FMT_19 // "))") object%m
end subroutine phs_rambo_write
@ %def phs_rambo_write
@ The finalizer is empty.
<<PHS rambo: phs rambo: TBP>>=
procedure :: final => phs_rambo_final
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_final (object)
class(phs_rambo_t), intent(inout) :: object
end subroutine phs_rambo_final
<<PHS rambo: procedures>>=
module subroutine phs_rambo_final (object)
class(phs_rambo_t), intent(inout) :: object
end subroutine phs_rambo_final
@ %def phs_rambo_final
@ Initialization. We allocate arrays ([[base_init]]) and adjust the
phase-space volume.
The energy dependent factor of $s^{n - 2}$ is applied later.
<<PHS rambo: phs rambo: TBP>>=
procedure :: init => phs_rambo_init
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_init (phs, phs_config)
class(phs_rambo_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
end subroutine phs_rambo_init
<<PHS rambo: procedures>>=
module subroutine phs_rambo_init (phs, phs_config)
class(phs_rambo_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
call phs%base_init (phs_config)
associate (n => phs%config%n_out)
select case (n)
case (1)
if (sum (phs%m_out) > phs%m_in (1)) then
print *, "m_in = ", phs%m_in
print *, "m_out = ", phs%m_out
call msg_fatal &
("[phs_rambo_init] Decay is kinematically forbidden.")
end if
end select
allocate (phs%k(n), source = 0._default)
allocate (phs%m(n), source = 0._default)
phs%volume = 1. / (twopi)**(3 * n) &
* (pi / 2.)**(n - 1) / (factorial(n - 1) * factorial(n - 2))
end associate
end subroutine phs_rambo_init
@ %def phs_rambo_init
@ Evaluation. There is only one channel for RAMBO, so the second subroutine does nothing.
Note: the current implementation works for elastic scattering only.
<<PHS rambo: phs rambo: TBP>>=
procedure :: evaluate_selected_channel => phs_rambo_evaluate_selected_channel
procedure :: evaluate_other_channels => phs_rambo_evaluate_other_channels
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in)
class(phs_rambo_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
end subroutine phs_rambo_evaluate_selected_channel
module subroutine phs_rambo_evaluate_other_channels (phs, c_in)
class(phs_rambo_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_rambo_evaluate_other_channels
<<PHS rambo: procedures>>=
module subroutine phs_rambo_evaluate_selected_channel (phs, c_in, r_in)
class(phs_rambo_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
type(vector4_t), dimension(2) :: p_rest, p_boosted
type(vector4_t) :: q
real(default), dimension(2) :: r_angle
integer :: i
if (.not. phs%p_defined) return
call phs%select_channel (c_in)
phs%r(:,c_in) = r_in
associate (n => phs%config%n_out, m => phs%m)
call phs%generate_intermediates (r_in(:n - 2))
q = sum (phs%p)
do i = 2, n
r_angle(1) = r_in(n - 5 + 2 * i)
r_angle(2) = r_in(n - 4 + 2 * i)
call phs%decay_intermediate (i, r_angle, p_rest)
p_boosted = boost(q, m(i - 1)) * p_rest
q = p_boosted(1)
phs%q(i - 1) = p_boosted(2)
end do
phs%q(n) = q
end associate
phs%q_defined = .true.
phs%r_defined = .true.
end subroutine phs_rambo_evaluate_selected_channel
module subroutine phs_rambo_evaluate_other_channels (phs, c_in)
class(phs_rambo_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_rambo_evaluate_other_channels
@ %def phs_rambo_evaluate_selected_channel
@ %def phs_rambo_evaluate_other_channels
@ Decay intermediate mass system $M_{i - 1}$ into a on-shell particle with mass
$m_{i - 1}$ and subsequent intermediate mass system with fixed $M_i$.
<<PHS rambo: phs rambo: TBP>>=
procedure, private :: decay_intermediate => phs_rambo_decay_intermediate
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p)
class(phs_rambo_t), intent(in) :: phs
integer, intent(in) :: i
real(default), dimension(2), intent(in) :: r_angle
type(vector4_t), dimension(2), intent(out) :: p
end subroutine phs_rambo_decay_intermediate
<<PHS rambo: procedures>>=
module subroutine phs_rambo_decay_intermediate (phs, i, r_angle, p)
class(phs_rambo_t), intent(in) :: phs
integer, intent(in) :: i
real(default), dimension(2), intent(in) :: r_angle
type(vector4_t), dimension(2), intent(out) :: p
real(default) :: k_abs, cos_theta, phi
type(vector3_t):: k
real(default), dimension(2) :: E
cos_theta = 2. * r_angle(1) - 1.
phi = twopi * r_angle(2)
if (phi > pi) phi = phi - twopi
k_abs = sqrt (lambda (phs%m(i - 1)**2, phs%m(i)**2, phs%m_out(i - 1)**2)) &
/ (2. * phs%m(i - 1))
k = k_abs * [cos(phi) * sqrt(1. - cos_theta**2), &
sin(phi) * sqrt(1. - cos_theta**2), cos_theta]
E(1) = sqrt (phs%m(i)**2 + k_abs**2)
E(2) = sqrt (phs%m_out(i - 1)**2 + k_abs**2)
p(1) = vector4_moving (E(1), -k)
p(2) = vector4_moving (E(2), k)
end subroutine phs_rambo_decay_intermediate
@ %def phs_rambo_decay_intermediate
@ Generate intermediate masses.
<<PHS rambo: parameters>>=
integer, parameter :: BISECT_MAX_ITERATIONS = 1000
real(default), parameter :: BISECT_MIN_PRECISION = tiny_10
<<PHS rambo: phs rambo: TBP>>=
procedure, private :: generate_intermediates => &
phs_rambo_generate_intermediates
procedure, private :: invert_intermediates => phs_rambo_invert_intermediates
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_generate_intermediates (phs, r)
class(phs_rambo_t), intent(inout) :: phs
real(default), dimension(:), intent(in) :: r
end subroutine phs_rambo_generate_intermediates
module subroutine phs_rambo_invert_intermediates (phs)
class(phs_rambo_t), intent(inout) :: phs
end subroutine phs_rambo_invert_intermediates
<<PHS rambo: procedures>>=
module subroutine phs_rambo_generate_intermediates (phs, r)
class(phs_rambo_t), intent(inout) :: phs
real(default), dimension(:), intent(in) :: r
integer :: i, j
associate (n => phs%config%n_out, k => phs%k, m => phs%m)
m(1) = invariant_mass (sum (phs%p))
m(n) = phs%m_out (n)
call calculate_k (r)
do i = 2, n - 1
m(i) = k(i) + sum (phs%m_out (i:n))
end do
! Massless volume times reweighting for massive volume
phs%f(1) = k(1)**(2 * n - 4) &
* 8. * rho(m(n - 1), phs%m_out(n), phs%m_out(n - 1))
do i = 2, n - 1
phs%f(1) = phs%f(1) * &
rho(m(i - 1), m(i), phs%m_out(i - 1)) / &
rho(k(i - 1), k(i), 0._default) * &
M(i) / K(i)
end do
end associate
contains
subroutine calculate_k (r)
real(default), dimension(:), intent(in) :: r
real(default), dimension(:), allocatable :: u
integer :: i
associate (n => phs%config%n_out, k => phs%k, m => phs%m)
k = 0
k(1) = m(1) - sum(phs%m_out(1:n))
allocate (u(2:n - 1), source=0._default)
call solve_for_u (r, u)
do i = 2, n - 1
k(i) = sqrt (u(i) * k(i - 1)**2)
end do
end associate
end subroutine calculate_k
subroutine solve_for_u (r, u)
real(default), dimension(phs%config%n_out - 2), intent(in) :: r
real(default), dimension(2:phs%config%n_out - 1), intent(out) :: u
integer :: i, j
real(default) :: f, f_mid, xl, xr, xmid
associate (n => phs%config%n_out)
do i = 2, n - 1
xl = 0
xr = 1
if (r(i - 1) == 1 .or. r(i - 1) == 0) then
u(i) = r(i - 1)
else
do j = 1, BISECT_MAX_ITERATIONS
xmid = (xl + xr) / 2.
f = f_rambo (xl, n - i) - r(i - 1)
f_mid = f_rambo (xmid, n - i) - r(i - 1)
if (f * f_mid > 0) then
xl = xmid
else
xr = xmid
end if
if (abs(xl - xr) < BISECT_MIN_PRECISION) exit
end do
u(i) = xmid
end if
end do
end associate
end subroutine solve_for_u
real(default) function f_rambo(u, n)
real(default), intent(in) :: u
integer, intent(in) :: n
f_rambo = (n + 1) * u**n - n * u**(n + 1)
end function f_rambo
real(default) function rho (M1, M2, m)
real(default), intent(in) :: M1, M2, m
real(default) :: MP, MM
rho = sqrt ((M1**2 - (M2 + m)**2) * (M1**2 - (M2 - m)**2))
! MP = (M1 - (M2 + m)) * (M1 + (M2 + m))
! MM = (M1 - (M2 - m)) * (M1 + (M2 - m))
! rho = sqrt (MP) * sqrt (MM)
rho = rho / (8._default * M1**2)
end function rho
end subroutine phs_rambo_generate_intermediates
module subroutine phs_rambo_invert_intermediates (phs)
class(phs_rambo_t), intent(inout) :: phs
real(default) :: u
integer :: i
associate (n => phs%config%n_out, k => phs%k, m => phs%m)
k = m
do i = 1, n - 1
k(i) = k(i) - sum (phs%m_out(i:n))
end do
do i = 2, n - 1
u = (k(i) / k(i - 1))**2
phs%r(i - 1, 1) = (n + 1 - i) * u**(n - i) &
- (n - i) * u**(n + 1 - i)
end do
end associate
end subroutine phs_rambo_invert_intermediates
@ %def phs_rambo_generate_intermediates
@ Inverse evaluation.
<<PHS rambo: phs rambo: TBP>>=
procedure :: inverse => phs_rambo_inverse
<<PHS rambo: sub interfaces>>=
module subroutine phs_rambo_inverse (phs)
class(phs_rambo_t), intent(inout) :: phs
end subroutine phs_rambo_inverse
<<PHS rambo: procedures>>=
module subroutine phs_rambo_inverse (phs)
class(phs_rambo_t), intent(inout) :: phs
type(vector4_t), dimension(:), allocatable :: q
type(vector4_t) :: p
type(lorentz_transformation_t) :: L
real(default) :: phi, cos_theta
integer :: i
if (.not. (phs%p_defined .and. phs%q_defined)) return
call phs%select_channel ()
associate (n => phs%config%n_out, m => phs%m)
allocate(q(n))
m(1) = invariant_mass (sum (phs%p))
q(1) = vector4_at_rest (m(1))
q(n) = phs%q(n)
do i = 2, n - 1
q(i) = q(i) + sum (phs%q(i:n))
m(i) = invariant_mass (q(i))
end do
call phs%invert_intermediates ()
do i = 2, n
L = inverse (boost (q(i - 1), m(i - 1)))
p = L * phs%q(i - 1)
phi = azimuthal_angle (p); cos_theta = polar_angle_ct (p)
phs%r(n - 5 + 2 * i, 1) = (cos_theta + 1.) / 2.
phs%r(n - 4 + 2 * i, 1) = phi / twopi
end do
end associate
phs%r_defined = .true.
end subroutine phs_rambo_inverse
@ %def phs_rambo_inverse
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[phs_rambo_ut.f90]]>>=
<<File header>>
module phs_rambo_ut
use unit_tests
use phs_rambo_uti
<<Standard module head>>
<<PHS rambo: public test>>
contains
<<PHS rambo: test driver>>
end module phs_rambo_ut
@ %def phs_rambo_ut
@
<<[[phs_rambo_uti.f90]]>>=
<<File header>>
module phs_rambo_uti
<<Use kinds>>
<<Use strings>>
use flavors
use lorentz
use model_data
use process_constants
use phs_base
use phs_rambo
use phs_base_ut, only: init_test_process_data, init_test_decay_data
<<Standard module head>>
<<PHS rambo: test declarations>>
contains
<<PHS rambo: tests>>
end module phs_rambo_uti
@ %def phs_rambo_ut
@ API: driver for the unit tests below.
<<PHS rambo: public test>>=
public :: phs_rambo_test
<<PHS rambo: test driver>>=
subroutine phs_rambo_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS rambo: execute tests>>
end subroutine phs_rambo_test
@ %def phs_rambo_test
@
\subsubsection{Phase-space configuration data}
Construct and display a test phase-space configuration object. Also
check the [[azimuthal_dependence]] flag.
<<PHS rambo: execute tests>>=
call test (phs_rambo_1, "phs_rambo_1", &
"phase-space configuration", &
u, results)
<<PHS rambo: test declarations>>=
public :: phs_rambo_1
<<PHS rambo: tests>>=
subroutine phs_rambo_1 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
class(phs_config_t), allocatable :: phs_data
real(default) :: sqrts
write (u, "(A)") "* Test output: phs_rambo_1"
write (u, "(A)") "* Purpose: initialize and display &
&phase-space configuration data"
write (u, "(A)")
call model%init_test ()
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_rambo_1"), process_data)
allocate (phs_rambo_config_t :: phs_data)
call phs_data%init (process_data, model)
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs_data%write (u)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_rambo_1"
end subroutine phs_rambo_1
@ %def phs_rambo_1
@
\subsubsection{Phase space evaluation}
Compute kinematics for given parameters, also invert the calculation.
<<PHS rambo: execute tests>>=
call test (phs_rambo_2, "phs_rambo_2", &
"phase-space evaluation", &
u, results)
<<PHS rambo: test declarations>>=
public :: phs_rambo_2
<<PHS rambo: tests>>=
subroutine phs_rambo_2 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(process_constants_t) :: process_data
real(default) :: sqrts, E
class(phs_config_t), allocatable, target :: phs_data
class(phs_t), pointer :: phs => null ()
type(vector4_t), dimension(2) :: p, q
write (u, "(A)") "* Test output: phs_rambo_2"
write (u, "(A)") "* Purpose: test simple two-channel phase space"
write (u, "(A)")
call model%init_test ()
call flv%init (25, model)
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_rambo_2"), process_data)
allocate (phs_rambo_config_t :: phs_data)
call phs_data%init (process_data, model)
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Set incoming momenta"
write (u, "(A)")
E = sqrts / 2
p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point &
&for x = 0.5, 0.125"
write (u, "(A)")
call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
call phs%evaluate_other_channels (1)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call phs%write (u)
call phs%final ()
deallocate (phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_rambo_2"
end subroutine phs_rambo_2
@ %def phs_rambo_2
@
\subsubsection{Phase space for non-c.m. system}
Compute kinematics for given parameters, also invert the calculation.
Since this will involve cancellations, we call [[pacify]] to eliminate
numerical noise.
<<PHS rambo: execute tests>>=
call test (phs_rambo_3, "phs_rambo_3", &
"phase-space evaluation in lab frame", &
u, results)
<<PHS rambo: test declarations>>=
public :: phs_rambo_3
<<PHS rambo: tests>>=
subroutine phs_rambo_3 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(process_constants_t) :: process_data
real(default) :: sqrts, E
class(phs_config_t), allocatable, target :: phs_data
class(phs_t), pointer :: phs => null ()
type(vector4_t), dimension(2) :: p, q
type(lorentz_transformation_t) :: lt
write (u, "(A)") "* Test output: phs_rambo_3"
write (u, "(A)") "* Purpose: phase-space evaluation in lab frame"
write (u, "(A)")
call model%init_test ()
call flv%init (25, model)
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_rambo_3"), process_data)
allocate (phs_rambo_config_t :: phs_data)
call phs_data%init (process_data, model)
sqrts = 1000._default
call phs_data%configure (sqrts, lab_is_cm=.false., sqrts_fixed=.false.)
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Set incoming momenta in lab system"
write (u, "(A)")
lt = boost (0.1_default, 1) * boost (0.3_default, 3)
E = sqrts / 2
p(1) = lt * vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
p(2) = lt * vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
call vector4_write (p(1), u)
call vector4_write (p(2), u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point &
&for x = 0.5, 0.125"
write (u, "(A)")
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
call phs%evaluate_other_channels (1)
call pacify (phs)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Extract outgoing momenta in lab system"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
call vector4_write (q(1), u)
call vector4_write (q(2), u)
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call pacify (phs)
call phs%write (u)
call phs%final ()
deallocate (phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_rambo_3"
end subroutine phs_rambo_3
@ %def phs_rambo_3
@
\subsubsection{Decay Phase space evaluation}
Compute kinematics for given parameters, also invert the calculation. This
time, implement a decay process.
<<PHS rambo: execute tests>>=
call test (phs_rambo_4, "phs_rambo_4", &
"decay phase-space evaluation", &
u, results)
<<PHS rambo: test declarations>>=
public :: phs_rambo_4
<<PHS rambo: tests>>=
subroutine phs_rambo_4 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(process_constants_t) :: process_data
class(phs_config_t), allocatable, target :: phs_data
class(phs_t), pointer :: phs => null ()
type(vector4_t), dimension(1) :: p
type(vector4_t), dimension(2) :: q
write (u, "(A)") "* Test output: phs_rambo_4"
write (u, "(A)") "* Purpose: test simple two-channel phase space"
write (u, "(A)")
call model%init_test ()
call model%set_par (var_str ("ff"), 0.4_default)
call model%set_par (var_str ("mf"), &
model%get_real (var_str ("ff")) * model%get_real (var_str ("ms")))
call flv%init (25, model)
write (u, "(A)") "* Initialize a decay and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_decay_data (var_str ("phs_rambo_4"), process_data)
allocate (phs_rambo_config_t :: phs_data)
call phs_data%init (process_data, model)
call phs_data%configure (flv%get_mass ())
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Set incoming momenta"
write (u, "(A)")
p(1) = vector4_at_rest (flv%get_mass ())
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point &
&for x = 0.5, 0.125"
write (u, "(A)")
call phs%evaluate_selected_channel (1, [0.5_default, 0.125_default])
call phs%evaluate_other_channels (1)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs_data%configure (flv%get_mass ())
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call phs%write (u)
call phs%final ()
deallocate (phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_rambo_4"
end subroutine phs_rambo_4
@ %def phs_rambo_4
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Resonance Handler}
For various purposes (e.g., shower histories), we should extract the set of
resonances and resonant channels from a phase-space tree set. A few methods
do kinematics calculations specifically for those resonance data.
<<[[resonances.f90]]>>=
<<File header>>
module resonances
<<Use kinds>>
<<Use strings>>
use lorentz
use model_data, only: model_data_t
use flavors, only: flavor_t
<<Standard module head>>
<<Resonances: public>>
<<Resonances: parameters>>
<<Resonances: types>>
interface
<<Resonances: sub interfaces>>
end interface
end module resonances
@ %def resonances
@
<<[[resonances_sub.f90]]>>=
<<File header>>
submodule (resonances) resonances_s
<<Use debug>>
use string_utils, only: str
use format_utils, only: write_indent
use constants, only: one
use io_units
use diagnostics
implicit none
contains
<<Resonances: procedures>>
end submodule resonances_s
@ %def resonances_s
@
\subsection{Decay products (contributors)}
This stores the indices of the particles that contribute to a resonance, i.e.,
the decay products.
<<Resonances: public>>=
public :: resonance_contributors_t
<<Resonances: types>>=
type :: resonance_contributors_t
integer, dimension(:), allocatable :: c
contains
<<Resonances: resonance contributors: TBP>>
end type resonance_contributors_t
@ %def resonance_contributors_t
@ Equality (comparison)
<<Resonances: resonance contributors: TBP>>=
procedure, private :: resonance_contributors_equal
generic :: operator(==) => resonance_contributors_equal
<<Resonances: sub interfaces>>=
elemental module function resonance_contributors_equal &
(c1, c2) result (equal)
logical :: equal
class(resonance_contributors_t), intent(in) :: c1, c2
end function resonance_contributors_equal
<<Resonances: procedures>>=
elemental module function resonance_contributors_equal &
(c1, c2) result (equal)
logical :: equal
class(resonance_contributors_t), intent(in) :: c1, c2
equal = allocated (c1%c) .and. allocated (c2%c)
if (equal) equal = size (c1%c) == size (c2%c)
if (equal) equal = all (c1%c == c2%c)
end function resonance_contributors_equal
@ %def resonance_contributors_equal
@ Assignment
<<Resonances: resonance contributors: TBP>>=
procedure, private :: resonance_contributors_assign
generic :: assignment(=) => resonance_contributors_assign
<<Resonances: sub interfaces>>=
pure module subroutine resonance_contributors_assign &
(contributors_out, contributors_in)
class(resonance_contributors_t), intent(inout) :: contributors_out
class(resonance_contributors_t), intent(in) :: contributors_in
end subroutine resonance_contributors_assign
<<Resonances: procedures>>=
pure module subroutine resonance_contributors_assign &
(contributors_out, contributors_in)
class(resonance_contributors_t), intent(inout) :: contributors_out
class(resonance_contributors_t), intent(in) :: contributors_in
if (allocated (contributors_out%c)) deallocate (contributors_out%c)
if (allocated (contributors_in%c)) then
allocate (contributors_out%c (size (contributors_in%c)))
contributors_out%c = contributors_in%c
end if
end subroutine resonance_contributors_assign
@ %def resonance_contributors_assign
@
\subsection{Resonance info object}
This data structure augments the set of resonance contributors by a flavor
object, such that we can perform calculations that take into
account the particle properties, including mass and width.
Avoiding nameclash with similar but different [[resonance_t]] of
[[phs_base]]:
<<Resonances: public>>=
public :: resonance_info_t
<<Resonances: types>>=
type :: resonance_info_t
type(flavor_t) :: flavor
type(resonance_contributors_t) :: contributors
contains
<<Resonances: resonance info: TBP>>
end type resonance_info_t
@ %def resonance_info_t
@
<<Resonances: resonance info: TBP>>=
procedure :: copy => resonance_info_copy
<<Resonances: sub interfaces>>=
module subroutine resonance_info_copy (resonance_in, resonance_out)
class(resonance_info_t), intent(in) :: resonance_in
type(resonance_info_t), intent(out) :: resonance_out
end subroutine resonance_info_copy
<<Resonances: procedures>>=
module subroutine resonance_info_copy (resonance_in, resonance_out)
class(resonance_info_t), intent(in) :: resonance_in
type(resonance_info_t), intent(out) :: resonance_out
resonance_out%flavor = resonance_in%flavor
if (allocated (resonance_in%contributors%c)) then
associate (c => resonance_in%contributors%c)
allocate (resonance_out%contributors%c (size (c)))
resonance_out%contributors%c = c
end associate
end if
end subroutine resonance_info_copy
@ %def resonance_info_copy
@
<<Resonances: resonance info: TBP>>=
procedure :: write => resonance_info_write
<<Resonances: sub interfaces>>=
module subroutine resonance_info_write (resonance, unit, verbose)
class(resonance_info_t), intent(in) :: resonance
integer, optional, intent(in) :: unit
logical, optional, intent(in) :: verbose
end subroutine resonance_info_write
<<Resonances: procedures>>=
module subroutine resonance_info_write (resonance, unit, verbose)
class(resonance_info_t), intent(in) :: resonance
integer, optional, intent(in) :: unit
logical, optional, intent(in) :: verbose
integer :: u, i
logical :: verb
u = given_output_unit (unit); if (u < 0) return
verb = .true.; if (present (verbose)) verb = verbose
if (verb) then
write (u, '(A)', advance='no') "Resonance contributors: "
else
write (u, '(1x)', advance="no")
end if
if (allocated (resonance%contributors%c)) then
do i = 1, size(resonance%contributors%c)
write (u, '(I0,1X)', advance='no') resonance%contributors%c(i)
end do
else if (verb) then
write (u, "(A)", advance="no") "[not allocated]"
end if
if (resonance%flavor%is_defined ()) call resonance%flavor%write (u)
write (u, '(A)')
end subroutine resonance_info_write
@ %def resonance_info_write
@ Create a resonance-info object. The particle info may be available
in term of a flavor object or as a PDG code; in the latter case we
have to require a model data object that provides mass and width information.
<<Resonances: resonance info: TBP>>=
procedure, private :: resonance_info_init_pdg
procedure, private :: resonance_info_init_flv
generic :: init => resonance_info_init_pdg, resonance_info_init_flv
<<Resonances: sub interfaces>>=
module subroutine resonance_info_init_pdg &
(resonance, mom_id, pdg, model, n_out)
class(resonance_info_t), intent(out) :: resonance
integer, intent(in) :: mom_id
integer, intent(in) :: pdg, n_out
class(model_data_t), intent(in), target :: model
end subroutine resonance_info_init_pdg
module subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out)
class(resonance_info_t), intent(out) :: resonance
integer, intent(in) :: mom_id
type(flavor_t), intent(in) :: flv
integer, intent(in) :: n_out
end subroutine resonance_info_init_flv
<<Resonances: procedures>>=
module subroutine resonance_info_init_pdg &
(resonance, mom_id, pdg, model, n_out)
class(resonance_info_t), intent(out) :: resonance
integer, intent(in) :: mom_id
integer, intent(in) :: pdg, n_out
class(model_data_t), intent(in), target :: model
type(flavor_t) :: flv
if (debug_on) call msg_debug (D_PHASESPACE, "resonance_info_init_pdg")
call flv%init (pdg, model)
call resonance%init (mom_id, flv, n_out)
end subroutine resonance_info_init_pdg
module subroutine resonance_info_init_flv (resonance, mom_id, flv, n_out)
class(resonance_info_t), intent(out) :: resonance
integer, intent(in) :: mom_id
type(flavor_t), intent(in) :: flv
integer, intent(in) :: n_out
integer :: i
logical, dimension(n_out) :: contrib
integer, dimension(n_out) :: tmp
if (debug_on) call msg_debug (D_PHASESPACE, "resonance_info_init_flv")
resonance%flavor = flv
do i = 1, n_out
tmp(i) = i
end do
contrib = btest (mom_id, tmp - 1)
allocate (resonance%contributors%c (count (contrib)))
resonance%contributors%c = pack (tmp, contrib)
end subroutine resonance_info_init_flv
@ %def resonance_info_init
@
<<Resonances: resonance info: TBP>>=
procedure, private :: resonance_info_equal
generic :: operator(==) => resonance_info_equal
<<Resonances: sub interfaces>>=
elemental module function resonance_info_equal (r1, r2) result (equal)
logical :: equal
class(resonance_info_t), intent(in) :: r1, r2
end function resonance_info_equal
<<Resonances: procedures>>=
elemental module function resonance_info_equal (r1, r2) result (equal)
logical :: equal
class(resonance_info_t), intent(in) :: r1, r2
equal = r1%flavor == r2%flavor .and. r1%contributors == r2%contributors
end function resonance_info_equal
@ %def resonance_info_equal
@ With each resonance region we associate a Breit-Wigner function
\begin{equation*}
P = \frac{M_{res}^4}{(s - M_{res}^2)^2 + \Gamma_{res}^2 M_{res}^2},
\end{equation*}
where $s$ denotes the invariant mass of the outgoing momenta originating
from this resonance. Note that the $M_{res}^4$ in the nominator makes
the mapping a dimensionless quantity.
<<Resonances: resonance info: TBP>>=
procedure :: mapping => resonance_info_mapping
<<Resonances: sub interfaces>>=
module function resonance_info_mapping (resonance, s) result (bw)
real(default) :: bw
class(resonance_info_t), intent(in) :: resonance
real(default), intent(in) :: s
end function resonance_info_mapping
<<Resonances: procedures>>=
module function resonance_info_mapping (resonance, s) result (bw)
real(default) :: bw
class(resonance_info_t), intent(in) :: resonance
real(default), intent(in) :: s
real(default) :: m, gamma
if (resonance%flavor%is_defined ()) then
m = resonance%flavor%get_mass ()
gamma = resonance%flavor%get_width ()
bw = m**4 / ((s - m**2)**2 + gamma**2 * m**2)
else
bw = one
end if
end function resonance_info_mapping
@ %def resonance_info_mapping
@ Used for building a resonance tree below.
<<Resonances: resonance info: TBP>>=
procedure, private :: get_n_contributors => resonance_info_get_n_contributors
procedure, private :: contains => resonance_info_contains
<<Resonances: sub interfaces>>=
elemental module function resonance_info_get_n_contributors &
(resonance) result (n)
class(resonance_info_t), intent(in) :: resonance
integer :: n
end function resonance_info_get_n_contributors
elemental module function resonance_info_contains &
(resonance, c) result (flag)
class(resonance_info_t), intent(in) :: resonance
integer, intent(in) :: c
logical :: flag
end function resonance_info_contains
<<Resonances: procedures>>=
elemental module function resonance_info_get_n_contributors &
(resonance) result (n)
class(resonance_info_t), intent(in) :: resonance
integer :: n
if (allocated (resonance%contributors%c)) then
n = size (resonance%contributors%c)
else
n = 0
end if
end function resonance_info_get_n_contributors
elemental module function resonance_info_contains &
(resonance, c) result (flag)
class(resonance_info_t), intent(in) :: resonance
integer, intent(in) :: c
logical :: flag
if (allocated (resonance%contributors%c)) then
flag = any (resonance%contributors%c == c)
else
flag = .false.
end if
end function resonance_info_contains
@ %def resonance_info_get_n_contributors
@ %def resonance_info_contains
@
\subsection{Resonance history object}
This data structure stores a set of resonances, i.e., the resonances that
appear in a particular Feynman graph or, in the context of phase space, phase
space diagram.
<<Resonances: public>>=
public :: resonance_history_t
<<Resonances: types>>=
type :: resonance_history_t
type(resonance_info_t), dimension(:), allocatable :: resonances
integer :: n_resonances = 0
contains
<<Resonances: resonance history: TBP>>
end type resonance_history_t
@ %def resonance_history_t
@ Clear the resonance history. Assuming that there are no
pointer-allocated parts, a straightforward [[intent(out)]] will do.
<<Resonances: resonance history: TBP>>=
procedure :: clear => resonance_history_clear
<<Resonances: sub interfaces>>=
module subroutine resonance_history_clear (res_hist)
class(resonance_history_t), intent(out) :: res_hist
end subroutine resonance_history_clear
<<Resonances: procedures>>=
module subroutine resonance_history_clear (res_hist)
class(resonance_history_t), intent(out) :: res_hist
end subroutine resonance_history_clear
@ %def resonance_history_clear
@
<<Resonances: resonance history: TBP>>=
procedure :: copy => resonance_history_copy
<<Resonances: sub interfaces>>=
module subroutine resonance_history_copy (res_hist_in, res_hist_out)
class(resonance_history_t), intent(in) :: res_hist_in
type(resonance_history_t), intent(out) :: res_hist_out
end subroutine resonance_history_copy
<<Resonances: procedures>>=
module subroutine resonance_history_copy (res_hist_in, res_hist_out)
class(resonance_history_t), intent(in) :: res_hist_in
type(resonance_history_t), intent(out) :: res_hist_out
integer :: i
res_hist_out%n_resonances = res_hist_in%n_resonances
allocate (res_hist_out%resonances (size (res_hist_in%resonances)))
do i = 1, size (res_hist_in%resonances)
call res_hist_in%resonances(i)%copy (res_hist_out%resonances(i))
end do
end subroutine resonance_history_copy
@ %def resonance_history_copy
@
<<Resonances: resonance history: TBP>>=
procedure :: write => resonance_history_write
<<Resonances: sub interfaces>>=
module subroutine resonance_history_write (res_hist, unit, verbose, indent)
class(resonance_history_t), intent(in) :: res_hist
integer, optional, intent(in) :: unit
logical, optional, intent(in) :: verbose
integer, optional, intent(in) :: indent
end subroutine resonance_history_write
<<Resonances: procedures>>=
module subroutine resonance_history_write (res_hist, unit, verbose, indent)
class(resonance_history_t), intent(in) :: res_hist
integer, optional, intent(in) :: unit
logical, optional, intent(in) :: verbose
integer, optional, intent(in) :: indent
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call write_indent (u, indent)
write(u, '(A,I0,A)') "Resonance history with ", &
res_hist%n_resonances, " resonances:"
do i = 1, res_hist%n_resonances
call write_indent (u, indent)
write (u, "(2x)", advance="no")
call res_hist%resonances(i)%write (u, verbose)
end do
end subroutine resonance_history_write
@ %def resonance_history_write
@ Assignment. Indirectly calls type-bound assignment for the contributors.
Strictly speaking, this is redundant. But NAGfor 6.208 intrinsic assignment
crashes under certain conditions.
<<Resonances: resonance history: TBP>>=
procedure, private :: resonance_history_assign
generic :: assignment(=) => resonance_history_assign
<<Resonances: sub interfaces>>=
module subroutine resonance_history_assign (res_hist_out, res_hist_in)
class(resonance_history_t), intent(out) :: res_hist_out
class(resonance_history_t), intent(in) :: res_hist_in
end subroutine resonance_history_assign
<<Resonances: procedures>>=
module subroutine resonance_history_assign (res_hist_out, res_hist_in)
class(resonance_history_t), intent(out) :: res_hist_out
class(resonance_history_t), intent(in) :: res_hist_in
if (allocated (res_hist_in%resonances)) then
res_hist_out%resonances = res_hist_in%resonances
res_hist_out%n_resonances = res_hist_in%n_resonances
end if
end subroutine resonance_history_assign
@ %def resonance_history_assign
@ Equality. If this turns out to slow down the program, we should
change the implementation or use hash codes.
<<Resonances: resonance history: TBP>>=
procedure, private :: resonance_history_equal
generic :: operator(==) => resonance_history_equal
<<Resonances: sub interfaces>>=
elemental module function resonance_history_equal (rh1, rh2) result (equal)
logical :: equal
class(resonance_history_t), intent(in) :: rh1, rh2
end function resonance_history_equal
<<Resonances: procedures>>=
elemental module function resonance_history_equal (rh1, rh2) result (equal)
logical :: equal
class(resonance_history_t), intent(in) :: rh1, rh2
integer :: i
equal = .false.
if (rh1%n_resonances == rh2%n_resonances) then
do i = 1, rh1%n_resonances
if (.not. rh1%resonances(i) == rh2%resonances(i)) then
return
end if
end do
equal = .true.
end if
end function resonance_history_equal
@ %def resonance_history_equal
@ Check if a resonance history is a strict superset of another one. This is
true if the first one is nonempty and the second one is empty.
Otherwise, we check if each entry of the second argument appears in
the first one.
<<Resonances: resonance history: TBP>>=
procedure, private :: resonance_history_contains
generic :: operator(.contains.) => resonance_history_contains
<<Resonances: sub interfaces>>=
elemental module function resonance_history_contains &
(rh1, rh2) result (flag)
logical :: flag
class(resonance_history_t), intent(in) :: rh1, rh2
end function resonance_history_contains
<<Resonances: procedures>>=
elemental module function resonance_history_contains &
(rh1, rh2) result (flag)
logical :: flag
class(resonance_history_t), intent(in) :: rh1, rh2
integer :: i
if (rh1%n_resonances > rh2%n_resonances) then
flag = .true.
do i = 1, rh2%n_resonances
flag = flag .and. any (rh1%resonances == rh2%resonances(i))
end do
else
flag = .false.
end if
end function resonance_history_contains
@ %def resonance_history_contains
@ Number of entries for dynamically extending the resonance-info array.
<<Resonances: parameters>>=
integer, parameter :: n_max_resonances = 10
@
<<Resonances: resonance history: TBP>>=
procedure :: add_resonance => resonance_history_add_resonance
<<Resonances: sub interfaces>>=
module subroutine resonance_history_add_resonance (res_hist, resonance)
class(resonance_history_t), intent(inout) :: res_hist
type(resonance_info_t), intent(in) :: resonance
end subroutine resonance_history_add_resonance
<<Resonances: procedures>>=
module subroutine resonance_history_add_resonance (res_hist, resonance)
class(resonance_history_t), intent(inout) :: res_hist
type(resonance_info_t), intent(in) :: resonance
type(resonance_info_t), dimension(:), allocatable :: tmp
integer :: n, i
if (debug_on) call msg_debug &
(D_PHASESPACE, "resonance_history_add_resonance")
if (.not. allocated (res_hist%resonances)) then
n = 0
allocate (res_hist%resonances (1))
else
n = res_hist%n_resonances
allocate (tmp (n))
do i = 1, n
call res_hist%resonances(i)%copy (tmp(i))
end do
deallocate (res_hist%resonances)
allocate (res_hist%resonances (n+1))
do i = 1, n
call tmp(i)%copy (res_hist%resonances(i))
end do
deallocate (tmp)
end if
call resonance%copy (res_hist%resonances(n+1))
res_hist%n_resonances = n + 1
if (debug_on) call msg_debug &
(D_PHASESPACE, "res_hist%n_resonances", res_hist%n_resonances)
end subroutine resonance_history_add_resonance
@ %def resonance_history_add_resonance
@
<<Resonances: resonance history: TBP>>=
procedure :: remove_resonance => resonance_history_remove_resonance
<<Resonances: sub interfaces>>=
module subroutine resonance_history_remove_resonance (res_hist, i_res)
class(resonance_history_t), intent(inout) :: res_hist
integer, intent(in) :: i_res
end subroutine resonance_history_remove_resonance
<<Resonances: procedures>>=
module subroutine resonance_history_remove_resonance (res_hist, i_res)
class(resonance_history_t), intent(inout) :: res_hist
integer, intent(in) :: i_res
type(resonance_info_t), dimension(:), allocatable :: tmp_1, tmp_2
integer :: i, j, n
n = res_hist%n_resonances
res_hist%n_resonances = n - 1
if (res_hist%n_resonances == 0) then
deallocate (res_hist%resonances)
else
if (i_res > 1) allocate (tmp_1(1:i_res-1))
if (i_res < n) allocate (tmp_2(i_res+1:n))
if (allocated (tmp_1)) then
do i = 1, i_res - 1
call res_hist%resonances(i)%copy (tmp_1(i))
end do
end if
if (allocated (tmp_2)) then
do i = i_res + 1, n
call res_hist%resonances(i)%copy (tmp_2(i))
end do
end if
deallocate (res_hist%resonances)
allocate (res_hist%resonances (res_hist%n_resonances))
j = 1
if (allocated (tmp_1)) then
do i = 1, i_res - 1
call tmp_1(i)%copy (res_hist%resonances(j))
j = j + 1
end do
deallocate (tmp_1)
end if
if (allocated (tmp_2)) then
do i = i_res + 1, n
call tmp_2(i)%copy (res_hist%resonances(j))
j = j + 1
end do
deallocate (tmp_2)
end if
end if
end subroutine resonance_history_remove_resonance
@ %def resonance_history_remove_resonance
@
<<Resonances: resonance history: TBP>>=
procedure :: add_offset => resonance_history_add_offset
<<Resonances: sub interfaces>>=
module subroutine resonance_history_add_offset (res_hist, n)
class(resonance_history_t), intent(inout) :: res_hist
integer, intent(in) :: n
end subroutine resonance_history_add_offset
<<Resonances: procedures>>=
module subroutine resonance_history_add_offset (res_hist, n)
class(resonance_history_t), intent(inout) :: res_hist
integer, intent(in) :: n
integer :: i_res
do i_res = 1, res_hist%n_resonances
associate (contributors => res_hist%resonances(i_res)%contributors%c)
contributors = contributors + n
end associate
end do
end subroutine resonance_history_add_offset
@ %def resonance_history_add_offset
@
<<Resonances: resonance history: TBP>>=
procedure :: contains_leg => resonance_history_contains_leg
<<Resonances: sub interfaces>>=
module function resonance_history_contains_leg &
(res_hist, i_leg) result (val)
logical :: val
class(resonance_history_t), intent(in) :: res_hist
integer, intent(in) :: i_leg
end function resonance_history_contains_leg
<<Resonances: procedures>>=
module function resonance_history_contains_leg &
(res_hist, i_leg) result (val)
logical :: val
class(resonance_history_t), intent(in) :: res_hist
integer, intent(in) :: i_leg
integer :: i_res
val = .false.
do i_res = 1, res_hist%n_resonances
if (any (res_hist%resonances(i_res)%contributors%c == i_leg)) then
val = .true.
exit
end if
end do
end function resonance_history_contains_leg
@ %def resonance_history_contains_leg
@
<<Resonances: resonance history: TBP>>=
procedure :: mapping => resonance_history_mapping
<<Resonances: sub interfaces>>=
module function resonance_history_mapping &
(res_hist, p, i_gluon) result (p_map)
real(default) :: p_map
class(resonance_history_t), intent(in) :: res_hist
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in), optional :: i_gluon
end function resonance_history_mapping
<<Resonances: procedures>>=
module function resonance_history_mapping &
(res_hist, p, i_gluon) result (p_map)
real(default) :: p_map
class(resonance_history_t), intent(in) :: res_hist
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in), optional :: i_gluon
integer :: i_res
real(default) :: s
p_map = one
do i_res = 1, res_hist%n_resonances
associate (res => res_hist%resonances(i_res))
s = compute_resonance_mass (p, res%contributors%c, i_gluon)**2
p_map = p_map * res%mapping (s)
end associate
end do
end function resonance_history_mapping
@ %def resonance_history_mapping
@ This predicate is true if all resonances in the history have exactly
[[n]] contributors. For instance, if $n=2$, all resonances have a
two-particle decay.
<<Resonances: resonance history: TBP>>=
procedure :: only_has_n_contributors => &
resonance_history_only_has_n_contributors
<<Resonances: sub interfaces>>=
module function resonance_history_only_has_n_contributors &
(res_hist, n) result (value)
logical :: value
class(resonance_history_t), intent(in) :: res_hist
integer, intent(in) :: n
end function resonance_history_only_has_n_contributors
<<Resonances: procedures>>=
module function resonance_history_only_has_n_contributors &
(res_hist, n) result (value)
logical :: value
class(resonance_history_t), intent(in) :: res_hist
integer, intent(in) :: n
integer :: i_res
value = .true.
do i_res = 1, res_hist%n_resonances
associate (res => res_hist%resonances(i_res))
value = value .and. size (res%contributors%c) == n
end associate
end do
end function resonance_history_only_has_n_contributors
@ %def resonance_history_only_has_n_contributors
@
<<Resonances: resonance history: TBP>>=
procedure :: has_flavor => resonance_history_has_flavor
<<Resonances: sub interfaces>>=
module function resonance_history_has_flavor &
(res_hist, flv) result (has_flv)
logical :: has_flv
class(resonance_history_t), intent(in) :: res_hist
type(flavor_t), intent(in) :: flv
end function resonance_history_has_flavor
<<Resonances: procedures>>=
module function resonance_history_has_flavor &
(res_hist, flv) result (has_flv)
logical :: has_flv
class(resonance_history_t), intent(in) :: res_hist
type(flavor_t), intent(in) :: flv
integer :: i
has_flv = .false.
do i = 1, res_hist%n_resonances
has_flv = has_flv .or. res_hist%resonances(i)%flavor == flv
end do
end function resonance_history_has_flavor
@ %def resonance_history_has_flavor
@
\subsection{Kinematics}
Evaluate the distance from a resonance. The distance is given by
$|p^2-m^2|/(m\Gamma)$. For $\Gamma\ll m$, this is the relative
distance from the resonance peak in units of the half-width.
<<Resonances: resonance info: TBP>>=
procedure :: evaluate_distance => resonance_info_evaluate_distance
<<Resonances: sub interfaces>>=
module subroutine resonance_info_evaluate_distance (res_info, p, dist)
class(resonance_info_t), intent(in) :: res_info
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(out) :: dist
end subroutine resonance_info_evaluate_distance
<<Resonances: procedures>>=
module subroutine resonance_info_evaluate_distance (res_info, p, dist)
class(resonance_info_t), intent(in) :: res_info
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(out) :: dist
real(default) :: m, w
type(vector4_t) :: q
m = res_info%flavor%get_mass ()
w = res_info%flavor%get_width ()
q = sum (p(res_info%contributors%c))
dist = abs (q**2 - m**2) / (m * w)
end subroutine resonance_info_evaluate_distance
@ %def resonance_info_evaluate_distance
@
Evaluate the array of distances from a resonance history. We assume that the
array has been allocated with correct size, namely the number of resonances in
this history.
<<Resonances: resonance history: TBP>>=
procedure :: evaluate_distances => resonance_history_evaluate_distances
<<Resonances: sub interfaces>>=
module subroutine resonance_history_evaluate_distances (res_hist, p, dist)
class(resonance_history_t), intent(in) :: res_hist
type(vector4_t), dimension(:), intent(in) :: p
real(default), dimension(:), intent(out) :: dist
end subroutine resonance_history_evaluate_distances
<<Resonances: procedures>>=
module subroutine resonance_history_evaluate_distances (res_hist, p, dist)
class(resonance_history_t), intent(in) :: res_hist
type(vector4_t), dimension(:), intent(in) :: p
real(default), dimension(:), intent(out) :: dist
integer :: i
do i = 1, res_hist%n_resonances
call res_hist%resonances(i)%evaluate_distance (p, dist(i))
end do
end subroutine resonance_history_evaluate_distances
@ %def resonance_history_evaluate_distances
@ Use the distance to determine a Gaussian turnoff factor for a
resonance. The factor is given by a Gaussian function
$e^{-d^2/\sigma^2}$, where $\sigma$ is the [[gw]] parameter multiplied
by the resonance width, and $d$ is the distance (see above). So, for
$d=\sigma$, the factor is $0.37$, and for $d=2\sigma$ we get $0.018$.
If the [[gw]] factor is less or equal to zero, return $1$.
<<Resonances: resonance info: TBP>>=
procedure :: evaluate_gaussian => resonance_info_evaluate_gaussian
<<Resonances: sub interfaces>>=
module function resonance_info_evaluate_gaussian &
(res_info, p, gw) result (factor)
class(resonance_info_t), intent(in) :: res_info
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: gw
real(default) :: factor
end function resonance_info_evaluate_gaussian
<<Resonances: procedures>>=
module function resonance_info_evaluate_gaussian &
(res_info, p, gw) result (factor)
class(resonance_info_t), intent(in) :: res_info
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: gw
real(default) :: factor
real(default) :: dist, w
if (gw > 0) then
w = res_info%flavor%get_width ()
call res_info%evaluate_distance (p, dist)
factor = exp (- (dist / (gw * w)) **2)
else
factor = 1
end if
end function resonance_info_evaluate_gaussian
@ %def resonance_info_evaluate_gaussian
@ The Gaussian factor of the history is the product of all factors.
<<Resonances: resonance history: TBP>>=
procedure :: evaluate_gaussian => resonance_history_evaluate_gaussian
<<Resonances: sub interfaces>>=
module function resonance_history_evaluate_gaussian &
(res_hist, p, gw) result (factor)
class(resonance_history_t), intent(in) :: res_hist
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: gw
real(default) :: factor
end function resonance_history_evaluate_gaussian
<<Resonances: procedures>>=
module function resonance_history_evaluate_gaussian &
(res_hist, p, gw) result (factor)
class(resonance_history_t), intent(in) :: res_hist
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: gw
real(default), dimension(:), allocatable :: dist
real(default) :: factor
integer :: i
factor = 1
do i = 1, res_hist%n_resonances
factor = factor * res_hist%resonances(i)%evaluate_gaussian (p, gw)
end do
end function resonance_history_evaluate_gaussian
@ %def resonance_history_evaluate_gaussian
@
Use the distances to determine whether the resonance history can qualify as
on-shell. The criterion is whether the distance is greater than the number of
width values as given by [[on_shell_limit]].
<<Resonances: resonance info: TBP>>=
procedure :: is_on_shell => resonance_info_is_on_shell
<<Resonances: sub interfaces>>=
module function resonance_info_is_on_shell (res_info, p, on_shell_limit) &
result (flag)
class(resonance_info_t), intent(in) :: res_info
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: on_shell_limit
logical :: flag
end function resonance_info_is_on_shell
<<Resonances: procedures>>=
module function resonance_info_is_on_shell (res_info, p, on_shell_limit) &
result (flag)
class(resonance_info_t), intent(in) :: res_info
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: on_shell_limit
logical :: flag
real(default) :: dist
call res_info%evaluate_distance (p, dist)
flag = dist < on_shell_limit
end function resonance_info_is_on_shell
@ %def resonance_info_is_on_shell
@
<<Resonances: resonance history: TBP>>=
procedure :: is_on_shell => resonance_history_is_on_shell
<<Resonances: sub interfaces>>=
module function resonance_history_is_on_shell &
(res_hist, p, on_shell_limit) result (flag)
class(resonance_history_t), intent(in) :: res_hist
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: on_shell_limit
logical :: flag
end function resonance_history_is_on_shell
<<Resonances: procedures>>=
module function resonance_history_is_on_shell &
(res_hist, p, on_shell_limit) result (flag)
class(resonance_history_t), intent(in) :: res_hist
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: on_shell_limit
logical :: flag
integer :: i
flag = .true.
do i = 1, res_hist%n_resonances
flag = flag .and. res_hist%resonances(i)%is_on_shell (p, on_shell_limit)
end do
end function resonance_history_is_on_shell
@ %def resonance_history_is_on_shell
@
\subsection{OMega restriction strings}
One application of the resonance module is creating restriction
strings that can be fed into process definitions with the OMega
generator. Since OMega counts the incoming particles first, we have
to supply [[n_in]] as an offset.
<<Resonances: resonance info: TBP>>=
procedure :: as_omega_string => resonance_info_as_omega_string
<<Resonances: resonance history: TBP>>=
procedure :: as_omega_string => resonance_history_as_omega_string
<<Resonances: sub interfaces>>=
module function resonance_info_as_omega_string &
(res_info, n_in) result (string)
class(resonance_info_t), intent(in) :: res_info
integer, intent(in) :: n_in
type(string_t) :: string
end function resonance_info_as_omega_string
module function resonance_history_as_omega_string &
(res_hist, n_in) result (string)
class(resonance_history_t), intent(in) :: res_hist
integer, intent(in) :: n_in
type(string_t) :: string
end function resonance_history_as_omega_string
<<Resonances: procedures>>=
module function resonance_info_as_omega_string &
(res_info, n_in) result (string)
class(resonance_info_t), intent(in) :: res_info
integer, intent(in) :: n_in
type(string_t) :: string
integer :: i
string = ""
if (allocated (res_info%contributors%c)) then
do i = 1, size (res_info%contributors%c)
if (i > 1) string = string // "+"
string = string // str (res_info%contributors%c(i) + n_in)
end do
string = string // "~" // res_info%flavor%get_name ()
end if
end function resonance_info_as_omega_string
module function resonance_history_as_omega_string &
(res_hist, n_in) result (string)
class(resonance_history_t), intent(in) :: res_hist
integer, intent(in) :: n_in
type(string_t) :: string
integer :: i
string = ""
do i = 1, res_hist%n_resonances
if (i > 1) string = string // " && "
string = string // res_hist%resonances(i)%as_omega_string (n_in)
end do
end function resonance_history_as_omega_string
@ %def resonance_info_as_omega_string
@ %def resonance_history_as_omega_string
@
\subsection{Resonance history as tree}
If we want to organize the resonances and their decay products, it can be
useful to have them explicitly as a tree structure. We implement this in the
traditional event-record form with the resonances sorted by decreasing number
of contributors, and their decay products added as an extra array.
<<Resonances: public>>=
public :: resonance_tree_t
<<Resonances: types>>=
type :: resonance_branch_t
integer :: i = 0
type(flavor_t) :: flv
integer, dimension(:), allocatable :: r_child
integer, dimension(:), allocatable :: o_child
end type resonance_branch_t
type :: resonance_tree_t
private
integer :: n = 0
type(resonance_branch_t), dimension(:), allocatable :: branch
contains
<<Resonances: resonance tree: TBP>>
end type resonance_tree_t
@ %def resonance_branch_t resonance_tree_t
@
<<Resonances: resonance tree: TBP>>=
procedure :: write => resonance_tree_write
<<Resonances: sub interfaces>>=
module subroutine resonance_tree_write (tree, unit, indent)
class(resonance_tree_t), intent(in) :: tree
integer, intent(in), optional :: unit, indent
end subroutine resonance_tree_write
<<Resonances: procedures>>=
module subroutine resonance_tree_write (tree, unit, indent)
class(resonance_tree_t), intent(in) :: tree
integer, intent(in), optional :: unit, indent
integer :: u, b, c
u = given_output_unit (unit)
call write_indent (u, indent)
write (u, "(A)", advance="no") "Resonance tree:"
if (tree%n > 0) then
write (u, *)
do b = 1, tree%n
call write_indent (u, indent)
write (u, "(2x,'r',I0,':',1x)", advance="no") b
associate (branch => tree%branch(b))
call branch%flv%write (u)
write (u, "(1x,'=>')", advance="no")
if (allocated (branch%r_child)) then
do c = 1, size (branch%r_child)
write (u, "(1x,'r',I0)", advance="no") branch%r_child(c)
end do
end if
if (allocated (branch%o_child)) then
do c = 1, size (branch%o_child)
write (u, "(1x,I0)", advance="no") branch%o_child(c)
end do
end if
write (u, *)
end associate
end do
else
write (u, "(1x,A)") "[empty]"
end if
end subroutine resonance_tree_write
@ %def resonance_tree_write
@ Contents.
<<Resonances: resonance tree: TBP>>=
procedure :: get_n_resonances => resonance_tree_get_n_resonances
procedure :: get_flv => resonance_tree_get_flv
<<Resonances: sub interfaces>>=
module function resonance_tree_get_n_resonances (tree) result (n)
class(resonance_tree_t), intent(in) :: tree
integer :: n
end function resonance_tree_get_n_resonances
module function resonance_tree_get_flv (tree, i) result (flv)
class(resonance_tree_t), intent(in) :: tree
integer, intent(in) :: i
type(flavor_t) :: flv
end function resonance_tree_get_flv
<<Resonances: procedures>>=
module function resonance_tree_get_n_resonances (tree) result (n)
class(resonance_tree_t), intent(in) :: tree
integer :: n
n = tree%n
end function resonance_tree_get_n_resonances
module function resonance_tree_get_flv (tree, i) result (flv)
class(resonance_tree_t), intent(in) :: tree
integer, intent(in) :: i
type(flavor_t) :: flv
flv = tree%branch(i)%flv
end function resonance_tree_get_flv
@ %def resonance_tree_get_n_resonances
@ %def resonance_tree_get_flv
@ Return the shifted indices of the resonance children for branch [[i]]. For
a child which is itself a resonance, add [[offset_r]] to the index value. For
the others, add [[offset_o]]. Combine both in a single array.
<<Resonances: resonance tree: TBP>>=
procedure :: get_children => resonance_tree_get_children
<<Resonances: sub interfaces>>=
module function resonance_tree_get_children (tree, i, offset_r, offset_o) &
result (child)
class(resonance_tree_t), intent(in) :: tree
integer, intent(in) :: i, offset_r, offset_o
integer, dimension(:), allocatable :: child
end function resonance_tree_get_children
<<Resonances: procedures>>=
module function resonance_tree_get_children (tree, i, offset_r, offset_o) &
result (child)
class(resonance_tree_t), intent(in) :: tree
integer, intent(in) :: i, offset_r, offset_o
integer, dimension(:), allocatable :: child
integer :: nr, no
associate (branch => tree%branch(i))
nr = size (branch%r_child)
no = size (branch%o_child)
allocate (child (nr + no))
child(1:nr) = branch%r_child + offset_r
child(nr+1:nr+no) = branch%o_child + offset_o
end associate
end function resonance_tree_get_children
@ %def resonance_tree_get_children
@ Transform a resonance history into a resonance tree.
Algorithm:
\begin{enumerate}
\item
Determine a mapping of the resonance array, such that in the new array the
resonances are ordered by decreasing number of contributors.
\item
Copy the flavor entries to the mapped array.
\item
Scan all resonances and, for each one, find a resonance that is its parent.
Since the resonances are ordered, later matches overwrite earlier ones. The
last match is the correct one. Then scan again and, for each resonance,
collect the resonances that have it as parent. This is the set of child
resonances.
\item
Analogously, scan all outgoing particles that appear in any of the
contributors list. Determine their immediate parent as above, and set the
child outgoing parents for the resonances, as above.
\end{enumerate}
<<Resonances: resonance history: TBP>>=
procedure :: to_tree => resonance_history_to_tree
<<Resonances: sub interfaces>>=
module subroutine resonance_history_to_tree (res_hist, tree)
class(resonance_history_t), intent(in) :: res_hist
type(resonance_tree_t), intent(out) :: tree
end subroutine resonance_history_to_tree
<<Resonances: procedures>>=
module subroutine resonance_history_to_tree (res_hist, tree)
class(resonance_history_t), intent(in) :: res_hist
type(resonance_tree_t), intent(out) :: tree
integer :: nr
integer, dimension(:), allocatable :: r_branch, r_source
nr = res_hist%n_resonances
tree%n = nr
allocate (tree%branch (tree%n), r_branch (tree%n), r_source (tree%n))
if (tree%n > 0) then
call find_branch_ordering ()
call set_flavors ()
call set_child_resonances ()
call set_child_outgoing ()
end if
contains
subroutine find_branch_ordering ()
integer, dimension(:), allocatable :: nc_array
integer :: r, ir, nc
allocate (nc_array (tree%n))
nc_array(:) = res_hist%resonances%get_n_contributors ()
ir = 0
do nc = maxval (nc_array), minval (nc_array), -1
do r = 1, nr
if (nc_array(r) == nc) then
ir = ir + 1
r_branch(r) = ir
r_source(ir) = r
end if
end do
end do
end subroutine find_branch_ordering
subroutine set_flavors ()
integer :: r
do r = 1, nr
tree%branch(r_branch(r))%flv = res_hist%resonances(r)%flavor
end do
end subroutine set_flavors
subroutine set_child_resonances ()
integer, dimension(:), allocatable :: r_child, r_parent
integer :: r, ir, pr
allocate (r_parent (nr), source = 0)
SCAN_RES: do r = 1, nr
associate (this_res => res_hist%resonances(r))
SCAN_PARENT: do ir = 1, nr
pr = r_source(ir)
if (pr == r) cycle SCAN_PARENT
if (all (res_hist%resonances(pr)%contains &
(this_res%contributors%c))) then
r_parent (r) = pr
end if
end do SCAN_PARENT
end associate
end do SCAN_RES
allocate (r_child (nr), source = [(r, r = 1, nr)])
do r = 1, nr
ir = r_branch(r)
tree%branch(ir)%r_child = r_branch (pack (r_child, r_parent == r))
end do
end subroutine set_child_resonances
subroutine set_child_outgoing ()
integer, dimension(:), allocatable :: o_child, o_parent
integer :: o_max, r, o, ir
o_max = 0
do r = 1, nr
associate (this_res => res_hist%resonances(r))
o_max = max (o_max, maxval (this_res%contributors%c))
end associate
end do
allocate (o_parent (o_max), source=0)
SCAN_OUT: do o = 1, o_max
SCAN_PARENT: do ir = 1, nr
r = r_source(ir)
associate (this_res => res_hist%resonances(r))
if (this_res%contains (o)) o_parent(o) = r
end associate
end do SCAN_PARENT
end do SCAN_OUT
allocate (o_child (o_max), source = [(o, o = 1, o_max)])
do r = 1, nr
ir = r_branch(r)
tree%branch(ir)%o_child = pack (o_child, o_parent == r)
end do
end subroutine set_child_outgoing
end subroutine resonance_history_to_tree
@ %def resonance_history_to_tree
@
\subsection{Resonance history set}
This is an array of resonance histories. The elements are supposed to
be unique. That is, entering a new element is successful only if the
element does not already exist.
The current implementation uses a straightforward linear search for
comparison. If this should become an issue, we may change the
implementation to a hash table. To keep this freedom, the set should
be an opaque object. In fact, we expect to use it as a transient data
structure. Once the set is complete, we transform it into a
contiguous array.
<<Resonances: public>>=
public :: resonance_history_set_t
<<Resonances: types>>=
type :: index_array_t
integer, dimension(:), allocatable :: i
end type index_array_t
type :: resonance_history_set_t
private
logical :: complete = .false.
integer :: n_filter = 0
type(resonance_history_t), dimension(:), allocatable :: history
type(index_array_t), dimension(:), allocatable :: contains_this
type(resonance_tree_t), dimension(:), allocatable :: tree
integer :: last = 0
contains
<<Resonances: resonance history set: TBP>>
end type resonance_history_set_t
@ %def resonance_history_set_t
@ Display.
The tree-format version of the histories is displayed only upon request.
<<Resonances: resonance history set: TBP>>=
procedure :: write => resonance_history_set_write
<<Resonances: sub interfaces>>=
module subroutine resonance_history_set_write &
(res_set, unit, indent, show_trees)
class(resonance_history_set_t), intent(in) :: res_set
integer, intent(in), optional :: unit
integer, intent(in), optional :: indent
logical, intent(in), optional :: show_trees
end subroutine resonance_history_set_write
<<Resonances: procedures>>=
module subroutine resonance_history_set_write &
(res_set, unit, indent, show_trees)
class(resonance_history_set_t), intent(in) :: res_set
integer, intent(in), optional :: unit
integer, intent(in), optional :: indent
logical, intent(in), optional :: show_trees
logical :: s_trees
integer :: u, i, j, ind
u = given_output_unit (unit)
s_trees = .false.; if (present (show_trees)) s_trees = show_trees
ind = 0; if (present (indent)) ind = indent
call write_indent (u, indent)
write (u, "(A)", advance="no") "Resonance history set:"
if (res_set%complete) then
write (u, *)
else
write (u, "(1x,A)") "[incomplete]"
end if
do i = 1, res_set%last
write (u, "(1x,I0,1x)", advance="no") i
call res_set%history(i)%write (u, verbose=.false., indent=indent)
if (allocated (res_set%contains_this)) then
call write_indent (u, indent)
write (u, "(3x,A)", advance="no") "contained in ("
do j = 1, size (res_set%contains_this(i)%i)
if (j>1) write (u, "(',')", advance="no")
write (u, "(I0)", advance="no") res_set%contains_this(i)%i(j)
end do
write (u, "(A)") ")"
end if
if (s_trees .and. allocated (res_set%tree)) then
call res_set%tree(i)%write (u, ind + 1)
end if
end do
end subroutine resonance_history_set_write
@ %def resonance_history_set_write
@ Initialization. The default initial size is 16 elements, to be doubled in
size repeatedly as needed.
<<Resonances: parameters>>=
integer, parameter :: resonance_history_set_initial_size = 16
@ %def resonance_history_set_initial_size = 16
<<Resonances: resonance history set: TBP>>=
procedure :: init => resonance_history_set_init
<<Resonances: sub interfaces>>=
module subroutine resonance_history_set_init &
(res_set, n_filter, initial_size)
class(resonance_history_set_t), intent(out) :: res_set
integer, intent(in), optional :: n_filter
integer, intent(in), optional :: initial_size
end subroutine resonance_history_set_init
<<Resonances: procedures>>=
module subroutine resonance_history_set_init &
(res_set, n_filter, initial_size)
class(resonance_history_set_t), intent(out) :: res_set
integer, intent(in), optional :: n_filter
integer, intent(in), optional :: initial_size
if (present (n_filter)) res_set%n_filter = n_filter
if (present (initial_size)) then
allocate (res_set%history (initial_size))
else
allocate (res_set%history (resonance_history_set_initial_size))
end if
end subroutine resonance_history_set_init
@ %def resonance_history_set_init
@ Enter an entry: append to the array if it does not yet exist, expand
as needed. If a [[n_filter]] value has been provided, enter the
resonance only if it fulfils the requirement.
An empty resonance history is entered only if the [[trivial]] flag is set.
<<Resonances: resonance history set: TBP>>=
procedure :: enter => resonance_history_set_enter
<<Resonances: sub interfaces>>=
module subroutine resonance_history_set_enter &
(res_set, res_history, trivial)
class(resonance_history_set_t), intent(inout) :: res_set
type(resonance_history_t), intent(in) :: res_history
logical, intent(in), optional :: trivial
end subroutine resonance_history_set_enter
<<Resonances: procedures>>=
module subroutine resonance_history_set_enter &
(res_set, res_history, trivial)
class(resonance_history_set_t), intent(inout) :: res_set
type(resonance_history_t), intent(in) :: res_history
logical, intent(in), optional :: trivial
integer :: i, new
if (res_history%n_resonances == 0) then
if (present (trivial)) then
if (.not. trivial) return
else
return
end if
end if
if (res_set%n_filter > 0) then
if (.not. res_history%only_has_n_contributors (res_set%n_filter)) return
end if
do i = 1, res_set%last
if (res_set%history(i) == res_history) return
end do
new = res_set%last + 1
if (new > size (res_set%history)) call res_set%expand ()
res_set%history(new) = res_history
res_set%last = new
end subroutine resonance_history_set_enter
@ %def resonance_history_set_enter
@ Freeze the resonance history set: determine the array that determines
in which other resonance histories a particular history is contained.
This can only be done once, and once this is done, no further histories can be
entered.
<<Resonances: resonance history set: TBP>>=
procedure :: freeze => resonance_history_set_freeze
<<Resonances: sub interfaces>>=
module subroutine resonance_history_set_freeze (res_set)
class(resonance_history_set_t), intent(inout) :: res_set
end subroutine resonance_history_set_freeze
<<Resonances: procedures>>=
module subroutine resonance_history_set_freeze (res_set)
class(resonance_history_set_t), intent(inout) :: res_set
integer :: i, n, c
logical, dimension(:), allocatable :: contains_this
integer, dimension(:), allocatable :: index_array
n = res_set%last
allocate (contains_this (n))
allocate (index_array (n), source = [(i, i=1, n)])
allocate (res_set%contains_this (n))
do i = 1, n
contains_this = resonance_history_contains &
(res_set%history(1:n), res_set%history(i))
c = count (contains_this)
allocate (res_set%contains_this(i)%i (c))
res_set%contains_this(i)%i = pack (index_array, contains_this)
end do
allocate (res_set%tree (n))
do i = 1, n
call res_set%history(i)%to_tree (res_set%tree(i))
end do
res_set%complete = .true.
end subroutine resonance_history_set_freeze
@ %def resonance_history_set_freeze
@ Determine the histories (in form of their indices in the array) that can be
considered on-shell, given a set of momenta and a maximum distance. The
distance from the resonance is measured in multiples of the resonance width.
Note that the momentum array must only contain the outgoing particles.
If a particular history is on-shell, but there is another history which
contains this and also is on-shell, only the latter is retained.
<<Resonances: resonance history set: TBP>>=
procedure :: determine_on_shell_histories &
=> resonance_history_set_determine_on_shell_histories
<<Resonances: sub interfaces>>=
module subroutine resonance_history_set_determine_on_shell_histories &
(res_set, p, on_shell_limit, index_array)
class(resonance_history_set_t), intent(in) :: res_set
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: on_shell_limit
integer, dimension(:), allocatable, intent(out) :: index_array
end subroutine resonance_history_set_determine_on_shell_histories
<<Resonances: procedures>>=
module subroutine resonance_history_set_determine_on_shell_histories &
(res_set, p, on_shell_limit, index_array)
class(resonance_history_set_t), intent(in) :: res_set
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: on_shell_limit
integer, dimension(:), allocatable, intent(out) :: index_array
integer :: n, i
integer, dimension(:), allocatable :: i_array
if (res_set%complete) then
n = res_set%last
allocate (i_array (n), source=0)
do i = 1, n
if (res_set%history(i)%is_on_shell (p, on_shell_limit)) i_array(i) = i
end do
do i = 1, n
if (any (i_array(res_set%contains_this(i)%i) /= 0)) then
i_array(i) = 0
end if
end do
allocate (index_array (count (i_array /= 0)))
index_array(:) = pack (i_array, i_array /= 0)
end if
end subroutine resonance_history_set_determine_on_shell_histories
@ %def resonance_history_set_determine_on_shell_histories
@ For the selected history, compute the Gaussian turnoff factor.
The turnoff parameter is [[gw]].
<<Resonances: resonance history set: TBP>>=
procedure :: evaluate_gaussian => resonance_history_set_evaluate_gaussian
<<Resonances: sub interfaces>>=
module function resonance_history_set_evaluate_gaussian &
(res_set, p, gw, i) result (factor)
class(resonance_history_set_t), intent(in) :: res_set
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: gw
integer, intent(in) :: i
real(default) :: factor
end function resonance_history_set_evaluate_gaussian
<<Resonances: procedures>>=
module function resonance_history_set_evaluate_gaussian &
(res_set, p, gw, i) result (factor)
class(resonance_history_set_t), intent(in) :: res_set
type(vector4_t), dimension(:), intent(in) :: p
real(default), intent(in) :: gw
integer, intent(in) :: i
real(default) :: factor
factor = res_set%history(i)%evaluate_gaussian (p, gw)
end function resonance_history_set_evaluate_gaussian
@ %def resonance_history_set_evaluate_gaussian
@ Return the number of histories. This is zero if there are none, or
if [[freeze]] has not been called yet.
<<Resonances: resonance history set: TBP>>=
procedure :: get_n_history => resonance_history_set_get_n_history
<<Resonances: sub interfaces>>=
module function resonance_history_set_get_n_history (res_set) result (n)
class(resonance_history_set_t), intent(in) :: res_set
integer :: n
end function resonance_history_set_get_n_history
<<Resonances: procedures>>=
module function resonance_history_set_get_n_history (res_set) result (n)
class(resonance_history_set_t), intent(in) :: res_set
integer :: n
if (res_set%complete) then
n = res_set%last
else
n = 0
end if
end function resonance_history_set_get_n_history
@ %def resonance_history_set_get_n_history
@ Return a single history.
<<Resonances: resonance history set: TBP>>=
procedure :: get_history => resonance_history_set_get_history
<<Resonances: sub interfaces>>=
module function resonance_history_set_get_history &
(res_set, i) result (res_history)
class(resonance_history_set_t), intent(in) :: res_set
integer, intent(in) :: i
type(resonance_history_t) :: res_history
end function resonance_history_set_get_history
<<Resonances: procedures>>=
module function resonance_history_set_get_history &
(res_set, i) result (res_history)
class(resonance_history_set_t), intent(in) :: res_set
integer, intent(in) :: i
type(resonance_history_t) :: res_history
if (res_set%complete .and. i <= res_set%last) then
res_history = res_set%history(i)
end if
end function resonance_history_set_get_history
@ %def resonance_history_set_get_history
@ Conversion to a plain array, sized correctly.
<<Resonances: resonance history set: TBP>>=
procedure :: to_array => resonance_history_set_to_array
<<Resonances: sub interfaces>>=
module subroutine resonance_history_set_to_array (res_set, res_history)
class(resonance_history_set_t), intent(in) :: res_set
type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
res_history
end subroutine resonance_history_set_to_array
<<Resonances: procedures>>=
module subroutine resonance_history_set_to_array (res_set, res_history)
class(resonance_history_set_t), intent(in) :: res_set
type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
res_history
if (res_set%complete) then
allocate (res_history (res_set%last))
res_history(:) = res_set%history(1:res_set%last)
end if
end subroutine resonance_history_set_to_array
@ %def resonance_history_set_to_array
@ Return a selected history in tree form.
<<Resonances: resonance history set: TBP>>=
procedure :: get_tree => resonance_history_set_get_tree
<<Resonances: sub interfaces>>=
module subroutine resonance_history_set_get_tree (res_set, i, res_tree)
class(resonance_history_set_t), intent(in) :: res_set
integer, intent(in) :: i
type(resonance_tree_t), intent(out) :: res_tree
end subroutine resonance_history_set_get_tree
<<Resonances: procedures>>=
module subroutine resonance_history_set_get_tree (res_set, i, res_tree)
class(resonance_history_set_t), intent(in) :: res_set
integer, intent(in) :: i
type(resonance_tree_t), intent(out) :: res_tree
if (res_set%complete) then
res_tree = res_set%tree(i)
end if
end subroutine resonance_history_set_get_tree
@ %def resonance_history_set_to_array
@ Expand: double the size of the array. We do not need this in the API.
<<Resonances: resonance history set: TBP>>=
procedure, private :: expand => resonance_history_set_expand
<<Resonances: sub interfaces>>=
module subroutine resonance_history_set_expand (res_set)
class(resonance_history_set_t), intent(inout) :: res_set
end subroutine resonance_history_set_expand
<<Resonances: procedures>>=
module subroutine resonance_history_set_expand (res_set)
class(resonance_history_set_t), intent(inout) :: res_set
type(resonance_history_t), dimension(:), allocatable :: history_new
integer :: s
s = size (res_set%history)
allocate (history_new (2 * s))
history_new(1:s) = res_set%history(1:s)
call move_alloc (history_new, res_set%history)
end subroutine resonance_history_set_expand
@ %def resonance_history_set_expand
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[resonances_ut.f90]]>>=
<<File header>>
module resonances_ut
use unit_tests
use resonances_uti
<<Standard module head>>
<<Resonances: public test>>
contains
<<Resonances: test driver>>
end module resonances_ut
@ %def resonances_ut
@
<<[[resonances_uti.f90]]>>=
<<File header>>
module resonances_uti
<<Use kinds>>
<<Use strings>>
use format_defs, only: FMF_12
use lorentz, only: vector4_t, vector4_at_rest
use model_data, only: model_data_t
use flavors, only: flavor_t
use resonances, only: resonance_history_t
use resonances
<<Standard module head>>
<<Resonances: test declarations>>
contains
<<Resonances: tests>>
end module resonances_uti
@ %def resonances_ut
@ API: driver for the unit tests below.
<<Resonances: public test>>=
public :: resonances_test
<<Resonances: test driver>>=
subroutine resonances_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Resonances: execute tests>>
end subroutine resonances_test
@ %def resonances_test
@ Basic operations on a resonance history object.
<<Resonances: execute tests>>=
call test (resonances_1, "resonances_1", &
"check resonance history setup", &
u, results)
<<Resonances: test declarations>>=
public :: resonances_1
<<Resonances: tests>>=
subroutine resonances_1 (u)
integer, intent(in) :: u
type(resonance_info_t) :: res_info
type(resonance_history_t) :: res_history
type(model_data_t), target :: model
write (u, "(A)") "* Test output: resonances_1"
write (u, "(A)") "* Purpose: test resonance history setup"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Empty resonance history"
write (u, "(A)")
call res_history%write (u)
write (u, "(A)")
write (u, "(A)") "* Add resonance"
write (u, "(A)")
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
write (u, "(A)")
write (u, "(A)") "* Add another resonance"
write (u, "(A)")
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
write (u, "(A)")
write (u, "(A)") "* Remove resonance"
write (u, "(A)")
call res_history%remove_resonance (1)
call res_history%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: resonances_1"
end subroutine resonances_1
@ %def resonances_1
@ Basic operations on a resonance history object.
<<Resonances: execute tests>>=
call test (resonances_2, "resonances_2", &
"check O'Mega restriction strings", &
u, results)
<<Resonances: test declarations>>=
public :: resonances_2
<<Resonances: tests>>=
subroutine resonances_2 (u)
integer, intent(in) :: u
type(resonance_info_t) :: res_info
type(resonance_history_t) :: res_history
type(model_data_t), target :: model
type(string_t) :: restrictions
write (u, "(A)") "* Test output: resonances_2"
write (u, "(A)") "* Purpose: test OMega restrictions strings &
&for resonance history"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Empty resonance history"
write (u, "(A)")
restrictions = res_history%as_omega_string (2)
write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'"
write (u, "(A)")
write (u, "(A)") "* Add resonance"
write (u, "(A)")
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
restrictions = res_history%as_omega_string (2)
write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'"
write (u, "(A)")
write (u, "(A)") "* Add another resonance"
write (u, "(A)")
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
restrictions = res_history%as_omega_string (2)
write (u, "(A,A,A)") "restrictions = '", char (restrictions), "'"
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: resonances_2"
end subroutine resonances_2
@ %def resonances_2
@ Basic operations on a resonance history set.
<<Resonances: execute tests>>=
call test (resonances_3, "resonances_3", &
"check resonance history set", &
u, results)
<<Resonances: test declarations>>=
public :: resonances_3
<<Resonances: tests>>=
subroutine resonances_3 (u)
integer, intent(in) :: u
type(resonance_info_t) :: res_info
type(resonance_history_t) :: res_history
type(resonance_history_t), dimension(:), allocatable :: res_histories
type(resonance_history_set_t) :: res_set
type(model_data_t), target :: model
integer :: i
write (u, "(A)") "* Test output: resonances_3"
write (u, "(A)") "* Purpose: test resonance history set"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Initialize resonance history set"
write (u, "(A)")
call res_set%init (initial_size = 2)
write (u, "(A)") "* Add resonance histories, one at a time"
write (u, "(A)")
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
write (u, *)
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
write (u, *)
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
write (u, *)
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
write (u, *)
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
write (u, *)
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_info%init (7, 25, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
call res_set%freeze ()
write (u, "(A)")
write (u, "(A)") "* Result"
write (u, "(A)")
call res_set%write (u)
write (u, "(A)")
write (u, "(A)") "* Queries"
write (u, "(A)")
write (u, "(A,1x,I0)") "n_history =", res_set%get_n_history ()
write (u, "(A)")
write (u, "(A)") "History #2:"
res_history = res_set%get_history (2)
call res_history%write (u, indent=1)
call res_history%clear ()
write (u, "(A)")
write (u, "(A)") "* Result in array form"
call res_set%to_array (res_histories)
do i = 1, size (res_histories)
write (u, *)
call res_histories(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Re-initialize resonance history set with filter n=2"
write (u, "(A)")
call res_set%init (n_filter = 2)
write (u, "(A)") "* Add resonance histories, one at a time"
write (u, "(A)")
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
write (u, *)
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
write (u, *)
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
write (u, *)
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
call res_set%enter (res_history)
call res_history%clear ()
call res_set%freeze ()
write (u, "(A)")
write (u, "(A)") "* Result"
write (u, "(A)")
call res_set%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: resonances_3"
end subroutine resonances_3
@ %def resonances_3
@ Probe momenta for resonance histories
<<Resonances: execute tests>>=
call test (resonances_4, "resonances_4", &
"resonance history: distance evaluation", &
u, results)
<<Resonances: test declarations>>=
public :: resonances_4
<<Resonances: tests>>=
subroutine resonances_4 (u)
integer, intent(in) :: u
type(resonance_info_t) :: res_info
type(resonance_history_t) :: res_history
type(model_data_t), target :: model
type(flavor_t) :: fw, fz
real(default) :: mw, mz, ww, wz
type(vector4_t), dimension(3) :: p
real(default), dimension(2) :: dist
real(default) :: gw, factor
integer :: i
write (u, "(A)") "* Test output: resonances_4"
write (u, "(A)") "* Purpose: test resonance history evaluation"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* W and Z parameters"
write (u, "(A)")
call fw%init (24, model)
call fz%init (23, model)
mw = fw%get_mass ()
ww = fw%get_width ()
mz = fz%get_mass ()
wz = fz%get_width ()
write (u, "(A,1x," // FMF_12 // ")") "mW =", mw
write (u, "(A,1x," // FMF_12 // ")") "wW =", ww
write (u, "(A,1x," // FMF_12 // ")") "mZ =", mz
write (u, "(A,1x," // FMF_12 // ")") "wZ =", wz
write (u, "(A)")
write (u, "(A)") "* Gaussian width parameter"
write (u, "(A)")
gw = 2
write (u, "(A,1x," // FMF_12 // ")") "gw =", gw
write (u, "(A)")
write (u, "(A)") "* Setup resonance histories"
write (u, "(A)")
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
write (u, "(A)")
write (u, "(A)") "* Setup zero momenta"
write (u, "(A)")
do i = 1, 3
call p(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Evaluate distances from resonances"
write (u, "(A)")
call res_history%evaluate_distances (p, dist)
write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1)
write (u, "(A,1x," // FMF_12 // ")") "m/w (W) =", mw / ww
write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2)
write (u, "(A,1x," // FMF_12 // ")") "m/w (Z) =", mz / wz
write (u, "(A)")
write (u, "(A)") "* Evaluate Gaussian turnoff factor"
write (u, "(A)")
factor = res_history%evaluate_gaussian (p, gw)
write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor
write (u, "(A)")
write (u, "(A)") "* Set momenta on W peak"
write (u, "(A)")
p(1) = vector4_at_rest (mw/2)
p(2) = vector4_at_rest (mw/2)
do i = 1, 3
call p(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Evaluate distances from resonances"
write (u, "(A)")
call res_history%evaluate_distances (p, dist)
write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1)
write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2)
write (u, "(A,1x," // FMF_12 // ")") "expected =", &
abs (mz**2 - mw**2) / (mz*wz)
write (u, "(A)")
write (u, "(A)") "* Evaluate Gaussian turnoff factor"
write (u, "(A)")
factor = res_history%evaluate_gaussian (p, gw)
write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor
write (u, "(A,1x," // FMF_12 // ")") "expected =", &
exp (- (abs (mz**2 - mw**2) / (mz*wz))**2 / (gw * wz)**2)
write (u, "(A)")
write (u, "(A)") "* Set momenta on both peaks"
write (u, "(A)")
p(3) = vector4_at_rest (mz - mw)
do i = 1, 3
call p(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Evaluate distances from resonances"
write (u, "(A)")
call res_history%evaluate_distances (p, dist)
write (u, "(A,1x," // FMF_12 // ")") "distance (W) =", dist(1)
write (u, "(A,1x," // FMF_12 // ")") "distance (Z) =", dist(2)
write (u, "(A)")
write (u, "(A)") "* Evaluate Gaussian turnoff factor"
write (u, "(A)")
factor = res_history%evaluate_gaussian (p, gw)
write (u, "(A,1x," // FMF_12 // ")") "gaussian fac =", factor
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: resonances_4"
end subroutine resonances_4
@ %def resonances_4
@ Probe on-shell test for resonance histories
<<Resonances: execute tests>>=
call test (resonances_5, "resonances_5", &
"resonance history: on-shell test", &
u, results)
<<Resonances: test declarations>>=
public :: resonances_5
<<Resonances: tests>>=
subroutine resonances_5 (u)
integer, intent(in) :: u
type(resonance_info_t) :: res_info
type(resonance_history_t) :: res_history
type(resonance_history_set_t) :: res_set
type(model_data_t), target :: model
type(flavor_t) :: fw, fz
real(default) :: mw, mz, ww, wz
real(default) :: on_shell_limit
integer, dimension(:), allocatable :: on_shell
type(vector4_t), dimension(4) :: p
write (u, "(A)") "* Test output: resonances_5"
write (u, "(A)") "* Purpose: resonance history on-shell test"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* W and Z parameters"
write (u, "(A)")
call fw%init (24, model)
call fz%init (23, model)
mw = fw%get_mass ()
ww = fw%get_width ()
mz = fz%get_mass ()
wz = fz%get_width ()
write (u, "(A,1x," // FMF_12 // ")") "mW =", mw
write (u, "(A,1x," // FMF_12 // ")") "wW =", ww
write (u, "(A,1x," // FMF_12 // ")") "mZ =", mz
write (u, "(A,1x," // FMF_12 // ")") "wZ =", wz
write (u, "(A)")
write (u, "(A)") "* On-shell parameter: distance as multiple of width"
write (u, "(A)")
on_shell_limit = 3
write (u, "(A,1x," // FMF_12 // ")") "on-shell limit =", on_shell_limit
write (u, "(A)")
write (u, "(A)") "* Setup resonance history set"
write (u, "(A)")
call res_set%init ()
call res_info%init (3, -24, model, 6)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_info%init (12, 24, model, 6)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_info%init (15, 23, model, 6)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_info%init (3, -24, model, 6)
call res_history%add_resonance (res_info)
call res_info%init (15, 23, model, 6)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_info%init (12, 24, model, 6)
call res_history%add_resonance (res_info)
call res_info%init (15, 23, model, 6)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_set%freeze ()
call res_set%write (u)
write (u, "(A)")
write (u, "(A)") "* Setup zero momenta"
write (u, "(A)")
call write_momenta (p)
call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
call write_on_shell_histories (on_shell)
write (u, "(A)")
write (u, "(A)") "* Setup momenta near W- resonance (2 widths off)"
write (u, "(A)")
p(1) = vector4_at_rest (82.5_default)
call write_momenta (p)
call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
call write_on_shell_histories (on_shell)
write (u, "(A)")
write (u, "(A)") "* Setup momenta near W- resonance (4 widths off)"
write (u, "(A)")
p(1) = vector4_at_rest (84.5_default)
call write_momenta (p)
call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
call write_on_shell_histories (on_shell)
write (u, "(A)")
write (u, "(A)") "* Setup momenta near Z resonance"
write (u, "(A)")
p(1) = vector4_at_rest (45._default)
p(3) = vector4_at_rest (45._default)
call write_momenta (p)
call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
call write_on_shell_histories (on_shell)
write (u, "(A)")
write (u, "(A)") "* Setup momenta near W- and W+ resonances"
write (u, "(A)")
p(1) = vector4_at_rest (40._default)
p(2) = vector4_at_rest (40._default)
p(3) = vector4_at_rest (40._default)
p(4) = vector4_at_rest (40._default)
call write_momenta (p)
call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
call write_on_shell_histories (on_shell)
write (u, "(A)")
write (u, "(A)") "* Setup momenta near W- and Z resonances, &
&shadowing single resonances"
write (u, "(A)")
p(1) = vector4_at_rest (40._default)
p(2) = vector4_at_rest (40._default)
p(3) = vector4_at_rest (10._default)
p(4) = vector4_at_rest ( 0._default)
call write_momenta (p)
call res_set%determine_on_shell_histories (p, on_shell_limit, on_shell)
call write_on_shell_histories (on_shell)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: resonances_5"
contains
subroutine write_momenta (p)
type(vector4_t), dimension(:), intent(in) :: p
integer :: i
do i = 1, size (p)
call p(i)%write (u)
end do
end subroutine write_momenta
subroutine write_on_shell_histories (on_shell)
integer, dimension(:), intent(in) :: on_shell
integer :: i
write (u, *)
write (u, "(A)", advance="no") "on-shell = ("
do i = 1, size (on_shell)
if (i > 1) write (u, "(',')", advance="no")
write (u, "(I0)", advance="no") on_shell(i)
end do
write (u, "(')')")
end subroutine write_on_shell_histories
end subroutine resonances_5
@ %def resonances_5
@ Organize the resonance history as a tree structure.
<<Resonances: execute tests>>=
call test (resonances_6, "resonances_6", &
"check resonance history setup", &
u, results)
<<Resonances: test declarations>>=
public :: resonances_6
<<Resonances: tests>>=
subroutine resonances_6 (u)
integer, intent(in) :: u
type(resonance_info_t) :: res_info
type(resonance_history_t) :: res_history
type(resonance_tree_t) :: res_tree
type(model_data_t), target :: model
write (u, "(A)") "* Test output: resonances_6"
write (u, "(A)") "* Purpose: retrieve resonance histories as trees"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Empty resonance history"
write (u, "(A)")
call res_history%write (u)
write (u, "(A)")
call res_history%to_tree (res_tree)
call res_tree%write (u)
write (u, "(A)")
write (u, "(A)") "* Single resonance"
write (u, "(A)")
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
write (u, "(A)")
call res_history%to_tree (res_tree)
call res_tree%write (u)
write (u, "(A)")
write (u, "(A)") "* Nested resonances"
write (u, "(A)")
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_history%write (u)
write (u, "(A)")
call res_history%to_tree (res_tree)
call res_tree%write (u)
write (u, "(A)")
write (u, "(A)") "* Disjunct resonances"
write (u, "(A)")
call res_history%clear ()
call res_info%init (5, 24, model, 7)
call res_history%add_resonance (res_info)
call res_info%init (7, 6, model, 7)
call res_history%add_resonance (res_info)
call res_info%init (80, -24, model, 7)
call res_history%add_resonance (res_info)
call res_info%init (112, -6, model, 7)
call res_history%add_resonance (res_info)
call res_history%write (u)
write (u, "(A)")
call res_history%to_tree (res_tree)
call res_tree%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: resonances_6"
end subroutine resonances_6
@ %def resonances_6
@ Basic operations on a resonance history set.
<<Resonances: execute tests>>=
call test (resonances_7, "resonances_7", &
"display tree format of history set elements", &
u, results)
<<Resonances: test declarations>>=
public :: resonances_7
<<Resonances: tests>>=
subroutine resonances_7 (u)
integer, intent(in) :: u
type(resonance_info_t) :: res_info
type(resonance_history_t) :: res_history
type(resonance_tree_t) :: res_tree
type(resonance_history_set_t) :: res_set
type(model_data_t), target :: model
type(flavor_t) :: flv
write (u, "(A)") "* Test output: resonances_7"
write (u, "(A)") "* Purpose: test tree format"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Initialize, fill and freeze resonance history set"
write (u, "(A)")
call res_set%init (initial_size = 2)
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_history%clear ()
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_info%init (7, 23, model, 5)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_info%init (3, -24, model, 5)
call res_history%add_resonance (res_info)
call res_info%init (7, 25, model, 5)
call res_history%add_resonance (res_info)
call res_set%enter (res_history)
call res_history%clear ()
call res_set%freeze ()
call res_set%write (u, show_trees = .true.)
write (u, "(A)")
write (u, "(A)") "* Extract tree #1"
write (u, "(A)")
call res_set%get_tree (1, res_tree)
call res_tree%write (u)
write (u, *)
write (u, "(1x,A,1x,I0)") "n_resonances =", res_tree%get_n_resonances ()
write (u, *)
write (u, "(1x,A,1x)", advance="no") "flv(r1) ="
flv = res_tree%get_flv (1)
call flv%write (u)
write (u, *)
write (u, "(1x,A,1x)", advance="no") "flv(r2) ="
flv = res_tree%get_flv (2)
call flv%write (u)
write (u, *)
write (u, *)
write (u, "(1x,A)") "[offset = 2, 4]"
write (u, "(1x,A,9(1x,I0))") "children(r1) =", &
res_tree%get_children(1, 2, 4)
write (u, "(1x,A,9(1x,I0))") "children(r2) =", &
res_tree%get_children(2, 2, 4)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: resonances_7"
end subroutine resonances_7
@ %def resonances_7
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\clearpage
\section{Mappings}
Mappings are objects that encode the transformation of the interval
$(0,1)$ to a physical variable $m^2$ or $\cos\theta$ (and back), as it
is used in the phase space parameterization. The mapping objects
contain fixed parameters, the associated methods implement the mapping
and inverse mapping operations, including the computation of the
Jacobian (phase space factor).
<<[[mappings.f90]]>>=
<<File header>>
module mappings
<<Use kinds>>
use kinds, only: TC
<<Use strings>>
use model_data
use flavors
<<Standard module head>>
<<Mappings: public>>
<<Mappings: parameters>>
<<Mappings: types>>
<<Mappings: interfaces>>
interface
<<Mappings: sub interfaces>>
end interface
end module mappings
@ %def mappings
@
<<[[mappings_sub.f90]]>>=
<<File header>>
submodule (mappings) mappings_s
use io_units
use constants, only: pi
use format_defs, only: FMT_19
use diagnostics
use md5
implicit none
contains
<<Mappings: procedures>>
end submodule mappings_s
@ %def mappings_s
@
\subsection{Default parameters}
This type holds the default parameters, needed for setting the scale
in cases where no mass parameter is available. The contents are public.
<<Mappings: public>>=
public :: mapping_defaults_t
<<Mappings: types>>=
type :: mapping_defaults_t
real(default) :: energy_scale = 10
real(default) :: invariant_mass_scale = 10
real(default) :: momentum_transfer_scale = 10
logical :: step_mapping = .true.
logical :: step_mapping_exp = .true.
logical :: enable_s_mapping = .false.
contains
<<Mappings: mapping defaults: TBP>>
end type mapping_defaults_t
@ %def mapping_defaults_t
@ Output.
<<Mappings: mapping defaults: TBP>>=
procedure :: write => mapping_defaults_write
<<Mappings: sub interfaces>>=
module subroutine mapping_defaults_write (object, unit)
class(mapping_defaults_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine mapping_defaults_write
<<Mappings: procedures>>=
module subroutine mapping_defaults_write (object, unit)
class(mapping_defaults_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(3x,A," // FMT_19 // ")") "energy scale = ", &
object%energy_scale
write (u, "(3x,A," // FMT_19 // ")") "mass scale = ", &
object%invariant_mass_scale
write (u, "(3x,A," // FMT_19 // ")") "q scale = ", &
object%momentum_transfer_scale
write (u, "(3x,A,L1)") "step mapping = ", &
object%step_mapping
write (u, "(3x,A,L1)") "step exp. mode = ", &
object%step_mapping_exp
write (u, "(3x,A,L1)") "allow s mapping = ", &
object%enable_s_mapping
end subroutine mapping_defaults_write
@ %def mapping_defaults_write
@
<<Mappings: public>>=
public :: mapping_defaults_md5sum
<<Mappings: sub interfaces>>=
module function mapping_defaults_md5sum &
(mapping_defaults) result (md5sum_map)
character(32) :: md5sum_map
type(mapping_defaults_t), intent(in) :: mapping_defaults
end function mapping_defaults_md5sum
<<Mappings: procedures>>=
module function mapping_defaults_md5sum &
(mapping_defaults) result (md5sum_map)
character(32) :: md5sum_map
type(mapping_defaults_t), intent(in) :: mapping_defaults
integer :: u
u = free_unit ()
open (u, status = "scratch")
write (u, *) mapping_defaults%energy_scale
write (u, *) mapping_defaults%invariant_mass_scale
write (u, *) mapping_defaults%momentum_transfer_scale
write (u, *) mapping_defaults%step_mapping
write (u, *) mapping_defaults%step_mapping_exp
write (u, *) mapping_defaults%enable_s_mapping
rewind (u)
md5sum_map = md5sum (u)
close (u)
end function mapping_defaults_md5sum
@ %def mapping_defaults_md5sum
@
\subsection{The Mapping type}
Each mapping has a type (e.g., s-channel, infrared), a binary code
(redundant, but useful for debugging), and a reference particle. The
flavor code of this particle is stored for bookkeeping reasons, what
matters are the mass and width of this particle. Furthermore,
depending on the type, various mapping parameters can be set and used.
The parameters [[a1]] to [[a3]] (for $m^2$ mappings) and [[b1]] to
[[b3]] (for $\cos\theta$ mappings) are values that are stored once to
speed up the calculation, if [[variable_limits]] is false. The exact
meaning of these parameters depends on the mapping type. The limits
are fixed if there is a fixed c.m. energy.
<<Mappings: public>>=
public :: mapping_t
<<Mappings: types>>=
type :: mapping_t
private
integer :: type = NO_MAPPING
integer(TC) :: bincode
type(flavor_t) :: flv
real(default) :: mass = 0
real(default) :: width = 0
logical :: a_unknown = .true.
real(default) :: a1 = 0
real(default) :: a2 = 0
real(default) :: a3 = 0
logical :: b_unknown = .true.
real(default) :: b1 = 0
real(default) :: b2 = 0
real(default) :: b3 = 0
logical :: variable_limits = .true.
contains
<<Mappings: mapping: TBP>>
end type mapping_t
@ %def mapping_t
@ The valid mapping types. The extra type [[STEP_MAPPING]] is used
only internally.
<<Mappings: parameters>>=
<<Mapping modes>>
@
\subsection{Screen output}
Do not write empty mappings.
<<Mappings: mapping: TBP>>=
procedure :: write => mapping_write
<<Mappings: sub interfaces>>=
module subroutine mapping_write (map, unit, verbose)
class(mapping_t), intent(in) :: map
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine mapping_write
<<Mappings: procedures>>=
module subroutine mapping_write (map, unit, verbose)
class(mapping_t), intent(in) :: map
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u
character(len=9) :: str
u = given_output_unit (unit); if (u < 0) return
select case(map%type)
case(S_CHANNEL); str = "s_channel"
case(COLLINEAR); str = "collinear"
case(INFRARED); str = "infrared "
case(RADIATION); str = "radiation"
case(T_CHANNEL); str = "t_channel"
case(U_CHANNEL); str = "u_channel"
case(STEP_MAPPING_E); str = "step_exp"
case(STEP_MAPPING_H); str = "step_hyp"
case(ON_SHELL); str = "on_shell"
case default; str = "????????"
end select
if (map%type /= NO_MAPPING) then
write (u, '(1x,A,I4,A)') &
"Branch #", map%bincode, ": " // &
"Mapping (" // str // ") for particle " // &
'"' // char (map%flv%get_name ()) // '"'
if (present (verbose)) then
if (verbose) then
select case (map%type)
case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H)
write (u, "(1x,A,3(" // FMT_19 // "))") &
" m/w = ", map%mass, map%width
case default
write (u, "(1x,A,3(" // FMT_19 // "))") &
" m = ", map%mass
end select
select case (map%type)
case (S_CHANNEL, T_CHANNEL, U_CHANNEL, &
STEP_MAPPING_E, STEP_MAPPING_H, &
COLLINEAR, INFRARED, RADIATION)
write (u, "(1x,A,3(" // FMT_19 // "))") &
" a1/2/3 = ", map%a1, map%a2, map%a3
end select
select case (map%type)
case (T_CHANNEL, U_CHANNEL, COLLINEAR)
write (u, "(1x,A,3(" // FMT_19 // "))") &
" b1/2/3 = ", map%b1, map%b2, map%b3
end select
end if
end if
end if
end subroutine mapping_write
@ %def mapping_write
@
\subsection{Define a mapping}
The initialization routine sets the mapping type and the particle
(binary code and flavor code) for which the mapping applies (e.g., a
$Z$ resonance in branch \#3).
<<Mappings: mapping: TBP>>=
procedure :: init => mapping_init
<<Mappings: sub interfaces>>=
module subroutine mapping_init (mapping, bincode, type, f, model)
class(mapping_t), intent(inout) :: mapping
integer(TC), intent(in) :: bincode
type(string_t), intent(in) :: type
integer, intent(in), optional :: f
class(model_data_t), intent(in), optional, target :: model
end subroutine mapping_init
<<Mappings: procedures>>=
module subroutine mapping_init (mapping, bincode, type, f, model)
class(mapping_t), intent(inout) :: mapping
integer(TC), intent(in) :: bincode
type(string_t), intent(in) :: type
integer, intent(in), optional :: f
class(model_data_t), intent(in), optional, target :: model
mapping%bincode = bincode
select case (char (type))
case ("s_channel"); mapping%type = S_CHANNEL
case ("collinear"); mapping%type = COLLINEAR
case ("infrared"); mapping%type = INFRARED
case ("radiation"); mapping%type = RADIATION
case ("t_channel"); mapping%type = T_CHANNEL
case ("u_channel"); mapping%type = U_CHANNEL
case ("step_exp"); mapping%type = STEP_MAPPING_E
case ("step_hyp"); mapping%type = STEP_MAPPING_H
case ("on_shell"); mapping%type = ON_SHELL
case default
call msg_bug ("Mappings: encountered undefined mapping key '" &
// char (type) // "'")
end select
if (present (f) .and. present (model)) call mapping%flv%init (f, model)
end subroutine mapping_init
@ %def mapping_init
@ This sets the actual mass and width, using a parameter set. Since
the auxiliary parameters will only be determined when the mapping is
first called, they are marked as unknown.
<<Mappings: mapping: TBP>>=
procedure :: set_parameters => mapping_set_parameters
<<Mappings: sub interfaces>>=
module subroutine mapping_set_parameters &
(map, mapping_defaults, variable_limits)
class(mapping_t), intent(inout) :: map
type(mapping_defaults_t), intent(in) :: mapping_defaults
logical, intent(in) :: variable_limits
end subroutine mapping_set_parameters
<<Mappings: procedures>>=
module subroutine mapping_set_parameters &
(map, mapping_defaults, variable_limits)
class(mapping_t), intent(inout) :: map
type(mapping_defaults_t), intent(in) :: mapping_defaults
logical, intent(in) :: variable_limits
if (map%type /= NO_MAPPING) then
map%mass = map%flv%get_mass ()
map%width = map%flv%get_width ()
map%variable_limits = variable_limits
map%a_unknown = .true.
map%b_unknown = .true.
select case (map%type)
case (S_CHANNEL)
if (map%mass <= 0) then
call map%write ()
call msg_fatal &
& (" S-channel resonance must have positive mass")
else if (map%width <= 0) then
call map%write ()
call msg_fatal &
& (" S-channel resonance must have positive width")
end if
case (RADIATION)
map%width = max (map%width, mapping_defaults%energy_scale)
case (INFRARED, COLLINEAR)
map%mass = max (map%mass, mapping_defaults%invariant_mass_scale)
case (T_CHANNEL, U_CHANNEL)
map%mass = max (map%mass, mapping_defaults%momentum_transfer_scale)
end select
end if
end subroutine mapping_set_parameters
@ %def mapping_set_code mapping_set_parameters
@ For a step mapping the mass and width are set directly, instead of
being determined from the flavor parameter (which is meaningless
here). They correspond to the effective upper bound of phase space
due to a resonance, as opposed to the absolute upper bound.
<<Mappings: mapping: TBP>>=
procedure :: set_step_mapping_parameters => &
mapping_set_step_mapping_parameters
<<Mappings: sub interfaces>>=
module subroutine mapping_set_step_mapping_parameters (map, &
mass, width, variable_limits)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: mass, width
logical, intent(in) :: variable_limits
end subroutine mapping_set_step_mapping_parameters
<<Mappings: procedures>>=
module subroutine mapping_set_step_mapping_parameters (map, &
mass, width, variable_limits)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: mass, width
logical, intent(in) :: variable_limits
select case (map%type)
case (STEP_MAPPING_E, STEP_MAPPING_H)
map%variable_limits = variable_limits
map%a_unknown = .true.
map%b_unknown = .true.
map%mass = mass
map%width = width
end select
end subroutine mapping_set_step_mapping_parameters
@ %def mapping_set_step_mapping_parameters
@
\subsection{Retrieve contents}
Return true if there is any / an s-channel mapping.
<<Mappings: mapping: TBP>>=
procedure :: is_set => mapping_is_set
procedure :: is_s_channel => mapping_is_s_channel
procedure :: is_on_shell => mapping_is_on_shell
<<Mappings: sub interfaces>>=
module function mapping_is_set (mapping) result (flag)
class(mapping_t), intent(in) :: mapping
logical :: flag
end function mapping_is_set
module function mapping_is_s_channel (mapping) result (flag)
class(mapping_t), intent(in) :: mapping
logical :: flag
end function mapping_is_s_channel
module function mapping_is_on_shell (mapping) result (flag)
class(mapping_t), intent(in) :: mapping
logical :: flag
end function mapping_is_on_shell
<<Mappings: procedures>>=
module function mapping_is_set (mapping) result (flag)
class(mapping_t), intent(in) :: mapping
logical :: flag
flag = mapping%type /= NO_MAPPING
end function mapping_is_set
module function mapping_is_s_channel (mapping) result (flag)
class(mapping_t), intent(in) :: mapping
logical :: flag
flag = mapping%type == S_CHANNEL
end function mapping_is_s_channel
module function mapping_is_on_shell (mapping) result (flag)
class(mapping_t), intent(in) :: mapping
logical :: flag
flag = mapping%type == ON_SHELL
end function mapping_is_on_shell
@ %def mapping_is_set
@ %def mapping_is_s_channel
@ %def mapping_is_on_shell
@ Return the binary code for the mapped particle.
<<Mappings: mapping: TBP>>=
procedure :: get_bincode => mapping_get_bincode
<<Mappings: sub interfaces>>=
module function mapping_get_bincode (mapping) result (bincode)
class(mapping_t), intent(in) :: mapping
integer(TC) :: bincode
end function mapping_get_bincode
<<Mappings: procedures>>=
module function mapping_get_bincode (mapping) result (bincode)
class(mapping_t), intent(in) :: mapping
integer(TC) :: bincode
bincode = mapping%bincode
end function mapping_get_bincode
@ %def mapping_get_bincode
@ Return the flavor object for the mapped particle.
<<Mappings: mapping: TBP>>=
procedure :: get_flv => mapping_get_flv
<<Mappings: sub interfaces>>=
module function mapping_get_flv (mapping) result (flv)
class(mapping_t), intent(in) :: mapping
type(flavor_t) :: flv
end function mapping_get_flv
<<Mappings: procedures>>=
module function mapping_get_flv (mapping) result (flv)
class(mapping_t), intent(in) :: mapping
type(flavor_t) :: flv
flv = mapping%flv
end function mapping_get_flv
@ %def mapping_get_flv
@ Return stored mass and width, respectively.
<<Mappings: mapping: TBP>>=
procedure :: get_mass => mapping_get_mass
procedure :: get_width => mapping_get_width
<<Mappings: sub interfaces>>=
module function mapping_get_mass (mapping) result (mass)
class(mapping_t), intent(in) :: mapping
real(default) :: mass
end function mapping_get_mass
module function mapping_get_width (mapping) result (width)
class(mapping_t), intent(in) :: mapping
real(default) :: width
end function mapping_get_width
<<Mappings: procedures>>=
module function mapping_get_mass (mapping) result (mass)
class(mapping_t), intent(in) :: mapping
real(default) :: mass
mass = mapping%mass
end function mapping_get_mass
module function mapping_get_width (mapping) result (width)
class(mapping_t), intent(in) :: mapping
real(default) :: width
width = mapping%width
end function mapping_get_width
@ %def mapping_get_mass
@ %def mapping_get_width
@
\subsection{Compare mappings}
Equality for single mappings and arrays
<<Mappings: public>>=
public :: operator(==)
<<Mappings: interfaces>>=
interface operator(==)
module procedure mapping_equal
end interface
<<Mappings: sub interfaces>>=
module function mapping_equal (m1, m2) result (equal)
type(mapping_t), intent(in) :: m1, m2
logical :: equal
end function mapping_equal
<<Mappings: procedures>>=
module function mapping_equal (m1, m2) result (equal)
type(mapping_t), intent(in) :: m1, m2
logical :: equal
if (m1%type == m2%type) then
select case (m1%type)
case (NO_MAPPING)
equal = .true.
case (S_CHANNEL, RADIATION, STEP_MAPPING_E, STEP_MAPPING_H)
equal = (m1%mass == m2%mass) .and. (m1%width == m2%width)
case default
equal = (m1%mass == m2%mass)
end select
else
equal = .false.
end if
end function mapping_equal
@ %def mapping_equal
@
\subsection{Mappings of the invariant mass}
Inserting an $x$ value between 0 and 1, we want to compute the
corresponding invariant mass $m^2(x)$ and the jacobian, aka phase
space factor $f(x)$. We also need the reverse operation.
In general, the phase space factor $f$ is defined by
\begin{equation}
\frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2)
= \int_0^1 dx\,\frac{1}{s}\,\frac{dm^2}{dx}\,g(m^2(x))
= \int_0^1 dx\,f(x)\,g(x),
\end{equation}
where thus
\begin{equation}
f(x) = \frac{1}{s}\,\frac{dm^2}{dx}.
\end{equation}
With this mapping, a function of the form
\begin{equation}
g(m^2) = c\frac{dx(m^2)}{dm^2}
\end{equation}
is mapped to a constant:
\begin{equation}
\frac{1}{s}\int_{m^2_{\textrm{min}}}^{m^2_{\textrm{max}}} dm^2\,g(m^2)
= \int_0^1 dx\,f(x)\,g(m^2(x)) = \int_0^1 dx\,\frac{c}{s}.
\end{equation}
Here is the mapping routine. Input are the available energy
squared [[s]], the limits for $m^2$, and the $x$ value. Output are
the $m^2$ value and the phase space factor $f$.
<<Mappings: mapping: TBP>>=
procedure :: compute_msq_from_x => mapping_compute_msq_from_x
<<Mappings: sub interfaces>>=
module subroutine mapping_compute_msq_from_x &
(map, s, msq_min, msq_max, msq, f, x)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: s, msq_min, msq_max
real(default), intent(out) :: msq, f
real(default), intent(in) :: x
end subroutine mapping_compute_msq_from_x
<<Mappings: procedures>>=
module subroutine mapping_compute_msq_from_x &
(map, s, msq_min, msq_max, msq, f, x)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: s, msq_min, msq_max
real(default), intent(out) :: msq, f
real(default), intent(in) :: x
real(default) :: z, msq0, msq1, tmp
integer :: type
type = map%type
if (s == 0) &
call msg_fatal (" Applying msq mapping for zero energy")
<<Modify mapping type if necessary>>
select case(type)
case (NO_MAPPING)
<<Constants for trivial msq mapping>>
<<Apply trivial msq mapping>>
case (S_CHANNEL)
<<Constants for s-channel resonance mapping>>
<<Apply s-channel resonance mapping>>
case (COLLINEAR, INFRARED, RADIATION)
<<Constants for s-channel pole mapping>>
<<Apply s-channel pole mapping>>
case (T_CHANNEL, U_CHANNEL)
<<Constants for t-channel pole mapping>>
<<Apply t-channel pole mapping>>
case (STEP_MAPPING_E)
<<Constants for exponential step mapping>>
<<Apply exponential step mapping>>
case (STEP_MAPPING_H)
<<Constants for hyperbolic step mapping>>
<<Apply hyperbolic step mapping>>
case default
call msg_fatal ( " Attempt to apply undefined msq mapping")
end select
end subroutine mapping_compute_msq_from_x
@ %def mapping_compute_msq_from_x
@ The inverse mapping
<<Mappings: mapping: TBP>>=
procedure :: compute_x_from_msq => mapping_compute_x_from_msq
<<Mappings: sub interfaces>>=
module subroutine mapping_compute_x_from_msq &
(map, s, msq_min, msq_max, msq, f, x)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: s, msq_min, msq_max
real(default), intent(in) :: msq
real(default), intent(out) :: f, x
end subroutine mapping_compute_x_from_msq
<<Mappings: procedures>>=
module subroutine mapping_compute_x_from_msq &
(map, s, msq_min, msq_max, msq, f, x)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: s, msq_min, msq_max
real(default), intent(in) :: msq
real(default), intent(out) :: f, x
real(default) :: msq0, msq1, tmp, z
integer :: type
type = map%type
if (s == 0) &
call msg_fatal (" Applying inverse msq mapping for zero energy")
<<Modify mapping type if necessary>>
select case (type)
case (NO_MAPPING)
<<Constants for trivial msq mapping>>
<<Apply inverse trivial msq mapping>>
case (S_CHANNEL)
<<Constants for s-channel resonance mapping>>
<<Apply inverse s-channel resonance mapping>>
case (COLLINEAR, INFRARED, RADIATION)
<<Constants for s-channel pole mapping>>
<<Apply inverse s-channel pole mapping>>
case (T_CHANNEL, U_CHANNEL)
<<Constants for t-channel pole mapping>>
<<Apply inverse t-channel pole mapping>>
case (STEP_MAPPING_E)
<<Constants for exponential step mapping>>
<<Apply inverse exponential step mapping>>
case (STEP_MAPPING_H)
<<Constants for hyperbolic step mapping>>
<<Apply inverse hyperbolic step mapping>>
case default
call msg_fatal ( " Attempt to apply undefined msq mapping")
end select
end subroutine mapping_compute_x_from_msq
@ %def mapping_compute_x_from_msq
@
\subsubsection{Trivial mapping}
We simply map the boundaries of the interval $(m_{\textrm{min}},
m_{\textrm{max}})$ to $(0,1)$:
\begin{equation}
m^2 = (1-x) m_{\textrm{min}}^2 + x m_{\textrm{max}}^2;
\end{equation}
the inverse is
\begin{equation}
x = \frac{m^2 - m_{\textrm{min}}^2}{m_{\textrm{max}}^2- m_{\textrm{min}}^2}.
\end{equation}
Hence
\begin{equation}
f(x) = \frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{s},
\end{equation}
and we have, as required,
\begin{equation}
f(x)\,\frac{dx}{dm^2} = \frac{1}{s}.
\end{equation}
We store the constant parameters the first time the mapping is called
-- or, if limits vary, recompute them each time.
<<Constants for trivial msq mapping>>=
if (map%variable_limits .or. map%a_unknown) then
map%a1 = 0
map%a2 = msq_max - msq_min
map%a3 = map%a2 / s
map%a_unknown = .false.
end if
<<Apply trivial msq mapping>>=
msq = (1-x) * msq_min + x * msq_max
f = map%a3
<<Apply inverse trivial msq mapping>>=
if (map%a2 /= 0) then
x = (msq - msq_min) / map%a2
else
x = 0
end if
f = map%a3
@ Resonance or step mapping does not make much sense if the resonance mass is
outside the kinematical bounds. If this is the case, revert to
[[NO_MAPPING]]. This is possible even if the kinematical bounds vary
from event to event.
<<Modify mapping type if necessary>>=
select case (type)
case (S_CHANNEL, STEP_MAPPING_E, STEP_MAPPING_H)
msq0 = map%mass**2
if (msq0 < msq_min .or. msq0 > msq_max) type = NO_MAPPING
end select
@
\subsubsection{Breit-Wigner mapping}
A Breit-Wigner resonance with mass $M$ and width $\Gamma$ is flattened
by the following mapping:
This mapping does not make much sense if the resonance mass is too low.
If this is the case, revert to [[NO_MAPPING]]. There is a tricky
point with this if the mass is too high: [[msq_max]] is not a
constant if structure functions are around. However, switching the
type depending on the overall energy does not change the integral, it
is just another branching point.
\begin{equation}
m^2 = M(M+t\Gamma),
\end{equation}
where
\begin{equation}
t = \tan\left[(1-x)\arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}
+ x \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}\right].
\end{equation}
The inverse:
\begin{equation}
x = \frac{ \arctan\frac{m^2 - M^2}{M\Gamma}
- \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}}
{ \arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}
- \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}}
\end{equation}
The phase-space factor of this transformation is
\begin{equation}
f(x) = \frac{M\Gamma}{s}\left(
\arctan\frac{m^2_{\textrm{max}} - M^2}{M\Gamma}
- \arctan\frac{m^2_{\textrm{min}} - M^2}{M\Gamma}\right)
(1 + t^2).
\end{equation}
This maps any function proportional to
\begin{equation}
g(m^2) = \frac{M\Gamma}{(m^2-M^2)^2 + M^2\Gamma^2}
\end{equation}
to a constant times $1/s$.
<<Constants for s-channel resonance mapping>>=
if (map%variable_limits .or. map%a_unknown) then
msq0 = map%mass ** 2
map%a1 = atan ((msq_min - msq0) / (map%mass * map%width))
map%a2 = atan ((msq_max - msq0) / (map%mass * map%width))
map%a3 = (map%a2 - map%a1) * (map%mass * map%width) / s
map%a_unknown = .false.
end if
<<Apply s-channel resonance mapping>>=
z = (1-x) * map%a1 + x * map%a2
if (-pi/2 < z .and. z < pi/2) then
tmp = tan (z)
msq = map%mass * (map%mass + map%width * tmp)
f = map%a3 * (1 + tmp**2)
else
msq = 0
f = 0
end if
<<Apply inverse s-channel resonance mapping>>=
tmp = (msq - msq0) / (map%mass * map%width)
x = (atan (tmp) - map%a1) / (map%a2 - map%a1)
f = map%a3 * (1 + tmp**2)
@
\subsubsection{Mapping for massless splittings}
This mapping accounts for approximately scale-invariant behavior where
$\ln M^2$ is evenly distributed.
\begin{equation}
m^2 = m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right)
\end{equation}
where
\begin{equation}
L = \ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{M^2} + 1\right).
\end{equation}
The inverse:
\begin{equation}
x = \frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right)
\end{equation}
The constant $M$ is a characteristic scale. Above this scale
($m^2-m_{\textrm{min}}^2 \gg M^2$), this mapping behaves like
$x\propto\ln m^2$, while below the scale it reverts to a linear
mapping.
The phase-space factor is
\begin{equation}
f(x) = \frac{M^2}{s}\,\exp(xL)\,L.
\end{equation}
A function proportional to
\begin{equation}
g(m^2) = \frac{1}{(m^2-m_{\textrm{min}}^2) + M^2}
\end{equation}
is mapped to a constant, i.e., a simple pole near $m_{\textrm{min}}$
with a regulator mass $M$.
This type of mapping is useful for massless collinear and infrared
singularities, where the scale is stored as the mass parameter. In
the radiation case (IR radiation off massive particle), the heavy
particle width is the characteristic scale.
<<Constants for s-channel pole mapping>>=
if (map%variable_limits .or. map%a_unknown) then
if (type == RADIATION) then
msq0 = map%width**2
else
msq0 = map%mass**2
end if
map%a1 = msq0
map%a2 = log ((msq_max - msq_min) / msq0 + 1)
map%a3 = map%a2 / s
map%a_unknown = .false.
end if
<<Apply s-channel pole mapping>>=
msq1 = map%a1 * exp (x * map%a2)
msq = msq1 - map%a1 + msq_min
f = map%a3 * msq1
<<Apply inverse s-channel pole mapping>>=
msq1 = msq - msq_min + map%a1
x = log (msq1 / map%a1) / map%a2
f = map%a3 * msq1
@
\subsubsection{Mapping for t-channel poles}
This is also approximately scale-invariant, and we use the same type
of mapping as before. However, we map $1/x$ singularities at both
ends of the interval; again, the mapping becomes linear when the
distance is less than $M^2$:
\begin{equation}
m^2 =
\begin{cases}
m_{\textrm{min}}^2 + M^2\left(\exp(xL)-1\right)
&
\text{for $0 < x < \frac12$}
\\
m_{\textrm{max}}^2 - M^2\left(\exp((1-x)L)-1\right)
&
\text{for $\frac12 \leq x < 1$}
\end{cases}
\end{equation}
where
\begin{equation}
L = 2\ln\left(\frac{m_{\textrm{max}}^2 - m_{\textrm{min}}^2}{2M^2}
+ 1\right).
\end{equation}
The inverse:
\begin{equation}
x =
\begin{cases}
\frac1L\ln\left(\frac{m^2-m_{\textrm{min}}^2}{M^2} + 1\right)
&
\text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
\\
1 - \frac1L\ln\left(\frac{m_{\textrm{max}}-m^2}{M^2} + 1\right)
&
\text{for $m^2 \geq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
\end{cases}
\end{equation}
The phase-space factor is
\begin{equation}
f(x) =
\begin{cases}
\frac{M^2}{s}\,\exp(xL)\,L.
&
\text{for $0 < x < \frac12$}
\\
\frac{M^2}{s}\,\exp((1-x)L)\,L.
&
\text{for $\frac12 \leq x < 1$}
\end{cases}
\end{equation}
A (continuous) function proportional to
\begin{equation}
g(m^2) =
\begin{cases}
1/(m^2-m_{\textrm{min}}^2) + M^2)
&
\text{for $m^2 < (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
\\
1/((m_{\textrm{max}}^2 - m^2) + M^2)
&
\text{for $m^2 \leq (m_{\textrm{max}}^2 - m_{\textrm{min}}^2)/2$}
\end{cases}
\end{equation}
is mapped to a constant by this mapping, i.e., poles near both ends of
the interval.
<<Constants for t-channel pole mapping>>=
if (map%variable_limits .or. map%a_unknown) then
msq0 = map%mass**2
map%a1 = msq0
map%a2 = 2 * log ((msq_max - msq_min)/(2*msq0) + 1)
map%a3 = map%a2 / s
map%a_unknown = .false.
end if
<<Apply t-channel pole mapping>>=
if (x < .5_default) then
msq1 = map%a1 * exp (x * map%a2)
msq = msq1 - map%a1 + msq_min
else
msq1 = map%a1 * exp ((1-x) * map%a2)
msq = -(msq1 - map%a1) + msq_max
end if
f = map%a3 * msq1
<<Apply inverse t-channel pole mapping>>=
if (msq < (msq_max + msq_min)/2) then
msq1 = msq - msq_min + map%a1
x = log (msq1/map%a1) / map%a2
else
msq1 = msq_max - msq + map%a1
x = 1 - log (msq1/map%a1) / map%a2
end if
f = map%a3 * msq1
@
\subsection{Step mapping}
Step mapping is useful when the allowed range for a squared-mass
variable is large, but only a fraction at the lower end is populated
because the particle in question is an (off-shell) decay product of a
narrow resonance. I.e., if the resonance was forced to be on-shell,
the upper end of the range would be the resonance mass, minus the
effective (real or resonance) mass of the particle(s) in the sibling
branch of the decay.
The edge of this phase space section has a width which is determined
by the width of the parent, plus the width of the sibling branch. (The
widths might be added in quadrature, but this precision is probably
not important.)
\subsubsection{Fermi function}
A possible mapping is derived from the Fermi function which has
precisely this behavior. The Fermi function is given by
\begin{equation}
f(x) = \frac{1}{1 + \exp\frac{x-\mu}{\gamma}}
\end{equation}
where $x$ is taken as the invariant mass squared, $\mu$ is the
invariant mass squared of the edge, and $\gamma$ is the effective
width which is given by the widths of the parent and the sibling
branch. (Widths might be added in quadrature, but we do not require
this level of precision.)
\begin{align}
x &= \frac{m^2 - m_{\text{min}}^2}{\Delta m^2}
\\
\mu &=
\frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2}
{\Delta m^2}
\\
\gamma &= \frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2}
\end{align}
with
\begin{equation}
\Delta m^2 = m_{\text{max}}^2 - m_{\text{min}}^2
\end{equation}
$m^2$ is thus given by
\begin{equation}
m^2(x) = xm_{\text{max}}^2 + (1-x)m_{\text{min}}^2
\end{equation}
For the mapping, we compute the integral $g(x)$ of the Fermi function,
normalized such that $g(0)=0$ and $g(1)=1$. We introduce the abbreviations
\begin{align}
\alpha &= 1 - \gamma\ln\frac{1 + \beta e^{1/\gamma}}{1 + \beta}
\\
\beta &= e^{- \mu/\gamma}
\end{align}
and obtain
\begin{equation}
g(x) = \frac{1}{\alpha}
\left(x - \gamma\ln\frac{1 + \beta e^{x/\gamma}}
{1 + \beta}\right)
\end{equation}
The actual mapping is the inverse function $h(y) = g^{-1}(y)$,
\begin{equation}
h(y) = -\gamma\ln\left(e^{-\alpha y/\gamma}(1 + \beta) - \beta\right)
\end{equation}
The Jacobian is
\begin{equation}
\frac{dh}{dy} = \alpha\left(1 - e^{\alpha y/\gamma}
\frac{\beta}{1 + \beta}\right)^{-1}
\end{equation}
which is equal to $1/(dg/dx)$, namely
\begin{equation}
\frac{dg}{dx} = \frac{1}{\alpha}\,\frac{1}{1 + \beta e^{x/\gamma}}
\end{equation}
The final result is
\begin{align}
\int_{m_{\text{min}}^2}^{m_{\text{max}}^2} dm^2\,F(m^2)
&= \Delta m^2\int_0^1\,dx\,F(m^2(x))
\\
&= \Delta m^2\int_0^1\,dy\,F(m^2(h(y)))\,\frac{dh}{dy}
\end{align}
Here is the implementation. We fill [[a1]], [[a2]], [[a3]] with
$\alpha,\beta,\gamma$, respectively.
<<Constants for exponential step mapping>>=
if (map%variable_limits .or. map%a_unknown) then
map%a3 = max (2 * map%mass * map%width / (msq_max - msq_min), 0.01_default)
map%a2 = exp (- (map%mass**2 - msq_min) / (msq_max - msq_min) &
/ map%a3)
map%a1 = 1 - map%a3 * log ((1 + map%a2 * exp (1 / map%a3)) / (1 + map%a2))
end if
<<Apply exponential step mapping>>=
tmp = exp (- x * map%a1 / map%a3) * (1 + map%a2)
z = - map%a3 * log (tmp - map%a2)
msq = z * msq_max + (1 - z) * msq_min
f = map%a1 / (1 - map%a2 / tmp) * (msq_max - msq_min) / s
<<Apply inverse exponential step mapping>>=
z = (msq - msq_min) / (msq_max - msq_min)
tmp = 1 + map%a2 * exp (z / map%a3)
x = (z - map%a3 * log (tmp / (1 + map%a2))) &
/ map%a1
f = map%a1 * tmp * (msq_max - msq_min) / s
@
\subsubsection{Hyperbolic mapping}
The Fermi function has the drawback that it decreases exponentially.
It might be preferable to take a function with a power-law decrease,
such that the high-mass region is not completely depopulated.
Here, we start with the actual mapping which we take as
\begin{equation}
h(y) = \frac{b}{a-y} - \frac{b}{a} + \mu y
\end{equation}
with the abbreviation
\begin{equation}
a = \frac12\left(1 + \sqrt{1 + \frac{4b}{1-\mu}}\right)
\end{equation}
This is a hyperbola in the $xy$ plane. The derivative is
\begin{equation}
\frac{dh}{dy} = \frac{b}{(a-y)^2} + \mu
\end{equation}
The constants correspond to
\begin{align}
\mu &=
\frac{m_{\text{max,eff}}^2 - m_{\text{min}}^2}
{\Delta m^2}
\\
b &= \frac{1}{\mu}\left(\frac{2m_{\text{max,eff}}\Gamma}{\Delta m^2}\right)^2
\end{align}
The inverse function is the solution of a quadratic equation,
\begin{equation}
g(x) = \frac{1}{2}
\left[\left(a + \frac{x}{\mu} + \frac{b}{a\mu}\right)
- \sqrt{\left(a-\frac{x}{\mu}\right)^2
+ 2\frac{b}{a\mu}\left(a + \frac{x}{\mu}\right)
+ \left(\frac{b}{a\mu}\right)^2}\right]
\end{equation}
The constants $a_{1,2,3}$ are identified with $a,b,\mu$.
<<Constants for hyperbolic step mapping>>=
if (map%variable_limits .or. map%a_unknown) then
map%a3 = (map%mass**2 - msq_min) / (msq_max - msq_min)
map%a2 = max ((2 * map%mass * map%width / (msq_max - msq_min))**2 &
/ map%a3, 1e-6_default)
map%a1 = (1 + sqrt (1 + 4 * map%a2 / (1 - map%a3))) / 2
end if
<<Apply hyperbolic step mapping>>=
z = map%a2 / (map%a1 - x) - map%a2 / map%a1 + map%a3 * x
msq = z * msq_max + (1 - z) * msq_min
f = (map%a2 / (map%a1 - x)**2 + map%a3) * (msq_max - msq_min) / s
<<Apply inverse hyperbolic step mapping>>=
z = (msq - msq_min) / (msq_max - msq_min)
tmp = map%a2 / (map%a1 * map%a3)
x = ((map%a1 + z / map%a3 + tmp) &
- sqrt ((map%a1 - z / map%a3)**2 + 2 * tmp * (map%a1 + z / map%a3) &
+ tmp**2)) / 2
f = (map%a2 / (map%a1 - x)**2 + map%a3) * (msq_max - msq_min) / s
@
\subsection{Mappings of the polar angle}
The other type of singularity, a simple pole just outside the
integration region, can occur in the integration over $\cos\theta$.
This applies to exchange of massless (or light) particles.
Double poles (Coulomb scattering) are also possible, but only in
certain cases. These are also handled by the single-pole mapping.
The mapping is analogous to the previous $m^2$ pole mapping, but with
a different normalization and notation of variables:
\begin{equation}
\frac12\int_{-1}^1 d\cos\theta\,g(\theta)
= \int_0^1 dx\,\frac{d\cos\theta}{dx}\,g(\theta(x))
= \int_0^1 dx\,f(x)\,g(x),
\end{equation}
where thus
\begin{equation}
f(x) = \frac12\,\frac{d\cos\theta}{dx}.
\end{equation}
With this mapping, a function of the form
\begin{equation}
g(\theta) = c\frac{dx(\cos\theta)}{d\cos\theta}
\end{equation}
is mapped to a constant:
\begin{equation}
\int_{-1}^1 d\cos\theta\,g(\theta)
= \int_0^1 dx\,f(x)\,g(\theta(x)) = \int_0^1 dx\,c.
\end{equation}
<<Mappings: mapping: TBP>>=
procedure :: compute_ct_from_x => mapping_compute_ct_from_x
<<Mappings: sub interfaces>>=
module subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: s
real(default), intent(out) :: ct, st, f
real(default), intent(in) :: x
end subroutine mapping_compute_ct_from_x
<<Mappings: procedures>>=
module subroutine mapping_compute_ct_from_x (map, s, ct, st, f, x)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: s
real(default), intent(out) :: ct, st, f
real(default), intent(in) :: x
real(default) :: tmp, ct1
select case (map%type)
case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, &
STEP_MAPPING_E, STEP_MAPPING_H)
<<Apply trivial ct mapping>>
case (T_CHANNEL, U_CHANNEL, COLLINEAR)
<<Constants for ct pole mapping>>
<<Apply ct pole mapping>>
case default
call msg_fatal (" Attempt to apply undefined ct mapping")
end select
end subroutine mapping_compute_ct_from_x
@ %def mapping_compute_ct_from_x
<<Mappings: mapping: TBP>>=
procedure :: compute_x_from_ct => mapping_compute_x_from_ct
<<Mappings: sub interfaces>>=
module subroutine mapping_compute_x_from_ct (map, s, ct, f, x)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: s
real(default), intent(in) :: ct
real(default), intent(out) :: f, x
end subroutine mapping_compute_x_from_ct
<<Mappings: procedures>>=
module subroutine mapping_compute_x_from_ct (map, s, ct, f, x)
class(mapping_t), intent(inout) :: map
real(default), intent(in) :: s
real(default), intent(in) :: ct
real(default), intent(out) :: f, x
real(default) :: ct1
select case (map%type)
case (NO_MAPPING, S_CHANNEL, INFRARED, RADIATION, &
STEP_MAPPING_E, STEP_MAPPING_H)
<<Apply inverse trivial ct mapping>>
case (T_CHANNEL, U_CHANNEL, COLLINEAR)
<<Constants for ct pole mapping>>
<<Apply inverse ct pole mapping>>
case default
call msg_fatal (" Attempt to apply undefined inverse ct mapping")
end select
end subroutine mapping_compute_x_from_ct
@ %def mapping_compute_x_from_ct
@
\subsubsection{Trivial mapping}
This is just the mapping of the interval $(-1,1)$ to $(0,1)$:
\begin{equation}
\cos\theta = -1 + 2x
\end{equation}
and
\begin{equation}
f(x) = 1
\end{equation}
with the inverse
\begin{equation}
x = \frac{1+\cos\theta}{2}
\end{equation}
<<Apply trivial ct mapping>>=
tmp = 2 * (1-x)
ct = 1 - tmp
st = sqrt (tmp * (2-tmp))
f = 1
<<Apply inverse trivial ct mapping>>=
x = (ct + 1) / 2
f = 1
@
\subsubsection{Pole mapping}
As above for $m^2$, we simultaneously map poles at both ends of the
$\cos\theta$ interval. The formulae are completely analogous:
\begin{equation}
\cos\theta =
\begin{cases}
\frac{M^2}{s}\left[\exp(xL)-1\right] - 1
&
\text{for $x<\frac12$}
\\
-\frac{M^2}{s}\left[\exp((1-x)L)-1\right] + 1
&
\text{for $x\geq\frac12$}
\end{cases}
\end{equation}
where
\begin{equation}
L = 2\ln\frac{M^2+s}{M^2}.
\end{equation}
Inverse:
\begin{equation}
x =
\begin{cases}
\frac{1}{2L}\ln\frac{1 + \cos\theta + M^2/s}{M^2/s}
&
\text{for $\cos\theta < 0$}
\\
1 - \frac{1}{2L}\ln\frac{1 - \cos\theta + M^2/s}{M^2/s}
&
\text{for $\cos\theta \geq 0$}
\end{cases}
\end{equation}
The phase-space factor:
\begin{equation}
f(x) =
\begin{cases}
\frac{M^2}{s}\exp(xL)\,L
&
\text{for $x<\frac12$}
\\
\frac{M^2}{s}\exp((1-x)L)\,L
&
\text{for $x\geq\frac12$}
\end{cases}
\end{equation}
<<Constants for ct pole mapping>>=
if (map%variable_limits .or. map%b_unknown) then
map%b1 = map%mass**2 / s
map%b2 = log ((map%b1 + 1) / map%b1)
map%b3 = 0
map%b_unknown = .false.
end if
<<Apply ct pole mapping>>=
if (x < .5_default) then
ct1 = map%b1 * exp (2 * x * map%b2)
ct = ct1 - map%b1 - 1
else
ct1 = map%b1 * exp (2 * (1-x) * map%b2)
ct = -(ct1 - map%b1) + 1
end if
if (ct >= -1 .and. ct <= 1) then
st = sqrt (1 - ct**2)
f = ct1 * map%b2
else
ct = 1; st = 0; f = 0
end if
<<Apply inverse ct pole mapping>>=
if (ct < 0) then
ct1 = ct + map%b1 + 1
x = log (ct1 / map%b1) / (2 * map%b2)
else
ct1 = -ct + map%b1 + 1
x = 1 - log (ct1 / map%b1) / (2 * map%b2)
end if
f = ct1 * map%b2
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\clearpage
\section{Phase-space trees}
The phase space evaluation is organized in terms of trees, where each
branch corresponds to three integrations: $m^2$, $\cos\theta$, and
$\phi$. The complete tree thus makes up a specific parameterization
of the multidimensional phase-space integral. For the multi-channel
integration, the phase-space tree is a single channel.
The trees imply mappings of formal Feynman tree graphs into arrays of
integer numbers: Each branch, corresponding to a particular line in
the graph, is assigned an integer code $c$ (with kind value [[TC]] =
tree code).
In this integer, each bit determines whether a particular external
momentum flows through the line. The external branches therefore have
codes $1,2,4,8,\ldots$. An internal branch has those bits ORed
corresponding to the momenta flowing through it. For example, a
branch with momentum $p_1+p_4$ has code $2^0+2^3=1+8=9$.
There is a two-fold ambiguity: Momentum conservation implies that the
branch with code
\begin{equation}
c_0 = \sum_{i=1}^{n(\rm{ext})} 2^{i-1}
\end{equation}
i.e. the branch with momentum $p_1+p_2+\ldots p_n$ has momentum zero,
which is equivalent to tree code $0$ by definition. Correspondingly,
\begin{equation}
c \quad\textrm{and}\quad c_0 - c = c\;\textrm{XOR}\;c_0
\end{equation}
are equivalent. E.g., if there are five externals with codes
$c=1,2,4,8,16$, then $c=9$ and $\bar c=31-9=22$ are equivalent.
This ambiguity may be used to assign a direction to the line: If all
momenta are understood as outgoing, $c=9$ in the example above means
$p_1+p_4$, but $c=22$ means $p_2+p_3+p_5 = -(p_1+p_4)$.
Here we make use of the ambiguity in a slightly different way. First,
the initial particles are singled out as those externals with the
highest bits, the IN-bits. (Here: $8$ and $16$ for a $2\to 3$
scattering process, $16$ only for a $1\to 4$ decay.) Then we invert
those codes where all IN-bits are set. For a decay process this maps
each tree of an equivalence class onto a unique representative (that one
with the smallest integer codes). For a scattering process we proceed
further:
The ambiguity remains in all branches where only one IN-bit is set,
including the initial particles. If there are only externals with
this property, we have an $s$-channel graph which we leave as it is.
In all other cases, an internal with only one IN-bit is a $t$-channel
line, which for phase space integration should be associated with one
of the initial momenta as a reference axis. We take that one whose
bit is set in the current tree code. (E.g., for branch $c=9$ we use
the initial particle $c=8$ as reference axis, whereas for the same
branch we would take $c=16$ if it had been assigned $\bar c=31-9=22$
as tree code.) Thus, different ways of coding the same $t$-channel
graph imply different phase space parameterizations.
$s$-channel graphs have a unique parameterization. The same sets of
parameterizations are used for $t$-channel graphs, except for the
reference frames of their angular parts. We map each
$t$-channel graph onto an $s$-channel graph as follows:
Working in ascending order, for each $t$-channel line (whose code has
exactly one IN-bit set) the attached initial line is flipped upstream,
while the outgoing line is flipped downstream. (This works only if
$t$-channel graphs are always parameterized beginning at their outer
vertices, which we require as a restriction.) After all possible
flips have been applied, we have an $s$-channel graph. We only have
to remember the initial particle a vertex was originally attached to.
<<[[phs_trees.f90]]>>=
<<File header>>
module phs_trees
<<Use kinds>>
use kinds, only: TC
<<Use strings>>
use lorentz
use permutations, only: permutation_t, permutation_size
use permutations, only: permutation_init, permutation_find
use permutations, only: tc_decay_level, tc_permute
use model_data
use flavors
use resonances, only: resonance_history_t, resonance_info_t
use mappings
<<Standard module head>>
<<PHS trees: public>>
<<PHS trees: types>>
interface
<<PHS trees: sub interfaces>>
end interface
end module phs_trees
@ %def phs_trees
@
<<[[phs_trees_sub.f90]]>>=
<<File header>>
submodule (phs_trees) phs_trees_s
use io_units
use constants, only: twopi, twopi2, twopi5
use format_defs, only: FMT_19
use numeric_utils, only: vanishes
use diagnostics
implicit none
contains
<<PHS trees: procedures>>
end submodule phs_trees_s
@ %def phs_trees_s
@
\subsection{Particles}
We define a particle type which contains only four-momentum and
invariant mass squared, and a flag that tells whether the momentum is
filled or not.
<<PHS trees: public>>=
public :: phs_prt_t
<<PHS trees: types>>=
type :: phs_prt_t
private
logical :: defined = .false.
type(vector4_t) :: p
real(default) :: p2
contains
<<PHS trees: prt: TBP>>
end type phs_prt_t
@ %def phs_prt_t
@ Set contents:
<<PHS trees: prt: TBP>>=
procedure :: set_defined => phs_prt_set_defined
procedure :: set_undefined => phs_prt_set_undefined
procedure :: set_momentum => phs_prt_set_momentum
procedure :: set_msq => phs_prt_set_msq
<<PHS trees: sub interfaces>>=
elemental module subroutine phs_prt_set_defined (prt)
class(phs_prt_t), intent(inout) :: prt
end subroutine phs_prt_set_defined
elemental module subroutine phs_prt_set_undefined (prt)
class(phs_prt_t), intent(inout) :: prt
end subroutine phs_prt_set_undefined
elemental module subroutine phs_prt_set_momentum (prt, p)
class(phs_prt_t), intent(inout) :: prt
type(vector4_t), intent(in) :: p
end subroutine phs_prt_set_momentum
elemental module subroutine phs_prt_set_msq (prt, p2)
class(phs_prt_t), intent(inout) :: prt
real(default), intent(in) :: p2
end subroutine phs_prt_set_msq
<<PHS trees: procedures>>=
elemental module subroutine phs_prt_set_defined (prt)
class(phs_prt_t), intent(inout) :: prt
prt%defined = .true.
end subroutine phs_prt_set_defined
elemental module subroutine phs_prt_set_undefined (prt)
class(phs_prt_t), intent(inout) :: prt
prt%defined = .false.
end subroutine phs_prt_set_undefined
elemental module subroutine phs_prt_set_momentum (prt, p)
class(phs_prt_t), intent(inout) :: prt
type(vector4_t), intent(in) :: p
prt%p = p
end subroutine phs_prt_set_momentum
elemental module subroutine phs_prt_set_msq (prt, p2)
class(phs_prt_t), intent(inout) :: prt
real(default), intent(in) :: p2
prt%p2 = p2
end subroutine phs_prt_set_msq
@ %def phs_prt_set_defined phs_prt_set_momentum phs_prt_set_msq
@ Access methods:
<<PHS trees: prt: TBP>>=
procedure :: is_defined => phs_prt_is_defined
procedure :: get_momentum => phs_prt_get_momentum
procedure :: get_msq => phs_prt_get_msq
<<PHS trees: sub interfaces>>=
elemental module function phs_prt_is_defined (prt) result (defined)
logical :: defined
class(phs_prt_t), intent(in) :: prt
end function phs_prt_is_defined
elemental module function phs_prt_get_momentum (prt) result (p)
type(vector4_t) :: p
class(phs_prt_t), intent(in) :: prt
end function phs_prt_get_momentum
elemental module function phs_prt_get_msq (prt) result (p2)
real(default) :: p2
class(phs_prt_t), intent(in) :: prt
end function phs_prt_get_msq
<<PHS trees: procedures>>=
elemental module function phs_prt_is_defined (prt) result (defined)
logical :: defined
class(phs_prt_t), intent(in) :: prt
defined = prt%defined
end function phs_prt_is_defined
elemental module function phs_prt_get_momentum (prt) result (p)
type(vector4_t) :: p
class(phs_prt_t), intent(in) :: prt
p = prt%p
end function phs_prt_get_momentum
elemental module function phs_prt_get_msq (prt) result (p2)
real(default) :: p2
class(phs_prt_t), intent(in) :: prt
p2 = prt%p2
end function phs_prt_get_msq
@ %def phs_prt_is_defined phs_prt_get_momentum phs_prt_get_msq
@ Addition of momenta (invariant mass square is computed).
<<PHS trees: prt: TBP>>=
procedure :: combine => phs_prt_combine
<<PHS trees: sub interfaces>>=
elemental module subroutine phs_prt_combine (prt, prt1, prt2)
class(phs_prt_t), intent(inout) :: prt
type(phs_prt_t), intent(in) :: prt1, prt2
end subroutine phs_prt_combine
<<PHS trees: procedures>>=
elemental module subroutine phs_prt_combine (prt, prt1, prt2)
class(phs_prt_t), intent(inout) :: prt
type(phs_prt_t), intent(in) :: prt1, prt2
prt%defined = .true.
prt%p = prt1%p + prt2%p
prt%p2 = prt%p ** 2
call phs_prt_check (prt)
end subroutine phs_prt_combine
@ %def phs_prt_combine
@ Output
<<PHS trees: prt: TBP>>=
procedure :: write => phs_prt_write
<<PHS trees: sub interfaces>>=
module subroutine phs_prt_write (prt, unit)
class(phs_prt_t), intent(in) :: prt
integer, intent(in), optional :: unit
end subroutine phs_prt_write
<<PHS trees: procedures>>=
module subroutine phs_prt_write (prt, unit)
class(phs_prt_t), intent(in) :: prt
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
if (prt%defined) then
call vector4_write (prt%p, u)
write (u, "(1x,A,1x," // FMT_19 // ")") "T = ", prt%p2
else
write (u, "(3x,A)") "[undefined]"
end if
end subroutine phs_prt_write
@ %def phs_prt_write
<<PHS trees: prt: TBP>>=
procedure :: check => phs_prt_check
<<PHS trees: sub interfaces>>=
elemental module subroutine phs_prt_check (prt)
class(phs_prt_t), intent(inout) :: prt
end subroutine phs_prt_check
<<PHS trees: procedures>>=
elemental module subroutine phs_prt_check (prt)
class(phs_prt_t), intent(inout) :: prt
if (prt%p2 < 0._default) then
prt%p2 = 0._default
end if
end subroutine phs_prt_check
@ %def phs_prt_check
@
\subsection{The phase-space tree type}
\subsubsection{Definition}
In the concrete implementation, each branch $c$ may have two
\emph{daughters} $c_1$ and $c_2$ such that $c_1+c_2=c$, a
\emph{sibling} $c_s$ and a \emph{mother} $c_m$ such that $c+c_s =
c_m$, and a \emph{friend} which is kept during flips, such that it can
indicate a fixed reference frame. Absent entries are set $c=0$.
First, declare the branch type. There is some need to have this
public. Give initializations for all components, so no [[init]]
routine is necessary. The branch has some information about the
associated coordinates and about connections.
<<PHS trees: types>>=
type :: phs_branch_t
private
logical :: set = .false.
logical :: inverted_decay = .false.
logical :: inverted_axis = .false.
integer(TC) :: mother = 0
integer(TC) :: sibling = 0
integer(TC) :: friend = 0
integer(TC) :: origin = 0
integer(TC), dimension(2) :: daughter = 0
integer :: firstborn = 0
logical :: has_children = .false.
logical :: has_friend = .false.
logical :: is_real = .false.
end type phs_branch_t
@ %def phs_branch_t
@ The tree type: No initialization, this is done by
[[phs_tree_init]]. In addition to the branch array which
The branches are collected in an array which holds all possible
branches, of which only a few are set. After flips have been applied,
the branch $c_M=\sum_{i=1}^{n({\rm fin})}2^{i-1}$ must be there,
indicating the mother of all decay products. In addition, we should
check for consistency at the beginning.
[[n_branches]] is the number of those actually set. [[n_externals]]
defines the number of significant bit, and [[mask]] is a code where all
bits are set. Analogous: [[n_in]] and [[mask_in]] for the incoming
particles.
The [[mapping]] array contains the mappings associated to the branches
(corresponding indices). The array [[mass_sum]] contains the sum of
the real masses of the external final-state particles associated to
the branch. During phase-space evaluation, this determines the
boundaries.
<<PHS trees: public>>=
public :: phs_tree_t
<<PHS trees: types>>=
type :: phs_tree_t
private
integer :: n_branches, n_externals, n_in, n_msq, n_angles
integer(TC) :: n_branches_tot, n_branches_out
integer(TC) :: mask, mask_in, mask_out
type(phs_branch_t), dimension(:), allocatable :: branch
type(mapping_t), dimension(:), allocatable :: mapping
real(default), dimension(:), allocatable :: mass_sum
real(default), dimension(:), allocatable :: effective_mass
real(default), dimension(:), allocatable :: effective_width
logical :: real_phsp = .false.
integer, dimension(:), allocatable :: momentum_link
contains
<<PHS trees: phs tree: TBP>>
end type phs_tree_t
@ %def phs_tree_t
@ The maximum number of external particles that can be represented is
related to the bit size of the integer that stores binary codes. With
the default integer of 32 bit on common machines, this is more than
enough space. If [[TC]] is actually the default integer kind, there
is no need to keep it separate, but doing so marks this as a
special type of integer. So, just state that the maximum number is 32:
<<Limits: public parameters>>=
integer, parameter, public :: MAX_EXTERNAL = 32
@ %def MAX_EXTERNAL
@
\subsubsection{Constructor and destructor}
Allocate memory for a phase-space tree with given number of externals and
incoming. The number of allocated branches can easily become large,
but appears manageable for realistic cases, e.g., for [[n_in=2]] and
[[n_out=8]] we get $2^{10}-1=1023$.
Here we set the masks for incoming and for all externals.
<<PHS trees: phs tree: TBP>>=
procedure :: init => phs_tree_init
procedure :: final => phs_tree_final
<<PHS trees: sub interfaces>>=
elemental module subroutine phs_tree_init &
(tree, n_in, n_out, n_masses, n_angles)
class(phs_tree_t), intent(inout) :: tree
integer, intent(in) :: n_in, n_out, n_masses, n_angles
end subroutine phs_tree_init
elemental module subroutine phs_tree_final (tree)
class(phs_tree_t), intent(inout) :: tree
end subroutine phs_tree_final
<<PHS trees: procedures>>=
elemental module subroutine phs_tree_init &
(tree, n_in, n_out, n_masses, n_angles)
class(phs_tree_t), intent(inout) :: tree
integer, intent(in) :: n_in, n_out, n_masses, n_angles
integer(TC) :: i
tree%n_externals = n_in + n_out
tree%n_branches_tot = 2**(n_in+n_out) - 1
tree%n_branches_out = 2**n_out - 1
tree%mask = 0
do i = 0, n_in + n_out - 1
tree%mask = ibset (tree%mask, i)
end do
tree%n_in = n_in
tree%mask_in = 0
do i = n_out, n_in + n_out - 1
tree%mask_in = ibset (tree%mask_in, i)
end do
tree%mask_out = ieor (tree%mask, tree%mask_in)
tree%n_msq = n_masses
tree%n_angles = n_angles
allocate (tree%branch (tree%n_branches_tot))
tree%n_branches = 0
allocate (tree%mapping (tree%n_branches_out))
allocate (tree%mass_sum (tree%n_branches_out))
allocate (tree%effective_mass (tree%n_branches_out))
allocate (tree%effective_width (tree%n_branches_out))
end subroutine phs_tree_init
elemental module subroutine phs_tree_final (tree)
class(phs_tree_t), intent(inout) :: tree
deallocate (tree%branch)
deallocate (tree%mapping)
deallocate (tree%mass_sum)
deallocate (tree%effective_mass)
deallocate (tree%effective_width)
end subroutine phs_tree_final
@ %def phs_tree_init phs_tree_final
@
\subsubsection{Screen output}
Write only the branches that are set:
<<PHS trees: phs tree: TBP>>=
procedure :: write => phs_tree_write
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_write (tree, unit)
class(phs_tree_t), intent(in) :: tree
integer, intent(in), optional :: unit
end subroutine phs_tree_write
<<PHS trees: procedures>>=
module subroutine phs_tree_write (tree, unit)
class(phs_tree_t), intent(in) :: tree
integer, intent(in), optional :: unit
integer :: u
integer(TC) :: k
u = given_output_unit (unit); if (u < 0) return
write (u, '(3X,A,1x,I0,5X,A,I3)') &
'External:', tree%n_externals, 'Mask:', tree%mask
write (u, '(3X,A,1x,I0,5X,A,I3)') &
'Incoming:', tree%n_in, 'Mask:', tree%mask_in
write (u, '(3X,A,1x,I0,5X,A,I3)') &
'Branches:', tree%n_branches
do k = size (tree%branch), 1, -1
if (tree%branch(k)%set) &
call phs_branch_write (tree%branch(k), unit=unit, kval=k)
end do
do k = 1, size (tree%mapping)
call tree%mapping (k)%write (unit, verbose=.true.)
end do
write (u, "(3x,A)") "Arrays: mass_sum, effective_mass, effective_width"
do k = 1, size (tree%mass_sum)
if (tree%branch(k)%set) then
write (u, "(5x,I0,3(2x," // FMT_19 // "))") k, tree%mass_sum(k), &
tree%effective_mass(k), tree%effective_width(k)
end if
end do
end subroutine phs_tree_write
subroutine phs_branch_write (b, unit, kval)
type(phs_branch_t), intent(in) :: b
integer, intent(in), optional :: unit
integer(TC), intent(in), optional :: kval
integer :: u
integer(TC) :: k
character(len=6) :: tmp
character(len=1) :: firstborn(2), sign_decay, sign_axis
integer :: i
u = given_output_unit (unit); if (u < 0) return
k = 0; if (present (kval)) k = kval
if (b%origin /= 0) then
write(tmp, '(A,I4,A)') '(', b%origin, ')'
else
tmp = ' '
end if
do i=1, 2
if (b%firstborn == i) then
firstborn(i) = "*"
else
firstborn(i) = " "
end if
end do
if (b%inverted_decay) then
sign_decay = "-"
else
sign_decay = "+"
end if
if (b%inverted_axis) then
sign_axis = "-"
else
sign_axis = "+"
end if
if (b%has_children) then
if (b%has_friend) then
write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A,1x,I0)') &
& '*', k, tmp, &
& 'Daughters: ', &
& b%daughter(1), firstborn(1), &
& b%daughter(2), firstborn(2), sign_decay, &
& 'Friend: ', b%friend
else
write(u,'(4X,A1,I0,3x,A,1X,A,I0,A1,1x,I0,A1,1X,A1,1X,A)') &
& '*', k, tmp, &
& 'Daughters: ', &
& b%daughter(1), firstborn(1), &
& b%daughter(2), firstborn(2), sign_decay, &
& '(axis '//sign_axis//')'
end if
else
write(u,'(5X,I0)') k
end if
end subroutine phs_branch_write
@ %def phs_tree_write phs_branch_write
@
\subsection{PHS tree setup}
\subsubsection{Transformation into an array of branch codes and back}
Assume that the tree/array has been created before with the
appropriate length and is empty.
<<PHS trees: public>>=
public :: phs_tree_from_array
<<PHS trees: phs tree: TBP>>=
procedure :: from_array => phs_tree_from_array
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_from_array (tree, a)
class(phs_tree_t), intent(inout) :: tree
integer(TC), dimension(:), intent(in) :: a
end subroutine phs_tree_from_array
<<PHS trees: procedures>>=
module subroutine phs_tree_from_array (tree, a)
class(phs_tree_t), intent(inout) :: tree
integer(TC), dimension(:), intent(in) :: a
integer :: i
integer(TC) :: k
<<Set branches from array [[a]]>>
<<Set external branches if necessary>>
<<Check number of branches>>
<<Determine the connections>>
contains
<<Subroutine: set relatives>>
end subroutine phs_tree_from_array
@ %def phs_tree_from_array
@ First, set all branches specified by the user. If all IN-bits
are set, we invert the branch code.
<<Set branches from array [[a]]>>=
do i=1, size(a)
k = a(i)
if (iand(k, tree%mask_in) == tree%mask_in) k = ieor(tree%mask, k)
tree%branch(k)%set = .true.
tree%n_branches = tree%n_branches+1
end do
@ The external branches are understood, so set them now if not yet
done. In all cases ensure that the representative with one bit set is
used, except for decays where the in-particle is represented by all
OUT-bits set instead.
<<Set external branches if necessary>>=
do i=0, tree%n_externals-1
k = ibset(0,i)
if (iand(k, tree%mask_in) == tree%mask_in) k = ieor(tree%mask, k)
if (tree%branch(ieor(tree%mask, k))%set) then
tree%branch(ieor(tree%mask, k))%set = .false.
tree%branch(k)%set = .true.
else if (.not.tree%branch(k)%set) then
tree%branch(k)%set = .true.
tree%n_branches = tree%n_branches+1
end if
end do
@ Now the number of branches set can be checked. Here we assume that
the tree is binary. For three externals there are three branches in
total, and for each additional external branch we get another internal
one.
<<Check number of branches>>=
if (tree%n_branches /= tree%n_externals*2-3) then
call phs_tree_write (tree)
call msg_bug &
& (" Wrong number of branches set in phase space tree")
end if
@ For all branches that are set, except for the externals, we try to
find the daughter branches:
<<Determine the connections>>=
do k=1, size (tree%branch)
if (tree%branch(k)%set .and. tc_decay_level (k) /= 1) then
call branch_set_relatives(k)
end if
end do
@ To this end, we scan all codes less than the current code, whether
we can find two branches which are set and which together give the
current code. After that, the tree may still not be connected, but at
least we know if a branch does not have daughters: This indicates some
inconsistency.
The algorithm ensures that, at this stage, the first daughter has a
smaller code value than the second one.
<<Subroutine: set relatives>>=
subroutine branch_set_relatives (k)
integer(TC), intent(in) :: k
integer(TC) :: m,n
do m=1, k-1
if (iand(k,m)==m) then
n = ieor(k,m)
if ( tree%branch(m)%set .and. tree%branch(n)%set ) then
tree%branch(k)%daughter(1) = m; tree%branch(k)%daughter(2) = n
tree%branch(m)%mother = k; tree%branch(n)%mother = k
tree%branch(m)%sibling = n; tree%branch(n)%sibling = m
tree%branch(k)%has_children = .true.
return
end if
end if
end do
call phs_tree_write (tree)
call msg_bug &
& (" Missing daughter branch(es) in phase space tree")
end subroutine branch_set_relatives
@ The inverse: this is trivial, fortunately.
@
\subsubsection{Flip $t$-channel into $s$-channel}
Flipping the tree is done upwards, beginning from the decay products.
First we select a $t$-channel branch [[k]]: one which is set, which
does have an IN-bit, and which is not an external particle.
Next, we determine the adjacent in-particle (called the 'friend' [[f]]
here, since it will provide the reference axis for the angular
integration). In addition, we look for the 'mother' and 'sibling' of
this particle. If the latter field is empty, we select the (unique)
other out-particle which has no mother, calling the internal
subroutine [[find_orphan]].
The flip is done as follows: We assume that the first daughter [[d]]
is an $s$-channel line, which is true if the daughters are sorted.
This will stay the first daughter. The second one is a $t$-channel
line; it is exchanged with the 'sibling' [[s]]. The new line which
replaces the branch [[k]] is just the sum of [[s]] and [[d]]. In
addition, we have to rearrange the relatives of [[s]] and [[d]], as
well of [[f]].
Finally, we flip 'sibling' and 'friend' and set the new $s$-channel
branch [[n]] which replaces the $t$-channel branch [[k]]. After this
is complete, we are ready to execute another flip.
[Although the friend is not needed for the final flip, since it would
be an initial particle anyway, we need to know whether we have $t$- or
$u$-channel.]
<<PHS trees: phs tree: TBP>>=
procedure :: flip_t_to_s_channel => phs_tree_flip_t_to_s_channel
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_flip_t_to_s_channel (tree)
class(phs_tree_t), intent(inout) :: tree
end subroutine phs_tree_flip_t_to_s_channel
<<PHS trees: procedures>>=
module subroutine phs_tree_flip_t_to_s_channel (tree)
class(phs_tree_t), intent(inout) :: tree
integer(TC) :: k, f, m, n, d, s
if (tree%n_in == 2) then
FLIP: do k=3, tree%mask-1
if (.not. tree%branch(k)%set) cycle FLIP
f = iand(k,tree%mask_in)
if (f==0 .or. f==k) cycle FLIP
m = tree%branch(k)%mother
s = tree%branch(k)%sibling
if (s==0) call find_orphan(s)
d = tree%branch(k)%daughter(1)
n = ior(d,s)
tree%branch(k)%set = .false.
tree%branch(n)%set = .true.
tree%branch(n)%origin = k
tree%branch(n)%daughter(1) = d; tree%branch(d)%mother = n
tree%branch(n)%daughter(2) = s; tree%branch(s)%mother = n
tree%branch(n)%has_children = .true.
tree%branch(d)%sibling = s; tree%branch(s)%sibling = d
tree%branch(n)%sibling = f; tree%branch(f)%sibling = n
tree%branch(n)%mother = m
tree%branch(f)%mother = m
if (m/=0) then
tree%branch(m)%daughter(1) = n
tree%branch(m)%daughter(2) = f
end if
tree%branch(n)%friend = f
tree%branch(n)%has_friend = .true.
tree%branch(n)%firstborn = 2
end do FLIP
end if
contains
subroutine find_orphan(s)
integer(TC) :: s
do s=1, tree%mask_out
if (tree%branch(s)%set .and. tree%branch(s)%mother==0) return
end do
call phs_tree_write (tree)
call msg_bug (" Can't flip phase space tree to channel")
end subroutine find_orphan
end subroutine phs_tree_flip_t_to_s_channel
@ %def phs_tree_flip_t_to_s_channel
@ After the tree has been flipped, one may need to determine what has
become of a particular $t$-channel branch. This function gives the
bincode of the flipped tree. If the original bincode does not contain
IN-bits, we leave it as it is.
<<PHS trees: procedures>>=
function tc_flipped (tree, kt) result (ks)
type(phs_tree_t), intent(in) :: tree
integer(TC), intent(in) :: kt
integer(TC) :: ks
if (iand (kt, tree%mask_in) == 0) then
ks = kt
else
ks = tree%branch(iand (kt, tree%mask_out))%mother
end if
end function tc_flipped
@ %def tc_flipped
@ Scan a tree and make sure that the first daughter has always a
smaller code than the second one. Furthermore, delete any [[friend]]
entry in the root branch -- this branching has the incoming particle
direction as axis anyway. Keep track of reordering by updating
[[inverted_axis]], [[inverted_decay]] and [[firstborn]].
<<PHS trees: phs tree: TBP>>=
procedure :: canonicalize => phs_tree_canonicalize
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_canonicalize (tree)
class(phs_tree_t), intent(inout) :: tree
end subroutine phs_tree_canonicalize
<<PHS trees: procedures>>=
module subroutine phs_tree_canonicalize (tree)
class(phs_tree_t), intent(inout) :: tree
integer :: n_out
integer(TC) :: k_out
call branch_canonicalize (tree%branch(tree%mask_out))
n_out = tree%n_externals - tree%n_in
k_out = tree%mask_out
if (tree%branch(k_out)%has_friend &
& .and. tree%branch(k_out)%friend == ibset (0, n_out)) then
tree%branch(k_out)%inverted_axis = .not.tree%branch(k_out)%inverted_axis
end if
tree%branch(k_out)%has_friend = .false.
tree%branch(k_out)%friend = 0
contains
recursive subroutine branch_canonicalize (b)
type(phs_branch_t), intent(inout) :: b
integer(TC) :: d1, d2
if (b%has_children) then
d1 = b%daughter(1)
d2 = b%daughter(2)
if (d1 > d2) then
b%daughter(1) = d2
b%daughter(2) = d1
b%inverted_decay = .not.b%inverted_decay
if (b%firstborn /= 0) b%firstborn = 3 - b%firstborn
end if
call branch_canonicalize (tree%branch(b%daughter(1)))
call branch_canonicalize (tree%branch(b%daughter(2)))
end if
end subroutine branch_canonicalize
end subroutine phs_tree_canonicalize
@ %def phs_tree_canonicalize
@
\subsubsection{Mappings}
Initialize a mapping for the current tree. This is done while reading
from file, so the mapping parameters are read, but applied to the
flipped tree. Thus, the size of the array of mappings is given by the
number of outgoing particles only.
<<PHS trees: phs tree: TBP>>=
procedure :: init_mapping => phs_tree_init_mapping
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_init_mapping (tree, k, type, pdg, model)
class(phs_tree_t), intent(inout) :: tree
integer(TC), intent(in) :: k
type(string_t), intent(in) :: type
integer, intent(in) :: pdg
class(model_data_t), intent(in), target :: model
end subroutine phs_tree_init_mapping
<<PHS trees: procedures>>=
module subroutine phs_tree_init_mapping (tree, k, type, pdg, model)
class(phs_tree_t), intent(inout) :: tree
integer(TC), intent(in) :: k
type(string_t), intent(in) :: type
integer, intent(in) :: pdg
class(model_data_t), intent(in), target :: model
integer(TC) :: kk
kk = tc_flipped (tree, k)
call tree%mapping(kk)%init (kk, type, pdg, model)
end subroutine phs_tree_init_mapping
@ %def phs_tree_init_mapping
@ Set the physical parameters for the mapping, using a specific
parameter set. Also set the mass sum array.
<<PHS trees: phs tree: TBP>>=
procedure :: set_mapping_parameters => phs_tree_set_mapping_parameters
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_set_mapping_parameters &
(tree, mapping_defaults, variable_limits)
class(phs_tree_t), intent(inout) :: tree
type(mapping_defaults_t), intent(in) :: mapping_defaults
logical, intent(in) :: variable_limits
end subroutine phs_tree_set_mapping_parameters
<<PHS trees: procedures>>=
module subroutine phs_tree_set_mapping_parameters &
(tree, mapping_defaults, variable_limits)
class(phs_tree_t), intent(inout) :: tree
type(mapping_defaults_t), intent(in) :: mapping_defaults
logical, intent(in) :: variable_limits
integer(TC) :: k
do k = 1, tree%n_branches_out
call tree%mapping(k)%set_parameters (mapping_defaults, variable_limits)
end do
end subroutine phs_tree_set_mapping_parameters
@ %def phs_tree_set_mapping_parameters
@ Return the mapping for the sum of all outgoing particles. This
should either be no mapping or a global s-channel mapping.
<<PHS trees: phs tree: TBP>>=
procedure :: assign_s_mapping => phs_tree_assign_s_mapping
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_assign_s_mapping (tree, mapping)
class(phs_tree_t), intent(in) :: tree
type(mapping_t), intent(out) :: mapping
end subroutine phs_tree_assign_s_mapping
<<PHS trees: procedures>>=
module subroutine phs_tree_assign_s_mapping (tree, mapping)
class(phs_tree_t), intent(in) :: tree
type(mapping_t), intent(out) :: mapping
mapping = tree%mapping(tree%mask_out)
end subroutine phs_tree_assign_s_mapping
@ %def phs_tree_assign_s_mapping
@
\subsubsection{Kinematics}
Fill the mass sum array, starting from the external particles and
working down to the tree root. For each bincode [[k]] we scan the
bits in [[k]]; if only one is set, we take the physical mass of the
corresponding external particle; if more then one is set, we sum up
the two masses (which we know have already been set).
<<PHS trees: phs tree: TBP>>=
procedure :: set_mass_sum => phs_tree_set_mass_sum
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_set_mass_sum (tree, flv)
class(phs_tree_t), intent(inout) :: tree
type(flavor_t), dimension(:), intent(in) :: flv
end subroutine phs_tree_set_mass_sum
<<PHS trees: procedures>>=
module subroutine phs_tree_set_mass_sum (tree, flv)
class(phs_tree_t), intent(inout) :: tree
type(flavor_t), dimension(:), intent(in) :: flv
integer(TC) :: k
integer :: i
tree%mass_sum = 0
do k = 1, tree%n_branches_out
do i = 0, size (flv) - 1
if (btest(k,i)) then
if (ibclr(k,i) == 0) then
tree%mass_sum(k) = flv(i+1)%get_mass ()
else
tree%mass_sum(k) = &
tree%mass_sum(ibclr(k,i)) + tree%mass_sum(ibset(0,i))
end if
exit
end if
end do
end do
end subroutine phs_tree_set_mass_sum
@ %def phs_tree_set_mass_sum
@ Set the effective masses and widths. For each non-resonant branch
in a tree, the effective mass is equal to the sum of the effective
masses of the children (and analogous for the width). External
particles have their real mass and width zero. For resonant branches,
we insert mass and width from the corresponding mapping.
This routine has [[phs_tree_set_mass_sum]] and
[[phs_tree_set_mapping_parameters]] as prerequisites.
<<PHS trees: phs tree: TBP>>=
procedure :: set_effective_masses => phs_tree_set_effective_masses
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_set_effective_masses (tree)
class(phs_tree_t), intent(inout) :: tree
end subroutine phs_tree_set_effective_masses
<<PHS trees: procedures>>=
module subroutine phs_tree_set_effective_masses (tree)
class(phs_tree_t), intent(inout) :: tree
tree%effective_mass = 0
tree%effective_width = 0
call set_masses_x (tree%mask_out)
contains
recursive subroutine set_masses_x (k)
integer(TC), intent(in) :: k
integer(TC) :: k1, k2
if (tree%branch(k)%has_children) then
k1 = tree%branch(k)%daughter(1)
k2 = tree%branch(k)%daughter(2)
call set_masses_x (k1)
call set_masses_x (k2)
if (tree%mapping(k)%is_s_channel ()) then
tree%effective_mass(k) = tree%mapping(k)%get_mass ()
tree%effective_width(k) = tree%mapping(k)%get_width ()
else
tree%effective_mass(k) = &
tree%effective_mass(k1) + tree%effective_mass(k2)
tree%effective_width(k) = &
tree%effective_width(k1) + tree%effective_width(k2)
end if
else
tree%effective_mass(k) = tree%mass_sum(k)
end if
end subroutine set_masses_x
end subroutine phs_tree_set_effective_masses
@ %def phs_tree_set_effective_masses
@ Define step mappings, recursively, for the decay products of all
intermediate resonances. Step mappings account for the fact that a
branch may originate from a resonance, which almost replaces the
upper limit on the possible invariant mass. The step
mapping implements a smooth cutoff that interpolates between the
resonance and the real kinematic limit. The mapping width determines
the sharpness of the cutoff.
Step mappings are inserted only for branches that are not mapped
otherwise.
At each branch, we record the mass that is effectively available for
phase space, by taking the previous limit and subtracting the
effective mass of the sibling branch. Widths are added, not subtracted.
If we encounter a resonance decay, we discard the previous limit and
replace it by the mass and width of the resonance, also subtracting
the sibling branch.
Initially, the limit is zero, so it becomes negative at any branch. Only
if there is a resonance, the limit becomes positive. Whenever the
limit is positive, and the current branch decays, we activate a step
mapping for the current branch.
As a result, step mappings are implemented for all internal lines that
originate from an intermediate resonance decay.
The flag [[variable_limits]] applies to the ultimate limit from the
available energy, not to the intermediate resonances whose masses are
always fixed.
This routine requires [[phs_tree_set_effective_masses]]
<<PHS trees: phs tree: TBP>>=
procedure :: set_step_mappings => phs_tree_set_step_mappings
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_set_step_mappings &
(tree, exp_type, variable_limits)
class(phs_tree_t), intent(inout) :: tree
logical, intent(in) :: exp_type
logical, intent(in) :: variable_limits
end subroutine phs_tree_set_step_mappings
<<PHS trees: procedures>>=
module subroutine phs_tree_set_step_mappings &
(tree, exp_type, variable_limits)
class(phs_tree_t), intent(inout) :: tree
logical, intent(in) :: exp_type
logical, intent(in) :: variable_limits
type(string_t) :: map_str
integer(TC) :: k
if (exp_type) then
map_str = "step_exp"
else
map_str = "step_hyp"
end if
k = tree%mask_out
call set_step_mappings_x (k, 0._default, 0._default)
contains
recursive subroutine set_step_mappings_x (k, m_limit, w_limit)
integer(TC), intent(in) :: k
real(default), intent(in) :: m_limit, w_limit
integer(TC), dimension(2) :: kk
real(default), dimension(2) :: m, w
if (tree%branch(k)%has_children) then
if (m_limit > 0) then
if (.not. tree%mapping(k)%is_set ()) then
call tree%mapping(k)%init (k, map_str)
call tree%mapping(k)%set_step_mapping_parameters (m_limit, &
w_limit, variable_limits)
end if
end if
kk = tree%branch(k)%daughter
m = tree%effective_mass(kk)
w = tree%effective_width(kk)
if (tree%mapping(k)%is_s_channel ()) then
call set_step_mappings_x (kk(1), &
tree%mapping(k)%get_mass () - m(2), &
tree%mapping(k)%get_width () + w(2))
call set_step_mappings_x (kk(2), &
tree%mapping(k)%get_mass () - m(1), &
tree%mapping(k)%get_width () + w(1))
else if (m_limit > 0) then
call set_step_mappings_x (kk(1), &
m_limit - m(2), &
w_limit + w(2))
call set_step_mappings_x (kk(2), &
m_limit - m(1), &
w_limit + w(1))
else
call set_step_mappings_x (kk(1), &
- m(2), &
+ w(2))
call set_step_mappings_x (kk(2), &
- m(1), &
+ w(1))
end if
end if
end subroutine set_step_mappings_x
end subroutine phs_tree_set_step_mappings
@ %def phs_tree_set_step_mappings
@
\subsubsection{Resonance structure}
We identify the resonances within a tree as the set of s-channel
mappings. The [[resonance_history_t]] type serves as the result
container.
<<PHS trees: phs tree: TBP>>=
procedure :: extract_resonance_history => phs_tree_extract_resonance_history
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_extract_resonance_history (tree, res_history)
class(phs_tree_t), intent(in) :: tree
type(resonance_history_t), intent(out) :: res_history
end subroutine phs_tree_extract_resonance_history
<<PHS trees: procedures>>=
module subroutine phs_tree_extract_resonance_history (tree, res_history)
class(phs_tree_t), intent(in) :: tree
type(resonance_history_t), intent(out) :: res_history
type(resonance_info_t) :: res_info
integer :: i
if (allocated (tree%mapping)) then
do i = 1, size (tree%mapping)
associate (mapping => tree%mapping(i))
if (mapping%is_s_channel ()) then
call res_info%init (mapping%get_bincode (), mapping%get_flv (), &
n_out = tree%n_externals - tree%n_in)
call res_history%add_resonance (res_info)
end if
end associate
end do
end if
end subroutine phs_tree_extract_resonance_history
@ %def phs_tree_extract_resonance_history
@
\subsubsection{Structural comparison}
This function allows to check whether one tree is the permutation of
another one. The permutation is applied to the second tree in the
argument list. We do not make up a temporary permuted tree, but
compare the two trees directly. The branches are scanned recursively,
where for each daughter we check the friend and the mapping as well.
Once a discrepancy is found, the recursion is exited immediately.
<<PHS trees: public>>=
public :: phs_tree_equivalent
<<PHS trees: sub interfaces>>=
module function phs_tree_equivalent (t1, t2, perm) result (is_equal)
type(phs_tree_t), intent(in) :: t1, t2
type(permutation_t), intent(in) :: perm
logical :: equal, is_equal
end function phs_tree_equivalent
<<PHS trees: procedures>>=
module function phs_tree_equivalent (t1, t2, perm) result (is_equal)
type(phs_tree_t), intent(in) :: t1, t2
type(permutation_t), intent(in) :: perm
logical :: equal, is_equal
integer(TC) :: k1, k2, mask_in
k1 = t1%mask_out
k2 = t2%mask_out
mask_in = t1%mask_in
equal = .true.
call check (t1%branch(k1), t2%branch(k2), k1, k2)
is_equal = equal
contains
recursive subroutine check (b1, b2, k1, k2)
type(phs_branch_t), intent(in) :: b1, b2
integer(TC), intent(in) :: k1, k2
integer(TC), dimension(2) :: d1, d2, pd2
integer :: i
if (.not.b1%has_friend .and. .not.b2%has_friend) then
equal = .true.
else if (b1%has_friend .and. b2%has_friend) then
equal = (b1%friend == tc_permute (b2%friend, perm, mask_in))
end if
if (equal) then
if (b1%has_children .and. b2%has_children) then
d1 = b1%daughter
d2 = b2%daughter
do i=1, 2
pd2(i) = tc_permute (d2(i), perm, mask_in)
end do
if (d1(1)==pd2(1) .and. d1(2)==pd2(2)) then
equal = (b1%firstborn == b2%firstborn)
if (equal) call check &
& (t1%branch(d1(1)), t2%branch(d2(1)), d1(1), d2(1))
if (equal) call check &
& (t1%branch(d1(2)), t2%branch(d2(2)), d1(2), d2(2))
else if (d1(1)==pd2(2) .and. d1(2)==pd2(1)) then
equal = ( (b1%firstborn == 0 .and. b2%firstborn == 0) &
& .or. (b1%firstborn == 3 - b2%firstborn) )
if (equal) call check &
& (t1%branch(d1(1)), t2%branch(d2(2)), d1(1), d2(2))
if (equal) call check &
& (t1%branch(d1(2)), t2%branch(d2(1)), d1(2), d2(1))
else
equal = .false.
end if
end if
end if
if (equal) then
equal = (t1%mapping(k1) == t2%mapping(k2))
end if
end subroutine check
end function phs_tree_equivalent
@ %def phs_tree_equivalent
@ Scan two decay trees and determine the correspondence of mass
variables, i.e., the permutation that transfers the ordered list of
mass variables belonging to the second tree into the first one. Mass
variables are assigned beginning from branches and ending at the root.
<<PHS trees: public>>=
public :: phs_tree_find_msq_permutation
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_find_msq_permutation &
(tree1, tree2, perm2, msq_perm)
type(phs_tree_t), intent(in) :: tree1, tree2
type(permutation_t), intent(in) :: perm2
type(permutation_t), intent(out) :: msq_perm
end subroutine phs_tree_find_msq_permutation
<<PHS trees: procedures>>=
module subroutine phs_tree_find_msq_permutation &
(tree1, tree2, perm2, msq_perm)
type(phs_tree_t), intent(in) :: tree1, tree2
type(permutation_t), intent(in) :: perm2
type(permutation_t), intent(out) :: msq_perm
type(permutation_t) :: perm1
integer(TC) :: mask_in, root
integer(TC), dimension(:), allocatable :: index1, index2
integer :: i
allocate (index1 (tree1%n_msq), index2 (tree2%n_msq))
call permutation_init (perm1, permutation_size (perm2))
mask_in = tree1%mask_in
root = tree1%mask_out
i = 0
call tree_scan (tree1, root, perm1, index1)
i = 0
call tree_scan (tree2, root, perm2, index2)
call permutation_find (msq_perm, index1, index2)
contains
recursive subroutine tree_scan (tree, k, perm, index)
type(phs_tree_t), intent(in) :: tree
integer(TC), intent(in) :: k
type(permutation_t), intent(in) :: perm
integer, dimension(:), intent(inout) :: index
if (tree%branch(k)%has_children) then
call tree_scan (tree, tree%branch(k)%daughter(1), perm, index)
call tree_scan (tree, tree%branch(k)%daughter(2), perm, index)
i = i + 1
if (i <= size (index)) index(i) = tc_permute (k, perm, mask_in)
end if
end subroutine tree_scan
end subroutine phs_tree_find_msq_permutation
@ %def phs_tree_find_msq_permutation
<<PHS trees: public>>=
public :: phs_tree_find_angle_permutation
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_find_angle_permutation &
(tree1, tree2, perm2, angle_perm, sig2)
type(phs_tree_t), intent(in) :: tree1, tree2
type(permutation_t), intent(in) :: perm2
type(permutation_t), intent(out) :: angle_perm
logical, dimension(:), allocatable, intent(out) :: sig2
end subroutine phs_tree_find_angle_permutation
<<PHS trees: procedures>>=
module subroutine phs_tree_find_angle_permutation &
(tree1, tree2, perm2, angle_perm, sig2)
type(phs_tree_t), intent(in) :: tree1, tree2
type(permutation_t), intent(in) :: perm2
type(permutation_t), intent(out) :: angle_perm
logical, dimension(:), allocatable, intent(out) :: sig2
type(permutation_t) :: perm1
integer(TC) :: mask_in, root
integer(TC), dimension(:), allocatable :: index1, index2
logical, dimension(:), allocatable :: sig1
integer :: i
allocate (index1 (tree1%n_angles), index2 (tree2%n_angles))
allocate (sig1 (tree1%n_angles), sig2 (tree2%n_angles))
call permutation_init (perm1, permutation_size (perm2))
mask_in = tree1%mask_in
root = tree1%mask_out
i = 0
call tree_scan (tree1, root, perm1, index1, sig1)
i = 0
call tree_scan (tree2, root, perm2, index2, sig2)
call permutation_find (angle_perm, index1, index2)
contains
recursive subroutine tree_scan (tree, k, perm, index, sig)
type(phs_tree_t), intent(in) :: tree
integer(TC), intent(in) :: k
type(permutation_t), intent(in) :: perm
integer, dimension(:), intent(inout) :: index
logical, dimension(:), intent(inout) :: sig
integer(TC) :: k1, k2, kp
logical :: s
if (tree%branch(k)%has_children) then
k1 = tree%branch(k)%daughter(1)
k2 = tree%branch(k)%daughter(2)
s = (tc_permute(k1, perm, mask_in) < tc_permute(k2, perm, mask_in))
kp = tc_permute (k, perm, mask_in)
i = i + 1
index(i) = kp
sig(i) = s
i = i + 1
index(i) = - kp
sig(i) = s
call tree_scan (tree, k1, perm, index, sig)
call tree_scan (tree, k2, perm, index, sig)
end if
end subroutine tree_scan
end subroutine phs_tree_find_angle_permutation
@ %def phs_tree_find_angle_permutation
@
\subsection{Phase-space evaluation}
\subsubsection{Phase-space volume}
We compute the phase-space volume recursively, following the same path
as for computing other kinematical variables. However, the volume
depends just on $\sqrt{\hat s}$, not on the momentum configuration.
Note: counting branches, we may replace this by a simple formula.
<<PHS trees: phs tree: TBP>>=
procedure :: compute_volume => phs_tree_compute_volume
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_compute_volume (tree, sqrts, volume)
class(phs_tree_t), intent(in) :: tree
real(default), intent(in) :: sqrts
real(default), intent(out) :: volume
end subroutine phs_tree_compute_volume
<<PHS trees: procedures>>=
module subroutine phs_tree_compute_volume (tree, sqrts, volume)
class(phs_tree_t), intent(in) :: tree
real(default), intent(in) :: sqrts
real(default), intent(out) :: volume
integer(TC) :: k
k = tree%mask_out
if (tree%branch(k)%has_children) then
call compute_volume_x (tree%branch(k), k, volume, .true.)
else
volume = 1
end if
contains
recursive subroutine compute_volume_x (b, k, volume, initial)
type(phs_branch_t), intent(in) :: b
integer(TC), intent(in) :: k
real(default), intent(out) :: volume
logical, intent(in) :: initial
integer(TC) :: k1, k2
real(default) :: v1, v2
k1 = b%daughter(1); k2 = b%daughter(2)
if (tree%branch(k1)%has_children) then
call compute_volume_x (tree%branch(k1), k1, v1, .false.)
else
v1 = 1
end if
if (tree%branch(k2)%has_children) then
call compute_volume_x (tree%branch(k2), k2, v2, .false.)
else
v2 = 1
end if
if (initial) then
volume = v1 * v2 / (4 * twopi5)
else
volume = v1 * v2 * sqrts**2 / (4 * twopi2)
end if
end subroutine compute_volume_x
end subroutine phs_tree_compute_volume
@ %def phs_tree_compute_volume
@
\subsubsection{Determine momenta}
This is done in two steps: First the masses are determined. This step
may fail, in which case [[ok]] is set to false. If successful, we
generate angles and the actual momenta. The array [[decay_p]] serves
for transferring the individual three-momenta of the daughter
particles in their mother rest frame from the mass generation to the
momentum generation step.
<<PHS trees: phs tree: TBP>>=
procedure :: compute_momenta_from_x => phs_tree_compute_momenta_from_x
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_compute_momenta_from_x &
(tree, prt, factor, volume, sqrts, x, ok)
class(phs_tree_t), intent(inout) :: tree
type(phs_prt_t), dimension(:), intent(inout) :: prt
real(default), intent(out) :: factor, volume
real(default), intent(in) :: sqrts
real(default), dimension(:), intent(in) :: x
logical, intent(out) :: ok
end subroutine phs_tree_compute_momenta_from_x
<<PHS trees: procedures>>=
module subroutine phs_tree_compute_momenta_from_x &
(tree, prt, factor, volume, sqrts, x, ok)
class(phs_tree_t), intent(inout) :: tree
type(phs_prt_t), dimension(:), intent(inout) :: prt
real(default), intent(out) :: factor, volume
real(default), intent(in) :: sqrts
real(default), dimension(:), intent(in) :: x
logical, intent(out) :: ok
real(default), dimension(tree%mask_out) :: decay_p
integer :: n1, n2
integer :: n_out
if (tree%real_phsp) then
n_out = tree%n_externals - tree%n_in - 1
n1 = max (n_out-2, 0)
n2 = n1 + max (2*n_out, 0)
else
n1 = tree%n_msq
n2 = n1 + tree%n_angles
end if
call phs_tree_set_msq &
(tree, prt, factor, volume, decay_p, sqrts, x(1:n1), ok)
if (ok) call phs_tree_set_angles &
(tree, prt, factor, decay_p, sqrts, x(n1+1:n2))
end subroutine phs_tree_compute_momenta_from_x
@ %def phs_tree_compute_momenta_from_x
@ Mass generation is done recursively. The [[ok]] flag causes the
filled tree to be discarded if set to [[.false.]]. This happens if a
three-momentum turns out to be imaginary, indicating impossible
kinematics. The index [[ix]] tells us how far we have used up the
input array [[x]].
<<PHS trees: procedures>>=
subroutine phs_tree_set_msq &
(tree, prt, factor, volume, decay_p, sqrts, x, ok)
type(phs_tree_t), intent(inout) :: tree
type(phs_prt_t), dimension(:), intent(inout) :: prt
real(default), intent(out) :: factor, volume
real(default), dimension(:), intent(out) :: decay_p
real(default), intent(in) :: sqrts
real(default), dimension(:), intent(in) :: x
logical, intent(out) :: ok
integer :: ix
integer(TC) :: k
real(default) :: m_tot
ok =.true.
ix = 1
k = tree%mask_out
m_tot = tree%mass_sum(k)
decay_p(k) = 0.
if (m_tot < sqrts .or. k == 1) then
if (tree%branch(k)%has_children) then
call set_msq_x (tree%branch(k), k, factor, volume, .true.)
else
factor = 1
volume = 1
end if
else
ok = .false.
end if
contains
recursive subroutine set_msq_x (b, k, factor, volume, initial)
type(phs_branch_t), intent(in) :: b
integer(TC), intent(in) :: k
real(default), intent(out) :: factor, volume
logical, intent(in) :: initial
real(default) :: msq, m, m_min, m_max, m1, m2, msq1, msq2, lda, rlda
integer(TC) :: k1, k2
real(default) :: f1, f2, v1, v2
k1 = b%daughter(1); k2 = b%daughter(2)
if (tree%branch(k1)%has_children) then
call set_msq_x (tree%branch(k1), k1, f1, v1, .false.)
if (.not.ok) return
else
f1 = 1; v1 = 1
end if
if (tree%branch(k2)%has_children) then
call set_msq_x (tree%branch(k2), k2, f2, v2, .false.)
if (.not.ok) return
else
f2 = 1; v2 = 1
end if
m_min = tree%mass_sum(k)
if (initial) then
msq = sqrts**2
m = sqrts
m_max = sqrts
factor = f1 * f2
volume = v1 * v2 / (4 * twopi5)
else
m_max = sqrts - m_tot + m_min
call tree%mapping(k)%compute_msq_from_x (sqrts**2, m_min**2, &
m_max**2, msq, factor, x(ix)); ix = ix + 1
if (msq >= 0) then
m = sqrt (msq)
factor = f1 * f2 * factor
volume = v1 * v2 * sqrts**2 / (4 * twopi2)
call prt(k)%set_msq (msq)
call prt(k)%set_defined ()
else
ok = .false.
end if
end if
if (ok) then
msq1 = prt(k1)%get_msq (); m1 = sqrt (msq1)
msq2 = prt(k2)%get_msq (); m2 = sqrt (msq2)
lda = lambda (msq, msq1, msq2)
if (lda > 0 .and. m > m1 + m2 .and. m <= m_max) then
rlda = sqrt (lda)
decay_p(k1) = rlda / (2*m)
decay_p(k2) = - decay_p(k1)
factor = rlda / msq * factor
else
ok = .false.
end if
end if
end subroutine set_msq_x
end subroutine phs_tree_set_msq
@ %def phs_tree_set_msq
@
The heart of phase space generation: Now we have the invariant masses,
let us generate angles. At each branch, we take a Lorentz
transformation and augment it by a boost to the current particle
rest frame, and by rotations $\phi$ and $\theta$ around the $z$ and
$y$ axis, respectively. This transformation is passed down to the
daughter particles, if present.
<<PHS trees: procedures>>=
subroutine phs_tree_set_angles (tree, prt, factor, decay_p, sqrts, x)
type(phs_tree_t), intent(inout) :: tree
type(phs_prt_t), dimension(:), intent(inout) :: prt
real(default), intent(inout) :: factor
real(default), dimension(:), intent(in) :: decay_p
real(default), intent(in) :: sqrts
real(default), dimension(:), intent(in) :: x
integer :: ix
integer(TC) :: k
ix = 1
k = tree%mask_out
call set_angles_x (tree%branch(k), k)
contains
recursive subroutine set_angles_x (b, k, L0)
type(phs_branch_t), intent(in) :: b
integer(TC), intent(in) :: k
type(lorentz_transformation_t), intent(in), optional :: L0
real(default) :: m, msq, ct, st, phi, f, E, p, bg
type(lorentz_transformation_t) :: L, LL
integer(TC) :: k1, k2
type(vector3_t) :: axis
p = decay_p(k)
msq = prt(k)%get_msq (); m = sqrt (msq)
E = sqrt (msq + p**2)
if (present (L0)) then
call prt(k)%set_momentum (L0 * vector4_moving (E,p,3))
else
call prt(k)%set_momentum (vector4_moving (E,p,3))
end if
call prt(k)%set_defined ()
if (b%has_children) then
k1 = b%daughter(1)
k2 = b%daughter(2)
if (m > 0) then
bg = p / m
else
bg = 0
end if
phi = x(ix) * twopi; ix = ix + 1
call tree%mapping(k)%compute_ct_from_x (sqrts**2, ct, st, f, &
x(ix)); ix = ix + 1
factor = factor * f
if (.not. b%has_friend) then
L = LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), bg)
!!! The function above is equivalent to:
! L = boost (bg,3) * rotation (phi,3) * rotation (ct,st,2)
else
LL = boost (-bg,3); if (present (L0)) LL = LL * inverse(L0)
axis = space_part ( &
LL * prt(tree%branch(k)%friend)%get_momentum () )
L = boost(bg,3) * rotation_to_2nd (vector3_canonical(3), axis) &
* LT_compose_r2_r3_b3 (ct, st, cos(phi), sin(phi), 0._default)
end if
if (present (L0)) L = L0 * L
call set_angles_x (tree%branch(k1), k1, L)
call set_angles_x (tree%branch(k2), k2, L)
end if
end subroutine set_angles_x
end subroutine phs_tree_set_angles
@ %def phs_tree_set_angles
@
\subsubsection{Recover random numbers}
For the other channels we want to compute the random numbers that
would have generated the momenta that we already know.
<<PHS trees: phs tree: TBP>>=
procedure :: compute_x_from_momenta => phs_tree_compute_x_from_momenta
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_compute_x_from_momenta &
(tree, prt, factor, sqrts, x)
class(phs_tree_t), intent(inout) :: tree
type(phs_prt_t), dimension(:), intent(in) :: prt
real(default), intent(out) :: factor
real(default), intent(in) :: sqrts
real(default), dimension(:), intent(inout) :: x
end subroutine phs_tree_compute_x_from_momenta
<<PHS trees: procedures>>=
module subroutine phs_tree_compute_x_from_momenta &
(tree, prt, factor, sqrts, x)
class(phs_tree_t), intent(inout) :: tree
type(phs_prt_t), dimension(:), intent(in) :: prt
real(default), intent(out) :: factor
real(default), intent(in) :: sqrts
real(default), dimension(:), intent(inout) :: x
real(default), dimension(tree%mask_out) :: decay_p
integer :: n1, n2
n1 = tree%n_msq
n2 = n1 + tree%n_angles
call phs_tree_get_msq &
(tree, prt, factor, decay_p, sqrts, x(1:n1))
call phs_tree_get_angles &
(tree, prt, factor, decay_p, sqrts, x(n1+1:n2))
end subroutine phs_tree_compute_x_from_momenta
@ %def phs_tree_compute_x_from_momenta
@ The inverse operation follows exactly the same steps. The tree is
[[inout]] because it contains mappings whose parameters can be reset
when the mapping is applied.
<<PHS trees: procedures>>=
subroutine phs_tree_get_msq (tree, prt, factor, decay_p, sqrts, x)
type(phs_tree_t), intent(inout) :: tree
type(phs_prt_t), dimension(:), intent(in) :: prt
real(default), intent(out) :: factor
real(default), dimension(:), intent(out) :: decay_p
real(default), intent(in) :: sqrts
real(default), dimension(:), intent(inout) :: x
integer :: ix
integer(TC) :: k
real(default) :: m_tot
ix = 1
k = tree%mask_out
m_tot = tree%mass_sum(k)
decay_p(k) = 0.
if (tree%branch(k)%has_children) then
call get_msq_x (tree%branch(k), k, factor, .true.)
else
factor = 1
end if
contains
recursive subroutine get_msq_x (b, k, factor, initial)
type(phs_branch_t), intent(in) :: b
integer(TC), intent(in) :: k
real(default), intent(out) :: factor
logical, intent(in) :: initial
real(default) :: msq, m, m_min, m_max, msq1, msq2, lda, rlda
integer(TC) :: k1, k2
real(default) :: f1, f2
k1 = b%daughter(1); k2 = b%daughter(2)
if (tree%branch(k1)%has_children) then
call get_msq_x (tree%branch(k1), k1, f1, .false.)
else
f1 = 1
end if
if (tree%branch(k2)%has_children) then
call get_msq_x (tree%branch(k2), k2, f2, .false.)
else
f2 = 1
end if
m_min = tree%mass_sum(k)
m_max = sqrts - m_tot + m_min
msq = prt(k)%get_msq (); m = sqrt (msq)
if (initial) then
factor = f1 * f2
else
call tree%mapping(k)%compute_x_from_msq (sqrts**2, m_min**2, &
m_max**2, msq, factor, x(ix)); ix = ix + 1
factor = f1 * f2 * factor
end if
msq1 = prt(k1)%get_msq ()
msq2 = prt(k2)%get_msq ()
lda = lambda (msq, msq1, msq2)
if (lda > 0) then
rlda = sqrt (lda)
decay_p(k1) = rlda / (2 * m)
decay_p(k2) = - decay_p(k1)
factor = rlda / msq * factor
else
decay_p(k1) = 0
decay_p(k2) = 0
factor = 0
end if
end subroutine get_msq_x
end subroutine phs_tree_get_msq
@ %def phs_tree_get_msq
@ This subroutine is the most time-critical part of the whole
program. Therefore, we do not exactly parallel the angle generation
routine above but make sure that things get evaluated only if they are
really needed, at the expense of readability. Particularly important
is to have as few multiplications of Lorentz transformations as
possible.
<<PHS trees: procedures>>=
subroutine phs_tree_get_angles (tree, prt, factor, decay_p, sqrts, x)
type(phs_tree_t), intent(inout) :: tree
type(phs_prt_t), dimension(:), intent(in) :: prt
real(default), intent(inout) :: factor
real(default), dimension(:), intent(in) :: decay_p
real(default), intent(in) :: sqrts
real(default), dimension(:), intent(out) :: x
integer :: ix
integer(TC) :: k
ix = 1
k = tree%mask_out
if (tree%branch(k)%has_children) then
call get_angles_x (tree%branch(k), k)
end if
contains
recursive subroutine get_angles_x (b, k, ct0, st0, phi0, L0)
type(phs_branch_t), intent(in) :: b
integer(TC), intent(in) :: k
real(default), intent(in), optional :: ct0, st0, phi0
type(lorentz_transformation_t), intent(in), optional :: L0
real(default) :: cp0, sp0, m, msq, ct, st, phi, bg, f
type(lorentz_transformation_t) :: L, LL
type(vector4_t) :: p1, pf
type(vector3_t) :: n, axis
integer(TC) :: k1, k2, kf
logical :: has_friend, need_L
k1 = b%daughter(1)
k2 = b%daughter(2)
kf = b%friend
has_friend = b%has_friend
if (present(L0)) then
p1 = L0 * prt(k1)%get_momentum ()
if (has_friend) pf = L0 * prt(kf)%get_momentum ()
else
p1 = prt(k1)%get_momentum ()
if (has_friend) pf = prt(kf)%get_momentum ()
end if
if (present(phi0)) then
cp0 = cos (phi0)
sp0 = sin (phi0)
end if
msq = prt(k)%get_msq (); m = sqrt (msq)
if (m > 0) then
bg = decay_p(k) / m
else
bg = 0
end if
if (has_friend) then
if (present (phi0)) then
axis = axis_from_p_r3_r2_b3 (pf, cp0, -sp0, ct0, -st0, -bg)
LL = rotation_to_2nd (axis, vector3_canonical (3)) &
* LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg)
else
axis = axis_from_p_b3 (pf, -bg)
LL = rotation_to_2nd (axis, vector3_canonical(3))
if (.not. vanishes (bg)) LL = LL * boost(-bg, 3)
end if
n = space_part (LL * p1)
else if (present (phi0)) then
n = axis_from_p_r3_r2_b3 (p1, cp0, -sp0, ct0, -st0, -bg)
else
n = axis_from_p_b3 (p1, -bg)
end if
phi = azimuthal_angle (n)
x(ix) = phi / twopi; ix = ix + 1
ct = polar_angle_ct (n)
st = sqrt (1 - ct**2)
call tree%mapping(k)%compute_x_from_ct (sqrts**2, ct, f, &
x(ix)); ix = ix + 1
factor = factor * f
if (tree%branch(k1)%has_children .or. tree%branch(k2)%has_children) then
need_L = .true.
if (has_friend) then
if (present (L0)) then
L = LL * L0
else
L = LL
end if
else if (present (L0)) then
L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg) * L0
else if (present (phi0)) then
L = LT_compose_r3_r2_b3 (cp0, -sp0, ct0, -st0, -bg)
else if (bg /= 0) then
L = boost(-bg, 3)
else
need_L = .false.
end if
if (need_L) then
if (tree%branch(k1)%has_children) &
call get_angles_x (tree%branch(k1), k1, ct, st, phi, L)
if (tree%branch(k2)%has_children) &
call get_angles_x (tree%branch(k2), k2, ct, st, phi, L)
else
if (tree%branch(k1)%has_children) &
call get_angles_x (tree%branch(k1), k1, ct, st, phi)
if (tree%branch(k2)%has_children) &
call get_angles_x (tree%branch(k2), k2, ct, st, phi)
end if
end if
end subroutine get_angles_x
end subroutine phs_tree_get_angles
@ %def phs_tree_get_angles
@
\subsubsection{Auxiliary stuff}
This calculates all momenta that are not yet known by summing up
daughter particle momenta. The external particles must be known.
Only composite particles not yet known are calculated.
<<PHS trees: public>>=
public :: phs_tree_combine_particles
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_combine_particles (tree, prt)
type(phs_tree_t), intent(in) :: tree
type(phs_prt_t), dimension(:), intent(inout) :: prt
end subroutine phs_tree_combine_particles
<<PHS trees: procedures>>=
module subroutine phs_tree_combine_particles (tree, prt)
type(phs_tree_t), intent(in) :: tree
type(phs_prt_t), dimension(:), intent(inout) :: prt
call combine_particles_x (tree%mask_out)
contains
recursive subroutine combine_particles_x (k)
integer(TC), intent(in) :: k
integer :: k1, k2
if (tree%branch(k)%has_children) then
k1 = tree%branch(k)%daughter(1); k2 = tree%branch(k)%daughter(2)
call combine_particles_x (k1)
call combine_particles_x (k2)
if (.not. prt(k)%defined) then
call prt(k)%combine (prt(k1), prt(k2))
end if
end if
end subroutine combine_particles_x
end subroutine phs_tree_combine_particles
@ %def phs_tree_combine_particles
@ The previous routine is to be evaluated at runtime. Instead of
scanning trees, we can as well set up a multiplication table. This is
generated here. Note that the table is [[intent(out)]].
<<PHS trees: public>>=
public :: phs_tree_setup_prt_combinations
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_setup_prt_combinations (tree, comb)
type(phs_tree_t), intent(in) :: tree
integer, dimension(:,:), intent(out) :: comb
end subroutine phs_tree_setup_prt_combinations
<<PHS trees: procedures>>=
module subroutine phs_tree_setup_prt_combinations (tree, comb)
type(phs_tree_t), intent(in) :: tree
integer, dimension(:,:), intent(out) :: comb
comb = 0
call setup_prt_combinations_x (tree%mask_out)
contains
recursive subroutine setup_prt_combinations_x (k)
integer(TC), intent(in) :: k
integer, dimension(2) :: kk
if (tree%branch(k)%has_children) then
kk = tree%branch(k)%daughter
call setup_prt_combinations_x (kk(1))
call setup_prt_combinations_x (kk(2))
comb(:,k) = kk
end if
end subroutine setup_prt_combinations_x
end subroutine phs_tree_setup_prt_combinations
@ %def phs_tree_setup_prt_combinations
@ JRR: 2022-01-22 [[reshuffle_mappings]] is commented out, and no
longer used, not clear why?
<<PHS trees: phs tree: TBP>>=
procedure :: reshuffle_mappings => phs_tree_reshuffle_mappings
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_reshuffle_mappings (tree)
class(phs_tree_t), intent(inout) :: tree
end subroutine phs_tree_reshuffle_mappings
<<PHS trees: procedures>>=
module subroutine phs_tree_reshuffle_mappings (tree)
class(phs_tree_t), intent(inout) :: tree
integer(TC) :: k0, k_old, k_new, k2
integer :: i
type(mapping_t) :: mapping_tmp
real(default) :: mass_tmp
do i = 1, size (tree%momentum_link)
if (i /= tree%momentum_link (i)) then
k_old = 2**(i-tree%n_in-1)
k_new = 2**(tree%momentum_link(i)-tree%n_in-1)
k0 = tree%branch(k_old)%mother
k2 = k_new + tree%branch(k_old)%sibling
mapping_tmp = tree%mapping(k0)
mass_tmp = tree%mass_sum(k0)
tree%mapping(k0) = tree%mapping(k2)
tree%mapping(k2) = mapping_tmp
tree%mass_sum(k0) = tree%mass_sum(k2)
tree%mass_sum(k2) = mass_tmp
end if
end do
end subroutine phs_tree_reshuffle_mappings
@ %def phs_tree_reshuffle_mappings
@
<<PHS trees: public>>=
public :: phs_tree_set_momentum_links
<<PHS trees: sub interfaces>>=
module subroutine phs_tree_set_momentum_links (tree, list)
type(phs_tree_t), intent(inout) :: tree
integer, dimension(:), allocatable :: list
end subroutine phs_tree_set_momentum_links
<<PHS trees: procedures>>=
module subroutine phs_tree_set_momentum_links (tree, list)
type(phs_tree_t), intent(inout) :: tree
integer, dimension(:), allocatable :: list
tree%momentum_link = list
end subroutine phs_tree_set_momentum_links
@ %def phs_tree_set_momentum_links
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[phs_trees_ut.f90]]>>=
<<File header>>
module phs_trees_ut
use unit_tests
use phs_trees_uti
<<Standard module head>>
<<PHS trees: public test>>
contains
<<PHS trees: test driver>>
end module phs_trees_ut
@ %def phs_trees_ut
@
<<[[phs_trees_uti.f90]]>>=
<<File header>>
module phs_trees_uti
!!!<<Use kinds>>
use kinds, only: TC
<<Use strings>>
use flavors, only: flavor_t
use model_data, only: model_data_t
use resonances, only: resonance_history_t
use mappings, only: mapping_defaults_t
use phs_trees
<<Standard module head>>
<<PHS trees: test declarations>>
contains
<<PHS trees: tests>>
end module phs_trees_uti
@ %def phs_trees_ut
@ API: driver for the unit tests below.
<<PHS trees: public test>>=
public :: phs_trees_test
<<PHS trees: test driver>>=
subroutine phs_trees_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS trees: execute tests>>
end subroutine phs_trees_test
@ %def phs_trees_test
@
Create a simple $2\to 3$ PHS tree and display it.
<<PHS trees: execute tests>>=
call test (phs_tree_1, "phs_tree_1", &
"check phs tree setup", &
u, results)
<<PHS trees: test declarations>>=
public :: phs_tree_1
<<PHS trees: tests>>=
subroutine phs_tree_1 (u)
integer, intent(in) :: u
type(phs_tree_t) :: tree
type(model_data_t), target :: model
type(flavor_t), dimension(5) :: flv
integer :: i
write (u, "(A)") "* Test output: phs_tree_1"
write (u, "(A)") "* Purpose: test PHS tree routines"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Set up flavors"
write (u, "(A)")
call flv%init ([1, -2, 24, 5, -5], model)
do i = 1, 5
write (u, "(1x)", advance="no")
call flv(i)%write (u)
end do
write (u, *)
write (u, "(A)")
write (u, "(A)") "* Create tree"
write (u, "(A)")
call tree%init (2, 3, 0, 0)
call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16])
call tree%set_mass_sum (flv)
call tree%set_effective_masses ()
call tree%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call tree%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_tree_1"
end subroutine phs_tree_1
@ %def phs_tree_1
@ The analogous tree with resonance (s-channel) mappings.
<<PHS trees: execute tests>>=
call test (phs_tree_2, "phs_tree_2", &
"check phs tree with resonances", &
u, results)
<<PHS trees: test declarations>>=
public :: phs_tree_2
<<PHS trees: tests>>=
subroutine phs_tree_2 (u)
integer, intent(in) :: u
type(phs_tree_t) :: tree
type(model_data_t), target :: model
type(mapping_defaults_t) :: mapping_defaults
type(flavor_t), dimension(5) :: flv
type(resonance_history_t) :: res_history
integer :: i
write (u, "(A)") "* Test output: phs_tree_2"
write (u, "(A)") "* Purpose: test PHS tree with resonances"
write (u, "(A)")
write (u, "(A)") "* Read model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Set up flavors"
write (u, "(A)")
call flv%init ([1, -2, 24, 5, -5], model)
do i = 1, 5
write (u, "(1x)", advance="no")
call flv(i)%write (u)
end do
write (u, *)
write (u, "(A)")
write (u, "(A)") "* Create tree with mappings"
write (u, "(A)")
call tree%init (2, 3, 0, 0)
call tree%from_array ([integer(TC) :: 1, 2, 3, 4, 7, 8, 16])
call tree%set_mass_sum (flv)
call tree%init_mapping (3_TC, var_str ("s_channel"), -24, model)
call tree%init_mapping (7_TC, var_str ("s_channel"), 23, model)
call tree%set_mapping_parameters (mapping_defaults, variable_limits=.false.)
call tree%set_effective_masses ()
call tree%write (u)
write (u, "(A)")
write (u, "(A)") "* Extract resonances from mappings"
write (u, "(A)")
call tree%extract_resonance_history (res_history)
call res_history%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call tree%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_tree_2"
end subroutine phs_tree_2
@ %def phs_tree_2
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{The phase-space forest}
Simply stated, a phase-space forest is a collection of phase-space
trees. More precisely, a [[phs_forest]] object contains all
parameterizations of phase space that \whizard\ will use for a single
hard process, prepared in the form of [[phs_tree]] objects. This is
suitable for evaluation by the \vamp\ integration package: each
parameterization (tree) is a valid channel in the multi-channel
adaptive integration, and each variable in a tree corresponds to an
integration dimension, defined by an appropriate mapping of the
$(0,1)$ interval to the allowed range of the integration variable.
The trees are grouped in groves. The trees (integration channels)
within a grove share a common weight, assuming that they are related
by some approximate symmetry.
Trees/channels that are related by an exact symmetry are connected by
an array of equivalences; each equivalence object holds the data that
relate one channel to another.
The phase-space setup, i.e., the detailed structure of trees and
forest, are read from a file. Therefore, this module also contains
the syntax definition and the parser needed for interpreting this
file.
<<[[phs_forests.f90]]>>=
<<File header>>
module phs_forests
<<Use kinds>>
use kinds, only: TC
<<Use strings>>
use lorentz
use permutations
use syntax_rules
use parser
use model_data
use flavors
use interactions
use phs_base
use resonances, only: resonance_history_t
use resonances, only: resonance_history_set_t
use mappings
use phs_trees
<<Standard module head>>
<<PHS forests: public>>
<<PHS forests: types>>
<<PHS forests: interfaces>>
<<PHS forests: variables>>
interface
<<PHS forests: sub interfaces>>
end interface
contains
<<PHS forests: main procedures>>
end module phs_forests
@ %def phs_forests
@
<<[[phs_forests_sub.f90]]>>=
<<File header>>
submodule (phs_forests) phs_forests_s
use io_units
use format_defs, only: FMT_19
use diagnostics
use numeric_utils
use ifiles
use lexers
!!! Intel oneAPI 2022/23 regression workaround
use resonances, only: resonance_history_t
implicit none
contains
<<PHS forests: procedures>>
end submodule phs_forests_s
@ %def phs_forests_s
@
\subsection{Phase-space setup parameters}
This transparent container holds the parameters that the algorithm
needs for phase-space setup, with reasonable defaults.
The threshold mass (for considering a particle as effectively
massless) is specified separately for s- and t-channel. The default is
to treat $W$ and $Z$ bosons as massive in the s-channel, but as
massless in the t-channel. The $b$-quark is treated always massless,
the $t$-quark always massive.
<<PHS forests: public>>=
public :: phs_parameters_t
<<PHS forests: types>>=
type :: phs_parameters_t
real(default) :: sqrts = 0
real(default) :: m_threshold_s = 50._default
real(default) :: m_threshold_t = 100._default
integer :: off_shell = 1
integer :: t_channel = 2
logical :: keep_nonresonant = .true.
contains
<<PHS forests: phs parameters: TBP>>
end type phs_parameters_t
@ %def phs_parameters_t
@ Write phase-space parameters to file.
<<PHS forests: phs parameters: TBP>>=
procedure :: write => phs_parameters_write
<<PHS forests: sub interfaces>>=
module subroutine phs_parameters_write (phs_par, unit)
class(phs_parameters_t), intent(in) :: phs_par
integer, intent(in), optional :: unit
end subroutine phs_parameters_write
<<PHS forests: procedures>>=
module subroutine phs_parameters_write (phs_par, unit)
class(phs_parameters_t), intent(in) :: phs_par
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(3x,A," // FMT_19 // ")") "sqrts = ", phs_par%sqrts
write (u, "(3x,A," // FMT_19 // ")") "m_threshold_s = ", phs_par%m_threshold_s
write (u, "(3x,A," // FMT_19 // ")") "m_threshold_t = ", phs_par%m_threshold_t
write (u, "(3x,A,I0)") "off_shell = ", phs_par%off_shell
write (u, "(3x,A,I0)") "t_channel = ", phs_par%t_channel
write (u, "(3x,A,L1)") "keep_nonresonant = ", phs_par%keep_nonresonant
end subroutine phs_parameters_write
@ %def phs_parameters_write
@ Read phase-space parameters from file.
<<PHS forests: phs parameters: TBP>>=
procedure :: read => phs_parameters_read
<<PHS forests: sub interfaces>>=
module subroutine phs_parameters_read (phs_par, unit)
class(phs_parameters_t), intent(out) :: phs_par
integer, intent(in) :: unit
end subroutine phs_parameters_read
<<PHS forests: procedures>>=
module subroutine phs_parameters_read (phs_par, unit)
class(phs_parameters_t), intent(out) :: phs_par
integer, intent(in) :: unit
character(20) :: dummy
character :: equals
read (unit, *) dummy, equals, phs_par%sqrts
read (unit, *) dummy, equals, phs_par%m_threshold_s
read (unit, *) dummy, equals, phs_par%m_threshold_t
read (unit, *) dummy, equals, phs_par%off_shell
read (unit, *) dummy, equals, phs_par%t_channel
read (unit, *) dummy, equals, phs_par%keep_nonresonant
end subroutine phs_parameters_read
@ %def phs_parameters_write
@ Comparison.
<<PHS forests: interfaces>>=
interface operator(==)
module procedure phs_parameters_eq
end interface
interface operator(/=)
module procedure phs_parameters_ne
end interface
<<PHS forests: sub interfaces>>=
module function phs_parameters_eq (phs_par1, phs_par2) result (equal)
logical :: equal
type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
end function phs_parameters_eq
module function phs_parameters_ne (phs_par1, phs_par2) result (ne)
logical :: ne
type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
end function phs_parameters_ne
<<PHS forests: procedures>>=
module function phs_parameters_eq (phs_par1, phs_par2) result (equal)
logical :: equal
type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
equal = phs_par1%sqrts == phs_par2%sqrts &
.and. phs_par1%m_threshold_s == phs_par2%m_threshold_s &
.and. phs_par1%m_threshold_t == phs_par2%m_threshold_t &
.and. phs_par1%off_shell == phs_par2%off_shell &
.and. phs_par1%t_channel == phs_par2%t_channel &
.and.(phs_par1%keep_nonresonant .eqv. phs_par2%keep_nonresonant)
end function phs_parameters_eq
module function phs_parameters_ne (phs_par1, phs_par2) result (ne)
logical :: ne
type(phs_parameters_t), intent(in) :: phs_par1, phs_par2
ne = phs_par1%sqrts /= phs_par2%sqrts &
.or. phs_par1%m_threshold_s /= phs_par2%m_threshold_s &
.or. phs_par1%m_threshold_t /= phs_par2%m_threshold_t &
.or. phs_par1%off_shell /= phs_par2%off_shell &
.or. phs_par1%t_channel /= phs_par2%t_channel &
.or.(phs_par1%keep_nonresonant .neqv. phs_par2%keep_nonresonant)
end function phs_parameters_ne
@ %def phs_parameters_eq phs_parameters_ne
@
\subsection{Equivalences}
This type holds information about equivalences between phase-space
trees. We make a linked list, where each node contains the two
trees which are equivalent and the corresponding permutation of
external particles. Two more arrays are to be filled: The permutation
of mass variables and the permutation of angular variables, where the
signature indicates a necessary exchange of daughter branches.
<<PHS forests: types>>=
type :: equivalence_t
private
integer :: left, right
type(permutation_t) :: perm
type(permutation_t) :: msq_perm, angle_perm
logical, dimension(:), allocatable :: angle_sig
type(equivalence_t), pointer :: next => null ()
end type equivalence_t
@ %def equivalence_t
<<PHS forests: types>>=
type :: equivalence_list_t
private
integer :: length = 0
type(equivalence_t), pointer :: first => null ()
type(equivalence_t), pointer :: last => null ()
end type equivalence_list_t
@ %def equivalence_list_t
@ Append an equivalence to the list
<<PHS forests: procedures>>=
subroutine equivalence_list_add (eql, left, right, perm)
type(equivalence_list_t), intent(inout) :: eql
integer, intent(in) :: left, right
type(permutation_t), intent(in) :: perm
type(equivalence_t), pointer :: eq
allocate (eq)
eq%left = left
eq%right = right
eq%perm = perm
if (associated (eql%last)) then
eql%last%next => eq
else
eql%first => eq
end if
eql%last => eq
eql%length = eql%length + 1
end subroutine equivalence_list_add
@ %def equivalence_list_add
@ Delete the list contents. Has to be pure because it is called from
an elemental subroutine.
<<PHS forests: procedures>>=
pure subroutine equivalence_list_final (eql)
type(equivalence_list_t), intent(inout) :: eql
type(equivalence_t), pointer :: eq
do while (associated (eql%first))
eq => eql%first
eql%first => eql%first%next
deallocate (eq)
end do
eql%last => null ()
eql%length = 0
end subroutine equivalence_list_final
@ %def equivalence_list_final
@ Make a deep copy of the equivalence list. This allows for deep
copies of groves and forests.
<<PHS forests: interfaces>>=
interface assignment(=)
module procedure equivalence_list_assign
end interface
<<PHS forests: main procedures>>=
subroutine equivalence_list_assign (eql_out, eql_in)
type(equivalence_list_t), intent(out) :: eql_out
type(equivalence_list_t), intent(in) :: eql_in
type(equivalence_t), pointer :: eq, eq_copy
eq => eql_in%first
do while (associated (eq))
allocate (eq_copy)
eq_copy = eq
eq_copy%next => null ()
if (associated (eql_out%first)) then
eql_out%last%next => eq_copy
else
eql_out%first => eq_copy
end if
eql_out%last => eq_copy
eq => eq%next
end do
end subroutine equivalence_list_assign
@ %def equivalence_list_assign
@ The number of list entries
<<PHS forests: procedures>>=
elemental function equivalence_list_length (eql) result (length)
integer :: length
type(equivalence_list_t), intent(in) :: eql
length = eql%length
end function equivalence_list_length
@ %def equivalence_list_length
@ Recursively write the equivalences list
<<PHS forests: procedures>>=
subroutine equivalence_list_write (eql, unit)
type(equivalence_list_t), intent(in) :: eql
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
if (associated (eql%first)) then
call equivalence_write_rec (eql%first, u)
else
write (u, *) " [empty]"
end if
contains
recursive subroutine equivalence_write_rec (eq, u)
type(equivalence_t), intent(in) :: eq
integer, intent(in) :: u
integer :: i
write (u, "(3x,A,1x,I0,1x,I0,2x,A)", advance="no") &
"Equivalence:", eq%left, eq%right, "Final state permutation:"
call permutation_write (eq%perm, u)
write (u, "(1x,12x,1x,A,1x)", advance="no") &
" msq permutation: "
call permutation_write (eq%msq_perm, u)
write (u, "(1x,12x,1x,A,1x)", advance="no") &
" angle permutation:"
call permutation_write (eq%angle_perm, u)
write (u, "(1x,12x,1x,26x)", advance="no")
do i = 1, size (eq%angle_sig)
if (eq%angle_sig(i)) then
write (u, "(1x,A)", advance="no") "+"
else
write (u, "(1x,A)", advance="no") "-"
end if
end do
write (u, *)
if (associated (eq%next)) call equivalence_write_rec (eq%next, u)
end subroutine equivalence_write_rec
end subroutine equivalence_list_write
@ %def equivalence_list_write
@
\subsection{Groves}
A grove is a group of trees (phase-space channels) that share a common
weight in the integration. Within a grove, channels can be declared
equivalent, so they also share their integration grids (up to
symmetries). The grove contains a list of equivalences. The
[[tree_count_offset]] is the total number of trees of the preceding
groves; when the trees are counted per forest (integration channels),
the offset has to be added to all tree indices.
<<PHS forests: types>>=
type :: phs_grove_t
private
integer :: tree_count_offset
type(phs_tree_t), dimension(:), allocatable :: tree
type(equivalence_list_t) :: equivalence_list
end type phs_grove_t
@ %def phs_grove_t
@ Call [[phs_tree_init]] which is also elemental:
<<PHS forests: procedures>>=
elemental subroutine phs_grove_init &
(grove, n_trees, n_in, n_out, n_masses, n_angles)
type(phs_grove_t), intent(inout) :: grove
integer, intent(in) :: n_trees, n_in, n_out, n_masses, n_angles
grove%tree_count_offset = 0
allocate (grove%tree (n_trees))
call grove%tree%init (n_in, n_out, n_masses, n_angles)
end subroutine phs_grove_init
@ %def phs_grove_init
@ The trees do not have pointer components, thus no call to
[[phs_tree_final]]:
<<PHS forests: procedures>>=
elemental subroutine phs_grove_final (grove)
type(phs_grove_t), intent(inout) :: grove
deallocate (grove%tree)
call equivalence_list_final (grove%equivalence_list)
end subroutine phs_grove_final
@ %def phs_grove_final
@ Deep copy. This triggers double free corruption with the Intel
compiler and hence has to remain in the main module.
<<PHS forests: interfaces>>=
interface assignment(=)
module procedure phs_grove_assign0
module procedure phs_grove_assign1
end interface
<<PHS forests: main procedures>>=
subroutine phs_grove_assign0 (grove_out, grove_in)
type(phs_grove_t), intent(out) :: grove_out
type(phs_grove_t), intent(in) :: grove_in
grove_out%tree_count_offset = grove_in%tree_count_offset
if (allocated (grove_in%tree)) then
allocate (grove_out%tree (size (grove_in%tree)))
grove_out%tree = grove_in%tree
end if
grove_out%equivalence_list = grove_in%equivalence_list
end subroutine phs_grove_assign0
subroutine phs_grove_assign1 (grove_out, grove_in)
type(phs_grove_t), dimension(:), intent(out) :: grove_out
type(phs_grove_t), dimension(:), intent(in) :: grove_in
integer :: i
do i = 1, size (grove_in)
call phs_grove_assign0 (grove_out(i), grove_in(i))
end do
end subroutine phs_grove_assign1
@ %def phs_grove_assign
@ Get the global (s-channel) mappings. Implemented as a subroutine
which returns an array (slice).
<<PHS forests: procedures>>=
subroutine phs_grove_assign_s_mappings (grove, mapping)
type(phs_grove_t), intent(in) :: grove
type(mapping_t), dimension(:), intent(out) :: mapping
integer :: i
if (size (mapping) == size (grove%tree)) then
do i = 1, size (mapping)
call grove%tree(i)%assign_s_mapping (mapping(i))
end do
else
call msg_bug ("phs_grove_assign_s_mappings: array size mismatch")
end if
end subroutine phs_grove_assign_s_mappings
@ %def phs_grove_assign_s_mappings
@
\subsection{The forest type}
This is a collection of trees and associated particles. In a given
tree, each branch code corresponds to a particle in the [[prt]] array.
Furthermore, we have an array of mass sums which is independent of the
decay tree and of the particular event. The mappings directly
correspond to the decay trees, and the decay groves collect the trees
in classes. The permutation list consists of all permutations of
outgoing particles that map the decay forest onto itself.
The particle codes [[flv]] (one for each external particle) are needed
for determining masses and such. The trees and associated information
are collected in the [[grove]] array, together with a lookup table
that associates tree indices to groves. Finally, the [[prt]] array
serves as workspace for phase-space evaluation.
The [[prt_combination]] is a list of index pairs, namely the particle
momenta pairs that need to be combined in order to provide all
momentum combinations that the phase-space trees need to know.
<<PHS forests: public>>=
public :: phs_forest_t
<<PHS forests: types>>=
type :: phs_forest_t
private
integer :: n_in, n_out, n_tot
integer :: n_masses, n_angles, n_dimensions
integer :: n_trees, n_equivalences
type(flavor_t), dimension(:), allocatable :: flv
type(phs_grove_t), dimension(:), allocatable :: grove
integer, dimension(:), allocatable :: grove_lookup
type(phs_prt_t), dimension(:), allocatable :: prt_in
type(phs_prt_t), dimension(:), allocatable :: prt_out
type(phs_prt_t), dimension(:), allocatable :: prt
integer(TC), dimension(:,:), allocatable :: prt_combination
type(mapping_t), dimension(:), allocatable :: s_mapping
contains
<<PHS forests: phs forest: TBP>>
end type phs_forest_t
@ %def phs_forest_t
@
The initialization merely allocates memory. We have to know how many
trees there are in each grove, so we can initialize everything. The
number of groves is the size of the [[n_tree]] array.
In the [[grove_lookup]] table we store the grove index that belongs to
each absolute tree index. The difference between the absolute index
and the relative (to the grove) index is stored, for each grove, as
[[tree_count_offset]].
The particle array is allocated according to the total number of
branches each tree has, but not filled.
<<PHS forests: phs forest: TBP>>=
procedure :: init => phs_forest_init
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_init (forest, n_tree, n_in, n_out)
class(phs_forest_t), intent(inout) :: forest
integer, dimension(:), intent(in) :: n_tree
integer, intent(in) :: n_in, n_out
end subroutine phs_forest_init
<<PHS forests: procedures>>=
module subroutine phs_forest_init (forest, n_tree, n_in, n_out)
class(phs_forest_t), intent(inout) :: forest
integer, dimension(:), intent(in) :: n_tree
integer, intent(in) :: n_in, n_out
integer :: g, count, k_root
forest%n_in = n_in
forest%n_out = n_out
forest%n_tot = n_in + n_out
forest%n_masses = max (n_out - 2, 0)
forest%n_angles = max (2*n_out - 2, 0)
forest%n_dimensions = forest%n_masses + forest%n_angles
forest%n_trees = sum (n_tree)
forest%n_equivalences = 0
allocate (forest%grove (size (n_tree)))
call phs_grove_init &
(forest%grove, n_tree, n_in, n_out, forest%n_masses, &
forest%n_angles)
allocate (forest%grove_lookup (forest%n_trees))
count = 0
do g = 1, size (forest%grove)
forest%grove(g)%tree_count_offset = count
forest%grove_lookup (count+1:count+n_tree(g)) = g
count = count + n_tree(g)
end do
allocate (forest%prt_in (n_in))
allocate (forest%prt_out (forest%n_out))
k_root = 2**forest%n_tot - 1
allocate (forest%prt (k_root))
allocate (forest%prt_combination (2, k_root))
allocate (forest%s_mapping (forest%n_trees))
end subroutine phs_forest_init
@ %def phs_forest_init
@ Assign the global (s-channel) mappings.
<<PHS forests: phs forest: TBP>>=
procedure :: set_s_mappings => phs_forest_set_s_mappings
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_set_s_mappings (forest)
class(phs_forest_t), intent(inout) :: forest
end subroutine phs_forest_set_s_mappings
<<PHS forests: procedures>>=
module subroutine phs_forest_set_s_mappings (forest)
class(phs_forest_t), intent(inout) :: forest
integer :: g, i0, i1, n
do g = 1, size (forest%grove)
call forest%get_grove_bounds (g, i0, i1, n)
call phs_grove_assign_s_mappings &
(forest%grove(g), forest%s_mapping(i0:i1))
end do
end subroutine phs_forest_set_s_mappings
@ %def phs_forest_set_s_mappings
@ The grove finalizer is called because it contains the equivalence list:
<<PHS forests: phs forest: TBP>>=
procedure :: final => phs_forest_final
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_final (forest)
class(phs_forest_t), intent(inout) :: forest
end subroutine phs_forest_final
<<PHS forests: procedures>>=
module subroutine phs_forest_final (forest)
class(phs_forest_t), intent(inout) :: forest
if (allocated (forest%grove)) then
call phs_grove_final (forest%grove)
deallocate (forest%grove)
end if
if (allocated (forest%grove_lookup)) deallocate (forest%grove_lookup)
if (allocated (forest%prt)) deallocate (forest%prt)
if (allocated (forest%s_mapping)) deallocate (forest%s_mapping)
end subroutine phs_forest_final
@ %def phs_forest_final
@
\subsection{Screen output}
Write the particles that are non-null, then the trees which point to
them:
<<PHS forests: phs forest: TBP>>=
procedure :: write => phs_forest_write
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_write (forest, unit)
class(phs_forest_t), intent(in) :: forest
integer, intent(in), optional :: unit
end subroutine phs_forest_write
<<PHS forests: procedures>>=
module subroutine phs_forest_write (forest, unit)
class(phs_forest_t), intent(in) :: forest
integer, intent(in), optional :: unit
integer :: u
integer :: i, g, k
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "Phase space forest:"
write (u, "(3x,A,I0)") "n_in = ", forest%n_in
write (u, "(3x,A,I0)") "n_out = ", forest%n_out
write (u, "(3x,A,I0)") "n_tot = ", forest%n_tot
write (u, "(3x,A,I0)") "n_masses = ", forest%n_masses
write (u, "(3x,A,I0)") "n_angles = ", forest%n_angles
write (u, "(3x,A,I0)") "n_dim = ", forest%n_dimensions
write (u, "(3x,A,I0)") "n_trees = ", forest%n_trees
write (u, "(3x,A,I0)") "n_equiv = ", forest%n_equivalences
write (u, "(3x,A)", advance="no") "flavors ="
if (allocated (forest%flv)) then
do i = 1, size (forest%flv)
write (u, "(1x,I0)", advance="no") forest%flv(i)%get_pdg ()
end do
write (u, "(A)")
else
write (u, "(1x,A)") "[empty]"
end if
write (u, "(1x,A)") "Particle combinations:"
if (allocated (forest%prt_combination)) then
do k = 1, size (forest%prt_combination, 2)
if (forest%prt_combination(1, k) /= 0) then
write (u, "(3x,I0,1x,'<=',1x,I0,1x,'+',1x,I0)") &
k, forest%prt_combination(:,k)
end if
end do
else
write (u, "(3x,A)") " [empty]"
end if
write (u, "(1x,A)") "Groves and trees:"
if (allocated (forest%grove)) then
do g = 1, size (forest%grove)
write (u, "(3x,A,1x,I0)") "Grove ", g
call phs_grove_write (forest%grove(g), unit)
end do
else
write (u, "(3x,A)") " [empty]"
end if
write (u, "(1x,A,I0)") "Total number of equivalences: ", &
forest%n_equivalences
write (u, "(A)")
write (u, "(1x,A)") "Global s-channel mappings:"
if (allocated (forest%s_mapping)) then
do i = 1, size (forest%s_mapping)
associate (mapping => forest%s_mapping(i))
if (mapping%is_s_channel () .or. mapping%is_on_shell ()) then
write (u, "(1x,I0,':',1x)", advance="no") i
call forest%s_mapping(i)%write (unit)
end if
end associate
end do
else
write (u, "(3x,A)") " [empty]"
end if
write (u, "(A)")
write (u, "(1x,A)") "Incoming particles:"
if (allocated (forest%prt_in)) then
if (any (forest%prt_in%is_defined ())) then
do i = 1, size (forest%prt_in)
if (forest%prt_in(i)%is_defined ()) then
write (u, "(1x,A,1x,I0)") "Particle", i
call forest%prt_in(i)%write (u)
end if
end do
else
write (u, "(3x,A)") "[all undefined]"
end if
else
write (u, "(3x,A)") " [empty]"
end if
write (u, "(A)")
write (u, "(1x,A)") "Outgoing particles:"
if (allocated (forest%prt_out)) then
if (any (forest%prt_out%is_defined ())) then
do i = 1, size (forest%prt_out)
if (forest%prt_out(i)%is_defined ()) then
write (u, "(1x,A,1x,I0)") "Particle", i
call forest%prt_out(i)%write (u)
end if
end do
else
write (u, "(3x,A)") "[all undefined]"
end if
else
write (u, "(1x,A)") " [empty]"
end if
write (u, "(A)")
write (u, "(1x,A)") "Tree particles:"
if (allocated (forest%prt)) then
if (any (forest%prt%is_defined ())) then
do i = 1, size (forest%prt)
if (forest%prt(i)%is_defined ()) then
write (u, "(1x,A,1x,I0)") "Particle", i
call forest%prt(i)%write (u)
end if
end do
else
write (u, "(3x,A)") "[all undefined]"
end if
else
write (u, "(3x,A)") " [empty]"
end if
end subroutine phs_forest_write
subroutine phs_grove_write (grove, unit)
type(phs_grove_t), intent(in) :: grove
integer, intent(in), optional :: unit
integer :: u
integer :: t
u = given_output_unit (unit); if (u < 0) return
do t = 1, size (grove%tree)
write (u, "(3x,A,I0)") "Tree ", t
call grove%tree(t)%write (unit)
end do
write (u, "(1x,A)") "Equivalence list:"
call equivalence_list_write (grove%equivalence_list, unit)
end subroutine phs_grove_write
@ %def phs_grove_write phs_forest_write
@ Deep copy.
<<PHS forests: public>>=
public :: assignment(=)
<<PHS forests: interfaces>>=
interface assignment(=)
module procedure phs_forest_assign
end interface
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_assign (forest_out, forest_in)
type(phs_forest_t), intent(out) :: forest_out
type(phs_forest_t), intent(in) :: forest_in
end subroutine phs_forest_assign
<<PHS forests: procedures>>=
module subroutine phs_forest_assign (forest_out, forest_in)
type(phs_forest_t), intent(out) :: forest_out
type(phs_forest_t), intent(in) :: forest_in
forest_out%n_in = forest_in%n_in
forest_out%n_out = forest_in%n_out
forest_out%n_tot = forest_in%n_tot
forest_out%n_masses = forest_in%n_masses
forest_out%n_angles = forest_in%n_angles
forest_out%n_dimensions = forest_in%n_dimensions
forest_out%n_trees = forest_in%n_trees
forest_out%n_equivalences = forest_in%n_equivalences
if (allocated (forest_in%flv)) then
allocate (forest_out%flv (size (forest_in%flv)))
forest_out%flv = forest_in%flv
end if
if (allocated (forest_in%grove)) then
allocate (forest_out%grove (size (forest_in%grove)))
forest_out%grove = forest_in%grove
end if
if (allocated (forest_in%grove_lookup)) then
allocate (forest_out%grove_lookup (size (forest_in%grove_lookup)))
forest_out%grove_lookup = forest_in%grove_lookup
end if
if (allocated (forest_in%prt_in)) then
allocate (forest_out%prt_in (size (forest_in%prt_in)))
forest_out%prt_in = forest_in%prt_in
end if
if (allocated (forest_in%prt_out)) then
allocate (forest_out%prt_out (size (forest_in%prt_out)))
forest_out%prt_out = forest_in%prt_out
end if
if (allocated (forest_in%prt)) then
allocate (forest_out%prt (size (forest_in%prt)))
forest_out%prt = forest_in%prt
end if
if (allocated (forest_in%s_mapping)) then
allocate (forest_out%s_mapping (size (forest_in%s_mapping)))
forest_out%s_mapping = forest_in%s_mapping
end if
if (allocated (forest_in%prt_combination)) then
allocate (forest_out%prt_combination &
(2, size (forest_in%prt_combination, 2)))
forest_out%prt_combination = forest_in%prt_combination
end if
end subroutine phs_forest_assign
@ %def phs_forest_assign
@
\subsection{Accessing contents}
Get the number of integration parameters
<<PHS forests: phs forest: TBP>>=
procedure :: get_n_parameters => phs_forest_get_n_parameters
<<PHS forests: sub interfaces>>=
module function phs_forest_get_n_parameters (forest) result (n)
integer :: n
class(phs_forest_t), intent(in) :: forest
end function phs_forest_get_n_parameters
<<PHS forests: procedures>>=
module function phs_forest_get_n_parameters (forest) result (n)
integer :: n
class(phs_forest_t), intent(in) :: forest
n = forest%n_dimensions
end function phs_forest_get_n_parameters
@ %def phs_forest_get_n_parameters
@ Get the number of integration channels
<<PHS forests: phs forest: TBP>>=
procedure :: get_n_channels => phs_forest_get_n_channels
<<PHS forests: sub interfaces>>=
module function phs_forest_get_n_channels (forest) result (n)
integer :: n
class(phs_forest_t), intent(in) :: forest
end function phs_forest_get_n_channels
<<PHS forests: procedures>>=
module function phs_forest_get_n_channels (forest) result (n)
integer :: n
class(phs_forest_t), intent(in) :: forest
n = forest%n_trees
end function phs_forest_get_n_channels
@ %def phs_forest_get_n_channels
@ Get the number of groves
<<PHS forests: phs forest: TBP>>=
procedure :: get_n_groves => phs_forest_get_n_groves
<<PHS forests: sub interfaces>>=
module function phs_forest_get_n_groves (forest) result (n)
integer :: n
class(phs_forest_t), intent(in) :: forest
end function phs_forest_get_n_groves
<<PHS forests: procedures>>=
module function phs_forest_get_n_groves (forest) result (n)
integer :: n
class(phs_forest_t), intent(in) :: forest
n = size (forest%grove)
end function phs_forest_get_n_groves
@ %def phs_forest_get_n_groves
@ Get the index bounds for a specific grove.
<<PHS forests: phs forest: TBP>>=
procedure :: get_grove_bounds => phs_forest_get_grove_bounds
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n)
class(phs_forest_t), intent(in) :: forest
integer, intent(in) :: g
integer, intent(out) :: i0, i1, n
end subroutine phs_forest_get_grove_bounds
<<PHS forests: procedures>>=
module subroutine phs_forest_get_grove_bounds (forest, g, i0, i1, n)
class(phs_forest_t), intent(in) :: forest
integer, intent(in) :: g
integer, intent(out) :: i0, i1, n
n = size (forest%grove(g)%tree)
i0 = forest%grove(g)%tree_count_offset + 1
i1 = forest%grove(g)%tree_count_offset + n
end subroutine phs_forest_get_grove_bounds
@ %def phs_forest_get_grove_bounds
@ Get the number of equivalences
<<PHS forests: phs forest: TBP>>=
procedure :: get_n_equivalences => phs_forest_get_n_equivalences
<<PHS forests: sub interfaces>>=
module function phs_forest_get_n_equivalences (forest) result (n)
integer :: n
class(phs_forest_t), intent(in) :: forest
end function phs_forest_get_n_equivalences
<<PHS forests: procedures>>=
module function phs_forest_get_n_equivalences (forest) result (n)
integer :: n
class(phs_forest_t), intent(in) :: forest
n = forest%n_equivalences
end function phs_forest_get_n_equivalences
@ %def phs_forest_get_n_equivalences
@ Return true if a particular channel has a global (s-channel)
mapping; also return the resonance mass and width for this mapping.
<<PHS forests: phs forest: TBP>>=
procedure :: get_s_mapping => phs_forest_get_s_mapping
procedure :: get_on_shell => phs_forest_get_on_shell
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_get_s_mapping &
(forest, channel, flag, mass, width)
class(phs_forest_t), intent(in) :: forest
integer, intent(in) :: channel
logical, intent(out) :: flag
real(default), intent(out) :: mass, width
end subroutine phs_forest_get_s_mapping
module subroutine phs_forest_get_on_shell (forest, channel, flag, mass)
class(phs_forest_t), intent(in) :: forest
integer, intent(in) :: channel
logical, intent(out) :: flag
real(default), intent(out) :: mass
end subroutine phs_forest_get_on_shell
<<PHS forests: procedures>>=
module subroutine phs_forest_get_s_mapping &
(forest, channel, flag, mass, width)
class(phs_forest_t), intent(in) :: forest
integer, intent(in) :: channel
logical, intent(out) :: flag
real(default), intent(out) :: mass, width
flag = forest%s_mapping(channel)%is_s_channel ()
if (flag) then
mass = forest%s_mapping(channel)%get_mass ()
width = forest%s_mapping(channel)%get_width ()
else
mass = 0
width = 0
end if
end subroutine phs_forest_get_s_mapping
module subroutine phs_forest_get_on_shell (forest, channel, flag, mass)
class(phs_forest_t), intent(in) :: forest
integer, intent(in) :: channel
logical, intent(out) :: flag
real(default), intent(out) :: mass
flag = forest%s_mapping(channel)%is_on_shell ()
if (flag) then
mass = forest%s_mapping(channel)%get_mass ()
else
mass = 0
end if
end subroutine phs_forest_get_on_shell
@ %def phs_forest_get_s_mapping
@ %def phs_forest_get_on_shell
@
Extract the set of unique resonance histories, in form of an array.
<<PHS forests: phs forest: TBP>>=
procedure :: extract_resonance_history_set &
=> phs_forest_extract_resonance_history_set
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_extract_resonance_history_set &
(forest, res_set, include_trivial)
class(phs_forest_t), intent(in) :: forest
type(resonance_history_set_t), intent(out) :: res_set
logical, intent(in), optional :: include_trivial
end subroutine phs_forest_extract_resonance_history_set
<<PHS forests: procedures>>=
module subroutine phs_forest_extract_resonance_history_set &
(forest, res_set, include_trivial)
class(phs_forest_t), intent(in) :: forest
type(resonance_history_set_t), intent(out) :: res_set
logical, intent(in), optional :: include_trivial
type(resonance_history_t) :: rh
integer :: g, t
logical :: triv
triv = .false.; if (present (include_trivial)) triv = include_trivial
call res_set%init ()
do g = 1, size (forest%grove)
associate (grove => forest%grove(g))
do t = 1, size (grove%tree)
call grove%tree(t)%extract_resonance_history (rh)
call res_set%enter (rh, include_trivial)
end do
end associate
end do
call res_set%freeze ()
end subroutine phs_forest_extract_resonance_history_set
@ %def phs_forest_extract_resonance_history_set
@
\subsection{Read the phase space setup from file}
The phase space setup is stored in a file. The file may be generated
by the [[cascades]] module below, or by other means. This file has to
be read and parsed to create the PHS forest as the internal
phase-space representation.
Create lexer and syntax:
<<PHS forests: procedures>>=
subroutine define_phs_forest_syntax (ifile)
type(ifile_t) :: ifile
call ifile_append (ifile, "SEQ phase_space_list = process_phase_space*")
call ifile_append (ifile, "SEQ process_phase_space = " &
// "process_def process_header phase_space")
call ifile_append (ifile, "SEQ process_def = process process_list")
call ifile_append (ifile, "KEY process")
call ifile_append (ifile, "LIS process_list = process_tag*")
call ifile_append (ifile, "IDE process_tag")
call ifile_append (ifile, "SEQ process_header = " &
// "md5sum_process = md5sum " &
// "md5sum_model_par = md5sum " &
// "md5sum_phs_config = md5sum " &
// "sqrts = real " &
// "m_threshold_s = real " &
// "m_threshold_t = real " &
// "off_shell = integer " &
// "t_channel = integer " &
// "keep_nonresonant = logical")
call ifile_append (ifile, "KEY '='")
call ifile_append (ifile, "KEY '-'")
call ifile_append (ifile, "KEY md5sum_process")
call ifile_append (ifile, "KEY md5sum_model_par")
call ifile_append (ifile, "KEY md5sum_phs_config")
call ifile_append (ifile, "KEY sqrts")
call ifile_append (ifile, "KEY m_threshold_s")
call ifile_append (ifile, "KEY m_threshold_t")
call ifile_append (ifile, "KEY off_shell")
call ifile_append (ifile, "KEY t_channel")
call ifile_append (ifile, "KEY keep_nonresonant")
call ifile_append (ifile, "QUO md5sum = '""' ... '""'")
call ifile_append (ifile, "REA real")
call ifile_append (ifile, "INT integer")
call ifile_append (ifile, "IDE logical")
call ifile_append (ifile, "SEQ phase_space = grove_def+")
call ifile_append (ifile, "SEQ grove_def = grove tree_def+")
call ifile_append (ifile, "KEY grove")
call ifile_append (ifile, "SEQ tree_def = tree bincodes mapping*")
call ifile_append (ifile, "KEY tree")
call ifile_append (ifile, "SEQ bincodes = bincode*")
call ifile_append (ifile, "INT bincode")
call ifile_append (ifile, "SEQ mapping = map bincode channel signed_pdg")
call ifile_append (ifile, "KEY map")
call ifile_append (ifile, "ALT channel = &
&s_channel | t_channel | u_channel | &
&collinear | infrared | radiation | on_shell")
call ifile_append (ifile, "KEY s_channel")
! call ifile_append (ifile, "KEY t_channel") !!! Key already exists
call ifile_append (ifile, "KEY u_channel")
call ifile_append (ifile, "KEY collinear")
call ifile_append (ifile, "KEY infrared")
call ifile_append (ifile, "KEY radiation")
call ifile_append (ifile, "KEY on_shell")
call ifile_append (ifile, "ALT signed_pdg = &
&pdg | negative_pdg")
call ifile_append (ifile, "SEQ negative_pdg = '-' pdg")
call ifile_append (ifile, "INT pdg")
end subroutine define_phs_forest_syntax
@ %def define_phs_forest_syntax
@ The model-file syntax and lexer are fixed, therefore stored as
module variables:
<<PHS forests: variables>>=
type(syntax_t), target, save :: syntax_phs_forest
@ %def syntax_phs_forest
<<PHS forests: public>>=
public :: syntax_phs_forest_init
<<PHS forests: sub interfaces>>=
module subroutine syntax_phs_forest_init ()
end subroutine syntax_phs_forest_init
<<PHS forests: procedures>>=
module subroutine syntax_phs_forest_init ()
type(ifile_t) :: ifile
call define_phs_forest_syntax (ifile)
call syntax_init (syntax_phs_forest, ifile)
call ifile_final (ifile)
end subroutine syntax_phs_forest_init
@ %def syntax_phs_forest_init
<<PHS forests: procedures>>=
subroutine lexer_init_phs_forest (lexer)
type(lexer_t), intent(out) :: lexer
call lexer_init (lexer, &
comment_chars = "#!", &
quote_chars = '"', &
quote_match = '"', &
single_chars = "-", &
special_class = ["="] , &
keyword_list = syntax_get_keyword_list_ptr (syntax_phs_forest))
end subroutine lexer_init_phs_forest
@ %def lexer_init_phs_forest
<<PHS forests: public>>=
public :: syntax_phs_forest_final
<<PHS forests: sub interfaces>>=
module subroutine syntax_phs_forest_final ()
end subroutine syntax_phs_forest_final
<<PHS forests: procedures>>=
module subroutine syntax_phs_forest_final ()
call syntax_final (syntax_phs_forest)
end subroutine syntax_phs_forest_final
@ %def syntax_phs_forest_final
<<PHS forests: public>>=
public :: syntax_phs_forest_write
<<PHS forests: sub interfaces>>=
module subroutine syntax_phs_forest_write (unit)
integer, intent(in), optional :: unit
end subroutine syntax_phs_forest_write
<<PHS forests: procedures>>=
module subroutine syntax_phs_forest_write (unit)
integer, intent(in), optional :: unit
call syntax_write (syntax_phs_forest, unit)
end subroutine syntax_phs_forest_write
@ %def syntax_phs_forest_write
@ The concrete parser and interpreter. Generate an input stream for
the external [[unit]], read the parse tree (with given [[syntax]] and
[[lexer]]) from this stream, and transfer the contents of the parse
tree to the PHS [[forest]].
We look for the matching [[process]] tag, count groves and trees for
initializing the [[forest]], and fill the trees.
If the optional parameters are set, compare the parameters stored in
the file to those. Set [[match]] true if everything agrees.
<<PHS forests: phs forest: TBP>>=
generic :: read => read_file, read_unit, read_parse_tree
procedure :: read_file => phs_forest_read_file
procedure :: read_unit => phs_forest_read_unit
procedure :: read_parse_tree => phs_forest_read_parse_tree
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_read_file &
(forest, filename, process_id, n_in, n_out, model, found, &
md5sum_process, md5sum_model_par, &
md5sum_phs_config, phs_par, match)
class(phs_forest_t), intent(out) :: forest
type(string_t), intent(in) :: filename
type(string_t), intent(in) :: process_id
integer, intent(in) :: n_in, n_out
class(model_data_t), intent(in), target :: model
logical, intent(out) :: found
character(32), intent(in), optional :: &
md5sum_process, md5sum_model_par, md5sum_phs_config
type(phs_parameters_t), intent(in), optional :: phs_par
logical, intent(out), optional :: match
end subroutine phs_forest_read_file
module subroutine phs_forest_read_unit &
(forest, unit, process_id, n_in, n_out, model, found, &
md5sum_process, md5sum_model_par, md5sum_phs_config, &
phs_par, match)
class(phs_forest_t), intent(out) :: forest
integer, intent(in) :: unit
type(string_t), intent(in) :: process_id
integer, intent(in) :: n_in, n_out
class(model_data_t), intent(in), target :: model
logical, intent(out) :: found
character(32), intent(in), optional :: &
md5sum_process, md5sum_model_par, md5sum_phs_config
type(phs_parameters_t), intent(in), optional :: phs_par
logical, intent(out), optional :: match
end subroutine phs_forest_read_unit
module subroutine phs_forest_read_parse_tree &
(forest, parse_tree, process_id, n_in, n_out, model, found, &
md5sum_process, md5sum_model_par, md5sum_phs_config, &
phs_par, match)
class(phs_forest_t), intent(out) :: forest
type(parse_tree_t), intent(in), target :: parse_tree
type(string_t), intent(in) :: process_id
integer, intent(in) :: n_in, n_out
class(model_data_t), intent(in), target :: model
logical, intent(out) :: found
character(32), intent(in), optional :: &
md5sum_process, md5sum_model_par, md5sum_phs_config
type(phs_parameters_t), intent(in), optional :: phs_par
logical, intent(out), optional :: match
end subroutine phs_forest_read_parse_tree
<<PHS forests: procedures>>=
module subroutine phs_forest_read_file &
(forest, filename, process_id, n_in, n_out, model, found, &
md5sum_process, md5sum_model_par, &
md5sum_phs_config, phs_par, match)
class(phs_forest_t), intent(out) :: forest
type(string_t), intent(in) :: filename
type(string_t), intent(in) :: process_id
integer, intent(in) :: n_in, n_out
class(model_data_t), intent(in), target :: model
logical, intent(out) :: found
character(32), intent(in), optional :: &
md5sum_process, md5sum_model_par, md5sum_phs_config
type(phs_parameters_t), intent(in), optional :: phs_par
logical, intent(out), optional :: match
type(parse_tree_t), target :: parse_tree
type(stream_t), target :: stream
type(lexer_t) :: lexer
call lexer_init_phs_forest (lexer)
call stream_init (stream, char (filename))
call lexer_assign_stream (lexer, stream)
call parse_tree_init (parse_tree, syntax_phs_forest, lexer)
call phs_forest_read_parse_tree (forest, parse_tree, &
process_id, n_in, n_out, model, found, &
md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
call stream_final (stream)
call lexer_final (lexer)
call parse_tree_final (parse_tree)
end subroutine phs_forest_read_file
module subroutine phs_forest_read_unit &
(forest, unit, process_id, n_in, n_out, model, found, &
md5sum_process, md5sum_model_par, md5sum_phs_config, &
phs_par, match)
class(phs_forest_t), intent(out) :: forest
integer, intent(in) :: unit
type(string_t), intent(in) :: process_id
integer, intent(in) :: n_in, n_out
class(model_data_t), intent(in), target :: model
logical, intent(out) :: found
character(32), intent(in), optional :: &
md5sum_process, md5sum_model_par, md5sum_phs_config
type(phs_parameters_t), intent(in), optional :: phs_par
logical, intent(out), optional :: match
type(parse_tree_t), target :: parse_tree
type(stream_t), target :: stream
type(lexer_t) :: lexer
call lexer_init_phs_forest (lexer)
call stream_init (stream, unit)
call lexer_assign_stream (lexer, stream)
call parse_tree_init (parse_tree, syntax_phs_forest, lexer)
call phs_forest_read_parse_tree (forest, parse_tree, &
process_id, n_in, n_out, model, found, &
md5sum_process, md5sum_model_par, md5sum_phs_config, &
phs_par, match)
call stream_final (stream)
call lexer_final (lexer)
call parse_tree_final (parse_tree)
end subroutine phs_forest_read_unit
module subroutine phs_forest_read_parse_tree &
(forest, parse_tree, process_id, n_in, n_out, model, found, &
md5sum_process, md5sum_model_par, md5sum_phs_config, &
phs_par, match)
class(phs_forest_t), intent(out) :: forest
type(parse_tree_t), intent(in), target :: parse_tree
type(string_t), intent(in) :: process_id
integer, intent(in) :: n_in, n_out
class(model_data_t), intent(in), target :: model
logical, intent(out) :: found
character(32), intent(in), optional :: &
md5sum_process, md5sum_model_par, md5sum_phs_config
type(phs_parameters_t), intent(in), optional :: phs_par
logical, intent(out), optional :: match
type(parse_node_t), pointer :: node_header, node_phs, node_grove
integer :: n_grove, g
integer, dimension(:), allocatable :: n_tree
integer :: t
node_header => parse_tree_get_process_ptr (parse_tree, process_id)
found = associated (node_header); if (.not. found) return
if (present (match)) then
call phs_forest_check_input (node_header, &
md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
if (.not. match) return
end if
node_phs => parse_node_get_next_ptr (node_header)
n_grove = parse_node_get_n_sub (node_phs)
allocate (n_tree (n_grove))
do g = 1, n_grove
node_grove => parse_node_get_sub_ptr (node_phs, g)
n_tree(g) = parse_node_get_n_sub (node_grove) - 1
end do
call forest%init (n_tree, n_in, n_out)
do g = 1, n_grove
node_grove => parse_node_get_sub_ptr (node_phs, g)
do t = 1, n_tree(g)
call phs_tree_set (forest%grove(g)%tree(t), &
parse_node_get_sub_ptr (node_grove, t+1), model)
end do
end do
end subroutine phs_forest_read_parse_tree
@ %def phs_forest
@ Check the input for consistency. If any MD5 sum or phase-space
parameter disagrees, the phase-space file cannot be used. The MD5
sum checks are skipped if the stored MD5 sum is empty.
<<PHS forests: procedures>>=
subroutine phs_forest_check_input (pn_header, &
md5sum_process, md5sum_model_par, md5sum_phs_config, phs_par, match)
type(parse_node_t), intent(in), target :: pn_header
character(32), intent(in) :: &
md5sum_process, md5sum_model_par, md5sum_phs_config
type(phs_parameters_t), intent(in), optional :: phs_par
logical, intent(out) :: match
type(parse_node_t), pointer :: pn_md5sum, pn_rval, pn_ival, pn_lval
character(32) :: md5sum
type(phs_parameters_t) :: phs_par_old
character(1) :: lstr
pn_md5sum => parse_node_get_sub_ptr (pn_header, 3)
md5sum = parse_node_get_string (pn_md5sum)
if (md5sum /= "" .and. md5sum /= md5sum_process) then
call msg_message ("Phase space: discarding old configuration &
&(process changed)")
match = .false.; return
end if
pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3)
md5sum = parse_node_get_string (pn_md5sum)
if (md5sum /= "" .and. md5sum /= md5sum_model_par) then
call msg_message ("Phase space: discarding old configuration &
&(model parameters changed)")
match = .false.; return
end if
pn_md5sum => parse_node_get_next_ptr (pn_md5sum, 3)
md5sum = parse_node_get_string (pn_md5sum)
if (md5sum /= "" .and. md5sum /= md5sum_phs_config) then
call msg_message ("Phase space: discarding old configuration &
&(configuration parameters changed)")
match = .false.; return
end if
if (present (phs_par)) then
pn_rval => parse_node_get_next_ptr (pn_md5sum, 3)
phs_par_old%sqrts = parse_node_get_real (pn_rval)
pn_rval => parse_node_get_next_ptr (pn_rval, 3)
phs_par_old%m_threshold_s = parse_node_get_real (pn_rval)
pn_rval => parse_node_get_next_ptr (pn_rval, 3)
phs_par_old%m_threshold_t = parse_node_get_real (pn_rval)
pn_ival => parse_node_get_next_ptr (pn_rval, 3)
phs_par_old%off_shell = parse_node_get_integer (pn_ival)
pn_ival => parse_node_get_next_ptr (pn_ival, 3)
phs_par_old%t_channel = parse_node_get_integer (pn_ival)
pn_lval => parse_node_get_next_ptr (pn_ival, 3)
lstr = parse_node_get_string (pn_lval)
read (lstr, "(L1)") phs_par_old%keep_nonresonant
if (phs_par_old /= phs_par) then
call msg_message &
("Phase space: discarding old configuration &
&(configuration parameters changed)")
match = .false.; return
end if
end if
match = .true.
end subroutine phs_forest_check_input
@ %def phs_forest_check_input
@ Initialize a specific tree in the forest, using the contents of the
'tree' node. First, count the bincodes, allocate an array and read
them in, and make the tree. Each $t$-channel tree is flipped to
$s$-channel. Then, find mappings and initialize them.
<<PHS forests: procedures>>=
subroutine phs_tree_set (tree, node, model)
type(phs_tree_t), intent(inout) :: tree
type(parse_node_t), intent(in), target :: node
class(model_data_t), intent(in), target :: model
type(parse_node_t), pointer :: node_bincodes, node_mapping, pn_pdg
integer :: n_bincodes, offset
integer(TC), dimension(:), allocatable :: bincode
integer :: b, n_mappings, m
integer(TC) :: k
type(string_t) :: type
integer :: pdg
node_bincodes => parse_node_get_sub_ptr (node, 2)
if (associated (node_bincodes)) then
select case (char (parse_node_get_rule_key (node_bincodes)))
case ("bincodes")
n_bincodes = parse_node_get_n_sub (node_bincodes)
offset = 2
case default
n_bincodes = 0
offset = 1
end select
else
n_bincodes = 0
offset = 2
end if
allocate (bincode (n_bincodes))
do b = 1, n_bincodes
bincode(b) = parse_node_get_integer &
(parse_node_get_sub_ptr (node_bincodes, b))
end do
call phs_tree_from_array (tree, bincode)
call tree%flip_t_to_s_channel ()
call tree%canonicalize ()
n_mappings = parse_node_get_n_sub (node) - offset
do m = 1, n_mappings
node_mapping => parse_node_get_sub_ptr (node, m + offset)
k = parse_node_get_integer &
(parse_node_get_sub_ptr (node_mapping, 2))
type = parse_node_get_key &
(parse_node_get_sub_ptr (node_mapping, 3))
pn_pdg => parse_node_get_sub_ptr (node_mapping, 4)
select case (char (pn_pdg%get_rule_key ()))
case ("pdg")
pdg = pn_pdg%get_integer ()
case ("negative_pdg")
pdg = - parse_node_get_integer (pn_pdg%get_sub_ptr (2))
end select
call tree%init_mapping (k, type, pdg, model)
end do
end subroutine phs_tree_set
@ %def phs_tree_set
@
\subsection{Preparation}
The trees that we read from file do not carry flavor information.
This is set separately:
The flavor list must be unique for a unique set of masses; if a given
particle can have different flavor, the mass must be degenerate, so we
can choose one of the possible flavor combinations.
<<PHS forests: phs forest: TBP>>=
procedure :: set_flavors => phs_forest_set_flavors
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra)
class(phs_forest_t), intent(inout) :: forest
type(flavor_t), dimension(:), intent(in) :: flv
integer, intent(in), dimension(:), allocatable, optional :: reshuffle
type(flavor_t), intent(in), optional :: flv_extra
end subroutine phs_forest_set_flavors
<<PHS forests: procedures>>=
module subroutine phs_forest_set_flavors (forest, flv, reshuffle, flv_extra)
class(phs_forest_t), intent(inout) :: forest
type(flavor_t), dimension(:), intent(in) :: flv
integer, intent(in), dimension(:), allocatable, optional :: reshuffle
type(flavor_t), intent(in), optional :: flv_extra
integer :: i, n_flv0
if (present (reshuffle) .and. present (flv_extra)) then
n_flv0 = size (flv)
do i = 1, n_flv0
if (reshuffle(i) <= n_flv0) then
forest%flv(i) = flv (reshuffle(i))
else
forest%flv(i) = flv_extra
end if
end do
else
allocate (forest%flv (size (flv)))
forest%flv = flv
end if
end subroutine phs_forest_set_flavors
@ %def phs_forest_set_flavors
@
<<PHS forests: phs forest: TBP>>=
procedure :: set_momentum_links => phs_forest_set_momentum_links
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_set_momentum_links (forest, list)
class(phs_forest_t), intent(inout) :: forest
integer, intent(in), dimension(:), allocatable :: list
end subroutine phs_forest_set_momentum_links
<<PHS forests: procedures>>=
module subroutine phs_forest_set_momentum_links (forest, list)
class(phs_forest_t), intent(inout) :: forest
integer, intent(in), dimension(:), allocatable :: list
integer :: g, t
do g = 1, size (forest%grove)
do t = 1, size (forest%grove(g)%tree)
associate (tree => forest%grove(g)%tree(t))
call phs_tree_set_momentum_links (tree, list)
!!! call tree%reshuffle_mappings ()
end associate
end do
end do
end subroutine phs_forest_set_momentum_links
@ %def phs_forest_set_momentum_links
@ Once the parameter set is fixed, the masses and the widths of the
particles are known and the [[mass_sum]] arrays as well as the mapping
parameters can be computed. Note that order is important: we first
compute the mass sums, then the ordinary mappings. The resonances
obtained here determine the effective masses, which in turn are used
to implement step mappings for resonance decay products that are not
mapped otherwise.
<<PHS forests: phs forest: TBP>>=
procedure :: set_parameters => phs_forest_set_parameters
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_set_parameters &
(forest, mapping_defaults, variable_limits)
class(phs_forest_t), intent(inout) :: forest
type(mapping_defaults_t), intent(in) :: mapping_defaults
logical, intent(in) :: variable_limits
end subroutine phs_forest_set_parameters
<<PHS forests: procedures>>=
module subroutine phs_forest_set_parameters &
(forest, mapping_defaults, variable_limits)
class(phs_forest_t), intent(inout) :: forest
type(mapping_defaults_t), intent(in) :: mapping_defaults
logical, intent(in) :: variable_limits
integer :: g, t
do g = 1, size (forest%grove)
do t = 1, size (forest%grove(g)%tree)
call forest%grove(g)%tree(t)%set_mass_sum (forest%flv(forest%n_in+1:))
call forest%grove(g)%tree(t)%set_mapping_parameters &
(mapping_defaults, variable_limits)
call forest%grove(g)%tree(t)%set_effective_masses ()
if (mapping_defaults%step_mapping) then
call forest%grove(g)%tree(t)%set_step_mappings &
(mapping_defaults%step_mapping_exp, variable_limits)
end if
end do
end do
end subroutine phs_forest_set_parameters
@ %def phs_forest_set_parameters
@ Generate the particle combination table. Scan all trees and merge
their individual combination tables. At the end, valid entries are
non-zero, and they indicate the indices of a pair of particles to be
combined to a new particle. If a particle is accessible by more than
one tree (this is usual), only keep the first possibility.
<<PHS forests: phs forest: TBP>>=
procedure :: setup_prt_combinations => phs_forest_setup_prt_combinations
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_setup_prt_combinations (forest)
class(phs_forest_t), intent(inout) :: forest
end subroutine phs_forest_setup_prt_combinations
<<PHS forests: procedures>>=
module subroutine phs_forest_setup_prt_combinations (forest)
class(phs_forest_t), intent(inout) :: forest
integer :: g, t
integer, dimension(:,:), allocatable :: tree_prt_combination
forest%prt_combination = 0
allocate (tree_prt_combination (2, size (forest%prt_combination, 2)))
do g = 1, size (forest%grove)
do t = 1, size (forest%grove(g)%tree)
call phs_tree_setup_prt_combinations &
(forest%grove(g)%tree(t), tree_prt_combination)
where (tree_prt_combination /= 0 .and. forest%prt_combination == 0)
forest%prt_combination = tree_prt_combination
end where
end do
end do
end subroutine phs_forest_setup_prt_combinations
@ %def phs_forest_setup_prt_combinations
@
\subsection{Accessing the particle arrays}
Set the incoming particles from the contents of an interaction.
<<PHS forests: phs forest: TBP>>=
generic :: set_prt_in => set_prt_in_int, set_prt_in_mom
procedure :: set_prt_in_int => phs_forest_set_prt_in_int
procedure :: set_prt_in_mom => phs_forest_set_prt_in_mom
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab)
class(phs_forest_t), intent(inout) :: forest
type(interaction_t), intent(in) :: int
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
end subroutine phs_forest_set_prt_in_int
module subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab)
class(phs_forest_t), intent(inout) :: forest
type(vector4_t), dimension(size (forest%prt_in)), intent(in) :: mom
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
end subroutine phs_forest_set_prt_in_mom
<<PHS forests: procedures>>=
module subroutine phs_forest_set_prt_in_int (forest, int, lt_cm_to_lab)
class(phs_forest_t), intent(inout) :: forest
type(interaction_t), intent(in) :: int
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
if (present (lt_cm_to_lab)) then
call forest%prt_in%set_momentum (inverse (lt_cm_to_lab) * &
int%get_momenta (outgoing=.false.))
else
call forest%prt_in%set_momentum (int%get_momenta (outgoing=.false.))
end if
associate (m_in => forest%flv(:forest%n_in)%get_mass ())
call forest%prt_in%set_msq (m_in ** 2)
end associate
call forest%prt_in%set_defined ()
end subroutine phs_forest_set_prt_in_int
module subroutine phs_forest_set_prt_in_mom (forest, mom, lt_cm_to_lab)
class(phs_forest_t), intent(inout) :: forest
type(vector4_t), dimension(size (forest%prt_in)), intent(in) :: mom
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
if (present (lt_cm_to_lab)) then
call forest%prt_in%set_momentum (inverse (lt_cm_to_lab) * mom)
else
call forest%prt_in%set_momentum (mom)
end if
associate (m_in => forest%flv(:forest%n_in)%get_mass ())
call forest%prt_in%set_msq (m_in ** 2)
end associate
call forest%prt_in%set_defined ()
end subroutine phs_forest_set_prt_in_mom
@ %def phs_forest_set_prt_in
@ Set the outgoing particles from the contents of an interaction.
<<PHS forests: phs forest: TBP>>=
generic :: set_prt_out => set_prt_out_int, set_prt_out_mom
procedure :: set_prt_out_int => phs_forest_set_prt_out_int
procedure :: set_prt_out_mom => phs_forest_set_prt_out_mom
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab)
class(phs_forest_t), intent(inout) :: forest
type(interaction_t), intent(in) :: int
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
end subroutine phs_forest_set_prt_out_int
module subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab)
class(phs_forest_t), intent(inout) :: forest
type(vector4_t), dimension(size (forest%prt_out)), intent(in) :: mom
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
end subroutine phs_forest_set_prt_out_mom
<<PHS forests: procedures>>=
module subroutine phs_forest_set_prt_out_int (forest, int, lt_cm_to_lab)
class(phs_forest_t), intent(inout) :: forest
type(interaction_t), intent(in) :: int
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
if (present (lt_cm_to_lab)) then
call forest%prt_out%set_momentum (inverse (lt_cm_to_lab) * &
int%get_momenta (outgoing=.true.))
else
call forest%prt_out%set_momentum (int%get_momenta (outgoing=.true.))
end if
associate (m_out => forest%flv(forest%n_in+1:)%get_mass ())
call forest%prt_out%set_msq (m_out ** 2)
end associate
call forest%prt_out%set_defined ()
end subroutine phs_forest_set_prt_out_int
module subroutine phs_forest_set_prt_out_mom (forest, mom, lt_cm_to_lab)
class(phs_forest_t), intent(inout) :: forest
type(vector4_t), dimension(size (forest%prt_out)), intent(in) :: mom
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
if (present (lt_cm_to_lab)) then
call forest%prt_out%set_momentum (inverse (lt_cm_to_lab) * mom)
else
call forest%prt_out%set_momentum (mom)
end if
associate (m_out => forest%flv(forest%n_in+1:)%get_mass ())
call forest%prt_out%set_msq (m_out ** 2)
end associate
call forest%prt_out%set_defined ()
end subroutine phs_forest_set_prt_out_mom
@ %def phs_forest_set_prt_out
@ Combine particles as described by the particle combination table.
Particle momentum sums will be calculated only if the resulting
particle is contained in at least one of the trees in the current
forest. The others are kept undefined.
<<PHS forests: phs forest: TBP>>=
procedure :: combine_particles => phs_forest_combine_particles
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_combine_particles (forest)
class(phs_forest_t), intent(inout) :: forest
end subroutine phs_forest_combine_particles
<<PHS forests: procedures>>=
module subroutine phs_forest_combine_particles (forest)
class(phs_forest_t), intent(inout) :: forest
integer :: k
integer, dimension(2) :: kk
do k = 1, size (forest%prt_combination, 2)
kk = forest%prt_combination(:,k)
if (kk(1) /= 0) then
call forest%prt(k)%combine (forest%prt(kk(1)), forest%prt(kk(2)))
end if
end do
end subroutine phs_forest_combine_particles
@ %def phs_forest_combine_particles
@ Extract the outgoing particles and insert into an interaction.
<<PHS forests: phs forest: TBP>>=
procedure :: get_prt_out => phs_forest_get_prt_out
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab)
class(phs_forest_t), intent(in) :: forest
type(interaction_t), intent(inout) :: int
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
end subroutine phs_forest_get_prt_out
<<PHS forests: procedures>>=
module subroutine phs_forest_get_prt_out (forest, int, lt_cm_to_lab)
class(phs_forest_t), intent(in) :: forest
type(interaction_t), intent(inout) :: int
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
if (present (lt_cm_to_lab)) then
call int%set_momenta (lt_cm_to_lab * &
forest%prt_out%get_momentum (), outgoing=.true.)
else
call int%set_momenta (forest%prt_out%get_momentum (), &
outgoing=.true.)
end if
end subroutine phs_forest_get_prt_out
@ %def phs_forest_get_prt_out
@ Extract the outgoing particle momenta
<<PHS forests: phs forest: TBP>>=
procedure :: get_momenta_out => phs_forest_get_momenta_out
<<PHS forests: sub interfaces>>=
module function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p)
class(phs_forest_t), intent(in) :: forest
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
type(vector4_t), dimension(size (forest%prt_out)) :: p
end function phs_forest_get_momenta_out
<<PHS forests: procedures>>=
module function phs_forest_get_momenta_out (forest, lt_cm_to_lab) result (p)
class(phs_forest_t), intent(in) :: forest
type(lorentz_transformation_t), intent(in), optional :: lt_cm_to_lab
type(vector4_t), dimension(size (forest%prt_out)) :: p
p = forest%prt_out%get_momentum ()
if (present (lt_cm_to_lab)) p = p * lt_cm_to_lab
end function phs_forest_get_momenta_out
@ %def phs_forest_get_momenta_out
@
\subsection{Find equivalences among phase-space trees}
Scan phase space for equivalences. We generate the complete set of
unique permutations for the given list of outgoing particles, and use
this for scanning equivalences within each grove.
@ We scan all pairs of trees, using all permutations. This implies
that trivial equivalences are included, and equivalences between
different trees are recorded twice. This is intentional.
<<PHS forests: procedures>>=
subroutine phs_grove_set_equivalences (grove, perm_array)
type(phs_grove_t), intent(inout) :: grove
type(permutation_t), dimension(:), intent(in) :: perm_array
type(equivalence_t), pointer :: eq
integer :: t1, t2, i
do t1 = 1, size (grove%tree)
do t2 = 1, size (grove%tree)
SCAN_PERM: do i = 1, size (perm_array)
if (phs_tree_equivalent &
(grove%tree(t1), grove%tree(t2), perm_array(i))) then
call equivalence_list_add &
(grove%equivalence_list, t1, t2, perm_array(i))
eq => grove%equivalence_list%last
call phs_tree_find_msq_permutation &
(grove%tree(t1), grove%tree(t2), eq%perm, &
eq%msq_perm)
call phs_tree_find_angle_permutation &
(grove%tree(t1), grove%tree(t2), eq%perm, &
eq%angle_perm, eq%angle_sig)
end if
end do SCAN_PERM
end do
end do
end subroutine phs_grove_set_equivalences
@ %def phs_grove_set_equivalences
<<PHS forests: phs forest: TBP>>=
procedure :: set_equivalences => phs_forest_set_equivalences
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_set_equivalences (forest)
class(phs_forest_t), intent(inout) :: forest
end subroutine phs_forest_set_equivalences
<<PHS forests: procedures>>=
module subroutine phs_forest_set_equivalences (forest)
class(phs_forest_t), intent(inout) :: forest
type(permutation_t), dimension(:), allocatable :: perm_array
integer :: i
call permutation_array_make &
(perm_array, forest%flv(forest%n_in+1:)%get_pdg ())
do i = 1, size (forest%grove)
call phs_grove_set_equivalences (forest%grove(i), perm_array)
end do
forest%n_equivalences = sum (forest%grove%equivalence_list%length)
end subroutine phs_forest_set_equivalences
@ %def phs_forest_set_equivalences
@
\subsection{Interface for channel equivalences}
Here, we store the equivalence list in the appropriate containers that
the [[phs_base]] module provides. There is one separate list for each
channel.
<<PHS forests: phs forest: TBP>>=
procedure :: get_equivalences => phs_forest_get_equivalences
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_get_equivalences &
(forest, channel, azimuthal_dependence)
class(phs_forest_t), intent(in) :: forest
type(phs_channel_t), dimension(:), intent(out) :: channel
logical, intent(in) :: azimuthal_dependence
end subroutine phs_forest_get_equivalences
<<PHS forests: procedures>>=
module subroutine phs_forest_get_equivalences &
(forest, channel, azimuthal_dependence)
class(phs_forest_t), intent(in) :: forest
type(phs_channel_t), dimension(:), intent(out) :: channel
logical, intent(in) :: azimuthal_dependence
integer :: n_masses, n_angles
integer :: mode_azimuthal_angle
integer, dimension(:), allocatable :: n_eq
type(equivalence_t), pointer :: eq
integer, dimension(:), allocatable :: perm, mode
integer :: g, c, j, left, right
n_masses = forest%n_masses
n_angles = forest%n_angles
allocate (n_eq (forest%n_trees), source = 0)
allocate (perm (forest%n_dimensions))
allocate (mode (forest%n_dimensions), source = EQ_IDENTITY)
do g = 1, size (forest%grove)
eq => forest%grove(g)%equivalence_list%first
do while (associated (eq))
left = eq%left + forest%grove(g)%tree_count_offset
n_eq(left) = n_eq(left) + 1
eq => eq%next
end do
end do
do c = 1, size (channel)
allocate (channel(c)%eq (n_eq(c)))
do j = 1, n_eq(c)
call channel(c)%eq(j)%init (forest%n_dimensions)
end do
end do
n_eq = 0
if (azimuthal_dependence) then
mode_azimuthal_angle = EQ_IDENTITY
else
mode_azimuthal_angle = EQ_INVARIANT
end if
do g = 1, size (forest%grove)
eq => forest%grove(g)%equivalence_list%first
do while (associated (eq))
left = eq%left + forest%grove(g)%tree_count_offset
right = eq%right + forest%grove(g)%tree_count_offset
do j = 1, n_masses
perm(j) = permute (j, eq%msq_perm)
mode(j) = EQ_IDENTITY
end do
do j = 1, n_angles
perm(n_masses+j) = n_masses + permute (j, eq%angle_perm)
if (j == 1) then
mode(n_masses+j) = mode_azimuthal_angle ! first az. angle
else if (mod(j,2) == 1) then
mode(n_masses+j) = EQ_SYMMETRIC ! other az. angles
else if (eq%angle_sig(j)) then
mode(n_masses+j) = EQ_IDENTITY ! polar angle +
else
mode(n_masses+j) = EQ_INVERT ! polar angle -
end if
end do
n_eq(left) = n_eq(left) + 1
associate (eq_cur => channel(left)%eq(n_eq(left)))
eq_cur%c = right
eq_cur%perm = perm
eq_cur%mode = mode
end associate
eq => eq%next
end do
end do
end subroutine phs_forest_get_equivalences
@ %def phs_forest_get_equivalences
@
\subsection{Phase-space evaluation}
Given one row of the [[x]] parameter array and the corresponding
channel index, compute first all relevant momenta and then recover the
remainder of the [[x]] array, the Jacobians [[phs_factor]], and the
phase-space [[volume]].
The output argument [[ok]] indicates whether this was successful.
<<PHS forests: phs forest: TBP>>=
procedure :: evaluate_selected_channel => phs_forest_evaluate_selected_channel
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_evaluate_selected_channel &
(forest, channel, active, sqrts, x, phs_factor, volume, ok)
class(phs_forest_t), intent(inout) :: forest
integer, intent(in) :: channel
logical, dimension(:), intent(in) :: active
real(default), intent(in) :: sqrts
real(default), dimension(:,:), intent(inout) :: x
real(default), dimension(:), intent(out) :: phs_factor
real(default), intent(out) :: volume
logical, intent(out) :: ok
end subroutine phs_forest_evaluate_selected_channel
<<PHS forests: procedures>>=
module subroutine phs_forest_evaluate_selected_channel &
(forest, channel, active, sqrts, x, phs_factor, volume, ok)
class(phs_forest_t), intent(inout) :: forest
integer, intent(in) :: channel
logical, dimension(:), intent(in) :: active
real(default), intent(in) :: sqrts
real(default), dimension(:,:), intent(inout) :: x
real(default), dimension(:), intent(out) :: phs_factor
real(default), intent(out) :: volume
logical, intent(out) :: ok
integer :: g, t
integer(TC) :: k, k_root, k_in
g = forest%grove_lookup (channel)
t = channel - forest%grove(g)%tree_count_offset
call forest%prt%set_undefined ()
call forest%prt_out%set_undefined ()
k_in = forest%n_tot
do k = 1,forest%n_in
forest%prt(ibset(0,k_in-k)) = forest%prt_in(k)
end do
do k = 1, forest%n_out
call forest%prt(ibset(0,k-1))%set_msq &
(forest%flv(forest%n_in+k)%get_mass () ** 2)
end do
k_root = 2**forest%n_out - 1
select case (forest%n_in)
case (1)
forest%prt(k_root) = forest%prt_in(1)
case (2)
call forest%prt(k_root)%combine (forest%prt_in(1), forest%prt_in(2))
end select
call forest%grove(g)%tree(t)%compute_momenta_from_x (forest%prt, &
phs_factor(channel), volume, sqrts, x(:,channel), ok)
if (ok) then
do k = 1, forest%n_out
forest%prt_out(k) = forest%prt(ibset(0,k-1))
end do
end if
end subroutine phs_forest_evaluate_selected_channel
@ %def phs_forest_evaluate_selected_channel
@ The remainder: recover $x$ values for all channels except for the current
channel.
NOTE: OpenMP not used for the first loop. [[combine_particles]] is not a
channel-local operation.
<<PHS forests: phs forest: TBP>>=
procedure :: evaluate_other_channels => phs_forest_evaluate_other_channels
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_evaluate_other_channels &
(forest, channel, active, sqrts, x, phs_factor, combine)
class(phs_forest_t), intent(inout) :: forest
integer, intent(in) :: channel
logical, dimension(:), intent(in) :: active
real(default), intent(in) :: sqrts
real(default), dimension(:,:), intent(inout) :: x
real(default), dimension(:), intent(inout) :: phs_factor
logical, intent(in) :: combine
end subroutine phs_forest_evaluate_other_channels
<<PHS forests: procedures>>=
module subroutine phs_forest_evaluate_other_channels &
(forest, channel, active, sqrts, x, phs_factor, combine)
class(phs_forest_t), intent(inout) :: forest
integer, intent(in) :: channel
logical, dimension(:), intent(in) :: active
real(default), intent(in) :: sqrts
real(default), dimension(:,:), intent(inout) :: x
real(default), dimension(:), intent(inout) :: phs_factor
logical, intent(in) :: combine
integer :: g, t, ch, n_channel
g = forest%grove_lookup (channel)
t = channel - forest%grove(g)%tree_count_offset
n_channel = forest%n_trees
if (combine) then
do ch = 1, n_channel
if (ch == channel) cycle
if (active(ch)) then
g = forest%grove_lookup(ch)
t = ch - forest%grove(g)%tree_count_offset
call phs_tree_combine_particles &
(forest%grove(g)%tree(t), forest%prt)
end if
end do
end if
!OMP PARALLEL PRIVATE (g,t,ch) SHARED(active,forest,sqrts,x,channel)
!OMP DO SCHEDULE(STATIC)
do ch = 1, n_channel
if (ch == channel) cycle
if (active(ch)) then
g = forest%grove_lookup(ch)
t = ch - forest%grove(g)%tree_count_offset
call forest%grove(g)%tree(t)%compute_x_from_momenta (forest%prt, &
phs_factor(ch), sqrts, x(:,ch))
end if
end do
!OMP END DO
!OMP END PARALLEL
end subroutine phs_forest_evaluate_other_channels
@ %def phs_forest_evaluate_other_channels
@ The complement: recover one row of the [[x]] array and the
associated Jacobian entry, corresponding to
[[channel]], from incoming and outgoing momenta. Also compute the
phase-space volume.
<<PHS forests: phs forest: TBP>>=
procedure :: recover_channel => phs_forest_recover_channel
<<PHS forests: sub interfaces>>=
module subroutine phs_forest_recover_channel &
(forest, channel, sqrts, x, phs_factor, volume)
class(phs_forest_t), intent(inout) :: forest
integer, intent(in) :: channel
real(default), intent(in) :: sqrts
real(default), dimension(:,:), intent(inout) :: x
real(default), dimension(:), intent(inout) :: phs_factor
real(default), intent(out) :: volume
end subroutine phs_forest_recover_channel
<<PHS forests: procedures>>=
module subroutine phs_forest_recover_channel &
(forest, channel, sqrts, x, phs_factor, volume)
class(phs_forest_t), intent(inout) :: forest
integer, intent(in) :: channel
real(default), intent(in) :: sqrts
real(default), dimension(:,:), intent(inout) :: x
real(default), dimension(:), intent(inout) :: phs_factor
real(default), intent(out) :: volume
integer :: g, t
integer(TC) :: k, k_in
g = forest%grove_lookup (channel)
t = channel - forest%grove(g)%tree_count_offset
call forest%prt%set_undefined ()
k_in = forest%n_tot
forall (k = 1:forest%n_in)
forest%prt(ibset(0,k_in-k)) = forest%prt_in(k)
end forall
forall (k = 1:forest%n_out)
forest%prt(ibset(0,k-1)) = forest%prt_out(k)
end forall
call forest%combine_particles ()
call forest%grove(g)%tree(t)%compute_volume (sqrts, volume)
call forest%grove(g)%tree(t)%compute_x_from_momenta (forest%prt, &
phs_factor(channel), sqrts, x(:,channel))
end subroutine phs_forest_recover_channel
@ %def phs_forest_recover_channel
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[phs_forests_ut.f90]]>>=
<<File header>>
module phs_forests_ut
use unit_tests
use phs_forests_uti
<<Standard module head>>
<<PHS forests: public test>>
contains
<<PHS forests: test driver>>
end module phs_forests_ut
@ %def phs_forests_ut
@
<<[[phs_forests_uti.f90]]>>=
<<File header>>
module phs_forests_uti
<<Use kinds>>
<<Use strings>>
use io_units
use format_defs, only: FMT_12
use lorentz
use flavors
use interactions
use model_data
use mappings
use phs_base
use resonances, only: resonance_history_set_t
use phs_forests
<<Standard module head>>
<<PHS forests: test declarations>>
contains
<<PHS forests: tests>>
end module phs_forests_uti
@ %def phs_forests_ut
@ API: driver for the unit tests below.
<<PHS forests: public test>>=
public :: phs_forests_test
<<PHS forests: test driver>>=
subroutine phs_forests_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS forests: execute tests>>
end subroutine phs_forests_test
@ %def phs_forests_test
@
\subsubsection{Basic universal test}
Write a possible phase-space file for a $2\to 3$ process and make the
corresponding forest, print the forest. Choose some in-particle
momenta and a random-number array and evaluate out-particles and
phase-space factors.
<<PHS forests: execute tests>>=
call test (phs_forest_1, "phs_forest_1", &
"check phs forest setup", &
u, results)
<<PHS forests: test declarations>>=
public :: phs_forest_1
<<PHS forests: tests>>=
subroutine phs_forest_1 (u)
use os_interface
integer, intent(in) :: u
type(phs_forest_t) :: forest
type(phs_channel_t), dimension(:), allocatable :: channel
type(model_data_t), target :: model
type(string_t) :: process_id
type(flavor_t), dimension(5) :: flv
type(string_t) :: filename
type(interaction_t) :: int
integer :: unit_fix
type(mapping_defaults_t) :: mapping_defaults
logical :: found_process, ok
integer :: n_channel, ch, i
logical, dimension(4) :: active = .true.
real(default) :: sqrts = 1000
real(default), dimension(5,4) :: x
real(default), dimension(4) :: factor
real(default) :: volume
write (u, "(A)") "* Test output: PHS forest"
write (u, "(A)") "* Purpose: test PHS forest routines"
write (u, "(A)")
write (u, "(A)") "* Reading model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Create phase-space file 'phs_forest_test.phs'"
write (u, "(A)")
call flv%init ([11, -11, 11, -11, 22], model)
unit_fix = free_unit ()
open (file="phs_forest_test.phs", unit=unit_fix, action="write")
write (unit_fix, *) "process foo"
write (unit_fix, *) 'md5sum_process = "6ABA33BC2927925D0F073B1C1170780A"'
write (unit_fix, *) 'md5sum_model_par = "1A0B151EE6E2DEB92D880320355A3EAB"'
write (unit_fix, *) 'md5sum_phs_config = "B6A8877058809A8BDD54753CDAB83ACE"'
write (unit_fix, *) "sqrts = 100.00000000000000"
write (unit_fix, *) "m_threshold_s = 50.000000000000000"
write (unit_fix, *) "m_threshold_t = 100.00000000000000"
write (unit_fix, *) "off_shell = 2"
write (unit_fix, *) "t_channel = 6"
write (unit_fix, *) "keep_nonresonant = F"
write (unit_fix, *) ""
write (unit_fix, *) " grove"
write (unit_fix, *) " tree 3 7"
write (unit_fix, *) " map 3 s_channel 23"
write (unit_fix, *) " tree 5 7"
write (unit_fix, *) " tree 6 7"
write (unit_fix, *) " grove"
write (unit_fix, *) " tree 9 11"
write (unit_fix, *) " map 9 t_channel 22"
close (unit_fix)
write (u, "(A)")
write (u, "(A)") "* Read phase-space file 'phs_forest_test.phs'"
call syntax_phs_forest_init ()
process_id = "foo"
filename = "phs_forest_test.phs"
call forest%read (filename, process_id, 2, 3, model, found_process)
write (u, "(A)")
write (u, "(A)") "* Set parameters, flavors, equiv, momenta"
write (u, "(A)")
call forest%set_flavors (flv)
call forest%set_parameters (mapping_defaults, .false.)
call forest%setup_prt_combinations ()
call forest%set_equivalences ()
call int%basic_init (2, 0, 3)
call int%set_momentum &
(vector4_moving (500._default, 500._default, 3), 1)
call int%set_momentum &
(vector4_moving (500._default,-500._default, 3), 2)
call forest%set_prt_in (int)
n_channel = 2
x = 0
x(:,n_channel) = [0.3, 0.4, 0.1, 0.9, 0.6]
write (u, "(A)") " Input values:"
write (u, "(3x,5(1x," // FMT_12 // "))") x(:,n_channel)
write (u, "(A)")
write (u, "(A)") "* Evaluating phase space"
call forest%evaluate_selected_channel (n_channel, active, sqrts, &
x, factor, volume, ok)
call forest%evaluate_other_channels (n_channel, active, sqrts, &
x, factor, combine=.true.)
call forest%get_prt_out (int)
write (u, "(A)") " Output values:"
do ch = 1, 4
write (u, "(3x,5(1x," // FMT_12 // "))") x(:,ch)
end do
call int%basic_write (u)
write (u, "(A)") " Factors:"
write (u, "(3x,5(1x," // FMT_12 // "))") factor
write (u, "(A)") " Volume:"
write (u, "(3x,5(1x," // FMT_12 // "))") volume
call forest%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute equivalences"
n_channel = 4
allocate (channel (n_channel))
call forest%get_equivalences (channel, .true.)
do i = 1, n_channel
write (u, "(1x,I0,':')", advance = "no") ch
call channel(i)%write (u)
end do
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
call forest%final ()
call syntax_phs_forest_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_forest_1"
end subroutine phs_forest_1
@ %def phs_forest_1
@
\subsubsection{Resonance histories}
Read a suitably nontrivial forest from file and recover the set of
resonance histories.
<<PHS forests: execute tests>>=
call test (phs_forest_2, "phs_forest_2", &
"handle phs forest resonance content", &
u, results)
<<PHS forests: test declarations>>=
public :: phs_forest_2
<<PHS forests: tests>>=
subroutine phs_forest_2 (u)
use os_interface
integer, intent(in) :: u
integer :: unit_fix
type(phs_forest_t) :: forest
type(model_data_t), target :: model
type(string_t) :: process_id
type(string_t) :: filename
logical :: found_process
type(resonance_history_set_t) :: res_set
integer :: i
write (u, "(A)") "* Test output: phs_forest_2"
write (u, "(A)") "* Purpose: test PHS forest routines"
write (u, "(A)")
write (u, "(A)") "* Reading model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Create phase-space file 'phs_forest_2.phs'"
write (u, "(A)")
unit_fix = free_unit ()
open (file="phs_forest_2.phs", unit=unit_fix, action="write")
write (unit_fix, *) "process foo"
write (unit_fix, *) 'md5sum_process = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"'
write (unit_fix, *) 'md5sum_model_par = "1A0B151EE6E2DEB92D880320355A3EAB"'
write (unit_fix, *) 'md5sum_phs_config = "XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX"'
write (unit_fix, *) "sqrts = 100.00000000000000"
write (unit_fix, *) "m_threshold_s = 50.000000000000000"
write (unit_fix, *) "m_threshold_t = 100.00000000000000"
write (unit_fix, *) "off_shell = 2"
write (unit_fix, *) "t_channel = 6"
write (unit_fix, *) "keep_nonresonant = F"
write (unit_fix, *) ""
write (unit_fix, *) " grove"
write (unit_fix, *) " tree 3 7"
write (unit_fix, *) " tree 3 7"
write (unit_fix, *) " map 3 s_channel -24"
write (unit_fix, *) " tree 5 7"
write (unit_fix, *) " tree 3 7"
write (unit_fix, *) " map 3 s_channel -24"
write (unit_fix, *) " map 7 s_channel 23"
write (unit_fix, *) " tree 5 7"
write (unit_fix, *) " map 7 s_channel 25"
write (unit_fix, *) " tree 3 11"
write (unit_fix, *) " map 3 s_channel -24"
close (unit_fix)
write (u, "(A)") "* Read phase-space file 'phs_forest_2.phs'"
call syntax_phs_forest_init ()
process_id = "foo"
filename = "phs_forest_2.phs"
call forest%read (filename, process_id, 2, 3, model, found_process)
write (u, "(A)")
write (u, "(A)") "* Extract resonance history set"
write (u, "(A)")
call forest%extract_resonance_history_set (res_set)
call res_set%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call model%final ()
call forest%final ()
call syntax_phs_forest_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_forest_2"
end subroutine phs_forest_2
@ %def phs_forest_2
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Finding phase space parameterizations}
If the phase space configuration is not found in the appropriate file,
we should generate one.
The idea is to construct all Feynman diagrams subject to certain
constraints which eliminate everything that is probably irrelevant for
the integration. These Feynman diagrams (cascades) are grouped in
groves by finding equivalence classes related by symmetry and ordered
with respect to their importance (resonances). Finally, the result
(or part of it) is written to file and used for the integration.
This module may eventually disappear and be replaced by CAML code.
In particular, we need here a set of Feynman rules (vertices with
particle codes, but not the factors). Thus, the module works for the
Standard Model only.
Note that this module is stand-alone, it communicates to the main
program only via the generated ASCII phase-space configuration file.
<<[[cascades.f90]]>>=
<<File header>>
module cascades
<<Use kinds>>
use kinds, only: TC, i8, i32
<<Use strings>>
<<Use debug>>
use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
use physics_defs, only: UNDEFINED
use model_data
use flavors
use resonances, only: resonance_info_t
use resonances, only: resonance_history_t
use resonances, only: resonance_history_set_t
use phs_forests
<<Standard module head>>
<<Cascades: public>>
<<Cascades: parameters>>
<<Cascades: types>>
<<Cascades: interfaces>>
interface
<<Cascades: sub interfaces>>
end interface
end module cascades
@ %def cascades
@
<<[[cascades_sub.f90]]>>=
<<File header>>
submodule (cascades) cascades_s
use io_units
use constants, only: one
use format_defs, only: FMT_12, FMT_19
use numeric_utils
use diagnostics
use hashes
use sorting
use lorentz
!!! Intel oneAPI 2022/23 regression workaround
use resonances, only: resonance_info_t
use resonances, only: resonance_history_t
use resonances, only: resonance_history_set_t
implicit none
contains
<<Cascades: procedures>>
end submodule cascades_s
@ %def cascades_s
@
\subsection{The mapping modes}
The valid mapping modes, to be used below. We will make use of the convention
that mappings of internal particles have a positive value. Only for positive
values, the flavor code is propagated when combining cascades.
<<Mapping modes>>=
integer, parameter :: &
& EXTERNAL_PRT = -1, &
& NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, &
& RADIATION = 4, COLLINEAR = 5, INFRARED = 6, &
& STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, &
& ON_SHELL = 99
@ %def EXTERNAL_PRT
@ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL
@ %def RADIATION COLLINEAR INFRARED
@ %def STEP_MAPPING_E STEP_MAPPING_H
@ %def ON_SHELL
<<Cascades: parameters>>=
<<Mapping modes>>
@
\subsection{The cascade type}
A cascade is essentially the same as a decay tree (both definitions
may be merged in a later version). It contains a linked tree of
nodes, each of which representing an internal particle. In contrast
to decay trees, each node has a definite particle code. These nodes
need not be modified, therefore we can use pointers and do not have to
copy them. Thus, physically each cascades has only a single node, the
mother particle. However, to be able to compare trees quickly, we
store in addition an array of binary codes which is always sorted in
ascending order. This is accompanied by a corresponding list of
particle codes. The index is the location of the corresponding
cascade in the cascade set, this may be used to access the daughters
directly.
The real mass is the particle mass belonging to the particle code.
The minimal mass is the sum of the real masses of all its daughters;
this is the kinematical cutoff. The effective mass may be zero if the
particle mass is below a certain threshold; it may be the real mass if
the particle is resonant; or it may be some other value.
The logical [[t_channel]] is set if this a $t$-channel line, while
[[initial]] is true only for an initial particle. Note that both
initial particles are also [[t_channel]] by definition, and that they
are distinguished by the direction of the tree: One of them decays
and is the root of the tree, while the other one is one of the leaves.
The cascade is a list of nodes (particles) which are linked via the
[[daughter]] entries. The node is the mother particle of
the decay cascade. Much of the information in the nodes is repeated
in arrays, to be accessible more easily. The arrays will be kept
sorted by binary codes.
The counter [[n_off_shell]] is increased for each internal line that
is neither resonant nor log-enhanced. It is set to zero if the
current line is resonant, since this implies on-shell particle production
and subsequent decay.
The counter [[n_t_channel]] is non-negative once an initial particle
is included in the tree: then, it counts the number of $t$-channel lines.
The [[multiplicity]] is the number of branchings to follow until all
daughters are on-shell. A resonant or non-decaying particle has
multiplicity one. Merging nodes, the multiplicities add unless the
mother is a resonance. An initial or final node has multiplicity
zero.
The arrays correspond to the subnode tree [[tree]] of the current
cascade. PDG codes are stored only for those positions which are
resonant, with the exception of the last entry, i.e., the current node.
Other positions, in particular external legs, are assigned undefined
PDG code.
A cascade is uniquely identified by its tree, the tree of PDG codes,
and the tree of mappings. The tree of resonances is kept only to mask
the PDG tree as described above.
<<Cascades: types>>=
type :: cascade_t
private
! counters
integer :: index = 0
integer :: grove = 0
! status
logical :: active = .false.
logical :: complete = .false.
logical :: incoming = .false.
! this node
integer(TC) :: bincode = 0
type(flavor_t) :: flv
integer :: pdg = UNDEFINED
logical :: is_vector = .false.
real(default) :: m_min = 0
real(default) :: m_rea = 0
real(default) :: m_eff = 0
integer :: mapping = NO_MAPPING
logical :: on_shell = .false.
logical :: resonant = .false.
logical :: log_enhanced = .false.
logical :: t_channel = .false.
! global tree properties
integer :: multiplicity = 0
integer :: internal = 0
integer :: n_off_shell = 0
integer :: n_resonances = 0
integer :: n_log_enhanced = 0
integer :: n_t_channel = 0
integer :: res_hash = 0
! the sub-node tree
integer :: depth = 0
integer(TC), dimension(:), allocatable :: tree
integer, dimension(:), allocatable :: tree_pdg
integer, dimension(:), allocatable :: tree_mapping
logical, dimension(:), allocatable :: tree_resonant
! branch connections
logical :: has_children = .false.
type(cascade_t), pointer :: daughter1 => null ()
type(cascade_t), pointer :: daughter2 => null ()
type(cascade_t), pointer :: mother => null ()
! next in list
type(cascade_t), pointer :: next => null ()
contains
<<Cascades: cascade: TBP>>
end type cascade_t
@ %def cascade_t
<<Cascades: procedures>>=
subroutine cascade_init (cascade, depth)
type(cascade_t), intent(out) :: cascade
integer, intent(in) :: depth
integer, save :: index = 0
index = cascade_index ()
cascade%index = index
cascade%depth = depth
cascade%active = .true.
allocate (cascade%tree (depth))
allocate (cascade%tree_pdg (depth))
allocate (cascade%tree_mapping (depth))
allocate (cascade%tree_resonant (depth))
end subroutine cascade_init
@ %def cascade_init
@ Keep and increment a global index
<<Cascades: procedures>>=
function cascade_index (seed) result (index)
integer :: index
integer, intent(in), optional :: seed
integer, save :: i = 0
if (present (seed)) i = seed
i = i + 1
index = i
end function cascade_index
@ %def cascade_index
@ We need three versions of writing cascades. This goes to the
phase-space file.
For t/u channel mappings, we use the absolute value of the PDG code.
<<Cascades: procedures>>=
subroutine cascade_write_file_format (cascade, model, unit)
type(cascade_t), intent(in) :: cascade
class(model_data_t), intent(in), target :: model
integer, intent(in), optional :: unit
type(flavor_t) :: flv
integer :: u, i
2 format(3x,A,1x,I3,1x,A,1x,I9,1x,'!',1x,A)
u = given_output_unit (unit); if (u < 0) return
call write_reduced (cascade%tree, u)
write (u, "(A)")
do i = 1, cascade%depth
call flv%init (cascade%tree_pdg(i), model)
select case (cascade%tree_mapping(i))
case (NO_MAPPING, EXTERNAL_PRT)
case (S_CHANNEL)
write(u,2) 'map', &
cascade%tree(i), 's_channel', cascade%tree_pdg(i), &
char (flv%get_name ())
case (T_CHANNEL)
write(u,2) 'map', &
cascade%tree(i), 't_channel', abs (cascade%tree_pdg(i)), &
char (flv%get_name ())
case (U_CHANNEL)
write(u,2) 'map', &
cascade%tree(i), 'u_channel', abs (cascade%tree_pdg(i)), &
char (flv%get_name ())
case (RADIATION)
write(u,2) 'map', &
cascade%tree(i), 'radiation', cascade%tree_pdg(i), &
char (flv%get_name ())
case (COLLINEAR)
write(u,2) 'map', &
cascade%tree(i), 'collinear', cascade%tree_pdg(i), &
char (flv%get_name ())
case (INFRARED)
write(u,2) 'map', &
cascade%tree(i), 'infrared ', cascade%tree_pdg(i), &
char (flv%get_name ())
case (ON_SHELL)
write(u,2) 'map', &
cascade%tree(i), 'on_shell ', cascade%tree_pdg(i), &
char (flv%get_name ())
case default
call msg_bug (" Impossible mapping mode encountered")
end select
end do
contains
subroutine write_reduced (array, unit)
integer(TC), dimension(:), intent(in) :: array
integer, intent(in) :: unit
integer :: i
write (u, "(3x,A,1x)", advance="no") "tree"
do i = 1, size (array)
if (decay_level (array(i)) > 1) then
write (u, "(1x,I0)", advance="no") array(i)
end if
end do
end subroutine write_reduced
elemental function decay_level (k) result (l)
integer(TC), intent(in) :: k
integer :: l
integer :: i
l = 0
do i = 0, bit_size(k) - 1
if (btest(k,i)) l = l + 1
end do
end function decay_level
subroutine start_comment (u)
integer, intent(in) :: u
write(u, '(1x,A)', advance='no') '!'
end subroutine start_comment
end subroutine cascade_write_file_format
@ %def cascade_write_file_format
@ This creates metapost source for graphical display:
<<Cascades: procedures>>=
subroutine cascade_write_graph_format (cascade, count, unit)
type(cascade_t), intent(in) :: cascade
integer, intent(in) :: count
integer, intent(in), optional :: unit
integer :: u
integer(TC) :: mask
type(string_t) :: left_str, right_str
u = given_output_unit (unit); if (u < 0) return
mask = 2**((cascade%depth+3)/2) - 1
left_str = ""
right_str = ""
write (u, '(A)') "\begin{minipage}{105pt}"
write (u, '(A)') "\vspace{30pt}"
write (u, '(A)') "\begin{center}"
write (u, '(A)') "\begin{fmfgraph*}(55,55)"
call graph_write (cascade, mask)
write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}"
write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}"
write (u, '(A)') "\end{fmfgraph*}\\"
write (u, '(A,I5,A)') "\fbox{$", count, "$}"
write (u, '(A)') "\end{center}"
write (u, '(A)') "\end{minipage}"
write (u, '(A)') "%"
contains
recursive subroutine graph_write (cascade, mask, reverse)
type(cascade_t), intent(in) :: cascade
integer(TC), intent(in) :: mask
logical, intent(in), optional :: reverse
type(flavor_t) :: anti
logical :: rev
rev = .false.; if (present(reverse)) rev = reverse
if (cascade%has_children) then
if (.not.rev) then
call vertex_write (cascade, cascade%daughter1, mask)
call vertex_write (cascade, cascade%daughter2, mask)
else
call vertex_write (cascade, cascade%daughter2, mask, .true.)
call vertex_write (cascade, cascade%daughter1, mask, .true.)
end if
if (cascade%complete) then
call vertex_write (cascade, cascade%mother, mask, .true.)
write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}"
end if
else
if (cascade%incoming) then
anti = cascade%flv%anti ()
call external_write (cascade%bincode, anti%get_tex_name (), &
left_str)
else
call external_write (cascade%bincode, cascade%flv%get_tex_name (), &
right_str)
end if
end if
end subroutine graph_write
recursive subroutine vertex_write (cascade, daughter, mask, reverse)
type(cascade_t), intent(in) :: cascade, daughter
integer(TC), intent(in) :: mask
logical, intent(in), optional :: reverse
integer :: bincode
if (cascade%complete) then
bincode = 0
else
bincode = cascade%bincode
end if
call graph_write (daughter, mask, reverse)
if (daughter%has_children) then
call line_write (bincode, daughter%bincode, daughter%flv, &
mapping=daughter%mapping)
else
call line_write (bincode, daughter%bincode, daughter%flv)
end if
end subroutine vertex_write
subroutine line_write (i1, i2, flv, mapping)
integer(TC), intent(in) :: i1, i2
type(flavor_t), intent(in) :: flv
integer, intent(in), optional :: mapping
integer :: k1, k2
type(string_t) :: prt_type
select case (flv%get_spin_type ())
case (SCALAR); prt_type = "plain"
case (SPINOR); prt_type = "fermion"
case (VECTOR); prt_type = "boson"
case (VECTORSPINOR); prt_type = "fermion"
case (TENSOR); prt_type = "dbl_wiggly"
case default; prt_type = "dashes"
end select
if (flv%is_antiparticle ()) then
k1 = i2; k2 = i1
else
k1 = i1; k2 = i2
end if
if (present (mapping)) then
select case (mapping)
case (S_CHANNEL)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=blue,lab=\sm\blue$" // &
& char (flv%get_tex_name ()) // "$}" // &
& "{v", k1, ",v", k2, "}"
case (T_CHANNEL, U_CHANNEL)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=cyan,lab=\sm\cyan$" // &
& char (flv%get_tex_name ()) // "$}" // &
& "{v", k1, ",v", k2, "}"
case (RADIATION)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=green,lab=\sm\green$" // &
& char (flv%get_tex_name ()) // "$}" // &
& "{v", k1, ",v", k2, "}"
case (COLLINEAR)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=magenta,lab=\sm\magenta$" // &
& char (flv%get_tex_name ()) // "$}" // &
& "{v", k1, ",v", k2, "}"
case (INFRARED)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=red,lab=\sm\red$" // &
& char (flv%get_tex_name ()) // "$}" // &
& "{v", k1, ",v", k2, "}"
case default
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=black}" // &
& "{v", k1, ",v", k2, "}"
end select
else
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& "}" // &
& "{v", k1, ",v", k2, "}"
end if
end subroutine line_write
subroutine external_write (bincode, name, ext_str)
integer(TC), intent(in) :: bincode
type(string_t), intent(in) :: name
type(string_t), intent(inout) :: ext_str
character(len=20) :: str
write (str, '(A2,I0)') ",v", bincode
ext_str = ext_str // trim (str)
write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" &
// char (name) &
// "\,(", bincode, ")" &
// "$}{v", bincode, "}"
end subroutine external_write
end subroutine cascade_write_graph_format
@ %def cascade_write_graph_format
@ This is for screen/debugging output:
<<Cascades: procedures>>=
subroutine cascade_write (cascade, unit)
type(cascade_t), intent(in) :: cascade
integer, intent(in), optional :: unit
integer :: u
character(9) :: depth
u = given_output_unit (unit); if (u < 0) return
write (u, "(A,(1x,I7))") 'Cascade #', cascade%index
write (u, "(A,(1x,I7))") ' Grove: #', cascade%grove
write (u, "(A,3(1x,L1))") ' act/cmp/inc: ', &
cascade%active, cascade%complete, cascade%incoming
write (u, "(A,I0)") ' Bincode: ', cascade%bincode
write (u, "(A)", advance="no") ' Flavor: '
call cascade%flv%write (unit)
write (u, "(A,I9)") ' Active flavor:', cascade%pdg
write (u, "(A,L1)") ' Is vector: ', cascade%is_vector
write (u, "(A,3(1x," // FMT_19 // "))") ' Mass (m/r/e): ', &
cascade%m_min, cascade%m_rea, cascade%m_eff
write (u, "(A,I1)") ' Mapping: ', cascade%mapping
write (u, "(A,3(1x,L1))") ' res/log/tch: ', &
cascade%resonant, cascade%log_enhanced, cascade%t_channel
write (u, "(A,(1x,I7))") ' Multiplicity: ', cascade%multiplicity
write (u, "(A,2(1x,I7))") ' n intern/off: ', &
cascade%internal, cascade%n_off_shell
write (u, "(A,3(1x,I7))") ' n res/log/tch:', &
cascade%n_resonances, cascade%n_log_enhanced, cascade%n_t_channel
write (u, "(A,I7)") ' Depth: ', cascade%depth
write (depth, "(I7)") cascade%depth
write (u, "(A," // depth // "(1x,I7))") &
' Tree: ', cascade%tree
write (u, "(A," // depth // "(1x,I7))") &
' Tree(PDG): ', cascade%tree_pdg
write (u, "(A," // depth // "(1x,I7))") &
' Tree(mapping):', cascade%tree_mapping
write (u, "(A," // depth // "(1x,L1))") &
' Tree(res): ', cascade%tree_resonant
if (cascade%has_children) then
write (u, "(A,I7,1x,I7)") ' Daughter1/2: ', &
cascade%daughter1%index, cascade%daughter2%index
end if
if (associated (cascade%mother)) then
write (u, "(A,I7)") ' Mother: ', cascade%mother%index
end if
end subroutine cascade_write
@ %def cascade_write
@
\subsection{Creating new cascades}
This initializes a single-particle cascade (external, final state).
The PDG entry in the tree is set undefined because the cascade is not
resonant. However, the flavor entry is set, so the cascade flavor
is identified nevertheless.
<<Cascades: procedures>>=
subroutine cascade_init_outgoing (cascade, flv, pos, m_thr)
type(cascade_t), intent(out) :: cascade
type(flavor_t), intent(in) :: flv
integer, intent(in) :: pos
real(default), intent(in) :: m_thr
call cascade_init (cascade, 1)
cascade%bincode = ibset (0_TC, pos-1)
cascade%flv = flv
cascade%pdg = cascade%flv%get_pdg ()
cascade%is_vector = flv%get_spin_type () == VECTOR
cascade%m_min = flv%get_mass ()
cascade%m_rea = cascade%m_min
if (cascade%m_rea >= m_thr) then
cascade%m_eff = cascade%m_rea
end if
cascade%on_shell = .true.
cascade%multiplicity = 1
cascade%tree(1) = cascade%bincode
cascade%tree_pdg(1) = cascade%pdg
cascade%tree_mapping(1) = EXTERNAL_PRT
cascade%tree_resonant(1) = .false.
end subroutine cascade_init_outgoing
@ %def cascade_init_outgoing
@ The same for an incoming line:
<<Cascades: procedures>>=
subroutine cascade_init_incoming (cascade, flv, pos, m_thr)
type(cascade_t), intent(out) :: cascade
type(flavor_t), intent(in) :: flv
integer, intent(in) :: pos
real(default), intent(in) :: m_thr
call cascade_init (cascade, 1)
cascade%incoming = .true.
cascade%bincode = ibset (0_TC, pos-1)
cascade%flv = flv%anti ()
cascade%pdg = cascade%flv%get_pdg ()
cascade%is_vector = flv%get_spin_type () == VECTOR
cascade%m_min = flv%get_mass ()
cascade%m_rea = cascade%m_min
if (cascade%m_rea >= m_thr) then
cascade%m_eff = cascade%m_rea
end if
cascade%on_shell = .true.
cascade%n_t_channel = 0
cascade%n_off_shell = 0
cascade%tree(1) = cascade%bincode
cascade%tree_pdg(1) = cascade%pdg
cascade%tree_mapping(1) = EXTERNAL_PRT
cascade%tree_resonant(1) = .false.
end subroutine cascade_init_incoming
@ %def cascade_init_outgoing
@
\subsection{Tools}
This function returns true if the two cascades share no common
external particle. This is a requirement for joining them.
<<Cascades: interfaces>>=
interface operator(.disjunct.)
module procedure cascade_disjunct
end interface
<<Cascades: sub interfaces>>=
module function cascade_disjunct (cascade1, cascade2) result (flag)
logical :: flag
type(cascade_t), intent(in) :: cascade1, cascade2
end function cascade_disjunct
<<Cascades: procedures>>=
module function cascade_disjunct (cascade1, cascade2) result (flag)
logical :: flag
type(cascade_t), intent(in) :: cascade1, cascade2
flag = iand (cascade1%bincode, cascade2%bincode) == 0
end function cascade_disjunct
@ %def cascade_disjunct
@ %def .disjunct.
@ Compute a hash code for the resonance pattern of a cascade. We count the
number of times each particle appears as a resonance.
We pack the PDG codes of the resonances in two arrays (s-channel and
t-channel), sort them both, concatenate the results, transfer to
[[i8]] integers, and compute the hash code from this byte stream.
For t/u-channel, we remove the sign for antiparticles since this is not
well-defined.
<<Cascades: procedures>>=
subroutine cascade_assign_resonance_hash (cascade)
type(cascade_t), intent(inout) :: cascade
integer(i8), dimension(1) :: mold
cascade%res_hash = hash (transfer &
([sort (pack (cascade%tree_pdg, &
cascade%tree_resonant)), &
sort (pack (abs (cascade%tree_pdg), &
cascade%tree_mapping == T_CHANNEL .or. &
cascade%tree_mapping == U_CHANNEL))], &
mold))
end subroutine cascade_assign_resonance_hash
@ %def cascade_assign_resonance_hash
@
\subsection{Hash entries for cascades}
We will set up a hash array which contains keys of and pointers to
cascades. We hold a list of cascade (pointers) within each bucket.
This is not for collision resolution, but for keeping similar, but
unequal cascades together.
<<Cascades: types>>=
type :: cascade_p
type(cascade_t), pointer :: cascade => null ()
type(cascade_p), pointer :: next => null ()
end type cascade_p
@ %def cascade_p
@ Here is the bucket or hash entry type:
<<Cascades: types>>=
type :: hash_entry_t
integer(i32) :: hashval = 0
integer(i8), dimension(:), allocatable :: key
type(cascade_p), pointer :: first => null ()
type(cascade_p), pointer :: last => null ()
end type hash_entry_t
@ %def hash_entry_t
<<Cascades: public>>=
public :: hash_entry_init
<<Cascades: sub interfaces>>=
module subroutine hash_entry_init (entry, entry_in)
type(hash_entry_t), intent(out) :: entry
type(hash_entry_t), intent(in) :: entry_in
end subroutine hash_entry_init
<<Cascades: procedures>>=
module subroutine hash_entry_init (entry, entry_in)
type(hash_entry_t), intent(out) :: entry
type(hash_entry_t), intent(in) :: entry_in
type(cascade_p), pointer :: casc_iter, casc_copy
entry%hashval = entry_in%hashval
entry%key = entry_in%key
casc_iter => entry_in%first
do while (associated (casc_iter))
allocate (casc_copy)
casc_copy = casc_iter
casc_copy%next => null ()
if (associated (entry%first)) then
entry%last%next => casc_copy
else
entry%first => casc_copy
end if
entry%last => casc_copy
casc_iter => casc_iter%next
end do
end subroutine hash_entry_init
@ %def hash_entry_init
@ Finalize: just deallocate the list; the contents are just pointers.
<<Cascades: procedures>>=
subroutine hash_entry_final (hash_entry)
type(hash_entry_t), intent(inout) :: hash_entry
type(cascade_p), pointer :: current
do while (associated (hash_entry%first))
current => hash_entry%first
hash_entry%first => current%next
deallocate (current)
end do
end subroutine hash_entry_final
@ %def hash_entry_final
@ Output: concise format for debugging, just list cascade indices.
<<Cascades: procedures>>=
subroutine hash_entry_write (hash_entry, unit)
type(hash_entry_t), intent(in) :: hash_entry
integer, intent(in), optional :: unit
type(cascade_p), pointer :: current
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)", advance="no") "Entry:"
do i = 1, size (hash_entry%key)
write (u, "(1x,I0)", advance="no") hash_entry%key(i)
end do
write (u, "(1x,A)", advance="no") "->"
current => hash_entry%first
do while (associated (current))
write (u, "(1x,I7)", advance="no") current%cascade%index
current => current%next
end do
write (u, *)
end subroutine hash_entry_write
@ %def hash_entry_write
@ This function adds a cascade pointer to the bucket. If [[ok]] is
present, check first if it is already there and return failure if yes.
If [[cascade_ptr]] is also present, set it to the current cascade if
successful. If not, set it to the cascade that is already there.
<<Cascades: procedures>>=
subroutine hash_entry_add_cascade_ptr (hash_entry, cascade, ok, cascade_ptr)
type(hash_entry_t), intent(inout) :: hash_entry
type(cascade_t), intent(in), target :: cascade
logical, intent(out), optional :: ok
type(cascade_t), optional, pointer :: cascade_ptr
type(cascade_p), pointer :: current
if (present (ok)) then
call hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr)
if (.not. ok) return
end if
allocate (current)
current%cascade => cascade
if (associated (hash_entry%last)) then
hash_entry%last%next => current
else
hash_entry%first => current
end if
hash_entry%last => current
end subroutine hash_entry_add_cascade_ptr
@ %def hash_entry_add_cascade_ptr
@ This function checks whether a cascade is already in the bucket.
For incomplete cascades, we look for an exact match. It should suffice
to verify the tree, the PDG codes, and the mapping modes. This is the
information that is written to the phase space file.
For complete cascades, we ignore the PDG code at positions with
mappings infrared, collinear, or t/u-channel. Thus a cascade which is
distinguished only by PDG code at such places, is flagged existent.
If the convention is followed that light particles come before heavier
ones (in the model definition), this ensures that the lightest
particle is kept in the appropriate place, corresponding to the
strongest peak.
For external cascades (incoming/outgoing) we take the PDG code into
account even though it is zeroed in the PDG-code tree.
<<Cascades: procedures>>=
subroutine hash_entry_check_cascade (hash_entry, cascade, ok, cascade_ptr)
type(hash_entry_t), intent(in), target :: hash_entry
type(cascade_t), intent(in), target :: cascade
logical, intent(out) :: ok
type(cascade_t), optional, pointer :: cascade_ptr
type(cascade_p), pointer :: current
integer, dimension(:), allocatable :: tree_pdg
ok = .true.
allocate (tree_pdg (size (cascade%tree_pdg)))
if (cascade%complete) then
where (cascade%tree_mapping == INFRARED .or. &
cascade%tree_mapping == COLLINEAR .or. &
cascade%tree_mapping == T_CHANNEL .or. &
cascade%tree_mapping == U_CHANNEL)
tree_pdg = 0
elsewhere
tree_pdg = cascade%tree_pdg
end where
else
tree_pdg = cascade%tree_pdg
end if
current => hash_entry%first
do while (associated (current))
if (current%cascade%depth == cascade%depth) then
if (all (current%cascade%tree == cascade%tree)) then
if (all (current%cascade%tree_mapping == cascade%tree_mapping)) &
then
if (all (current%cascade%tree_pdg .match. tree_pdg)) then
if (present (cascade_ptr)) cascade_ptr => current%cascade
ok = .false.; return
end if
end if
end if
end if
current => current%next
end do
if (present (cascade_ptr)) cascade_ptr => cascade
end subroutine hash_entry_check_cascade
@ %def hash_entry_check_cascade
@ For PDG codes, we specify that the undefined code matches any code.
This is already defined for flavor objects, but here we need it for
the codes themselves.
<<Cascades: interfaces>>=
interface operator(.match.)
module procedure pdg_match
end interface
<<Cascades: sub interfaces>>=
elemental module function pdg_match (pdg1, pdg2) result (flag)
logical :: flag
integer(TC), intent(in) :: pdg1, pdg2
end function pdg_match
<<Cascades: procedures>>=
elemental module function pdg_match (pdg1, pdg2) result (flag)
logical :: flag
integer(TC), intent(in) :: pdg1, pdg2
select case (pdg1)
case (0)
flag = .true.
case default
select case (pdg2)
case (0)
flag = .true.
case default
flag = pdg1 == pdg2
end select
end select
end function pdg_match
@ %def .match.
@
\subsection{The cascade set}
The cascade set will later be transformed into the decay forest. It
is set up as a linked list. In addition to the usual [[first]] and
[[last]] pointers, there is a [[first_t]] pointer which points to the
first t-channel cascade (after all s-channel cascades), and a
[[first_k]] pointer which points to the first final cascade (with a
keystone).
As an auxiliary device, the object contains a hash array with
associated parameters where an additional pointer is stored for each
cascade. The keys are made from the relevant cascade data. This hash
is used for fast detection (and thus avoidance) of double entries in
the cascade list.
<<Cascades: public>>=
public :: cascade_set_t
<<Cascades: types>>=
type :: cascade_set_t
private
class(model_data_t), pointer :: model
integer :: n_in, n_out, n_tot
type(flavor_t), dimension(:,:), allocatable :: flv
integer :: depth_out, depth_tot
real(default) :: sqrts = 0
real(default) :: m_threshold_s = 0
real(default) :: m_threshold_t = 0
integer :: off_shell = 0
integer :: t_channel = 0
logical :: keep_nonresonant
integer :: n_groves = 0
! The cascade list
type(cascade_t), pointer :: first => null ()
type(cascade_t), pointer :: last => null ()
type(cascade_t), pointer :: first_t => null ()
type(cascade_t), pointer :: first_k => null ()
! The hashtable
integer :: n_entries = 0
real :: fill_ratio = 0
integer :: n_entries_max = 0
integer(i32) :: mask = 0
logical :: fatal_beam_decay = .true.
type(hash_entry_t), dimension(:), allocatable :: entry
end type cascade_set_t
@ %def cascade_set_t
@
<<Cascades: public>>=
interface cascade_set_init
module procedure cascade_set_init_base
module procedure cascade_set_init_from_cascade
end interface
@ %def cascade_set_init
@ This might be broken. Test before using.
<<Cascades: sub interfaces>>=
module subroutine cascade_set_init_from_cascade &
(cascade_set, cascade_set_in)
type(cascade_set_t), intent(out) :: cascade_set
type(cascade_set_t), intent(in), target :: cascade_set_in
end subroutine cascade_set_init_from_cascade
<<Cascades: procedures>>=
module subroutine cascade_set_init_from_cascade &
(cascade_set, cascade_set_in)
type(cascade_set_t), intent(out) :: cascade_set
type(cascade_set_t), intent(in), target :: cascade_set_in
type(cascade_t), pointer :: casc_iter, casc_copy
cascade_set%model => cascade_set_in%model
cascade_set%n_in = cascade_set_in%n_in
cascade_set%n_out = cascade_set_in%n_out
cascade_set%n_tot = cascade_set_in%n_tot
cascade_set%flv = cascade_set_in%flv
cascade_set%depth_out = cascade_set_in%depth_out
cascade_set%depth_tot = cascade_set_in%depth_tot
cascade_set%sqrts = cascade_set_in%sqrts
cascade_set%m_threshold_s = cascade_set_in%m_threshold_s
cascade_set%m_threshold_t = cascade_set_in%m_threshold_t
cascade_set%off_shell = cascade_set_in%off_shell
cascade_set%t_channel = cascade_set_in%t_channel
cascade_set%keep_nonresonant = cascade_set_in%keep_nonresonant
cascade_set%n_groves = cascade_set_in%n_groves
casc_iter => cascade_set_in%first
do while (associated (casc_iter))
allocate (casc_copy)
casc_copy = casc_iter
casc_copy%next => null ()
if (associated (cascade_set%first)) then
cascade_set%last%next => casc_copy
else
cascade_set%first => casc_copy
end if
cascade_set%last => casc_copy
casc_iter => casc_iter%next
end do
cascade_set%n_entries = cascade_set_in%n_entries
cascade_set%fill_ratio = cascade_set_in%fill_ratio
cascade_set%n_entries_max = cascade_set_in%n_entries_max
cascade_set%mask = cascade_set_in%mask
cascade_set%fatal_beam_decay = cascade_set_in%fatal_beam_decay
allocate (cascade_set%entry (0:cascade_set%mask))
cascade_set%entry = cascade_set_in%entry
end subroutine cascade_set_init_from_cascade
@ %def cascade_set_init_from_cascade
@ Return true if there are cascades which are active and complete, so
the phase space file would be nonempty.
<<Cascades: public>>=
public :: cascade_set_is_valid
<<Cascades: sub interfaces>>=
module function cascade_set_is_valid (cascade_set) result (flag)
logical :: flag
type(cascade_set_t), intent(in) :: cascade_set
end function cascade_set_is_valid
<<Cascades: procedures>>=
module function cascade_set_is_valid (cascade_set) result (flag)
logical :: flag
type(cascade_set_t), intent(in) :: cascade_set
type(cascade_t), pointer :: cascade
flag = .false.
cascade => cascade_set%first_k
do while (associated (cascade))
if (cascade%active .and. cascade%complete) then
flag = .true.
return
end if
cascade => cascade%next
end do
end function cascade_set_is_valid
@ %def cascade_set_is_valid
@ The initializer sets up the hash table with some initial size
guessed by looking at the number of external particles. We choose 256
for 3 external particles and a factor of 4 for each additional
particle, limited at $2^{30}$=1G.
<<Cascades: parameters>>=
real, parameter, public :: CASCADE_SET_FILL_RATIO = 0.1
<<Cascades: sub interfaces>>=
module subroutine cascade_set_init_base (cascade_set, model, &
n_in, n_out, phs_par, fatal_beam_decay, flv)
type(cascade_set_t), intent(out) :: cascade_set
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in, n_out
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
type(flavor_t), dimension(:,:), intent(in), optional :: flv
end subroutine cascade_set_init_base
<<Cascades: procedures>>=
module subroutine cascade_set_init_base (cascade_set, model, &
n_in, n_out, phs_par, fatal_beam_decay, flv)
type(cascade_set_t), intent(out) :: cascade_set
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in, n_out
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
type(flavor_t), dimension(:,:), intent(in), optional :: flv
integer :: size_guess
integer :: i, j
cascade_set%model => model
cascade_set%n_in = n_in
cascade_set%n_out = n_out
cascade_set%n_tot = n_in + n_out
if (present (flv)) then
allocate (cascade_set%flv (size (flv, 1), size (flv, 2)))
do i = 1, size (flv, 2)
do j = 1, size (flv, 1)
call cascade_set%flv(j,i)%init (flv(j,i)%get_pdg (), model)
end do
end do
end if
select case (n_in)
case (1); cascade_set%depth_out = 2 * n_out - 3
case (2); cascade_set%depth_out = 2 * n_out - 1
end select
cascade_set%depth_tot = 2 * cascade_set%n_tot - 3
cascade_set%sqrts = phs_par%sqrts
cascade_set%m_threshold_s = phs_par%m_threshold_s
cascade_set%m_threshold_t = phs_par%m_threshold_t
cascade_set%off_shell = phs_par%off_shell
cascade_set%t_channel = phs_par%t_channel
cascade_set%keep_nonresonant = phs_par%keep_nonresonant
cascade_set%fill_ratio = CASCADE_SET_FILL_RATIO
size_guess = ishft (256, min (2 * (cascade_set%n_tot - 3), 22))
cascade_set%n_entries_max = size_guess * cascade_set%fill_ratio
cascade_set%mask = size_guess - 1
allocate (cascade_set%entry (0:cascade_set%mask))
cascade_set%fatal_beam_decay = fatal_beam_decay
end subroutine cascade_set_init_base
@ %def cascade_set_init_base
@ The finalizer has to delete both the hash and the list.
<<Cascades: public>>=
public :: cascade_set_final
<<Cascades: sub interfaces>>=
module subroutine cascade_set_final (cascade_set)
type(cascade_set_t), intent(inout), target :: cascade_set
end subroutine cascade_set_final
<<Cascades: procedures>>=
module subroutine cascade_set_final (cascade_set)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), pointer :: current
integer :: i
if (allocated (cascade_set%entry)) then
do i = 0, cascade_set%mask
call hash_entry_final (cascade_set%entry(i))
end do
deallocate (cascade_set%entry)
end if
do while (associated (cascade_set%first))
current => cascade_set%first
cascade_set%first => cascade_set%first%next
deallocate (current)
end do
end subroutine cascade_set_final
@ %def cascade_set_final
@ Write the process in ASCII format, in columns that are headed by the
corresponding bincode.
<<Cascades: public>>=
public :: cascade_set_write_process_bincode_format
<<Cascades: sub interfaces>>=
module subroutine cascade_set_write_process_bincode_format &
(cascade_set, unit)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: unit
end subroutine cascade_set_write_process_bincode_format
<<Cascades: procedures>>=
module subroutine cascade_set_write_process_bincode_format &
(cascade_set, unit)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: unit
integer, dimension(:), allocatable :: bincode, field_width
integer :: n_in, n_out, n_tot, n_flv
integer :: u, f, i, bc
character(20) :: str
type(string_t) :: fmt_head
type(string_t), dimension(:), allocatable :: fmt_proc
u = given_output_unit (unit); if (u < 0) return
if (.not. allocated (cascade_set%flv)) return
write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:"
n_in = cascade_set%n_in
n_out = cascade_set%n_out
n_tot = cascade_set%n_tot
n_flv = size (cascade_set%flv, 2)
allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot))
bc = 1
do i = 1, n_out
bincode(n_in + i) = bc
bc = 2 * bc
end do
do i = n_in, 1, -1
bincode(i) = bc
bc = 2 * bc
end do
do i = 1, n_tot
write (str, "(I0)") bincode(i)
field_width(i) = len_trim (str)
do f = 1, n_flv
field_width(i) = max (field_width(i), &
len (cascade_set%flv(i,f)%get_name ()))
end do
end do
fmt_head = "('!'"
do i = 1, n_tot
fmt_head = fmt_head // ",1x,"
fmt_proc(i) = "(1x,"
write (str, "(I0)") field_width(i)
fmt_head = fmt_head // "I" // trim(str)
fmt_proc(i) = fmt_proc(i) // "A" // trim(str)
if (i == n_in) then
fmt_head = fmt_head // ",1x,' '"
end if
end do
do i = 1, n_tot
fmt_proc(i) = fmt_proc(i) // ")"
end do
fmt_head = fmt_head // ")"
write (u, char (fmt_head)) bincode
do f = 1, n_flv
write (u, "('!')", advance="no")
do i = 1, n_tot
write (u, char (fmt_proc(i)), advance="no") &
char (cascade_set%flv(i,f)%get_name ())
if (i == n_in) write (u, "(1x,'=>')", advance="no")
end do
write (u, *)
end do
write (u, char (fmt_head)) bincode
end subroutine cascade_set_write_process_bincode_format
@ %def cascade_set_write_process_tex_format
@ Write the process as a \LaTeX\ expression.
<<Cascades: procedures>>=
subroutine cascade_set_write_process_tex_format (cascade_set, unit)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: unit
integer :: u, f, i
u = given_output_unit (unit); if (u < 0) return
if (.not. allocated (cascade_set%flv)) return
write (u, "(A)") "\begin{align*}"
do f = 1, size (cascade_set%flv, 2)
do i = 1, cascade_set%n_in
if (i > 1) write (u, "(A)", advance="no") "\quad "
write (u, "(A)", advance="no") &
char (cascade_set%flv(i,f)%get_tex_name ())
end do
write (u, "(A)", advance="no") "\quad &\to\quad "
do i = cascade_set%n_in + 1, cascade_set%n_tot
if (i > cascade_set%n_in + 1) write (u, "(A)", advance="no") "\quad "
write (u, "(A)", advance="no") &
char (cascade_set%flv(i,f)%get_tex_name ())
end do
if (f < size (cascade_set%flv, 2)) then
write (u, "(A)") "\\"
else
write (u, "(A)") ""
end if
end do
write (u, "(A)") "\end{align*}"
end subroutine cascade_set_write_process_tex_format
@ %def cascade_set_write_process_tex_format
@ Three output routines: phase-space file, graph source code, and
screen output.
This version generates the phase space file. It deals only with
complete cascades.
<<Cascades: public>>=
public :: cascade_set_write_file_format
<<Cascades: sub interfaces>>=
module subroutine cascade_set_write_file_format (cascade_set, unit)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: unit
end subroutine cascade_set_write_file_format
<<Cascades: procedures>>=
module subroutine cascade_set_write_file_format (cascade_set, unit)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: unit
type(cascade_t), pointer :: cascade
integer :: u, grove, count
logical :: first_in_grove
u = given_output_unit (unit); if (u < 0) return
count = 0
do grove = 1, cascade_set%n_groves
first_in_grove = .true.
cascade => cascade_set%first_k
do while (associated (cascade))
if (cascade%active .and. cascade%complete) then
if (cascade%grove == grove) then
if (first_in_grove) then
first_in_grove = .false.
write (u, "(A)")
write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') &
'Multiplicity =', cascade%multiplicity, ","
select case (cascade%n_resonances)
case (0)
write (u, '(1x,A)', advance='no') 'no resonances, '
case (1)
write (u, '(1x,A)', advance='no') '1 resonance, '
case default
write (u, '(1x,I0,1x,A)', advance='no') &
cascade%n_resonances, 'resonances, '
end select
write (u, '(1x,I0,1x,A)', advance='no') &
cascade%n_log_enhanced, 'logs, '
write (u, '(1x,I0,1x,A)', advance='no') &
cascade%n_off_shell, 'off-shell, '
select case (cascade%n_t_channel)
case (0); write (u, '(1x,A)') 's-channel graph'
case (1); write (u, '(1x,A)') '1 t-channel line'
case default
write(u,'(1x,I0,1x,A)') &
cascade%n_t_channel, 't-channel lines'
end select
write (u, '(1x,A,I0)') 'grove #', grove
end if
count = count + 1
write (u, "(1x,'!',1x,A,I0)") "Channel #", count
call cascade_write_file_format (cascade, cascade_set%model, u)
end if
end if
cascade => cascade%next
end do
end do
end subroutine cascade_set_write_file_format
@ %def cascade_set_write_file_format
@ This is the graph output format, the driver-file
<<Cascades: public>>=
public :: cascade_set_write_graph_format
<<Cascades: sub interfaces>>=
module subroutine cascade_set_write_graph_format &
(cascade_set, filename, process_id, unit)
type(cascade_set_t), intent(in), target :: cascade_set
type(string_t), intent(in) :: filename, process_id
integer, intent(in), optional :: unit
end subroutine cascade_set_write_graph_format
<<Cascades: procedures>>=
module subroutine cascade_set_write_graph_format &
(cascade_set, filename, process_id, unit)
type(cascade_set_t), intent(in), target :: cascade_set
type(string_t), intent(in) :: filename, process_id
integer, intent(in), optional :: unit
type(cascade_t), pointer :: cascade
integer :: u, grove, count, pgcount
logical :: first_in_grove
u = given_output_unit (unit); if (u < 0) return
write (u, '(A)') "\documentclass[10pt]{article}"
write (u, '(A)') "\usepackage{amsmath}"
write (u, '(A)') "\usepackage{feynmp}"
write (u, '(A)') "\usepackage{url}"
write (u, '(A)') "\usepackage{color}"
write (u, *)
write (u, '(A)') "\textwidth 18.5cm"
write (u, '(A)') "\evensidemargin -1.5cm"
write (u, '(A)') "\oddsidemargin -1.5cm"
write (u, *)
write (u, '(A)') "\newcommand{\blue}{\color{blue}}"
write (u, '(A)') "\newcommand{\green}{\color{green}}"
write (u, '(A)') "\newcommand{\red}{\color{red}}"
write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}"
write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}"
write (u, '(A)') "\newcommand{\sm}{\footnotesize}"
write (u, '(A)') "\setlength{\parindent}{0pt}"
write (u, '(A)') "\setlength{\parsep}{20pt}"
write (u, *)
write (u, '(A)') "\begin{document}"
write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}"
write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}"
write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}"
write (u, '(A)') "\begin{fmfshrink}{0.5}"
write (u, '(A)') "\begin{flushleft}"
write (u, *)
write (u, '(A)') "\noindent" // &
& "\textbf{\large\texttt{WHIZARD} phase space channels}" // &
& "\hfill\today"
write (u, *)
write (u, '(A)') "\vspace{10pt}"
write (u, '(A)') "\noindent" // &
& "\textbf{Process:} \url{" // char (process_id) // "}"
call cascade_set_write_process_tex_format (cascade_set, u)
write (u, *)
write (u, '(A)') "\noindent" // &
& "\textbf{Note:} These are pseudo Feynman graphs that "
write (u, '(A)') "visualize phase-space parameterizations " // &
& "(``integration channels''). "
write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // &
& "matrix element."
write (u, *)
write (u, '(A)') "\textbf{Color code:} " // &
& "{\blue resonance,} " // &
& "{\cyan t-channel,} " // &
& "{\green radiation,} "
write (u, '(A)') "{\red infrared,} " // &
& "{\magenta collinear,} " // &
& "external/off-shell"
write (u, *)
write (u, '(A)') "\noindent" // &
& "\textbf{Black square:} Keystone, indicates ordering of " // &
& "phase space parameters."
write (u, *)
write (u, '(A)') "\vspace{-20pt}"
count = 0
pgcount = 0
do grove = 1, cascade_set%n_groves
first_in_grove = .true.
cascade => cascade_set%first
do while (associated (cascade))
if (cascade%active .and. cascade%complete) then
if (cascade%grove == grove) then
if (first_in_grove) then
first_in_grove = .false.
write (u, *)
write (u, '(A)') "\vspace{20pt}"
write (u, '(A)') "\begin{tabular}{l}"
write (u, '(A,I5,A)') &
& "\fbox{\bf Grove \boldmath$", grove, "$} \\[10pt]"
write (u, '(A,I1,A)') "Multiplicity: ", &
cascade%multiplicity, "\\"
write (u, '(A,I1,A)') "Resonances: ", &
cascade%n_resonances, "\\"
write (u, '(A,I1,A)') "Log-enhanced: ", &
cascade%n_log_enhanced, "\\"
write (u, '(A,I1,A)') "Off-shell: ", &
cascade%n_off_shell, "\\"
write (u, '(A,I1,A)') "t-channel: ", &
cascade%n_t_channel, ""
write (u, '(A)') "\end{tabular}"
end if
count = count + 1
call cascade_write_graph_format (cascade, count, unit)
if (pgcount >= 250) then
write (u, '(A)') "\clearpage"
pgcount = 0
end if
end if
end if
cascade => cascade%next
end do
end do
write (u, '(A)') "\end{flushleft}"
write (u, '(A)') "\end{fmfshrink}"
write (u, '(A)') "\end{fmffile}"
write (u, '(A)') "\end{document}"
end subroutine cascade_set_write_graph_format
@ %def cascade_set_write_graph_format
@ This is for screen output and debugging:
<<Cascades: public>>=
public :: cascade_set_write
<<Cascades: sub interfaces>>=
module subroutine cascade_set_write &
(cascade_set, unit, active_only, complete_only)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: unit
logical, intent(in), optional :: active_only, complete_only
end subroutine cascade_set_write
<<Cascades: procedures>>=
module subroutine cascade_set_write &
(cascade_set, unit, active_only, complete_only)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: unit
logical, intent(in), optional :: active_only, complete_only
logical :: active, complete
type(cascade_t), pointer :: cascade
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
active = .true.; if (present (active_only)) active = active_only
complete = .false.; if (present (complete_only)) complete = complete_only
write (u, "(A)") "Cascade set:"
write (u, "(3x,A)", advance="no") "Model:"
if (associated (cascade_set%model)) then
write (u, "(1x,A)") char (cascade_set%model%get_name ())
else
write (u, "(1x,A)") "[none]"
end if
write (u, "(3x,A)", advance="no") "n_in/out/tot ="
write (u, "(3(1x,I7))") &
cascade_set%n_in, cascade_set%n_out, cascade_set%n_tot
write (u, "(3x,A)", advance="no") "depth_out/tot ="
write (u, "(2(1x,I7))") cascade_set%depth_out, cascade_set%depth_tot
write (u, "(3x,A)", advance="no") "mass thr(s/t) ="
write (u, "(2(1x," // FMT_19 // "))") &
cascade_set%m_threshold_s, cascade_set%m_threshold_t
write (u, "(3x,A)", advance="no") "off shell ="
write (u, "(1x,I7)") cascade_set%off_shell
write (u, "(3x,A)", advance="no") "keep_nonreson ="
write (u, "(1x,L1)") cascade_set%keep_nonresonant
write (u, "(3x,A)", advance="no") "n_groves ="
write (u, "(1x,I7)") cascade_set%n_groves
write (u, "(A)")
write (u, "(A)") "Cascade list:"
if (associated (cascade_set%first)) then
cascade => cascade_set%first
do while (associated (cascade))
if (active .and. .not. cascade%active) cycle
if (complete .and. .not. cascade%complete) cycle
call cascade_write (cascade, unit)
cascade => cascade%next
end do
else
write (u, "(A)") "[empty]"
end if
write (u, "(A)") "Hash array"
write (u, "(3x,A)", advance="no") "n_entries ="
write (u, "(1x,I7)") cascade_set%n_entries
write (u, "(3x,A)", advance="no") "fill_ratio ="
write (u, "(1x," // FMT_12 // ")") cascade_set%fill_ratio
write (u, "(3x,A)", advance="no") "n_entries_max ="
write (u, "(1x,I7)") cascade_set%n_entries_max
write (u, "(3x,A)", advance="no") "mask ="
write (u, "(1x,I0)") cascade_set%mask
do i = 0, ubound (cascade_set%entry, 1)
if (allocated (cascade_set%entry(i)%key)) then
write (u, "(1x,I7)") i
call hash_entry_write (cascade_set%entry(i), u)
end if
end do
end subroutine cascade_set_write
@ %def cascade_set_write
@
\subsection{Adding cascades}
Add a deep copy of a cascade to the set. The copy has all content of the
original, but the pointers are nullified. We do not care whether insertion
was successful or not. The pointer argument, if present, is assigned to the
input cascade, or to the hash entry if it is already present.
The procedure is recursive: any daughter or mother entries are also
deep-copied and added to the cascade set before the current copy is added.
<<Cascades: procedures>>=
recursive subroutine cascade_set_add_copy &
(cascade_set, cascade_in, cascade_ptr)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in) :: cascade_in
type(cascade_t), optional, pointer :: cascade_ptr
type(cascade_t), pointer :: cascade
logical :: ok
allocate (cascade)
cascade = cascade_in
if (associated (cascade_in%daughter1)) call cascade_set_add_copy &
(cascade_set, cascade_in%daughter1, cascade%daughter1)
if (associated (cascade_in%daughter2)) call cascade_set_add_copy &
(cascade_set, cascade_in%daughter2, cascade%daughter2)
if (associated (cascade_in%mother)) call cascade_set_add_copy &
(cascade_set, cascade_in%mother, cascade%mother)
cascade%next => null ()
call cascade_set_add (cascade_set, cascade, ok, cascade_ptr)
if (.not. ok) deallocate (cascade)
end subroutine cascade_set_add_copy
@ %def cascade_set_add_copy
@ Add a cascade to the set. This does not deep-copy. We first try to insert
it in the hash array. If successful, add it to the list. Failure indicates
that it is already present, and we drop it.
The hash key is built solely from the tree array, so neither particle
codes nor resonances count, just topology.
Technically, hash and list receive only pointers, so the cascade can
be considered as being in either of both. We treat it as part of the
list.
<<Cascades: procedures>>=
subroutine cascade_set_add (cascade_set, cascade, ok, cascade_ptr)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in), target :: cascade
logical, intent(out) :: ok
type(cascade_t), optional, pointer :: cascade_ptr
integer(i8), dimension(1) :: mold
call cascade_set_hash_insert &
(cascade_set, transfer (cascade%tree, mold), cascade, ok, cascade_ptr)
if (ok) call cascade_set_list_add (cascade_set, cascade)
end subroutine cascade_set_add
@ %def cascade_set_add
@ Add a new cascade to the list:
<<Cascades: procedures>>=
subroutine cascade_set_list_add (cascade_set, cascade)
type(cascade_set_t), intent(inout) :: cascade_set
type(cascade_t), intent(in), target :: cascade
if (associated (cascade_set%last)) then
cascade_set%last%next => cascade
else
cascade_set%first => cascade
end if
cascade_set%last => cascade
end subroutine cascade_set_list_add
@ %def cascade_set_list_add
@ Add a cascade entry to the hash array:
<<Cascades: procedures>>=
subroutine cascade_set_hash_insert &
(cascade_set, key, cascade, ok, cascade_ptr)
type(cascade_set_t), intent(inout), target :: cascade_set
integer(i8), dimension(:), intent(in) :: key
type(cascade_t), intent(in), target :: cascade
logical, intent(out) :: ok
type(cascade_t), optional, pointer :: cascade_ptr
integer(i32) :: h
if (cascade_set%n_entries >= cascade_set%n_entries_max) &
call cascade_set_hash_expand (cascade_set)
h = hash (key)
call cascade_set_hash_insert_rec &
(cascade_set, h, h, key, cascade, ok, cascade_ptr)
end subroutine cascade_set_hash_insert
@ %def cascade_set_hash_insert
@ Double the hashtable size when necesssary:
<<Cascades: procedures>>=
subroutine cascade_set_hash_expand (cascade_set)
type(cascade_set_t), intent(inout), target :: cascade_set
type(hash_entry_t), dimension(:), allocatable, target :: table_tmp
type(cascade_p), pointer :: current
integer :: i, s
allocate (table_tmp (0:cascade_set%mask))
table_tmp = cascade_set%entry
deallocate (cascade_set%entry)
s = 2 * size (table_tmp)
cascade_set%n_entries = 0
cascade_set%n_entries_max = s * cascade_set%fill_ratio
cascade_set%mask = s - 1
allocate (cascade_set%entry (0:cascade_set%mask))
do i = 0, ubound (table_tmp, 1)
current => table_tmp(i)%first
do while (associated (current))
call cascade_set_hash_insert_rec &
(cascade_set, table_tmp(i)%hashval, table_tmp(i)%hashval, &
table_tmp(i)%key, current%cascade)
current => current%next
end do
end do
end subroutine cascade_set_hash_expand
@ %def cascade_set_hash_expand
@ Insert the cascade at the bucket determined by the hash value. If
the bucket is filled, check first for a collision (unequal keys). In
that case, choose the following bucket and repeat. Otherwise, add the
cascade to the bucket.
If the bucket is empty, record the hash value, allocate and store the
key, and then add the cascade to the bucket.
If [[ok]] is present, before insertion we check whether the cascade is
already stored, and return failure if yes.
<<Cascades: procedures>>=
recursive subroutine cascade_set_hash_insert_rec &
(cascade_set, h, hashval, key, cascade, ok, cascade_ptr)
type(cascade_set_t), intent(inout) :: cascade_set
integer(i32), intent(in) :: h, hashval
integer(i8), dimension(:), intent(in) :: key
type(cascade_t), intent(in), target :: cascade
logical, intent(out), optional :: ok
type(cascade_t), optional, pointer :: cascade_ptr
integer(i32) :: i
i = iand (h, cascade_set%mask)
if (allocated (cascade_set%entry(i)%key)) then
if (size (cascade_set%entry(i)%key) /= size (key)) then
call cascade_set_hash_insert_rec &
(cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr)
else if (any (cascade_set%entry(i)%key /= key)) then
call cascade_set_hash_insert_rec &
(cascade_set, h + 1, hashval, key, cascade, ok, cascade_ptr)
else
call hash_entry_add_cascade_ptr &
(cascade_set%entry(i), cascade, ok, cascade_ptr)
end if
else
cascade_set%entry(i)%hashval = hashval
allocate (cascade_set%entry(i)%key (size (key)))
cascade_set%entry(i)%key = key
call hash_entry_add_cascade_ptr &
(cascade_set%entry(i), cascade, ok, cascade_ptr)
cascade_set%n_entries = cascade_set%n_entries + 1
end if
end subroutine cascade_set_hash_insert_rec
@ %def cascade_set_hash_insert_rec
@
\subsection{External particles}
We want to initialize the cascade set with the outgoing particles. In
case of multiple processes, initial cascades are prepared for all of
them. The hash array check ensures that no particle appears more than
once at the same place.
<<Cascades: interfaces>>=
interface cascade_set_add_outgoing
module procedure cascade_set_add_outgoing1
module procedure cascade_set_add_outgoing2
end interface
<<Cascades: sub interfaces>>=
module subroutine cascade_set_add_outgoing1 (cascade_set, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
type(flavor_t), dimension(:), intent(in) :: flv
end subroutine cascade_set_add_outgoing1
module subroutine cascade_set_add_outgoing2 (cascade_set, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
type(flavor_t), dimension(:,:), intent(in) :: flv
end subroutine cascade_set_add_outgoing2
<<Cascades: procedures>>=
module subroutine cascade_set_add_outgoing2 (cascade_set, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
type(flavor_t), dimension(:,:), intent(in) :: flv
integer :: pos, prc, n_out, n_prc
type(cascade_t), pointer :: cascade
logical :: ok
n_out = size (flv, dim=1)
n_prc = size (flv, dim=2)
do prc = 1, n_prc
do pos = 1, n_out
allocate (cascade)
call cascade_init_outgoing &
(cascade, flv(pos,prc), pos, cascade_set%m_threshold_s)
call cascade_set_add (cascade_set, cascade, ok)
if (.not. ok) then
deallocate (cascade)
end if
end do
end do
end subroutine cascade_set_add_outgoing2
module subroutine cascade_set_add_outgoing1 (cascade_set, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
type(flavor_t), dimension(:), intent(in) :: flv
integer :: pos, n_out
type(cascade_t), pointer :: cascade
logical :: ok
n_out = size (flv, dim=1)
do pos = 1, n_out
allocate (cascade)
call cascade_init_outgoing &
(cascade, flv(pos), pos, cascade_set%m_threshold_s)
call cascade_set_add (cascade_set, cascade, ok)
if (.not. ok) then
deallocate (cascade)
end if
end do
end subroutine cascade_set_add_outgoing1
@ %def cascade_set_add_outgoing
@ The incoming particles are added one at a time. Nevertheless, we
may have several processes which are looped over. At the first
opportunity, we set the pointer [[first_t]] in the cascade set which
should point to the first t-channel cascade.
Return the indices of the first and last cascade generated.
<<Cascades: interfaces>>=
interface cascade_set_add_incoming
module procedure cascade_set_add_incoming0
module procedure cascade_set_add_incoming1
end interface
<<Cascades: sub interfaces>>=
module subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
integer, intent(out) :: n1, n2
integer, intent(in) :: pos
type(flavor_t), dimension(:), intent(in) :: flv
end subroutine cascade_set_add_incoming1
module subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
integer, intent(out) :: n1, n2
integer, intent(in) :: pos
type(flavor_t), intent(in) :: flv
end subroutine cascade_set_add_incoming0
<<Cascades: procedures>>=
module subroutine cascade_set_add_incoming1 (cascade_set, n1, n2, pos, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
integer, intent(out) :: n1, n2
integer, intent(in) :: pos
type(flavor_t), dimension(:), intent(in) :: flv
integer :: prc, n_prc
type(cascade_t), pointer :: cascade
logical :: ok
n1 = 0
n2 = 0
n_prc = size (flv)
do prc = 1, n_prc
allocate (cascade)
call cascade_init_incoming &
(cascade, flv(prc), pos, cascade_set%m_threshold_t)
call cascade_set_add (cascade_set, cascade, ok)
if (ok) then
if (n1 == 0) n1 = cascade%index
n2 = cascade%index
if (.not. associated (cascade_set%first_t)) then
cascade_set%first_t => cascade
end if
else
deallocate (cascade)
end if
end do
end subroutine cascade_set_add_incoming1
module subroutine cascade_set_add_incoming0 (cascade_set, n1, n2, pos, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
integer, intent(out) :: n1, n2
integer, intent(in) :: pos
type(flavor_t), intent(in) :: flv
type(cascade_t), pointer :: cascade
logical :: ok
n1 = 0
n2 = 0
allocate (cascade)
call cascade_init_incoming &
(cascade, flv, pos, cascade_set%m_threshold_t)
call cascade_set_add (cascade_set, cascade, ok)
if (ok) then
if (n1 == 0) n1 = cascade%index
n2 = cascade%index
if (.not. associated (cascade_set%first_t)) then
cascade_set%first_t => cascade
end if
else
deallocate (cascade)
end if
end subroutine cascade_set_add_incoming0
@ %def cascade_set_add_incoming
@
\subsection{Cascade combination I: flavor assignment}
We have two disjunct cascades, now use the vertex table to determine
the possible flavors of the combination cascade. For each
possibility, try to generate a new cascade. The total cascade depth
has to be one less than the limit, because this is reached by setting
the keystone.
<<Cascades: procedures>>=
subroutine cascade_match_pair (cascade_set, cascade1, cascade2, s_channel)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in), target :: cascade1, cascade2
logical, intent(in) :: s_channel
integer, dimension(:), allocatable :: pdg3
integer :: i, depth_max
type(flavor_t) :: flv
if (s_channel) then
depth_max = cascade_set%depth_out
else
depth_max = cascade_set%depth_tot
end if
if (cascade1%depth + cascade2%depth < depth_max) then
call cascade_set%model%match_vertex ( &
cascade1%flv%get_pdg (), &
cascade2%flv%get_pdg (), &
pdg3)
do i = 1, size (pdg3)
call flv%init (pdg3(i), cascade_set%model)
if (s_channel) then
call cascade_combine_s (cascade_set, cascade1, cascade2, flv)
else
call cascade_combine_t (cascade_set, cascade1, cascade2, flv)
end if
end do
deallocate (pdg3)
end if
end subroutine cascade_match_pair
@ %def cascade_match_pair
@ The triplet version takes a third cascade, and we check whether this
triplet has a matching vertex in the database. If yes, we make a
keystone cascade.
<<Cascades: procedures>>=
subroutine cascade_match_triplet &
(cascade_set, cascade1, cascade2, cascade3, s_channel)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
logical, intent(in) :: s_channel
integer :: depth_max
depth_max = cascade_set%depth_tot
if (cascade1%depth + cascade2%depth + cascade3%depth == depth_max) then
if (cascade_set%model%check_vertex ( &
cascade1%flv%get_pdg (), &
cascade2%flv%get_pdg (), &
cascade3%flv%get_pdg ())) then
call cascade_combine_keystone &
(cascade_set, cascade1, cascade2, cascade3, s_channel)
end if
end if
end subroutine cascade_match_triplet
@ %def cascade_match_triplet
@
\subsection{Cascade combination II: kinematics setup and check}
Having three matching flavors, we start constructing the combination
cascade. We look at the mass hierarchies and determine whether the
cascade is to be kept. In passing we set mapping modes, resonance
properties and such.
If successful, the cascade is finalized. For a resonant cascade, we
prepare in addition a copy without the resonance.
<<Cascades: procedures>>=
subroutine cascade_combine_s (cascade_set, cascade1, cascade2, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in), target :: cascade1, cascade2
type(flavor_t), intent(in) :: flv
type(cascade_t), pointer :: cascade3, cascade4
real(default) :: width
logical :: keep
keep = .false.
allocate (cascade3)
call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1)
cascade3%bincode = ior (cascade1%bincode, cascade2%bincode)
cascade3%flv = flv%anti ()
cascade3%pdg = cascade3%flv%get_pdg ()
cascade3%is_vector = flv%get_spin_type () == VECTOR
cascade3%m_min = cascade1%m_min + cascade2%m_min
cascade3%m_rea = flv%get_mass ()
width = flv%get_width ()
if (cascade3%m_rea > cascade_set%m_threshold_s) then
cascade3%m_eff = cascade3%m_rea
end if
! Potentially resonant cases [sqrts = m_rea for on-shell decay]
if (cascade3%m_rea > cascade3%m_min .and. &
cascade3%m_rea <= cascade_set%sqrts) then
if (width /= 0) then
if (cascade1%on_shell .or. cascade2%on_shell) then
keep = .true.
cascade3%mapping = S_CHANNEL
cascade3%resonant = .true.
end if
else
call warn_decay (flv)
end if
! Collinear and IR singular cases
else if (cascade3%m_rea < cascade_set%sqrts) then
! Massless splitting
if (cascade1%m_eff == 0 .and. cascade2%m_eff == 0 &
.and. cascade3%depth <= 3) then
keep = .true.
cascade3%log_enhanced = .true.
if (cascade3%is_vector) then
if (cascade1%is_vector .and. cascade2%is_vector) then
cascade3%mapping = COLLINEAR ! three-vector-vertex
else
cascade3%mapping = INFRARED ! vector splitting into matter
end if
else
if (cascade1%is_vector .or. cascade2%is_vector) then
cascade3%mapping = COLLINEAR ! vector radiation off matter
else
cascade3%mapping = INFRARED ! scalar radiation/splitting
end if
end if
! IR radiation off massive particle
else if (cascade3%m_eff > 0 .and. cascade1%m_eff > 0 &
.and. cascade2%m_eff == 0 &
.and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) &
.and. abs (cascade3%m_eff - cascade1%m_eff) &
< cascade_set%m_threshold_s) &
then
keep = .true.
cascade3%log_enhanced = .true.
cascade3%mapping = RADIATION
else if (cascade3%m_eff > 0 .and. cascade2%m_eff > 0 &
.and. cascade1%m_eff == 0 &
.and. (cascade2%on_shell .or. cascade2%mapping == RADIATION) &
.and. abs (cascade3%m_eff - cascade2%m_eff) &
< cascade_set%m_threshold_s) &
then
keep = .true.
cascade3%log_enhanced = .true.
cascade3%mapping = RADIATION
end if
end if
! Non-singular cases, including failed resonances
if (.not. keep) then
! Two on-shell particles from a virtual mother
if (cascade1%on_shell .or. cascade2%on_shell) then
keep = .true.
cascade3%m_eff = max (cascade3%m_min, &
cascade1%m_eff + cascade2%m_eff)
if (cascade3%m_eff < cascade_set%m_threshold_s) then
cascade3%m_eff = 0
end if
end if
end if
! Complete and register the cascade (two in case of resonance)
if (keep) then
cascade3%on_shell = cascade3%resonant .or. cascade3%log_enhanced
if (cascade3%resonant) then
cascade3%pdg = cascade3%flv%get_pdg ()
if (cascade_set%keep_nonresonant) then
allocate (cascade4)
cascade4 = cascade3
cascade4%index = cascade_index ()
cascade4%pdg = UNDEFINED
cascade4%mapping = NO_MAPPING
cascade4%resonant = .false.
cascade4%on_shell = .false.
end if
cascade3%m_min = cascade3%m_rea
call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
if (cascade_set%keep_nonresonant) then
call cascade_fusion (cascade_set, cascade1, cascade2, cascade4)
end if
else
call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
end if
else
deallocate (cascade3)
end if
contains
subroutine warn_decay (flv)
type(flavor_t), intent(in) :: flv
integer :: i
integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0
LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE
if (warned_code(i) == 0) then
warned_code(i) = flv%get_pdg ()
write (msg_buffer, "(A)") &
& " Intermediate decay of zero-width particle " &
& // char (flv%get_name ()) &
& // " may be possible."
call msg_warning
exit LOOP_WARNED
else if (warned_code(i) == flv%get_pdg ()) then
exit LOOP_WARNED
end if
end do LOOP_WARNED
end subroutine warn_decay
end subroutine cascade_combine_s
@ %def cascade_combine_s
<<Cascades: parameters>>=
integer, parameter, public :: MAX_WARN_RESONANCE = 50
@ %def MAX_WARN_RESONANCE
@ This is the t-channel version. [[cascade1]] is t-channel and
contains the seed, [[cascade2]] is s-channel. We check for
kinematically allowed beam decay (which is a fatal error), or massless
splitting / soft radiation. The cascade is kept in all remaining
cases and submitted for registration.
<<Cascades: procedures>>=
subroutine cascade_combine_t (cascade_set, cascade1, cascade2, flv)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in), target :: cascade1, cascade2
type(flavor_t), intent(in) :: flv
type(cascade_t), pointer :: cascade3
allocate (cascade3)
call cascade_init (cascade3, cascade1%depth + cascade2%depth + 1)
cascade3%bincode = ior (cascade1%bincode, cascade2%bincode)
cascade3%flv = flv%anti ()
cascade3%pdg = abs (cascade3%flv%get_pdg ())
cascade3%is_vector = flv%get_spin_type () == VECTOR
if (cascade1%incoming) then
cascade3%m_min = cascade2%m_min
else
cascade3%m_min = cascade1%m_min + cascade2%m_min
end if
cascade3%m_rea = flv%get_mass ()
if (cascade3%m_rea > cascade_set%m_threshold_t) then
cascade3%m_eff = max (cascade3%m_rea, cascade2%m_eff)
else if (cascade2%m_eff > cascade_set%m_threshold_t) then
cascade3%m_eff = cascade2%m_eff
else
cascade3%m_eff = 0
end if
! Allowed decay of beam particle
if (cascade1%incoming &
.and. cascade1%m_rea > cascade2%m_rea + cascade3%m_rea) then
call beam_decay (cascade_set%fatal_beam_decay)
! Massless splitting
else if (cascade1%m_eff == 0 &
.and. cascade2%m_eff < cascade_set%m_threshold_t &
.and. cascade3%m_eff == 0) then
cascade3%mapping = U_CHANNEL
cascade3%log_enhanced = .true.
! IR radiation off massive particle
else if (cascade1%m_eff /= 0 .and. cascade2%m_eff == 0 &
.and. cascade3%m_eff /= 0 &
.and. (cascade1%on_shell .or. cascade1%mapping == RADIATION) &
.and. abs (cascade1%m_eff - cascade3%m_eff) &
< cascade_set%m_threshold_t) &
then
cascade3%pdg = flv%get_pdg ()
cascade3%log_enhanced = .true.
cascade3%mapping = RADIATION
end if
cascade3%t_channel = .true.
call cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
contains
subroutine beam_decay (fatal_beam_decay)
logical, intent(in) :: fatal_beam_decay
write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") &
char (cascade1%flv%get_name ()), &
char (cascade3%flv%get_name ()), &
char (cascade2%flv%get_name ())
call msg_message
write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
char (cascade1%flv%get_name ()), cascade1%m_rea
call msg_message
write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
char (cascade3%flv%get_name ()), cascade3%m_rea
call msg_message
write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
char (cascade2%flv%get_name ()), cascade2%m_rea
call msg_message
if (fatal_beam_decay) then
call msg_fatal (" Phase space: Initial beam particle can decay")
else
call msg_warning (" Phase space: Initial beam particle can decay")
end if
end subroutine beam_decay
end subroutine cascade_combine_t
@ %def cascade_combine_t
@ Here we complete a decay cascade. The third input is the
single-particle cascade for the initial particle. There is no
resonance or mapping assignment. The only condition for keeping the
cascade is the mass sum of the final state, which must be less than
the available energy.
Two modifications are necessary for scattering cascades: a pure
s-channel diagram (cascade1 is the incoming particle) do not have a
logarithmic mapping at top-level. And in a t-channel diagram, the
last line exchanged is mapped t-channel, not u-channel. Finally, we
can encounter the case of a $2\to 1$ process, where cascade1 is
incoming, and cascade2 is the outgoing particle. In all three cases
we register a new cascade with the modified mapping.
<<Cascades: procedures>>=
subroutine cascade_combine_keystone &
(cascade_set, cascade1, cascade2, cascade3, s_channel)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
logical, intent(in) :: s_channel
type(cascade_t), pointer :: cascade4, cascade0
logical :: keep, ok
keep = .false.
allocate (cascade4)
call cascade_init &
(cascade4, cascade1%depth + cascade2%depth + cascade3%depth)
cascade4%complete = .true.
if (s_channel) then
cascade4%bincode = ior (cascade1%bincode, cascade2%bincode)
else
cascade4%bincode = cascade3%bincode
end if
cascade4%flv = cascade3%flv
cascade4%pdg = cascade3%pdg
cascade4%mapping = EXTERNAL_PRT
cascade4%is_vector = cascade3%is_vector
cascade4%m_min = cascade1%m_min + cascade2%m_min
cascade4%m_rea = cascade3%m_rea
cascade4%m_eff = cascade3%m_rea
if (cascade4%m_min < cascade_set%sqrts) then
keep = .true.
end if
if (keep) then
if (cascade1%incoming .and. cascade2%log_enhanced) then
allocate (cascade0)
cascade0 = cascade2
cascade0%next => null ()
cascade0%index = cascade_index ()
cascade0%mapping = NO_MAPPING
cascade0%log_enhanced = .false.
cascade0%n_log_enhanced = cascade0%n_log_enhanced - 1
cascade0%tree_mapping(cascade0%depth) = NO_MAPPING
call cascade_keystone &
(cascade_set, cascade1, cascade0, cascade3, cascade4, ok)
if (ok) then
call cascade_set_add (cascade_set, cascade0, ok)
else
deallocate (cascade0)
end if
else if (cascade1%t_channel .and. cascade1%mapping == U_CHANNEL) then
allocate (cascade0)
cascade0 = cascade1
cascade0%next => null ()
cascade0%index = cascade_index ()
cascade0%mapping = T_CHANNEL
cascade0%tree_mapping(cascade0%depth) = T_CHANNEL
call cascade_keystone &
(cascade_set, cascade0, cascade2, cascade3, cascade4, ok)
if (ok) then
call cascade_set_add (cascade_set, cascade0, ok)
else
deallocate (cascade0)
end if
else if (cascade1%incoming .and. cascade2%depth == 1) then
allocate (cascade0)
cascade0 = cascade2
cascade0%next => null ()
cascade0%index = cascade_index ()
cascade0%mapping = ON_SHELL
cascade0%tree_mapping(cascade0%depth) = ON_SHELL
call cascade_keystone &
(cascade_set, cascade1, cascade0, cascade3, cascade4, ok)
if (ok) then
call cascade_set_add (cascade_set, cascade0, ok)
else
deallocate (cascade0)
end if
else
call cascade_keystone &
(cascade_set, cascade1, cascade2, cascade3, cascade4, ok)
end if
else
deallocate (cascade4)
end if
end subroutine cascade_combine_keystone
@ %def cascade_combine_keystone
@
\subsection{Cascade combination III: node connections and tree fusion}
Here we assign global tree properties. If the allowed number of
off-shell lines is exceeded, discard the new cascade. Otherwise,
assign the trees, sort them, and assign connections. Finally, append
the cascade to the list. This may fail (because in the hash array
there is already an equivalent cascade). On failure, discard the
cascade.
<<Cascades: procedures>>=
subroutine cascade_fusion (cascade_set, cascade1, cascade2, cascade3)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in), target :: cascade1, cascade2
type(cascade_t), pointer :: cascade3
integer :: i1, i2, i3, i4
logical :: ok
cascade3%internal = (cascade3%depth - 3) / 2
if (cascade3%resonant) then
cascade3%multiplicity = 1
cascade3%n_resonances = &
cascade1%n_resonances + cascade2%n_resonances + 1
else
cascade3%multiplicity = cascade1%multiplicity + cascade2%multiplicity
cascade3%n_resonances = cascade1%n_resonances + cascade2%n_resonances
end if
if (cascade3%log_enhanced) then
cascade3%n_log_enhanced = &
cascade1%n_log_enhanced + cascade2%n_log_enhanced + 1
else
cascade3%n_log_enhanced = &
cascade1%n_log_enhanced + cascade2%n_log_enhanced
end if
if (cascade3%resonant) then
cascade3%n_off_shell = 0
else if (cascade3%log_enhanced) then
cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell
else
cascade3%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell + 1
end if
if (cascade3%t_channel) then
cascade3%n_t_channel = cascade1%n_t_channel + 1
end if
if (cascade3%n_off_shell > cascade_set%off_shell) then
deallocate (cascade3)
else if (cascade3%n_t_channel > cascade_set%t_channel) then
deallocate (cascade3)
else
i1 = cascade1%depth
i2 = i1 + 1
i3 = i1 + cascade2%depth
i4 = cascade3%depth
cascade3%tree(:i1) = cascade1%tree
where (cascade1%tree_mapping > NO_MAPPING)
cascade3%tree_pdg(:i1) = cascade1%tree_pdg
elsewhere
cascade3%tree_pdg(:i1) = UNDEFINED
end where
cascade3%tree_mapping(:i1) = cascade1%tree_mapping
cascade3%tree_resonant(:i1) = cascade1%tree_resonant
cascade3%tree(i2:i3) = cascade2%tree
where (cascade2%tree_mapping > NO_MAPPING)
cascade3%tree_pdg(i2:i3) = cascade2%tree_pdg
elsewhere
cascade3%tree_pdg(i2:i3) = UNDEFINED
end where
cascade3%tree_mapping(i2:i3) = cascade2%tree_mapping
cascade3%tree_resonant(i2:i3) = cascade2%tree_resonant
cascade3%tree(i4) = cascade3%bincode
cascade3%tree_pdg(i4) = cascade3%pdg
cascade3%tree_mapping(i4) = cascade3%mapping
cascade3%tree_resonant(i4) = cascade3%resonant
call tree_sort (cascade3%tree, &
cascade3%tree_pdg, cascade3%tree_mapping, cascade3%tree_resonant)
cascade3%has_children = .true.
cascade3%daughter1 => cascade1
cascade3%daughter2 => cascade2
call cascade_set_add (cascade_set, cascade3, ok)
if (.not. ok) deallocate (cascade3)
end if
end subroutine cascade_fusion
@ %def cascade_fusion
@ Here we combine a cascade pair with an incoming particle, i.e., we
set a keystone. Otherwise, this is similar. On the first
opportunity, we set the [[first_k]] pointer in the cascade set.
<<Cascades: procedures>>=
subroutine cascade_keystone &
(cascade_set, cascade1, cascade2, cascade3, cascade4, ok)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), intent(in), target :: cascade1, cascade2, cascade3
type(cascade_t), pointer :: cascade4
logical, intent(out) :: ok
integer :: i1, i2, i3, i4
cascade4%internal = (cascade4%depth - 3) / 2
cascade4%multiplicity = cascade1%multiplicity + cascade2%multiplicity
cascade4%n_resonances = cascade1%n_resonances + cascade2%n_resonances
cascade4%n_off_shell = cascade1%n_off_shell + cascade2%n_off_shell
cascade4%n_log_enhanced = &
cascade1%n_log_enhanced + cascade2%n_log_enhanced
cascade4%n_t_channel = cascade1%n_t_channel + cascade2%n_t_channel
if (cascade4%n_off_shell > cascade_set%off_shell) then
deallocate (cascade4)
ok = .false.
else if (cascade4%n_t_channel > cascade_set%t_channel) then
deallocate (cascade4)
ok = .false.
else
i1 = cascade1%depth
i2 = i1 + 1
i3 = i1 + cascade2%depth
i4 = cascade4%depth
cascade4%tree(:i1) = cascade1%tree
where (cascade1%tree_mapping > NO_MAPPING)
cascade4%tree_pdg(:i1) = cascade1%tree_pdg
elsewhere
cascade4%tree_pdg(:i1) = UNDEFINED
end where
cascade4%tree_mapping(:i1) = cascade1%tree_mapping
cascade4%tree_resonant(:i1) = cascade1%tree_resonant
cascade4%tree(i2:i3) = cascade2%tree
where (cascade2%tree_mapping > NO_MAPPING)
cascade4%tree_pdg(i2:i3) = cascade2%tree_pdg
elsewhere
cascade4%tree_pdg(i2:i3) = UNDEFINED
end where
cascade4%tree_mapping(i2:i3) = cascade2%tree_mapping
cascade4%tree_resonant(i2:i3) = cascade2%tree_resonant
cascade4%tree(i4) = cascade4%bincode
cascade4%tree_pdg(i4) = UNDEFINED
cascade4%tree_mapping(i4) = cascade4%mapping
cascade4%tree_resonant(i4) = .false.
call tree_sort (cascade4%tree, &
cascade4%tree_pdg, cascade4%tree_mapping, cascade4%tree_resonant)
cascade4%has_children = .true.
cascade4%daughter1 => cascade1
cascade4%daughter2 => cascade2
cascade4%mother => cascade3
call cascade_set_add (cascade_set, cascade4, ok)
if (ok) then
if (.not. associated (cascade_set%first_k)) then
cascade_set%first_k => cascade4
end if
else
deallocate (cascade4)
end if
end if
end subroutine cascade_keystone
@ %def cascade_keystone
@
Sort a tree (array of binary codes) and particle code array
simultaneously, by ascending binary codes. A convenient method is to
use the [[maxloc]] function iteratively, to find and remove the
largest entry in the tree array one by one.
<<Cascades: procedures>>=
subroutine tree_sort (tree, pdg, mapping, resonant)
integer(TC), dimension(:), intent(inout) :: tree
integer, dimension(:), intent(inout) :: pdg, mapping
logical, dimension(:), intent(inout) :: resonant
integer(TC), dimension(size(tree)) :: tree_tmp
integer, dimension(size(pdg)) :: pdg_tmp, mapping_tmp
logical, dimension(size(resonant)) :: resonant_tmp
integer, dimension(1) :: pos
integer :: i
tree_tmp = tree
pdg_tmp = pdg
mapping_tmp = mapping
resonant_tmp = resonant
do i = size(tree),1,-1
pos = maxloc (tree_tmp)
tree(i) = tree_tmp (pos(1))
pdg(i) = pdg_tmp (pos(1))
mapping(i) = mapping_tmp (pos(1))
resonant(i) = resonant_tmp (pos(1))
tree_tmp(pos(1)) = 0
end do
end subroutine tree_sort
@ %def tree_sort
@
\subsection{Cascade set generation}
These procedures loop over cascades and build up the cascade set. After each
iteration of the innermost loop, we set a breakpoint.
s-channel: We use a nested scan to combine all cascades with all other
cascades.
<<Cascades: procedures>>=
subroutine cascade_set_generate_s (cascade_set)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), pointer :: cascade1, cascade2
cascade1 => cascade_set%first
LOOP1: do while (associated (cascade1))
cascade2 => cascade_set%first
LOOP2: do while (associated (cascade2))
if (cascade2%index >= cascade1%index) exit LOOP2
if (cascade1 .disjunct. cascade2) then
call cascade_match_pair (cascade_set, cascade1, cascade2, .true.)
end if
call terminate_now_if_signal ()
cascade2 => cascade2%next
end do LOOP2
cascade1 => cascade1%next
end do LOOP1
end subroutine cascade_set_generate_s
@ %def cascade_set_generate_s
@ The t-channel cascades are directed and have a seed (one of the
incoming particles) and a target (the other one). We loop over all
possible seeds and targets. Inside this, we loop over all t-channel
cascades ([[cascade1]]) and s-channel cascades ([[cascade2]]) and try
to combine them.
<<Cascades: procedures>>=
subroutine cascade_set_generate_t (cascade_set, pos_seed, pos_target)
type(cascade_set_t), intent(inout), target :: cascade_set
integer, intent(in) :: pos_seed, pos_target
type(cascade_t), pointer :: cascade_seed, cascade_target
type(cascade_t), pointer :: cascade1, cascade2
integer(TC) :: bc_seed, bc_target
bc_seed = ibset (0_TC, pos_seed-1)
bc_target = ibset (0_TC, pos_target-1)
cascade_seed => cascade_set%first_t
LOOP_SEED: do while (associated (cascade_seed))
if (cascade_seed%bincode == bc_seed) then
cascade_target => cascade_set%first_t
LOOP_TARGET: do while (associated (cascade_target))
if (cascade_target%bincode == bc_target) then
cascade1 => cascade_set%first_t
LOOP_T: do while (associated (cascade1))
if ((cascade1 .disjunct. cascade_target) &
.and. .not. (cascade1 .disjunct. cascade_seed)) then
cascade2 => cascade_set%first
LOOP_S: do while (associated (cascade2))
if ((cascade2 .disjunct. cascade_target) &
.and. (cascade2 .disjunct. cascade1)) then
call cascade_match_pair &
(cascade_set, cascade1, cascade2, .false.)
end if
call terminate_now_if_signal ()
cascade2 => cascade2%next
end do LOOP_S
end if
call terminate_now_if_signal ()
cascade1 => cascade1%next
end do LOOP_T
end if
call terminate_now_if_signal ()
cascade_target => cascade_target%next
end do LOOP_TARGET
end if
call terminate_now_if_signal ()
cascade_seed => cascade_seed%next
end do LOOP_SEED
end subroutine cascade_set_generate_t
@ %def cascade_set_generate_t
@ This part completes the phase space for decay processes. It is
similar to s-channel cascade generation, but combines two cascade with
the particular cascade of the incoming particle. This particular
cascade is expected to be pointed at by [[first_t]].
<<Cascades: procedures>>=
subroutine cascade_set_generate_decay (cascade_set)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), pointer :: cascade1, cascade2
type(cascade_t), pointer :: cascade_in
cascade_in => cascade_set%first_t
cascade1 => cascade_set%first
do while (associated (cascade1))
if (cascade1 .disjunct. cascade_in) then
cascade2 => cascade1%next
do while (associated (cascade2))
if ((cascade2 .disjunct. cascade1) &
.and. (cascade2 .disjunct. cascade_in)) then
call cascade_match_triplet (cascade_set, &
cascade1, cascade2, cascade_in, .true.)
end if
call terminate_now_if_signal ()
cascade2 => cascade2%next
end do
end if
call terminate_now_if_signal ()
cascade1 => cascade1%next
end do
end subroutine cascade_set_generate_decay
@ %def cascade_set_generate_decay
@ This part completes the phase space for scattering processes. We
combine a t-channel cascade (containing the seed) with a s-channel
cascade and the target.
<<Cascades: procedures>>=
subroutine cascade_set_generate_scattering &
(cascade_set, ns1, ns2, nt1, nt2, pos_seed, pos_target)
type(cascade_set_t), intent(inout), target :: cascade_set
integer, intent(in) :: pos_seed, pos_target
integer, intent(in) :: ns1, ns2, nt1, nt2
type(cascade_t), pointer :: cascade_seed, cascade_target
type(cascade_t), pointer :: cascade1, cascade2
integer(TC) :: bc_seed, bc_target
bc_seed = ibset (0_TC, pos_seed-1)
bc_target = ibset (0_TC, pos_target-1)
cascade_seed => cascade_set%first_t
LOOP_SEED: do while (associated (cascade_seed))
if (cascade_seed%index < ns1) then
cascade_seed => cascade_seed%next
cycle LOOP_SEED
else if (cascade_seed%index > ns2) then
exit LOOP_SEED
else if (cascade_seed%bincode == bc_seed) then
cascade_target => cascade_set%first_t
LOOP_TARGET: do while (associated (cascade_target))
if (cascade_target%index < nt1) then
cascade_target => cascade_target%next
cycle LOOP_TARGET
else if (cascade_target%index > nt2) then
exit LOOP_TARGET
else if (cascade_target%bincode == bc_target) then
cascade1 => cascade_set%first_t
LOOP_T: do while (associated (cascade1))
if ((cascade1 .disjunct. cascade_target) &
.and. .not. (cascade1 .disjunct. cascade_seed)) then
cascade2 => cascade_set%first
LOOP_S: do while (associated (cascade2))
if ((cascade2 .disjunct. cascade_target) &
.and. (cascade2 .disjunct. cascade1)) then
call cascade_match_triplet (cascade_set, &
cascade1, cascade2, cascade_target, .false.)
end if
call terminate_now_if_signal ()
cascade2 => cascade2%next
end do LOOP_S
end if
call terminate_now_if_signal ()
cascade1 => cascade1%next
end do LOOP_T
end if
call terminate_now_if_signal ()
cascade_target => cascade_target%next
end do LOOP_TARGET
end if
call terminate_now_if_signal ()
cascade_seed => cascade_seed%next
end do LOOP_SEED
end subroutine cascade_set_generate_scattering
@ %def cascade_set_generate_scattering
@
\subsection{Groves}
Before assigning groves, assign hashcodes to the resonance patterns, so they
can easily be compared.
<<Cascades: procedures>>=
subroutine cascade_set_assign_resonance_hash (cascade_set)
type(cascade_set_t), intent(inout) :: cascade_set
type(cascade_t), pointer :: cascade
cascade => cascade_set%first_k
do while (associated (cascade))
call cascade_assign_resonance_hash (cascade)
cascade => cascade%next
end do
end subroutine cascade_set_assign_resonance_hash
@ %def cascade_assign_resonance_hash
@ After all cascades are recorded, we group the complete cascades in
groves. A grove consists of cascades with identical multiplicity,
number of resonances, log-enhanced, t-channel lines, and resonance flavors.
<<Cascades: procedures>>=
subroutine cascade_set_assign_groves (cascade_set)
type(cascade_set_t), intent(inout), target :: cascade_set
type(cascade_t), pointer :: cascade1, cascade2
integer :: multiplicity
integer :: n_resonances, n_log_enhanced, n_t_channel, n_off_shell
integer :: res_hash
integer :: grove
grove = 0
cascade1 => cascade_set%first_k
do while (associated (cascade1))
if (cascade1%active .and. cascade1%complete &
.and. cascade1%grove == 0) then
grove = grove + 1
cascade1%grove = grove
multiplicity = cascade1%multiplicity
n_resonances = cascade1%n_resonances
n_log_enhanced = cascade1%n_log_enhanced
n_off_shell = cascade1%n_off_shell
n_t_channel = cascade1%n_t_channel
res_hash = cascade1%res_hash
cascade2 => cascade1%next
do while (associated (cascade2))
if (cascade2%grove == 0) then
if (cascade2%multiplicity == multiplicity &
.and. cascade2%n_resonances == n_resonances &
.and. cascade2%n_log_enhanced == n_log_enhanced &
.and. cascade2%n_off_shell == n_off_shell &
.and. cascade2%n_t_channel == n_t_channel &
.and. cascade2%res_hash == res_hash) then
cascade2%grove = grove
end if
end if
call terminate_now_if_signal ()
cascade2 => cascade2%next
end do
end if
call terminate_now_if_signal ()
cascade1 => cascade1%next
end do
cascade_set%n_groves = grove
end subroutine cascade_set_assign_groves
@ %def cascade_set_assign_groves
@
\subsection{Generate the phase space file}
Generate a complete phase space configuration.
For each flavor assignment: First, all s-channel
graphs that can be built up from the outgoing particles. Then we
distinguish (1) decay, where we complete the s-channel graphs by
connecting to the input line, and (2) scattering, where we now
generate t-channel graphs by introducing an incoming particle, and
complete this by connecting to the other incoming particle.
After all cascade sets have been generated, merge them into a common set.
This eliminates redunancies between flavor assignments.
<<Cascades: public>>=
public :: cascade_set_generate
<<Cascades: sub interfaces>>=
module subroutine cascade_set_generate &
(cascade_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay)
type(cascade_set_t), intent(out) :: cascade_set
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in, n_out
type(flavor_t), dimension(:,:), intent(in) :: flv
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
end subroutine cascade_set_generate
<<Cascades: procedures>>=
module subroutine cascade_set_generate &
(cascade_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay)
type(cascade_set_t), intent(out) :: cascade_set
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in, n_out
type(flavor_t), dimension(:,:), intent(in) :: flv
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
type(cascade_set_t), dimension(:), allocatable :: cset
type(cascade_t), pointer :: cascade
integer :: i
if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return
call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, &
fatal_beam_decay, flv)
allocate (cset (size (flv, 2)))
do i = 1, size (cset)
call cascade_set_generate_single (cset(i), &
model, n_in, n_out, flv(:,i), phs_par, fatal_beam_decay)
cascade => cset(i)%first_k
do while (associated (cascade))
if (cascade%active .and. cascade%complete) then
call cascade_set_add_copy (cascade_set, cascade)
end if
cascade => cascade%next
end do
call cascade_set_final (cset(i))
end do
cascade_set%first_k => cascade_set%first
call cascade_set_assign_resonance_hash (cascade_set)
call cascade_set_assign_groves (cascade_set)
end subroutine cascade_set_generate
@ %def cascade_set_generate
@ This generates phase space for a single channel, without assigning groves.
<<Cascades: procedures>>=
subroutine cascade_set_generate_single (cascade_set, &
model, n_in, n_out, flv, phs_par, fatal_beam_decay)
type(cascade_set_t), intent(out) :: cascade_set
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in, n_out
type(flavor_t), dimension(:), intent(in) :: flv
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
integer :: n11, n12, n21, n22
call cascade_set_init (cascade_set, model, n_in, n_out, phs_par, &
fatal_beam_decay)
call cascade_set_add_outgoing (cascade_set, flv(n_in+1:))
call cascade_set_generate_s (cascade_set)
select case (n_in)
case(1)
call cascade_set_add_incoming &
(cascade_set, n11, n12, n_out + 1, flv(1))
call cascade_set_generate_decay (cascade_set)
case(2)
call cascade_set_add_incoming &
(cascade_set, n11, n12, n_out + 1, flv(2))
call cascade_set_add_incoming &
(cascade_set, n21, n22, n_out + 2, flv(1))
call cascade_set_generate_t (cascade_set, n_out + 1, n_out + 2)
call cascade_set_generate_t (cascade_set, n_out + 2, n_out + 1)
call cascade_set_generate_scattering &
(cascade_set, n11, n12, n21, n22, n_out + 1, n_out + 2)
call cascade_set_generate_scattering &
(cascade_set, n21, n22, n11, n12, n_out + 2, n_out + 1)
end select
end subroutine cascade_set_generate_single
@ %def cascade_set_generate_single
@ Sanity check: Before anything else is done, check if there could
possibly be any phase space.
<<Cascades: public>>=
public :: phase_space_vanishes
<<Cascades: sub interfaces>>=
module function phase_space_vanishes (sqrts, n_in, flv) result (flag)
logical :: flag
real(default), intent(in) :: sqrts
integer, intent(in) :: n_in
type(flavor_t), dimension(:,:), intent(in) :: flv
end function phase_space_vanishes
<<Cascades: procedures>>=
module function phase_space_vanishes (sqrts, n_in, flv) result (flag)
logical :: flag
real(default), intent(in) :: sqrts
integer, intent(in) :: n_in
type(flavor_t), dimension(:,:), intent(in) :: flv
real(default), dimension(:,:), allocatable :: mass
real(default), dimension(:), allocatable :: mass_in, mass_out
integer :: n_prt, n_flv, i, j
flag = .false.
if (sqrts <= 0) then
call msg_error ("Phase space vanishes (sqrts must be positive)")
flag = .true.; return
end if
n_prt = size (flv, 1)
n_flv = size (flv, 2)
allocate (mass (n_prt, n_flv), mass_in (n_flv), mass_out (n_flv))
mass = flv%get_mass ()
mass_in = sum (mass(:n_in,:), 1)
mass_out = sum (mass(n_in+1:,:), 1)
if (any (mass_in > sqrts)) then
call msg_error ("Mass sum of incoming particles " &
// "is more than available energy")
flag = .true.; return
end if
if (any (mass_out > sqrts)) then
call msg_error ("Mass sum of outgoing particles " &
// "is more than available energy")
flag = .true.; return
end if
end function phase_space_vanishes
@ %def phase_space_vanishes
@
\subsection{Return the resonance histories for subtraction}
This appears to be essential (re-export of some imported assignment?)!
<<Cascades: public>>=
public :: assignment(=)
@
Extract the resonance set from a complete cascade.
<<Cascades: cascade: TBP>>=
procedure :: extract_resonance_history => cascade_extract_resonance_history
<<Cascades: sub interfaces>>=
module subroutine cascade_extract_resonance_history &
(cascade, res_hist, model, n_out)
class(cascade_t), intent(in), target :: cascade
type(resonance_history_t), intent(out) :: res_hist
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_out
end subroutine cascade_extract_resonance_history
<<Cascades: procedures>>=
module subroutine cascade_extract_resonance_history &
(cascade, res_hist, model, n_out)
class(cascade_t), intent(in), target :: cascade
type(resonance_history_t), intent(out) :: res_hist
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_out
type(resonance_info_t) :: resonance
integer :: i, mom_id, pdg
if (debug_on) call msg_debug2 (D_PHASESPACE, "cascade_extract_resonance_history")
if (cascade%n_resonances > 0) then
if (cascade%has_children) then
if (debug_on) call msg_debug2 (D_PHASESPACE, "cascade has resonances and children")
do i = 1, size(cascade%tree_resonant)
if (cascade%tree_resonant (i)) then
mom_id = cascade%tree (i)
pdg = cascade%tree_pdg (i)
call resonance%init (mom_id, pdg, model, n_out)
if (debug2_active (D_PHASESPACE)) then
print *, 'D: Adding resonance'
call resonance%write ()
end if
call res_hist%add_resonance (resonance)
end if
end do
end if
end if
end subroutine cascade_extract_resonance_history
@ %def cascade_extract_resonance_history
@
<<Cascades: public>>=
public :: cascade_set_get_n_trees
<<Cascades: sub interfaces>>=
module function cascade_set_get_n_trees (cascade_set) result (n)
type(cascade_set_t), intent(in), target :: cascade_set
integer :: n
end function cascade_set_get_n_trees
<<Cascades: procedures>>=
module function cascade_set_get_n_trees (cascade_set) result (n)
type(cascade_set_t), intent(in), target :: cascade_set
integer :: n
type(cascade_t), pointer :: cascade
integer :: grove
if (debug_on) call msg_debug (D_PHASESPACE, "cascade_set_get_n_trees")
n = 0
do grove = 1, cascade_set%n_groves
cascade => cascade_set%first_k
do while (associated (cascade))
if (cascade%active .and. cascade%complete) then
if (cascade%grove == grove) then
n = n + 1
end if
end if
cascade => cascade%next
end do
end do
if (debug_on) call msg_debug (D_PHASESPACE, "n", n)
end function cascade_set_get_n_trees
@ %def cascade_set_get_n_trees
@ Distill the set of resonance histories from the cascade set. The
result is an array which contains each valid history exactly once.
<<Cascades: public>>=
public :: cascade_set_get_resonance_histories
<<Cascades: sub interfaces>>=
module subroutine cascade_set_get_resonance_histories &
(cascade_set, n_filter, res_hists)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: n_filter
type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
res_hists
end subroutine cascade_set_get_resonance_histories
<<Cascades: procedures>>=
module subroutine cascade_set_get_resonance_histories &
(cascade_set, n_filter, res_hists)
type(cascade_set_t), intent(in), target :: cascade_set
integer, intent(in), optional :: n_filter
type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
res_hists
type(resonance_history_t), dimension(:), allocatable :: tmp
type(cascade_t), pointer :: cascade
type(resonance_history_t) :: res_hist
type(resonance_history_set_t) :: res_hist_set
integer :: grove, i, n_hists
logical :: included, add_to_list
if (debug_on) call msg_debug &
(D_PHASESPACE, "cascade_set_get_resonance_histories")
call res_hist_set%init (n_filter = n_filter)
do grove = 1, cascade_set%n_groves
cascade => cascade_set%first_k
do while (associated (cascade))
if (cascade%active .and. cascade%complete) then
if (cascade%grove == grove) then
if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", grove)
call cascade%extract_resonance_history &
(res_hist, cascade_set%model, cascade_set%n_out)
call res_hist_set%enter (res_hist)
end if
end if
cascade => cascade%next
end do
end do
call res_hist_set%freeze ()
call res_hist_set%to_array (res_hists)
end subroutine cascade_set_get_resonance_histories
@ %def cascade_set_get_resonance_histories
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[cascades_ut.f90]]>>=
<<File header>>
module cascades_ut
use unit_tests
use cascades_uti
<<Standard module head>>
<<Cascades: public test>>
contains
<<Cascades: test driver>>
end module cascades_ut
@ %def cascades_ut
@
<<[[cascades_uti.f90]]>>=
<<File header>>
module cascades_uti
<<Use kinds>>
<<Use strings>>
use numeric_utils
use flavors
use model_data
use phs_forests, only: phs_parameters_t
use resonances, only: resonance_history_t
use cascades
<<Standard module head>>
<<Cascades: test declarations>>
contains
<<Cascades: tests>>
end module cascades_uti
@ %def cascades_ut
@ API: driver for the unit tests below.
<<Cascades: public test>>=
public :: cascades_test
<<Cascades: test driver>>=
subroutine cascades_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Cascades: execute tests>>
end subroutine cascades_test
@ %def cascades_test
\subsubsection{Check cascade setup}
@ Checking the basic setup up of the phase space cascade parameterizations.
<<Cascades: execute tests>>=
call test (cascades_1, "cascades_1", &
"check cascade setup", &
u, results)
<<Cascades: test declarations>>=
public :: cascades_1
<<Cascades: tests>>=
subroutine cascades_1 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t), dimension(5,2) :: flv
type(cascade_set_t) :: cascade_set
type(phs_parameters_t) :: phs_par
write (u, "(A)") "* Test output: cascades_1"
write (u, "(A)") "* Purpose: test cascade phase space functions"
write (u, "(A)")
write (u, "(A)") "* Initializing"
write (u, "(A)")
call model%init_sm_test ()
call flv(1,1)%init ( 2, model)
call flv(2,1)%init (-2, model)
call flv(3,1)%init ( 1, model)
call flv(4,1)%init (-1, model)
call flv(5,1)%init (21, model)
call flv(1,2)%init ( 2, model)
call flv(2,2)%init (-2, model)
call flv(3,2)%init ( 2, model)
call flv(4,2)%init (-2, model)
call flv(5,2)%init (21, model)
phs_par%sqrts = 1000._default
phs_par%off_shell = 2
write (u, "(A)")
write (u, "(A)") "* Generating the cascades"
write (u, "(A)")
call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.)
call cascade_set_write (cascade_set, u)
call cascade_set_write_file_format (cascade_set, u)
write (u, "(A)") "* Cleanup"
write (u, "(A)")
call cascade_set_final (cascade_set)
call model%final ()
write (u, *)
write (u, "(A)") "* Test output end: cascades_1"
end subroutine cascades_1
@ %def cascades_1
@
\subsubsection{Check resonance history}
<<Cascades: execute tests>>=
call test(cascades_2, "cascades_2", &
"Check resonance history", u, results)
<<Cascades: test declarations>>=
public :: cascades_2
<<Cascades: tests>>=
subroutine cascades_2 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t), dimension(5,1) :: flv
type(cascade_set_t) :: cascade_set
type(phs_parameters_t) :: phs_par
type(resonance_history_t), dimension(:), allocatable :: res_hists
integer :: n, i
write (u, "(A)") "* Test output: cascades_2"
write (u, "(A)") "* Purpose: Check resonance history"
write (u, "(A)")
write (u, "(A)") "* Initializing"
write (u, "(A)")
call model%init_sm_test ()
call flv(1,1)%init ( 2, model)
call flv(2,1)%init (-2, model)
call flv(3,1)%init ( 1, model)
call flv(4,1)%init (-1, model)
call flv(5,1)%init (22, model)
phs_par%sqrts = 1000._default
phs_par%off_shell = 2
write (u, "(A)")
write (u, "(A)") "* Generating the cascades"
write (u, "(A)")
call cascade_set_generate (cascade_set, model, 2, 3, flv, phs_par,.true.)
call cascade_set_get_resonance_histories (cascade_set, res_hists = res_hists)
n = cascade_set_get_n_trees (cascade_set)
call assert_equal (u, n, 24, "Number of trees")
do i = 1, size(res_hists)
call res_hists(i)%write (u)
write (u, "(A)")
end do
write (u, "(A)") "* Cleanup"
write (u, "(A)")
call cascade_set_final (cascade_set)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: cascades_2"
end subroutine cascades_2
@ %def cascades_2
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{A lexer for O'Mega's phase-space output}
This module provides three data types. One of them is the type
[[dag_string_t]] which should contain the information of all Feynman
diagrams in the factorized form which is provided by O'Mega in its
phase-space outout. This output is translated into a string of tokens (in
the form of an a array of the type [[dag_token_t]]) which have a certain
meaning. The purpose of this module is only to identify these tokens
correctly and to provide some procedures and interfaces which allow us to
use these strings in a similar way as variables of the basic character
type or the type [[iso_varying_string]]. Both [[character]] and
[[iso_varying_string]] have some disadvantages at least if one wants to
keep support for some older compiler versions. These can be circumvented
by the [[dag_string_t]] type. Finally the [[dag_chain_t]] type is used
to create a larger string in several steps without always recreating the
string, which is done in the form of a simple linked list. In the end
one can create a single [[dag_string]] out of this list, which is more
useful.
<<[[cascades2_lexer.f90]]>>=
<<File header>>
module cascades2_lexer
<<Use kinds>>
use kinds, only: TC, i8
<<Standard module head>>
<<Cascades2 lexer: public>>
<<Cascades2 lexer: parameters>>
<<Cascades2 lexer: types>>
<<Cascades2 lexer: interfaces>>
interface
<<Cascades2 lexer: sub interfaces>>
end interface
end module cascades2_lexer
@ %def cascades2_lexer
@
<<[[cascades2_lexer_sub.f90]]>>=
<<File header>>
submodule (cascades2_lexer) cascades2_lexer_s
implicit none
contains
<<Cascades2 lexer: procedures>>
end submodule cascades2_lexer_s
@ %def cascades2_lexer_s
@
This is the token type. By default the variable [[type]] is [[EMPTY_TK]]
but can obtain other values corresponding to the parameters defined below.
The type of the token corresponds to a particular sequence of characters.
When the token corresponds to a node of a tree, i.e. some particle in the
Feynman diagram, the type is [[NODE_TK]] and the [[particle_name]] variable
is holding the name of the particle. O'Megas output contains in
addition to the particle name some numbers which indicate the external
momenta that are flowing through this line. These numbers are translated
into a binary code and saved in the variable [[bincode]]. In this case
the number 1 corresponds to a bit set at position 0, 2 corresponds to a
bit set at position 1, etc. Instead of numbers which are composed out of
several digits, letters are used, i.e. A instead of 10 (bit at position 9),
B instead of 11 (bit at position 10), etc.\\
When the DAG is reconstructed from a [[dag_string]] which was built from
O'Mega's output, this string is modified such that a substring (a set of
tokens) is replaced by a single token where the type variable is one of
the three parameters [[DAG_NODE_TK]], [[DAG_OPTIONS_TK]] and
[[DAG_COMBINATION_TK]]. These parameters correspond to the three types
[[dag_node_t]], [[dag_options_t]] and [[dag_combination_t]] (see [[cascades2]]
for more information. In this case, since these objects are organized
in arrays, the [[index]] variable holds the corresponding position in
the array.\\
In any case, we want to be able to reproduce the character string from
which a token (or a string) has been created. The variable [[char_len]]
is the length of this string. For tokens with the type [[DAG_NODE_TK]],
[[DAG_OPTIONS_TK]] and [[DAG_COMBINATION_TK]] we use output of the form
[[<N23>]], [[<O23>]] or [[<C23>]] which is useful for debugging the parser.
Here 23 is the [[index]] and [[N]], [[O]] or [[C]] obviously corresponds
to the [[type]].
<<Cascades2 lexer: parameters>>=
integer, parameter :: PRT_NAME_LEN = 20
@ %def PRT_NAME_LEN
<<Cascades2 lexer: public>>=
public :: dag_token_t
<<Cascades2 lexer: types>>=
type :: dag_token_t
integer :: type = EMPTY_TK
integer :: char_len = 0
integer(TC) :: bincode = 0
character(len=PRT_NAME_LEN) :: particle_name=""
integer :: index = 0
contains
<<Cascades2 lexer: dag token: TBP>>
end type dag_token_t
@ %def dag_token_t
@ This is the string type. It also holds the number of characters in the
corresponding character string. It contains an array of tokens. If the
[[dag_string]] is constructed using the type [[dag_chain_t]], which creates
a linked list, we also need the pointer [[next]].
<<Cascades2 lexer: public>>=
public :: dag_string_t
<<Cascades2 lexer: types>>=
type :: dag_string_t
integer :: char_len = 0
type(dag_token_t), dimension(:), allocatable :: t
type(dag_string_t), pointer :: next => null ()
contains
<<Cascades2 lexer: dag string: TBP>>
end type dag_string_t
@ %def dag_string_t
@ This is the chain of [[dag_strings]]. It allows us to construct a large
string by appending new strings to the linked list, which can later be
merged to a single string. This is very useful because the file written
by O'Mega contains large strings where each string contains all Feynman
diagrams in a factorized form, but these large strings are cut into
several pieces and distributed over many lines. As the file can become
large, rewriting a new [[dag_string]] (or [[iso_varying_string]]) would
consume more and more time with each additional line. For recreating a
single [[dag_string]] out of this chain, we need the total character
length and the sum of all sizes of the [[dag_token]] arrays [[t]].
<<Cascades2 lexer: public>>=
public :: dag_chain_t
<<Cascades2 lexer: types>>=
type :: dag_chain_t
integer :: char_len = 0
integer :: t_size = 0
type(dag_string_t), pointer :: first => null ()
type(dag_string_t), pointer :: last => null ()
contains
<<Cascades2 lexer: dag chain: TBP>>
end type dag_chain_t
@ %def dag_chain_t
@ We define two parameters holding the characters corresponding to a
backslash and a blanc space.
<<Cascades2 lexer: parameters>>=
character(len=1), parameter, public :: BACKSLASH_CHAR = "\\"
character(len=1), parameter :: BLANC_CHAR = " "
@ %def BACKSLASH_CHAR BLANC_CHAR
@ These are the parameters which correspond to meaningful types
of [[token]].
<<Cascades2 lexer: parameters>>=
integer, parameter, public :: NEW_LINE_TK = -2
integer, parameter :: BLANC_SPACE_TK = -1
integer, parameter :: EMPTY_TK = 0
integer, parameter, public :: NODE_TK = 1
integer, parameter, public :: DAG_NODE_TK = 2
integer, parameter, public :: DAG_OPTIONS_TK = 3
integer, parameter, public :: DAG_COMBINATION_TK = 4
integer, parameter, public :: COLON_TK = 11
integer, parameter, public :: COMMA_TK = 12
integer, parameter, public :: VERTICAL_BAR_TK = 13
integer, parameter, public :: OPEN_PAR_TK = 21
integer, parameter, public :: CLOSED_PAR_TK = 22
integer, parameter, public :: OPEN_CURLY_TK = 31
integer, parameter, public :: CLOSED_CURLY_TK = 32
@ %def NEW_LINE_TK BLANC_SPACE_TK EMPTY_TK NODE_TK
@ %def COLON_TK COMMA_TK VERTICAL_LINE_TK OPEN_PAR_TK
@ %def CLOSED_PAR_TK OPEN_CURLY_TK CLOSED_CURLY_TK
@ Different sorts of assignment. This contains the conversion
of a [[character]] variable into a [[dag_token]] or [[dag_string]].
<<Cascades2 lexer: public>>=
public :: assignment (=)
<<Cascades2 lexer: interfaces>>=
interface assignment (=)
module procedure dag_token_assign_from_char_string
module procedure dag_token_assign_from_dag_token
module procedure dag_string_assign_from_dag_token
module procedure dag_string_assign_from_char_string
module procedure dag_string_assign_from_dag_string
module procedure dag_string_assign_from_dag_token_array
end interface assignment (=)
@ %def interfaces
<<Cascades2 lexer: dag token: TBP>>=
procedure :: init_dag_object_token => dag_token_init_dag_object_token
<<Cascades2 lexer: sub interfaces>>=
module subroutine dag_token_init_dag_object_token (dag_token, type, index)
class(dag_token_t), intent(out) :: dag_token
integer, intent(in) :: index
integer :: type
end subroutine dag_token_init_dag_object_token
<<Cascades2 lexer: procedures>>=
module subroutine dag_token_init_dag_object_token (dag_token, type, index)
class(dag_token_t), intent(out) :: dag_token
integer, intent(in) :: index
integer :: type
dag_token%type = type
dag_token%char_len = integer_n_dec_digits (index) + 3
dag_token%index = index
contains
function integer_n_dec_digits (number) result (n_digits)
integer, intent(in) :: number
integer :: n_digits
integer :: div_number
n_digits = 0
div_number = number
do
div_number = div_number / 10
n_digits = n_digits + 1
if (div_number == 0) exit
end do
end function integer_n_dec_digits
end subroutine dag_token_init_dag_object_token
@ %def dag_token_init_dag_object_token
<<Cascades2 lexer: sub interfaces>>=
elemental module subroutine dag_token_assign_from_char_string &
(dag_token, char_string)
type(dag_token_t), intent(out) :: dag_token
character(len=*), intent(in) :: char_string
end subroutine dag_token_assign_from_char_string
<<Cascades2 lexer: procedures>>=
elemental module subroutine dag_token_assign_from_char_string &
(dag_token, char_string)
type(dag_token_t), intent(out) :: dag_token
character(len=*), intent(in) :: char_string
integer :: i, j
logical :: set_bincode
integer :: bit_pos
character(len=10) :: index_char
dag_token%char_len = len (char_string)
if (dag_token%char_len == 1) then
select case (char_string(1:1))
case (BACKSLASH_CHAR)
dag_token%type = NEW_LINE_TK
case (" ")
dag_token%type = BLANC_SPACE_TK
case (":")
dag_token%type = COLON_TK
case (",")
dag_token%type = COMMA_TK
case ("|")
dag_token%type = VERTICAL_BAR_TK
case ("(")
dag_token%type = OPEN_PAR_TK
case (")")
dag_token%type = CLOSED_PAR_TK
case ("{")
dag_token%type = OPEN_CURLY_TK
case ("}")
dag_token%type = CLOSED_CURLY_TK
end select
else if (char_string(1:1) == "<") then
select case (char_string(2:2))
case ("N")
dag_token%type = DAG_NODE_TK
case ("O")
dag_token%type = DAG_OPTIONS_TK
case ("C")
dag_token%type = DAG_COMBINATION_TK
end select
read(char_string(3:dag_token%char_len-1), fmt="(I10)") dag_token%index
else
dag_token%bincode = 0
set_bincode = .false.
do i=1, dag_token%char_len
select case (char_string(i:i))
case ("[")
dag_token%type = NODE_TK
if (i > 1) then
do j = 1, i - 1
dag_token%particle_name(j:j) = char_string(j:j)
end do
end if
set_bincode = .true.
case ("]")
set_bincode = .false.
case default
dag_token%type = NODE_TK
if (set_bincode) then
select case (char_string(i:i))
case ("1", "2", "3", "4", "5", "6", "7", "8", "9")
read (char_string(i:i), fmt="(I1)") bit_pos
case ("A")
bit_pos = 10
case ("B")
bit_pos = 11
case ("C")
bit_pos = 12
end select
dag_token%bincode = ibset(dag_token%bincode, bit_pos - 1)
end if
end select
if (dag_token%type /= NODE_TK) exit
end do
end if
end subroutine dag_token_assign_from_char_string
@ %def dag_token_assign_from_char_string
<<Cascades2 lexer: sub interfaces>>=
elemental module subroutine dag_token_assign_from_dag_token &
(token_out, token_in)
type(dag_token_t), intent(out) :: token_out
type(dag_token_t), intent(in) :: token_in
end subroutine dag_token_assign_from_dag_token
<<Cascades2 lexer: procedures>>=
elemental module subroutine dag_token_assign_from_dag_token &
(token_out, token_in)
type(dag_token_t), intent(out) :: token_out
type(dag_token_t), intent(in) :: token_in
token_out%type = token_in%type
token_out%char_len = token_in%char_len
token_out%bincode = token_in%bincode
token_out%particle_name = token_in%particle_name
token_out%index = token_in%index
end subroutine dag_token_assign_from_dag_token
@ %def dag_token_assign_from_dag_token
<<Cascades2 lexer: sub interfaces>>=
elemental module subroutine dag_string_assign_from_dag_token &
(dag_string, dag_token)
type(dag_string_t), intent(out) :: dag_string
type(dag_token_t), intent(in) :: dag_token
end subroutine dag_string_assign_from_dag_token
<<Cascades2 lexer: procedures>>=
elemental module subroutine dag_string_assign_from_dag_token &
(dag_string, dag_token)
type(dag_string_t), intent(out) :: dag_string
type(dag_token_t), intent(in) :: dag_token
allocate (dag_string%t(1))
dag_string%t(1) = dag_token
dag_string%char_len = dag_token%char_len
end subroutine dag_string_assign_from_dag_token
@ %def dag_string_assign_from_dag_token
<<Cascades2 lexer: sub interfaces>>=
module subroutine dag_string_assign_from_dag_token_array &
(dag_string, dag_token)
type(dag_string_t), intent(out) :: dag_string
type(dag_token_t), dimension(:), intent(in) :: dag_token
end subroutine dag_string_assign_from_dag_token_array
<<Cascades2 lexer: procedures>>=
module subroutine dag_string_assign_from_dag_token_array &
(dag_string, dag_token)
type(dag_string_t), intent(out) :: dag_string
type(dag_token_t), dimension(:), intent(in) :: dag_token
allocate (dag_string%t(size(dag_token)))
dag_string%t = dag_token
dag_string%char_len = sum(dag_token%char_len)
end subroutine dag_string_assign_from_dag_token_array
@ %def dag_string_assign_from_dag_token_array
<<Cascades2 lexer: sub interfaces>>=
elemental module subroutine dag_string_assign_from_char_string &
(dag_string, char_string)
type(dag_string_t), intent(out) :: dag_string
character(len=*), intent(in) :: char_string
end subroutine dag_string_assign_from_char_string
<<Cascades2 lexer: procedures>>=
elemental module subroutine dag_string_assign_from_char_string &
(dag_string, char_string)
type(dag_string_t), intent(out) :: dag_string
character(len=*), intent(in) :: char_string
type(dag_token_t), dimension(:), allocatable :: token
integer :: token_pos
integer :: i
character(len=len(char_string)) :: node_char
integer :: node_char_len
node_char = ""
dag_string%char_len = len (char_string)
if (dag_string%char_len > 0) then
allocate (token(dag_string%char_len))
token_pos = 0
node_char_len = 0
do i=1, dag_string%char_len
select case (char_string(i:i))
case (BACKSLASH_CHAR, " ", ":", ",", "|", "(", ")", "{", "}")
if (node_char_len > 0) then
token_pos = token_pos + 1
token(token_pos) = node_char(:node_char_len)
node_char_len = 0
end if
token_pos = token_pos + 1
token(token_pos) = char_string(i:i)
case default
node_char_len = node_char_len + 1
node_char(node_char_len:node_char_len) = char_string(i:i)
end select
end do
if (node_char_len > 0) then
token_pos = token_pos + 1
token(token_pos) = node_char(:node_char_len)
end if
if (token_pos > 0) then
allocate (dag_string%t(token_pos))
dag_string%t = token(:token_pos)
deallocate (token)
end if
end if
end subroutine dag_string_assign_from_char_string
@ %def dag_string_assign_from_char_string
<<Cascades2 lexer: sub interfaces>>=
elemental module subroutine dag_string_assign_from_dag_string &
(string_out, string_in)
type(dag_string_t), intent(out) :: string_out
type(dag_string_t), intent(in) :: string_in
end subroutine dag_string_assign_from_dag_string
<<Cascades2 lexer: procedures>>=
elemental module subroutine dag_string_assign_from_dag_string &
(string_out, string_in)
type(dag_string_t), intent(out) :: string_out
type(dag_string_t), intent(in) :: string_in
if (allocated (string_in%t)) then
allocate (string_out%t (size(string_in%t)))
string_out%t = string_in%t
end if
string_out%char_len = string_in%char_len
end subroutine dag_string_assign_from_dag_string
@ %def dag_string_assign_from_dag_string
@ Concatenate strings/tokens. The result is always a [[dag_string]].
<<Cascades2 lexer: public>>=
public :: operator (//)
<<Cascades2 lexer: interfaces>>=
interface operator (//)
module procedure concat_dag_token_dag_token
module procedure concat_dag_string_dag_token
module procedure concat_dag_token_dag_string
module procedure concat_dag_string_dag_string
end interface operator (//)
@ %def interfaces
<<Cascades2 lexer: sub interfaces>>=
module function concat_dag_token_dag_token &
(token1, token2) result (res_string)
type(dag_token_t), intent(in) :: token1, token2
type(dag_string_t) :: res_string
end function concat_dag_token_dag_token
<<Cascades2 lexer: procedures>>=
module function concat_dag_token_dag_token &
(token1, token2) result (res_string)
type(dag_token_t), intent(in) :: token1, token2
type(dag_string_t) :: res_string
if (token1%type == EMPTY_TK) then
call dag_string_assign_from_dag_token (res_string, token2)
else if (token2%type == EMPTY_TK) then
call dag_string_assign_from_dag_token (res_string, token1)
else
allocate (res_string%t(2))
res_string%t(1) = token1
res_string%t(2) = token2
res_string%char_len = token1%char_len + token2%char_len
end if
end function concat_dag_token_dag_token
@ %def concat_dag_token_dag_token
<<Cascades2 lexer: sub interfaces>>=
module function concat_dag_string_dag_token &
(dag_string, dag_token) result (res_string)
type(dag_string_t), intent(in) :: dag_string
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t) :: res_string
end function concat_dag_string_dag_token
<<Cascades2 lexer: procedures>>=
module function concat_dag_string_dag_token &
(dag_string, dag_token) result (res_string)
type(dag_string_t), intent(in) :: dag_string
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t) :: res_string
integer :: t_size
if (dag_string%char_len == 0) then
call dag_string_assign_from_dag_token (res_string, dag_token)
else if (dag_token%type == EMPTY_TK) then
res_string = dag_string
else
t_size = size (dag_string%t)
allocate (res_string%t(t_size+1))
res_string%t(:t_size) = dag_string%t
res_string%t(t_size+1) = dag_token
res_string%char_len = dag_string%char_len + dag_token%char_len
end if
end function concat_dag_string_dag_token
@ %def concat_dag_string_dag_token
<<Cascades2 lexer: sub interfaces>>=
module function concat_dag_token_dag_string &
(dag_token, dag_string) result (res_string)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
type(dag_string_t) :: res_string
integer :: t_size
end function concat_dag_token_dag_string
<<Cascades2 lexer: procedures>>=
module function concat_dag_token_dag_string &
(dag_token, dag_string) result (res_string)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
type(dag_string_t) :: res_string
integer :: t_size
if (dag_token%type == EMPTY_TK) then
res_string = dag_string
else if (dag_string%char_len == 0) then
call dag_string_assign_from_dag_token (res_string, dag_token)
else
t_size = size (dag_string%t)
allocate (res_string%t(t_size+1))
res_string%t(2:t_size+1) = dag_string%t
res_string%t(1) = dag_token
res_string%char_len = dag_token%char_len + dag_string%char_len
end if
end function concat_dag_token_dag_string
@ %def concat_dag_token_dag_string
<<Cascades2 lexer: sub interfaces>>=
module function concat_dag_string_dag_string &
(string1, string2) result (res_string)
type(dag_string_t), intent(in) :: string1, string2
type(dag_string_t) :: res_string
end function concat_dag_string_dag_string
<<Cascades2 lexer: procedures>>=
module function concat_dag_string_dag_string &
(string1, string2) result (res_string)
type(dag_string_t), intent(in) :: string1, string2
type(dag_string_t) :: res_string
integer :: t1_size, t2_size, t_size
if (string1%char_len == 0) then
res_string = string2
else if (string2%char_len == 0) then
res_string = string1
else
t1_size = size (string1%t)
t2_size = size (string2%t)
t_size = t1_size + t2_size
if (t_size > 0) then
allocate (res_string%t(t_size))
res_string%t(:t1_size) = string1%t
res_string%t(t1_size+1:) = string2%t
res_string%char_len = string1%char_len + string2%char_len
end if
end if
end function concat_dag_string_dag_string
@ %def concat_dag_string_dag_string
@ Compare strings/tokens/characters. Each character is relevant, including
all blanc spaces. An exception is the [[newline]] character which is not
treated by the types used in this module (not to confused with the type
parameter [[NEW_LINE_TK]] which corresponds to the backslash character
and simply tells us that the string continues on the next line in the file).
<<Cascades2 lexer: public>>=
public :: operator (==)
<<Cascades2 lexer: interfaces>>=
interface operator (==)
module procedure dag_token_eq_dag_token
module procedure dag_string_eq_dag_string
module procedure dag_token_eq_dag_string
module procedure dag_string_eq_dag_token
module procedure dag_token_eq_char_string
module procedure char_string_eq_dag_token
module procedure dag_string_eq_char_string
module procedure char_string_eq_dag_string
end interface operator (==)
@ %def interfaces
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_token_eq_dag_token &
(token1, token2) result (flag)
type(dag_token_t), intent(in) :: token1, token2
logical :: flag
end function dag_token_eq_dag_token
<<Cascades2 lexer: procedures>>=
elemental module function dag_token_eq_dag_token &
(token1, token2) result (flag)
type(dag_token_t), intent(in) :: token1, token2
logical :: flag
flag = (token1%type == token2%type) .and. &
(token1%char_len == token2%char_len) .and. &
(token1%bincode == token2%bincode) .and. &
(token1%index == token2%index) .and. &
(token1%particle_name == token2%particle_name)
end function dag_token_eq_dag_token
@ %def dag_token_eq_dag_token
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_string_eq_dag_string &
(string1, string2) result (flag)
type(dag_string_t), intent(in) :: string1, string2
logical :: flag
end function dag_string_eq_dag_string
<<Cascades2 lexer: procedures>>=
elemental module function dag_string_eq_dag_string &
(string1, string2) result (flag)
type(dag_string_t), intent(in) :: string1, string2
logical :: flag
flag = (string1%char_len == string2%char_len) .and. &
(allocated (string1%t) .eqv. allocated (string2%t))
if (flag) then
if (allocated (string1%t)) flag = all (string1%t == string2%t)
end if
end function dag_string_eq_dag_string
@ %def dag_string_eq_dag_string
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_token_eq_dag_string &
(dag_token, dag_string) result (flag)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
logical :: flag
end function dag_token_eq_dag_string
<<Cascades2 lexer: procedures>>=
elemental module function dag_token_eq_dag_string &
(dag_token, dag_string) result (flag)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
logical :: flag
flag = size (dag_string%t) == 1 .and. &
dag_string%char_len == dag_token%char_len
if (flag) flag = (dag_string%t(1) == dag_token)
end function dag_token_eq_dag_string
@ %def dag_token_eq_dag_string
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_string_eq_dag_token &
(dag_string, dag_token) result (flag)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
logical :: flag
end function dag_string_eq_dag_token
<<Cascades2 lexer: procedures>>=
elemental module function dag_string_eq_dag_token &
(dag_string, dag_token) result (flag)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
logical :: flag
flag = (dag_token == dag_string)
end function dag_string_eq_dag_token
@ %def dag_string_eq_dag_token
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_token_eq_char_string &
(dag_token, char_string) result (flag)
type(dag_token_t), intent(in) :: dag_token
character(len=*), intent(in) :: char_string
logical :: flag
end function dag_token_eq_char_string
<<Cascades2 lexer: procedures>>=
elemental module function dag_token_eq_char_string &
(dag_token, char_string) result (flag)
type(dag_token_t), intent(in) :: dag_token
character(len=*), intent(in) :: char_string
logical :: flag
flag = (char (dag_token) == char_string)
end function dag_token_eq_char_string
@ %def dag_token_eq_char_string
<<Cascades2 lexer: sub interfaces>>=
elemental module function char_string_eq_dag_token &
(char_string, dag_token) result (flag)
type(dag_token_t), intent(in) :: dag_token
character(len=*), intent(in) :: char_string
logical :: flag
end function char_string_eq_dag_token
<<Cascades2 lexer: procedures>>=
elemental module function char_string_eq_dag_token &
(char_string, dag_token) result (flag)
type(dag_token_t), intent(in) :: dag_token
character(len=*), intent(in) :: char_string
logical :: flag
flag = (char (dag_token) == char_string)
end function char_string_eq_dag_token
@ %def char_string_eq_dag_token
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_string_eq_char_string &
(dag_string, char_string) result (flag)
type(dag_string_t), intent(in) :: dag_string
character(len=*), intent(in) :: char_string
logical :: flag
end function dag_string_eq_char_string
<<Cascades2 lexer: procedures>>=
elemental module function dag_string_eq_char_string &
(dag_string, char_string) result (flag)
type(dag_string_t), intent(in) :: dag_string
character(len=*), intent(in) :: char_string
logical :: flag
flag = (char (dag_string) == char_string)
end function dag_string_eq_char_string
@ %def dag_string_eq_char_string
<<Cascades2 lexer: sub interfaces>>=
elemental module function char_string_eq_dag_string &
(char_string, dag_string) result (flag)
type(dag_string_t), intent(in) :: dag_string
character(len=*), intent(in) :: char_string
logical :: flag
end function char_string_eq_dag_string
<<Cascades2 lexer: procedures>>=
elemental module function char_string_eq_dag_string &
(char_string, dag_string) result (flag)
type(dag_string_t), intent(in) :: dag_string
character(len=*), intent(in) :: char_string
logical :: flag
flag = (char (dag_string) == char_string)
end function char_string_eq_dag_string
@ %def char_string_eq_dag_string
<<Cascades2 lexer: public>>=
public :: operator (/=)
<<Cascades2 lexer: interfaces>>=
interface operator (/=)
module procedure dag_token_ne_dag_token
module procedure dag_string_ne_dag_string
module procedure dag_token_ne_dag_string
module procedure dag_string_ne_dag_token
module procedure dag_token_ne_char_string
module procedure char_string_ne_dag_token
module procedure dag_string_ne_char_string
module procedure char_string_ne_dag_string
end interface operator (/=)
@ %def interfaces
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_token_ne_dag_token &
(token1, token2) result (flag)
type(dag_token_t), intent(in) :: token1, token2
logical :: flag
end function dag_token_ne_dag_token
<<Cascades2 lexer: procedures>>=
elemental module function dag_token_ne_dag_token &
(token1, token2) result (flag)
type(dag_token_t), intent(in) :: token1, token2
logical :: flag
flag = .not. (token1 == token2)
end function dag_token_ne_dag_token
@ %def dag_token_ne_dag_token
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_string_ne_dag_string &
(string1, string2) result (flag)
type(dag_string_t), intent(in) :: string1, string2
logical :: flag
end function dag_string_ne_dag_string
<<Cascades2 lexer: procedures>>=
elemental module function dag_string_ne_dag_string &
(string1, string2) result (flag)
type(dag_string_t), intent(in) :: string1, string2
logical :: flag
flag = .not. (string1 == string2)
end function dag_string_ne_dag_string
@ %def dag_string_ne_dag_string
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_token_ne_dag_string &
(dag_token, dag_string) result (flag)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
logical :: flag
end function dag_token_ne_dag_string
<<Cascades2 lexer: procedures>>=
elemental module function dag_token_ne_dag_string &
(dag_token, dag_string) result (flag)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
logical :: flag
flag = .not. (dag_token == dag_string)
end function dag_token_ne_dag_string
@ %def dag_token_ne_dag_string
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_string_ne_dag_token &
(dag_string, dag_token) result (flag)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
logical :: flag
end function dag_string_ne_dag_token
<<Cascades2 lexer: procedures>>=
elemental module function dag_string_ne_dag_token &
(dag_string, dag_token) result (flag)
type(dag_token_t), intent(in) :: dag_token
type(dag_string_t), intent(in) :: dag_string
logical :: flag
flag = .not. (dag_string == dag_token)
end function dag_string_ne_dag_token
@ %def dag_string_ne_dag_token
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_token_ne_char_string &
(dag_token, char_string) result (flag)
type(dag_token_t), intent(in) :: dag_token
character(len=*), intent(in) :: char_string
logical :: flag
end function dag_token_ne_char_string
<<Cascades2 lexer: procedures>>=
elemental module function dag_token_ne_char_string &
(dag_token, char_string) result (flag)
type(dag_token_t), intent(in) :: dag_token
character(len=*), intent(in) :: char_string
logical :: flag
flag = .not. (dag_token == char_string)
end function dag_token_ne_char_string
@ %def dag_token_ne_char_string
<<Cascades2 lexer: sub interfaces>>=
elemental module function char_string_ne_dag_token &
(char_string, dag_token) result (flag)
type(dag_token_t), intent(in) :: dag_token
character(len=*), intent(in) :: char_string
logical :: flag
end function char_string_ne_dag_token
<<Cascades2 lexer: procedures>>=
elemental module function char_string_ne_dag_token &
(char_string, dag_token) result (flag)
type(dag_token_t), intent(in) :: dag_token
character(len=*), intent(in) :: char_string
logical :: flag
flag = .not. (char_string == dag_token)
end function char_string_ne_dag_token
@ %def char_string_ne_dag_token
<<Cascades2 lexer: sub interfaces>>=
elemental module function dag_string_ne_char_string &
(dag_string, char_string) result (flag)
type(dag_string_t), intent(in) :: dag_string
character(len=*), intent(in) :: char_string
logical :: flag
end function dag_string_ne_char_string
<<Cascades2 lexer: procedures>>=
elemental module function dag_string_ne_char_string &
(dag_string, char_string) result (flag)
type(dag_string_t), intent(in) :: dag_string
character(len=*), intent(in) :: char_string
logical :: flag
flag = .not. (dag_string == char_string)
end function dag_string_ne_char_string
@ %def dag_string_ne_char_string
<<Cascades2 lexer: sub interfaces>>=
elemental module function char_string_ne_dag_string &
(char_string, dag_string) result (flag)
type(dag_string_t), intent(in) :: dag_string
character(len=*), intent(in) :: char_string
logical :: flag
end function char_string_ne_dag_string
<<Cascades2 lexer: procedures>>=
elemental module function char_string_ne_dag_string &
(char_string, dag_string) result (flag)
type(dag_string_t), intent(in) :: dag_string
character(len=*), intent(in) :: char_string
logical :: flag
flag = .not. (char_string == dag_string)
end function char_string_ne_dag_string
@ %def char_string_ne_dag_string
@ Convert a [[dag_token]] or [[dag_string]] to character.
<<Cascades2 lexer: public>>=
public :: char
<<Cascades2 lexer: interfaces>>=
interface char
module procedure char_dag_token
module procedure char_dag_string
end interface char
@ %def interfaces
<<Cascades2 lexer: sub interfaces>>=
pure module function char_dag_token (dag_token) result (char_string)
type(dag_token_t), intent(in) :: dag_token
character (dag_token%char_len) :: char_string
end function char_dag_token
<<Cascades2 lexer: procedures>>=
pure module function char_dag_token (dag_token) result (char_string)
type(dag_token_t), intent(in) :: dag_token
character (dag_token%char_len) :: char_string
integer :: i
integer :: name_len
integer :: bc_pos
integer :: n_digits
character(len=9) :: fmt_spec
select case (dag_token%type)
case (EMPTY_TK)
char_string = ""
case (NEW_LINE_TK)
char_string = BACKSLASH_CHAR
case (BLANC_SPACE_TK)
char_string = " "
case (COLON_TK)
char_string = ":"
case (COMMA_TK)
char_string = ","
case (VERTICAL_BAR_TK)
char_string = "|"
case (OPEN_PAR_TK)
char_string = "("
case (CLOSED_PAR_TK)
char_string = ")"
case (OPEN_CURLY_TK)
char_string = "{"
case (CLOSED_CURLY_TK)
char_string = "}"
case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
n_digits = dag_token%char_len - 3
fmt_spec = ""
if (n_digits > 9) then
write (fmt_spec, fmt="(A,I2,A)") "(A,I", n_digits, ",A)"
else
write (fmt_spec, fmt="(A,I1,A)") "(A,I", n_digits, ",A)"
end if
select case (dag_token%type)
case (DAG_NODE_TK)
write (char_string, fmt=fmt_spec) "<N", dag_token%index, ">"
case (DAG_OPTIONS_TK)
write (char_string, fmt=fmt_spec) "<O", dag_token%index, ">"
case (DAG_COMBINATION_TK)
write (char_string, fmt=fmt_spec) "<C", dag_token%index, ">"
end select
case (NODE_TK)
name_len = len_trim (dag_token%particle_name)
char_string = dag_token%particle_name
bc_pos = name_len + 1
char_string(bc_pos:bc_pos) = "["
do i=0, bit_size (dag_token%bincode) - 1
if (btest (dag_token%bincode, i)) then
bc_pos = bc_pos + 1
select case (i)
case (0, 1, 2, 3, 4, 5, 6, 7, 8)
write (char_string(bc_pos:bc_pos), fmt="(I1)") i + 1
case (9)
write (char_string(bc_pos:bc_pos), fmt="(A1)") "A"
case (10)
write (char_string(bc_pos:bc_pos), fmt="(A1)") "B"
case (11)
write (char_string(bc_pos:bc_pos), fmt="(A1)") "C"
end select
bc_pos = bc_pos + 1
if (bc_pos == dag_token%char_len) then
write (char_string(bc_pos:bc_pos), fmt="(A1)") "]"
return
else
write (char_string(bc_pos:bc_pos), fmt="(A1)") "/"
end if
end if
end do
end select
end function char_dag_token
@ %def char_dag_token
<<Cascades2 lexer: sub interfaces>>=
pure module function char_dag_string (dag_string) result (char_string)
type(dag_string_t), intent(in) :: dag_string
character (dag_string%char_len) :: char_string
end function char_dag_string
<<Cascades2 lexer: procedures>>=
pure module function char_dag_string (dag_string) result (char_string)
type(dag_string_t), intent(in) :: dag_string
character (dag_string%char_len) :: char_string
integer :: pos
integer :: i
char_string = ""
pos = 0
do i=1, size(dag_string%t)
char_string(pos+1:pos+dag_string%t(i)%char_len) = char (dag_string%t(i))
pos = pos + dag_string%t(i)%char_len
end do
end function char_dag_string
@ %def char_dag_string
@ Remove all tokens which are irrelevant for parsing. These are of type
[[NEW_LINE_TK]], [[BLANC_SPACE_TK]] and [[EMTPY_TK]].
<<Cascades2 lexer: dag string: TBP>>=
procedure :: clean => dag_string_clean
<<Cascades2 lexer: sub interfaces>>=
module subroutine dag_string_clean (dag_string)
class(dag_string_t), intent(inout) :: dag_string
end subroutine dag_string_clean
<<Cascades2 lexer: procedures>>=
module subroutine dag_string_clean (dag_string)
class(dag_string_t), intent(inout) :: dag_string
type(dag_token_t), dimension(:), allocatable :: tmp_token
integer :: n_keep
integer :: i
n_keep = 0
dag_string%char_len = 0
allocate (tmp_token (size(dag_string%t)))
do i=1, size (dag_string%t)
select case (dag_string%t(i)%type)
case(NEW_LINE_TK, BLANC_SPACE_TK, EMPTY_TK)
case default
n_keep = n_keep + 1
tmp_token(n_keep) = dag_string%t(i)
dag_string%char_len = dag_string%char_len + dag_string%t(i)%char_len
end select
end do
deallocate (dag_string%t)
allocate (dag_string%t(n_keep))
dag_string%t = tmp_token(:n_keep)
end subroutine dag_string_clean
@ %def dag_string_clean
@ If we operate explicitly on the [[token]] array [[t]] of a [[dag_string]],
the variable [[char_len]] is not automatically modified. It can however be
determined afterwards using the following subroutine.
<<Cascades2 lexer: dag string: TBP>>=
procedure :: update_char_len => dag_string_update_char_len
<<Cascades2 lexer: sub interfaces>>=
module subroutine dag_string_update_char_len (dag_string)
class(dag_string_t), intent(inout) :: dag_string
end subroutine dag_string_update_char_len
<<Cascades2 lexer: procedures>>=
module subroutine dag_string_update_char_len (dag_string)
class(dag_string_t), intent(inout) :: dag_string
integer :: char_len
integer :: i
char_len = 0
if (allocated (dag_string%t)) then
do i=1, size (dag_string%t)
char_len = char_len + dag_string%t(i)%char_len
end do
end if
dag_string%char_len = char_len
end subroutine dag_string_update_char_len
@ %def dag_string_update_char_len
@ Append a [[dag_string]] to a [[dag_chain]]. The argument [[char_string]]
is of type [[character]] because the subroutine is used for reading from
the file produced by O'Mega which is first read line by line to a character
variable.
<<Cascades2 lexer: dag chain: TBP>>=
procedure :: append => dag_chain_append_string
<<Cascades2 lexer: sub interfaces>>=
module subroutine dag_chain_append_string (dag_chain, char_string)
class(dag_chain_t), intent(inout) :: dag_chain
character(len=*), intent(in) :: char_string
end subroutine dag_chain_append_string
<<Cascades2 lexer: procedures>>=
module subroutine dag_chain_append_string (dag_chain, char_string)
class(dag_chain_t), intent(inout) :: dag_chain
character(len=*), intent(in) :: char_string
if (.not. associated (dag_chain%first)) then
allocate (dag_chain%first)
dag_chain%last => dag_chain%first
else
allocate (dag_chain%last%next)
dag_chain%last => dag_chain%last%next
end if
dag_chain%last = char_string
dag_chain%char_len = dag_chain%char_len + dag_chain%last%char_len
dag_chain%t_size = dag_chain%t_size + size (dag_chain%last%t)
end subroutine dag_chain_append_string
@ %def dag_chain_append_string
@ Reduce the linked list of [[dag_string]] objects which are attached
to a given [[dag_chain]] object to a single [[dag_string]].
<<Cascades2 lexer: dag chain: TBP>>=
procedure :: compress => dag_chain_compress
<<Cascades2 lexer: sub interfaces>>=
module subroutine dag_chain_compress (dag_chain)
class(dag_chain_t), intent(inout) :: dag_chain
end subroutine dag_chain_compress
<<Cascades2 lexer: procedures>>=
module subroutine dag_chain_compress (dag_chain)
class(dag_chain_t), intent(inout) :: dag_chain
type(dag_string_t), pointer :: current
type(dag_string_t), pointer :: remove
integer :: filled_t
current => dag_chain%first
dag_chain%first => null ()
allocate (dag_chain%first)
dag_chain%last => dag_chain%first
dag_chain%first%char_len = dag_chain%char_len
allocate (dag_chain%first%t (dag_chain%t_size))
filled_t = 0
do while (associated (current))
dag_chain%first%t(filled_t+1:filled_t+size(current%t)) = current%t
filled_t = filled_t + size (current%t)
remove => current
current => current%next
deallocate (remove)
end do
end subroutine dag_chain_compress
@ %def dag_chain_compress
@ Finalizer for [[dag_string_t]].
<<Cascades2 lexer: dag string: TBP>>=
procedure :: final => dag_string_final
<<Cascades2 lexer: sub interfaces>>=
module subroutine dag_string_final (dag_string)
class(dag_string_t), intent(inout) :: dag_string
end subroutine dag_string_final
<<Cascades2 lexer: procedures>>=
module subroutine dag_string_final (dag_string)
class(dag_string_t), intent(inout) :: dag_string
if (allocated (dag_string%t)) deallocate (dag_string%t)
dag_string%next => null ()
end subroutine dag_string_final
@ %def dag_string_final
@ Finalizer for [[dag_chain_t]].
<<Cascades2 lexer: dag chain: TBP>>=
procedure :: final => dag_chain_final
<<Cascades2 lexer: sub interfaces>>=
module subroutine dag_chain_final (dag_chain)
class(dag_chain_t), intent(inout) :: dag_chain
end subroutine dag_chain_final
<<Cascades2 lexer: procedures>>=
module subroutine dag_chain_final (dag_chain)
class(dag_chain_t), intent(inout) :: dag_chain
type(dag_string_t), pointer :: current
current => dag_chain%first
do while (associated (current))
dag_chain%first => dag_chain%first%next
call current%final ()
deallocate (current)
current => dag_chain%first
end do
dag_chain%last => null ()
end subroutine dag_chain_final
@ %def dag_chain_final
<<[[cascades2_lexer_ut.f90]]>>=
<<File header>>
module cascades2_lexer_ut
use unit_tests
use cascades2_lexer_uti
<<Standard module head>>
<<Cascades2 lexer: public test>>
contains
<<Cascades2 lexer: test driver>>
end module cascades2_lexer_ut
@ %def cascades2_lexer_ut
@
<<[[cascades2_lexer_uti.f90]]>>=
<<File header>>
module cascades2_lexer_uti
<<Use kinds>>
<<Use strings>>
use numeric_utils
use cascades2_lexer
<<Standard module head>>
<<Cascades2 lexer: test declarations>>
contains
<<Cascades2 lexer: tests>>
end module cascades2_lexer_uti
@ %def cascades2_lexer_uti
@ API: driver for the unit tests below.
<<Cascades2 lexer: public test>>=
public :: cascades2_lexer_test
<<Cascades2 lexer: test driver>>=
subroutine cascades2_lexer_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Cascades2 lexer: execute tests>>
end subroutine cascades2_lexer_test
@ %def cascades2_lexer_test
@
<<Cascades2 lexer: execute tests>>=
call test (cascades2_lexer_1, "cascades2_lexer_1", &
"make phase-space", u, results)
<<Cascades2 lexer: test declarations>>=
public :: cascades2_lexer_1
<<Cascades2 lexer: tests>>=
subroutine cascades2_lexer_1 (u)
integer, intent(in) :: u
integer :: u_in = 8
character(len=300) :: line
integer :: stat
logical :: fail
type(dag_string_t) :: dag_string
write (u, "(A)") "* Test output: cascades2_lexer_1"
write (u, "(A)") "* Purpose: read lines of O'Mega's phase space output, translate"
write (u, "(A)") "* to dag_string, retranslate to character string and"
write (u, "(A)") "* compare"
write (u, "(A)")
open (unit=u_in, file="cascades2_lexer_1.fds", status='old', action='read')
stat = 0
fail = .false.
read (unit=u_in, fmt="(A)", iostat=stat) line
do while (stat == 0 .and. .not. fail)
read (unit=u_in, fmt="(A)", iostat=stat) line
if (stat /= 0) exit
dag_string = line
fail = (char(dag_string) /= line)
end do
if (fail) then
write (u, "(A)") "* Test result: Test failed!"
else
write (u, "(A)") "* Test result: Test passed"
end if
close (u_in)
write (u, *)
write (u, "(A)") "* Test output end: cascades2_lexer_1"
end subroutine cascades2_lexer_1
@ %def cascades2_lexer_1
@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{An alternative cascades module}
This module might replace the module [[cascades]], which generates
suitable phase space parametrizations and generates the phase space file.
The mappings, as well as the criteria to determine these, do not change.
The advantage of this module is that it makes use of the [[O'Mega]] matrix
element generator which provides the relevant Feynman diagrams (the ones
which can be constructed only from 3-vertices). In principle, the
construction of these diagrams is also one of the tasks of the existing
[[cascades]] module, in which the diagrams would correspond to a set of
cascades. It starts by creating cascades which correspond to the
outgoing particles. These are combined to a new cascade using the
vertices of the model. In this way, since each cascade knows the
daughter cascades from which it is built, complete Feynman diagrams are
represented by sets of cascades, as soon as the existing cascades can be
recombined with the incoming particle(s).
In this module, the Feynman diagrams are represented by the type
[[feyngraph_t]], which represents the Feynman diagrams as a tree of
nodes. The object which contains the necessary kinematical information
to determine mappings, and hence sensible phase space parametrizations
is of another type, called [[kingraph_t]], which is built from a
corresponding [[feyngraph]] object.
There are two types of output which can be produced by [[O'Mega]] and
are potentially relevant here. The first type contains all tree
diagrams for the process under consideration, where each line of the
output corresponds to one Feynman diagram. This output is easy to read,
but can be very large, depending on the number of particles involved in
the process. Moreover, it repeats substructures of the diagrams which
are part of more than one diagram. One could in principle work with
this output and construct a [[feyngraph]] from each line, if allowed,
i.e. if there are only 3-vertices.
The other output contains also all of these Feynman diagrams, but in
a factorized form. This means that the substructures which appear in
several Feynman diagrams, are written only once, if possible. This
leads to a much shorter input file, which speeds up the parsing
process. Furthermore it makes it possible to reconstruct the
[[feyngraphs]] in such a way that the calculations concerning
subdiagrams which reappear in other [[feyngraphs]] have to be
performed only once. This is already the case in the existing
[[cascades]] module but can be exploited more efficiently here
because the possible graphs are well known from the input file, whereas
the [[cascades]] module would create a large number of [[cascades]]
which do not lead to a complete Feynman diagram of the given process.
<<[[cascades2.f90]]>>=
<<File header>>
module cascades2
use, intrinsic :: iso_fortran_env, only : input_unit, output_unit, error_unit
<<Use kinds>>
use kinds, only: TC, i8
<<Use strings>>
<<Use debug>>
use diagnostics
use flavors
use model_data
use phs_forests, only: phs_parameters_t
use resonances, only: resonance_info_t
use resonances, only: resonance_history_t
use resonances, only: resonance_history_set_t
use cascades2_lexer
<<Standard module head>>
<<Cascades2: public>>
<<Cascades2: parameters>>
<<Cascades2: types>>
<<Cascades2: interfaces>>
interface
<<Cascades2: sub interfaces>>
end interface
contains
<<Cascades2: main procedures>>
end module cascades2
@ %def cascades2
@
<<[[cascades2_sub.f90]]>>=
<<File header>>
submodule (cascades2) cascades2_s
use sorting
use io_units
use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
use hashes
use cascades, only: phase_space_vanishes, MAX_WARN_RESONANCE
implicit none
contains
<<Cascades2: procedures>>
end submodule cascades2_s
@ %def cascades2_s
@
\subsection{Particle properties}
We define a type holding the properties of the particles which are needed
for parsing and finding the phase space parametrizations and mappings.
The properties of all particles which appear in the parsed
Feynman diagrams for the given process will be stored in a central place,
and only pointers to these objects are used.
<<Cascades2: types>>=
type :: part_prop_t
character(len=LABEL_LEN) :: particle_label
integer :: pdg = 0
real(default) :: mass = 0.
real :: width = 0.
integer :: spin_type = 0
logical :: is_vector = .false.
logical :: empty = .true.
type(part_prop_t), pointer :: anti => null ()
type(string_t) :: tex_name
contains
<<Cascades2: part prop: TBP>>
end type part_prop_t
@ %def part_prop_t
@ The [[particle_label]] in [[part_prop_t]] is simply the particle name
(e.g. 'W+'). The corresponding variable in the type [[f_node_t]] contains
some additional information related to the external momenta, see below.
The length of the [[character]] variable is fixed as:
<<Cascades2: parameters>>=
integer, parameter :: LABEL_LEN=30
@ %def LABEL_LEN
<<Cascades2: part prop: TBP>>=
procedure :: final => part_prop_final
<<Cascades2: sub interfaces>>=
module subroutine part_prop_final (part)
class(part_prop_t), intent(inout) :: part
end subroutine part_prop_final
<<Cascades2: procedures>>=
module subroutine part_prop_final (part)
class(part_prop_t), intent(inout) :: part
part%anti => null ()
end subroutine part_prop_final
@ %def part_prop_final
@
\subsection{The mapping modes}
The possible mappings are essentially the same as in [[cascades]], but we
introduce in addition the mapping constant [[NON_RESONANT]], which does
not refer to a new mapping; it corresponds to the nonresonant version of
a potentially resonant particle (or [[k_node]]). This becomes relevant
when we compare [[k_nodes]] to eliminate equivalences.
<<Cascades2: parameters>>=
integer, parameter :: &
& NONRESONANT = -2, EXTERNAL_PRT = -1, &
& NO_MAPPING = 0, S_CHANNEL = 1, T_CHANNEL = 2, U_CHANNEL = 3, &
& RADIATION = 4, COLLINEAR = 5, INFRARED = 6, &
& STEP_MAPPING_E = 11, STEP_MAPPING_H = 12, &
& ON_SHELL = 99
@ %def NONRESONANT EXTERNAL_PRT
@ %def NO_MAPPING S_CHANNEL T_CHANNEL U_CHANNEL
@ %def RADIATION COLLINEAR INFRARED
@ %def STEP_MAPPING_E STEP_MAPPING_H
@ %def ON_SHELL
@
\subsection{Grove properties}
The channels or [[kingraphs]] will be grouped in groves, i.e. sets of
channels, which share some characteristic numbers. These numbers are
stored in the following type:
<<Cascades2: types>>=
type :: grove_prop_t
integer :: multiplicity = 0
integer :: n_resonances = 0
integer :: n_log_enhanced = 0
integer :: n_off_shell = 0
integer :: n_t_channel = 0
integer :: res_hash = 0
end type grove_prop_t
@ %def grove_prop_t
@
\subsection{The tree type}
This type contains all the information which is needed to
reconstruct a [[feyngraph]] or [[kingraph]]. We store bincodes, pdg codes
and mappings for all nodes of a valid [[kingraph]]. If we label the
external particles as given in the process definition with integer
numbers representing their position in the process definition, the bincode
would be the number that one obtains by setting the bit at the position
that is given by this number. If we combine two particles/nodes to a third
one (using a three-vertex of the given model), the bincode is the number which
one obtains by setting all the bits which are set for the two particles.
The [[pdg]] and [[mapping]] are simply the pdg-code and mapping at the
position (i.e. propagator or external particle) which is specified by the
corresponding bincode. We use [[tree_t]] not only for completed [[kingraphs]],
but also for all [[k_nodes]], which are a subtree of a [[kingraph]].
<<Cascades2: types>>=
type :: tree_t
integer(TC), dimension(:), allocatable :: bc
integer, dimension(:), allocatable :: pdg
integer, dimension(:), allocatable :: mapping
integer :: n_entries = 0
logical :: keep = .true.
logical :: empty = .true.
contains
<<Cascades2: tree: TBP>>
end type tree_t
@ %def tree_t
<<Cascades2: tree: TBP>>=
procedure :: final => tree_final
<<Cascades2: sub interfaces>>=
module subroutine tree_final (tree)
class(tree_t), intent(inout) :: tree
end subroutine tree_final
<<Cascades2: procedures>>=
module subroutine tree_final (tree)
class(tree_t), intent(inout) :: tree
if (allocated (tree%bc)) deallocate (tree%bc)
if (allocated (tree%pdg)) deallocate (tree%pdg)
if (allocated (tree%mapping)) deallocate (tree%mapping)
end subroutine tree_final
@ %def tree_final
<<Cascades2: interfaces>>=
interface assignment (=)
module procedure tree_assign
end interface assignment (=)
<<Cascades2: sub interfaces>>=
module subroutine tree_assign (tree1, tree2)
type(tree_t), intent(inout) :: tree1
type(tree_t), intent(in) :: tree2
end subroutine tree_assign
<<Cascades2: procedures>>=
module subroutine tree_assign (tree1, tree2)
type(tree_t), intent(inout) :: tree1
type(tree_t), intent(in) :: tree2
if (allocated (tree2%bc)) then
allocate (tree1%bc(size(tree2%bc)))
tree1%bc = tree2%bc
end if
if (allocated (tree2%pdg)) then
allocate (tree1%pdg(size(tree2%pdg)))
tree1%pdg = tree2%pdg
end if
if (allocated (tree2%mapping)) then
allocate (tree1%mapping(size(tree2%mapping)))
tree1%mapping = tree2%mapping
end if
tree1%n_entries = tree2%n_entries
tree1%keep = tree2%keep
tree1%empty = tree2%empty
end subroutine tree_assign
@ %def tree_assign
@
\subsection{Add entries to the tree}
The following procedures fill the arrays in [[tree_t]] with entries
resulting from the bincode and mapping assignment.
<<Cascades2: tree: TBP>>=
procedure :: add_entry_from_numbers => tree_add_entry_from_numbers
procedure :: add_entry_from_node => tree_add_entry_from_node
generic :: add_entry => add_entry_from_numbers, add_entry_from_node
@ Here we add a single entry to each of the arrays. This will exclusively
be used for external particles.
<<Cascades2: sub interfaces>>=
module subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping)
class(tree_t), intent(inout) :: tree
integer(TC), intent(in) :: bincode
integer, intent(in) :: pdg
integer, intent(in) :: mapping
end subroutine tree_add_entry_from_numbers
<<Cascades2: procedures>>=
module subroutine tree_add_entry_from_numbers (tree, bincode, pdg, mapping)
class(tree_t), intent(inout) :: tree
integer(TC), intent(in) :: bincode
integer, intent(in) :: pdg
integer, intent(in) :: mapping
integer :: pos
if (tree%empty) then
allocate (tree%bc(1))
allocate (tree%pdg(1))
allocate (tree%mapping(1))
pos = tree%n_entries + 1
tree%bc(pos) = bincode
tree%pdg(pos) = pdg
tree%mapping(pos) = mapping
tree%n_entries = pos
tree%empty = .false.
end if
end subroutine tree_add_entry_from_numbers
@ %def tree_add_entry_from_numbers
@ Here we merge two existing subtrees and a single entry (bc, pdg and
mapping).
<<Cascades2: procedures>>=
subroutine tree_merge (tree, tree1, tree2, bc, pdg, mapping)
class(tree_t), intent(inout) :: tree
type(tree_t), intent(in) :: tree1, tree2
integer(TC), intent(in) :: bc
integer, intent(in) :: pdg, mapping
integer :: tree_size
integer :: i1, i2
if (tree%empty) then
i1 = tree1%n_entries
i2 = tree1%n_entries + tree2%n_entries
!! Proof: tree_size > 0 (always)
tree_size = tree1%n_entries + tree2%n_entries + 1
allocate (tree%bc (tree_size))
allocate (tree%pdg (tree_size))
allocate (tree%mapping (tree_size))
if (.not. tree1%empty) then
tree%bc(:i1) = tree1%bc
tree%pdg(:i1) = tree1%pdg
tree%mapping(:i1) = tree1%mapping
end if
if (.not. tree2%empty) then
tree%bc(i1+1:i2) = tree2%bc
tree%pdg(i1+1:i2) = tree2%pdg
tree%mapping(i1+1:i2) = tree2%mapping
end if
tree%bc(tree_size) = bc
tree%pdg(tree_size) = pdg
tree%mapping(tree_size) = mapping
tree%n_entries = tree_size
tree%empty = .false.
end if
end subroutine tree_merge
@ %def tree_merge
@ Here we add entries to a tree for a given [[k_node]], which means that
we first have to determine whether the node is external or internal.
The arrays are sorted after the entries have been added (see below for
details).
<<Cascades2: sub interfaces>>=
module subroutine tree_add_entry_from_node (tree, node)
class(tree_t), intent(inout) :: tree
type(k_node_t), intent(in) :: node
end subroutine tree_add_entry_from_node
<<Cascades2: procedures>>=
module subroutine tree_add_entry_from_node (tree, node)
class(tree_t), intent(inout) :: tree
type(k_node_t), intent(in) :: node
integer :: pdg
if (node%t_line) then
pdg = abs (node%particle%pdg)
else
pdg = node%particle%pdg
end if
if (associated (node%daughter1) .and. &
associated (node%daughter2)) then
call tree_merge (tree, node%daughter1%subtree, &
node%daughter2%subtree, node%bincode, &
node%particle%pdg, node%mapping)
else
call tree_add_entry_from_numbers (tree, node%bincode, &
node%particle%pdg, node%mapping)
end if
call tree%sort ()
end subroutine tree_add_entry_from_node
@ %def tree_add_entry_from_node
@ For a well-defined order of the elements of the arrays in [[tree_t]],
the elements can be sorted. The bincodes (entries of [[bc]]) are
simply ordered by size, the [[pdg]] and [[mapping]] entries go to the
positions of the corresponding [[bc]] values.
<<Cascades2: tree: TBP>>=
procedure :: sort => tree_sort
<<Cascades2: sub interfaces>>=
module subroutine tree_sort (tree)
class(tree_t), intent(inout) :: tree
end subroutine tree_sort
<<Cascades2: procedures>>=
module subroutine tree_sort (tree)
class(tree_t), intent(inout) :: tree
integer(TC), dimension(size(tree%bc)) :: bc_tmp
integer, dimension(size(tree%pdg)) :: pdg_tmp, mapping_tmp
integer, dimension(1) :: pos
integer :: i
bc_tmp = tree%bc
pdg_tmp = tree%pdg
mapping_tmp = tree%mapping
do i = size(tree%bc),1,-1
pos = maxloc (bc_tmp)
tree%bc(i) = bc_tmp (pos(1))
tree%pdg(i) = pdg_tmp (pos(1))
tree%mapping(i) = mapping_tmp (pos(1))
bc_tmp(pos(1)) = 0
end do
end subroutine tree_sort
@ %def tree_sort
@
\subsection{Graph types}
We define an abstract type which will give rise to two different types:
The type [[feyngraph_t]] contains the pure information of the
corresponding Feynman diagram, but also a list of objects of the
[[kingraph]] type which contain the kinematically relevant data for the
mapping calculation as well as the mappings themselves. Every graph
should have an index which is unique. Graphs which are not needed any
more can be disabled by setting the [[keep]] variable to [[false]].
<<Cascades2: types>>=
type, abstract :: graph_t
integer :: index = 0
integer :: n_nodes = 0
logical :: keep = .true.
end type graph_t
@ %def graph_t
@ This is the type representing the Feynman diagrams which are read from
an input file created by O'Mega. It is a tree of nodes, which we call
[[f_nodes]], so that [[feyngraph_t]] contains a pointer to the root of
this tree, and each node can have two daughter nodes. The case of only
one associated daughter should never appear, because in the method of
phase space parametrization which is used here, we combine always two
particle momenta to a third one. The [[feyngraphs]] will be arranged in
a linked list. This is why we have a pointer to the next graph. The
[[kingraphs]] on the other hand are arranged in linked lists which are
attached to the corresponding [[feyngraph]]. In general, a [[feyngraph]]
can give rise to more than one [[kingraph]] because we make a copy
every time a particle can be resonant, so that in the copy we keep
the particle nonresonant.
<<Cascades2: types>>=
type, extends (graph_t) :: feyngraph_t
type(string_t) :: omega_feyngraph_output
type(f_node_t), pointer :: root => null ()
type(feyngraph_t), pointer :: next => null()
type(kingraph_t), pointer :: kin_first => null ()
type(kingraph_t), pointer :: kin_last => null ()
contains
<<Cascades2: feyngraph: TBP>>
end type feyngraph_t
@ %def feyngraph_t
@ A container for a pointer of type [[feyngraph_t]]. This is used to
realize arrays of these pointers.
<<Cascades2: types>>=
type :: feyngraph_ptr_t
type(feyngraph_t), pointer :: graph => null ()
end type feyngraph_ptr_t
@ %def feyngraph_ptr_t
@
The length of a string describing a Feynman diagram which is produced by
O'Mega is fixed by the parameter
<<Cascades2: parameters>>=
integer, parameter :: FEYNGRAPH_LEN=300
@ %def feyngraph_len
<<Cascades2: feyngraph: TBP>>=
procedure :: final => feyngraph_final
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_final (graph)
class(feyngraph_t), intent(inout) :: graph
end subroutine feyngraph_final
<<Cascades2: procedures>>=
module subroutine feyngraph_final (graph)
class(feyngraph_t), intent(inout) :: graph
type(kingraph_t), pointer :: current
graph%root => null ()
graph%kin_last => null ()
do while (associated (graph%kin_first))
current => graph%kin_first
graph%kin_first => graph%kin_first%next
call current%final ()
deallocate (current)
end do
end subroutine feyngraph_final
@ %def feyngraph_final
This is the type of graph which is used to find the phase space channels,
or in other words, each kingraph could correspond to a channel, if it is
not eliminated for kinematical reasons or due to an equivalence. For the
linked list which is attached to the corresponding [[feyngraph]], we
need the [[next]] pointer, whereas [[grove_next]] points to the next
[[kingraph]] within a grove. The information which is relevant for the
specification of a channel is stored in [[tree]]. We use [[grove_prop]]
to sort the [[kingraph]] in a grove in which all [[kingraphs]] are
characterized by the numbers contained in [[grove_prop]]. Later these
groves are further subdevided using the resonance hash. A [[kingraph]]
which is constructed directly from the output of O'Mega, is not
[[inverse]]. In this case the first incoming particle is the root ofthe
tree. In a scattering process, we can also construct a [[kingraph]]
where the root of the tree is the second incoming particle. In this
case the value of [[inverse]] is [[.true.]].
<<Cascades2: types>>=
type, extends (graph_t) :: kingraph_t
type(k_node_t), pointer :: root => null ()
type(kingraph_t), pointer :: next => null()
type(kingraph_t), pointer :: grove_next => null ()
type(tree_t) :: tree
type(grove_prop_t) :: grove_prop
logical :: inverse = .false.
integer :: prc_component = 0
contains
<<Cascades2: kingraph: TBP>>
end type kingraph_t
@ %def kingraph_t
@ Another container for a pointer to emulate arrays of pointers:
<<Cascades2: types>>=
type :: kingraph_ptr_t
type(kingraph_t), pointer :: graph => null ()
end type kingraph_ptr_t
@ %def kingraph_ptr_t
@
<<Cascades2: kingraph: TBP>>=
procedure :: final => kingraph_final
<<Cascades2: sub interfaces>>=
module subroutine kingraph_final (graph)
class(kingraph_t), intent(inout) :: graph
end subroutine kingraph_final
<<Cascades2: procedures>>=
module subroutine kingraph_final (graph)
class(kingraph_t), intent(inout) :: graph
graph%root => null ()
graph%next => null ()
graph%grove_next => null ()
call graph%tree%final ()
end subroutine kingraph_final
@ %def kingraph_final
@
\subsection{The node types}
We define an abstract type containing variables which are needed for
[[f_node_t]] as well as [[k_node_t]]. We say that a node is on the
t-line if it lies between the two nodes which correspond to the two
incoming particles. [[incoming]] and [[tline]] are used only for
scattering processes and remain [[.false.]] in decay processes. The
variable [[n_subtree_nodes]] holds the number of nodes (including the
node itself) of the subtree of which the node is the root.
<<Cascades2: types>>=
type, abstract :: node_t
type(part_prop_t), pointer :: particle => null ()
logical :: incoming = .false.
logical :: t_line = .false.
integer :: index = 0
logical :: keep = .true.
integer :: n_subtree_nodes = 1
end type node_t
@ %def node_t
@ We use two different list types for the different kinds of nodes. We
therefore start with an abstract type:
<<Cascades2: types>>=
type, abstract :: list_t
integer :: n_entries = 0
end type list_t
@ %def list_t
@ Since the contents of the lists are different, we introduce two
different entry types. Since the trees of nodes use pointers, the nodes
should only be allocated by a type-bound procedure of the corresponding
list type, such that we can keep track of all nodes, eventually reuse
and in the end deallocate nodes correctly, without forgetting any nodes.
Here is the type for the [[k_nodes]]. The list is a linked list. We want
to reuse (recycle) the [[k_nodes]] which are neither [[incoming]] nore
[[t_line]].
<<Cascades2: types>>=
type :: k_node_entry_t
type(k_node_t), pointer :: node => null ()
type(k_node_entry_t), pointer :: next => null ()
logical :: recycle = .false.
contains
<<Cascades2: k node entry: TBP>>
end type k_node_entry_t
@ %def k_node_entry_t
<<Cascades2: k node entry: TBP>>=
procedure :: final => k_node_entry_final
<<Cascades2: sub interfaces>>=
module subroutine k_node_entry_final (entry)
class(k_node_entry_t), intent(inout) :: entry
end subroutine k_node_entry_final
<<Cascades2: procedures>>=
module subroutine k_node_entry_final (entry)
class(k_node_entry_t), intent(inout) :: entry
if (associated (entry%node)) then
call entry%node%final
deallocate (entry%node)
end if
entry%next => null ()
end subroutine k_node_entry_final
@ %def k_node_entry_final
<<Cascades2: k node entry: TBP>>=
procedure :: write => k_node_entry_write
<<Cascades2: sub interfaces>>=
module subroutine k_node_entry_write (k_node_entry, u)
class(k_node_entry_t), intent(in) :: k_node_entry
integer, intent(in) :: u
end subroutine k_node_entry_write
<<Cascades2: procedures>>=
module subroutine k_node_entry_write (k_node_entry, u)
class(k_node_entry_t), intent(in) :: k_node_entry
integer, intent(in) :: u
end subroutine k_node_entry_write
@ %def k_node_entry_write
@ Here is the list type for [[k_nodes]]. A [[k_node_list]] can be
declared to be an observer. In this case it does not create any nodes by
itself, but the entries set their pointers to existing nodes. In this
way we can use the list structure and the type bound procedures for
existing nodes.
<<Cascades2: types>>=
type, extends (list_t) :: k_node_list_t
type(k_node_entry_t), pointer :: first => null ()
type(k_node_entry_t), pointer :: last => null ()
integer :: n_recycle
logical :: observer = .false.
contains
<<Cascades2: k node list: TBP>>
end type k_node_list_t
@ %def k_node_list_t
<<Cascades2: k node list: TBP>>=
procedure :: final => k_node_list_final
<<Cascades2: sub interfaces>>=
module subroutine k_node_list_final (list)
class(k_node_list_t), intent(inout) :: list
end subroutine k_node_list_final
<<Cascades2: procedures>>=
module subroutine k_node_list_final (list)
class(k_node_list_t), intent(inout) :: list
type(k_node_entry_t), pointer :: current
do while (associated (list%first))
current => list%first
list%first => list%first%next
if (list%observer) current%node => null ()
call current%final ()
deallocate (current)
end do
end subroutine k_node_list_final
@ %def k_node_list_final
@ The [[f_node_t]] type contains the [[particle_label]] variable which is
extracted from the input file. It consists not only of the particle
name, but also of some numbers in brackets. These numbers indicate which
external particles are part of the subtree of this node. The [[f_node]]
contains also a list of [[k_nodes]]. Therefore, if the nodes are not
[[incoming]] or [[t_line]], the mapping calculations for these
[[k_nodes]] which can appear in several [[kingraphs]] have to be
performed only once.
<<Cascades2: types>>=
type, extends (node_t) :: f_node_t
type(f_node_t), pointer :: daughter1 => null ()
type(f_node_t), pointer :: daughter2 => null ()
character(len=LABEL_LEN) :: particle_label
type(k_node_list_t) :: k_node_list
contains
<<Cascades2: f node: TBP>>
end type f_node_t
@ %def f_node_t
@ The finalizer nullifies the daughter pointers, since they are
deallocated, like the [[f_node]] itself, with the finalizer of the
[[f_node_list]].
<<Cascades2: f node: TBP>>=
procedure :: final => f_node_final
<<Cascades2: sub interfaces>>=
recursive module subroutine f_node_final (node)
class(f_node_t), intent(inout) :: node
end subroutine f_node_final
<<Cascades2: procedures>>=
recursive module subroutine f_node_final (node)
class(f_node_t), intent(inout) :: node
call node%k_node_list%final ()
node%daughter1 => null ()
node%daughter2 => null ()
end subroutine f_node_final
@ %def f_node_final
@ Finaliser for [[f_node_entry]].
<<Cascades2: f node entry: TBP>>=
procedure :: final => f_node_entry_final
<<Cascades2: sub interfaces>>=
module subroutine f_node_entry_final (entry)
class(f_node_entry_t), intent(inout) :: entry
end subroutine f_node_entry_final
<<Cascades2: procedures>>=
module subroutine f_node_entry_final (entry)
class(f_node_entry_t), intent(inout) :: entry
if (associated (entry%node)) then
call entry%node%final ()
deallocate (entry%node)
end if
entry%next => null ()
end subroutine f_node_entry_final
@ %def f_node_entry_final
@ Set index if not yet done, i.e. if it is zero.
<<Cascades2: f node: TBP>>=
procedure :: set_index => f_node_set_index
<<Cascades2: sub interfaces>>=
module subroutine f_node_set_index (f_node)
class(f_node_t), intent(inout) :: f_node
end subroutine f_node_set_index
<<Cascades2: procedures>>=
module subroutine f_node_set_index (f_node)
class(f_node_t), intent(inout) :: f_node
integer, save :: counter = 0
if (f_node%index == 0) then
counter = counter + 1
f_node%index = counter
end if
end subroutine f_node_set_index
@ %def f_node_set_index
@
Type for the nodes of the tree (lines of the Feynman diagrams). We
also need a type containing a pointer to a node, which is needed for
creating arrays of pointers. This will be used for scattering
processes where we can take either the first or the second particle to
be the root of the tree. Since we need both cases for the calculations
and O'Mega only gives us one of these, we have to perform a
transformation of the graph in which some nodes (on the line which we
hereafter call t-line) need to know their mother and sister nodes,
which become their daughters within this transformation.
<<Cascades2: types>>=
type :: f_node_ptr_t
type(f_node_t), pointer :: node => null ()
contains
<<Cascades2: f node ptr: TBP>>
end type f_node_ptr_t
@ %def f_node_ptr_t
<<Cascades2: f node ptr: TBP>>=
procedure :: final => f_node_ptr_final
<<Cascades2: sub interfaces>>=
module subroutine f_node_ptr_final (f_node_ptr)
class(f_node_ptr_t), intent(inout) :: f_node_ptr
end subroutine f_node_ptr_final
<<Cascades2: procedures>>=
module subroutine f_node_ptr_final (f_node_ptr)
class(f_node_ptr_t), intent(inout) :: f_node_ptr
f_node_ptr%node => null ()
end subroutine f_node_ptr_final
@ %def f_node_ptr_final
<<Cascades2: interfaces>>=
interface assignment (=)
module procedure f_node_ptr_assign
end interface assignment (=)
<<Cascades2: sub interfaces>>=
module subroutine f_node_ptr_assign (ptr1, ptr2)
type(f_node_ptr_t), intent(out) :: ptr1
type(f_node_ptr_t), intent(in) :: ptr2
end subroutine f_node_ptr_assign
<<Cascades2: procedures>>=
module subroutine f_node_ptr_assign (ptr1, ptr2)
type(f_node_ptr_t), intent(out) :: ptr1
type(f_node_ptr_t), intent(in) :: ptr2
ptr1%node => ptr2%node
end subroutine f_node_ptr_assign
@ %def f_node_ptr_assign
@
<<Cascades2: types>>=
type :: k_node_ptr_t
type(k_node_t), pointer :: node => null ()
end type k_node_ptr_t
@ %def k_node_ptr_t
@
<<Cascades2: types>>=
type, extends (node_t) :: k_node_t
type(k_node_t), pointer :: daughter1 => null ()
type(k_node_t), pointer :: daughter2 => null ()
type(k_node_t), pointer :: inverse_daughter1 => null ()
type(k_node_t), pointer :: inverse_daughter2 => null ()
type(f_node_t), pointer :: f_node => null ()
type(tree_t) :: subtree
real (default) :: ext_mass_sum = 0.
real (default) :: effective_mass = 0.
logical :: resonant = .false.
logical :: on_shell = .false.
logical :: log_enhanced = .false.
integer :: mapping = NO_MAPPING
integer(TC) :: bincode = 0
logical :: mapping_assigned = .false.
logical :: is_nonresonant_copy = .false.
logical :: subtree_checked = .false.
integer :: n_off_shell = 0
integer :: n_log_enhanced = 0
integer :: n_resonances = 0
integer :: multiplicity = 0
integer :: n_t_channel = 0
integer :: f_node_index = 0
contains
<<Cascades2: k node: TBP>>
end type k_node_t
@ %def k_node_t
@
Subroutine for [[k_node]] assignment.
<<Cascades2: interfaces>>=
interface assignment (=)
module procedure k_node_assign
end interface assignment (=)
<<Cascades2: sub interfaces>>=
module subroutine k_node_assign (k_node1, k_node2)
type(k_node_t), intent(inout) :: k_node1
type(k_node_t), intent(in) :: k_node2
end subroutine k_node_assign
<<Cascades2: procedures>>=
module subroutine k_node_assign (k_node1, k_node2)
type(k_node_t), intent(inout) :: k_node1
type(k_node_t), intent(in) :: k_node2
k_node1%f_node => k_node2%f_node
k_node1%particle => k_node2%particle
k_node1%incoming = k_node2%incoming
k_node1%t_line = k_node2%t_line
k_node1%keep = k_node2%keep
k_node1%n_subtree_nodes = k_node2%n_subtree_nodes
k_node1%ext_mass_sum = k_node2%ext_mass_sum
k_node1%effective_mass = k_node2%effective_mass
k_node1%resonant = k_node2%resonant
k_node1%on_shell = k_node2%on_shell
k_node1%log_enhanced = k_node2%log_enhanced
k_node1%mapping = k_node2%mapping
k_node1%bincode = k_node2%bincode
k_node1%mapping_assigned = k_node2%mapping_assigned
k_node1%is_nonresonant_copy = k_node2%is_nonresonant_copy
k_node1%n_off_shell = k_node2%n_off_shell
k_node1%n_log_enhanced = k_node2%n_log_enhanced
k_node1%n_resonances = k_node2%n_resonances
k_node1%multiplicity = k_node2%multiplicity
k_node1%n_t_channel = k_node2%n_t_channel
k_node1%f_node_index = k_node2%f_node_index
end subroutine k_node_assign
@ %def k_node_assign
@ The finalizer of [[k_node_t]] nullifies all pointers to nodes, since the
deallocation of these nodes takes place in the finalizer of the list by which
they were created.
<<Cascades2: k node: TBP>>=
procedure :: final => k_node_final
<<Cascades2: sub interfaces>>=
recursive module subroutine k_node_final (k_node)
class(k_node_t), intent(inout) :: k_node
end subroutine k_node_final
<<Cascades2: procedures>>=
recursive module subroutine k_node_final (k_node)
class(k_node_t), intent(inout) :: k_node
k_node%daughter1 => null ()
k_node%daughter2 => null ()
k_node%inverse_daughter1 => null ()
k_node%inverse_daughter2 => null ()
k_node%f_node => null ()
end subroutine k_node_final
@ %def k_node_final
@ Set an index to a [[k_node]], if not yet done, i.e. if it is zero. The
indices are simply positive integer numbers starting from 1.
<<Cascades2: k node: TBP>>=
procedure :: set_index => k_node_set_index
<<Cascades2: sub interfaces>>=
module subroutine k_node_set_index (k_node)
class(k_node_t), intent(inout) :: k_node
end subroutine k_node_set_index
<<Cascades2: procedures>>=
module subroutine k_node_set_index (k_node)
class(k_node_t), intent(inout) :: k_node
integer, save :: counter = 0
if (k_node%index == 0) then
counter = counter + 1
k_node%index = counter
end if
end subroutine k_node_set_index
@ %def k_node_set_index
@ The process type (decay or scattering) is given by an integer which is
equal to the number of incoming particles.
<<Cascades2: public>>=
public :: DECAY, SCATTERING
<<Cascades2: parameters>>=
integer, parameter :: DECAY=1, SCATTERING=2
@ %def decay scattering
@ The entries of the [[f_node_list]] contain the substring of the input
file from which the node's subtree will be constructed (or a modified
string containing placeholders for substrings). We use the
length of this string for fast comparison to find the nodes in the
[[f_node_list]] which we want to reuse.
<<Cascades2: types>>=
type :: f_node_entry_t
character(len=FEYNGRAPH_LEN) :: subtree_string
integer :: string_len = 0
type(f_node_t), pointer :: node => null ()
type(f_node_entry_t), pointer :: next => null ()
integer :: subtree_size = 0
contains
<<Cascades2: f node entry: TBP>>
end type f_node_entry_t
@ %def f_node_entry_t
@ A write method for [[f_node_entry]].
<<Cascades2: f node entry: TBP>>=
procedure :: write => f_node_entry_write
<<Cascades2: sub interfaces>>=
module subroutine f_node_entry_write (f_node_entry, u)
class(f_node_entry_t), intent(in) :: f_node_entry
integer, intent(in) :: u
end subroutine f_node_entry_write
<<Cascades2: procedures>>=
module subroutine f_node_entry_write (f_node_entry, u)
class(f_node_entry_t), intent(in) :: f_node_entry
integer, intent(in) :: u
write (unit=u, fmt='(A)') trim(f_node_entry%subtree_string)
end subroutine f_node_entry_write
@ %def f_node_entry_write
<<Cascades2: interfaces>>=
interface assignment (=)
module procedure f_node_entry_assign
end interface assignment (=)
<<Cascades2: sub interfaces>>=
module subroutine f_node_entry_assign (entry1, entry2)
type(f_node_entry_t), intent(out) :: entry1
type(f_node_entry_t), intent(in) :: entry2
end subroutine f_node_entry_assign
<<Cascades2: procedures>>=
module subroutine f_node_entry_assign (entry1, entry2)
type(f_node_entry_t), intent(out) :: entry1
type(f_node_entry_t), intent(in) :: entry2
entry1%node => entry2%node
entry1%subtree_string = entry2%subtree_string
entry1%string_len = entry2%string_len
entry1%subtree_size = entry2%subtree_size
end subroutine f_node_entry_assign
@ %def f_node_entry_assign
@ This is the list type for [[f_nodes]]. The variable [[max_tree_size]]
is the number of nodes which appear in a complete graph.
<<Cascades2: types>>=
type, extends (list_t) :: f_node_list_t
type(f_node_entry_t), pointer :: first => null ()
type(f_node_entry_t), pointer :: last => null ()
type(k_node_list_t), pointer :: k_node_list => null ()
integer :: max_tree_size = 0
contains
<<Cascades2: f node list: TBP>>
end type f_node_list_t
@ %def f_node_list_t
@ Add an entry to the [[f_node_list]]. If the node might be reused, we check first
using the [[subtree_string]] if there is already a node in the list which
is the root of exactly the same subtree. Otherwise we add an entry to the
list and allocate the node. In both cases we return a pointer to the node
which allows to access the node.
<<Cascades2: f node list: TBP>>=
procedure :: add_entry => f_node_list_add_entry
<<Cascades2: sub interfaces>>=
module subroutine f_node_list_add_entry (list, subtree_string, &
ptr_to_node, recycle, subtree_size)
class(f_node_list_t), intent(inout) :: list
character(len=*), intent(in) :: subtree_string
type(f_node_t), pointer, intent(out) :: ptr_to_node
logical, intent(in) :: recycle
integer, intent(in), optional :: subtree_size
end subroutine f_node_list_add_entry
<<Cascades2: procedures>>=
module subroutine f_node_list_add_entry (list, subtree_string, &
ptr_to_node, recycle, subtree_size)
class(f_node_list_t), intent(inout) :: list
character(len=*), intent(in) :: subtree_string
type(f_node_t), pointer, intent(out) :: ptr_to_node
logical, intent(in) :: recycle
integer, intent(in), optional :: subtree_size
type(f_node_entry_t), pointer :: current
type(f_node_entry_t), pointer :: second
integer :: subtree_len
ptr_to_node => null ()
if (recycle) then
subtree_len = len_trim (subtree_string)
current => list%first
do while (associated (current))
if (present (subtree_size)) then
if (current%subtree_size /= subtree_size) exit
end if
if (current%string_len == subtree_len) then
if (trim (current%subtree_string) == trim (subtree_string)) then
ptr_to_node => current%node
exit
end if
end if
current => current%next
end do
end if
if (.not. associated (ptr_to_node)) then
if (list%n_entries == 0) then
allocate (list%first)
list%last => list%first
else
second => list%first
list%first => null ()
allocate (list%first)
list%first%next => second
end if
list%n_entries = list%n_entries + 1
list%first%subtree_string = trim(subtree_string)
list%first%string_len = subtree_len
if (present (subtree_size)) list%first%subtree_size = subtree_size
allocate (list%first%node)
call list%first%node%set_index ()
ptr_to_node => list%first%node
end if
end subroutine f_node_list_add_entry
@ %def f_node_list_add_entry
@ A write method for debugging.
<<Cascades2: f node list: TBP>>=
procedure :: write => f_node_list_write
<<Cascades2: sub interfaces>>=
module subroutine f_node_list_write (f_node_list, u)
class(f_node_list_t), intent(in) :: f_node_list
integer, intent(in) :: u
end subroutine f_node_list_write
<<Cascades2: procedures>>=
module subroutine f_node_list_write (f_node_list, u)
class(f_node_list_t), intent(in) :: f_node_list
integer, intent(in) :: u
type(f_node_entry_t), pointer :: current
integer :: pos = 0
current => f_node_list%first
do while (associated (current))
pos = pos + 1
write (unit=u, fmt='(A,I10)') 'entry #: ', pos
call current%write (u)
write (unit=u, fmt=*)
current => current%next
end do
end subroutine f_node_list_write
@ %def f_node_list_write
<<Cascades2: interfaces>>=
interface assignment (=)
module procedure k_node_entry_assign
end interface assignment (=)
<<Cascades2: sub interfaces>>=
module subroutine k_node_entry_assign (entry1, entry2)
type(k_node_entry_t), intent(out) :: entry1
type(k_node_entry_t), intent(in) :: entry2
end subroutine k_node_entry_assign
<<Cascades2: procedures>>=
module subroutine k_node_entry_assign (entry1, entry2)
type(k_node_entry_t), intent(out) :: entry1
type(k_node_entry_t), intent(in) :: entry2
entry1%node => entry2%node
entry1%recycle = entry2%recycle
end subroutine k_node_entry_assign
@ %def k_node_entry_assign
@ Add an entry to the [[k_node_list]]. We have to specify if the
node can be reused. The check for existing reusable nodes happens with
[[k_node_list_get_nodes]] (see below).
<<Cascades2: k node list: TBP>>=
procedure :: add_entry => k_node_list_add_entry
<<Cascades2: sub interfaces>>=
recursive module subroutine k_node_list_add_entry &
(list, ptr_to_node, recycle)
class(k_node_list_t), intent(inout) :: list
type(k_node_t), pointer, intent(out) :: ptr_to_node
logical, intent(in) :: recycle
end subroutine k_node_list_add_entry
<<Cascades2: procedures>>=
recursive module subroutine k_node_list_add_entry &
(list, ptr_to_node, recycle)
class(k_node_list_t), intent(inout) :: list
type(k_node_t), pointer, intent(out) :: ptr_to_node
logical, intent(in) :: recycle
if (list%n_entries == 0) then
allocate (list%first)
list%last => list%first
else
allocate (list%last%next)
list%last => list%last%next
end if
list%n_entries = list%n_entries + 1
list%last%recycle = recycle
allocate (list%last%node)
call list%last%node%set_index ()
ptr_to_node => list%last%node
end subroutine k_node_list_add_entry
@ %def k_node_list_add_entry
@ We need a similar subroutine for adding only a pointer to a list. This
is needed for a [[k_node_list]] which is only an observer, i.e. it does
not create any nodes by itself.
<<Cascades2: k node list: TBP>>=
procedure :: add_pointer => k_node_list_add_pointer
<<Cascades2: sub interfaces>>=
module subroutine k_node_list_add_pointer (list, ptr_to_node, recycle)
class(k_node_list_t), intent(inout) :: list
type(k_node_t), pointer, intent(in) :: ptr_to_node
logical, optional, intent(in) :: recycle
end subroutine k_node_list_add_pointer
<<Cascades2: procedures>>=
module subroutine k_node_list_add_pointer (list, ptr_to_node, recycle)
class(k_node_list_t), intent(inout) :: list
type(k_node_t), pointer, intent(in) :: ptr_to_node
logical, optional, intent(in) :: recycle
logical :: rec
if (present (recycle)) then
rec = recycle
else
rec = .false.
end if
if (list%n_entries == 0) then
allocate (list%first)
list%last => list%first
else
allocate (list%last%next)
list%last => list%last%next
end if
list%n_entries = list%n_entries + 1
list%last%recycle = rec
list%last%node => ptr_to_node
end subroutine k_node_list_add_pointer
@ %def k_node_list_add_pointer
@ The [[k_node_list]] can also be used to collect [[k_nodes]] which belong to
different [[f_nodes]] in order to compare these. This is done only for nodes
which have the same number of subtree nodes. We compare all nodes of the
list with each other (as long as the node is not deactivated, i.e. if
the [[keep]] variable is set to [[.true.]]) using the subroutine
[[subtree_select]]. If it turns out that two nodes are equivalent, we
keep only one of them. The term equivalent in this module refers to trees
or subtrees which differ in the pdg codes at positions where
the trivial mapping is used ([[NO_MAPPING]] or [[NON_RESONANT]]) so that
the mass of the particle does not matter. Depending on the available
couplings, two equivalent subtrees could eventually lead to the same phase
space channels, which is why only one of them is kept.
<<Cascades2: k node list: TBP>>=
procedure :: check_subtree_equivalences => &
k_node_list_check_subtree_equivalences
<<Cascades2: sub interfaces>>=
module subroutine k_node_list_check_subtree_equivalences (list, model)
class(k_node_list_t), intent(inout) :: list
type(model_data_t), intent(in) :: model
end subroutine k_node_list_check_subtree_equivalences
<<Cascades2: procedures>>=
module subroutine k_node_list_check_subtree_equivalences (list, model)
class(k_node_list_t), intent(inout) :: list
type(model_data_t), intent(in) :: model
type(k_node_ptr_t), dimension (:), allocatable :: set
type(k_node_entry_t), pointer :: current
integer :: pos
integer :: i,j
if (list%n_entries == 0) return
allocate (set (list%n_entries))
current => list%first
pos = 0
do while (associated (current))
pos = pos + 1
set(pos)%node => current%node
current => current%next
end do
do i=1, list%n_entries
if (set(i)%node%keep) then
do j=i+1, list%n_entries
if (set(j)%node%keep) then
if (set(i)%node%bincode == set(j)%node%bincode) then
call subtree_select (set(i)%node%subtree,set(j)%node%subtree, model)
if (.not. set(i)%node%subtree%keep) then
set(i)%node%keep = .false.
exit
else if (.not. set(j)%node%subtree%keep) then
set(j)%node%keep = .false.
end if
end if
end if
end do
end if
end do
deallocate (set)
end subroutine k_node_list_check_subtree_equivalences
@ %def k_node_list_check_subtree_equivalences
@ This subroutine is used to obtain all [[k_nodes]] of a [[k_node_list]]
which can be recycled and are not disabled for some reason. We pass an
allocatable array of the type [[k_node_ptr_t]] which will be allocated
if there are any such nodes in the list and the pointers will be
associated with these nodes.
<<Cascades2: k node list: TBP>>=
procedure :: get_nodes => k_node_list_get_nodes
<<Cascades2: sub interfaces>>=
module subroutine k_node_list_get_nodes (list, nodes)
class(k_node_list_t), intent(inout) :: list
type(k_node_ptr_t), dimension(:), allocatable, intent(out) :: nodes
end subroutine k_node_list_get_nodes
<<Cascades2: procedures>>=
module subroutine k_node_list_get_nodes (list, nodes)
class(k_node_list_t), intent(inout) :: list
type(k_node_ptr_t), dimension(:), allocatable, intent(out) :: nodes
integer :: n_nodes
integer :: pos
type(k_node_entry_t), pointer :: current, garbage
n_nodes = 0
current => list%first
do while (associated (current))
if (current%recycle .and. current%node%keep) n_nodes = n_nodes + 1
current => current%next
end do
if (n_nodes /= 0) then
pos = 1
allocate (nodes (n_nodes))
do while (associated (list%first) .and. .not. list%first%node%keep)
garbage => list%first
list%first => list%first%next
call garbage%final ()
deallocate (garbage)
end do
current => list%first
do while (associated (current))
do while (associated (current%next))
if (.not. current%next%node%keep) then
garbage => current%next
current%next => current%next%next
call garbage%final
deallocate (garbage)
else
exit
end if
end do
if (current%recycle .and. current%node%keep) then
nodes(pos)%node => current%node
pos = pos + 1
end if
current => current%next
end do
end if
end subroutine k_node_list_get_nodes
@ %def k_node_list_get_nodes
Gfortran 7/8/9 bug, has to remain in the main module:
<<Cascades2: f node list: TBP>>=
procedure :: final => f_node_list_final
<<Cascades2: main procedures>>=
subroutine f_node_list_final (list)
class(f_node_list_t) :: list
type(f_node_entry_t), pointer :: current
list%k_node_list => null ()
do while (associated (list%first))
current => list%first
list%first => list%first%next
call current%final ()
deallocate (current)
end do
end subroutine f_node_list_final
@ %def f_node_list_final
@
\subsection{The grove list}
First a type is introduced in order to speed up the comparison of kingraphs
with the purpose to quickly find the graphs that might be equivalent.
This is done solely on the basis of a number (which is given
by the value of [[depth]] in [[compare_tree_t]]) of bincodes, which are
the highest ones that do not belong to external particles.
The highest such value determines the index of the element in the [[entry]]
array of the [[compare_tree]]. The next lower such value determines
the index of the element in the [[entry]] array of this [[entry]], and so
on and so forth. This results in a tree structure where the number of
levels is given by [[depth]] and should not be too large for reasons of
memory.
This is the entry type.
<<Cascades2: types>>=
type :: compare_tree_entry_t
type(compare_tree_entry_t), dimension(:), pointer :: entry => null ()
type(kingraph_ptr_t), dimension(:), allocatable :: graph_entry
contains
<<Cascades2: compare tree entry: TBP>>
end type compare_tree_entry_t
@ %def compare_tree_entry_t
@ This is the tree type.
<<Cascades2: types>>=
type :: compare_tree_t
integer :: depth = 3
type(compare_tree_entry_t), dimension(:), pointer :: entry => null ()
contains
<<Cascades2: compare tree: TBP>>
end type compare_tree_t
@ %def compare_tree_t
@ Finalizers for both types. The one for the entry type has to be recursive.
<<Cascades2: compare tree: TBP>>=
procedure :: final => compare_tree_final
<<Cascades2: sub interfaces>>=
module subroutine compare_tree_final (ctree)
class(compare_tree_t), intent(inout) :: ctree
end subroutine compare_tree_final
<<Cascades2: procedures>>=
module subroutine compare_tree_final (ctree)
class(compare_tree_t), intent(inout) :: ctree
integer :: i
if (associated (ctree%entry)) then
do i=1, size (ctree%entry)
call ctree%entry(i)%final ()
deallocate (ctree%entry)
end do
end if
end subroutine compare_tree_final
@ %def compare_tree_final
<<Cascades2: compare tree entry: TBP>>=
procedure :: final => compare_tree_entry_final
<<Cascades2: sub interfaces>>=
recursive module subroutine compare_tree_entry_final (ct_entry)
class(compare_tree_entry_t), intent(inout) :: ct_entry
end subroutine compare_tree_entry_final
<<Cascades2: procedures>>=
recursive module subroutine compare_tree_entry_final (ct_entry)
class(compare_tree_entry_t), intent(inout) :: ct_entry
integer :: i
if (associated (ct_entry%entry)) then
do i=1, size (ct_entry%entry)
call ct_entry%entry(i)%final ()
end do
deallocate (ct_entry%entry)
else
deallocate (ct_entry%graph_entry)
end if
end subroutine compare_tree_entry_final
@ %def compare_tree_entry_final
@ Check the presence of a graph which is considered as equivalent and
select between the two. If there is no such graph, the current one
is added to the list. First the entry has to be found:
<<Cascades2: compare tree: TBP>>=
procedure :: check_kingraph => compare_tree_check_kingraph
<<Cascades2: sub interfaces>>=
module subroutine compare_tree_check_kingraph &
(ctree, kingraph, model, preliminary)
class(compare_tree_t), intent(inout) :: ctree
type(kingraph_t), intent(inout), pointer :: kingraph
type(model_data_t), intent(in) :: model
logical, intent(in) :: preliminary
end subroutine compare_tree_check_kingraph
<<Cascades2: procedures>>=
module subroutine compare_tree_check_kingraph &
(ctree, kingraph, model, preliminary)
class(compare_tree_t), intent(inout) :: ctree
type(kingraph_t), intent(inout), pointer :: kingraph
type(model_data_t), intent(in) :: model
logical, intent(in) :: preliminary
integer :: i
integer :: pos
integer(TC) :: sz
integer(TC), dimension(:), allocatable :: identifier
if (.not. associated (ctree%entry)) then
sz = 0_TC
do i = size(kingraph%tree%bc), 1, -1
sz = ior (sz, kingraph%tree%bc(i))
end do
if (sz > 0) then
allocate (ctree%entry (sz))
else
call msg_bug ("Compare tree could not be created")
end if
end if
allocate (identifier (ctree%depth))
pos = 0
do i = size(kingraph%tree%bc), 1, -1
if (popcnt (kingraph%tree%bc(i)) /= 1) then
pos = pos + 1
identifier(pos) = kingraph%tree%bc(i)
if (pos == ctree%depth) exit
end if
end do
if (size (identifier) > 1) then
call ctree%entry(identifier(1))%check_kingraph (kingraph, model, &
preliminary, identifier(1), identifier(2:))
else if (size (identifier) == 1) then
call ctree%entry(identifier(1))%check_kingraph &
(kingraph, model, preliminary)
end if
deallocate (identifier)
end subroutine compare_tree_check_kingraph
@ %def compare_tree_check_kingraph
@ Then the graphs of the entry are checked.
<<Cascades2: compare tree entry: TBP>>=
procedure :: check_kingraph => compare_tree_entry_check_kingraph
<<Cascades2: sub interfaces>>=
recursive module subroutine compare_tree_entry_check_kingraph (ct_entry, &
kingraph, model, preliminary, subtree_size, identifier)
class(compare_tree_entry_t), intent(inout) :: ct_entry
type(kingraph_t), pointer, intent(inout) :: kingraph
type(model_data_t), intent(in) :: model
logical, intent(in) :: preliminary
integer, intent(in), optional :: subtree_size
integer, dimension (:), intent(in), optional :: identifier
end subroutine compare_tree_entry_check_kingraph
<<Cascades2: procedures>>=
recursive module subroutine compare_tree_entry_check_kingraph (ct_entry, &
kingraph, model, preliminary, subtree_size, identifier)
class(compare_tree_entry_t), intent(inout) :: ct_entry
type(kingraph_t), pointer, intent(inout) :: kingraph
type(model_data_t), intent(in) :: model
logical, intent(in) :: preliminary
integer, intent(in), optional :: subtree_size
integer, dimension (:), intent(in), optional :: identifier
if (present (identifier)) then
if (.not. associated (ct_entry%entry)) &
allocate (ct_entry%entry(subtree_size))
if (size (identifier) > 1) then
call ct_entry%entry(identifier(1))%check_kingraph (kingraph, &
model, preliminary, identifier(1), identifier(2:))
else if (size (identifier) == 1) then
call ct_entry%entry(identifier(1))%check_kingraph (kingraph, &
model, preliminary)
end if
else
if (allocated (ct_entry%graph_entry)) then
call perform_check
else
allocate (ct_entry%graph_entry(1))
ct_entry%graph_entry(1)%graph => kingraph
end if
end if
contains
subroutine perform_check
integer :: i
logical :: rebuild
rebuild = .true.
do i=1, size(ct_entry%graph_entry)
if (ct_entry%graph_entry(i)%graph%keep) then
if (preliminary .or. &
ct_entry%graph_entry(i)%graph%prc_component /= &
kingraph%prc_component) then
call kingraph_select (ct_entry%graph_entry(i)%graph, &
kingraph, model, preliminary)
if (.not. kingraph%keep) then
return
else if (rebuild .and. .not. &
ct_entry%graph_entry(i)%graph%keep) then
ct_entry%graph_entry(i)%graph => kingraph
rebuild = .false.
end if
end if
end if
end do
if (rebuild) call rebuild_graph_entry
end subroutine perform_check
subroutine rebuild_graph_entry
type(kingraph_ptr_t), dimension(:), allocatable :: tmp_ptr
integer :: i
integer :: pos
allocate (tmp_ptr(size(ct_entry%graph_entry)+1))
pos = 0
do i=1, size(ct_entry%graph_entry)
pos = pos + 1
tmp_ptr(pos)%graph => ct_entry%graph_entry(i)%graph
end do
pos = pos + 1
tmp_ptr(pos)%graph => kingraph
deallocate (ct_entry%graph_entry)
allocate (ct_entry%graph_entry (pos))
do i=1, pos
ct_entry%graph_entry(i)%graph => tmp_ptr(i)%graph
end do
deallocate (tmp_ptr)
end subroutine rebuild_graph_entry
end subroutine compare_tree_entry_check_kingraph
@ %def compare_tree_entry_check_kingraph
@ The grove to which a completed [[kingraph]] will be added is determined by the
entries of [[grove_prop]]. We use another list type (linked list) to
arrange the groves. Each [[grove]] contains again a linked list of
[[kingraphs]].
<<Cascades2: types>>=
type :: grove_t
type(grove_prop_t) :: grove_prop
type(grove_t), pointer :: next => null ()
type(kingraph_t), pointer :: first => null ()
type(kingraph_t), pointer :: last => null ()
type(compare_tree_t) :: compare_tree
contains
<<Cascades2: grove: TBP>>
end type grove_t
@ %def grove_t
@ Container for a pointer of type [[grove_t]]:
<<Cascades2: types>>=
type :: grove_ptr_t
type(grove_t), pointer :: grove => null ()
end type grove_ptr_t
@ %def grove_ptr_t
<<Cascades2: grove: TBP>>=
procedure :: final => grove_final
<<Cascades2: sub interfaces>>=
module subroutine grove_final (grove)
class(grove_t), intent(inout) :: grove
end subroutine grove_final
<<Cascades2: procedures>>=
module subroutine grove_final (grove)
class(grove_t), intent(inout) :: grove
grove%first => null ()
grove%last => null ()
grove%next => null ()
end subroutine grove_final
@ %def grove_final
@ This is the list type:
<<Cascades2: types>>=
type :: grove_list_t
type(grove_t), pointer :: first => null ()
contains
<<Cascades2: grove list: TBP>>
end type grove_list_t
@ %def grove_list_t
Gfortran 7/8/9 bug, has to remain in the main module:
<<Cascades2: grove list: TBP>>=
procedure :: final => grove_list_final
<<Cascades2: main procedures>>=
subroutine grove_list_final (list)
class(grove_list_t), intent(inout) :: list
class(grove_t), pointer :: current
do while (associated (list%first))
current => list%first
list%first => list%first%next
call current%final ()
deallocate (current)
end do
end subroutine grove_list_final
@ %def grove_list_final
@
\subsection{The feyngraph set}
The fundament of the module is the public type [[feyngraph_set_t]]. It
is not only a linked list of all [[feyngraphs]] but contains an array
of all particle properties ([[particle]]), an [[f_node_list]] and a
pointer of the type [[grove_list_t]], since several [[feyngraph_sets]]
can share a common [[grove_list]]. In addition it keeps the data which
unambiguously specifies the process, as well as the model which
provides information which allows us to choose between equivalent
subtrees or complete [[kingraphs]].
<<Cascades2: public>>=
public :: feyngraph_set_t
<<Cascades2: types>>=
type :: feyngraph_set_t
type(model_data_t), pointer :: model => null ()
type(flavor_t), dimension(:,:), allocatable :: flv
integer :: n_in = 0
integer :: n_out = 0
integer :: process_type = DECAY
type(phs_parameters_t) :: phs_par
logical :: fatal_beam_decay = .true.
type(part_prop_t), dimension (:), pointer :: particle => null ()
type(f_node_list_t) :: f_node_list
type(feyngraph_t), pointer :: first => null ()
type(feyngraph_t), pointer :: last => null ()
integer :: n_graphs = 0
type(grove_list_t), pointer :: grove_list => null ()
logical :: use_dag = .true.
type(dag_t), pointer :: dag => null ()
type(feyngraph_set_t), dimension (:), pointer :: fset => null ()
contains
<<Cascades2: feyngraph set: TBP>>
end type feyngraph_set_t
@ %def feyngraph_set_t
@ This final procedure contains calls to all other necessary final
procedures. Gfortran 7/8/9 bug, has to remain in the main module:
<<Cascades2: feyngraph set: TBP>>=
procedure :: final => feyngraph_set_final
<<Cascades2: main procedures>>=
recursive subroutine feyngraph_set_final (set)
class(feyngraph_set_t), intent(inout) :: set
class(feyngraph_t), pointer :: current
integer :: i
if (associated (set%fset)) then
do i=1, size (set%fset)
call set%fset(i)%final ()
end do
deallocate (set%fset)
else
set%particle => null ()
set%grove_list => null ()
end if
set%model => null ()
if (allocated (set%flv)) deallocate (set%flv)
set%last => null ()
do while (associated (set%first))
current => set%first
set%first => set%first%next
call current%final ()
deallocate (current)
end do
if (associated (set%particle)) then
do i = 1, size (set%particle)
call set%particle(i)%final ()
end do
deallocate (set%particle)
end if
if (associated (set%grove_list)) then
if (debug_on) call msg_debug (D_PHASESPACE, "grove_list: final")
call set%grove_list%final ()
deallocate (set%grove_list)
end if
if (debug_on) call msg_debug (D_PHASESPACE, "f_node_list: final")
call set%f_node_list%final ()
if (associated (set%dag)) then
if (debug_on) call msg_debug (D_PHASESPACE, "dag: final")
if (associated (set%dag)) then
call set%dag%final ()
deallocate (set%dag)
end if
end if
end subroutine feyngraph_set_final
@ %def feyngraph_set_final
@
\subsection{Construct the feyngraph set}
We construct the [[feyngraph_set]] from an input file. Therefore we pass
a unit to [[feyngraph_set_build]]. The parsing subroutines are chosen
depending on the value of [[use_dag]]. In the DAG output, which is the one
that is produced by default, we have to work on a string of one line,
where the lenght of this string becomes larger the more particles are
involved in the process. The other output (which is now only used in a
unit test) contains one Feynman diagram per line and each line starts with an open
parenthesis so that we read the file line per line and create a
[[feyngraph]] for every line. Only after this, nodes are created. In both
decay and scattering processes the diagrams are represented like in a decay
process, i.e. in a scattering process one of the incoming particles appears
as an outgoing particle.
<<Cascades2: feyngraph set: TBP>>=
procedure :: build => feyngraph_set_build
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_set_build (feyngraph_set, u_in)
class(feyngraph_set_t), intent(inout) :: feyngraph_set
integer, intent(in) :: u_in
end subroutine feyngraph_set_build
<<Cascades2: procedures>>=
module subroutine feyngraph_set_build (feyngraph_set, u_in)
class(feyngraph_set_t), intent(inout) :: feyngraph_set
integer, intent(in) :: u_in
integer :: stat = 0
character(len=FEYNGRAPH_LEN) :: omega_feyngraph_output
type(feyngraph_t), pointer :: current_graph
type(feyngraph_t), pointer :: compare_graph
logical :: present
if (feyngraph_set%use_dag) then
allocate (feyngraph_set%dag)
if (.not. associated (feyngraph_set%first)) then
call feyngraph_set%dag%read_string (u_in, feyngraph_set%flv(:,1))
call feyngraph_set%dag%construct (feyngraph_set)
call feyngraph_set%dag%make_feyngraphs (feyngraph_set)
end if
else
if (.not. associated (feyngraph_set%first)) then
read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') &
omega_feyngraph_output
if (omega_feyngraph_output(1:1) == '(') then
allocate (feyngraph_set%first)
feyngraph_set%first%omega_feyngraph_output = &
trim(omega_feyngraph_output)
feyngraph_set%last => feyngraph_set%first
feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
else
call msg_fatal ("Invalid input file")
end if
read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') &
omega_feyngraph_output
do while (stat == 0)
if (omega_feyngraph_output(1:1) == '(') then
compare_graph => feyngraph_set%first
present = .false.
do while (associated (compare_graph))
if (len_trim(compare_graph%omega_feyngraph_output) &
== len_trim(omega_feyngraph_output)) then
if (compare_graph%omega_feyngraph_output == &
omega_feyngraph_output) then
present = .true.
exit
end if
end if
compare_graph => compare_graph%next
end do
if (.not. present) then
allocate (feyngraph_set%last%next)
feyngraph_set%last => feyngraph_set%last%next
feyngraph_set%last%omega_feyngraph_output = &
trim(omega_feyngraph_output)
feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
end if
read (unit=u_in, fmt='(A)', iostat=stat, advance='yes') &
omega_feyngraph_output
else
exit
end if
end do
current_graph => feyngraph_set%first
do while (associated (current_graph))
call feyngraph_construct (feyngraph_set, current_graph)
current_graph => current_graph%next
end do
feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes
end if
end if
end subroutine feyngraph_set_build
@ %def feyngraph_set_build
@ Read the string from the file. The output which is produced by O'Mega
contains the DAG in a factorised form as a long string, distributed over
several lines (in addition, in the case of a scattering process, it
contains a similar string for the same process, but with the other
incoming particle as the root of the tree structure). In general, such a
file can contain many of these strings, belonging to different process
components. Therefore we first have to find the correct position of the
string for the process in question. Therefore we look for a line
containing a pair of colons, in which case the line contains a process
string. Then we check if the process string describes the correct
process, which is done by checking for all the incoming and outgoing
particle names. If the process is correct, the dag output should start
in the following line. As long as we do not find the correct process
string, we continue searching. If we reach the end of the file, we
rewind the unit once, and repeat searching. If the process is still not
found, there must be some sort of error.
<<Cascades2: dag: TBP>>=
procedure :: read_string => dag_read_string
<<Cascades2: sub interfaces>>=
module subroutine dag_read_string (dag, u_in, flv)
class(dag_t), intent(inout) :: dag
integer, intent(in) :: u_in
type(flavor_t), dimension(:), intent(in) :: flv
end subroutine dag_read_string
<<Cascades2: procedures>>=
module subroutine dag_read_string (dag, u_in, flv)
class(dag_t), intent(inout) :: dag
integer, intent(in) :: u_in
type(flavor_t), dimension(:), intent(in) :: flv
character(len=BUFFER_LEN) :: process_string
logical :: process_found
logical :: rewound
!!! Find process string in file
process_found = .false.
rewound = .false.
do while (.not. process_found)
process_string = ""
read (unit=u_in, fmt='(A)') process_string
if (len_trim(process_string) /= 0) then
if (index (process_string, "::") > 0) then
process_found = process_string_match (trim (process_string), flv)
end if
else if (.not. rewound) then
rewind (u_in)
rewound = .true.
else
call msg_bug ("Process string not found in O'Mega input file.")
end if
end do
call fds_file_get_line (u_in, dag%string)
call dag%string%clean ()
if (.not. allocated (dag%string%t) .or. dag%string%char_len == 0) &
call msg_bug ("Process string not found in O'Mega input file.")
end subroutine dag_read_string
@ %def dag_read_string
@ The output of factorized Feynman diagrams which is created by O'Mega
for a given process could in principle be written to a single line in
the file. This can however lead to different problems with different
compilers as soon as such lines become too long. This is the reason why
the line is cut into smaller pieces. This means that a new line starts
after each vertical bar. For this long string the type [[dag_string_t]]
has been introduced. In order to read the file quickly into such a
[[dag_string]] we use another type, [[dag_chain_t]] which is a linked
list of such [[dag_strings]]. This has the advantage that we do not
have to recreate a new [[dag_string]] for every line which has been
read from file. Only in the end of this operation we compress the
list of strings to a single string, removing useless [[dag_tokens]],
such as blanc space tokens. This subroutine reads all lines starting
from the position in the file the unit is connected to, until no
backslash character is found at the end of a line (the backslash
means that the next line also belongs to the current string).
<<Cascades2: parameters>>=
integer, parameter :: BUFFER_LEN = 1000
integer, parameter :: STACK_SIZE = 100
@ %def BUFFER_LEN STACK_SIZE
<<Cascades2: procedures>>=
subroutine fds_file_get_line (u, string)
integer, intent(in) :: u
type(dag_string_t), intent(out) :: string
type(dag_chain_t) :: chain
integer :: string_size, current_len
character(len=BUFFER_LEN) :: buffer
integer :: fragment_len
integer :: stat
current_len = 0
stat = 0
string_size = 0
do while (stat == 0)
read (unit=u, fmt='(A)', iostat=stat) buffer
if (stat /= 0) exit
fragment_len = len_trim (buffer)
if (fragment_len == 0) then
exit
else if (buffer (fragment_len:fragment_len) == BACKSLASH_CHAR) then
fragment_len = fragment_len - 1
end if
call chain%append (buffer(:fragment_len))
if (buffer(fragment_len+1:fragment_len+1) /= BACKSLASH_CHAR) exit
end do
if (associated (chain%first)) then
call chain%compress ()
string = chain%first
call chain%final ()
end if
end subroutine fds_file_get_line
@ %def fds_file_get_line
@ We check, if the process string which has been read from file
corresponds to the process for which we want to extract the Feynman
diagrams.
<<Cascades2: procedures>>=
function process_string_match (string, flv) result (match)
character(len=*), intent(in) :: string
type(flavor_t), dimension(:), intent(in) :: flv
logical :: match
integer :: pos
integer :: occurence
integer :: i
pos = 1
match = .false.
do i=1, size (flv)
occurence = index (string(pos:), char(flv(i)%get_name()))
if (occurence > 0) then
pos = pos + occurence
match = .true.
else
match = .false.
exit
end if
end do
end function process_string_match
@ %def process_string_match
@
\subsection{Particle properties}
This subroutine initializes a model instance with the Standard Model
data. It is only relevant for a unit test.
We do not have to care about the model initialization in this module
because the [[model]] is passed to [[feyngraph_set_generate]] when
it is called.
<<Cascades2: public>>=
public :: init_sm_full_test
<<Cascades2: sub interfaces>>=
module subroutine init_sm_full_test (model)
class(model_data_t), intent(out) :: model
end subroutine init_sm_full_test
<<Cascades2: procedures>>=
module subroutine init_sm_full_test (model)
class(model_data_t), intent(out) :: model
type(field_data_t), pointer :: field
integer, parameter :: n_real = 17
integer, parameter :: n_field = 21
integer, parameter :: n_vtx = 56
integer :: i
call model%init (var_str ("SM_vertex_test"), &
n_real, 0, n_field, n_vtx)
call model%init_par (1, var_str ("mZ"), 91.1882_default)
call model%init_par (2, var_str ("mW"), 80.419_default)
call model%init_par (3, var_str ("mH"), 125._default)
call model%init_par (4, var_str ("me"), 0.000510997_default)
call model%init_par (5, var_str ("mmu"), 0.105658389_default)
call model%init_par (6, var_str ("mtau"), 1.77705_default)
call model%init_par (7, var_str ("ms"), 0.095_default)
call model%init_par (8, var_str ("mc"), 1.2_default)
call model%init_par (9, var_str ("mb"), 4.2_default)
call model%init_par (10, var_str ("mtop"), 173.1_default)
call model%init_par (11, var_str ("wtop"), 1.523_default)
call model%init_par (12, var_str ("wZ"), 2.443_default)
call model%init_par (13, var_str ("wW"), 2.049_default)
call model%init_par (14, var_str ("wH"), 0.004143_default)
call model%init_par (15, var_str ("ee"), 0.3079561542961_default)
call model%init_par (16, var_str ("cw"), 8.819013863636E-01_default)
call model%init_par (17, var_str ("sw"), 4.714339240339E-01_default)
i = 0
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("D_QUARK"), 1)
call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
call field%set (name = [var_str ("d")], anti = [var_str ("dbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("U_QUARK"), 2)
call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
call field%set (name = [var_str ("u")], anti = [var_str ("ubar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("S_QUARK"), 3)
call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
call field%set (mass_data=model%get_par_real_ptr (7))
call field%set (name = [var_str ("s")], anti = [var_str ("sbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("C_QUARK"), 4)
call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
call field%set (mass_data=model%get_par_real_ptr (8))
call field%set (name = [var_str ("c")], anti = [var_str ("cbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("B_QUARK"), 5)
call field%set (spin_type=2, color_type=3, charge_type=-2, isospin_type=-2)
call field%set (mass_data=model%get_par_real_ptr (9))
call field%set (name = [var_str ("b")], anti = [var_str ("bbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("T_QUARK"), 6)
call field%set (spin_type=2, color_type=3, charge_type=3, isospin_type=2)
call field%set (mass_data=model%get_par_real_ptr (10))
call field%set (width_data=model%get_par_real_ptr (11))
call field%set (name = [var_str ("t")], anti = [var_str ("tbar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("E_LEPTON"), 11)
call field%set (spin_type=2)
call field%set (mass_data=model%get_par_real_ptr (4))
call field%set (name = [var_str ("e-")], anti = [var_str ("e+")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("E_NEUTRINO"), 12)
call field%set (spin_type=2, is_left_handed=.true.)
call field%set (name = [var_str ("nue")], anti = [var_str ("nuebar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("MU_LEPTON"), 13)
call field%set (spin_type=2)
call field%set (mass_data=model%get_par_real_ptr (5))
call field%set (name = [var_str ("mu-")], anti = [var_str ("mu+")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("MU_NEUTRINO"), 14)
call field%set (spin_type=2, is_left_handed=.true.)
call field%set (name = [var_str ("numu")], anti = [var_str ("numubar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("TAU_LEPTON"), 15)
call field%set (spin_type=2)
call field%set (mass_data=model%get_par_real_ptr (6))
call field%set (name = [var_str ("tau-")], anti = [var_str ("tau+")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("TAU_NEUTRINO"), 16)
call field%set (spin_type=2, is_left_handed=.true.)
call field%set (name = [var_str ("nutau")], anti = [var_str ("nutaubar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("GLUON"), 21)
call field%set (spin_type=3, color_type=8)
call field%set (name = [var_str ("gl")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("PHOTON"), 22)
call field%set (spin_type=3)
call field%set (name = [var_str ("A")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("Z_BOSON"), 23)
call field%set (spin_type=3)
call field%set (mass_data=model%get_par_real_ptr (1))
call field%set (width_data=model%get_par_real_ptr (12))
call field%set (name = [var_str ("Z")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("W_BOSON"), 24)
call field%set (spin_type=3)
call field%set (mass_data=model%get_par_real_ptr (2))
call field%set (width_data=model%get_par_real_ptr (13))
call field%set (name = [var_str ("W+")], anti = [var_str ("W-")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("HIGGS"), 25)
call field%set (spin_type=1)
call field%set (mass_data=model%get_par_real_ptr (3))
call field%set (width_data=model%get_par_real_ptr (14))
call field%set (name = [var_str ("H")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("PROTON"), 2212)
call field%set (spin_type=2)
call field%set (name = [var_str ("p")], anti = [var_str ("pbar")])
! call field%set (mass_data=model%get_par_real_ptr (12))
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("HADRON_REMNANT_SINGLET"), 91)
call field%set (color_type=1)
call field%set (name = [var_str ("hr1")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("HADRON_REMNANT_TRIPLET"), 92)
call field%set (color_type=3)
call field%set (name = [var_str ("hr3")], anti = [var_str ("hr3bar")])
i = i + 1
field => model%get_field_ptr_by_index (i)
call field%init (var_str ("HADRON_REMNANT_OCTET"), 93)
call field%set (color_type=8)
call field%set (name = [var_str ("hr8")])
call model%freeze_fields ()
i = 0
i = i + 1
!!! QED
call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("A")])
i = i + 1
!!!
call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("mu+"), var_str ("mu-"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("A")])
i = i + 1
!!! QCD
call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("gl"), var_str ("gl"), &
var_str ("gl"), var_str ("gl")])
i = i + 1
!!!
call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("gl")])
i = i + 1
call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("gl")])
i = i + 1
!!! Neutral currents
call model%set_vertex (i, [var_str ("dbar"), var_str ("d"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("ubar"), var_str ("u"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("Z")])
i = i + 1
!!!
call model%set_vertex (i, [var_str ("e+"), var_str ("e-"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("mu+"), var_str ("muu-"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("tau+"), var_str ("tau-"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("nuebar"), var_str ("nue"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("numubar"), var_str ("numu"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("nutaubar"), var_str ("nutau"), &
var_str ("Z")])
i = i + 1
!!! Charged currents
call model%set_vertex (i, [var_str ("ubar"), var_str ("d"), var_str ("W+")])
i = i + 1
call model%set_vertex (i, [var_str ("cbar"), var_str ("s"), var_str ("W+")])
i = i + 1
call model%set_vertex (i, [var_str ("tbar"), var_str ("b"), var_str ("W+")])
i = i + 1
call model%set_vertex (i, [var_str ("dbar"), var_str ("u"), var_str ("W-")])
i = i + 1
call model%set_vertex (i, [var_str ("sbar"), var_str ("c"), var_str ("W-")])
i = i + 1
call model%set_vertex (i, [var_str ("bbar"), var_str ("t"), var_str ("W-")])
i = i + 1
!!!
call model%set_vertex (i, [var_str ("nuebar"), var_str ("e-"), var_str ("W+")])
i = i + 1
call model%set_vertex (i, [var_str ("numubar"), var_str ("mu-"), var_str ("W+")])
i = i + 1
call model%set_vertex (i, [var_str ("nutaubar"), var_str ("tau-"), var_str ("W+")])
i = i + 1
call model%set_vertex (i, [var_str ("e+"), var_str ("nue"), var_str ("W-")])
i = i + 1
call model%set_vertex (i, [var_str ("mu+"), var_str ("numu"), var_str ("W-")])
i = i + 1
call model%set_vertex (i, [var_str ("tau+"), var_str ("nutau"), var_str ("W-")])
i = i + 1
!!! Yukawa
!!! keeping only 3rd generation for the moment
! call model%set_vertex (i, [var_str ("sbar"), var_str ("s"), var_str ("H")])
! i = i + 1
! call model%set_vertex (i, [var_str ("cbar"), var_str ("c"), var_str ("H")])
! i = i + 1
call model%set_vertex (i, [var_str ("bbar"), var_str ("b"), var_str ("H")])
i = i + 1
call model%set_vertex (i, [var_str ("tbar"), var_str ("t"), var_str ("H")])
i = i + 1
! call model%set_vertex (i, [var_str ("mubar"), var_str ("mu"), var_str ("H")])
! i = i + 1
call model%set_vertex (i, [var_str ("taubar"), var_str ("tau"), var_str ("H")])
i = i + 1
!!! Vector-boson self-interactions
call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z")])
i = i + 1
!!!
call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("W+"), var_str ("W+"), var_str ("W-"), var_str ("W-")])
i = i + 1
call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("Z"), var_str ("A")])
i = i + 1
call model%set_vertex (i, [var_str ("W+"), var_str ("W-"), var_str ("A"), var_str ("A")])
i = i + 1
!!! Higgs - vector boson
! call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("A")])
! i = i + 1
! call model%set_vertex (i, [var_str ("H"), var_str ("A"), var_str ("A")])
! i = i + 1
! call model%set_vertex (i, [var_str ("H"), var_str ("gl"), var_str ("gl")])
! i = i + 1
!!!
call model%set_vertex (i, [var_str ("H"), var_str ("W+"), var_str ("W-")])
i = i + 1
call model%set_vertex (i, [var_str ("H"), var_str ("Z"), var_str ("Z")])
i = i + 1
call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("W+"), var_str ("W-")])
i = i + 1
call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("Z"), var_str ("Z")])
i = i + 1
!!! Higgs self-interactions
call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H")])
i = i + 1
call model%set_vertex (i, [var_str ("H"), var_str ("H"), var_str ("H"), var_str ("H")])
i = i + 1
call model%freeze_vertices ()
end subroutine init_sm_full_test
@ %def init_sm_full_test
@ Initialize a [[part_prop]] object by passing a [[particle_label]],
which is simply the particle name. [[part_prop]] should be part of the
[[particle]] array of [[feyngraph_set]]. We use the [[model]] of
[[feyngraph_set]] to obtain the relevant data of the particle which is
needed to find [[phase_space]] parametrizations. When a [[part_prop]]
is initialized, we add and initialize also the corresponding anti-
particle [[part_prop]] if it is not yet in the array.
<<Cascades2: part prop: TBP>>=
procedure :: init => part_prop_init
<<Cascades2: sub interfaces>>=
recursive module subroutine part_prop_init &
(part_prop, feyngraph_set, particle_label)
class(part_prop_t), intent(out), target :: part_prop
type(feyngraph_set_t), intent(inout) :: feyngraph_set
character(len=*), intent(in) :: particle_label
end subroutine part_prop_init
<<Cascades2: procedures>>=
recursive module subroutine part_prop_init &
(part_prop, feyngraph_set, particle_label)
class(part_prop_t), intent(out), target :: part_prop
type(feyngraph_set_t), intent(inout) :: feyngraph_set
character(len=*), intent(in) :: particle_label
type(flavor_t) :: flv, anti
type(string_t) :: name
integer :: i
name = particle_label
call flv%init (name, feyngraph_set%model)
part_prop%particle_label = particle_label
part_prop%pdg = flv%get_pdg ()
part_prop%mass = flv%get_mass ()
part_prop%width = flv%get_width()
part_prop%spin_type = flv%get_spin_type ()
part_prop%is_vector = flv%get_spin_type () == VECTOR
part_prop%empty = .false.
part_prop%tex_name = flv%get_tex_name ()
anti = flv%anti ()
if (flv%get_pdg() == anti%get_pdg()) then
select type (part_prop)
type is (part_prop_t)
part_prop%anti => part_prop
end select
else
do i=1, size (feyngraph_set%particle)
if (feyngraph_set%particle(i)%pdg == (- part_prop%pdg)) then
part_prop%anti => feyngraph_set%particle(i)
exit
else if (feyngraph_set%particle(i)%empty) then
part_prop%anti => feyngraph_set%particle(i)
call feyngraph_set%particle(i)%init &
(feyngraph_set, char(anti%get_name()))
exit
end if
end do
end if
end subroutine part_prop_init
@ %def part_prop_init
@ This subroutine assigns to a node the particle properties. Since these
properties do not change and are simply read from the model file, we
use pointers to the elements of the [[particle]] array of the
[[feyngraph_set]]. If there is no corresponding array element, we
have to initialize the first empty element of the array.
<<Cascades2: parameters>>=
integer, parameter :: PRT_ARRAY_SIZE = 200
<<Cascades2: f node: TBP>>=
procedure :: assign_particle_properties => f_node_assign_particle_properties
<<Cascades2: sub interfaces>>=
module subroutine f_node_assign_particle_properties (node, feyngraph_set)
class(f_node_t), intent(inout ) :: node
type(feyngraph_set_t), intent(inout) :: feyngraph_set
end subroutine f_node_assign_particle_properties
<<Cascades2: procedures>>=
module subroutine f_node_assign_particle_properties (node, feyngraph_set)
class(f_node_t), intent(inout ) :: node
type(feyngraph_set_t), intent(inout) :: feyngraph_set
character(len=LABEL_LEN) :: particle_label
integer :: i
particle_label = node%particle_label(1:index (node%particle_label, '[')-1)
if (.not. associated (feyngraph_set%particle)) then
allocate (feyngraph_set%particle (PRT_ARRAY_SIZE))
end if
do i = 1, size (feyngraph_set%particle)
if (particle_label == feyngraph_set%particle(i)%particle_label) then
node%particle => feyngraph_set%particle(i)
exit
else if (feyngraph_set%particle(i)%empty) then
call feyngraph_set%particle(i)%init (feyngraph_set, particle_label)
node%particle => feyngraph_set%particle(i)
exit
end if
end do
!!! Since the O'Mega output uses the anti-particles instead of the
!!! particles specified in the process definition, we revert this
!!! here. An exception is the first particle in the parsable DAG output
node%particle => node%particle%anti
end subroutine f_node_assign_particle_properties
@ %def f_node_assign_particle_properties
@ From the output of a Feynman diagram (in the non-factorized output)
we need to find out how many daughter nodes would be required to
reconstruct it correctly, to make sure that we keep
only those [[feyngraphs]] which are constructed solely on the basis of
the 3-vertices which are provided by the model. The number of daughter
particles can easily be determined from the syntax of O'Mega's output:
The particle which appears before the colon ':' is the mother particle.
The particles or subtrees (i.e. whole parentheses) follow after the
colon and are separated by commas.
<<Cascades2: procedures>>=
function get_n_daughters (subtree_string, pos_first_colon) &
result (n_daughters)
character(len=*), intent(in) :: subtree_string
integer, intent(in) :: pos_first_colon
integer :: n_daughters
integer :: n_open_par
integer :: i
n_open_par = 1
n_daughters = 0
if (len_trim(subtree_string) > 0) then
if (pos_first_colon > 0) then
do i=pos_first_colon, len_trim(subtree_string)
if (subtree_string(i:i) == ',') then
if (n_open_par == 1) n_daughters = n_daughters + 1
else if (subtree_string(i:i) == '(') then
n_open_par = n_open_par + 1
else if (subtree_string(i:i) == ')') then
n_open_par = n_open_par - 1
end if
end do
if (n_open_par == 0) then
n_daughters = n_daughters + 1
end if
end if
end if
end function get_n_daughters
@ %def get_n_daughters
@
\subsection{Reconstruction of trees}
The reconstruction of a tree or subtree with the non-factorized input can
be done recursively, i.e. we first find the root of the tree in the
string and create an [[f_node]]. Then we look for daughters, which in the
string appear either as single particles or subtrees (which are of the
same form as the tree which we want to reconstruct. Therefore the
subroutine can simply be called again and again until there are no more
daughter nodes to create. When we meet a vertex which requires more than
two daughter particles, we stop the recursion and disable the node using
its [[keep]] variable. Whenever a daughter node is not kept, we do not
keep the mother node as well.
<<Cascades2: procedures>>=
recursive subroutine node_construct_subtree_rec (feyngraph_set, &
feyngraph, subtree_string, mother_node)
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(feyngraph_t), intent(inout) :: feyngraph
character(len=*), intent(in) :: subtree_string
type(f_node_t), pointer, intent(inout) :: mother_node
integer :: n_daughters
integer :: pos_first_colon
integer :: current_daughter
integer :: pos_subtree_begin, pos_subtree_end
integer :: i
integer :: n_open_par
if (.not. associated (mother_node)) then
call feyngraph_set%f_node_list%add_entry (subtree_string, mother_node, .true.)
current_daughter = 1
n_open_par = 1
pos_first_colon = index (subtree_string, ':')
n_daughters = get_n_daughters (subtree_string, pos_first_colon)
if (pos_first_colon == 0) then
mother_node%particle_label = subtree_string
else
mother_node%particle_label = subtree_string(2:pos_first_colon-1)
end if
if (.not. associated (mother_node%particle)) then
call mother_node%assign_particle_properties (feyngraph_set)
end if
if (n_daughters /= 2 .and. n_daughters /= 0) then
mother_node%keep = .false.
feyngraph%keep = .false.
return
end if
pos_subtree_begin = pos_first_colon + 1
do i = pos_first_colon + 1, len(trim(subtree_string))
if (current_daughter == 2) then
pos_subtree_end = len(trim(subtree_string)) - 1
call node_construct_subtree_rec (feyngraph_set, feyngraph, &
subtree_string(pos_subtree_begin:pos_subtree_end), &
mother_node%daughter2)
exit
else if (subtree_string(i:i) == ',') then
if (n_open_par == 1) then
pos_subtree_end = i - 1
call node_construct_subtree_rec (feyngraph_set, feyngraph, &
subtree_string(pos_subtree_begin:pos_subtree_end), &
mother_node%daughter1)
current_daughter = 2
pos_subtree_begin = i + 1
end if
else if (subtree_string(i:i) == '(') then
n_open_par = n_open_par + 1
else if (subtree_string(i:i) == ')') then
n_open_par = n_open_par - 1
end if
end do
end if
if (associated (mother_node%daughter1)) then
if (.not. mother_node%daughter1%keep) then
mother_node%keep = .false.
end if
end if
if (associated (mother_node%daughter2)) then
if (.not. mother_node%daughter2%keep) then
mother_node%keep = .false.
end if
end if
if (associated (mother_node%daughter1) .and. &
associated (mother_node%daughter2)) then
mother_node%n_subtree_nodes = &
mother_node%daughter1%n_subtree_nodes &
+ mother_node%daughter2%n_subtree_nodes + 1
end if
if (.not. mother_node%keep) then
feyngraph%keep = .false.
end if
end subroutine node_construct_subtree_rec
@ %def node_construct_subtree_rec
@ When the non-factorized version of the O'Mega output is used, the
[[feyngraph]] is reconstructed from the contents of its [[string_t]]
variable [[omega_feyngraph_output]]. This can be used for the recursive
reconstruction of the tree of [[k_nodes]] with
[[node_construct_subtree_rec]].
<<Cascades2: procedures>>=
subroutine feyngraph_construct (feyngraph_set, feyngraph)
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(feyngraph_t), pointer, intent(inout) :: feyngraph
call node_construct_subtree_rec (feyngraph_set, feyngraph, &
char(feyngraph%omega_feyngraph_output), feyngraph%root)
feyngraph%n_nodes = feyngraph%root%n_subtree_nodes
end subroutine feyngraph_construct
@ %def feyngraph_construct
@ We introduce another node type, which is called [[dag_node_t]] and
is used to reproduce the dag structure which is represented by the input.
The [[dag_nodes]] can have several combinations of daughters 1 and 2.
The [[dag]] type contains an array of [[dag_nodes]] and is only used
for the reconstruction of [[feyngraphs]] which are factorized as well, but
in the other direction as the original output. This means in particular
that the outgoing particles in the output file (which there can appear
many times) exist only once as [[f_nodes]]. To represent combinations of
daughters and alternatives (options), we further use the types
[[dag_options_t]] and [[dag_combination_t]]. The [[dag_nodes]],
[[dag_options]] and [[dag_combinations]] correspond to a substring of
the string which has been read from file (and transformed into an object
of type [[dag_string_t]], which is simply another compact representation
of this string), or a modified version of this substring. The aim is to
create only one object for a given substring, even if it appears several
times in the original string and then create trees of [[f_nodes]], which
build up the [[feyngraph]], such that as many [[f_nodes]] as possible can be reused.
An outgoing particle (always interpreting the input as a decay) is
called a [[leaf]] in the context of a [[dag]].
<<Cascades2: types>>=
type :: dag_node_t
integer :: string_len
type(dag_string_t) :: string
logical :: leaf = .false.
type(f_node_ptr_t), dimension (:), allocatable :: f_node
integer :: subtree_size = 0
contains
<<Cascades2: dag node: TBP>>
end type dag_node_t
@ %def dag_node_t
<<Cascades2: dag node: TBP>>=
procedure :: final => dag_node_final
<<Cascades2: sub interfaces>>=
module subroutine dag_node_final (dag_node)
class(dag_node_t), intent(inout) :: dag_node
end subroutine dag_node_final
<<Cascades2: procedures>>=
module subroutine dag_node_final (dag_node)
class(dag_node_t), intent(inout) :: dag_node
integer :: i
call dag_node%string%final ()
if (allocated (dag_node%f_node)) then
do i=1, size (dag_node%f_node)
if (associated (dag_node%f_node(i)%node)) then
call dag_node%f_node(i)%node%final ()
deallocate (dag_node%f_node(i)%node)
end if
end do
deallocate (dag_node%f_node)
end if
end subroutine dag_node_final
@ %def dag_node_final
@ Whenever there are more than one possible subtrees (represented by
a [[dag_node]]) or combinations of subtrees to daughters (represented
by [[dag_combination_t]]), we use the type [[dag_options_t]]. In the
syntax of the factorized output, options are listed within curly
braces, separated by horizontal bars.
<<Cascades2: types>>=
type :: dag_options_t
integer :: string_len
type(dag_string_t) :: string
type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1
type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2
contains
<<Cascades2: dag options: TBP>>
end type dag_options_t
@ %def dag_node_options_t
<<Cascades2: dag options: TBP>>=
procedure :: final => dag_options_final
<<Cascades2: sub interfaces>>=
module subroutine dag_options_final (dag_options)
class(dag_options_t), intent(inout) :: dag_options
end subroutine dag_options_final
<<Cascades2: procedures>>=
module subroutine dag_options_final (dag_options)
class(dag_options_t), intent(inout) :: dag_options
integer :: i
call dag_options%string%final ()
if (allocated (dag_options%f_node_ptr1)) then
do i=1, size (dag_options%f_node_ptr1)
dag_options%f_node_ptr1(i)%node => null ()
end do
deallocate (dag_options%f_node_ptr1)
end if
if (allocated (dag_options%f_node_ptr2)) then
do i=1, size (dag_options%f_node_ptr2)
dag_options%f_node_ptr2(i)%node => null ()
end do
deallocate (dag_options%f_node_ptr2)
end if
end subroutine dag_options_final
@ %def dag_options_final
@ A pair of two daughters (which can be [[dag_nodes]] or [[dag_options]])
is represented by the type [[dag_combination_t]]. In the original string,
a [[dag_combination]] appears between parentheses, which contain a comma,
but not a colon. If we find a colon between these parentheses, it is a
a [[dag_node]] instead.
<<Cascades2: types>>=
type :: dag_combination_t
integer :: string_len
type(dag_string_t) :: string
integer, dimension (2) :: combination
type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr1
type(f_node_ptr_t), dimension (:), allocatable :: f_node_ptr2
contains
<<Cascades2: dag combination: TBP>>
end type dag_combination_t
@ %def dag_combination_t
<<Cascades2: dag combination: TBP>>=
procedure :: final => dag_combination_final
<<Cascades2: sub interfaces>>=
module subroutine dag_combination_final (dag_combination)
class(dag_combination_t), intent(inout) :: dag_combination
end subroutine dag_combination_final
<<Cascades2: procedures>>=
module subroutine dag_combination_final (dag_combination)
class(dag_combination_t), intent(inout) :: dag_combination
integer :: i
call dag_combination%string%final ()
if (allocated (dag_combination%f_node_ptr1)) then
do i=1, size (dag_combination%f_node_ptr1)
dag_combination%f_node_ptr1(i)%node => null ()
end do
deallocate (dag_combination%f_node_ptr1)
end if
if (allocated (dag_combination%f_node_ptr2)) then
do i=1, size (dag_combination%f_node_ptr2)
dag_combination%f_node_ptr2(i)%node => null ()
end do
deallocate (dag_combination%f_node_ptr2)
end if
end subroutine dag_combination_final
@ %def dag_combination_final
@ Here is the type representing the DAG, i.e. it holds arrays of the
[[dag_nodes]], [[dag_options]] and [[dag_combinations]]. The root node
of the [[dag]] is the last filled element of the [[node]] array.
<<Cascades2: types>>=
type :: dag_t
type(dag_string_t) :: string
type(dag_node_t), dimension (:), allocatable :: node
type(dag_options_t), dimension (:), allocatable :: options
type(dag_combination_t), dimension (:), allocatable :: combination
integer :: n_nodes = 0
integer :: n_options = 0
integer :: n_combinations = 0
contains
<<Cascades2: dag: TBP>>
end type dag_t
@ %def dag_t
<<Cascades2: dag: TBP>>=
procedure :: final => dag_final
<<Cascades2: sub interfaces>>=
module subroutine dag_final (dag)
class(dag_t), intent(inout) :: dag
end subroutine dag_final
<<Cascades2: procedures>>=
module subroutine dag_final (dag)
class(dag_t), intent(inout) :: dag
integer :: i
call dag%string%final ()
if (allocated (dag%node)) then
do i=1, size (dag%node)
call dag%node(i)%final ()
end do
deallocate (dag%node)
end if
if (allocated (dag%options)) then
do i=1, size (dag%options)
call dag%options(i)%final ()
end do
deallocate (dag%options)
end if
if (allocated (dag%combination)) then
do i=1, size (dag%combination)
call dag%combination(i)%final ()
end do
deallocate (dag%combination)
end if
end subroutine dag_final
@ %def dag_final
@ We construct the DAG from the given [[dag_string]] which is modified
several times so that in the end the remaining string corresponds to a
simple [[dag_node]], the root of the factorized tree. This means that
we first identify the leaves, i.e. outgoing particles. Then we identify
[[dag_nodes]], [[dag_combinations]] and [[options]] until the number of
these objects does not change any more. Identifying means that we add
a corresponding object to the array (if not yet present), which can be
identified with the corresponding substring, and replace the substring
in the original [[dag_string]] by a [[dag_token]] of the corresponding
type (in the char output of this token, this corresponds to a place
holder like e.g. '<O23>' which in this particular case corresponds to
an option and can be found at the position 23 in the array). The
character output of the substrings turns out to be very useful for
debugging.
<<Cascades2: dag: TBP>>=
procedure :: construct => dag_construct
<<Cascades2: sub interfaces>>=
module subroutine dag_construct (dag, feyngraph_set)
class(dag_t), intent(inout) :: dag
type(feyngraph_set_t), intent(inout) :: feyngraph_set
end subroutine dag_construct
<<Cascades2: procedures>>=
module subroutine dag_construct (dag, feyngraph_set)
class(dag_t), intent(inout) :: dag
type(feyngraph_set_t), intent(inout) :: feyngraph_set
integer :: n_nodes
integer :: n_options
integer :: n_combinations
logical :: continue_loop
integer :: subtree_size
integer :: i,j
subtree_size = 1
call dag%get_nodes_and_combinations (leaves = .true.)
do i=1, dag%n_nodes
call dag%node(i)%make_f_nodes (feyngraph_set, dag)
end do
continue_loop = .true.
subtree_size = subtree_size + 2
do while (continue_loop)
n_nodes = dag%n_nodes
n_options = dag%n_options
n_combinations = dag%n_combinations
call dag%get_nodes_and_combinations (leaves = .false.)
if (n_nodes /= dag%n_nodes) then
dag%node(n_nodes+1:dag%n_nodes)%subtree_size = subtree_size
do i = n_nodes+1, dag%n_nodes
call dag%node(i)%make_f_nodes (feyngraph_set, dag)
end do
subtree_size = subtree_size + 2
end if
if (n_combinations /= dag%n_combinations) then
!$OMP PARALLEL DO
do i = n_combinations+1, dag%n_combinations
call dag%combination(i)%make_f_nodes (feyngraph_set, dag)
end do
!$OMP END PARALLEL DO
end if
call dag%get_options ()
if (n_options /= dag%n_options) then
!$OMP PARALLEL DO
do i = n_options+1, dag%n_options
call dag%options(i)%make_f_nodes (feyngraph_set, dag)
end do
!$OMP END PARALLEL DO
end if
if (n_nodes == dag%n_nodes .and. n_options == dag%n_options &
.and. n_combinations == dag%n_combinations) then
continue_loop = .false.
end if
end do
!!! add root node to dag
call dag%add_node (dag%string%t, leaf = .false.)
dag%node(dag%n_nodes)%subtree_size = subtree_size
call dag%node(dag%n_nodes)%make_f_nodes (feyngraph_set, dag)
if (debug2_active (D_PHASESPACE)) then
call dag%write (output_unit)
end if
!!! set indices for all f_nodes
do i=1, dag%n_nodes
if (allocated (dag%node(i)%f_node)) then
do j=1, size (dag%node(i)%f_node)
if (associated (dag%node(i)%f_node(j)%node)) &
call dag%node(i)%f_node(j)%node%set_index ()
end do
end if
end do
end subroutine dag_construct
@ %def dag_construct
@ Identify [[dag_nodes]] and [[dag_combinations]]. Leaves are simply
nodes (i.e. of type [[NODE_TK]]) where only one bit in the bincode is
set. The [[dag_nodes]] and [[dag_combinations]] have in common that they
are surrounded by parentheses. There is however a way to distinguish
between them because the corresponding substring contains a colon (or
[[dag_token]] with type [[COLON_TK]]) if it is a [[dag_node]]. Otherwise
it is a [[dag_combination]]. The string of the [[dag_node]] or
[[dag_combination]] should not contain curly braces, because these
correspond to [[dag_options]] and should be identified before.
<<Cascades2: dag: TBP>>=
procedure :: get_nodes_and_combinations => dag_get_nodes_and_combinations
<<Cascades2: sub interfaces>>=
module subroutine dag_get_nodes_and_combinations (dag, leaves)
class(dag_t), intent(inout) :: dag
logical, intent(in) :: leaves
end subroutine dag_get_nodes_and_combinations
<<Cascades2: procedures>>=
module subroutine dag_get_nodes_and_combinations (dag, leaves)
class(dag_t), intent(inout) :: dag
logical, intent(in) :: leaves
type(dag_string_t) :: new_string
integer :: i, j, k
integer :: i_node
integer :: new_size
integer :: first_colon
logical :: combination
!!! Create nodes also for external particles, except for the incoming one
!!! which appears as the root of the tree. These can easily be identified
!!! by their bincodes, since they should contain only one bit which is set.
if (leaves) then
first_colon = &
minloc (dag%string%t%type, 1, dag%string%t%type == COLON_TK)
do i = first_colon + 1, size (dag%string%t)
if (dag%string%t(i)%type == NODE_TK) then
if (popcnt(dag%string%t(i)%bincode) == 1) then
call dag%add_node (dag%string%t(i:i), .true., i_node)
call dag%string%t(i)%init_dag_object_token (DAG_NODE_TK, i_node)
end if
end if
end do
call dag%string%update_char_len ()
else
!!! Create a node or combination for every closed pair of parentheses
!!! which do not contain any other parentheses or curly braces.
!!! A node (not outgoing) contains a colon. This is not the case
!!! for combinations, which we use as the criteria to distinguish
!!! between both.
allocate (new_string%t (size (dag%string%t)))
i = 1
new_size = 0
do while (i <= size(dag%string%t))
if (dag%string%t(i)%type == OPEN_PAR_TK) then
combination = .true.
do j = i+1, size (dag%string%t)
select case (dag%string%t(j)%type)
case (CLOSED_PAR_TK)
new_size = new_size + 1
if (combination) then
call dag%add_combination (dag%string%t(i:j), i_node)
call new_string%t(new_size)%init_dag_object_token &
(DAG_COMBINATION_TK, i_node)
else
call dag%add_node (dag%string%t(i:j), leaves, i_node)
call new_string%t(new_size)%init_dag_object_token &
(DAG_NODE_TK, i_node)
end if
i = j + 1
exit
case (OPEN_PAR_TK, OPEN_CURLY_TK, CLOSED_CURLY_TK)
new_size = new_size + 1
new_string%t(new_size) = dag%string%t(i)
i = i + 1
exit
case (COLON_TK)
combination = .false.
end select
end do
else
new_size = new_size + 1
new_string%t(new_size) = dag%string%t(i)
i = i + 1
end if
end do
dag%string = new_string%t(:new_size)
call dag%string%update_char_len ()
end if
end subroutine dag_get_nodes_and_combinations
@ %def dag_get_nodes_and_combinations
@ Identify [[dag_options]], i.e. lists of rival nodes or combinations
of nodes. These are identified by the surrounding curly braces. They
should not contain any parentheses any more, because these correspond
either to nodes or to combinations and should be identified before.
<<Cascades2: dag: TBP>>=
procedure :: get_options => dag_get_options
<<Cascades2: sub interfaces>>=
module subroutine dag_get_options (dag)
class(dag_t), intent(inout) :: dag
end subroutine dag_get_options
<<Cascades2: procedures>>=
module subroutine dag_get_options (dag)
class(dag_t), intent(inout) :: dag
type(dag_string_t) :: new_string
integer :: i, j, k
integer :: new_size
integer :: i_options
character(len=10) :: index_char
integer :: index_start, index_end
!!! Create a node or combination for every closed pair of parentheses
!!! which do not contain any other parentheses or curly braces.
!!! A node (not outgoing) contains a colon. This is not the case
!!! for combinations, which we use as the criteria to distinguish
!!! between both.
allocate (new_string%t (size (dag%string%t)))
i = 1
new_size = 0
do while (i <= size(dag%string%t))
if (dag%string%t(i)%type == OPEN_CURLY_TK) then
do j = i+1, size (dag%string%t)
select case (dag%string%t(j)%type)
case (CLOSED_CURLY_TK)
new_size = new_size + 1
call dag%add_options (dag%string%t(i:j), i_options)
call new_string%t(new_size)%init_dag_object_token (DAG_OPTIONS_TK, i_options)
i = j + 1
exit
case (OPEN_PAR_TK, CLOSED_PAR_TK, OPEN_CURLY_TK)
new_size = new_size + 1
new_string%t(new_size) = dag%string%t(i)
i = i + 1
exit
end select
end do
else
new_size = new_size + 1
new_string%t(new_size) = dag%string%t(i)
i = i + 1
end if
end do
dag%string = new_string%t(:new_size)
call dag%string%update_char_len ()
end subroutine dag_get_options
@ %def dag_get_options
@ Add a [[dag_node]] to the list. The optional argument returns the index
of the node. The node might already exist. In this case we only return
the index.
<<Cascades2: dag: TBP>>=
procedure :: add_node => dag_add_node
<<Cascades2: parameters>>=
integer, parameter :: DAG_STACK_SIZE = 1000
<<Cascades2: sub interfaces>>=
module subroutine dag_add_node (dag, string, leaf, i_node)
class(dag_t), intent(inout) :: dag
type(dag_token_t), dimension (:), intent(in) :: string
logical, intent(in) :: leaf
integer, intent(out), optional :: i_node
end subroutine dag_add_node
<<Cascades2: procedures>>=
module subroutine dag_add_node (dag, string, leaf, i_node)
class(dag_t), intent(inout) :: dag
type(dag_token_t), dimension (:), intent(in) :: string
logical, intent(in) :: leaf
integer, intent(out), optional :: i_node
type(dag_node_t), dimension (:), allocatable :: tmp_node
integer :: string_len
integer :: i
string_len = sum (string%char_len)
if (.not. allocated (dag%node)) then
allocate (dag%node (DAG_STACK_SIZE))
else if (dag%n_nodes == size (dag%node)) then
allocate (tmp_node (dag%n_nodes))
tmp_node = dag%node
deallocate (dag%node)
allocate (dag%node (dag%n_nodes+DAG_STACK_SIZE))
dag%node(:dag%n_nodes) = tmp_node
deallocate (tmp_node)
end if
do i = 1, dag%n_nodes
if (dag%node(i)%string_len == string_len) then
if (size (dag%node(i)%string%t) == size (string)) then
if (all(dag%node(i)%string%t == string)) then
if (present (i_node)) i_node = i
return
end if
end if
end if
end do
dag%n_nodes = dag%n_nodes + 1
dag%node(dag%n_nodes)%string = string
dag%node(dag%n_nodes)%string_len = string_len
if (present (i_node)) i_node = dag%n_nodes
dag%node(dag%n_nodes)%leaf = leaf
end subroutine dag_add_node
@ %def dag_add_node
@ A similar subroutine for options.
<<Cascades2: dag: TBP>>=
procedure :: add_options => dag_add_options
<<Cascades2: sub interfaces>>=
module subroutine dag_add_options (dag, string, i_options)
class(dag_t), intent(inout) :: dag
type(dag_token_t), dimension (:), intent(in) :: string
integer, intent(out), optional :: i_options
end subroutine dag_add_options
<<Cascades2: procedures>>=
module subroutine dag_add_options (dag, string, i_options)
class(dag_t), intent(inout) :: dag
type(dag_token_t), dimension (:), intent(in) :: string
integer, intent(out), optional :: i_options
type(dag_options_t), dimension (:), allocatable :: tmp_options
integer :: string_len
integer :: i
string_len = sum (string%char_len)
if (.not. allocated (dag%options)) then
allocate (dag%options (DAG_STACK_SIZE))
else if (dag%n_options == size (dag%options)) then
allocate (tmp_options (dag%n_options))
tmp_options = dag%options
deallocate (dag%options)
allocate (dag%options (dag%n_options+DAG_STACK_SIZE))
dag%options(:dag%n_options) = tmp_options
deallocate (tmp_options)
end if
do i = 1, dag%n_options
if (dag%options(i)%string_len == string_len) then
if (size (dag%options(i)%string%t) == size (string)) then
if (all(dag%options(i)%string%t == string)) then
if (present (i_options)) i_options = i
return
end if
end if
end if
end do
dag%n_options = dag%n_options + 1
dag%options(dag%n_options)%string = string
dag%options(dag%n_options)%string_len = string_len
if (present (i_options)) i_options = dag%n_options
end subroutine dag_add_options
@ %def dag_add_options
@ A similar subroutine for combinations.
<<Cascades2: dag: TBP>>=
procedure :: add_combination => dag_add_combination
<<Cascades2: sub interfaces>>=
module subroutine dag_add_combination (dag, string, i_combination)
class(dag_t), intent(inout) :: dag
type(dag_token_t), dimension (:), intent(in) :: string
integer, intent(out), optional :: i_combination
end subroutine dag_add_combination
<<Cascades2: procedures>>=
module subroutine dag_add_combination (dag, string, i_combination)
class(dag_t), intent(inout) :: dag
type(dag_token_t), dimension (:), intent(in) :: string
integer, intent(out), optional :: i_combination
type(dag_combination_t), dimension (:), allocatable :: tmp_combination
integer :: string_len
integer :: i
string_len = sum (string%char_len)
if (.not. allocated (dag%combination)) then
allocate (dag%combination (DAG_STACK_SIZE))
else if (dag%n_combinations == size (dag%combination)) then
allocate (tmp_combination (dag%n_combinations))
tmp_combination = dag%combination
deallocate (dag%combination)
allocate (dag%combination (dag%n_combinations+DAG_STACK_SIZE))
dag%combination(:dag%n_combinations) = tmp_combination
deallocate (tmp_combination)
end if
do i = 1, dag%n_combinations
if (dag%combination(i)%string_len == string_len) then
if (size (dag%combination(i)%string%t) == size (string)) then
if (all(dag%combination(i)%string%t == string)) then
i_combination = i
return
end if
end if
end if
end do
dag%n_combinations = dag%n_combinations + 1
dag%combination(dag%n_combinations)%string = string
dag%combination(dag%n_combinations)%string_len = string_len
if (present (i_combination)) i_combination = dag%n_combinations
end subroutine dag_add_combination
@ %def dag_add_combination
@ For a given [[dag_node]] we want to create all [[f_nodes]]. If the node
is not a leaf, it contains in its string placeholders for options or
combinations. For these objects there are similar subroutines which are
needed here to obtain the sets of daughter nodes. If the [[dag_node]] is
a leaf, it corresponds to an external particle and the token contains the
particle name.
<<Cascades2: dag node: TBP>>=
procedure :: make_f_nodes => dag_node_make_f_nodes
<<Cascades2: sub interfaces>>=
module subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag)
class(dag_node_t), intent(inout) :: dag_node
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(dag_t), intent(inout) :: dag
end subroutine dag_node_make_f_nodes
<<Cascades2: procedures>>=
module subroutine dag_node_make_f_nodes (dag_node, feyngraph_set, dag)
class(dag_node_t), intent(inout) :: dag_node
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(dag_t), intent(inout) :: dag
character(len=LABEL_LEN) :: particle_label
integer :: i, j
integer, dimension (2) :: obj
integer, dimension (2) :: i_obj
integer :: n_obj
integer :: pos
integer :: new_size, size1, size2
integer, dimension(:), allocatable :: match
if (allocated (dag_node%f_node)) return
pos = minloc (dag_node%string%t%type, 1,dag_node%string%t%type == NODE_TK)
particle_label = char (dag_node%string%t(pos))
if (dag_node%leaf) then
!!! construct subtree with procedure similar to the one for the old output
allocate (dag_node%f_node(1))
allocate (dag_node%f_node(1)%node)
dag_node%f_node(1)%node%particle_label = particle_label
call dag_node%f_node(1)%node%assign_particle_properties (feyngraph_set)
if (.not. dag_node%f_node(1)%node%keep) then
deallocate (dag_node%f_node)
return
end if
else
n_obj = 0
do i = 1, size (dag_node%string%t)
select case (dag_node%string%t(i)%type)
case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
n_obj = n_obj + 1
if (n_obj > 2) return
obj(n_obj) = dag_node%string%t(i)%type
i_obj(n_obj) = dag_node%string%t(i)%index
end select
end do
if (n_obj == 1) then
if (obj(1) == DAG_OPTIONS_TK) then
if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then
size1 = size(dag%options(i_obj(1))%f_node_ptr1)
allocate (dag_node%f_node(size1))
do i=1, size1
allocate (dag_node%f_node(i)%node)
dag_node%f_node(i)%node%particle_label = particle_label
call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set)
dag_node%f_node(i)%node%daughter1 => dag%options(i_obj(1))%f_node_ptr1(i)%node
dag_node%f_node(i)%node%daughter2 => dag%options(i_obj(1))%f_node_ptr2(i)%node
dag_node%f_node(i)%node%n_subtree_nodes = &
dag%options(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes &
+ dag%options(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1
end do
end if
else if (obj(1) == DAG_COMBINATION_TK) then
if (allocated (dag%combination(i_obj(1))%f_node_ptr1)) then
size1 = size(dag%combination(i_obj(1))%f_node_ptr1)
allocate (dag_node%f_node(size1))
do i=1, size1
allocate (dag_node%f_node(i)%node)
dag_node%f_node(i)%node%particle_label = particle_label
call dag_node%f_node(i)%node%assign_particle_properties (feyngraph_set)
dag_node%f_node(i)%node%daughter1 => dag%combination(i_obj(1))%f_node_ptr1(i)%node
dag_node%f_node(i)%node%daughter2 => dag%combination(i_obj(1))%f_node_ptr2(i)%node
dag_node%f_node(i)%node%n_subtree_nodes = &
dag%combination(i_obj(1))%f_node_ptr1(i)%node%n_subtree_nodes &
+ dag%combination(i_obj(1))%f_node_ptr2(i)%node%n_subtree_nodes + 1
end do
end if
end if
!!! simply set daughter pointers, daughters are already combined correctly
else if (n_obj == 2) then
size1 = 0
size2 = 0
if (obj(1) == DAG_NODE_TK) then
if (allocated (dag%node(i_obj(1))%f_node)) then
do i=1, size (dag%node(i_obj(1))%f_node)
if (dag%node(i_obj(1))%f_node(i)%node%keep) size1 = size1 + 1
end do
end if
else if (obj(1) == DAG_OPTIONS_TK) then
if (allocated (dag%options(i_obj(1))%f_node_ptr1)) then
do i=1, size (dag%options(i_obj(1))%f_node_ptr1)
if (dag%options(i_obj(1))%f_node_ptr1(i)%node%keep) size1 = size1 + 1
end do
end if
end if
if (obj(2) == DAG_NODE_TK) then
if (allocated (dag%node(i_obj(2))%f_node)) then
do i=1, size (dag%node(i_obj(2))%f_node)
if (dag%node(i_obj(2))%f_node(i)%node%keep) size2 = size2 + 1
end do
end if
else if (obj(2) == DAG_OPTIONS_TK) then
if (allocated (dag%options(i_obj(2))%f_node_ptr1)) then
do i=1, size (dag%options(i_obj(2))%f_node_ptr1)
if (dag%options(i_obj(2))%f_node_ptr1(i)%node%keep) size2 = size2 + 1
end do
end if
end if
!!! make all combinations of daughters
select case (obj(1))
case (DAG_NODE_TK)
select case (obj(2))
case (DAG_NODE_TK)
call combine_all_daughters(dag%node(i_obj(1))%f_node, &
dag%node(i_obj(2))%f_node)
case (DAG_OPTIONS_TK)
call combine_all_daughters(dag%node(i_obj(1))%f_node, &
dag%options(i_obj(2))%f_node_ptr1)
end select
case (DAG_OPTIONS_TK)
select case (obj(2))
case (DAG_NODE_TK)
call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, &
dag%node(i_obj(2))%f_node)
case (DAG_OPTIONS_TK)
call combine_all_daughters(dag%options(i_obj(1))%f_node_ptr1, &
dag%options(i_obj(2))%f_node_ptr1)
end select
end select
end if
end if
contains
subroutine combine_all_daughters (daughter1_ptr, daughter2_ptr)
type(f_node_ptr_t), dimension (:), intent(in) :: daughter1_ptr
type(f_node_ptr_t), dimension (:), intent(in) :: daughter2_ptr
integer :: i, j
integer :: pos
new_size = size1*size2
allocate (dag_node%f_node(new_size))
pos = 0
do i = 1, size (daughter1_ptr)
if (daughter1_ptr(i)%node%keep) then
do j = 1, size (daughter2_ptr)
if (daughter2_ptr(j)%node%keep) then
pos = pos + 1
allocate (dag_node%f_node(pos)%node)
dag_node%f_node(pos)%node%particle_label = particle_label
call dag_node%f_node(pos)%node%assign_particle_properties (feyngraph_set)
dag_node%f_node(pos)%node%daughter1 => daughter1_ptr(i)%node
dag_node%f_node(pos)%node%daughter2 => daughter2_ptr(j)%node
dag_node%f_node(pos)%node%n_subtree_nodes = daughter1_ptr(i)%node%n_subtree_nodes &
+ daughter2_ptr(j)%node%n_subtree_nodes + 1
call feyngraph_set%model%match_vertex (daughter1_ptr(i)%node%particle%pdg, &
daughter2_ptr(j)%node%particle%pdg, match)
if (allocated (match)) then
if (any (abs(match) == abs(dag_node%f_node(pos)%node%particle%pdg))) then
dag_node%f_node(pos)%node%keep = .true.
else
dag_node%f_node(pos)%node%keep = .false.
end if
deallocate (match)
else
dag_node%f_node(pos)%node%keep = .false.
end if
end if
end do
end if
end do
end subroutine combine_all_daughters
end subroutine dag_node_make_f_nodes
@ %def dag_node_make_f_nodes
@ In [[dag_options_make_f_nodes_single]]
we obtain all [[f_nodes]] for [[dag_nodes]] which correspond to a
set of rival subtrees or nodes, which is the first possibility for
which [[dag_options]] can appear.
In [[dag_options_make_f_nodes_pair]]
the options are rival pairs ([[daughter1]], [[daughter2]]).
Therefore we have to pass two allocatable arrays of type [[f_node_ptr_t]]
to the subroutine.
<<Cascades2: dag options: TBP>>=
procedure :: make_f_nodes => dag_options_make_f_nodes
<<Cascades2: sub interfaces>>=
module subroutine dag_options_make_f_nodes (dag_options, &
feyngraph_set, dag)
class(dag_options_t), intent(inout) :: dag_options
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(dag_t), intent(inout) :: dag
end subroutine dag_options_make_f_nodes
<<Cascades2: procedures>>=
module subroutine dag_options_make_f_nodes (dag_options, &
feyngraph_set, dag)
class(dag_options_t), intent(inout) :: dag_options
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(dag_t), intent(inout) :: dag
integer, dimension (:), allocatable :: obj, i_obj
integer :: n_obj
integer :: i
integer :: pos
!!! read options
if (allocated (dag_options%f_node_ptr1)) return
n_obj = count ((dag_options%string%t%type == DAG_NODE_TK) .or. &
(dag_options%string%t%type == DAG_OPTIONS_TK) .or. &
(dag_options%string%t%type == DAG_COMBINATION_TK), 1)
allocate (obj(n_obj)); allocate (i_obj(n_obj))
pos = 0
do i = 1, size (dag_options%string%t)
select case (dag_options%string%t(i)%type)
case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
pos = pos + 1
obj(pos) = dag_options%string%t(i)%type
i_obj(pos) = dag_options%string%t(i)%index
end select
end do
if (any (dag_options%string%t%type == DAG_NODE_TK)) then
call dag_options_make_f_nodes_single
else if (any (dag_options%string%t%type == DAG_COMBINATION_TK)) then
call dag_options_make_f_nodes_pair
end if
deallocate (obj, i_obj)
contains
subroutine dag_options_make_f_nodes_single
integer :: i_start, i_end
integer :: n_nodes
n_nodes = 0
do i=1, n_obj
if (allocated (dag%node(i_obj(i))%f_node)) then
n_nodes = n_nodes + size (dag%node(i_obj(i))%f_node)
end if
end do
if (n_nodes /= 0) then
allocate (dag_options%f_node_ptr1 (n_nodes))
i_end = 0
do i = 1, n_obj
if (allocated (dag%node(i_obj(i))%f_node)) then
i_start = i_end + 1
i_end = i_end + size (dag%node(i_obj(i))%f_node)
dag_options%f_node_ptr1(i_start:i_end) = dag%node(i_obj(i))%f_node
end if
end do
end if
end subroutine dag_options_make_f_nodes_single
subroutine dag_options_make_f_nodes_pair
integer :: i_start, i_end
integer :: n_nodes
!!! get f_nodes from each combination
n_nodes = 0
do i=1, n_obj
if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then
n_nodes = n_nodes + size (dag%combination(i_obj(i))%f_node_ptr1)
end if
end do
if (n_nodes /= 0) then
allocate (dag_options%f_node_ptr1 (n_nodes))
allocate (dag_options%f_node_ptr2 (n_nodes))
i_end = 0
do i=1, n_obj
if (allocated (dag%combination(i_obj(i))%f_node_ptr1)) then
i_start = i_end + 1
i_end = i_end + size (dag%combination(i_obj(i))%f_node_ptr1)
dag_options%f_node_ptr1(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr1
dag_options%f_node_ptr2(i_start:i_end) = dag%combination(i_obj(i))%f_node_ptr2
end if
end do
end if
end subroutine dag_options_make_f_nodes_pair
end subroutine dag_options_make_f_nodes
@ %def dag_options_make_f_nodes
@ We create all combinations of daughter [[f_nodes]] for a combination.
In the combination each daughter can be either a single [[dag_node]] or
[[dag_options]] which are a set of single [[dag_nodes]]. Therefore, we
first create all possible [[f_nodes]] for daughter1, then all possible
[[f_nodes]] for daughter2. In the end we combine all [[daughter1]] nodes
with all [[daughter2]] nodes.
<<Cascades2: dag combination: TBP>>=
procedure :: make_f_nodes => dag_combination_make_f_nodes
<<Cascades2: sub interfaces>>=
module subroutine dag_combination_make_f_nodes (dag_combination, &
feyngraph_set, dag)
class(dag_combination_t), intent(inout) :: dag_combination
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(dag_t), intent(inout) :: dag
end subroutine dag_combination_make_f_nodes
<<Cascades2: procedures>>=
module subroutine dag_combination_make_f_nodes (dag_combination, &
feyngraph_set, dag)
class(dag_combination_t), intent(inout) :: dag_combination
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(dag_t), intent(inout) :: dag
integer, dimension (2) :: obj, i_obj
integer :: n_obj
integer :: new_size, size1, size2
integer :: i, j, pos
if (allocated (dag_combination%f_node_ptr1)) return
n_obj = 0
do i = 1, size (dag_combination%string%t)
select case (dag_combination%string%t(i)%type)
case (DAG_NODE_TK, DAG_OPTIONS_TK, DAG_COMBINATION_TK)
n_obj = n_obj + 1
if (n_obj > 2) return
obj(n_obj) = dag_combination%string%t(i)%type
i_obj(n_obj) = dag_combination%string%t(i)%index
end select
end do
size1 = 0
size2 = 0
if (obj(1) == DAG_NODE_TK) then
if (allocated (dag%node(i_obj(1))%f_node)) &
size1 = size (dag%node(i_obj(1))%f_node)
else if (obj(1) == DAG_OPTIONS_TK) then
if (allocated (dag%options(i_obj(1))%f_node_ptr1)) &
size1 = size (dag%options(i_obj(1))%f_node_ptr1)
end if
if (obj(2) == DAG_NODE_TK) then
if (allocated (dag%node(i_obj(2))%f_node)) &
size2 = size (dag%node(i_obj(2))%f_node)
else if (obj(2) == DAG_OPTIONS_TK) then
if (allocated (dag%options(i_obj(2))%f_node_ptr1)) &
size2 = size (dag%options(i_obj(2))%f_node_ptr1)
end if
!!! combine the 2 arrays of f_nodes
new_size = size1*size2
if (new_size /= 0) then
allocate (dag_combination%f_node_ptr1 (new_size))
allocate (dag_combination%f_node_ptr2 (new_size))
pos = 0
select case (obj(1))
case (DAG_NODE_TK)
select case (obj(2))
case (DAG_NODE_TK)
do i = 1, size1
do j = 1, size2
pos = pos + 1
dag_combination%f_node_ptr1(pos) = &
dag%node(i_obj(1))%f_node(i)
dag_combination%f_node_ptr2(pos) = &
dag%node(i_obj(2))%f_node(j)
end do
end do
case (DAG_OPTIONS_TK)
do i = 1, size1
do j = 1, size2
pos = pos + 1
dag_combination%f_node_ptr1(pos) = &
dag%node(i_obj(1))%f_node(i)
dag_combination%f_node_ptr2(pos) = &
dag%options(i_obj(2))%f_node_ptr1(j)
end do
end do
end select
case (DAG_OPTIONS_TK)
select case (obj(2))
case (DAG_NODE_TK)
do i = 1, size1
do j = 1, size2
pos = pos + 1
dag_combination%f_node_ptr1(pos) = &
dag%options(i_obj(1))%f_node_ptr1(i)
dag_combination%f_node_ptr2(pos) = &
dag%node(i_obj(2))%f_node(j)
end do
end do
case (DAG_OPTIONS_TK)
do i = 1, size1
do j = 1, size2
pos = pos + 1
dag_combination%f_node_ptr1(pos) = &
dag%options(i_obj(1))%f_node_ptr1(i)
dag_combination%f_node_ptr2(pos) = &
dag%options(i_obj(2))%f_node_ptr1(j)
end do
end do
end select
end select
end if
end subroutine dag_combination_make_f_nodes
@ %def dag_combination_make_f_nodes
@ Here we create the [[feyngraphs]]. After the construction of the
[[dag]] the remaining [[dag_string]] should contain a token for a
single [[dag_node]] which corresponds to the roots of the
[[feyngraphs]]. Therefore we make all [[f_nodes]] for this [[dag_node]]
and create a [[feyngraph]] for each [[f_node]]. Note that only
3-vertices are accepted. All other vertices are rejected. The
starting point is the last dag node which has been added to the list,
since this corresponds to the root of the tree.
Is is important to understand that the structure of feyngraphs is not
the same as the structure of the dag which is read from file, because
for the calculations which are performed in this module we want to
reuse the nodes for the outgoing particles, which means that they
appear only once. In O'Mega's output, it is the first incoming particle
which appears only once and the outgoing particles appear many times. This
transition is incorporated in the subroutines which create [[f_nodes]]
from the different dag objects.
<<Cascades2: dag: TBP>>=
procedure :: make_feyngraphs => dag_make_feyngraphs
<<Cascades2: sub interfaces>>=
module subroutine dag_make_feyngraphs (dag, feyngraph_set)
class(dag_t), intent(inout) :: dag
type(feyngraph_set_t), intent(inout) :: feyngraph_set
end subroutine dag_make_feyngraphs
<<Cascades2: procedures>>=
module subroutine dag_make_feyngraphs (dag, feyngraph_set)
class(dag_t), intent(inout) :: dag
type(feyngraph_set_t), intent(inout) :: feyngraph_set
integer :: i
integer :: max_subtree_size
max_subtree_size = dag%node(dag%n_nodes)%subtree_size
if (allocated (dag%node(dag%n_nodes)%f_node)) then
do i = 1, size (dag%node(dag%n_nodes)%f_node)
if (.not. associated (feyngraph_set%first)) then
allocate (feyngraph_set%last)
feyngraph_set%first => feyngraph_set%last
else
allocate (feyngraph_set%last%next)
feyngraph_set%last => feyngraph_set%last%next
end if
feyngraph_set%last%root => dag%node(dag%n_nodes)%f_node(i)%node
!!! The first particle was correct in the O'Mega parsable DAG output.
!!! It was however changed to its anti-particle in
!!! f_node_assign_particle_properties, which we revert here.
feyngraph_set%last%root%particle => &
feyngraph_set%last%root%particle%anti
feyngraph_set%last%n_nodes = feyngraph_set%last%root%n_subtree_nodes
feyngraph_set%n_graphs = feyngraph_set%n_graphs + 1
end do
feyngraph_set%f_node_list%max_tree_size = feyngraph_set%first%n_nodes
end if
end subroutine dag_make_feyngraphs
@ %def dag_make_feyngraphs
@ A write procedure of the [[dag]] for debugging.
<<Cascades2: dag: TBP>>=
procedure :: write => dag_write
<<Cascades2: sub interfaces>>=
module subroutine dag_write (dag, u)
class(dag_t), intent(in) :: dag
integer, intent(in) :: u
end subroutine dag_write
<<Cascades2: procedures>>=
module subroutine dag_write (dag, u)
class(dag_t), intent(in) :: dag
integer, intent(in) :: u
integer :: i
write (u,fmt='(A)') 'nodes'
do i=1, dag%n_nodes
write (u,fmt='(I5,3X,A)') i, char (dag%node(i)%string)
end do
write (u,fmt='(A)') 'options'
do i=1, dag%n_options
write (u,fmt='(I5,3X,A)') i, char (dag%options(i)%string)
end do
write (u,fmt='(A)') 'combination'
do i=1, dag%n_combinations
write (u,fmt='(I5,3X,A)') i, char (dag%combination(i)%string)
end do
end subroutine dag_write
@ %def dag_write
@ Make a copy of a resonant [[k_node]], where the copy is kept
nonresonant.
<<Cascades2: procedures>>=
subroutine k_node_make_nonresonant_copy (k_node)
type(k_node_t), intent(in) :: k_node
type(k_node_t), pointer :: copy
call k_node%f_node%k_node_list%add_entry (copy, recycle=.true.)
copy%daughter1 => k_node%daughter1
copy%daughter2 => k_node%daughter2
copy = k_node
copy%mapping = NONRESONANT
copy%resonant = .false.
copy%on_shell = .false.
copy%mapping_assigned = .true.
copy%is_nonresonant_copy = .true.
end subroutine k_node_make_nonresonant_copy
@ %def k_node_make_nonresonant_copy
@ For a given [[feyngraph]] we create all possible [[kingraphs]]. Here
we use existing [[k_nodes]] which have already been created when the
mapping calculations of the pure s-channel subgraphs are performed. The
nodes for the incoming particles or the nodes on the t-line will have
to be created in all cases because they are not used in several graphs.
To obtain the existing [[k_nodes]], we use the subroutine
[[k_node_init_from_f_node]] which itself uses [[f_node_list_get_nodes]]
to obtain all active [[k_nodes]] in the [[k_node_list]] of the [[f_node]].
The created [[kingraphs]] are attached to the linked list
of the [[feyngraph]]. For scattering processes we have to split up the
t-line, because since all graphs are represented as a decay, different
nodes can share daughter nodes. This happens also for the t-line or
the incoming particle which appears as an outgoing particle. For the
[[t_line]] or [[incoming]] nodes we do not want to recycle nodes but
rather create a copy of this line for each [[kingraph]].
<<Cascades2: feyngraph: TBP>>=
procedure :: make_kingraphs => feyngraph_make_kingraphs
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set)
class(feyngraph_t), intent(inout) :: feyngraph
type(feyngraph_set_t), intent(in) :: feyngraph_set
end subroutine feyngraph_make_kingraphs
<<Cascades2: procedures>>=
module subroutine feyngraph_make_kingraphs (feyngraph, feyngraph_set)
class(feyngraph_t), intent(inout) :: feyngraph
type(feyngraph_set_t), intent(in) :: feyngraph_set
type(k_node_ptr_t), dimension (:), allocatable :: kingraph_root
integer :: i
if (.not. associated (feyngraph%kin_first)) then
call k_node_init_from_f_node (feyngraph%root, &
kingraph_root, feyngraph_set)
if (.not. feyngraph%root%keep) return
if (feyngraph_set%process_type == SCATTERING) then
call split_up_t_lines (kingraph_root)
end if
do i=1, size (kingraph_root)
if (associated (feyngraph%kin_last)) then
allocate (feyngraph%kin_last%next)
feyngraph%kin_last => feyngraph%kin_last%next
else
allocate (feyngraph%kin_last)
feyngraph%kin_first => feyngraph%kin_last
end if
feyngraph%kin_last%root => kingraph_root(i)%node
feyngraph%kin_last%n_nodes = feyngraph%n_nodes
feyngraph%kin_last%keep = feyngraph%keep
if (feyngraph_set%process_type == SCATTERING) then
feyngraph%kin_last%root%bincode = &
f_node_get_external_bincode (feyngraph_set, feyngraph%root)
end if
end do
deallocate (kingraph_root)
end if
end subroutine feyngraph_make_kingraphs
@ %def feyngraph_make_kingraphs
@ Create all [[k_nodes]] for a given [[f_node]]. We return these nodes
using [[k_node_ptr]]. If the node is external, we assign also the bincode
to the [[k_nodes]] because this is determined from substrings of the
input file which belong to the [[feyngraphs]] and [[f_nodes]].
<<Cascades2: procedures>>=
recursive subroutine k_node_init_from_f_node (f_node, k_node_ptr, feyngraph_set)
type(f_node_t), target, intent(inout) :: f_node
type(k_node_ptr_t), allocatable, dimension (:), intent(out) :: k_node_ptr
type(feyngraph_set_t), intent(in) :: feyngraph_set
type(k_node_ptr_t), allocatable, dimension(:) :: daughter_ptr1, daughter_ptr2
integer :: n_nodes
integer :: i, j
integer :: pos
integer, save :: counter = 0
if (.not. (f_node%incoming .or. f_node%t_line)) then
call f_node%k_node_list%get_nodes (k_node_ptr)
if (.not. allocated (k_node_ptr) .and. f_node%k_node_list%n_entries > 0) then
f_node%keep = .false.
return
end if
end if
if (.not. allocated (k_node_ptr)) then
if (associated (f_node%daughter1) .and. associated (f_node%daughter2)) then
call k_node_init_from_f_node (f_node%daughter1, daughter_ptr1, &
feyngraph_set)
call k_node_init_from_f_node (f_node%daughter2, daughter_ptr2, &
feyngraph_set)
if (.not. (f_node%daughter1%keep .and. f_node%daughter2%keep)) then
f_node%keep = .false.
return
end if
n_nodes = size (daughter_ptr1) * size (daughter_ptr2)
allocate (k_node_ptr (n_nodes))
pos = 1
do i=1, size (daughter_ptr1)
do j=1, size (daughter_ptr2)
if (f_node%incoming .or. f_node%t_line) then
call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .false.)
else
call f_node%k_node_list%add_entry (k_node_ptr(pos)%node, recycle = .true.)
end if
k_node_ptr(pos)%node%f_node => f_node
k_node_ptr(pos)%node%daughter1 => daughter_ptr1(i)%node
k_node_ptr(pos)%node%daughter2 => daughter_ptr2(j)%node
k_node_ptr(pos)%node%f_node_index = f_node%index
k_node_ptr(pos)%node%incoming = f_node%incoming
k_node_ptr(pos)%node%t_line = f_node%t_line
k_node_ptr(pos)%node%particle => f_node%particle
pos = pos + 1
end do
end do
deallocate (daughter_ptr1, daughter_ptr2)
else
allocate (k_node_ptr(1))
if (f_node%incoming .or. f_node%t_line) then
call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.false.)
else
call f_node%k_node_list%add_entry (k_node_ptr(1)%node, recycle=.true.)
end if
k_node_ptr(1)%node%f_node => f_node
k_node_ptr(1)%node%f_node_index = f_node%index
k_node_ptr(1)%node%incoming = f_node%incoming
k_node_ptr(1)%node%t_line = f_node%t_line
k_node_ptr(1)%node%particle => f_node%particle
k_node_ptr(1)%node%bincode = f_node_get_external_bincode (feyngraph_set, &
f_node)
end if
end if
end subroutine k_node_init_from_f_node
@ %def k_node_init_from_f_node
@ The graphs resulting from [[k_node_init_from_f_node]] are fine if they
are used only in one direction. This is however not the case when one
wants to invert the graphs, i.e. take the other incoming particle of a
scattering process as the decaying particle, because the outgoing
[[f_nodes]] (and hence also the [[k_nodes]]) exist only once. This
problem is solved here by creating a distinct t-line for each of the
graphs. The following subroutine disentangles the data structure by
creating new nodes such that the different t-lines are not connected
any more.
<<Cascades2: procedures>>=
recursive subroutine split_up_t_lines (t_node)
type(k_node_ptr_t), dimension(:), intent(inout) :: t_node
type(k_node_t), pointer :: ref_node => null ()
type(k_node_t), pointer :: ref_daughter => null ()
type(k_node_t), pointer :: new_daughter => null ()
type(k_node_ptr_t), dimension(:), allocatable :: t_daughter
integer :: ref_daughter_index
integer :: i, j
allocate (t_daughter (size (t_node)))
do i=1, size (t_node)
ref_node => t_node(i)%node
if (associated (ref_node%daughter1) .and. associated (ref_node%daughter2)) then
ref_daughter => null ()
if (ref_node%daughter1%incoming .or. ref_node%daughter1%t_line) then
ref_daughter => ref_node%daughter1
ref_daughter_index = 1
else if (ref_node%daughter2%incoming .or. ref_node%daughter2%t_line) then
ref_daughter => ref_node%daughter2
ref_daughter_index = 2
end if
do j=1, size (t_daughter)
if (.not. associated (t_daughter(j)%node)) then
t_daughter(j)%node => ref_daughter
exit
else if (t_daughter(j)%node%index == ref_daughter%index) then
new_daughter => null ()
call ref_daughter%f_node%k_node_list%add_entry (new_daughter, recycle=.false.)
new_daughter = ref_daughter
new_daughter%daughter1 => ref_daughter%daughter1
new_daughter%daughter2 => ref_daughter%daughter2
if (ref_daughter_index == 1) then
ref_node%daughter1 => new_daughter
else if (ref_daughter_index == 2) then
ref_node%daughter2 => new_daughter
end if
ref_daughter => new_daughter
end if
end do
else
return
end if
end do
call split_up_t_lines (t_daughter)
deallocate (t_daughter)
end subroutine split_up_t_lines
@ %def split_up_t_lines
@ This subroutine sets the [[inverse_daughters]] of a [[k_node]]. If we
invert a [[kingraph]] such that not the first but the second incoming
particle appears as the root of the tree, the [[incoming]] and [[t_line]]
particles obtain other daughters. These are the former mother node and
the sister node [[s_daughter]]. Here we set only the pointers for
the [[inverse_daughters]]. The inversion happens in [[kingraph_make_inverse_copy]]
and [[node_inverse_deep_copy]].
<<Cascades2: procedures>>=
subroutine kingraph_set_inverse_daughters (kingraph)
type(kingraph_t), intent(inout) :: kingraph
type(k_node_t), pointer :: mother
type(k_node_t), pointer :: t_daughter
type(k_node_t), pointer :: s_daughter
mother => kingraph%root
do while (associated (mother))
if (associated (mother%daughter1) .and. &
associated (mother%daughter2)) then
if (mother%daughter1%t_line .or. mother%daughter1%incoming) then
t_daughter => mother%daughter1; s_daughter => mother%daughter2
else if (mother%daughter2%t_line .or. mother%daughter2%incoming) then
t_daughter => mother%daughter2; s_daughter => mother%daughter1
else
exit
end if
t_daughter%inverse_daughter1 => mother
t_daughter%inverse_daughter2 => s_daughter
mother => t_daughter
else
exit
end if
end do
end subroutine kingraph_set_inverse_daughters
@ %def kingraph_set_inverse_daughters
@ Set the bincode of an [[f_node]] which corresponds to an external
particle. This is done on the basis of the [[particle_label]] which is a
substring of the input file. Here it is not the particle name which is
important, but the number(s) in brackets which in general indicate the
external particles which are connected to the current node. This function
is however only used for external particles, so there can either be
one or [[n_out + 1]] particles in the brackets (in the DAG input file
always one, because also for the root there is only a single number).
In all cases we check the number of particles (in the DAG input the
numbers are separated by a slash).
<<Cascades2: procedures>>=
function f_node_get_external_bincode (feyngraph_set, f_node) result (bincode)
type(feyngraph_set_t), intent(in) :: feyngraph_set
type(f_node_t), intent(in) :: f_node
integer (TC) :: bincode
character(len=LABEL_LEN) :: particle_label
integer :: start_pos, end_pos, n_out_decay
integer :: n_prt ! for DAG
integer :: i
bincode = 0
if (feyngraph_set%process_type == DECAY) then
n_out_decay = feyngraph_set%n_out
else
n_out_decay = feyngraph_set%n_out + 1
end if
particle_label = f_node%particle_label
start_pos = index (particle_label, '[') + 1
end_pos = index (particle_label, ']') - 1
particle_label = particle_label(start_pos:end_pos)
!!! n_out_decay is the number of outgoing particles in the
!!! O'Mega output, which is always represented as a decay
if (feyngraph_set%use_dag) then
n_prt = 1
do i=1, len(particle_label)
if (particle_label(i:i) == '/') n_prt = n_prt + 1
end do
else
n_prt = end_pos - start_pos + 1
end if
if (n_prt == 1) then
bincode = calculate_external_bincode (particle_label, &
feyngraph_set%process_type, n_out_decay)
else if (n_prt == n_out_decay) then
bincode = ibset (0, n_out_decay)
end if
end function f_node_get_external_bincode
@ %def f_node_get_external_bincode
@ Assign a bincode to an internal node, which is calculated from
the bincodes of [[daughter1]] and [[daughter2]].
<<Cascades2: procedures>>=
subroutine node_assign_bincode (node)
type(k_node_t), intent(inout) :: node
if (associated (node%daughter1) .and. associated (node%daughter2) &
.and. .not. node%incoming) then
node%bincode = ior(node%daughter1%bincode, node%daughter2%bincode)
end if
end subroutine node_assign_bincode
@ %def node_assign_bincode
@ Calculate the [[bincode]] from the number in the brackets of the
[[particle_label]], if the node is external. For the root in the
non-factorized output, this is calculated directly in
[[f_node_get_external_bincode]] because in this case all the other
external particle numbers appear between the brackets.
<<Cascades2: procedures>>=
function calculate_external_bincode (label_number_string, process_type, n_out_decay) result (bincode)
character(len=*), intent(in) :: label_number_string
integer, intent(in) :: process_type
integer, intent(in) :: n_out_decay
character :: number_char
integer :: number_int
integer (kind=TC) :: bincode
bincode = 0
read (label_number_string, fmt='(A)') number_char
!!! check if the character is a letter (A,B,C,...) or a number (1...9)
!!! numbers 1 and 2 are special cases
select case (number_char)
case ('1')
if (process_type == SCATTERING) then
number_int = n_out_decay + 3
else
number_int = n_out_decay + 2
end if
case ('2')
if (process_type == SCATTERING) then
number_int = n_out_decay + 2
else
number_int = 2
end if
case ('A')
number_int = 10
case ('B')
number_int = 11
case ('C')
number_int = 12
case ('D')
number_int = 13
case default
read (number_char, fmt='(I1)') number_int
end select
bincode = ibset (bincode, number_int - process_type - 1)
end function calculate_external_bincode
@ %def calculate_external_bincode
@
\subsection{Mapping calculations}
Once a [[k_node]] and its subtree nodes have been created, we can
perform the kinematical calculations and assign mappings, depending on
the particle properties and the results for the subtree nodes. This
could in principle be done recursively, calling the procedure first
for the daughter nodes and then perform the calculations for the actual
node. But for parallization and comparing the nodes, this will be done
simultaneously for all nodes with the same number of subtree nodes, and the number of
subtree nodes increases, starting from one, in steps of two. The
actual mapping calculations are done in complete analogy to cascades.
<<Cascades2: procedures>>=
subroutine node_assign_mapping_s (feyngraph, node, feyngraph_set)
type(feyngraph_t), intent(inout) :: feyngraph
type(k_node_t), intent(inout) :: node
type(feyngraph_set_t), intent(inout) :: feyngraph_set
real(default) :: eff_mass_sum
logical :: keep
if (.not. node%mapping_assigned) then
if (node%particle%mass > feyngraph_set%phs_par%m_threshold_s) then
node%effective_mass = node%particle%mass
end if
if (associated (node%daughter1) .and. associated (node%daughter2)) then
if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then
node%keep = .false.; return
end if
node%ext_mass_sum = node%daughter1%ext_mass_sum &
+ node%daughter2%ext_mass_sum
keep = .false.
!!! Potentially resonant cases [sqrts = m_rea for on-shell decay]
if (node%particle%mass > node%ext_mass_sum &
.and. node%particle%mass <= feyngraph_set%phs_par%sqrts) then
if (node%particle%width /= 0) then
if (node%daughter1%on_shell .or. node%daughter2%on_shell) then
keep = .true.
node%mapping = S_CHANNEL
node%resonant = .true.
end if
else
call warn_decay (node%particle)
end if
!!! Collinear and IR singular cases
else if (node%particle%mass < feyngraph_set%phs_par%sqrts) then
!!! Massless splitting
if (node%daughter1%effective_mass == 0 &
.and. node%daughter2%effective_mass == 0 &
.and. .not. associated (node%daughter1%daughter1) &
.and. .not. associated (node%daughter1%daughter2) &
.and. .not. associated (node%daughter2%daughter1) &
.and. .not. associated (node%daughter2%daughter2)) then
keep = .true.
node%log_enhanced = .true.
if (node%particle%is_vector) then
if (node%daughter1%particle%is_vector &
.and. node%daughter2%particle%is_vector) then
node%mapping = COLLINEAR !!! three-vector-splitting
else
node%mapping = INFRARED !!! vector spliiting into matter
end if
else
if (node%daughter1%particle%is_vector &
.or. node%daughter2%particle%is_vector) then
node%mapping = COLLINEAR !!! vector radiation off matter
else
node%mapping = INFRARED !!! scalar radiation/splitting
end if
end if
!!! IR radiation off massive particle [cascades]
else if (node%effective_mass > 0 .and. &
node%daughter1%effective_mass > 0 .and. &
node%daughter2%effective_mass == 0 .and. &
(node%daughter1%on_shell .or. &
node%daughter1%mapping == RADIATION) .and. &
abs (node%effective_mass - &
node%daughter1%effective_mass) < feyngraph_set%phs_par%m_threshold_s) &
then
keep = .true.
node%log_enhanced = .true.
node%mapping = RADIATION
else if (node%effective_mass > 0 .and. &
node%daughter2%effective_mass > 0 .and. &
node%daughter1%effective_mass == 0 .and. &
(node%daughter2%on_shell .or. &
node%daughter2%mapping == RADIATION) .and. &
abs (node%effective_mass - &
node%daughter2%effective_mass) < feyngraph_set%phs_par%m_threshold_s) &
then
keep = .true.
node%log_enhanced = .true.
node%mapping = RADIATION
end if
end if
!!! Non-singular cases, including failed resonances [from cascades]
if (.not. keep) then
!!! Two on-shell particles from a virtual mother [from cascades, here eventually more than 2]
if (node%daughter1%on_shell .or. node%daughter2%on_shell) then
keep = .true.
eff_mass_sum = node%daughter1%effective_mass &
+ node%daughter2%effective_mass
node%effective_mass = max (node%ext_mass_sum, eff_mass_sum)
if (node%effective_mass < feyngraph_set%phs_par%m_threshold_s) then
node%effective_mass = 0
end if
end if
end if
!!! Complete and register feyngraph (make copy in case of resonance)
if (keep) then
node%on_shell = node%resonant .or. node%log_enhanced
if (node%resonant) then
if (feyngraph_set%phs_par%keep_nonresonant) then
call k_node_make_nonresonant_copy (node)
end if
node%ext_mass_sum = node%particle%mass
end if
end if
node%mapping_assigned = .true.
call node_assign_bincode (node)
call node%subtree%add_entry (node)
else !!! external (outgoing) particle
node%ext_mass_sum = node%particle%mass
node%mapping = EXTERNAL_PRT
node%multiplicity = 1
node%mapping_assigned = .true.
call node%subtree%add_entry (node)
node%on_shell = .true.
if (node%particle%mass >= feyngraph_set%phs_par%m_threshold_s) then
node%effective_mass = node%particle%mass
end if
end if
else if (node%is_nonresonant_copy) then
call node_assign_bincode (node)
call node%subtree%add_entry (node)
node%is_nonresonant_copy = .false.
end if
call node_count_specific_properties (node)
if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
node%keep = .false.
end if
contains
subroutine warn_decay (particle)
type(part_prop_t), intent(in) :: particle
integer :: i
integer, dimension(MAX_WARN_RESONANCE), save :: warned_code = 0
LOOP_WARNED: do i = 1, MAX_WARN_RESONANCE
if (warned_code(i) == 0) then
warned_code(i) = particle%pdg
write (msg_buffer, "(A)") &
& " Intermediate decay of zero-width particle " &
& // trim(particle%particle_label) &
& // " may be possible."
call msg_warning
exit LOOP_WARNED
else if (warned_code(i) == particle%pdg) then
exit LOOP_WARNED
end if
end do LOOP_WARNED
end subroutine warn_decay
end subroutine node_assign_mapping_s
@ %def node_assign_mapping_s
@ We determine the numbers [[n_resonances]], [[multiplicity]],
[[n_off_shell]] and [[n_log_enhanced]] for a given node.
<<Cascades2: procedures>>=
subroutine node_count_specific_properties (node)
type(k_node_t), intent(inout) :: node
if (associated (node%daughter1) .and. associated(node%daughter2)) then
if (node%resonant) then
node%multiplicity = 1
node%n_resonances &
= node%daughter1%n_resonances &
+ node%daughter2%n_resonances + 1
else
node%multiplicity &
= node%daughter1%multiplicity &
+ node%daughter2%multiplicity
node%n_resonances &
= node%daughter1%n_resonances &
+ node%daughter2%n_resonances
end if
if (node%log_enhanced) then
node%n_log_enhanced &
= node%daughter1%n_log_enhanced &
+ node%daughter2%n_log_enhanced + 1
else
node%n_log_enhanced &
= node%daughter1%n_log_enhanced &
+ node%daughter2%n_log_enhanced
end if
if (node%resonant) then
node%n_off_shell = 0
else if (node%log_enhanced) then
node%n_off_shell &
= node%daughter1%n_off_shell &
+ node%daughter2%n_off_shell
else
node%n_off_shell &
= node%daughter1%n_off_shell &
+ node%daughter2%n_off_shell + 1
end if
if (node%t_line) then
if (node%daughter1%t_line .or. node%daughter1%incoming) then
node%n_t_channel = node%daughter1%n_t_channel + 1
else if (node%daughter2%t_line .or. node%daughter2%incoming) then
node%n_t_channel = node%daughter2%n_t_channel + 1
end if
end if
end if
end subroutine node_count_specific_properties
@ %def node_count_specific_properties
@ The subroutine [[kingraph_assign_mappings_s]] completes kinematical
calculations for a decay process, considering the [[root]] node.
<<Cascades2: procedures>>=
subroutine kingraph_assign_mappings_s (feyngraph, kingraph, feyngraph_set)
type(feyngraph_t), intent(inout) :: feyngraph
type(kingraph_t), pointer, intent(inout) :: kingraph
type(feyngraph_set_t), intent(inout) :: feyngraph_set
if (.not. (kingraph%root%daughter1%keep .and. kingraph%root%daughter2%keep)) then
kingraph%keep = .false.
call kingraph%tree%final ()
end if
if (kingraph%keep) then
kingraph%root%on_shell = .true.
kingraph%root%mapping = EXTERNAL_PRT
kingraph%root%mapping_assigned = .true.
call node_assign_bincode (kingraph%root)
kingraph%root%ext_mass_sum = &
kingraph%root%daughter1%ext_mass_sum + &
kingraph%root%daughter2%ext_mass_sum
if (kingraph%root%ext_mass_sum >= feyngraph_set%phs_par%sqrts) then
kingraph%root%keep = .false.
kingraph%keep = .false.; call kingraph%tree%final (); return
end if
call kingraph%root%subtree%add_entry (kingraph%root)
kingraph%root%multiplicity &
= kingraph%root%daughter1%multiplicity &
+ kingraph%root%daughter2%multiplicity
kingraph%root%n_resonances &
= kingraph%root%daughter1%n_resonances &
+ kingraph%root%daughter2%n_resonances
kingraph%root%n_off_shell &
= kingraph%root%daughter1%n_off_shell &
+ kingraph%root%daughter2%n_off_shell
kingraph%root%n_log_enhanced &
= kingraph%root%daughter1%n_log_enhanced &
+ kingraph%root%daughter2%n_log_enhanced
if (kingraph%root%n_off_shell > feyngraph_set%phs_par%off_shell) then
kingraph%root%keep = .false.
kingraph%keep = .false.; call kingraph%tree%final (); return
else
kingraph%grove_prop%multiplicity = &
kingraph%root%multiplicity
kingraph%grove_prop%n_resonances = &
kingraph%root%n_resonances
kingraph%grove_prop%n_off_shell = &
kingraph%root%n_off_shell
kingraph%grove_prop%n_log_enhanced = &
kingraph%root%n_log_enhanced
end if
kingraph%tree = kingraph%root%subtree
end if
end subroutine kingraph_assign_mappings_s
@ %def kingraph_assign_mappings_s
@ Compute mappings for the [[t_line]] and [[incoming]] nodes. This is
done recursively using [[node_compute_t_line]].
<<Cascades2: procedures>>=
subroutine kingraph_compute_mappings_t_line (feyngraph, kingraph, feyngraph_set)
type(feyngraph_t), intent(inout) :: feyngraph
type(kingraph_t), pointer, intent(inout) :: kingraph
type(feyngraph_set_t), intent(inout) :: feyngraph_set
call node_compute_t_line (feyngraph, kingraph, kingraph%root, feyngraph_set)
if (.not. kingraph%root%keep) then
kingraph%keep = .false.
call kingraph%tree%final ()
end if
if (kingraph%keep) kingraph%tree = kingraph%root%subtree
end subroutine kingraph_compute_mappings_t_line
@ %def kingraph_compute_mappings_t_line
@ Perform the kinematical calculations and mapping assignment for a node
which is either [[incoming]] or [[t_line]]. This is done recursively,
going first to the daughter node which has this property. Therefore we
first set the pointer [[t_node]] to this daughter node and [[s_node]] to
the other one. The mapping determination happens again in the same way as
in [[cascades]].
<<Cascades2: procedures>>=
recursive subroutine node_compute_t_line (feyngraph, kingraph, node, feyngraph_set)
type(feyngraph_t), intent(inout) :: feyngraph
type(kingraph_t), intent(inout) :: kingraph
type(k_node_t), intent(inout) :: node
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(k_node_t), pointer :: s_node
type(k_node_t), pointer :: t_node
type(k_node_t), pointer :: new_s_node
if (.not. (node%daughter1%keep .and. node%daughter2%keep)) then
node%keep = .false.
return
end if
s_node => null ()
t_node => null ()
new_s_node => null ()
if (associated (node%daughter1) .and. associated (node%daughter2)) then
if (node%daughter1%t_line .or. node%daughter1%incoming) then
t_node => node%daughter1; s_node => node%daughter2
else if (node%daughter2%t_line .or. node%daughter2%incoming) then
t_node => node%daughter2; s_node => node%daughter1
end if
if (t_node%t_line) then
call node_compute_t_line (feyngraph, kingraph, t_node, feyngraph_set)
if (.not. t_node%keep) then
node%keep = .false.
return
end if
else if (t_node%incoming) then
t_node%mapping = EXTERNAL_PRT
t_node%on_shell = .true.
t_node%ext_mass_sum = t_node%particle%mass
if (t_node%particle%mass >= feyngraph_set%phs_par%m_threshold_t) then
t_node%effective_mass = t_node%particle%mass
end if
call t_node%subtree%add_entry (t_node)
end if
!!! root:
if (.not. node%incoming) then
if (t_node%incoming) then
node%ext_mass_sum = s_node%ext_mass_sum
else
node%ext_mass_sum &
= node%daughter1%ext_mass_sum &
+ node%daughter2%ext_mass_sum
end if
if (node%particle%mass > feyngraph_set%phs_par%m_threshold_t) then
node%effective_mass = max (node%particle%mass, &
s_node%effective_mass)
else if (s_node%effective_mass > feyngraph_set%phs_par%m_threshold_t) then
node%effective_mass = s_node%effective_mass
else
node%effective_mass = 0
end if
!!! Allowed decay of beam particle
if (t_node%incoming &
.and. t_node%particle%mass > s_node%particle%mass &
+ node%particle%mass) then
call beam_decay (feyngraph_set%fatal_beam_decay)
!!! Massless splitting
else if (t_node%effective_mass == 0 &
.and. s_node%effective_mass < feyngraph_set%phs_par%m_threshold_t &
.and. node%effective_mass == 0) then
node%mapping = U_CHANNEL
node%log_enhanced = .true.
!!! IR radiation off massive particle
else if (t_node%effective_mass /= 0 &
.and. s_node%effective_mass == 0 &
.and. node%effective_mass /= 0 &
.and. (t_node%on_shell &
.or. t_node%mapping == RADIATION) &
.and. abs (t_node%effective_mass - node%effective_mass) &
< feyngraph_set%phs_par%m_threshold_t) then
node%log_enhanced = .true.
node%mapping = RADIATION
end if
node%mapping_assigned = .true.
call node_assign_bincode (node)
call node%subtree%add_entry (node)
call node_count_specific_properties (node)
if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
node%keep = .false.
kingraph%keep = .false.; call kingraph%tree%final (); return
else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then
node%keep = .false.;
kingraph%keep = .false.; call kingraph%tree%final (); return
end if
else
node%mapping = EXTERNAL_PRT
node%on_shell = .true.
node%ext_mass_sum &
= t_node%ext_mass_sum &
+ s_node%ext_mass_sum
node%effective_mass = node%particle%mass
if (.not. (node%ext_mass_sum < feyngraph_set%phs_par%sqrts)) then
node%keep = .false.
kingraph%keep = .false.; call kingraph%tree%final (); return
end if
if (kingraph%keep) then
if (t_node%incoming .and. s_node%log_enhanced) then
call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.)
new_s_node = s_node
new_s_node%daughter1 => s_node%daughter1
new_s_node%daughter2 => s_node%daughter2
if (s_node%index == node%daughter1%index) then
node%daughter1 => new_s_node
else if (s_node%index == node%daughter2%index) then
node%daughter2 => new_s_node
end if
new_s_node%subtree = s_node%subtree
new_s_node%mapping = NO_MAPPING
new_s_node%log_enhanced = .false.
new_s_node%n_log_enhanced &
= new_s_node%n_log_enhanced - 1
new_s_node%log_enhanced = .false.
where (new_s_node%subtree%bc == new_s_node%bincode)
new_s_node%subtree%mapping = NO_MAPPING
endwhere
else if ((t_node%t_line .or. t_node%incoming) .and. &
t_node%mapping == U_CHANNEL) then
t_node%mapping = T_CHANNEL
where (t_node%subtree%bc == t_node%bincode)
t_node%subtree%mapping = T_CHANNEL
endwhere
else if (t_node%incoming .and. &
.not. associated (s_node%daughter1) .and. &
.not. associated (s_node%daughter2)) then
call s_node%f_node%k_node_list%add_entry (new_s_node, recycle=.false.)
new_s_node = s_node
new_s_node%mapping = ON_SHELL
new_s_node%daughter1 => s_node%daughter1
new_s_node%daughter2 => s_node%daughter2
new_s_node%subtree = s_node%subtree
if (s_node%index == node%daughter1%index) then
node%daughter1 => new_s_node
else if (s_node%index == node%daughter2%index) then
node%daughter2 => new_s_node
end if
where (new_s_node%subtree%bc == new_s_node%bincode)
new_s_node%subtree%mapping = ON_SHELL
endwhere
end if
end if
call node%subtree%add_entry (node)
node%multiplicity &
= node%daughter1%multiplicity &
+ node%daughter2%multiplicity
node%n_resonances &
= node%daughter1%n_resonances &
+ node%daughter2%n_resonances
node%n_off_shell &
= node%daughter1%n_off_shell &
+ node%daughter2%n_off_shell
node%n_log_enhanced &
= node%daughter1%n_log_enhanced &
+ node%daughter2%n_log_enhanced
node%n_t_channel &
= node%daughter1%n_t_channel &
+ node%daughter2%n_t_channel
if (node%n_off_shell > feyngraph_set%phs_par%off_shell) then
node%keep = .false.
kingraph%keep = .false.; call kingraph%tree%final (); return
else if (node%n_t_channel > feyngraph_set%phs_par%t_channel) then
node%keep = .false.
kingraph%keep = .false.; call kingraph%tree%final (); return
else
kingraph%grove_prop%multiplicity = node%multiplicity
kingraph%grove_prop%n_resonances = node%n_resonances
kingraph%grove_prop%n_off_shell = node%n_off_shell
kingraph%grove_prop%n_log_enhanced = node%n_log_enhanced
kingraph%grove_prop%n_t_channel = node%n_t_channel
end if
end if
end if
contains
subroutine beam_decay (fatal_beam_decay)
logical, intent(in) :: fatal_beam_decay
write (msg_buffer, "(1x,A,1x,'->',1x,A,1x,A)") &
t_node%particle%particle_label, &
node%particle%particle_label, &
s_node%particle%particle_label
call msg_message
write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
t_node%particle%particle_label, t_node%particle%mass
call msg_message
write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
node%particle%particle_label, node%particle%mass
call msg_message
write (msg_buffer, "(1x,'mass(',A,') =',1x,E17.10)") &
s_node%particle%particle_label, s_node%particle%mass
call msg_message
if (fatal_beam_decay) then
call msg_fatal (" Phase space: Initial beam particle can decay")
else
call msg_warning (" Phase space: Initial beam particle can decay")
end if
end subroutine beam_decay
end subroutine node_compute_t_line
@ %def node_compute_t_line
@ After all pure s-channel subdiagrams have already been created from the
corresponding [[f_nodes]] and mappings have been determined for their
nodes, we complete the calculations here. In a first step, the
[[kingraphs]] have to be created on the basis of the existing
[[k_nodes]], which means in particular that a [[feyngraph]] can give
rise to several [[kingraphs]] which will all be attached to the linked
list of the [[feyngraph]]. The calculations which remain are of different
kinds for decay and scattering processes. In a decay process the
kinematical calculations have to be done for the [[root]] node. In a
scattering process, after the creation of [[kingraphs]] in the first
step, there will be only [[kingraphs]] with the first incoming particle
as the [[root]] of the tree. For these graphs the [[inverse]] variable
has the value [[.false.]]. Before performing any calculations on these
graphs we make a so-called inverse copy of the graph (see below), which
will also be attached to the linked list. Since the s-channel subgraph
calculations have already been completed, only the t-line computations
remain.
<<Cascades2: feyngraph: TBP>>=
procedure :: make_inverse_kingraphs => feyngraph_make_inverse_kingraphs
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_make_inverse_kingraphs (feyngraph)
class(feyngraph_t), intent(inout) :: feyngraph
end subroutine feyngraph_make_inverse_kingraphs
<<Cascades2: procedures>>=
module subroutine feyngraph_make_inverse_kingraphs (feyngraph)
class(feyngraph_t), intent(inout) :: feyngraph
type(kingraph_t), pointer :: current
current => feyngraph%kin_first
do while (associated (current))
if (current%inverse) exit
call current%make_inverse_copy (feyngraph)
current => current%next
end do
end subroutine feyngraph_make_inverse_kingraphs
@ %def feyngraph_make_inverse_kingraphs
<<Cascades2: feyngraph: TBP>>=
procedure :: compute_mappings => feyngraph_compute_mappings
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set)
class(feyngraph_t), intent(inout) :: feyngraph
type(feyngraph_set_t), intent(inout) :: feyngraph_set
end subroutine feyngraph_compute_mappings
<<Cascades2: procedures>>=
module subroutine feyngraph_compute_mappings (feyngraph, feyngraph_set)
class(feyngraph_t), intent(inout) :: feyngraph
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(kingraph_t), pointer :: current
current => feyngraph%kin_first
do while (associated (current))
if (feyngraph_set%process_type == DECAY) then
call kingraph_assign_mappings_s (feyngraph, current, feyngraph_set)
else if (feyngraph_set%process_type == SCATTERING) then
call kingraph_compute_mappings_t_line &
(feyngraph, current, feyngraph_set)
end if
current => current%next
end do
end subroutine feyngraph_compute_mappings
@ %def feyngraph_compute_mappings
@ Here we control the mapping calculations for the nodes of s-channel
subgraphs. We start with the nodes with the smallest number of subtree
nodes and always increase this number by two because nodes have exactly
zero or two daughter nodes. We create the [[k_nodes]] using the
[[k_node_list]] of each [[f_node]]. The number of nodes which have to
be created depends of the number of existing daughter nodes, which means
that we have to create a node for each combination of existing and
valid (the ones which we [[keep]]) daughter nodes. If the node
corresponds to an external particle, we create only one node, since
there are no daughter nodes. If the particle is not external and
the daughter [[f_nodes]] do not contain any valid [[k_nodes]], we do
not create a new [[k_nodes]] either. When the calculations for all nodes
with the same number of subtree nodes have been completed, we compare
the valid nodes to eliminate equivalences (see below).
<<Cascades2: procedures>>=
subroutine f_node_list_compute_mappings_s (feyngraph_set)
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(f_node_ptr_t), dimension(:), allocatable :: set
type(k_node_ptr_t), dimension(:), allocatable :: k_set
type(k_node_entry_t), pointer :: k_entry
type(f_node_entry_t), pointer :: current
type(k_node_list_t), allocatable :: compare_list
integer :: n_entries
integer :: pos
integer :: i, j, k
do i = 1, feyngraph_set%f_node_list%max_tree_size - 2, 2
!!! Counter number of f_nodes with subtree size i for s channel calculations
n_entries = 0
if (feyngraph_set%use_dag) then
do j=1, feyngraph_set%dag%n_nodes
if (allocated (feyngraph_set%dag%node(j)%f_node)) then
do k=1, size(feyngraph_set%dag%node(j)%f_node)
if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then
if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming &
.or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) &
.and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then
n_entries = n_entries + 1
end if
end if
end do
end if
end do
else
current => feyngraph_set%f_node_list%first
do while (associated (current))
if (.not. (current%node%incoming .or. current%node%t_line) &
.and. current%node%n_subtree_nodes == i) then
n_entries = n_entries + 1
end if
current => current%next
end do
end if
if (n_entries == 0) exit
!!! Create a temporary k node list for comparison
allocate (set(n_entries))
pos = 0
if (feyngraph_set%use_dag) then
do j=1, feyngraph_set%dag%n_nodes
if (allocated (feyngraph_set%dag%node(j)%f_node)) then
do k=1, size(feyngraph_set%dag%node(j)%f_node)
if (associated (feyngraph_set%dag%node(j)%f_node(k)%node)) then
if (.not. (feyngraph_set%dag%node(j)%f_node(k)%node%incoming &
.or. feyngraph_set%dag%node(j)%f_node(k)%node%t_line) &
.and. feyngraph_set%dag%node(j)%f_node(k)%node%n_subtree_nodes == i) then
pos = pos + 1
set(pos)%node => feyngraph_set%dag%node(j)%f_node(k)%node
end if
end if
end do
end if
end do
else
current => feyngraph_set%f_node_list%first
do while (associated (current))
if (.not. (current%node%incoming .or. current%node%t_line) &
.and. current%node%n_subtree_nodes == i) then
pos = pos + 1
set(pos)%node => current%node
end if
current => current%next
end do
end if
allocate (compare_list)
compare_list%observer = .true.
do j = 1, n_entries
call k_node_init_from_f_node (set(j)%node, k_set, &
feyngraph_set)
if (allocated (k_set)) deallocate (k_set)
end do
!$OMP PARALLEL DO PRIVATE (k_entry)
do j = 1, n_entries
k_entry => set(j)%node%k_node_list%first
do while (associated (k_entry))
call node_assign_mapping_s(feyngraph_set%first, k_entry%node, feyngraph_set)
k_entry => k_entry%next
end do
end do
!$OMP END PARALLEL DO
do j = 1, size (set)
k_entry => set(j)%node%k_node_list%first
do while (associated (k_entry))
if (k_entry%node%keep) then
if (k_entry%node%mapping == NO_MAPPING .or. k_entry%node%mapping == NONRESONANT) then
call compare_list%add_pointer (k_entry%node)
end if
end if
k_entry => k_entry%next
end do
end do
deallocate (set)
call compare_list%check_subtree_equivalences(feyngraph_set%model)
call compare_list%final
deallocate (compare_list)
end do
end subroutine f_node_list_compute_mappings_s
@ %def f_node_list_compute_mappings_s
@
\subsection{Fill the grove list}
Find the [[grove]] within the [[grove_list]] for a [[kingraph]] for
which the kinematical calculations and mapping assignments have been completed. The [[groves]]
are defined by the [[grove_prop]] entries and the value of the resonance
hash ([[res_hash]]). Whenever a matching grove does not exist, we
create one. In a first step we consider only part of the grove properties
(see [[grove_prop_match]]) and the resonance hash is ignored, which leads
to a preliminary grove list. In the end all numbers in [[grove_prop]] as
well as the resonance hash are compared, i.e. we create a new
[[grove_list]].
<<Cascades2: grove list: TBP>>=
procedure :: get_grove => grove_list_get_grove
<<Cascades2: sub interfaces>>=
module subroutine grove_list_get_grove (grove_list, kingraph, &
return_grove, preliminary)
class(grove_list_t), intent(inout) :: grove_list
type(kingraph_t), intent(in), pointer :: kingraph
type(grove_t), intent(inout), pointer :: return_grove
logical, intent(in) :: preliminary
end subroutine grove_list_get_grove
<<Cascades2: procedures>>=
module subroutine grove_list_get_grove (grove_list, kingraph, &
return_grove, preliminary)
class(grove_list_t), intent(inout) :: grove_list
type(kingraph_t), intent(in), pointer :: kingraph
type(grove_t), intent(inout), pointer :: return_grove
logical, intent(in) :: preliminary
type(grove_t), pointer :: current_grove
return_grove => null ()
if (.not. associated(grove_list%first)) then
allocate (grove_list%first)
grove_list%first%grove_prop = kingraph%grove_prop
return_grove => grove_list%first
return
end if
current_grove => grove_list%first
do while (associated (current_grove))
if ((preliminary .and. &
(current_grove%grove_prop .match. kingraph%grove_prop)) .or. &
(.not. preliminary .and. &
current_grove%grove_prop == kingraph%grove_prop)) then
return_grove => current_grove
exit
else if (.not. associated (current_grove%next)) then
allocate (current_grove%next)
current_grove%next%grove_prop = kingraph%grove_prop
if (size (kingraph%tree%bc) < 9) &
current_grove%compare_tree%depth = 1
return_grove => current_grove%next
exit
end if
if (associated (current_grove%next)) then
current_grove => current_grove%next
end if
end do
end subroutine grove_list_get_grove
@ %def grove_list_get_grove
@ Add a valid [[kingraph]] to a [[grove_list]]. We first look for the
[[grove]] which has the grove properties of the [[kingraph]]. If no such
[[grove]] exists so far, it is created.
<<Cascades2: grove list: TBP>>=
procedure :: add_kingraph => grove_list_add_kingraph
<<Cascades2: sub interfaces>>=
module subroutine grove_list_add_kingraph (grove_list, kingraph, &
preliminary, check, model)
class(grove_list_t), intent(inout) :: grove_list
type(kingraph_t), pointer, intent(inout) :: kingraph
logical, intent(in) :: preliminary
logical, intent(in) :: check
type(model_data_t), optional, intent(in) :: model
end subroutine grove_list_add_kingraph
<<Cascades2: procedures>>=
module subroutine grove_list_add_kingraph (grove_list, kingraph, &
preliminary, check, model)
class(grove_list_t), intent(inout) :: grove_list
type(kingraph_t), pointer, intent(inout) :: kingraph
logical, intent(in) :: preliminary
logical, intent(in) :: check
type(model_data_t), optional, intent(in) :: model
type(grove_t), pointer :: grove
type(kingraph_t), pointer :: current
integer, save :: index = 0
grove => null ()
current => null ()
if (preliminary) then
if (kingraph%index == 0) then
index = index + 1
kingraph%index = index
end if
end if
call grove_list%get_grove (kingraph, grove, preliminary)
if (check) then
call grove%compare_tree%check_kingraph (kingraph, model, preliminary)
end if
if (kingraph%keep) then
if (associated (grove%first)) then
grove%last%grove_next => kingraph
grove%last => kingraph
else
grove%first => kingraph
grove%last => kingraph
end if
end if
end subroutine grove_list_add_kingraph
@ %ref grove_list_add_kingraph
@ For a given [[feyngraph]] we store all valid [[kingraphs]] in the
[[grove_list]].
<<Cascades2: grove list: TBP>>=
procedure :: add_feyngraph => grove_list_add_feyngraph
<<Cascades2: sub interfaces>>=
module subroutine grove_list_add_feyngraph (grove_list, feyngraph, model)
class(grove_list_t), intent(inout) :: grove_list
type(feyngraph_t), intent(inout) :: feyngraph
type(model_data_t), intent(in) :: model
end subroutine grove_list_add_feyngraph
<<Cascades2: procedures>>=
module subroutine grove_list_add_feyngraph (grove_list, feyngraph, model)
class(grove_list_t), intent(inout) :: grove_list
type(feyngraph_t), intent(inout) :: feyngraph
type(model_data_t), intent(in) :: model
type(kingraph_t), pointer :: current_kingraph, add_kingraph
do while (associated (feyngraph%kin_first))
if (feyngraph%kin_first%keep) then
add_kingraph => feyngraph%kin_first
feyngraph%kin_first => feyngraph%kin_first%next
add_kingraph%next => null ()
call grove_list%add_kingraph (kingraph=add_kingraph, &
preliminary=.true., check=.true., model=model)
else
exit
end if
end do
if (associated (feyngraph%kin_first)) then
current_kingraph => feyngraph%kin_first
do while (associated (current_kingraph%next))
if (current_kingraph%next%keep) then
add_kingraph => current_kingraph%next
current_kingraph%next => current_kingraph%next%next
add_kingraph%next => null ()
call grove_list%add_kingraph (kingraph=add_kingraph, &
preliminary=.true., check=.true., model=model)
else
current_kingraph => current_kingraph%next
end if
end do
end if
end subroutine grove_list_add_feyngraph
@ %def grove_list_add_feyngraph
@ Compare two [[grove_prop]] objects. The [[.match.]] operator is used
for preliminary groves in which the [[kingraphs]] share only the 3
numbers [[n_resonances]], [[n_log_enhanced]] and [[n_t_channel]]. These
groves are only used for comparing the kingraphs, because only graphs
within these preliminary groves can be equivalent (the numbers which are
compared here are unambigously fixed by the combination of mappings in
these channels).
<<Cascades2: interfaces>>=
interface operator (.match.)
module procedure grove_prop_match
end interface operator (.match.)
<<Cascades2: sub interfaces>>=
module function grove_prop_match (grove_prop1, grove_prop2) &
result (gp_match)
type(grove_prop_t), intent(in) :: grove_prop1
type(grove_prop_t), intent(in) :: grove_prop2
logical :: gp_match
end function grove_prop_match
<<Cascades2: procedures>>=
module function grove_prop_match (grove_prop1, grove_prop2) result (gp_match)
type(grove_prop_t), intent(in) :: grove_prop1
type(grove_prop_t), intent(in) :: grove_prop2
logical :: gp_match
gp_match = (grove_prop1%n_resonances == grove_prop2%n_resonances) &
.and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) &
.and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel)
end function grove_prop_match
@ %def grove_prop_match
@ The equal operator on the other hand will be used when all valid
[[kingraphs]] have been created and mappings have been determined, to
split up the existing (preliminary) grove list, i.e. to create new
groves which are determined by all entries in [[grove_prop_t]].
<<Cascades2: interfaces>>=
interface operator (==)
module procedure grove_prop_equal
end interface operator (==)
<<Cascades2: sub interfaces>>=
module function grove_prop_equal (grove_prop1, grove_prop2) &
result (gp_equal)
type(grove_prop_t), intent(in) :: grove_prop1
type(grove_prop_t), intent(in) :: grove_prop2
logical :: gp_equal
end function grove_prop_equal
<<Cascades2: procedures>>=
module function grove_prop_equal (grove_prop1, grove_prop2) result (gp_equal)
type(grove_prop_t), intent(in) :: grove_prop1
type(grove_prop_t), intent(in) :: grove_prop2
logical :: gp_equal
gp_equal = (grove_prop1%res_hash == grove_prop2%res_hash) &
.and. (grove_prop1%n_resonances == grove_prop2%n_resonances) &
.and. (grove_prop1%n_log_enhanced == grove_prop2%n_log_enhanced) &
.and. (grove_prop1%n_off_shell == grove_prop2%n_off_shell) &
.and. (grove_prop1%multiplicity == grove_prop2%multiplicity) &
.and. (grove_prop1%n_t_channel == grove_prop2%n_t_channel)
end function grove_prop_equal
@ %def grove_prop_equal
@
\subsection{Remove equivalent channels}
Here we define the equivalence condition for completed [[kingraphs]].
The aim is to keep those [[kingraphs]] which describe the strongest
peaks of the amplitude. The [[bincodes]] and [[mappings]] have to be
the same for an equivalence, but the [[pdgs]] can be different. At
the same time we check if the trees are exacly the same (up to the
sign of pdg codes) in which case we do not keep both of them. This
can be the case when the incoming particles are the same or their
mutual anti-particles and there are no t-channel lines in the
Feynman diagram to which the kingraph belongs.
<<Cascades2: parameters>>=
integer, parameter :: EMPTY = -999
<<Cascades2: procedures>>=
function kingraph_eqv (kingraph1, kingraph2) result (eqv)
type(kingraph_t), intent(in) :: kingraph1
type(kingraph_t), intent(inout) :: kingraph2
logical :: eqv
integer :: i
logical :: equal
eqv = .false.
do i = kingraph1%tree%n_entries, 1, -1
if (kingraph1%tree%bc(i) /= kingraph2%tree%bc(i)) return
end do
do i = kingraph1%tree%n_entries, 1, -1
if ( .not. (kingraph1%tree%mapping(i) == kingraph2%tree%mapping(i) &
.or. ((kingraph1%tree%mapping(i) == NO_MAPPING .or. &
kingraph1%tree%mapping(i) == NONRESONANT) .and. &
(kingraph2%tree%mapping(i) == NO_MAPPING .or. &
kingraph2%tree%mapping(i) == NONRESONANT)))) return
end do
equal = .true.
do i = kingraph1%tree%n_entries, 1, -1
if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then
equal = .false.;
select case (kingraph1%tree%mapping(i))
case (S_CHANNEL, RADIATION)
select case (kingraph2%tree%mapping(i))
case (S_CHANNEL, RADIATION)
return
end select
end select
end if
end do
if (equal) then
kingraph2%keep = .false.
call kingraph2%tree%final ()
else
eqv = .true.
end if
end function kingraph_eqv
@ %def kingraph_eqv
@ Select between two [[kingraphs]] which fulfill the equivalence
condition above. This is done by comparing the [[pdg]] values of the
[[tree]] for increasing bincode. If the particles are different at
some place, we usually choose the one which would be returned first by the
subroutine [[match_vertex]] of the model for the daughter [[pdg]] codes.
Since we work here only on the basis of the the [[trees]] of the
completed [[kingraphs]], we have to use the [[bc]] array to determine
the positions of the daughter nodes' entries in the array. The graph
which has to be kept should correspond to the stronger peak at the place
which is compared.
<<Cascades2: procedures>>=
subroutine kingraph_select (kingraph1, kingraph2, model, preliminary)
type(kingraph_t), intent(inout) :: kingraph1
type(kingraph_t), intent(inout) :: kingraph2
type(model_data_t), intent(in) :: model
logical, intent(in) :: preliminary
integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc
integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg
integer, dimension (:), allocatable :: pdg_match
integer :: i, j
integer :: n_ext1, n_ext2
if (kingraph_eqv (kingraph1, kingraph2)) then
if (.not. preliminary) then
kingraph2%keep = .false.; call kingraph2%tree%final ()
return
end if
do i=1, size (kingraph1%tree%bc)
if (abs(kingraph1%tree%pdg(i)) /= abs(kingraph2%tree%pdg(i))) then
if (kingraph1%tree%mapping(i) /= EXTERNAL_PRT) then
n_ext1 = popcnt (kingraph1%tree%bc(i))
n_ext2 = n_ext1
do j=i+1, size (kingraph1%tree%bc)
if (abs(kingraph1%tree%pdg(j)) /= abs(kingraph2%tree%pdg(j))) then
n_ext2 = popcnt (kingraph1%tree%bc(j))
if (n_ext2 < n_ext1) exit
end if
end do
if (n_ext2 < n_ext1) cycle
allocate (tmp_bc(i-1))
tmp_bc = kingraph1%tree%bc(:i-1)
allocate (tmp_pdg(i-1))
tmp_pdg = kingraph1%tree%pdg(:i-1)
do j=i-1, 1, - 1
where (iand (tmp_bc(:j-1),tmp_bc(j)) /= 0 &
.or. iand(tmp_bc(:j-1),kingraph1%tree%bc(i)) == 0)
tmp_bc(:j-1) = 0
tmp_pdg(:j-1) = 0
endwhere
end do
allocate (daughter_bc(size(pack(tmp_bc, tmp_bc /= 0))))
daughter_bc = pack (tmp_bc, tmp_bc /= 0)
allocate (daughter_pdg(size(pack(tmp_pdg, tmp_pdg /= 0))))
daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0)
if (size (daughter_pdg) == 2) then
call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match)
end if
do j=1, size (pdg_match)
if (abs(pdg_match(j)) == abs(kingraph1%tree%pdg(i))) then
kingraph2%keep = .false.; call kingraph2%tree%final ()
exit
else if (abs(pdg_match(j)) == abs(kingraph2%tree%pdg(i))) then
kingraph1%keep = .false.; call kingraph1%tree%final ()
exit
end if
end do
deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match)
if (.not. (kingraph1%keep .and. kingraph2%keep)) exit
end if
end if
end do
end if
end subroutine kingraph_select
@ %def kingraph_select
@ At the beginning we do not care about the resonance hash, but only
about part of the grove properties, which is defined in
[[grove_prop_match]]. In these resulting preliminary groves the kingraphs
can be equivalent, i.e. we do not have to compare all graphs with each
other but only all graphs within each of these preliminary groves. In the
end we create a new grove list where the grove properties of the
[[kingraphs]] within a [[grove]] have to be exactly the same and in
addition the groves are distinguished by the resonance hash values. Here
the kingraphs are not compared any more, which means that the number of
channels is not reduced any more.
<<Cascades2: grove list: TBP>>=
procedure :: merge => grove_list_merge
<<Cascades2: sub interfaces>>=
module subroutine grove_list_merge (target_list, grove_list, model, &
prc_component)
class(grove_list_t), intent(inout) :: target_list
type(grove_list_t), intent(inout) :: grove_list
type(model_data_t), intent(in) :: model
integer, intent(in) :: prc_component
end subroutine grove_list_merge
<<Cascades2: procedures>>=
module subroutine grove_list_merge (target_list, grove_list, model, &
prc_component)
class(grove_list_t), intent(inout) :: target_list
type(grove_list_t), intent(inout) :: grove_list
type(model_data_t), intent(in) :: model
integer, intent(in) :: prc_component
type(grove_t), pointer :: current_grove
type(kingraph_t), pointer :: current_graph
current_grove => grove_list%first
do while (associated (current_grove))
do while (associated (current_grove%first))
current_graph => current_grove%first
current_grove%first => current_grove%first%grove_next
current_graph%grove_next => null ()
if (current_graph%keep) then
current_graph%prc_component = prc_component
call target_list%add_kingraph(kingraph=current_graph, &
preliminary=.false., check=.true., model=model)
else
call current_graph%final ()
deallocate (current_graph)
end if
end do
current_grove => current_grove%next
end do
end subroutine grove_list_merge
@ %def grove_list_merge
@ Recreate a grove list where we have different groves for different
resonance hashes.
<<Cascades2: grove list: TBP>>=
procedure :: rebuild => grove_list_rebuild
<<Cascades2: sub interfaces>>=
module subroutine grove_list_rebuild (grove_list)
class(grove_list_t), intent(inout) :: grove_list
end subroutine grove_list_rebuild
<<Cascades2: procedures>>=
module subroutine grove_list_rebuild (grove_list)
class(grove_list_t), intent(inout) :: grove_list
type(grove_list_t) :: tmp_list
type(grove_t), pointer :: current_grove
type(grove_t), pointer :: remove_grove
type(kingraph_t), pointer :: current_graph
type(kingraph_t), pointer :: next_graph
tmp_list%first => grove_list%first
grove_list%first => null ()
current_grove => tmp_list%first
do while (associated (current_grove))
current_graph => current_grove%first
do while (associated (current_graph))
call current_graph%assign_resonance_hash ()
next_graph => current_graph%grove_next
current_graph%grove_next => null ()
if (current_graph%keep) then
call grove_list%add_kingraph (kingraph=current_graph, &
preliminary=.false., check=.false.)
end if
current_graph => next_graph
end do
current_grove => current_grove%next
end do
call tmp_list%final
end subroutine grove_list_rebuild
@ %def grove_list_rebuild
@
\subsection{Write the phase-space file}
The phase-space file is written from the graphs which survive the
calculations and equivalence checks and are in the grove list. It is
written grove by grove. The output should be the same as in the
corresponding procedure [[cascade_set_write_file_format]] of
[[cascades]], up to the order of groves and channels.
<<Cascades2: public>>=
public :: feyngraph_set_write_file_format
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_set_write_file_format (feyngraph_set, u)
type(feyngraph_set_t), intent(in) :: feyngraph_set
integer, intent(in) :: u
end subroutine feyngraph_set_write_file_format
<<Cascades2: procedures>>=
module subroutine feyngraph_set_write_file_format (feyngraph_set, u)
type(feyngraph_set_t), intent(in) :: feyngraph_set
integer, intent(in) :: u
type(grove_t), pointer :: grove
integer :: channel_number
integer :: grove_number
channel_number = 0
grove_number = 0
grove => feyngraph_set%grove_list%first
do while (associated (grove))
grove_number = grove_number + 1
call grove%write_file_format &
(feyngraph_set, grove_number, channel_number, u)
grove => grove%next
end do
end subroutine feyngraph_set_write_file_format
@ %def feyngraph_set_write_file_format
@ Write the relevant information of the [[kingraphs]] of a [[grove]] and
the grove properties in the file format.
<<Cascades2: grove: TBP>>=
procedure :: write_file_format => grove_write_file_format
<<Cascades2: sub interfaces>>=
recursive module subroutine grove_write_file_format &
(grove, feyngraph_set, gr_number, ch_number, u)
class(grove_t), intent(in) :: grove
type(feyngraph_set_t), intent(in) :: feyngraph_set
integer, intent(in) :: u
integer, intent(inout) :: gr_number
integer, intent(inout) :: ch_number
end subroutine grove_write_file_format
<<Cascades2: procedures>>=
recursive module subroutine grove_write_file_format &
(grove, feyngraph_set, gr_number, ch_number, u)
class(grove_t), intent(in) :: grove
type(feyngraph_set_t), intent(in) :: feyngraph_set
integer, intent(in) :: u
integer, intent(inout) :: gr_number
integer, intent(inout) :: ch_number
type(kingraph_t), pointer :: current
1 format(3x,A,1x,40(1x,I4))
write (u, "(A)")
write (u, "(1x,'!',1x,A,1x,I0,A)", advance='no') &
'Multiplicity =', grove%grove_prop%multiplicity, ","
select case (grove%grove_prop%n_resonances)
case (0)
write (u, '(1x,A)', advance='no') 'no resonances, '
case (1)
write (u, '(1x,A)', advance='no') '1 resonance, '
case default
write (u, '(1x,I0,1x,A)', advance='no') &
grove%grove_prop%n_resonances, 'resonances, '
end select
write (u, '(1x,I0,1x,A)', advance='no') &
grove%grove_prop%n_log_enhanced, 'logs, '
write (u, '(1x,I0,1x,A)', advance='no') &
grove%grove_prop%n_off_shell, 'off-shell, '
select case (grove%grove_prop%n_t_channel)
case (0); write (u, '(1x,A)') 's-channel graph'
case (1); write (u, '(1x,A)') '1 t-channel line'
case default
write(u,'(1x,I0,1x,A)') &
grove%grove_prop%n_t_channel, 't-channel lines'
end select
write (u, '(1x,A,I0)') 'grove #', gr_number
current => grove%first
do while (associated (current))
if (current%keep) then
ch_number = ch_number + 1
call current%write_file_format (feyngraph_set, ch_number, u)
end if
current => current%grove_next
end do
end subroutine grove_write_file_format
@ %def grove_write_file_format
@ Write the relevant information of a valid [[kingraph]] in the file
format. The information is extracted from the [[tree]].
<<Cascades2: kingraph: TBP>>=
procedure :: write_file_format => kingraph_write_file_format
<<Cascades2: sub interfaces>>=
module subroutine kingraph_write_file_format &
(kingraph, feyngraph_set, ch_number, u)
class(kingraph_t), intent(in) :: kingraph
type(feyngraph_set_t), intent(in) :: feyngraph_set
integer, intent(in) :: ch_number
integer, intent(in) :: u
end subroutine kingraph_write_file_format
<<Cascades2: procedures>>=
module subroutine kingraph_write_file_format &
(kingraph, feyngraph_set, ch_number, u)
class(kingraph_t), intent(in) :: kingraph
type(feyngraph_set_t), intent(in) :: feyngraph_set
integer, intent(in) :: ch_number
integer, intent(in) :: u
integer :: i
integer(TC) :: bincode_incoming
2 format(3X,'map',1X,I3,1X,A,1X,I9,1X,'!',1X,A)
!!! determine bincode of incoming particle from tree
bincode_incoming = maxval (kingraph%tree%bc)
write (unit=u, fmt='(1X,A,I0)') '! Channel #', ch_number
write (unit=u, fmt='(3X,A,1X)', advance='no') 'tree'
do i=1, size (kingraph%tree%bc)
if (kingraph%tree%mapping(i) >=0 &
.or. kingraph%tree%mapping(i) == NONRESONANT &
.or. (kingraph%tree%bc(i) == bincode_incoming &
.and. feyngraph_set%process_type == DECAY)) then
write (unit=u, fmt='(1X,I0)', advance='no') kingraph%tree%bc(i)
end if
end do
write (unit=u, fmt='(A)', advance='yes')
do i=1, size(kingraph%tree%bc)
select case (kingraph%tree%mapping(i))
case (NO_MAPPING, NONRESONANT, EXTERNAL_PRT)
case (S_CHANNEL)
write (unit=u, fmt=2) kingraph%tree%bc(i), 's_channel', &
kingraph%tree%pdg(i), &
trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
case (T_CHANNEL)
write (unit=u, fmt=2) kingraph%tree%bc(i), 't_channel', &
abs (kingraph%tree%pdg(i)), &
trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i))))
case (U_CHANNEL)
write (unit=u, fmt=2) kingraph%tree%bc(i), 'u_channel', &
abs (kingraph%tree%pdg(i)), &
trim(get_particle_name (feyngraph_set, abs(kingraph%tree%pdg(i))))
case (RADIATION)
write (unit=u, fmt=2) kingraph%tree%bc(i), 'radiation', &
kingraph%tree%pdg(i), &
trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
case (COLLINEAR)
write (unit=u, fmt=2) kingraph%tree%bc(i), 'collinear', &
kingraph%tree%pdg(i), &
trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
case (INFRARED)
write (unit=u, fmt=2) kingraph%tree%bc(i), 'infrared ', &
kingraph%tree%pdg(i), &
trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
case (ON_SHELL)
write (unit=u, fmt=2) kingraph%tree%bc(i), 'on_shell ', &
kingraph%tree%pdg(i), &
trim(get_particle_name (feyngraph_set, kingraph%tree%pdg(i)))
case default
call msg_bug (" Impossible mapping mode encountered")
end select
end do
end subroutine kingraph_write_file_format
@ %def kingraph_write_file_format
@ Get the particle name from the [[particle]] array of the
[[feyngraph_set]]. This is needed for the phs file creation.
<<Cascades2: procedures>>=
function get_particle_name (feyngraph_set, pdg) result (particle_name)
type(feyngraph_set_t), intent(in) :: feyngraph_set
integer, intent(in) :: pdg
character(len=LABEL_LEN) :: particle_name
integer :: i
do i=1, size (feyngraph_set%particle)
if (feyngraph_set%particle(i)%pdg == pdg) then
particle_name = feyngraph_set%particle(i)%particle_label
exit
end if
end do
end function get_particle_name
@ %def get_particle_name
@
\subsection{Invert a graph}
All Feynman diagrams given by O'Mega look like a decay. The [[feyngraph]]
which is constructed from this output also looks like a decay, where one
of the incoming particles is the decaying particle (or the root of the
tree). The calculations can in principle be done on this data structure.
However, it is also performed with the other incoming particle as
the root. The first part of the calculation is the same for both cases.
For the second part we need to transform/turn the graphs such that the
other incoming particle becomes the root. This is done by identifying
the incoming particles from the O'Mega output (the first one is simply
the root of the existing tree, the second contains [2] in the
[[particle_label]]) and the nodes/particles which connect both incoming
particles (here we set [[t_line = .true.]]). At the same time we set the
pointers [[inverse_daughter1]] and [[inverse_daughter2]] for the
corresponding node, which point to the mother node and the other daughter
of the mother node; these will be the daughters of the node in the
inverted [[feyngraph]].
<<Cascades2: feyngraph: TBP>>=
procedure :: make_invertible => feyngraph_make_invertible
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_make_invertible (feyngraph)
class(feyngraph_t), intent(inout) :: feyngraph
end subroutine feyngraph_make_invertible
<<Cascades2: procedures>>=
module subroutine feyngraph_make_invertible (feyngraph)
class(feyngraph_t), intent(inout) :: feyngraph
logical :: t_line_found
feyngraph%root%incoming = .true.
t_line_found = .false.
if (associated (feyngraph%root%daughter1)) then
call f_node_t_line_check (feyngraph%root%daughter1, t_line_found)
if (.not. t_line_found) then
if (associated (feyngraph%root%daughter2)) then
call f_node_t_line_check (feyngraph%root%daughter2, t_line_found)
end if
end if
end if
contains
<<k node t line check>>
end subroutine feyngraph_make_invertible
@ %def feyngraph_make_invertible
@ Check if a node has to be [[t_line]] or [[incoming]] and assign
inverse daughter pointers.
<<k node t line check>>=
recursive subroutine f_node_t_line_check (node, t_line_found)
type(f_node_t), target, intent(inout) :: node
integer :: pos
logical, intent(inout) :: t_line_found
if (associated (node%daughter1)) then
call f_node_t_line_check (node%daughter1, t_line_found)
if (node%daughter1%incoming .or. node%daughter1%t_line) then
node%t_line = .true.
else if (associated (node%daughter2)) then
call f_node_t_line_check (node%daughter2, t_line_found)
if (node%daughter2%incoming .or. node%daughter2%t_line) then
node%t_line = .true.
end if
end if
else
pos = index (node%particle_label, '[') + 1
if (node%particle_label(pos:pos) == '2') then
node%incoming = .true.
t_line_found = .true.
end if
end if
end subroutine f_node_t_line_check
@ %def k_node_t_line_check
@ Make an inverted copy of a [[kingraph]] using the inverse daughter
pointers.
<<Cascades2: kingraph: TBP>>=
procedure :: make_inverse_copy => kingraph_make_inverse_copy
<<Cascades2: sub interfaces>>=
module subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph)
class(kingraph_t), intent(inout) :: original_kingraph
type(feyngraph_t), intent(inout) :: feyngraph
end subroutine kingraph_make_inverse_copy
<<Cascades2: procedures>>=
module subroutine kingraph_make_inverse_copy (original_kingraph, feyngraph)
class(kingraph_t), intent(inout) :: original_kingraph
type(feyngraph_t), intent(inout) :: feyngraph
type(kingraph_t), pointer :: kingraph_copy
type(k_node_t), pointer :: potential_root
allocate (kingraph_copy)
if (associated (feyngraph%kin_last)) then
allocate (feyngraph%kin_last%next)
feyngraph%kin_last => feyngraph%kin_last%next
else
allocate(feyngraph%kin_first)
feyngraph%kin_last => feyngraph%kin_first
end if
kingraph_copy => feyngraph%kin_last
call kingraph_set_inverse_daughters (original_kingraph)
kingraph_copy%inverse = .true.
kingraph_copy%n_nodes = original_kingraph%n_nodes
kingraph_copy%keep = original_kingraph%keep
potential_root => original_kingraph%root
do while (.not. potential_root%incoming .or. &
(associated (potential_root%daughter1) .and. &
associated (potential_root%daughter2)))
if (potential_root%daughter1%incoming .or. &
potential_root%daughter1%t_line) then
potential_root => potential_root%daughter1
else if (potential_root%daughter2%incoming .or. &
potential_root%daughter2%t_line) then
potential_root => potential_root%daughter2
end if
end do
call node_inverse_deep_copy (potential_root, kingraph_copy%root)
end subroutine kingraph_make_inverse_copy
@ %def kingraph_make_inverse_copy
@ Recursively deep-copy nodes, but along the t-line the inverse daughters
become the new daughters. We need a deep copy only for the [[incoming]]
or [[t_line]] nodes. For the other nodes (of s-channel subgraphs) we set
only pointers to the existing nodes of the non-inverted graph.
<<Cascades2: procedures>>=
recursive subroutine node_inverse_deep_copy (original_node, node_copy)
type(k_node_t), intent(in) :: original_node
type(k_node_t), pointer, intent(out) :: node_copy
call original_node%f_node%k_node_list%add_entry(node_copy, recycle=.false.)
node_copy = original_node
if (node_copy%t_line .or. node_copy%incoming) then
node_copy%particle => original_node%particle%anti
else
node_copy%particle => original_node%particle
end if
if (associated (original_node%inverse_daughter1) .and. associated (original_node%inverse_daughter2)) then
if (original_node%inverse_daughter1%incoming .or. original_node%inverse_daughter1%t_line) then
node_copy%daughter2 => original_node%inverse_daughter2
call node_inverse_deep_copy (original_node%inverse_daughter1, &
node_copy%daughter1)
else if (original_node%inverse_daughter2%incoming .or. original_node%inverse_daughter2%t_line) then
node_copy%daughter1 => original_node%inverse_daughter1
call node_inverse_deep_copy (original_node%inverse_daughter2, &
node_copy%daughter2)
end if
end if
end subroutine node_inverse_deep_copy
@ %def node_inverse_deep_copy
@
\subsection{Find phase-space parametrizations}
Perform all mapping calculations for a single process and store valid
[[kingraphs]] (channels) into the grove list, without caring for instance
about the resonance hash values.
<<Cascades2: public>>=
public :: feyngraph_set_generate_single
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_set_generate_single (feyngraph_set, model, &
n_in, n_out, phs_par, fatal_beam_decay, u_in)
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(model_data_t), target, intent(in) :: model
integer, intent(in) :: n_in, n_out
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
integer, intent(in) :: u_in
end subroutine feyngraph_set_generate_single
<<Cascades2: procedures>>=
module subroutine feyngraph_set_generate_single (feyngraph_set, model, &
n_in, n_out, phs_par, fatal_beam_decay, u_in)
type(feyngraph_set_t), intent(inout) :: feyngraph_set
type(model_data_t), target, intent(in) :: model
integer, intent(in) :: n_in, n_out
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
integer, intent(in) :: u_in
feyngraph_set%n_in = n_in
feyngraph_set%n_out = n_out
feyngraph_set%process_type = n_in
feyngraph_set%phs_par = phs_par
feyngraph_set%model => model
if (debug_on) call msg_debug &
(D_PHASESPACE, "Construct relevant Feynman diagrams from Omega output")
call feyngraph_set%build (u_in)
if (debug_on) call msg_debug &
(D_PHASESPACE, "Find phase-space parametrizations")
call feyngraph_set_find_phs_parametrizations(feyngraph_set)
end subroutine feyngraph_set_generate_single
@ %def feyngraph_set_generate_single
@ Find the phase space parametrizations. We start with the computation
of pure s-channel subtrees, i.e. we determine mappings and compare
subtrees in order to reduce the number of channels. This can be
parallelized easily. When all s-channel [[k_nodes]] exist, the possible
[[kingraphs]] are created using these nodes and we determine mappings for
t-channel nodes.
<<Cascades2: procedures>>=
subroutine feyngraph_set_find_phs_parametrizations (feyngraph_set)
class(feyngraph_set_t), intent(inout) :: feyngraph_set
type(feyngraph_t), pointer :: current => null ()
type(feyngraph_ptr_t), dimension (:), allocatable :: set
integer :: pos
integer :: i
allocate (set (feyngraph_set%n_graphs))
pos = 0
current => feyngraph_set%first
do while (associated (current))
pos = pos + 1
set(pos)%graph => current
current => current%next
end do
if (feyngraph_set%process_type == SCATTERING) then
!$OMP PARALLEL DO
do i=1, feyngraph_set%n_graphs
if (set(i)%graph%keep) then
call set(i)%graph%make_invertible ()
end if
end do
!$OMP END PARALLEL DO
end if
call f_node_list_compute_mappings_s (feyngraph_set)
do i=1, feyngraph_set%n_graphs
if (set(i)%graph%keep) then
call set(i)%graph%make_kingraphs (feyngraph_set)
end if
end do
if (feyngraph_set%process_type == SCATTERING) then
do i=1, feyngraph_set%n_graphs
if (set(i)%graph%keep) then
call set(i)%graph%make_inverse_kingraphs ()
end if
end do
end if
do i=1, feyngraph_set%n_graphs
if (set(i)%graph%keep) then
call set(i)%graph%compute_mappings (feyngraph_set)
end if
end do
do i=1, feyngraph_set%n_graphs
if (set(i)%graph%keep) then
call feyngraph_set%grove_list%add_feyngraph (set(i)%graph, &
feyngraph_set%model)
end if
end do
end subroutine feyngraph_set_find_phs_parametrizations
@ %def feyngraph_set_find_phs_parametrizations
@ Compare objects of type [[tree_t]].
<<Cascades2: interfaces>>=
interface operator (==)
module procedure tree_equal
end interface operator (==)
<<Cascades2: sub interfaces>>=
elemental module function tree_equal (tree1, tree2) result (flag)
type(tree_t), intent(in) :: tree1, tree2
logical :: flag
end function tree_equal
<<Cascades2: procedures>>=
elemental module function tree_equal (tree1, tree2) result (flag)
type(tree_t), intent(in) :: tree1, tree2
logical :: flag
if (tree1%n_entries == tree2%n_entries) then
if (tree1%bc(size(tree1%bc)) == tree2%bc(size(tree2%bc))) then
flag = all (tree1%mapping == tree2%mapping) .and. &
all (tree1%bc == tree2%bc) .and. &
all (abs(tree1%pdg) == abs(tree2%pdg))
else
flag = .false.
end if
else
flag = .false.
end if
end function tree_equal
@ %def tree_equal
@ Select between equivalent subtrees (type [[tree_t]]). This is similar
to [[kingraph_select]], but we compare only positions with mappings
[[NONRESONANT]] and [[NO_MAPPING]].
<<Cascades2: interfaces>>=
interface operator (.eqv.)
module procedure subtree_eqv
end interface operator (.eqv.)
<<Cascades2: sub interfaces>>=
pure module function subtree_eqv (subtree1, subtree2) result (eqv)
type(tree_t), intent(in) :: subtree1, subtree2
logical :: eqv
end function subtree_eqv
<<Cascades2: procedures>>=
pure module function subtree_eqv (subtree1, subtree2) result (eqv)
type(tree_t), intent(in) :: subtree1, subtree2
logical :: eqv
integer :: root_pos
integer :: i
logical :: equal
eqv = .false.
if (subtree1%n_entries /= subtree2%n_entries) return
root_pos = subtree1%n_entries
if (subtree1%mapping(root_pos) == NONRESONANT .or. &
subtree2%mapping(root_pos) == NONRESONANT .or. &
(subtree1%mapping(root_pos) == NO_MAPPING .and. &
subtree2%mapping(root_pos) == NO_MAPPING .and. &
abs(subtree1%pdg(root_pos)) == abs(subtree2%pdg(root_pos)))) then
do i = subtree1%n_entries, 1, -1
if (subtree1%bc(i) /= subtree2%bc(i)) return
end do
equal = .true.
do i = subtree1%n_entries, 1, -1
if (abs(subtree1%pdg(i)) /= abs (subtree2%pdg(i))) then
select case (subtree1%mapping(i))
case (NO_MAPPING, NONRESONANT)
select case (subtree2%mapping(i))
case (NO_MAPPING, NONRESONANT)
equal = .false.
case default
return
end select
case default
return
end select
end if
end do
do i = subtree1%n_entries, 1, -1
if (subtree1%mapping(i) /= subtree2%mapping(i)) then
select case (subtree1%mapping(i))
case (NO_MAPPING, NONRESONANT)
select case (subtree2%mapping(i))
case (NO_MAPPING, NONRESONANT)
case default
return
end select
case default
return
end select
end if
end do
if (.not. equal) eqv = .true.
end if
end function subtree_eqv
@ %def subtree_eqv
<<Cascades2: procedures>>=
subroutine subtree_select (subtree1, subtree2, model)
type(tree_t), intent(inout) :: subtree1, subtree2
type(model_data_t), intent(in) :: model
integer :: j, k
integer(TC), dimension(:), allocatable :: tmp_bc, daughter_bc
integer, dimension(:), allocatable :: tmp_pdg, daughter_pdg
integer, dimension (:), allocatable :: pdg_match
if (subtree1 .eqv. subtree2) then
do j=1, subtree1%n_entries
if (abs(subtree1%pdg(j)) /= abs(subtree2%pdg(j))) then
tmp_bc = subtree1%bc(:j-1); tmp_pdg = subtree1%pdg(:j-1)
do k=j-1, 1, - 1
where (iand (tmp_bc(:k-1),tmp_bc(k)) /= 0 &
.or. iand(tmp_bc(:k-1),subtree1%bc(j)) == 0)
tmp_bc(:k-1) = 0
tmp_pdg(:k-1) = 0
endwhere
end do
daughter_bc = pack (tmp_bc, tmp_bc /= 0)
daughter_pdg = pack (tmp_pdg, tmp_pdg /= 0)
if (size (daughter_pdg) == 2) then
call model%match_vertex(daughter_pdg(1), daughter_pdg(2), pdg_match)
if (.not. allocated (pdg_match)) then
!!! Relevant if tree contains only abs (pdg). In this case, changing the
!!! sign of one of the pdg codes should give a result.
call model%match_vertex(-daughter_pdg(1), daughter_pdg(2), pdg_match)
end if
end if
do k=1, size (pdg_match)
if (abs(pdg_match(k)) == abs(subtree1%pdg(j))) then
if (subtree1%keep) subtree2%keep = .false.
exit
else if (abs(pdg_match(k)) == abs(subtree2%pdg(j))) then
if (subtree2%keep) subtree1%keep = .false.
exit
end if
end do
deallocate (tmp_bc, tmp_pdg, daughter_bc, daughter_pdg, pdg_match)
if (.not. (subtree1%keep .and. subtree2%keep)) exit
end if
end do
end if
end subroutine subtree_select
@ %def subtree_select
@ Assign a resonance hash value to a [[kingraph]], like in [[cascades]],
but here without the array [[tree_resonant]].
<<Cascades2: kingraph: TBP>>=
procedure :: assign_resonance_hash => kingraph_assign_resonance_hash
<<Cascades2: sub interfaces>>=
module subroutine kingraph_assign_resonance_hash (kingraph)
class(kingraph_t), intent(inout) :: kingraph
end subroutine kingraph_assign_resonance_hash
<<Cascades2: procedures>>=
module subroutine kingraph_assign_resonance_hash (kingraph)
class(kingraph_t), intent(inout) :: kingraph
logical, dimension (:), allocatable :: tree_resonant
integer(i8), dimension(1) :: mold
allocate (tree_resonant (kingraph%tree%n_entries))
tree_resonant = (kingraph%tree%mapping == S_CHANNEL)
kingraph%grove_prop%res_hash = hash (transfer &
([sort (pack (kingraph%tree%pdg, tree_resonant)), &
sort (pack (abs (kingraph%tree%pdg), &
kingraph%tree%mapping == T_CHANNEL .or. &
kingraph%tree%mapping == U_CHANNEL))], mold))
deallocate (tree_resonant)
end subroutine kingraph_assign_resonance_hash
@ %def kingraph_assign_resonance_hash
@ Write the process in the bincode format. This is again a copy of the
corresponding procedure in [[cascades]], using [[feyngraph_set]] instead
of [[cascade_set]] as an argument.
<<Cascades2: public>>=
public :: feyngraph_set_write_process_bincode_format
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_set_write_process_bincode_format &
(feyngraph_set, unit)
type(feyngraph_set_t), intent(in), target :: feyngraph_set
integer, intent(in), optional :: unit
end subroutine feyngraph_set_write_process_bincode_format
<<Cascades2: procedures>>=
module subroutine feyngraph_set_write_process_bincode_format &
(feyngraph_set, unit)
type(feyngraph_set_t), intent(in), target :: feyngraph_set
integer, intent(in), optional :: unit
integer, dimension(:), allocatable :: bincode, field_width
integer :: n_in, n_out, n_tot, n_flv
integer :: u, f, i, bc
character(20) :: str
type(string_t) :: fmt_head
type(string_t), dimension(:), allocatable :: fmt_proc
u = given_output_unit (unit); if (u < 0) return
if (.not. allocated (feyngraph_set%flv)) return
write (u, "('!',1x,A)") "List of subprocesses with particle bincodes:"
n_in = feyngraph_set%n_in
n_out = feyngraph_set%n_out
n_tot = n_in + n_out
n_flv = size (feyngraph_set%flv, 2)
allocate (bincode (n_tot), field_width (n_tot), fmt_proc (n_tot))
bc = 1
do i = 1, n_out
bincode(n_in + i) = bc
bc = 2 * bc
end do
do i = n_in, 1, -1
bincode(i) = bc
bc = 2 * bc
end do
do i = 1, n_tot
write (str, "(I0)") bincode(i)
field_width(i) = len_trim (str)
do f = 1, n_flv
field_width(i) = max (field_width(i), &
len (feyngraph_set%flv(i,f)%get_name ()))
end do
end do
fmt_head = "('!'"
do i = 1, n_tot
fmt_head = fmt_head // ",1x,"
fmt_proc(i) = "(1x,"
write (str, "(I0)") field_width(i)
fmt_head = fmt_head // "I" // trim(str)
fmt_proc(i) = fmt_proc(i) // "A" // trim(str)
if (i == n_in) then
fmt_head = fmt_head // ",1x,' '"
end if
end do
do i = 1, n_tot
fmt_proc(i) = fmt_proc(i) // ")"
end do
fmt_head = fmt_head // ")"
write (u, char (fmt_head)) bincode
do f = 1, n_flv
write (u, "('!')", advance="no")
do i = 1, n_tot
write (u, char (fmt_proc(i)), advance="no") &
char (feyngraph_set%flv(i,f)%get_name ())
if (i == n_in) write (u, "(1x,'=>')", advance="no")
end do
write (u, *)
end do
write (u, char (fmt_head)) bincode
end subroutine feyngraph_set_write_process_bincode_format
@ %def feyngraph_set_write_process_bincode_format
@ Write tex file for graphical display of channels.
<<Cascades2: public>>=
public :: feyngraph_set_write_graph_format
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_set_write_graph_format &
(feyngraph_set, filename, process_id, unit)
type(feyngraph_set_t), intent(in), target :: feyngraph_set
type(string_t), intent(in) :: filename, process_id
integer, intent(in), optional :: unit
end subroutine feyngraph_set_write_graph_format
<<Cascades2: procedures>>=
module subroutine feyngraph_set_write_graph_format &
(feyngraph_set, filename, process_id, unit)
type(feyngraph_set_t), intent(in), target :: feyngraph_set
type(string_t), intent(in) :: filename, process_id
integer, intent(in), optional :: unit
type(kingraph_t), pointer :: kingraph
type(grove_t), pointer :: grove
integer :: u, n_grove, count, pgcount
logical :: first_in_grove
u = given_output_unit (unit); if (u < 0) return
write (u, '(A)') "\documentclass[10pt]{article}"
write (u, '(A)') "\usepackage{amsmath}"
write (u, '(A)') "\usepackage{feynmp}"
write (u, '(A)') "\usepackage{url}"
write (u, '(A)') "\usepackage{color}"
write (u, *)
write (u, '(A)') "\textwidth 18.5cm"
write (u, '(A)') "\evensidemargin -1.5cm"
write (u, '(A)') "\oddsidemargin -1.5cm"
write (u, *)
write (u, '(A)') "\newcommand{\blue}{\color{blue}}"
write (u, '(A)') "\newcommand{\green}{\color{green}}"
write (u, '(A)') "\newcommand{\red}{\color{red}}"
write (u, '(A)') "\newcommand{\magenta}{\color{magenta}}"
write (u, '(A)') "\newcommand{\cyan}{\color{cyan}}"
write (u, '(A)') "\newcommand{\sm}{\footnotesize}"
write (u, '(A)') "\setlength{\parindent}{0pt}"
write (u, '(A)') "\setlength{\parsep}{20pt}"
write (u, *)
write (u, '(A)') "\begin{document}"
write (u, '(A)') "\begin{fmffile}{" // char (filename) // "}"
write (u, '(A)') "\fmfcmd{color magenta; magenta = red + blue;}"
write (u, '(A)') "\fmfcmd{color cyan; cyan = green + blue;}"
write (u, '(A)') "\begin{fmfshrink}{0.5}"
write (u, '(A)') "\begin{flushleft}"
write (u, *)
write (u, '(A)') "\noindent" // &
& "\textbf{\large\texttt{WHIZARD} phase space channels}" // &
& "\hfill\today"
write (u, *)
write (u, '(A)') "\vspace{10pt}"
write (u, '(A)') "\noindent" // &
& "\textbf{Process:} \url{" // char (process_id) // "}"
call feyngraph_set_write_process_tex_format (feyngraph_set, u)
write (u, *)
write (u, '(A)') "\noindent" // &
& "\textbf{Note:} These are pseudo Feynman graphs that "
write (u, '(A)') "visualize phase-space parameterizations " // &
& "(``integration channels''). "
write (u, '(A)') "They do \emph{not} indicate Feynman graphs used for the " // &
& "matrix element."
write (u, *)
write (u, '(A)') "\textbf{Color code:} " // &
& "{\blue resonance,} " // &
& "{\cyan t-channel,} " // &
& "{\green radiation,} "
write (u, '(A)') "{\red infrared,} " // &
& "{\magenta collinear,} " // &
& "external/off-shell"
write (u, *)
write (u, '(A)') "\noindent" // &
& "\textbf{Black square:} Keystone, indicates ordering of " // &
& "phase space parameters."
write (u, *)
write (u, '(A)') "\vspace{-20pt}"
count = 0
pgcount = 0
n_grove = 0
grove => feyngraph_set%grove_list%first
do while (associated (grove))
n_grove = n_grove + 1
write (u, *)
write (u, '(A)') "\vspace{20pt}"
write (u, '(A)') "\begin{tabular}{l}"
write (u, '(A,I5,A)') &
& "\fbox{\bf Grove \boldmath$", n_grove, "$} \\[10pt]"
write (u, '(A,I1,A)') "Multiplicity: ", &
grove%grove_prop%multiplicity, "\\"
write (u, '(A,I1,A)') "Resonances: ", &
grove%grove_prop%n_resonances, "\\"
write (u, '(A,I1,A)') "Log-enhanced: ", &
grove%grove_prop%n_log_enhanced, "\\"
write (u, '(A,I1,A)') "Off-shell: ", &
grove%grove_prop%n_off_shell, "\\"
write (u, '(A,I1,A)') "t-channel: ", &
grove%grove_prop%n_t_channel, ""
write (u, '(A)') "\end{tabular}"
kingraph => grove%first
do while (associated (kingraph))
count = count + 1
call kingraph_write_graph_format (kingraph, count, unit)
kingraph => kingraph%grove_next
end do
grove => grove%next
end do
write (u, '(A)') "\end{flushleft}"
write (u, '(A)') "\end{fmfshrink}"
write (u, '(A)') "\end{fmffile}"
write (u, '(A)') "\end{document}"
end subroutine feyngraph_set_write_graph_format
@ %def feyngraph_set_write_graph_format
@ Write the process as a \LaTeX\ expression. This is a slightly modified
copy of [[cascade_set_write_process_tex_format]] which has only been
adapted to the types which are used here.
<<Cascades2: procedures>>=
subroutine feyngraph_set_write_process_tex_format (feyngraph_set, unit)
type(feyngraph_set_t), intent(in), target :: feyngraph_set
integer, intent(in), optional :: unit
integer :: n_tot
integer :: u, f, i
n_tot = feyngraph_set%n_in + feyngraph_set%n_out
u = given_output_unit (unit); if (u < 0) return
if (.not. allocated (feyngraph_set%flv)) return
write (u, "(A)") "\begin{align*}"
do f = 1, size (feyngraph_set%flv, 2)
do i = 1, feyngraph_set%n_in
if (i > 1) write (u, "(A)", advance="no") "\quad "
write (u, "(A)", advance="no") &
char (feyngraph_set%flv(i,f)%get_tex_name ())
end do
write (u, "(A)", advance="no") "\quad &\to\quad "
do i = feyngraph_set%n_in + 1, n_tot
if (i > feyngraph_set%n_in + 1) write (u, "(A)", advance="no") "\quad "
write (u, "(A)", advance="no") &
char (feyngraph_set%flv(i,f)%get_tex_name ())
end do
if (f < size (feyngraph_set%flv, 2)) then
write (u, "(A)") "\\"
else
write (u, "(A)") ""
end if
end do
write (u, "(A)") "\end{align*}"
end subroutine feyngraph_set_write_process_tex_format
@ %def feyngraph_set_write_process_tex_format
@ This creates metapost source for graphical display for a given [[kingraph]].
It is the analogon to [[cascade_write_graph_format]] (a modified copy).
<<Cascades2: procedures>>=
subroutine kingraph_write_graph_format (kingraph, count, unit)
type(kingraph_t), intent(in) :: kingraph
integer, intent(in) :: count
integer, intent(in), optional :: unit
integer :: u
type(string_t) :: left_str, right_str
u = given_output_unit (unit); if (u < 0) return
left_str = ""
right_str = ""
write (u, '(A)') "\begin{minipage}{105pt}"
write (u, '(A)') "\vspace{30pt}"
write (u, '(A)') "\begin{center}"
write (u, '(A)') "\begin{fmfgraph*}(55,55)"
call graph_write_node (kingraph%root)
write (u, '(A)') "\fmfleft{" // char (extract (left_str, 2)) // "}"
write (u, '(A)') "\fmfright{" // char (extract (right_str, 2)) // "}"
write (u, '(A)') "\end{fmfgraph*}\\"
write (u, '(A,I5,A)') "\fbox{$", count, "$}"
write (u, '(A)') "\end{center}"
write (u, '(A)') "\end{minipage}"
write (u, '(A)') "%"
contains
recursive subroutine graph_write_node (node)
type(k_node_t), intent(in) :: node
if (associated (node%daughter1) .or. associated (node%daughter2)) then
if (node%daughter2%t_line .or. node%daughter2%incoming) then
call vertex_write (node, node%daughter2)
call vertex_write (node, node%daughter1)
else
call vertex_write (node, node%daughter1)
call vertex_write (node, node%daughter2)
end if
if (node%mapping == EXTERNAL_PRT) then
call line_write (node%bincode, 0, node%particle)
call external_write (node%bincode, node%particle%tex_name, &
left_str)
write (u, '(A,I0,A)') "\fmfv{d.shape=square}{v0}"
end if
else
if (node%incoming) then
call external_write (node%bincode, node%particle%anti%tex_name, &
left_str)
else
call external_write (node%bincode, node%particle%tex_name, &
right_str)
end if
end if
end subroutine graph_write_node
recursive subroutine vertex_write (node, daughter)
type(k_node_t), intent(in) :: node, daughter
integer :: bincode
if (associated (node%daughter1) .and. associated (node%daughter2) &
.and. node%mapping == EXTERNAL_PRT) then
bincode = 0
else
bincode = node%bincode
end if
call graph_write_node (daughter)
if (associated (node%daughter1) .or. associated (node%daughter2)) then
call line_write (bincode, daughter%bincode, daughter%particle, &
mapping=daughter%mapping)
else
call line_write (bincode, daughter%bincode, daughter%particle)
end if
end subroutine vertex_write
subroutine line_write (i1, i2, particle, mapping)
integer(TC), intent(in) :: i1, i2
type(part_prop_t), intent(in) :: particle
integer, intent(in), optional :: mapping
integer :: k1, k2
type(string_t) :: prt_type
select case (particle%spin_type)
case (SCALAR); prt_type = "plain"
case (SPINOR); prt_type = "fermion"
case (VECTOR); prt_type = "boson"
case (VECTORSPINOR); prt_type = "fermion"
case (TENSOR); prt_type = "dbl_wiggly"
case default; prt_type = "dashes"
end select
if (particle%pdg < 0) then
!!! anti-particle
k1 = i2; k2 = i1
else
k1 = i1; k2 = i2
end if
if (present (mapping)) then
select case (mapping)
case (S_CHANNEL)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=blue,lab=\sm\blue$" // &
& char (particle%tex_name) // "$}" // &
& "{v", k1, ",v", k2, "}"
case (T_CHANNEL, U_CHANNEL)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=cyan,lab=\sm\cyan$" // &
& char (particle%tex_name) // "$}" // &
& "{v", k1, ",v", k2, "}"
case (RADIATION)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=green,lab=\sm\green$" // &
& char (particle%tex_name) // "$}" // &
& "{v", k1, ",v", k2, "}"
case (COLLINEAR)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=magenta,lab=\sm\magenta$" // &
& char (particle%tex_name) // "$}" // &
& "{v", k1, ",v", k2, "}"
case (INFRARED)
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=red,lab=\sm\red$" // &
& char (particle%tex_name) // "$}" // &
& "{v", k1, ",v", k2, "}"
case default
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& ",f=black}" // &
& "{v", k1, ",v", k2, "}"
end select
else
write (u, '(A,I0,A,I0,A)') "\fmf{" // char (prt_type) // &
& "}" // &
& "{v", k1, ",v", k2, "}"
end if
end subroutine line_write
subroutine external_write (bincode, name, ext_str)
integer(TC), intent(in) :: bincode
type(string_t), intent(in) :: name
type(string_t), intent(inout) :: ext_str
character(len=20) :: str
write (str, '(A2,I0)') ",v", bincode
ext_str = ext_str // trim (str)
write (u, '(A,I0,A,I0,A)') "\fmflabel{\sm$" &
// char (name) &
// "\,(", bincode, ")" &
// "$}{v", bincode, "}"
end subroutine external_write
end subroutine kingraph_write_graph_format
@ %def kingraph_write_graph_format
@ Generate a [[feyngraph_set]] for several subprocesses. Mapping
calculations are performed separately, but the final grove list is shared
between the subsets [[fset]] of the [[feyngraph_set]].
<<Cascades2: public>>=
public :: feyngraph_set_generate
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_set_generate &
(feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, &
u_in, vis_channels, use_dag)
type(feyngraph_set_t), intent(out) :: feyngraph_set
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in, n_out
type(flavor_t), dimension(:,:), intent(in) :: flv
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
integer, intent(in) :: u_in
logical, intent(in) :: vis_channels
logical, optional, intent(in) :: use_dag
end subroutine feyngraph_set_generate
<<Cascades2: procedures>>=
module subroutine feyngraph_set_generate &
(feyngraph_set, model, n_in, n_out, flv, phs_par, fatal_beam_decay, &
u_in, vis_channels, use_dag)
type(feyngraph_set_t), intent(out) :: feyngraph_set
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_in, n_out
type(flavor_t), dimension(:,:), intent(in) :: flv
type(phs_parameters_t), intent(in) :: phs_par
logical, intent(in) :: fatal_beam_decay
integer, intent(in) :: u_in
logical, intent(in) :: vis_channels
logical, optional, intent(in) :: use_dag
type(grove_t), pointer :: grove
integer :: i, j
type(kingraph_t), pointer :: kingraph
if (phase_space_vanishes (phs_par%sqrts, n_in, flv)) return
if (present (use_dag)) feyngraph_set%use_dag = use_dag
feyngraph_set%process_type = n_in
feyngraph_set%n_in = n_in
feyngraph_set%n_out = n_out
allocate (feyngraph_set%flv (size (flv, 1), size (flv, 2)))
do i = 1, size (flv, 2)
do j = 1, size (flv, 1)
call feyngraph_set%flv(j,i)%init (flv(j,i)%get_pdg (), model)
end do
end do
allocate (feyngraph_set%particle (PRT_ARRAY_SIZE))
allocate (feyngraph_set%grove_list)
allocate (feyngraph_set%fset (size (flv, 2)))
do i = 1, size (feyngraph_set%fset)
feyngraph_set%fset(i)%use_dag = feyngraph_set%use_dag
allocate (feyngraph_set%fset(i)%flv(size (flv,1),1))
feyngraph_set%fset(i)%flv(:,1) = flv(:,i)
feyngraph_set%fset(i)%particle => feyngraph_set%particle
allocate (feyngraph_set%fset(i)%grove_list)
call feyngraph_set_generate_single (feyngraph_set%fset(i), &
model, n_in, n_out, phs_par, fatal_beam_decay, u_in)
call feyngraph_set%grove_list%merge &
(feyngraph_set%fset(i)%grove_list, model, i)
if (.not. vis_channels) call feyngraph_set%fset(i)%final()
end do
call feyngraph_set%grove_list%rebuild ()
end subroutine feyngraph_set_generate
@ %def feyngraph_set_generate
@ Check whether the [[grove_list]] of the [[feyngraph_set]] contains any
[[kingraphs]] which are valid, i.e. where the [[keep]] variable has the
value [[.true.]]. This is necessary to write a non-empty phase-space
file. The function is the pendant to [[cascade_set_is_valid]].
<<Cascades2: public>>=
public :: feyngraph_set_is_valid
<<Cascades2: sub interfaces>>=
module function feyngraph_set_is_valid (feyngraph_set) result (flag)
class(feyngraph_set_t), intent(in) :: feyngraph_set
logical :: flag
end function feyngraph_set_is_valid
<<Cascades2: procedures>>=
module function feyngraph_set_is_valid (feyngraph_set) result (flag)
class(feyngraph_set_t), intent(in) :: feyngraph_set
type(kingraph_t), pointer :: kingraph
type(grove_t), pointer :: grove
logical :: flag
flag = .false.
if (associated (feyngraph_set%grove_list)) then
grove => feyngraph_set%grove_list%first
do while (associated (grove))
kingraph => grove%first
do while (associated (kingraph))
if (kingraph%keep) then
flag = .true.
return
end if
kingraph => kingraph%next
end do
grove => grove%next
end do
end if
end function feyngraph_set_is_valid
@ %def feyngraph_set_is_valid
@
\subsection{Return the resonance histories for subtraction}
The following procedures are copies of corresponding procedures in
[[cascades]], which only have been adapted to the new types used in
this module.
Extract the resonance set from a valid [[kingraph]] which is kept in the
final grove list.
<<Cascades2: kingraph: TBP>>=
procedure :: extract_resonance_history => kingraph_extract_resonance_history
<<Cascades2: sub interfaces>>=
module subroutine kingraph_extract_resonance_history &
(kingraph, res_hist, model, n_out)
class(kingraph_t), intent(in), target :: kingraph
type(resonance_history_t), intent(out) :: res_hist
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_out
end subroutine kingraph_extract_resonance_history
<<Cascades2: procedures>>=
module subroutine kingraph_extract_resonance_history &
(kingraph, res_hist, model, n_out)
class(kingraph_t), intent(in), target :: kingraph
type(resonance_history_t), intent(out) :: res_hist
class(model_data_t), intent(in), target :: model
integer, intent(in) :: n_out
type(resonance_info_t) :: resonance
integer :: i, mom_id, pdg
if (debug_on) call msg_debug2 &
(D_PHASESPACE, "kingraph_extract_resonance_history")
if (kingraph%grove_prop%n_resonances > 0) then
if (associated (kingraph%root%daughter1) .or. &
associated (kingraph%root%daughter2)) then
if (debug_on) call msg_debug2 &
(D_PHASESPACE, "kingraph has resonances, root has children")
do i = 1, kingraph%tree%n_entries
if (kingraph%tree%mapping(i) == S_CHANNEL) then
mom_id = kingraph%tree%bc (i)
pdg = kingraph%tree%pdg (i)
call resonance%init (mom_id, pdg, model, n_out)
if (debug2_active (D_PHASESPACE)) then
print *, 'D: Adding resonance'
call resonance%write ()
end if
call res_hist%add_resonance (resonance)
end if
end do
end if
end if
end subroutine kingraph_extract_resonance_history
@ %def kingraph_extract_resonance_history
@ Determine the number of valid [[kingraphs]] in [[grove_list]].
<<Cascades2: public>>=
public :: grove_list_get_n_trees
<<Cascades2: sub interfaces>>=
module function grove_list_get_n_trees (grove_list) result (n)
class(grove_list_t), intent(in) :: grove_list
integer :: n
end function grove_list_get_n_trees
<<Cascades2: procedures>>=
module function grove_list_get_n_trees (grove_list) result (n)
class(grove_list_t), intent(in) :: grove_list
integer :: n
type(kingraph_t), pointer :: kingraph
type(grove_t), pointer :: grove
if (debug_on) call msg_debug (D_PHASESPACE, "grove_list_get_n_trees")
n = 0
grove => grove_list%first
do while (associated (grove))
kingraph => grove%first
do while (associated (kingraph))
if (kingraph%keep) n = n + 1
kingraph => kingraph%grove_next
end do
grove => grove%next
end do
if (debug_on) call msg_debug (D_PHASESPACE, "n", n)
end function grove_list_get_n_trees
@ %def grove_list_get_n_trees
@ Extract the resonance histories from the [[feyngraph_set]], in complete
analogy to [[cascade_set_get_resonance_histories]]
<<Cascades2: public>>=
public :: feyngraph_set_get_resonance_histories
<<Cascades2: sub interfaces>>=
module subroutine feyngraph_set_get_resonance_histories &
(feyngraph_set, n_filter, res_hists)
type(feyngraph_set_t), intent(in), target :: feyngraph_set
integer, intent(in), optional :: n_filter
type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
res_hists
end subroutine feyngraph_set_get_resonance_histories
<<Cascades2: procedures>>=
module subroutine feyngraph_set_get_resonance_histories &
(feyngraph_set, n_filter, res_hists)
type(feyngraph_set_t), intent(in), target :: feyngraph_set
integer, intent(in), optional :: n_filter
type(resonance_history_t), dimension(:), allocatable, intent(out) :: &
res_hists
type(kingraph_t), pointer :: kingraph
type(grove_t), pointer :: grove
type(resonance_history_t) :: res_hist
type(resonance_history_set_t) :: res_hist_set
integer :: i_grove
if (debug_on) call msg_debug &
(D_PHASESPACE, "grove_list_get_resonance_histories")
call res_hist_set%init (n_filter = n_filter)
grove => feyngraph_set%grove_list%first
i_grove = 0
do while (associated (grove))
i_grove = i_grove + 1
kingraph => grove%first
do while (associated (kingraph))
if (kingraph%keep) then
if (debug_on) call msg_debug2 (D_PHASESPACE, "grove", i_grove)
call kingraph%extract_resonance_history &
(res_hist, feyngraph_set%model, feyngraph_set%n_out)
call res_hist_set%enter (res_hist)
end if
kingraph => kingraph%grove_next
end do
end do
call res_hist_set%freeze ()
call res_hist_set%to_array (res_hists)
end subroutine feyngraph_set_get_resonance_histories
@ %def feyngraph_set_get_resonance_histories
@
<<[[cascades2_ut.f90]]>>=
<<File header>>
module cascades2_ut
use unit_tests
use cascades2_uti
<<Standard module head>>
<<Cascades2: public test>>
contains
<<Cascades2: test driver>>
end module cascades2_ut
@ %def cascades2_ut
@
<<[[cascades2_uti.f90]]>>=
<<File header>>
module cascades2_uti
<<Use kinds>>
<<Use strings>>
use numeric_utils
use cascades2
use flavors
use phs_forests, only: phs_parameters_t
use model_data
<<Standard module head>>
<<Cascades2: test declarations>>
contains
<<Cascades2: tests>>
end module cascades2_uti
@ %def cascades2_uti
@ API: driver for the unit tests below.
<<Cascades2: public test>>=
public :: cascades2_test
<<Cascades2: test driver>>=
subroutine cascades2_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Cascades2: execute tests>>
end subroutine cascades2_test
@ %def cascades2_test
@
<<Cascades2: execute tests>>=
call test (cascades2_1, "cascades2_1", &
"make phase-space", u, results)
call test (cascades2_2, "cascades2_2", &
"make phase-space (scattering)", u, results)
<<Cascades2: test declarations>>=
public :: cascades2_1
<<Cascades2: tests>>=
subroutine cascades2_1 (u)
integer, intent(in) :: u
type(feyngraph_set_t) :: feyngraph_set
type(model_data_t) :: model
integer :: n_in = 1
integer :: n_out = 6
type(flavor_t), dimension(7,1) :: flv
type(phs_parameters_t) :: phs_par
logical :: fatal_beam_decay = .true.
integer :: u_in = 8
write (u, "(A)") "* Test output: cascades2_1"
write (u, "(A)") "* Purpose: create a test phs file (decay) with the forest"
write (u, "(A)") "* output of O'Mega"
write (u, "(A)")
write (u, "(A)") "* Initializing"
write (u, "(A)")
call init_sm_full_test (model)
call flv(1,1)%init (6, model)
call flv(2,1)%init (5, model)
call flv(3,1)%init (-11, model)
call flv(4,1)%init (12, model)
call flv(5,1)%init (21, model)
call flv(6,1)%init (22, model)
call flv(7,1)%init (21, model)
phs_par%sqrts = 173.1_default
phs_par%m_threshold_s = 50._default
phs_par%m_threshold_t = 100._default
phs_par%keep_nonresonant = .true.
phs_par%off_shell = 2
open (unit=u_in, file="cascades2_1.fds", status='old', action='read')
write (u, "(A)")
write (u, "(A)") "* Generating phase-space parametrizations"
write (u, "(A)")
call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, &
flv, phs_par, fatal_beam_decay, u_in, use_dag = .false., &
vis_channels = .false.)
call feyngraph_set_write_process_bincode_format (feyngraph_set, u)
call feyngraph_set_write_file_format (feyngraph_set, u)
write (u, "(A)") "* Cleanup"
write (u, "(A)")
close (u_in)
call feyngraph_set%final ()
call model%final ()
write (u, *)
write (u, "(A)") "* Test output end: cascades2_1"
end subroutine cascades2_1
@ %def cascades2_1
@
<<Cascades2: test declarations>>=
public :: cascades2_2
<<Cascades2: tests>>=
subroutine cascades2_2 (u)
integer, intent(in) :: u
type(feyngraph_set_t) :: feyngraph_set
type(model_data_t) :: model
integer :: n_in = 2
integer :: n_out = 5
type(flavor_t), dimension(7,1) :: flv
type(phs_parameters_t) :: phs_par
logical :: fatal_beam_decay = .true.
integer :: u_in = 8
write (u, "(A)") "* Test output: cascades2_2"
write (u, "(A)") "* Purpose: create a test phs file (scattering) with the"
write (u, "(A)") "* parsable DAG output of O'Mega"
write (u, "(A)")
write (u, "(A)") "* Initializing"
write (u, "(A)")
call init_sm_full_test (model)
call flv(1,1)%init (-11, model)
call flv(2,1)%init (11, model)
call flv(3,1)%init (-11, model)
call flv(4,1)%init (12, model)
call flv(5,1)%init (1, model)
call flv(6,1)%init (-2, model)
call flv(7,1)%init (22, model)
phs_par%sqrts = 500._default
phs_par%m_threshold_s = 50._default
phs_par%m_threshold_t = 100._default
phs_par%keep_nonresonant = .true.
phs_par%off_shell = 2
phs_par%t_channel = 6
open (unit=u_in, file="cascades2_2.fds", &
status='old', action='read')
write (u, "(A)")
write (u, "(A)") "* Generating phase-space parametrizations"
write (u, "(A)")
call feyngraph_set_generate (feyngraph_set, model, n_in, n_out, &
flv, phs_par, fatal_beam_decay, u_in, use_dag = .true., &
vis_channels = .false.)
call feyngraph_set_write_process_bincode_format (feyngraph_set, u)
call feyngraph_set_write_file_format (feyngraph_set, u)
write (u, "(A)") "* Cleanup"
write (u, "(A)")
close (u_in)
call feyngraph_set%final ()
call model%final ()
write (u, *)
write (u, "(A)") "* Test output end: cascades2_2"
end subroutine cascades2_2
@ %def cascades2_2
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{WOOD phase space}
This is the module that interfaces the [[phs_forests]] phase-space
treatment and the [[cascades]] module for generating phase-space
channels. As an extension of the [[phs_base]] abstract type,
the phase-space configuration and instance implement the standard API.
(Currently, this is the only generic phase-space implementation of
\whizard. For trivial two-particle phase space, there is
[[phs_wood]] as an alternative.)
<<[[phs_wood.f90]]>>=
<<File header>>
module phs_wood
<<Use kinds>>
<<Use strings>>
use os_interface
use lorentz
use model_data
use flavors
use phs_base
use mappings
use resonances, only: resonance_history_set_t
use phs_forests
use cascades
use cascades2
<<Standard module head>>
<<PHS wood: public>>
<<PHS wood: types>>
interface
<<PHS wood: sub interfaces>>
end interface
contains
<<PHS wood: main procedures>>
end module phs_wood
@ %def phs_wood
@
<<[[phs_wood_sub.f90]]>>=
<<File header>>
submodule (phs_wood) phs_wood_s
use io_units
use constants
use numeric_utils
use diagnostics
use physics_defs
use md5
use process_constants
use sf_mappings
use sf_base
!!! Intel oneAPI 2022/23 regression workaround
use resonances, only: resonance_history_t
use resonances, only: resonance_history_set_t
implicit none
contains
<<PHS wood: procedures>>
end submodule phs_wood_s
@ %def phs_wood_s
@
\subsection{Configuration}
<<PHS wood: public>>=
public :: phs_wood_config_t
<<PHS wood: types>>=
type, extends (phs_config_t) :: phs_wood_config_t
character(32) :: md5sum_forest = ""
type(string_t) :: phs_path
integer :: io_unit = 0
logical :: io_unit_keep_open = .false.
logical :: use_equivalences = .false.
logical :: fatal_beam_decay = .true.
type(mapping_defaults_t) :: mapping_defaults
type(phs_parameters_t) :: par
type(string_t) :: run_id
type(cascade_set_t), allocatable :: cascade_set
logical :: use_cascades2 = .false.
type(feyngraph_set_t), allocatable :: feyngraph_set
type(phs_forest_t) :: forest
type(os_data_t) :: os_data
logical :: is_combined_integration = .false.
contains
<<PHS wood: phs wood config: TBP>>
end type phs_wood_config_t
@ %def phs_wood_config_t
@ Finalizer. We should delete the cascade set and the forest subobject.
Also close the I/O unit, just in case. (We assume that [[io_unit]] is
not standard input/output.)
<<PHS wood: phs wood config: TBP>>=
procedure :: final => phs_wood_config_final
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_final (object)
class(phs_wood_config_t), intent(inout) :: object
end subroutine phs_wood_config_final
<<PHS wood: procedures>>=
module subroutine phs_wood_config_final (object)
class(phs_wood_config_t), intent(inout) :: object
logical :: opened
if (object%io_unit /= 0) then
inquire (unit = object%io_unit, opened = opened)
if (opened) close (object%io_unit)
end if
call object%clear_phase_space ()
call object%forest%final ()
end subroutine phs_wood_config_final
@ %def phs_wood_config_final
@
<<PHS wood: phs wood config: TBP>>=
procedure :: increase_n_par => phs_wood_config_increase_n_par
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_increase_n_par (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
end subroutine phs_wood_config_increase_n_par
<<PHS wood: procedures>>=
module subroutine phs_wood_config_increase_n_par (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
if (phs_config%is_combined_integration) then
phs_config%n_par = phs_config%n_par + 3
end if
end subroutine phs_wood_config_increase_n_par
@ %def phs_wood_config_increase_n_par
@ Output. The contents of the PHS forest are not printed explicitly.
<<PHS wood: phs wood config: TBP>>=
procedure :: write => phs_wood_config_write
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_write (object, unit, include_id)
class(phs_wood_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
end subroutine phs_wood_config_write
<<PHS wood: procedures>>=
module subroutine phs_wood_config_write (object, unit, include_id)
class(phs_wood_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") &
"Partonic phase-space configuration (phase-space forest):"
call object%base_write (unit)
write (u, "(1x,A)") "Phase-space configuration parameters:"
call object%par%write (u)
call object%mapping_defaults%write (u)
write (u, "(3x,A,A,A)") "Run ID: '", char (object%run_id), "'"
end subroutine phs_wood_config_write
@ %def phs_wood_config_write
@ Print the PHS forest contents.
<<PHS wood: phs wood config: TBP>>=
procedure :: write_forest => phs_wood_config_write_forest
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_write_forest (object, unit)
class(phs_wood_config_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine phs_wood_config_write_forest
<<PHS wood: procedures>>=
module subroutine phs_wood_config_write_forest (object, unit)
class(phs_wood_config_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
call object%forest%write (u)
end subroutine phs_wood_config_write_forest
@ %def phs_wood_config_write_forest
@ Set the phase-space parameters that the configuration generator requests.
<<PHS wood: phs wood config: TBP>>=
procedure :: set_parameters => phs_wood_config_set_parameters
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_set_parameters (phs_config, par)
class(phs_wood_config_t), intent(inout) :: phs_config
type(phs_parameters_t), intent(in) :: par
end subroutine phs_wood_config_set_parameters
<<PHS wood: procedures>>=
module subroutine phs_wood_config_set_parameters (phs_config, par)
class(phs_wood_config_t), intent(inout) :: phs_config
type(phs_parameters_t), intent(in) :: par
phs_config%par = par
end subroutine phs_wood_config_set_parameters
@ %def phs_wood_config_set_parameters
@ Enable the generation of channel equivalences (when calling [[configure]]).
<<PHS wood: phs wood config: TBP>>=
procedure :: enable_equivalences => phs_wood_config_enable_equivalences
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_enable_equivalences (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
end subroutine phs_wood_config_enable_equivalences
<<PHS wood: procedures>>=
module subroutine phs_wood_config_enable_equivalences (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
phs_config%use_equivalences = .true.
end subroutine phs_wood_config_enable_equivalences
@ %def phs_wood_config_enable_equivalences
@ Set the phase-space mapping parameters that the configuration generator
requests.g
<<PHS wood: phs wood config: TBP>>=
procedure :: set_mapping_defaults => phs_wood_config_set_mapping_defaults
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_set_mapping_defaults &
(phs_config, mapping_defaults)
class(phs_wood_config_t), intent(inout) :: phs_config
type(mapping_defaults_t), intent(in) :: mapping_defaults
end subroutine phs_wood_config_set_mapping_defaults
<<PHS wood: procedures>>=
module subroutine phs_wood_config_set_mapping_defaults &
(phs_config, mapping_defaults)
class(phs_wood_config_t), intent(inout) :: phs_config
type(mapping_defaults_t), intent(in) :: mapping_defaults
phs_config%mapping_defaults = mapping_defaults
end subroutine phs_wood_config_set_mapping_defaults
@ %def phs_wood_config_set_mapping_defaults
@ Define the input stream for the phase-space file as an open logical unit.
The unit must be connected.
<<PHS wood: phs wood config: TBP>>=
procedure :: set_input => phs_wood_config_set_input
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_set_input (phs_config, unit)
class(phs_wood_config_t), intent(inout) :: phs_config
integer, intent(in) :: unit
end subroutine phs_wood_config_set_input
<<PHS wood: procedures>>=
module subroutine phs_wood_config_set_input (phs_config, unit)
class(phs_wood_config_t), intent(inout) :: phs_config
integer, intent(in) :: unit
phs_config%io_unit = unit
rewind (unit)
end subroutine phs_wood_config_set_input
@ %def phs_wood_config_set_input
@
\subsection{Phase-space generation}
This subroutine generates a phase space configuration using the
[[cascades]] module. Note that this may take time, and the
[[cascade_set]] subobject may consume a large amount of memory.
<<PHS wood: phs wood config: TBP>>=
procedure :: generate_phase_space => phs_wood_config_generate_phase_space
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_generate_phase_space (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
end subroutine phs_wood_config_generate_phase_space
<<PHS wood: procedures>>=
module subroutine phs_wood_config_generate_phase_space (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
integer :: off_shell, extra_off_shell
logical :: valid
integer :: unit_fds
type(string_t) :: file_name
logical :: file_exists
call msg_message ("Phase space: generating configuration ...")
off_shell = phs_config%par%off_shell
if (phs_config%use_cascades2) then
file_name = char (phs_config%id) // ".fds"
inquire (file=char (file_name), exist=file_exists)
if (.not. file_exists) call msg_fatal &
("The O'Mega input file " // char (file_name) // &
" does not exist. " // "Please make sure that the " // &
"variable ?omega_write_phs_output has been set correctly.")
unit_fds = free_unit ()
open (unit=unit_fds, file=char(file_name), status='old', action='read')
do extra_off_shell = 0, max (phs_config%n_tot - 3, 0)
phs_config%par%off_shell = off_shell + extra_off_shell
allocate (phs_config%feyngraph_set)
call feyngraph_set_generate (phs_config%feyngraph_set, &
phs_config%model, phs_config%n_in, phs_config%n_out, &
phs_config%flv, &
phs_config%par, phs_config%fatal_beam_decay, unit_fds, &
phs_config%vis_channels)
if (feyngraph_set_is_valid (phs_config%feyngraph_set)) then
exit
else
call msg_message ("Phase space: ... failed. &
&Increasing phs_off_shell ...")
call phs_config%feyngraph_set%final ()
deallocate (phs_config%feyngraph_set)
end if
end do
close (unit_fds)
else
allocate (phs_config%cascade_set)
do extra_off_shell = 0, max (phs_config%n_tot - 3, 0)
phs_config%par%off_shell = off_shell + extra_off_shell
call cascade_set_generate (phs_config%cascade_set, &
phs_config%model, phs_config%n_in, phs_config%n_out, &
phs_config%flv, &
phs_config%par, phs_config%fatal_beam_decay)
if (cascade_set_is_valid (phs_config%cascade_set)) then
exit
else
call msg_message ("Phase space: ... failed. &
&Increasing phs_off_shell ...")
end if
end do
end if
if (phs_config%use_cascades2) then
valid = feyngraph_set_is_valid (phs_config%feyngraph_set)
else
valid = cascade_set_is_valid (phs_config%cascade_set)
end if
if (valid) then
call msg_message ("Phase space: ... success.")
else
call msg_fatal ("Phase-space: generation failed")
end if
end subroutine phs_wood_config_generate_phase_space
@ %def phs_wood_config_generate_phase_space
@ Using the generated phase-space configuration, write an appropriate
phase-space file to the stored (or explicitly specified) I/O unit.
<<PHS wood: phs wood config: TBP>>=
procedure :: write_phase_space => phs_wood_config_write_phase_space
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_write_phase_space (phs_config, &
filename_vis, unit)
class(phs_wood_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
type(string_t), intent(in), optional :: filename_vis
end subroutine phs_wood_config_write_phase_space
<<PHS wood: procedures>>=
module subroutine phs_wood_config_write_phase_space (phs_config, &
filename_vis, unit)
class(phs_wood_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
type(string_t), intent(in), optional :: filename_vis
type(string_t) :: setenv_tex, setenv_mp, pipe, pipe_dvi
integer :: u, unit_tex, unit_dev, status
if (allocated (phs_config%cascade_set) .or. &
allocated (phs_config%feyngraph_set)) then
if (present (unit)) then
u = unit
else
u = phs_config%io_unit
end if
write (u, "(1x,A,A)") "process ", char (phs_config%id)
write (u, "(A)")
if (phs_config%use_cascades2) then
call feyngraph_set_write_process_bincode_format (phs_config%feyngraph_set, u)
else
call cascade_set_write_process_bincode_format (phs_config%cascade_set, u)
end if
write (u, "(A)")
write (u, "(3x,A,A,A32,A)") "md5sum_process = ", &
'"', phs_config%md5sum_process, '"'
write (u, "(3x,A,A,A32,A)") "md5sum_model_par = ", &
'"', phs_config%md5sum_model_par, '"'
write (u, "(3x,A,A,A32,A)") "md5sum_phs_config = ", &
'"', phs_config%md5sum_phs_config, '"'
call phs_config%par%write (u)
if (phs_config%use_cascades2) then
call feyngraph_set_write_file_format (phs_config%feyngraph_set, u)
else
call cascade_set_write_file_format (phs_config%cascade_set, u)
end if
if (phs_config%vis_channels) then
unit_tex = free_unit ()
open (unit=unit_tex, file=char(filename_vis // ".tex"), &
action="write", status="replace")
if (phs_config%use_cascades2) then
call feyngraph_set_write_graph_format (phs_config%feyngraph_set, &
filename_vis // "-graphs", phs_config%id, unit_tex)
else
call cascade_set_write_graph_format (phs_config%cascade_set, &
filename_vis // "-graphs", phs_config%id, unit_tex)
end if
close (unit_tex)
call msg_message ("Phase space: visualizing channels in file " &
// char(trim(filename_vis)) // "...")
if (phs_config%os_data%event_analysis_ps) then
BLOCK: do
unit_dev = free_unit ()
open (file = "/dev/null", unit = unit_dev, &
action = "write", iostat = status)
if (status /= 0) then
pipe = ""
pipe_dvi = ""
else
pipe = " > /dev/null"
pipe_dvi = " 2>/dev/null 1>/dev/null"
end if
close (unit_dev)
if (phs_config%os_data%whizard_texpath /= "") then
setenv_tex = "TEXINPUTS=" // &
phs_config%os_data%whizard_texpath // ":$TEXINPUTS "
setenv_mp = "MPINPUTS=" // &
phs_config%os_data%whizard_texpath // ":$MPINPUTS "
else
setenv_tex = ""
setenv_mp = ""
end if
call os_system_call (setenv_tex // &
phs_config%os_data%latex // " " // &
filename_vis // ".tex " // pipe, status)
if (status /= 0) exit BLOCK
if (phs_config%os_data%mpost /= "") then
call os_system_call (setenv_mp // &
phs_config%os_data%mpost // " " // &
filename_vis // "-graphs.mp" // pipe, status)
else
call msg_fatal ("Could not use MetaPOST.")
end if
if (status /= 0) exit BLOCK
call os_system_call (setenv_tex // &
phs_config%os_data%latex // " " // &
filename_vis // ".tex" // pipe, status)
if (status /= 0) exit BLOCK
call os_system_call &
(phs_config%os_data%dvips // " -o " // filename_vis &
// ".ps " // filename_vis // ".dvi" // pipe_dvi, status)
if (status /= 0) exit BLOCK
if (phs_config%os_data%event_analysis_pdf) then
call os_system_call (phs_config%os_data%ps2pdf // " " // &
filename_vis // ".ps", status)
if (status /= 0) exit BLOCK
end if
exit BLOCK
end do BLOCK
if (status /= 0) then
call msg_error ("Unable to compile analysis output file")
end if
end if
end if
else
call msg_fatal ("Phase-space configuration: &
&no phase space object generated")
end if
end subroutine phs_wood_config_write_phase_space
@ %def phs_config_write_phase_space
@ Clear the phase-space configuration. This is useful since the
object may become \emph{really} large.
<<PHS wood: phs wood config: TBP>>=
procedure :: clear_phase_space => phs_wood_config_clear_phase_space
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_clear_phase_space (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
end subroutine phs_wood_config_clear_phase_space
<<PHS wood: procedures>>=
module subroutine phs_wood_config_clear_phase_space (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
if (allocated (phs_config%cascade_set)) then
call cascade_set_final (phs_config%cascade_set)
deallocate (phs_config%cascade_set)
end if
if (allocated (phs_config%feyngraph_set)) then
call phs_config%feyngraph_set%final ()
deallocate (phs_config%feyngraph_set)
end if
end subroutine phs_wood_config_clear_phase_space
@ %def phs_wood_config_clear_phase_space
@
Extract the set of resonance histories
<<PHS wood: phs wood config: TBP>>=
procedure :: extract_resonance_history_set &
=> phs_wood_config_extract_resonance_history_set
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_extract_resonance_history_set &
(phs_config, res_set, include_trivial)
class(phs_wood_config_t), intent(in) :: phs_config
type(resonance_history_set_t), intent(out) :: res_set
logical, intent(in), optional :: include_trivial
end subroutine phs_wood_config_extract_resonance_history_set
<<PHS wood: procedures>>=
module subroutine phs_wood_config_extract_resonance_history_set &
(phs_config, res_set, include_trivial)
class(phs_wood_config_t), intent(in) :: phs_config
type(resonance_history_set_t), intent(out) :: res_set
logical, intent(in), optional :: include_trivial
call phs_config%forest%extract_resonance_history_set &
(res_set, include_trivial)
end subroutine phs_wood_config_extract_resonance_history_set
@ %def phs_wood_config_extract_resonance_history_set
@
\subsection{Phase-space configuration}
We read the phase-space configuration from the stored I/O unit. If
this is not set, we assume that we have to generate a phase space
configuration. When done, we open a scratch file and write the
configuration.
If [[rebuild]] is set, we should trash any existing phase space file
and build a new one. Otherwise, we try to use an old one, which we
check for existence and integrity. If [[ignore_mismatch]] is set, we
reuse an existing file even if it does not match the current setup.
<<PHS wood: phs wood config: TBP>>=
procedure :: configure => phs_wood_config_configure
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_wood_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
end subroutine phs_wood_config_configure
<<PHS wood: procedures>>=
module subroutine phs_wood_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_wood_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
type(string_t) :: filename, filename_vis
logical :: variable_limits
logical :: ok, exist, found, check, match, rebuild_phs
integer :: g, c0, c1, n
if (present (nlo_type)) then
phs_config%nlo_type = nlo_type
else
phs_config%nlo_type = BORN
end if
phs_config%sqrts = sqrts
phs_config%par%sqrts = sqrts
if (present (sqrts_fixed)) &
phs_config%sqrts_fixed = sqrts_fixed
if (present (lab_is_cm)) &
phs_config%lab_is_cm = lab_is_cm
if (present (azimuthal_dependence)) &
phs_config%azimuthal_dependence = azimuthal_dependence
if (present (rebuild)) then
rebuild_phs = rebuild
else
rebuild_phs = .true.
end if
if (present (ignore_mismatch)) then
check = .not. ignore_mismatch
if (ignore_mismatch) &
call msg_warning ("Reading phs file: MD5 sum check disabled")
else
check = .true.
end if
phs_config%md5sum_forest = ""
call phs_config%compute_md5sum (include_id = .false.)
if (phs_config%io_unit == 0) then
filename = phs_config%make_phs_filename (subdir)
filename_vis = phs_config%make_phs_filename (subdir) // "-vis"
if (.not. rebuild_phs) then
if (check) then
call phs_config%read_phs_file (exist, found, match, subdir=subdir)
rebuild_phs = .not. (exist .and. found .and. match)
else
call phs_config%read_phs_file (exist, found, subdir=subdir)
rebuild_phs = .not. (exist .and. found)
end if
end if
if (.not. mpi_is_comm_master ()) then
rebuild_phs = .false.
call msg_message ("MPI: Workers do not build phase space configuration.")
end if
if (rebuild_phs) then
call phs_config%generate_phase_space ()
phs_config%io_unit = free_unit ()
if (phs_config%id /= "") then
call msg_message ("Phase space: writing configuration file '" &
// char (filename) // "'")
open (phs_config%io_unit, file = char (filename), &
status = "replace", action = "readwrite")
else
open (phs_config%io_unit, status = "scratch", action = "readwrite")
end if
call phs_config%write_phase_space (filename_vis)
rewind (phs_config%io_unit)
else
call msg_message ("Phase space: keeping configuration file '" &
// char (filename) // "'")
end if
end if
if (phs_config%io_unit == 0) then
ok = .true.
else
call phs_config%forest%read (phs_config%io_unit, phs_config%id, &
phs_config%n_in, phs_config%n_out, phs_config%model, ok)
if (.not. phs_config%io_unit_keep_open) then
close (phs_config%io_unit)
phs_config%io_unit = 0
end if
end if
if (ok) then
call phs_config%forest%set_flavors (phs_config%flv(:,1))
variable_limits = .not. phs_config%lab_is_cm
call phs_config%forest%set_parameters (phs_config%mapping_defaults, &
variable_limits)
call phs_config%forest%setup_prt_combinations ()
phs_config%n_channel = phs_config%forest%get_n_channels ()
phs_config%n_par = phs_config%forest%get_n_parameters ()
allocate (phs_config%channel (phs_config%n_channel))
if (phs_config%use_equivalences) then
call phs_config%forest%set_equivalences ()
call phs_config%forest%get_equivalences (phs_config%channel, &
phs_config%azimuthal_dependence)
phs_config%provides_equivalences = .true.
end if
call phs_config%forest%set_s_mappings ()
call phs_config%record_on_shell ()
if (phs_config%mapping_defaults%enable_s_mapping) then
call phs_config%record_s_mappings ()
end if
allocate (phs_config%chain (phs_config%n_channel), source = 0)
do g = 1, phs_config%forest%get_n_groves ()
call phs_config%forest%get_grove_bounds (g, c0, c1, n)
phs_config%chain (c0:c1) = g
end do
phs_config%provides_chains = .true.
call phs_config%compute_md5sum_forest ()
else
write (msg_buffer, "(A,A,A)") &
"Phase space: process '", &
char (phs_config%id), "' not found in configuration file"
call msg_fatal ()
end if
end subroutine phs_wood_config_configure
@ %def phs_wood_config_configure
@ The MD5 sum of the forest is computed in addition to the MD5 sum of
the configuration. The reason is that the forest may depend on a
user-provided external file. On the other hand, this MD5 sum encodes
all information that is relevant for further processing. Therefore,
the [[get_md5sum]] method returns this result, once it is available.
<<PHS wood: phs wood config: TBP>>=
procedure :: compute_md5sum_forest => phs_wood_config_compute_md5sum_forest
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_compute_md5sum_forest (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
end subroutine phs_wood_config_compute_md5sum_forest
<<PHS wood: procedures>>=
module subroutine phs_wood_config_compute_md5sum_forest (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
integer :: u
u = free_unit ()
open (u, status = "scratch", action = "readwrite")
call phs_config%write_forest (u)
rewind (u)
phs_config%md5sum_forest = md5sum (u)
close (u)
end subroutine phs_wood_config_compute_md5sum_forest
@ %def phs_wood_config_compute_md5sum_forest
@ Create filenames according to standard conventions. The [[id]] is the
process name including the suffix [[_iX]] where [[X]] stands for the component
identifier (an integer). The [[run_id]] may be set or unset.
The convention for file names that include the run ID is to separate prefix, run
ID, and any extensions by dots. We construct the file name by concatenating
the individual elements accordingly. If there is no run ID, we nevertheless
replace [[_iX]] by [[.iX]].
<<PHS wood: phs wood config: TBP>>=
procedure :: make_phs_filename => phs_wood_make_phs_filename
<<PHS wood: sub interfaces>>=
module function phs_wood_make_phs_filename &
(phs_config, subdir) result (filename)
class(phs_wood_config_t), intent(in) :: phs_config
type(string_t), intent(in), optional :: subdir
type(string_t) :: filename
end function phs_wood_make_phs_filename
<<PHS wood: procedures>>=
module function phs_wood_make_phs_filename &
(phs_config, subdir) result (filename)
class(phs_wood_config_t), intent(in) :: phs_config
type(string_t), intent(in), optional :: subdir
type(string_t) :: filename
type(string_t) :: basename, suffix, comp_code, comp_index
basename = phs_config%id
call split (basename, suffix, "_", back=.true.)
comp_code = extract (suffix, 1, 1)
comp_index = extract (suffix, 2)
if (comp_code == "i" .and. verify (comp_index, "1234567890") == 0) then
suffix = "." // comp_code // comp_index
else
basename = phs_config%id
suffix = ""
end if
if (phs_config%run_id /= "") then
filename = basename // "." // phs_config%run_id // suffix // ".phs"
else
filename = basename // suffix // ".phs"
end if
if (present (subdir)) then
filename = subdir // "/" // filename
end if
end function phs_wood_make_phs_filename
@ %def phs_wood_make_phs_filename
@
<<PHS wood: phs wood config: TBP>>=
procedure :: reshuffle_flavors => phs_wood_config_reshuffle_flavors
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_reshuffle_flavors &
(phs_config, reshuffle, flv_extra)
class(phs_wood_config_t), intent(inout) :: phs_config
integer, intent(in), dimension(:), allocatable :: reshuffle
type(flavor_t), intent(in) :: flv_extra
end subroutine phs_wood_config_reshuffle_flavors
<<PHS wood: procedures>>=
module subroutine phs_wood_config_reshuffle_flavors &
(phs_config, reshuffle, flv_extra)
class(phs_wood_config_t), intent(inout) :: phs_config
integer, intent(in), dimension(:), allocatable :: reshuffle
type(flavor_t), intent(in) :: flv_extra
call phs_config%forest%set_flavors (phs_config%flv(:,1), reshuffle, &
flv_extra)
end subroutine phs_wood_config_reshuffle_flavors
@ %def phs_wood_config_reshuffle_flavors
@
<<PHS wood: phs wood config: TBP>>=
procedure :: set_momentum_links => phs_wood_config_set_momentum_links
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle)
class(phs_wood_config_t), intent(inout) :: phs_config
integer, intent(in), dimension(:), allocatable :: reshuffle
end subroutine phs_wood_config_set_momentum_links
<<PHS wood: procedures>>=
module subroutine phs_wood_config_set_momentum_links (phs_config, reshuffle)
class(phs_wood_config_t), intent(inout) :: phs_config
integer, intent(in), dimension(:), allocatable :: reshuffle
call phs_config%forest%set_momentum_links (reshuffle)
end subroutine phs_wood_config_set_momentum_links
@ %def phs_wood_config_set_momentum_links
@ Identify resonances which are marked by s-channel mappings for the
whole phase space and report them to the channel array.
<<PHS wood: phs wood config: TBP>>=
procedure :: record_s_mappings => phs_wood_config_record_s_mappings
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_record_s_mappings (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
end subroutine phs_wood_config_record_s_mappings
<<PHS wood: procedures>>=
module subroutine phs_wood_config_record_s_mappings (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
logical :: flag
real(default) :: mass, width
integer :: c
do c = 1, phs_config%n_channel
call phs_config%forest%get_s_mapping (c, flag, mass, width)
if (flag) then
if (mass == 0) then
call msg_fatal ("Phase space: s-channel resonance " &
// " has zero mass")
end if
if (width == 0) then
call msg_fatal ("Phase space: s-channel resonance " &
// " has zero width")
end if
call phs_config%channel(c)%set_resonant (mass, width)
end if
end do
end subroutine phs_wood_config_record_s_mappings
@ %def phs_wood_config_record_s_mappings
@ Identify on-shell mappings for the whole phase space and report them
to the channel array.
<<PHS wood: phs wood config: TBP>>=
procedure :: record_on_shell => phs_wood_config_record_on_shell
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_record_on_shell (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
end subroutine phs_wood_config_record_on_shell
<<PHS wood: procedures>>=
module subroutine phs_wood_config_record_on_shell (phs_config)
class(phs_wood_config_t), intent(inout) :: phs_config
logical :: flag
real(default) :: mass
integer :: c
do c = 1, phs_config%n_channel
call phs_config%forest%get_on_shell (c, flag, mass)
if (flag) then
call phs_config%channel(c)%set_on_shell (mass)
end if
end do
end subroutine phs_wood_config_record_on_shell
@ %def phs_wood_config_record_on_shell
@ Return the most relevant MD5 sum. This overrides the method of the
base type.
<<PHS wood: phs wood config: TBP>>=
procedure :: get_md5sum => phs_wood_config_get_md5sum
<<PHS wood: sub interfaces>>=
module function phs_wood_config_get_md5sum (phs_config) result (md5sum)
class(phs_wood_config_t), intent(in) :: phs_config
character(32) :: md5sum
end function phs_wood_config_get_md5sum
<<PHS wood: procedures>>=
module function phs_wood_config_get_md5sum (phs_config) result (md5sum)
class(phs_wood_config_t), intent(in) :: phs_config
character(32) :: md5sum
if (phs_config%md5sum_forest /= "") then
md5sum = phs_config%md5sum_forest
else
md5sum = phs_config%md5sum_phs_config
end if
end function phs_wood_config_get_md5sum
@ %def phs_wood_config_get_md5sum
@ Check whether a phase-space configuration for the current process exists.
We look for the phase-space file that should correspond to the current
process. If we find it, we check the MD5 sums stored in the file against the
MD5 sums in the current configuration (if required).
If successful, read the PHS file.
<<PHS wood: phs wood config: TBP>>=
procedure :: read_phs_file => phs_wood_read_phs_file
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_read_phs_file &
(phs_config, exist, found, match, subdir)
class(phs_wood_config_t), intent(inout) :: phs_config
logical, intent(out) :: exist
logical, intent(out) :: found
logical, intent(out), optional :: match
type(string_t), intent(in), optional :: subdir
end subroutine phs_wood_read_phs_file
<<PHS wood: procedures>>=
module subroutine phs_wood_read_phs_file &
(phs_config, exist, found, match, subdir)
class(phs_wood_config_t), intent(inout) :: phs_config
logical, intent(out) :: exist
logical, intent(out) :: found
logical, intent(out), optional :: match
type(string_t), intent(in), optional :: subdir
type(string_t) :: filename
integer :: u
filename = phs_config%make_phs_filename (subdir)
inquire (file = char (filename), exist = exist)
if (exist) then
u = free_unit ()
open (u, file = char (filename), action = "read", status = "old")
call phs_config%forest%read (u, phs_config%id, phs_config%n_in, &
phs_config%n_out, phs_config%model, found, &
phs_config%md5sum_process, phs_config%md5sum_model_par, &
phs_config%md5sum_phs_config, match = match)
close (u)
else
found = .false.
if (present (match)) match = .false.
end if
end subroutine phs_wood_read_phs_file
@ %def phs_wood_read_phs_file
@ Startup message, after configuration is complete.
<<PHS wood: phs wood config: TBP>>=
procedure :: startup_message => phs_wood_config_startup_message
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_config_startup_message (phs_config, unit)
class(phs_wood_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
end subroutine phs_wood_config_startup_message
<<PHS wood: procedures>>=
module subroutine phs_wood_config_startup_message (phs_config, unit)
class(phs_wood_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
integer :: n_groves, n_eq
n_groves = phs_config%forest%get_n_groves ()
n_eq = phs_config%forest%get_n_equivalences ()
call phs_config%base_startup_message (unit)
if (phs_config%n_channel == 1) then
write (msg_buffer, "(A,2(I0,A))") &
"Phase space: found ", phs_config%n_channel, &
" channel, collected in ", n_groves, &
" grove."
else if (n_groves == 1) then
write (msg_buffer, "(A,2(I0,A))") &
"Phase space: found ", phs_config%n_channel, &
" channels, collected in ", n_groves, &
" grove."
else
write (msg_buffer, "(A,2(I0,A))") &
"Phase space: found ", phs_config%n_channel, &
" channels, collected in ", n_groves, &
" groves."
end if
call msg_message (unit = unit)
if (phs_config%use_equivalences) then
if (n_eq == 1) then
write (msg_buffer, "(A,I0,A)") &
"Phase space: Using ", n_eq, &
" equivalence between channels."
else
write (msg_buffer, "(A,I0,A)") &
"Phase space: Using ", n_eq, &
" equivalences between channels."
end if
else
write (msg_buffer, "(A)") &
"Phase space: no equivalences between channels used."
end if
call msg_message (unit = unit)
write (msg_buffer, "(A,2(1x,I0,1x,A))") &
"Phase space: wood"
call msg_message (unit = unit)
end subroutine phs_wood_config_startup_message
@ %def phs_wood_config_startup_message
@ Allocate an instance: the actual phase-space object.
Gfortran 7/8/9 bug, has to remain in the main module.
<<PHS wood: phs wood config: TBP>>=
procedure, nopass :: allocate_instance => phs_wood_config_allocate_instance
<<PHS wood: main procedures>>=
subroutine phs_wood_config_allocate_instance (phs)
class(phs_t), intent(inout), pointer :: phs
allocate (phs_wood_t :: phs)
end subroutine phs_wood_config_allocate_instance
@ %def phs_wood_config_allocate_instance
@
\subsection{Kinematics implementation}
We generate $\cos\theta$ and $\phi$ uniformly, covering the solid angle.
<<PHS wood: public>>=
public :: phs_wood_t
<<PHS wood: types>>=
type, extends (phs_t) :: phs_wood_t
real(default) :: sqrts = 0
type(phs_forest_t) :: forest
real(default), dimension(3) :: r_real
integer :: n_r_born = 0
contains
<<PHS wood: phs wood: TBP>>
end type phs_wood_t
@ %def phs_wood_t
@ Output. The [[verbose]] setting is irrelevant, we just display the contents
of the base object.
<<PHS wood: phs wood: TBP>>=
procedure :: write => phs_wood_write
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_write (object, unit, verbose)
class(phs_wood_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine phs_wood_write
<<PHS wood: procedures>>=
module subroutine phs_wood_write (object, unit, verbose)
class(phs_wood_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u
u = given_output_unit (unit)
call object%base_write (u)
end subroutine phs_wood_write
@ %def phs_wood_write
@ Write the forest separately.
<<PHS wood: phs wood: TBP>>=
procedure :: write_forest => phs_wood_write_forest
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_write_forest (object, unit)
class(phs_wood_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine phs_wood_write_forest
<<PHS wood: procedures>>=
module subroutine phs_wood_write_forest (object, unit)
class(phs_wood_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
call object%forest%write (u)
end subroutine phs_wood_write_forest
@ %def phs_wood_write_forest
@ Finalizer.
<<PHS wood: phs wood: TBP>>=
procedure :: final => phs_wood_final
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_final (object)
class(phs_wood_t), intent(inout) :: object
end subroutine phs_wood_final
<<PHS wood: procedures>>=
module subroutine phs_wood_final (object)
class(phs_wood_t), intent(inout) :: object
call object%forest%final ()
end subroutine phs_wood_final
@ %def phs_wood_final
@ Initialization. We allocate arrays ([[base_init]]) and adjust the
phase-space volume. The two-particle phase space volume is
\begin{equation}
\Phi_2 = \frac{1}{4(2\pi)^5} = 2.55294034614 \times 10^{-5}
\end{equation}
independent of the particle masses.
<<PHS wood: phs wood: TBP>>=
procedure :: init => phs_wood_init
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_init (phs, phs_config)
class(phs_wood_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
end subroutine phs_wood_init
<<PHS wood: procedures>>=
module subroutine phs_wood_init (phs, phs_config)
class(phs_wood_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
call phs%base_init (phs_config)
select type(phs_config)
type is (phs_wood_config_t)
phs%forest = phs_config%forest
if (phs_config%is_combined_integration) then
phs%n_r_born = phs_config%n_par - 3
end if
end select
end subroutine phs_wood_init
@ %def phs_wood_init
@
\subsection{Evaluation}
We compute the outgoing momenta from the incoming momenta and
the input parameter set [[r_in]] in channel [[r_in]]. We also compute the
[[r]] parameters and Jacobians [[f]] for all other channels.
We do \emph{not} need to a apply a transformation from/to the c.m.\ frame,
because in [[phs_base]] the momenta are already boosted to the c.m.\ frame
before assigning them in the [[phs]] object, and inversely boosted when
extracting them.
<<PHS wood: phs wood: TBP>>=
procedure :: evaluate_selected_channel => phs_wood_evaluate_selected_channel
procedure :: evaluate_other_channels => phs_wood_evaluate_other_channels
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in)
class(phs_wood_t), intent(inout) :: phs
real(default), intent(in), dimension(:) :: r_in
integer, intent(in) :: c_in
end subroutine phs_wood_evaluate_selected_channel
module subroutine phs_wood_evaluate_other_channels (phs, c_in)
class(phs_wood_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_wood_evaluate_other_channels
<<PHS wood: procedures>>=
module subroutine phs_wood_evaluate_selected_channel (phs, c_in, r_in)
class(phs_wood_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
logical :: ok
phs%q_defined = .false.
if (phs%p_defined) then
call phs%forest%set_prt_in (phs%p)
phs%r(:,c_in) = r_in
call phs%forest%evaluate_selected_channel (c_in, phs%active_channel, &
phs%sqrts_hat, phs%r, phs%f, phs%volume, ok)
select type (config => phs%config)
type is (phs_wood_config_t)
if (config%is_combined_integration) then
if (phs%n_r_born >= 0) then
phs%r_real = r_in (phs%n_r_born + 1 : phs%n_r_born + 3)
else
call msg_fatal ("n_r_born should be larger than 0!")
end if
end if
end select
if (ok) then
phs%q = phs%forest%get_momenta_out ()
phs%q_defined = .true.
end if
end if
end subroutine phs_wood_evaluate_selected_channel
module subroutine phs_wood_evaluate_other_channels (phs, c_in)
class(phs_wood_t), intent(inout) :: phs
integer, intent(in) :: c_in
integer :: c
if (phs%q_defined) then
call phs%forest%evaluate_other_channels (c_in, phs%active_channel, &
phs%sqrts_hat, phs%r, phs%f, combine=.true.)
select type (config => phs%config)
type is (phs_wood_config_t)
if (config%is_combined_integration) then
if (phs%n_r_born >= 0) then
do c = 1, size (phs%r, 2)
phs%r(phs%n_r_born + 1 : phs%n_r_born + 3, c) = phs%r_real
end do
else
phs%r_defined = .false.
end if
end if
end select
phs%r_defined = .true.
end if
end subroutine phs_wood_evaluate_other_channels
@ %def phs_wood_evaluate_selected_channel
@ %def phs_wood_evaluate_other_channels
@ Inverse evaluation.
<<PHS wood: phs wood: TBP>>=
procedure :: inverse => phs_wood_inverse
<<PHS wood: sub interfaces>>=
module subroutine phs_wood_inverse (phs)
class(phs_wood_t), intent(inout) :: phs
end subroutine phs_wood_inverse
<<PHS wood: procedures>>=
module subroutine phs_wood_inverse (phs)
class(phs_wood_t), intent(inout) :: phs
if (phs%p_defined .and. phs%q_defined) then
call phs%forest%set_prt_in (phs%p)
call phs%forest%set_prt_out (phs%q)
call phs%forest%recover_channel (1, phs%sqrts_hat, phs%r, &
phs%f, phs%volume)
call phs%forest%evaluate_other_channels (1, phs%active_channel, &
phs%sqrts_hat, phs%r, phs%f, combine=.false.)
phs%r_defined = .true.
end if
end subroutine phs_wood_inverse
@ %def phs_wood_inverse
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[phs_wood_ut.f90]]>>=
<<File header>>
module phs_wood_ut
use unit_tests
use phs_wood_uti
<<Standard module head>>
<<PHS wood: public test>>
<<PHS wood: public test auxiliary>>
contains
<<PHS wood: test driver>>
end module phs_wood_ut
@ %def phs_wood_ut
@
<<[[phs_wood_uti.f90]]>>=
<<File header>>
module phs_wood_uti
<<Use kinds>>
<<Use strings>>
use io_units
use os_interface
use lorentz
use flavors
use model_data
use process_constants
use mappings
use phs_base
use phs_forests
use phs_wood
use phs_base_ut, only: init_test_process_data, init_test_decay_data
<<Standard module head>>
<<PHS wood: public test auxiliary>>
<<PHS wood: test declarations>>
contains
<<PHS wood: tests>>
<<PHS wood: test auxiliary>>
end module phs_wood_uti
@ %def phs_wood_ut
@ API: driver for the unit tests below.
<<PHS wood: public test>>=
public :: phs_wood_test
<<PHS wood: test driver>>=
subroutine phs_wood_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS wood: execute tests>>
end subroutine phs_wood_test
@ %def phs_wood_test
<<PHS wood: public test>>=
public :: phs_wood_vis_test
<<PHS wood: test driver>>=
subroutine phs_wood_vis_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<PHS wood: execute vis tests>>
end subroutine phs_wood_vis_test
@ %def phs_wood_vis_test
@
\subsubsection{Phase-space configuration data}
Construct and display a test phase-space configuration object. Also
check the [[azimuthal_dependence]] flag.
This auxiliary routine writes a phase-space configuration file to unit
[[u_phs]].
<<PHS wood: public test auxiliary>>=
public :: write_test_phs_file
<<PHS wood: test auxiliary>>=
subroutine write_test_phs_file (u_phs, procname)
integer, intent(in) :: u_phs
type(string_t), intent(in), optional :: procname
if (present (procname)) then
write (u_phs, "(A,A)") "process ", char (procname)
else
write (u_phs, "(A)") "process testproc"
end if
write (u_phs, "(A,A)") " md5sum_process = ", '""'
write (u_phs, "(A,A)") " md5sum_model_par = ", '""'
write (u_phs, "(A,A)") " md5sum_phs_config = ", '""'
write (u_phs, "(A)") " sqrts = 1000"
write (u_phs, "(A)") " m_threshold_s = 50"
write (u_phs, "(A)") " m_threshold_t = 100"
write (u_phs, "(A)") " off_shell = 2"
write (u_phs, "(A)") " t_channel = 6"
write (u_phs, "(A)") " keep_nonresonant = T"
write (u_phs, "(A)") " grove #1"
write (u_phs, "(A)") " tree 3"
end subroutine write_test_phs_file
@ %def write_test_phs_file
@
<<PHS wood: execute tests>>=
call test (phs_wood_1, "phs_wood_1", &
"phase-space configuration", &
u, results)
<<PHS wood: test declarations>>=
public :: phs_wood_1
<<PHS wood: tests>>=
subroutine phs_wood_1 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
class(phs_config_t), allocatable :: phs_data
type(mapping_defaults_t) :: mapping_defaults
real(default) :: sqrts
integer :: u_phs, iostat
character(32) :: buffer
write (u, "(A)") "* Test output: phs_wood_1"
write (u, "(A)") "* Purpose: initialize and display &
&phase-space configuration data"
write (u, "(A)")
call model%init_test ()
call syntax_phs_forest_init ()
write (u, "(A)") "* Initialize a process"
write (u, "(A)")
call init_test_process_data (var_str ("phs_wood_1"), process_data)
write (u, "(A)") "* Create a scratch phase-space file"
write (u, "(A)")
u_phs = free_unit ()
open (u_phs, status = "scratch", action = "readwrite")
call write_test_phs_file (u_phs, var_str ("phs_wood_1"))
rewind (u_phs)
do
read (u_phs, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
write (u, "(A)")
write (u, "(A)") "* Setup phase-space configuration object"
write (u, "(A)")
mapping_defaults%step_mapping = .false.
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_input (u_phs)
call phs_data%set_mapping_defaults (mapping_defaults)
end select
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs_data%write (u)
write (u, "(A)")
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%write_forest (u)
end select
write (u, "(A)")
write (u, "(A)") "* Cleanup"
close (u_phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_wood_1"
end subroutine phs_wood_1
@ %def phs_wood_1
@
\subsubsection{Phase space evaluation}
Compute kinematics for given parameters, also invert the calculation.
<<PHS wood: execute tests>>=
call test (phs_wood_2, "phs_wood_2", &
"phase-space evaluation", &
u, results)
<<PHS wood: test declarations>>=
public :: phs_wood_2
<<PHS wood: tests>>=
subroutine phs_wood_2 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(process_constants_t) :: process_data
real(default) :: sqrts, E
class(phs_config_t), allocatable, target :: phs_data
class(phs_t), pointer :: phs => null ()
type(vector4_t), dimension(2) :: p, q
integer :: u_phs
write (u, "(A)") "* Test output: phs_wood_2"
write (u, "(A)") "* Purpose: test simple single-channel phase space"
write (u, "(A)")
call model%init_test ()
call flv%init (25, model)
write (u, "(A)") "* Initialize a process and a matching &
&phase-space configuration"
write (u, "(A)")
call init_test_process_data (var_str ("phs_wood_2"), process_data)
u_phs = free_unit ()
open (u_phs, status = "scratch", action = "readwrite")
call write_test_phs_file (u_phs, var_str ("phs_wood_2"))
rewind (u_phs)
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_input (u_phs)
end select
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs_data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%write (u, verbose=.true.)
write (u, "(A)")
write (u, "(A)") "* Set incoming momenta"
write (u, "(A)")
E = sqrts / 2
p(1) = vector4_moving (E, sqrt (E**2 - flv%get_mass ()**2), 3)
p(2) = vector4_moving (E,-sqrt (E**2 - flv%get_mass ()**2), 3)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Compute phase-space point &
&for x = 0.125, 0.5"
write (u, "(A)")
call phs%evaluate_selected_channel (1, [0.125_default, 0.5_default])
call phs%evaluate_other_channels (1)
call phs%write (u)
write (u, "(A)")
select type (phs)
type is (phs_wood_t)
call phs%write_forest (u)
end select
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
call phs%final ()
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call phs%write (u)
write (u, "(A)")
select type (phs)
type is (phs_wood_t)
call phs%write_forest (u)
end select
call phs%final ()
deallocate (phs)
close (u_phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_wood_2"
end subroutine phs_wood_2
@ %def phs_wood_2
@
\subsubsection{Phase-space generation}
Generate phase space for a simple process.
<<PHS wood: execute tests>>=
call test (phs_wood_3, "phs_wood_3", &
"phase-space generation", &
u, results)
<<PHS wood: test declarations>>=
public :: phs_wood_3
<<PHS wood: tests>>=
subroutine phs_wood_3 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
type(phs_parameters_t) :: phs_par
class(phs_config_t), allocatable :: phs_data
integer :: iostat
character(80) :: buffer
write (u, "(A)") "* Test output: phs_wood_3"
write (u, "(A)") "* Purpose: generate a phase-space configuration"
write (u, "(A)")
call model%init_test ()
call syntax_phs_forest_init ()
write (u, "(A)") "* Initialize a process and phase-space parameters"
write (u, "(A)")
call init_test_process_data (var_str ("phs_wood_3"), process_data)
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
phs_par%sqrts = 1000
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
phs_data%io_unit_keep_open = .true.
end select
write (u, "(A)")
write (u, "(A)") "* Generate a scratch phase-space file"
write (u, "(A)")
call phs_data%configure (phs_par%sqrts)
select type (phs_data)
type is (phs_wood_config_t)
rewind (phs_data%io_unit)
do
read (phs_data%io_unit, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
end select
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_wood_3"
end subroutine phs_wood_3
@ %def phs_wood_3
@
\subsubsection{Nontrivial process}
Generate phase space for a $2\to 3$ process.
<<PHS wood: execute tests>>=
call test (phs_wood_4, "phs_wood_4", &
"nontrivial process", &
u, results)
<<PHS wood: test declarations>>=
public :: phs_wood_4
<<PHS wood: tests>>=
subroutine phs_wood_4 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
type(phs_parameters_t) :: phs_par
class(phs_config_t), allocatable, target :: phs_data
integer :: iostat
character(80) :: buffer
class(phs_t), pointer :: phs => null ()
real(default) :: E, pL
type(vector4_t), dimension(2) :: p
type(vector4_t), dimension(3) :: q
write (u, "(A)") "* Test output: phs_wood_4"
write (u, "(A)") "* Purpose: generate a phase-space configuration"
write (u, "(A)")
call model%init_test ()
call syntax_phs_forest_init ()
write (u, "(A)") "* Initialize a process and phase-space parameters"
write (u, "(A)")
process_data%id = "phs_wood_4"
process_data%model_name = "Test"
process_data%n_in = 2
process_data%n_out = 3
process_data%n_flv = 1
allocate (process_data%flv_state (process_data%n_in + process_data%n_out, &
process_data%n_flv))
process_data%flv_state(:,1) = [25, 25, 25, 6, -6]
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
phs_par%sqrts = 1000
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
phs_data%io_unit_keep_open = .true.
end select
write (u, "(A)")
write (u, "(A)") "* Generate a scratch phase-space file"
write (u, "(A)")
call phs_data%configure (phs_par%sqrts)
select type (phs_data)
type is (phs_wood_config_t)
rewind (phs_data%io_unit)
do
read (phs_data%io_unit, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
end select
write (u, "(A)")
write (u, "(A)") "* Initialize the phase-space instance"
write (u, "(A)")
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
write (u, "(A)") "* Set incoming momenta"
write (u, "(A)")
select type (phs_data)
type is (phs_wood_config_t)
E = phs_data%sqrts / 2
pL = sqrt (E**2 - phs_data%flv(1,1)%get_mass ()**2)
end select
p(1) = vector4_moving (E, pL, 3)
p(2) = vector4_moving (E, -pL, 3)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
write (u, "(A)") "* Compute phase-space point &
&for x = 0.1, 0.2, 0.3, 0.4, 0.5"
write (u, "(A)")
call phs%evaluate_selected_channel (1, &
[0.1_default, 0.2_default, 0.3_default, 0.4_default, 0.5_default])
call phs%evaluate_other_channels (1)
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Inverse kinematics"
write (u, "(A)")
call phs%get_outgoing_momenta (q)
call phs%final ()
deallocate (phs)
call phs_data%allocate_instance (phs)
call phs%init (phs_data)
call phs%set_incoming_momenta (p)
call phs%compute_flux ()
call phs%set_outgoing_momenta (q)
call phs%inverse ()
call phs%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call phs%final ()
deallocate (phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_wood_4"
end subroutine phs_wood_4
@ %def phs_wood_4
@
\subsubsection{Equivalences}
Generate phase space for a simple process, including channel equivalences.
<<PHS wood: execute tests>>=
call test (phs_wood_5, "phs_wood_5", &
"equivalences", &
u, results)
<<PHS wood: test declarations>>=
public :: phs_wood_5
<<PHS wood: tests>>=
subroutine phs_wood_5 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
type(phs_parameters_t) :: phs_par
class(phs_config_t), allocatable :: phs_data
write (u, "(A)") "* Test output: phs_wood_5"
write (u, "(A)") "* Purpose: generate a phase-space configuration"
write (u, "(A)")
call model%init_test ()
call syntax_phs_forest_init ()
write (u, "(A)") "* Initialize a process and phase-space parameters"
write (u, "(A)")
call init_test_process_data (var_str ("phs_wood_5"), process_data)
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
phs_par%sqrts = 1000
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
call phs_data%enable_equivalences ()
end select
write (u, "(A)")
write (u, "(A)") "* Generate a scratch phase-space file"
write (u, "(A)")
call phs_data%configure (phs_par%sqrts)
call phs_data%write (u)
write (u, "(A)")
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%write_forest (u)
end select
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_wood_5"
end subroutine phs_wood_5
@ %def phs_wood_5
@
\subsubsection{MD5 sum checks}
Generate phase space for a simple process. Repeat this with and without
parameter change.
<<PHS wood: execute tests>>=
call test (phs_wood_6, "phs_wood_6", &
"phase-space generation", &
u, results)
<<PHS wood: test declarations>>=
public :: phs_wood_6
<<PHS wood: tests>>=
subroutine phs_wood_6 (u)
integer, intent(in) :: u
type(model_data_t), target :: model
type(process_constants_t) :: process_data
type(phs_parameters_t) :: phs_par
class(phs_config_t), allocatable :: phs_data
logical :: exist, found, match
integer :: u_phs
character(*), parameter :: filename = "phs_wood_6_p.phs"
write (u, "(A)") "* Test output: phs_wood_6"
write (u, "(A)") "* Purpose: generate and check phase-space file"
write (u, "(A)")
call model%init_test ()
call syntax_phs_forest_init ()
write (u, "(A)") "* Initialize a process and phase-space parameters"
write (u, "(A)")
call init_test_process_data (var_str ("phs_wood_6"), process_data)
process_data%id = "phs_wood_6_p"
process_data%md5sum = "1234567890abcdef1234567890abcdef"
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
phs_par%sqrts = 1000
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
end select
write (u, "(A)") "* Remove previous phs file, if any"
write (u, "(A)")
inquire (file = filename, exist = exist)
if (exist) then
u_phs = free_unit ()
open (u_phs, file = filename, action = "write")
close (u_phs, status = "delete")
end if
write (u, "(A)") "* Check phase-space file (should fail)"
write (u, "(A)")
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%read_phs_file (exist, found, match)
write (u, "(1x,A,L1)") "exist = ", exist
write (u, "(1x,A,L1)") "found = ", found
write (u, "(1x,A,L1)") "match = ", match
end select
write (u, "(A)")
write (u, "(A)") "* Generate a phase-space file"
write (u, "(A)")
call phs_data%configure (phs_par%sqrts)
write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
phs_data%md5sum_process, "'"
write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
phs_data%md5sum_model_par, "'"
write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
phs_data%md5sum_phs_config, "'"
write (u, "(A)")
write (u, "(A)") "* Check MD5 sum"
write (u, "(A)")
call phs_data%final ()
deallocate (phs_data)
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
phs_par%sqrts = 1000
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
phs_data%sqrts = phs_par%sqrts
phs_data%par%sqrts = phs_par%sqrts
end select
call phs_data%compute_md5sum ()
write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
phs_data%md5sum_process, "'"
write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
phs_data%md5sum_model_par, "'"
write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
phs_data%md5sum_phs_config, "'"
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%read_phs_file (exist, found, match)
write (u, "(1x,A,L1)") "exist = ", exist
write (u, "(1x,A,L1)") "found = ", found
write (u, "(1x,A,L1)") "match = ", match
end select
write (u, "(A)")
write (u, "(A)") "* Modify sqrts and check MD5 sum"
write (u, "(A)")
call phs_data%final ()
deallocate (phs_data)
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
phs_par%sqrts = 500
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
phs_data%sqrts = phs_par%sqrts
phs_data%par%sqrts = phs_par%sqrts
end select
call phs_data%compute_md5sum ()
write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
phs_data%md5sum_process, "'"
write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
phs_data%md5sum_model_par, "'"
write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
phs_data%md5sum_phs_config, "'"
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%read_phs_file (exist, found, match)
write (u, "(1x,A,L1)") "exist = ", exist
write (u, "(1x,A,L1)") "found = ", found
write (u, "(1x,A,L1)") "match = ", match
end select
write (u, "(A)")
write (u, "(A)") "* Modify process and check MD5 sum"
write (u, "(A)")
call phs_data%final ()
deallocate (phs_data)
process_data%md5sum = "77777777777777777777777777777777"
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
phs_par%sqrts = 1000
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
phs_data%sqrts = phs_par%sqrts
phs_data%par%sqrts = phs_par%sqrts
end select
call phs_data%compute_md5sum ()
write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
phs_data%md5sum_process, "'"
write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
phs_data%md5sum_model_par, "'"
write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
phs_data%md5sum_phs_config, "'"
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%read_phs_file (exist, found, match)
write (u, "(1x,A,L1)") "exist = ", exist
write (u, "(1x,A,L1)") "found = ", found
write (u, "(1x,A,L1)") "match = ", match
end select
write (u, "(A)")
write (u, "(A)") "* Modify phs parameter and check MD5 sum"
write (u, "(A)")
call phs_data%final ()
deallocate (phs_data)
allocate (phs_wood_config_t :: phs_data)
process_data%md5sum = "1234567890abcdef1234567890abcdef"
call phs_data%init (process_data, model)
phs_par%sqrts = 1000
phs_par%off_shell = 17
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
phs_data%sqrts = phs_par%sqrts
phs_data%par%sqrts = phs_par%sqrts
end select
call phs_data%compute_md5sum ()
write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
phs_data%md5sum_process, "'"
write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
phs_data%md5sum_model_par, "'"
write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
phs_data%md5sum_phs_config, "'"
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%read_phs_file (exist, found, match)
write (u, "(1x,A,L1)") "exist = ", exist
write (u, "(1x,A,L1)") "found = ", found
write (u, "(1x,A,L1)") "match = ", match
end select
write (u, "(A)")
write (u, "(A)") "* Modify model parameter and check MD5 sum"
write (u, "(A)")
call phs_data%final ()
deallocate (phs_data)
allocate (phs_wood_config_t :: phs_data)
call model%set_par (var_str ("ms"), 100._default)
call phs_data%init (process_data, model)
phs_par%sqrts = 1000
phs_par%off_shell = 1
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_parameters (phs_par)
phs_data%sqrts = phs_par%sqrts
phs_data%par%sqrts = phs_par%sqrts
end select
call phs_data%compute_md5sum ()
write (u, "(1x,A,A,A)") "MD5 sum (process) = '", &
phs_data%md5sum_process, "'"
write (u, "(1x,A,A,A)") "MD5 sum (model par) = '", &
phs_data%md5sum_model_par, "'"
write (u, "(1x,A,A,A)") "MD5 sum (phs config) = '", &
phs_data%md5sum_phs_config, "'"
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%read_phs_file (exist, found, match)
write (u, "(1x,A,L1)") "exist = ", exist
write (u, "(1x,A,L1)") "found = ", found
write (u, "(1x,A,L1)") "match = ", match
end select
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_wood_6"
end subroutine phs_wood_6
@ %def phs_wood_6
@
<<PHS wood: execute vis tests>>=
call test (phs_wood_vis_1, "phs_wood_vis_1", &
"visualizing phase space channels", &
u, results)
<<PHS wood: test declarations>>=
public :: phs_wood_vis_1
<<PHS wood: tests>>=
subroutine phs_wood_vis_1 (u)
integer, intent(in) :: u
type(os_data_t) :: os_data
type(model_data_t), target :: model
type(process_constants_t) :: process_data
class(phs_config_t), allocatable :: phs_data
type(mapping_defaults_t) :: mapping_defaults
type(string_t) :: vis_file, pdf_file, ps_file
real(default) :: sqrts
logical :: exist, exist_pdf, exist_ps
integer :: u_phs, iostat, u_vis
character(95) :: buffer
write (u, "(A)") "* Test output: phs_wood_vis_1"
write (u, "(A)") "* Purpose: visualizing the &
&phase-space configuration"
write (u, "(A)")
call os_data%init ()
call model%init_test ()
call syntax_phs_forest_init ()
write (u, "(A)") "* Initialize a process"
write (u, "(A)")
call init_test_process_data (var_str ("phs_wood_vis_1"), process_data)
write (u, "(A)") "* Create a scratch phase-space file"
write (u, "(A)")
u_phs = free_unit ()
open (u_phs, status = "scratch", action = "readwrite")
call write_test_phs_file (u_phs, var_str ("phs_wood_vis_1"))
rewind (u_phs)
do
read (u_phs, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
write (u, "(A)")
write (u, "(A)") "* Setup phase-space configuration object"
write (u, "(A)")
mapping_defaults%step_mapping = .false.
allocate (phs_wood_config_t :: phs_data)
call phs_data%init (process_data, model)
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%set_input (u_phs)
call phs_data%set_mapping_defaults (mapping_defaults)
phs_data%os_data = os_data
phs_data%io_unit = 0
phs_data%io_unit_keep_open = .true.
phs_data%vis_channels = .true.
end select
sqrts = 1000._default
call phs_data%configure (sqrts)
call phs_data%write (u)
write (u, "(A)")
select type (phs_data)
type is (phs_wood_config_t)
call phs_data%write_forest (u)
end select
vis_file = "phs_wood_vis_1.phs-vis.tex"
ps_file = "phs_wood_vis_1.phs-vis.ps"
pdf_file = "phs_wood_vis_1.phs-vis.pdf"
inquire (file = char (vis_file), exist = exist)
if (exist) then
u_vis = free_unit ()
open (u_vis, file = char (vis_file), action = "read", status = "old")
iostat = 0
do while (iostat == 0)
read (u_vis, "(A)", iostat = iostat) buffer
if (iostat == 0) write (u, "(A)") trim (buffer)
end do
close (u_vis)
else
write (u, "(A)") "[Visualize LaTeX file is missing]"
end if
inquire (file = char (ps_file), exist = exist_ps)
if (exist_ps) then
write (u, "(A)") "[Visualize Postscript file exists and is nonempty]"
else
write (u, "(A)") "[Visualize Postscript file is missing/non-regular]"
end if
inquire (file = char (pdf_file), exist = exist_pdf)
if (exist_pdf) then
write (u, "(A)") "[Visualize PDF file exists and is nonempty]"
else
write (u, "(A)") "[Visualize PDF file is missing/non-regular]"
end if
write (u, "(A)")
write (u, "(A)") "* Cleanup"
close (u_phs)
call phs_data%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_wood_vis_1"
end subroutine phs_wood_vis_1
@ %def phs_wood_vis_1
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{The FKS phase space}
<<[[phs_fks.f90]]>>=
<<File header>>
module phs_fks
<<Use kinds>>
<<Use strings>>
use constants
use lorentz
use phs_points
use models, only: model_t
use phs_base
use resonances, only: resonance_contributors_t, resonance_history_t
use phs_wood
<<Standard module head>>
<<PHS fks: public>>
<<PHS fks: parameters>>
<<PHS fks: types>>
interface
<<PHS fks: sub interfaces>>
end interface
contains
<<PHS fks: main procedures>>
end module phs_fks
@ %def phs_fks
@
<<[[phs_fks_sub.f90]]>>=
<<File header>>
submodule (phs_fks) phs_fks_s
<<Use debug>>
use diagnostics
use io_units, only: given_output_unit, free_unit
use format_defs, only: FMT_17
use format_utils, only: write_separator
use physics_defs
use flavors
use pdg_arrays, only: is_colored
use cascades
use cascades2
use ttv_formfactors, only: generate_on_shell_decay_threshold, m1s_to_mpole
!!! Intel oneAPI 2022/23 regression workaround
use resonances, only: resonance_history_t
use resonances, only: resonance_contributors_t
implicit none
<<PHS fks: interfaces>>
contains
<<PHS fks: procedures>>
end submodule phs_fks_s
@ %def phs_fks_s
@ A container for the $x_\oplus$- and $x_\ominus$-values for initial-state
phase spaces.
<<PHS fks: public>>=
public :: isr_kinematics_t
<<PHS fks: types>>=
type :: isr_kinematics_t
integer :: n_in
real(default), dimension(2) :: x = one
real(default), dimension(2) :: z = zero
real(default) :: sqrts_born = zero
real(default), dimension(:), allocatable :: beam_energy
real(default) :: fac_scale = zero
real(default), dimension(2) :: jacobian = one
integer :: isr_mode = SQRTS_FIXED
contains
<<PHS fks: isr kinematics: TBP>>
end type isr_kinematics_t
@ %def type isr_kinematics_t
@
<<PHS fks: isr kinematics: TBP>>=
procedure :: write => isr_kinematics_write
<<PHS fks: sub interfaces>>=
module subroutine isr_kinematics_write (isr, unit)
class(isr_kinematics_t), intent(in) :: isr
integer, intent(in), optional :: unit
end subroutine isr_kinematics_write
<<PHS fks: procedures>>=
module subroutine isr_kinematics_write (isr, unit)
class(isr_kinematics_t), intent(in) :: isr
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u,"(A)") "ISR kinematics: "
write (u,"(A," // FMT_17 // ",1X)") "x(+): ", isr%x(1)
write (u,"(A," // FMT_17 // ",1X)") "x(-): ", isr%x(2)
write (u,"(A," // FMT_17 // ",1X)") "z(+): ", isr%z(1)
write (u,"(A," // FMT_17 // ",1X)") "z(-): ", isr%z(2)
write (u,"(A," // FMT_17 // ",1X)") "sqrts (Born): ", isr%sqrts_born
if (allocated (isr%beam_energy)) then
do i = 1, size (isr%beam_energy)
write (u,"(A," // FMT_17 // ",1X)") "Beam energy: ", &
isr%beam_energy(i)
end do
end if
write (u,"(A," // FMT_17 // ",1X)") "Fac. scale: ", isr%fac_scale
do i = 1, 2
write (u,"(A," // FMT_17 // ",1X)") "Jacobian: ", isr%jacobian(i)
end do
write (u,"(A,I0,1X)") "ISR mode: ", isr%isr_mode
end subroutine isr_kinematics_write
@ %def isr_kinematics_write
@
<<PHS fks: public>>=
public :: phs_point_set_t
<<PHS fks: types>>=
type :: phs_point_set_t
type(phs_point_t), dimension(:), allocatable :: phs_point
logical :: initialized = .false.
contains
<<PHS fks: phs point set: TBP>>
end type phs_point_set_t
@ %def phs_point_set_t
@
<<PHS fks: phs point set: TBP>>=
procedure :: init => phs_point_set_init
<<PHS fks: sub interfaces>>=
module subroutine phs_point_set_init (phs_point_set, n_particles, n_phs)
class(phs_point_set_t), intent(out) :: phs_point_set
integer, intent(in) :: n_particles, n_phs
end subroutine phs_point_set_init
<<PHS fks: procedures>>=
module subroutine phs_point_set_init (phs_point_set, n_particles, n_phs)
class(phs_point_set_t), intent(out) :: phs_point_set
integer, intent(in) :: n_particles, n_phs
integer :: i_phs
allocate (phs_point_set%phs_point (n_phs))
do i_phs = 1, n_phs
phs_point_set%phs_point(i_phs) = n_particles
end do
phs_point_set%initialized = .true.
end subroutine phs_point_set_init
@ %def phs_point_set_init
@
<<PHS fks: phs point set: TBP>>=
procedure :: write => phs_point_set_write
<<PHS fks: sub interfaces>>=
module subroutine phs_point_set_write (phs_point_set, i_phs, contributors, &
unit, show_mass, testflag, check_conservation, ultra, n_in)
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in), optional :: i_phs
integer, intent(in), dimension(:), optional :: contributors
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_mass
logical, intent(in), optional :: testflag, ultra
logical, intent(in), optional :: check_conservation
integer, intent(in), optional :: n_in
end subroutine phs_point_set_write
<<PHS fks: procedures>>=
module subroutine phs_point_set_write (phs_point_set, i_phs, contributors, &
unit, show_mass, testflag, check_conservation, ultra, n_in)
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in), optional :: i_phs
integer, intent(in), dimension(:), optional :: contributors
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_mass
logical, intent(in), optional :: testflag, ultra
logical, intent(in), optional :: check_conservation
integer, intent(in), optional :: n_in
integer :: i, u
type(vector4_t) :: p_sum
u = given_output_unit (unit); if (u < 0) return
if (present (i_phs)) then
call phs_point_set%phs_point(i_phs)%write &
(unit = u, show_mass = show_mass, testflag = testflag, &
check_conservation = check_conservation, ultra = ultra, n_in = n_in)
else
do i = 1, size(phs_point_set%phs_point)
call phs_point_set%phs_point(i)%write &
(unit = u, show_mass = show_mass, testflag = testflag, &
check_conservation = check_conservation, ultra = ultra,&
n_in = n_in)
end do
end if
if (present (contributors)) then
if (debug_on) call msg_debug &
(D_SUBTRACTION, "Invariant masses for real emission: ")
associate (pp => phs_point_set%phs_point(i_phs))
p_sum = sum (pp, [contributors, size (pp)])
end associate
if (debug_active (D_SUBTRACTION)) &
call vector4_write (p_sum, unit = unit, show_mass = show_mass, &
testflag = testflag, ultra = ultra)
end if
end subroutine phs_point_set_write
@ %def phs_point_set_write
@
<<PHS fks: phs point set: TBP>>=
procedure :: get_n_momenta => phs_point_set_get_n_momenta
<<PHS fks: sub interfaces>>=
elemental module function phs_point_set_get_n_momenta &
(phs_point_set, i_res) result (n)
integer :: n
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_res
end function phs_point_set_get_n_momenta
<<PHS fks: procedures>>=
elemental module function phs_point_set_get_n_momenta &
(phs_point_set, i_res) result (n)
integer :: n
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_res
n = size (phs_point_set%phs_point(i_res))
end function phs_point_set_get_n_momenta
@ %def phs_point_set_get_n_momenta
@
<<PHS fks: phs point set: TBP>>=
procedure :: get_momenta => phs_point_set_get_momenta
<<PHS fks: sub interfaces>>=
pure module function phs_point_set_get_momenta &
(phs_point_set, i_phs, n_in) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs
integer, intent(in), optional :: n_in
end function phs_point_set_get_momenta
<<PHS fks: procedures>>=
pure module function phs_point_set_get_momenta &
(phs_point_set, i_phs, n_in) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs
integer, intent(in), optional :: n_in
integer :: i
if (present (n_in)) then
p = phs_point_set%phs_point(i_phs)%select ([(i, i=1, n_in)])
else
p = phs_point_set%phs_point(i_phs)
end if
end function phs_point_set_get_momenta
@ %def phs_point_set_get_momenta
@
<<PHS fks: phs point set: TBP>>=
procedure :: get_momentum => phs_point_set_get_momentum
<<PHS fks: sub interfaces>>=
pure module function phs_point_set_get_momentum &
(phs_point_set, i_phs, i_mom) result (p)
type(vector4_t) :: p
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs, i_mom
end function phs_point_set_get_momentum
<<PHS fks: procedures>>=
pure module function phs_point_set_get_momentum &
(phs_point_set, i_phs, i_mom) result (p)
type(vector4_t) :: p
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs, i_mom
p = phs_point_set%phs_point(i_phs)%select (i_mom)
end function phs_point_set_get_momentum
@ %def phs_point_set_get_momentum
@
<<PHS fks: phs point set: TBP>>=
procedure :: get_energy => phs_point_set_get_energy
<<PHS fks: sub interfaces>>=
pure module function phs_point_set_get_energy &
(phs_point_set, i_phs, i_mom) result (E)
real(default) :: E
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs, i_mom
end function phs_point_set_get_energy
<<PHS fks: procedures>>=
pure module function phs_point_set_get_energy &
(phs_point_set, i_phs, i_mom) result (E)
real(default) :: E
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs, i_mom
E = energy (phs_point_set%phs_point(i_phs)%select (i_mom))
end function phs_point_set_get_energy
@ %def phs_point_set_get_energy
@
<<PHS fks: phs point set: TBP>>=
procedure :: get_sqrts => phs_point_set_get_sqrts
<<PHS fks: sub interfaces>>=
module function phs_point_set_get_sqrts &
(phs_point_set, i_phs) result (sqrts)
real(default) :: sqrts
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs
end function phs_point_set_get_sqrts
<<PHS fks: procedures>>=
module function phs_point_set_get_sqrts &
(phs_point_set, i_phs) result (sqrts)
real(default) :: sqrts
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs
sqrts = sqrt (phs_point_set%phs_point(i_phs)%get_msq ([1,2]))
end function phs_point_set_get_sqrts
@ %def phs_point_set_get_sqrts
@
<<PHS fks: phs point set: TBP>>=
generic :: set_momenta => set_momenta_p, set_momenta_phs_point
procedure :: set_momenta_p => phs_point_set_set_momenta_p
<<PHS fks: sub interfaces>>=
module subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p)
class(phs_point_set_t), intent(inout) :: phs_point_set
integer, intent(in) :: i_phs
type(vector4_t), intent(in), dimension(:) :: p
end subroutine phs_point_set_set_momenta_p
<<PHS fks: procedures>>=
module subroutine phs_point_set_set_momenta_p (phs_point_set, i_phs, p)
class(phs_point_set_t), intent(inout) :: phs_point_set
integer, intent(in) :: i_phs
type(vector4_t), intent(in), dimension(:) :: p
phs_point_set%phs_point(i_phs) = p
end subroutine phs_point_set_set_momenta_p
@ %def phs_point_set_set_momenta_p
@
<<PHS fks: phs point set: TBP>>=
procedure :: set_momenta_phs_point => phs_point_set_set_momenta_phs_point
<<PHS fks: sub interfaces>>=
module subroutine phs_point_set_set_momenta_phs_point &
(phs_point_set, i_phs, p)
class(phs_point_set_t), intent(inout) :: phs_point_set
integer, intent(in) :: i_phs
type(phs_point_t), intent(in) :: p
end subroutine phs_point_set_set_momenta_phs_point
<<PHS fks: procedures>>=
module subroutine phs_point_set_set_momenta_phs_point &
(phs_point_set, i_phs, p)
class(phs_point_set_t), intent(inout) :: phs_point_set
integer, intent(in) :: i_phs
type(phs_point_t), intent(in) :: p
phs_point_set%phs_point(i_phs) = p
end subroutine phs_point_set_set_momenta_phs_point
@ %def phs_point_set_set_momenta_phs_point
@
<<PHS fks: phs point set: TBP>>=
procedure :: get_n_particles => phs_point_set_get_n_particles
<<PHS fks: sub interfaces>>=
module function phs_point_set_get_n_particles &
(phs_point_set, i) result (n_particles)
integer :: n_particles
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in), optional :: i
end function phs_point_set_get_n_particles
<<PHS fks: procedures>>=
module function phs_point_set_get_n_particles &
(phs_point_set, i) result (n_particles)
integer :: n_particles
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in), optional :: i
integer :: j
j = 1; if (present (i)) j = i
n_particles = size (phs_point_set%phs_point(j))
end function phs_point_set_get_n_particles
@ %def phs_point_set_get_n_particles
@
<<PHS fks: phs point set: TBP>>=
procedure :: get_n_phs => phs_point_set_get_n_phs
<<PHS fks: sub interfaces>>=
module function phs_point_set_get_n_phs (phs_point_set) result (n_phs)
integer :: n_phs
class(phs_point_set_t), intent(in) :: phs_point_set
end function phs_point_set_get_n_phs
<<PHS fks: procedures>>=
module function phs_point_set_get_n_phs (phs_point_set) result (n_phs)
integer :: n_phs
class(phs_point_set_t), intent(in) :: phs_point_set
n_phs = size (phs_point_set%phs_point)
end function phs_point_set_get_n_phs
@ %def phs_point_set_get_n_phs
@
<<PHS fks: phs point set: TBP>>=
procedure :: get_invariant_mass => phs_point_set_get_invariant_mass
<<PHS fks: sub interfaces>>=
module function phs_point_set_get_invariant_mass &
(phs_point_set, i_phs, i_part) result (m2)
real(default) :: m2
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs
integer, intent(in), dimension(:) :: i_part
end function phs_point_set_get_invariant_mass
<<PHS fks: procedures>>=
module function phs_point_set_get_invariant_mass &
(phs_point_set, i_phs, i_part) result (m2)
real(default) :: m2
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs
integer, intent(in), dimension(:) :: i_part
m2 = phs_point_set%phs_point(i_phs)%get_msq (i_part)
end function phs_point_set_get_invariant_mass
@ %def phs_point_set_get_invariant_mass
@
<<PHS fks: phs point set: TBP>>=
procedure :: write_phs_point => phs_point_set_write_phs_point
<<PHS fks: sub interfaces>>=
module subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, &
unit, show_mass, testflag, check_conservation, ultra, n_in)
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_mass
logical, intent(in), optional :: testflag, ultra
logical, intent(in), optional :: check_conservation
integer, intent(in), optional :: n_in
end subroutine phs_point_set_write_phs_point
<<PHS fks: procedures>>=
module subroutine phs_point_set_write_phs_point (phs_point_set, i_phs, &
unit, show_mass, testflag, check_conservation, ultra, n_in)
class(phs_point_set_t), intent(in) :: phs_point_set
integer, intent(in) :: i_phs
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_mass
logical, intent(in), optional :: testflag, ultra
logical, intent(in), optional :: check_conservation
integer, intent(in), optional :: n_in
call phs_point_set%phs_point(i_phs)%write (unit, show_mass, testflag, &
check_conservation, ultra, n_in)
end subroutine phs_point_set_write_phs_point
@ %def phs_point_set_write_phs_point
@
<<PHS fks: phs point set: TBP>>=
procedure :: final => phs_point_set_final
<<PHS fks: sub interfaces>>=
module subroutine phs_point_set_final (phs_point_set)
class(phs_point_set_t), intent(inout) :: phs_point_set
end subroutine phs_point_set_final
<<PHS fks: procedures>>=
module subroutine phs_point_set_final (phs_point_set)
class(phs_point_set_t), intent(inout) :: phs_point_set
integer :: i
deallocate (phs_point_set%phs_point)
phs_point_set%initialized = .false.
end subroutine phs_point_set_final
@ %def phs_point_set_final
@
<<PHS fks: public>>=
public :: real_jacobian_t
<<PHS fks: types>>=
type :: real_jacobian_t
real(default), dimension(4) :: jac = 1._default
end type real_jacobian_t
@ %def real_jacobian_t
@
<<PHS fks: public>>=
public :: real_kinematics_t
<<PHS fks: types>>=
type :: real_kinematics_t
logical :: supply_xi_max = .true.
real(default) :: xi_tilde
real(default) :: phi
real(default), dimension(:), allocatable :: xi_max, y
real(default) :: xi_mismatch, y_mismatch
type(real_jacobian_t), dimension(:), allocatable :: jac
real(default) :: jac_mismatch
type(phs_point_set_t) :: p_born_cms
type(phs_point_set_t) :: p_born_lab
type(phs_point_set_t) :: p_real_cms
type(phs_point_set_t) :: p_real_lab
type(phs_point_set_t) :: p_born_onshell
type(phs_point_set_t), dimension(2) :: p_real_onshell
integer, dimension(:), allocatable :: alr_to_i_phs
real(default), dimension(3) :: x_rad
real(default), dimension(:), allocatable :: jac_rand
real(default), dimension(:), allocatable :: y_soft
real(default) :: cms_energy2
type(vector4_t), dimension(:), allocatable :: xi_ref_momenta
contains
<<PHS fks: real kinematics: TBP>>
end type real_kinematics_t
@ %def real_kinematics_t
@
<<PHS fks: real kinematics: TBP>>=
procedure :: init => real_kinematics_init
<<PHS fks: sub interfaces>>=
module subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr)
class(real_kinematics_t), intent(inout) :: r
integer, intent(in) :: n_tot, n_phs, n_alr, n_contr
end subroutine real_kinematics_init
<<PHS fks: procedures>>=
module subroutine real_kinematics_init (r, n_tot, n_phs, n_alr, n_contr)
class(real_kinematics_t), intent(inout) :: r
integer, intent(in) :: n_tot, n_phs, n_alr, n_contr
allocate (r%xi_max (n_phs))
allocate (r%y (n_phs))
allocate (r%y_soft (n_phs))
call r%p_born_cms%init (n_tot - 1, 1)
call r%p_born_lab%init (n_tot - 1, 1)
call r%p_real_cms%init (n_tot, n_phs)
call r%p_real_lab%init (n_tot, n_phs)
allocate (r%jac (n_phs), r%jac_rand (n_phs))
allocate (r%alr_to_i_phs (n_alr))
allocate (r%xi_ref_momenta (n_contr))
r%alr_to_i_phs = 0
r%xi_tilde = zero; r%xi_mismatch = zero
r%xi_max = zero
r%y = zero; r%y_mismatch = zero
r%y_soft = zero
r%phi = zero
r%cms_energy2 = zero
r%xi_ref_momenta = vector4_null
r%jac_mismatch = one
r%jac_rand = one
end subroutine real_kinematics_init
@ %def real_kinematics_init
@
<<PHS fks: real kinematics: TBP>>=
procedure :: init_onshell => real_kinematics_init_onshell
<<PHS fks: sub interfaces>>=
module subroutine real_kinematics_init_onshell (r, n_tot, n_phs)
class(real_kinematics_t), intent(inout) :: r
integer, intent(in) :: n_tot, n_phs
end subroutine real_kinematics_init_onshell
<<PHS fks: procedures>>=
module subroutine real_kinematics_init_onshell (r, n_tot, n_phs)
class(real_kinematics_t), intent(inout) :: r
integer, intent(in) :: n_tot, n_phs
call r%p_born_onshell%init (n_tot - 1, 1)
call r%p_real_onshell(1)%init (n_tot, n_phs)
call r%p_real_onshell(2)%init (n_tot, n_phs)
end subroutine real_kinematics_init_onshell
@ %def real_kinematics_init_onshell
@
<<PHS fks: real kinematics: TBP>>=
procedure :: write => real_kinematics_write
<<PHS fks: sub interfaces>>=
module subroutine real_kinematics_write (r, unit)
class(real_kinematics_t), intent(in) :: r
integer, intent(in), optional :: unit
end subroutine real_kinematics_write
<<PHS fks: procedures>>=
module subroutine real_kinematics_write (r, unit)
class(real_kinematics_t), intent(in) :: r
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u,"(A)") "Real kinematics: "
write (u,"(A," // FMT_17 // ",1X)") "xi_tilde: ", r%xi_tilde
write (u,"(A," // FMT_17 // ",1X)") "phi: ", r%phi
do i = 1, size (r%xi_max)
write (u,"(A,I1,1X)") "i_phs: ", i
write (u,"(A," // FMT_17 // ",1X)") "xi_max: ", r%xi_max(i)
write (u,"(A," // FMT_17 // ",1X)") "y: ", r%y(i)
write (u,"(A," // FMT_17 // ",1X)") "jac_rand: ", r%jac_rand(i)
write (u,"(A," // FMT_17 // ",1X)") "y_soft: ", r%y_soft(i)
end do
write (u, "(A)") "Born Momenta: "
write (u, "(A)") "CMS: "
call r%p_born_cms%write (unit = u)
write (u, "(A)") "Lab: "
call r%p_born_lab%write (unit = u)
write (u, "(A)") "Real Momenta: "
write (u, "(A)") "CMS: "
call r%p_real_cms%write (unit = u)
write (u, "(A)") "Lab: "
call r%p_real_lab%write (unit = u)
end subroutine real_kinematics_write
@ %def real_kinematics_write
@ The boost to the center-of-mass system only has a reasonable meaning
above the threshold. Below the threshold, we do not apply boost at all, so
that the top quarks stay in the rest frame. However, with top quarks exactly
at rest, problems arise in the matrix elements (e.g. in the computation
of angles). Therefore, we apply a boost which is not exactly 1, but has a
tiny value differing from that.
<<PHS fks: public>>=
public :: get_boost_for_threshold_projection
<<PHS fks: sub interfaces>>=
module function get_boost_for_threshold_projection &
(p, sqrts, mtop) result (L)
type(lorentz_transformation_t) :: L
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: sqrts, mtop
end function get_boost_for_threshold_projection
<<PHS fks: procedures>>=
module function get_boost_for_threshold_projection &
(p, sqrts, mtop) result (L)
type(lorentz_transformation_t) :: L
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(in) :: sqrts, mtop
type(vector4_t) :: p_tmp
type(vector3_t) :: dir
real(default) :: scale_factor, arg
p_tmp = p(THR_POS_WP) + p(THR_POS_B)
arg = sqrts**2 - four * mtop**2
if (arg > zero) then
scale_factor = sqrt (arg) / two
else
scale_factor = tiny_07*1000
end if
dir = scale_factor * create_unit_vector (p_tmp)
p_tmp = [sqrts / two, dir%p]
L = boost (p_tmp, mtop)
end function get_boost_for_threshold_projection
@ %def get_boost_for_threshold_projection
-@ This routine recomputes the value of $\phi$ used to generate the real phase space.
-<<PHS fks: procedures>>=
- function get_generation_phi (p_born, p_real, emitter, i_gluon) result (phi)
- real(default) :: phi
- type(vector4_t), intent(in), dimension(:) :: p_born, p_real
- integer, intent(in) :: emitter, i_gluon
- type(vector4_t) :: p1, p2, pp
- type(lorentz_transformation_t) :: rot_to_gluon, rot_to_z
- type(vector3_t) :: dir, z
- real(default) :: cpsi
- pp = p_real(emitter) + p_real(i_gluon)
- cpsi = (space_part_norm (pp)**2 - space_part_norm (p_real(emitter))**2 &
- + space_part_norm (p_real(i_gluon))**2) / &
- (two * space_part_norm (pp) * space_part_norm (p_real(i_gluon)))
- dir = create_orthogonal (space_part (p_born(emitter)))
- rot_to_gluon = rotation (cpsi, sqrt (one - cpsi**2), dir)
- pp = rot_to_gluon * p_born(emitter)
- z%p = [0._default, 0._default, 1._default]
- rot_to_z = rotation_to_2nd &
- (space_part (p_born(emitter)) / space_part_norm (p_born(emitter)), z)
- p1 = rot_to_z * pp / space_part_norm (pp)
- p2 = rot_to_z * p_real(i_gluon)
- phi = azimuthal_distance (p1, p2)
- if (phi < zero) phi = twopi - abs(phi)
- end function get_generation_phi
-
-@ %def get_generation_phi
@
<<PHS fks: real kinematics: TBP>>=
procedure :: apply_threshold_projection_real => &
real_kinematics_apply_threshold_projection_real
<<PHS fks: sub interfaces>>=
module subroutine real_kinematics_apply_threshold_projection_real &
(r, i_phs, mtop, L_to_cms, invert)
class(real_kinematics_t), intent(inout) :: r
integer, intent(in) :: i_phs
real(default), intent(in) :: mtop
type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms
logical, intent(in) :: invert
end subroutine real_kinematics_apply_threshold_projection_real
<<PHS fks: procedures>>=
module subroutine real_kinematics_apply_threshold_projection_real &
(r, i_phs, mtop, L_to_cms, invert)
class(real_kinematics_t), intent(inout) :: r
integer, intent(in) :: i_phs
real(default), intent(in) :: mtop
type(lorentz_transformation_t), intent(in), dimension(:) :: L_to_cms
logical, intent(in) :: invert
integer :: leg, other_leg
type(vector4_t), dimension(:), allocatable :: p_real
type(vector4_t), dimension(:), allocatable :: p_real_onshell
type(vector4_t), dimension(4) :: k_tmp
type(vector4_t), dimension(4) :: k_decay_onshell_real
type(vector4_t), dimension(3) :: k_decay_onshell_born
do leg = 1, 2
other_leg = 3 - leg
p_real = r%p_real_cms%phs_point(i_phs)
allocate (p_real_onshell (size (p_real)))
p_real_onshell(1:2) = p_real(1:2)
k_tmp(1) = p_real(7)
k_tmp(2) = p_real(ass_quark(leg))
k_tmp(3) = p_real(ass_boson(leg))
k_tmp(4) = [mtop, zero, zero, zero]
call generate_on_shell_decay_threshold (k_tmp(1:3), &
k_tmp(4), k_decay_onshell_real (2:4))
k_decay_onshell_real (1) = k_tmp(4)
k_tmp(1) = p_real(ass_quark(other_leg))
k_tmp(2) = p_real(ass_boson(other_leg))
k_decay_onshell_born = create_two_particle_decay (mtop**2, k_tmp(1), k_tmp(2))
p_real_onshell(THR_POS_GLUON) = L_to_cms(leg) * k_decay_onshell_real (2)
p_real_onshell(ass_quark(leg)) = L_to_cms(leg) * k_decay_onshell_real(3)
p_real_onshell(ass_boson(leg)) = L_to_cms(leg) * k_decay_onshell_real(4)
p_real_onshell(ass_quark(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (2)
p_real_onshell(ass_boson(other_leg)) = L_to_cms(leg) * k_decay_onshell_born (3)
if (invert) then
call vector4_invert_direction (p_real_onshell (ass_quark(other_leg)))
call vector4_invert_direction (p_real_onshell (ass_boson(other_leg)))
end if
r%p_real_onshell(leg)%phs_point(i_phs) = p_real_onshell
deallocate (p_real_onshell)
end do
end subroutine real_kinematics_apply_threshold_projection_real
@ %def real_kinematics_apply_threshold_projection_real
@
<<PHS fks: public>>=
public :: threshold_projection_born
<<PHS fks: sub interfaces>>=
module subroutine threshold_projection_born &
(mtop, L_to_cms, p_in, p_onshell)
real(default), intent(in) :: mtop
type(lorentz_transformation_t), intent(in) :: L_to_cms
type(vector4_t), intent(in), dimension(:) :: p_in
type(vector4_t), intent(out), dimension(:) :: p_onshell
end subroutine threshold_projection_born
<<PHS fks: procedures>>=
module subroutine threshold_projection_born &
(mtop, L_to_cms, p_in, p_onshell)
real(default), intent(in) :: mtop
type(lorentz_transformation_t), intent(in) :: L_to_cms
type(vector4_t), intent(in), dimension(:) :: p_in
type(vector4_t), intent(out), dimension(:) :: p_onshell
type(vector4_t), dimension(3) :: k_decay_onshell
type(vector4_t) :: p_tmp_1, p_tmp_2
type(lorentz_transformation_t) :: L_to_cms_inv
p_onshell(1:2) = p_in(1:2)
L_to_cms_inv = inverse (L_to_cms)
p_tmp_1 = L_to_cms_inv * p_in(THR_POS_B)
p_tmp_2 = L_to_cms_inv * p_in(THR_POS_WP)
k_decay_onshell = create_two_particle_decay (mtop**2, &
p_tmp_1, p_tmp_2)
p_onshell([THR_POS_B, THR_POS_WP]) = k_decay_onshell([2, 3])
p_tmp_1 = L_to_cms * p_in(THR_POS_BBAR)
p_tmp_2 = L_to_cms * p_in(THR_POS_WM)
k_decay_onshell = create_two_particle_decay (mtop**2, &
p_tmp_1, p_tmp_2)
p_onshell([THR_POS_BBAR, THR_POS_WM]) = k_decay_onshell([2, 3])
p_onshell([THR_POS_WP, THR_POS_B]) = L_to_cms * p_onshell([THR_POS_WP, THR_POS_B])
p_onshell([THR_POS_WM, THR_POS_BBAR]) = L_to_cms_inv * p_onshell([THR_POS_WM, THR_POS_BBAR])
end subroutine threshold_projection_born
@ %def threshold_projection_born
@ This routine computes the bounds of the Dalitz region for massive emitters.
The corresponding derivation can be found in [[1202.0465]], App. A.
It is also used for the POWHEG matching so the routine is public.
The input parameter [[m2]] corresponds to the squared mass of the emitter.
<<PHS fks: public>>=
public :: compute_dalitz_bounds
<<PHS fks: sub interfaces>>=
pure module subroutine compute_dalitz_bounds &
(q0, m2, mrec2, z1, z2, k0_rec_max)
real(default), intent(in) :: q0, m2, mrec2
real(default), intent(out) :: z1, z2, k0_rec_max
end subroutine compute_dalitz_bounds
<<PHS fks: procedures>>=
pure module subroutine compute_dalitz_bounds &
(q0, m2, mrec2, z1, z2, k0_rec_max)
real(default), intent(in) :: q0, m2, mrec2
real(default), intent(out) :: z1, z2, k0_rec_max
k0_rec_max = (q0**2 - m2 + mrec2) / (two * q0)
z1 = (k0_rec_max + sqrt(k0_rec_max**2 - mrec2)) / q0
z2 = (k0_rec_max - sqrt(k0_rec_max**2 - mrec2)) / q0
end subroutine compute_dalitz_bounds
@ %def compute_dalitz_bounds
@ Compute the [[kt2]] of a given emitter
<<PHS fks: real kinematics: TBP>>=
procedure :: kt2 => real_kinematics_kt2
<<PHS fks: sub interfaces>>=
module function real_kinematics_kt2 &
(real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2)
real(default) :: kt2
class(real_kinematics_t), intent(in) :: real_kinematics
integer, intent(in) :: emitter, i_phs, kt2_type
real(default), intent(in), optional :: xi, y
end function real_kinematics_kt2
<<PHS fks: procedures>>=
module function real_kinematics_kt2 &
(real_kinematics, i_phs, emitter, kt2_type, xi, y) result (kt2)
real(default) :: kt2
class(real_kinematics_t), intent(in) :: real_kinematics
integer, intent(in) :: emitter, i_phs, kt2_type
real(default), intent(in), optional :: xi, y
real(default) :: xii, yy
real(default) :: q, E_em, z, z1, z2, m2, mrec2, k0_rec_max
type(vector4_t) :: p_emitter
if (present (y)) then
yy = y
else
yy = real_kinematics%y (i_phs)
end if
if (present (xi)) then
xii = xi
else
xii = real_kinematics%xi_tilde * real_kinematics%xi_max (i_phs)
end if
select case (kt2_type)
case (UBF_FSR_SIMPLE)
kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy)
case (UBF_FSR_MASSIVE)
q = sqrt (real_kinematics%cms_energy2)
p_emitter = real_kinematics%p_born_cms%phs_point(1)%select (emitter)
mrec2 = (q - p_emitter%p(0))**2 - sum (p_emitter%p(1:3)**2)
m2 = p_emitter**2
E_em = energy (p_emitter)
call compute_dalitz_bounds (q, m2, mrec2, z1, z2, k0_rec_max)
z = z2 - (z2 - z1) * (one + yy) / two
kt2 = xii**2 * q**3 * (one - z) / &
(two * E_em - z * xii * q)
case (UBF_FSR_MASSLESS_RECOIL)
kt2 = real_kinematics%cms_energy2 / two * xii**2 * (1 - yy**2) / two
case (UBF_ISR)
kt2 = real_kinematics%cms_energy2 / four * xii**2 * (1 - yy**2) / (1 - xii)
case default
kt2 = zero
call msg_bug ("kt2_type must be set to a known value")
end select
end function real_kinematics_kt2
@ %def real_kinematics_kt2
@ These are the possible values for [[upper_bound_func_type]] and will be
used to decide which UBF object is allocated and which $K_T$ scale for the
matching is computed.
<<PHS fks: parameters>>=
integer, parameter, public :: UBF_FSR_SIMPLE = 1
integer, parameter, public :: UBF_FSR_MASSIVE = 2
integer, parameter, public :: UBF_FSR_MASSLESS_RECOIL = 3
integer, parameter, public :: UBF_ISR = 4
@ %def UBF_FSR_SIMPLE UBF_FSR_MASSIVE UBF_FSR_MASSLESS_RECOIL UBF_ISR
@
<<PHS fks: real kinematics: TBP>>=
procedure :: final => real_kinematics_final
<<PHS fks: sub interfaces>>=
module subroutine real_kinematics_final (real_kin)
class(real_kinematics_t), intent(inout) :: real_kin
end subroutine real_kinematics_final
<<PHS fks: procedures>>=
module subroutine real_kinematics_final (real_kin)
class(real_kinematics_t), intent(inout) :: real_kin
if (allocated (real_kin%xi_max)) deallocate (real_kin%xi_max)
if (allocated (real_kin%y)) deallocate (real_kin%y)
if (allocated (real_kin%alr_to_i_phs)) deallocate (real_kin%alr_to_i_phs)
if (allocated (real_kin%jac_rand)) deallocate (real_kin%jac_rand)
if (allocated (real_kin%y_soft)) deallocate (real_kin%y_soft)
if (allocated (real_kin%xi_ref_momenta)) &
deallocate (real_kin%xi_ref_momenta)
call real_kin%p_born_cms%final (); call real_kin%p_born_lab%final ()
call real_kin%p_real_cms%final (); call real_kin%p_real_lab%final ()
end subroutine real_kinematics_final
@ %def real_kinematics_final
@
<<PHS fks: parameters>>=
integer, parameter, public :: I_XI = 1
integer, parameter, public :: I_Y = 2
integer, parameter, public :: I_PHI = 3
integer, parameter, public :: PHS_MODE_UNDEFINED = 0
integer, parameter, public :: PHS_MODE_ADDITIONAL_PARTICLE = 1
integer, parameter, public :: PHS_MODE_COLLINEAR_REMNANT = 2
@ %def parameters
@
<<PHS fks: public>>=
public :: phs_fks_config_t
<<PHS fks: types>>=
type, extends (phs_wood_config_t) :: phs_fks_config_t
integer :: mode = PHS_MODE_UNDEFINED
character(32) :: md5sum_born_config
logical :: born_2_to_1 = .false.
logical :: make_dalitz_plot = .false.
contains
<<PHS fks: fks config: TBP>>
end type phs_fks_config_t
@ %def phs_fks_config_t
@
<<PHS fks: fks config: TBP>>=
procedure :: clear_phase_space => fks_config_clear_phase_space
<<PHS fks: sub interfaces>>=
module subroutine fks_config_clear_phase_space (phs_config)
class(phs_fks_config_t), intent(inout) :: phs_config
end subroutine fks_config_clear_phase_space
<<PHS fks: procedures>>=
module subroutine fks_config_clear_phase_space (phs_config)
class(phs_fks_config_t), intent(inout) :: phs_config
end subroutine fks_config_clear_phase_space
@ %def fks_config_clear_phase_space
@
<<PHS fks: fks config: TBP>>=
procedure :: write => phs_fks_config_write
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_config_write (object, unit, include_id)
class(phs_fks_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
end subroutine phs_fks_config_write
<<PHS fks: procedures>>=
module subroutine phs_fks_config_write (object, unit, include_id)
class(phs_fks_config_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: include_id
integer :: u
u = given_output_unit (unit)
call object%phs_wood_config_t%write (u)
write (u, "(3x,A,I0)") "NLO mode = ", object%mode
write (u, "(3x,A,L1)") "2->1 proc = ", object%born_2_to_1
write (u, "(3x,A,L1)") "Dalitz = ", object%make_dalitz_plot
write (u, "(A,A)") "Extra Born md5sum: ", object%md5sum_born_config
end subroutine phs_fks_config_write
@ %def phs_fks_config_write
@
<<PHS fks: fks config: TBP>>=
procedure :: set_mode => phs_fks_config_set_mode
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_config_set_mode (phs_config, mode)
class(phs_fks_config_t), intent(inout) :: phs_config
integer, intent(in) :: mode
end subroutine phs_fks_config_set_mode
<<PHS fks: procedures>>=
module subroutine phs_fks_config_set_mode (phs_config, mode)
class(phs_fks_config_t), intent(inout) :: phs_config
integer, intent(in) :: mode
select case (mode)
case (NLO_REAL, NLO_MISMATCH)
phs_config%mode = PHS_MODE_ADDITIONAL_PARTICLE
case (NLO_DGLAP)
phs_config%mode = PHS_MODE_COLLINEAR_REMNANT
end select
end subroutine phs_fks_config_set_mode
@ %def phs_fks_config_set_mod
@
<<PHS fks: fks config: TBP>>=
procedure :: configure => phs_fks_config_configure
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_fks_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
end subroutine phs_fks_config_configure
<<PHS fks: procedures>>=
module subroutine phs_fks_config_configure (phs_config, sqrts, &
sqrts_fixed, lab_is_cm, azimuthal_dependence, rebuild, &
ignore_mismatch, nlo_type, subdir)
class(phs_fks_config_t), intent(inout) :: phs_config
real(default), intent(in) :: sqrts
logical, intent(in), optional :: sqrts_fixed
logical, intent(in), optional :: lab_is_cm
logical, intent(in), optional :: azimuthal_dependence
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: ignore_mismatch
integer, intent(in), optional :: nlo_type
type(string_t), intent(in), optional :: subdir
if (present (nlo_type)) phs_config%nlo_type = nlo_type
if (.not. phs_config%is_combined_integration) then
select case (phs_config%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
phs_config%n_par = phs_config%n_par + 3
if (phs_config%nlo_type == NLO_REAL .and. phs_config%n_out == 2) then
phs_config%born_2_to_1 = .true.
end if
case (PHS_MODE_COLLINEAR_REMNANT)
phs_config%n_par = phs_config%n_par + 1
end select
end if
call phs_config%compute_md5sum ()
end subroutine phs_fks_config_configure
@ %def phs_fks_config_configure
@
<<PHS fks: fks config: TBP>>=
procedure :: startup_message => phs_fks_config_startup_message
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_config_startup_message (phs_config, unit)
class(phs_fks_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
end subroutine phs_fks_config_startup_message
<<PHS fks: procedures>>=
module subroutine phs_fks_config_startup_message (phs_config, unit)
class(phs_fks_config_t), intent(in) :: phs_config
integer, intent(in), optional :: unit
call phs_config%phs_wood_config_t%startup_message (unit)
end subroutine phs_fks_config_startup_message
@ %def phs_fks_config_startup_message
@ Gfortran 7/8/9 bug, has to remain in the main module:
<<PHS fks: fks config: TBP>>=
procedure, nopass :: allocate_instance => phs_fks_config_allocate_instance
<<PHS fks: main procedures>>=
subroutine phs_fks_config_allocate_instance (phs)
class(phs_t), intent(inout), pointer :: phs
allocate (phs_fks_t :: phs)
end subroutine phs_fks_config_allocate_instance
@ %def phs_fks_config_allocate_instance
@ If the phase space is generated from file, but we want to have resonance
histories, we must force the cascade sets to be generated. However, it must
be assured that Born flavors are used for this.
<<PHS fks: fks config: TBP>>=
procedure :: generate_phase_space_extra => &
phs_fks_config_generate_phase_space_extra
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_config_generate_phase_space_extra (phs_config)
class(phs_fks_config_t), intent(inout) :: phs_config
end subroutine phs_fks_config_generate_phase_space_extra
<<PHS fks: procedures>>=
module subroutine phs_fks_config_generate_phase_space_extra (phs_config)
class(phs_fks_config_t), intent(inout) :: phs_config
integer :: off_shell, extra_off_shell
type(flavor_t), dimension(:,:), allocatable :: flv_born
integer :: i, j
integer :: n_state, n_flv_born
integer :: unit_fds
logical :: valid
type(string_t) :: file_name
logical :: file_exists
if (phs_config%use_cascades2) then
allocate (phs_config%feyngraph_set)
else
allocate (phs_config%cascade_set)
end if
n_flv_born = size (phs_config%flv, 1) - 1
n_state = size (phs_config%flv, 2)
allocate (flv_born (n_flv_born, n_state))
do i = 1, n_flv_born
do j = 1, n_state
flv_born(i, j) = phs_config%flv(i, j)
end do
end do
if (phs_config%use_cascades2) then
file_name = char (phs_config%id) // ".fds"
inquire (file=char (file_name), exist=file_exists)
if (.not. file_exists) call msg_fatal &
("The O'Mega input file " // char (file_name) // &
" does not exist. " // "Please make sure that the " // &
"variable ?omega_write_phs_output has been set correctly.")
unit_fds = free_unit ()
open (unit=unit_fds, file=char(file_name), status='old', action='read')
end if
off_shell = phs_config%par%off_shell
do extra_off_shell = 0, max (n_flv_born - 2, 0)
phs_config%par%off_shell = off_shell + extra_off_shell
if (phs_config%use_cascades2) then
call feyngraph_set_generate (phs_config%feyngraph_set, &
phs_config%model, phs_config%n_in, phs_config%n_out - 1, &
flv_born, phs_config%par, phs_config%fatal_beam_decay, unit_fds, &
phs_config%vis_channels)
if (feyngraph_set_is_valid (phs_config%feyngraph_set)) exit
else
call cascade_set_generate (phs_config%cascade_set, &
phs_config%model, phs_config%n_in, phs_config%n_out - 1, &
flv_born, phs_config%par, phs_config%fatal_beam_decay)
if (cascade_set_is_valid (phs_config%cascade_set)) exit
end if
end do
if (phs_config%use_cascades2) then
close (unit_fds)
valid = feyngraph_set_is_valid (phs_config%feyngraph_set)
else
valid = cascade_set_is_valid (phs_config%cascade_set)
end if
if (.not. valid) &
call msg_fatal ("Resonance extraction: Phase space generation failed")
end subroutine phs_fks_config_generate_phase_space_extra
@ %def phs_fks_config_generate_phase_space_extra
@
<<PHS fks: fks config: TBP>>=
procedure :: set_born_config => phs_fks_config_set_born_config
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born)
class(phs_fks_config_t), intent(inout) :: phs_config
type(phs_wood_config_t), intent(in), target :: phs_cfg_born
end subroutine phs_fks_config_set_born_config
<<PHS fks: procedures>>=
module subroutine phs_fks_config_set_born_config (phs_config, phs_cfg_born)
class(phs_fks_config_t), intent(inout) :: phs_config
type(phs_wood_config_t), intent(in), target :: phs_cfg_born
if (debug_on) &
call msg_debug (D_PHASESPACE, "phs_fks_config_set_born_config")
phs_config%forest = phs_cfg_born%forest
phs_config%n_channel = phs_cfg_born%n_channel
allocate (phs_config%channel (phs_config%n_channel))
phs_config%channel = phs_cfg_born%channel
phs_config%n_par = phs_cfg_born%n_par
phs_config%n_state = phs_cfg_born%n_state
phs_config%sqrts = phs_cfg_born%sqrts
phs_config%par = phs_cfg_born%par
phs_config%sqrts_fixed = phs_cfg_born%sqrts_fixed
phs_config%azimuthal_dependence = phs_cfg_born%azimuthal_dependence
phs_config%provides_chains = phs_cfg_born%provides_chains
phs_config%lab_is_cm = phs_cfg_born%lab_is_cm
phs_config%vis_channels = phs_cfg_born%vis_channels
phs_config%provides_equivalences = phs_cfg_born%provides_equivalences
allocate (phs_config%chain (size (phs_cfg_born%chain)))
phs_config%chain = phs_cfg_born%chain
phs_config%model => phs_cfg_born%model
phs_config%use_cascades2 = phs_cfg_born%use_cascades2
if (allocated (phs_cfg_born%cascade_set)) then
allocate (phs_config%cascade_set)
phs_config%cascade_set = phs_cfg_born%cascade_set
end if
if (allocated (phs_cfg_born%feyngraph_set)) then
allocate (phs_config%feyngraph_set)
phs_config%feyngraph_set = phs_cfg_born%feyngraph_set
end if
phs_config%md5sum_born_config = phs_cfg_born%md5sum_phs_config
end subroutine phs_fks_config_set_born_config
@ %def phs_fks_config_set_born_config
@
<<PHS fks: fks config: TBP>>=
procedure :: get_resonance_histories => &
phs_fks_config_get_resonance_histories
<<PHS fks: sub interfaces>>=
module function phs_fks_config_get_resonance_histories &
(phs_config) result (resonance_histories)
type(resonance_history_t), dimension(:), allocatable :: &
resonance_histories
class(phs_fks_config_t), intent(inout) :: phs_config
end function phs_fks_config_get_resonance_histories
<<PHS fks: procedures>>=
module function phs_fks_config_get_resonance_histories &
(phs_config) result (resonance_histories)
type(resonance_history_t), dimension(:), allocatable :: resonance_histories
class(phs_fks_config_t), intent(inout) :: phs_config
if (allocated (phs_config%cascade_set)) then
call cascade_set_get_resonance_histories (phs_config%cascade_set, &
n_filter = 2, res_hists = resonance_histories)
else if (allocated (phs_config%feyngraph_set)) then
call feyngraph_set_get_resonance_histories (phs_config%feyngraph_set, &
n_filter = 2, res_hists = resonance_histories)
else
if (debug_on) call msg_debug (D_PHASESPACE, "Have to rebuild phase space for resonance histories")
call phs_config%generate_phase_space_extra ()
if (phs_config%use_cascades2) then
call feyngraph_set_get_resonance_histories &
(phs_config%feyngraph_set, n_filter = 2, res_hists = resonance_histories)
else
call cascade_set_get_resonance_histories &
(phs_config%cascade_set, n_filter = 2, res_hists = resonance_histories)
end if
end if
end function phs_fks_config_get_resonance_histories
@ %def phs_fks_config_get_resonance_histories
@
<<PHS fks: public>>=
public :: dalitz_plot_t
<<PHS fks: types>>=
type :: dalitz_plot_t
integer :: unit = -1
type(string_t) :: filename
logical :: active = .false.
logical :: inverse = .false.
contains
<<PHS fks: dalitz plot: TBP>>
end type dalitz_plot_t
@ %def dalitz_plot_t
@
<<PHS fks: dalitz plot: TBP>>=
procedure :: init => dalitz_plot_init
<<PHS fks: sub interfaces>>=
module subroutine dalitz_plot_init (plot, unit, filename, inverse)
class(dalitz_plot_t), intent(inout) :: plot
integer, intent(in) :: unit
type(string_t), intent(in) :: filename
logical, intent(in) :: inverse
end subroutine dalitz_plot_init
<<PHS fks: procedures>>=
module subroutine dalitz_plot_init (plot, unit, filename, inverse)
class(dalitz_plot_t), intent(inout) :: plot
integer, intent(in) :: unit
type(string_t), intent(in) :: filename
logical, intent(in) :: inverse
plot%active = .true.
plot%unit = unit
plot%inverse = inverse
open (plot%unit, file = char (filename), action = "write")
end subroutine dalitz_plot_init
@ %def daltiz_plot_init
@
<<PHS fks: dalitz plot: TBP>>=
procedure :: write_header => dalitz_plot_write_header
<<PHS fks: sub interfaces>>=
module subroutine dalitz_plot_write_header (plot)
class(dalitz_plot_t), intent(in) :: plot
end subroutine dalitz_plot_write_header
<<PHS fks: procedures>>=
module subroutine dalitz_plot_write_header (plot)
class(dalitz_plot_t), intent(in) :: plot
write (plot%unit, "(A36)") "### Dalitz plot generated by WHIZARD"
if (plot%inverse) then
write (plot%unit, "(A10,1x,A4)") "### k0_n+1", "k0_n"
else
write (plot%unit, "(A8,1x,A6)") "### k0_n", "k0_n+1"
end if
end subroutine dalitz_plot_write_header
@ %def dalitz_plot_write_header
@
<<PHS fks: dalitz plot: TBP>>=
procedure :: register => dalitz_plot_register
<<PHS fks: sub interfaces>>=
module subroutine dalitz_plot_register (plot, k0_n, k0_np1)
class(dalitz_plot_t), intent(in) :: plot
real(default), intent(in) :: k0_n, k0_np1
end subroutine dalitz_plot_register
<<PHS fks: procedures>>=
module subroutine dalitz_plot_register (plot, k0_n, k0_np1)
class(dalitz_plot_t), intent(in) :: plot
real(default), intent(in) :: k0_n, k0_np1
if (plot%inverse) then
write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n
else
write (plot%unit, "(F8.4,1X,F8.4)") k0_np1, k0_n
end if
end subroutine dalitz_plot_register
@ %def dalitz_plot_register
@
<<PHS fks: dalitz plot: TBP>>=
procedure :: final => dalitz_plot_final
<<PHS fks: sub interfaces>>=
module subroutine dalitz_plot_final (plot)
class(dalitz_plot_t), intent(inout) :: plot
end subroutine dalitz_plot_final
<<PHS fks: procedures>>=
module subroutine dalitz_plot_final (plot)
class(dalitz_plot_t), intent(inout) :: plot
logical :: opened
plot%active = .false.
plot%inverse = .false.
if (plot%unit >= 0) then
inquire (unit = plot%unit, opened = opened)
if (opened) close (plot%unit)
end if
plot%filename = var_str ('')
plot%unit = -1
end subroutine dalitz_plot_final
@ %def dalitz_plot_final
@
<<PHS fks: parameters>>=
integer, parameter, public :: GEN_REAL_PHASE_SPACE = 1
integer, parameter, public :: GEN_SOFT_MISMATCH = 2
integer, parameter, public :: GEN_SOFT_LIMIT_TEST = 3
integer, parameter, public :: GEN_COLL_LIMIT_TEST = 4
integer, parameter, public :: GEN_ANTI_COLL_LIMIT_TEST = 5
integer, parameter, public :: GEN_SOFT_COLL_LIMIT_TEST = 6
integer, parameter, public :: GEN_SOFT_ANTI_COLL_LIMIT_TEST = 7
integer, parameter, public :: SQRTS_FIXED = 1
integer, parameter, public :: SQRTS_VAR = 2
real(default), parameter :: xi_tilde_test_soft = 0.00001_default
real(default), parameter :: xi_tilde_test_coll = 0.5_default
real(default), parameter :: y_test_soft = 0.5_default
real(default), parameter :: y_test_coll = 0.9999999_default
!!! for testing EW singularities: y_test_coll = 0.99999999_default
@
@ Very soft or collinear phase-space points can become a problem for
matrix elements providers, as some scalar products cannot be evaluated
properly. Here, a nonsensical result can spoil the whole integration.
We therefore check the scalar products appearing to be below a certain
tolerance.\\
Naturally, this happens very rarely but for some processes,
setting [[?test_coll_limit = true]] and/or [[?test_soft_limit = true]]
leads to all phase space points beeing discarded by this routine.
<<PHS fks: public>>=
public :: check_scalar_products
<<PHS fks: sub interfaces>>=
module function check_scalar_products (p) result (valid)
logical :: valid
type(vector4_t), intent(in), dimension(:) :: p
end function check_scalar_products
<<PHS fks: procedures>>=
module function check_scalar_products (p) result (valid)
logical :: valid
type(vector4_t), intent(in), dimension(:) :: p
real(default), parameter :: tolerance = 1E-7_default
!!! for testing EW singularities: tolerance = 5E-9_default
integer :: i, j
valid = .true.
do i = 1, size (p)
do j = i, size (p)
if (i /= j) then
if (abs(p(i) * p(j)) < tolerance) then
valid = .false.
exit
end if
end if
end do
end do
end function check_scalar_products
@ %def check_scalar_products
@ [[xi_min]] should be set to a non-zero value in order to avoid
phase-space points with [[p_real(emitter) = 0]].
<<PHS fks: public>>=
public :: phs_fks_generator_t
<<PHS fks: types>>=
type :: phs_fks_generator_t
integer, dimension(:), allocatable :: emitters
type(real_kinematics_t), pointer :: real_kinematics => null()
type(isr_kinematics_t), pointer :: isr_kinematics => null()
integer :: n_in
real(default) :: xi_min
real(default) :: y_max
real(default) :: sqrts
real(default) :: E_gluon
real(default) :: mrec2
real(default), dimension(:), allocatable :: m2
logical :: massive_phsp = .false.
logical, dimension(:), allocatable :: is_massive
logical :: singular_jacobian = .false.
integer :: i_fsr_first = -1
type(resonance_contributors_t), dimension(:), allocatable :: resonance_contributors !!! Put somewhere else?
integer :: mode = GEN_REAL_PHASE_SPACE
contains
<<PHS fks: phs fks generator: TBP>>
end type phs_fks_generator_t
@ %def phs_fks_generator_t
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: connect_kinematics => phs_fks_generator_connect_kinematics
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_connect_kinematics &
(generator, isr_kinematics, real_kinematics, massive_phsp)
class(phs_fks_generator_t), intent(inout) :: generator
type(isr_kinematics_t), intent(in), pointer :: isr_kinematics
type(real_kinematics_t), intent(in), pointer :: real_kinematics
logical, intent(in) :: massive_phsp
end subroutine phs_fks_generator_connect_kinematics
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_connect_kinematics &
(generator, isr_kinematics, real_kinematics, massive_phsp)
class(phs_fks_generator_t), intent(inout) :: generator
type(isr_kinematics_t), intent(in), pointer :: isr_kinematics
type(real_kinematics_t), intent(in), pointer :: real_kinematics
logical, intent(in) :: massive_phsp
generator%real_kinematics => real_kinematics
generator%isr_kinematics => isr_kinematics
generator%massive_phsp = massive_phsp
end subroutine phs_fks_generator_connect_kinematics
@ %def phs_fks_generator_connect_kinematics
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_isr_kinematics => &
phs_fks_generator_compute_isr_kinematics
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_isr_kinematics &
(generator, r, p_in)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: r
type(vector4_t), dimension(2), intent(in), optional :: p_in
end subroutine phs_fks_generator_compute_isr_kinematics
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_isr_kinematics &
(generator, r, p_in)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: r
type(vector4_t), dimension(2), intent(in), optional :: p_in
integer :: em
type(vector4_t), dimension(2) :: p
if (present (p_in)) then
p = p_in
else
p = generator%real_kinematics%p_born_lab%phs_point(1)%select ([1,2])
end if
associate (isr_kinematics => generator%isr_kinematics)
do em = 1, 2
isr_kinematics%x(em) = p(em)%p(0) / isr_kinematics%beam_energy(em)
isr_kinematics%z(em) = one - (one - isr_kinematics%x(em)) * r
isr_kinematics%jacobian(em) = one - isr_kinematics%x(em)
end do
isr_kinematics%sqrts_born = (p(1) + p(2))**1
end associate
end subroutine phs_fks_generator_compute_isr_kinematics
@ %def phs_fks_generator_compute_isr_kinematics
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: final => phs_fks_generator_final
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_final (generator)
class(phs_fks_generator_t), intent(inout) :: generator
end subroutine phs_fks_generator_final
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_final (generator)
class(phs_fks_generator_t), intent(inout) :: generator
if (allocated (generator%emitters)) deallocate (generator%emitters)
if (associated (generator%real_kinematics)) &
nullify (generator%real_kinematics)
if (associated (generator%isr_kinematics)) &
nullify (generator%isr_kinematics)
if (allocated (generator%m2)) deallocate (generator%m2)
generator%massive_phsp = .false.
if (allocated (generator%is_massive)) deallocate (generator%is_massive)
generator%singular_jacobian = .false.
generator%i_fsr_first = -1
if (allocated (generator%resonance_contributors)) &
deallocate (generator%resonance_contributors)
generator%mode = GEN_REAL_PHASE_SPACE
end subroutine phs_fks_generator_final
@ %def phs_fks_generator_final
@ A resonance phase space is uniquely specified via the resonance contributors and the
corresponding emitters. The [[phs_identifier]] type also checks whether
the given contributor-emitter configuration has already been evaluated to
avoid duplicate computations.
<<PHS fks: public>>=
public :: phs_identifier_t
<<PHS fks: types>>=
type :: phs_identifier_t
integer, dimension(:), allocatable :: contributors
integer :: emitter = -1
logical :: evaluated = .false.
contains
<<PHS fks: phs identifier: TBP>>
end type phs_identifier_t
@ %def phs_identifier_t
@
<<PHS fks: phs identifier: TBP>>=
generic :: init => init_from_emitter, init_from_emitter_and_contributors
procedure :: init_from_emitter => phs_identifier_init_from_emitter
procedure :: init_from_emitter_and_contributors &
=> phs_identifier_init_from_emitter_and_contributors
<<PHS fks: sub interfaces>>=
module subroutine phs_identifier_init_from_emitter (phs_id, emitter)
class(phs_identifier_t), intent(out) :: phs_id
integer, intent(in) :: emitter
end subroutine phs_identifier_init_from_emitter
module subroutine phs_identifier_init_from_emitter_and_contributors &
(phs_id, emitter, contributors)
class(phs_identifier_t), intent(out) :: phs_id
integer, intent(in) :: emitter
integer, intent(in), dimension(:) :: contributors
end subroutine phs_identifier_init_from_emitter_and_contributors
<<PHS fks: procedures>>=
module subroutine phs_identifier_init_from_emitter (phs_id, emitter)
class(phs_identifier_t), intent(out) :: phs_id
integer, intent(in) :: emitter
phs_id%emitter = emitter
end subroutine phs_identifier_init_from_emitter
module subroutine phs_identifier_init_from_emitter_and_contributors &
(phs_id, emitter, contributors)
class(phs_identifier_t), intent(out) :: phs_id
integer, intent(in) :: emitter
integer, intent(in), dimension(:) :: contributors
allocate (phs_id%contributors (size (contributors)))
phs_id%contributors = contributors
phs_id%emitter = emitter
end subroutine phs_identifier_init_from_emitter_and_contributors
@ %def phs_identifier_init_from_emitter
@ %def phs_identifier_init_from_emitter_and_contributors
@
<<PHS fks: phs identifier: TBP>>=
procedure :: check => phs_identifier_check
<<PHS fks: sub interfaces>>=
module function phs_identifier_check &
(phs_id, emitter, contributors) result (check)
logical :: check
class(phs_identifier_t), intent(in) :: phs_id
integer, intent(in) :: emitter
integer, intent(in), dimension(:), optional :: contributors
end function phs_identifier_check
<<PHS fks: procedures>>=
module function phs_identifier_check &
(phs_id, emitter, contributors) result (check)
logical :: check
class(phs_identifier_t), intent(in) :: phs_id
integer, intent(in) :: emitter
integer, intent(in), dimension(:), optional :: contributors
check = phs_id%emitter == emitter
if (present (contributors)) then
if (.not. allocated (phs_id%contributors)) &
call msg_fatal ("Phs identifier: contributors not allocated!")
check = check .and. all (phs_id%contributors == contributors)
end if
end function phs_identifier_check
@ %def phs_identifier_check
@
<<PHS fks: phs identifier: TBP>>=
procedure :: write => phs_identifier_write
<<PHS fks: sub interfaces>>=
module subroutine phs_identifier_write (phs_id, unit)
class(phs_identifier_t), intent(in) :: phs_id
integer, intent(in), optional :: unit
end subroutine phs_identifier_write
<<PHS fks: procedures>>=
module subroutine phs_identifier_write (phs_id, unit)
class(phs_identifier_t), intent(in) :: phs_id
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, '(A)') 'phs_identifier: '
write (u, '(A,1X,I1)') 'Emitter: ', phs_id%emitter
if (allocated (phs_id%contributors)) then
write (u, '(A)', advance = 'no') 'Resonance contributors: '
do i = 1, size (phs_id%contributors)
write (u, '(I1,1X)', advance = 'no') phs_id%contributors(i)
end do
else
write (u, '(A)') 'No Contributors allocated'
end if
end subroutine phs_identifier_write
@ %def phs_identifier_write
@
<<PHS fks: public>>=
public :: check_for_phs_identifier
<<PHS fks: sub interfaces>>=
module subroutine check_for_phs_identifier &
(phs_id, n_in, emitter, contributors, phs_exist, i_phs)
type(phs_identifier_t), intent(in), dimension(:) :: phs_id
integer, intent(in) :: n_in, emitter
integer, intent(in), dimension(:), optional :: contributors
logical, intent(out) :: phs_exist
integer, intent(out) :: i_phs
end subroutine check_for_phs_identifier
<<PHS fks: procedures>>=
module subroutine check_for_phs_identifier &
(phs_id, n_in, emitter, contributors, phs_exist, i_phs)
type(phs_identifier_t), intent(in), dimension(:) :: phs_id
integer, intent(in) :: n_in, emitter
integer, intent(in), dimension(:), optional :: contributors
logical, intent(out) :: phs_exist
integer, intent(out) :: i_phs
integer :: i
phs_exist = .false.
i_phs = -1
do i = 1, size (phs_id)
if (phs_id(i)%emitter < 0) then
i_phs = i
exit
end if
phs_exist = phs_id(i)%emitter == emitter
if (present (contributors)) &
phs_exist = phs_exist .and. &
all (phs_id(i)%contributors == contributors)
if (phs_exist) then
i_phs = i
exit
end if
end do
end subroutine check_for_phs_identifier
@ %def check_for_phs_identifier
@
@ The fks phase space type contains the wood phase space and
separately the in- and outcoming momenta for the real process and the
corresponding Born momenta. Additionally, there are the variables
$\xi$,$\xi_{max}$, $y$ and $\phi$ which are used to create the real
phase space, as well as the jacobian and its corresponding soft and
collinear limit. Lastly, the array \texttt{ch\_to\_em} connects each
channel with an emitter.
<<PHS fks: public>>=
public :: phs_fks_t
<<PHS fks: types>>=
type, extends (phs_wood_t) :: phs_fks_t
integer :: mode = PHS_MODE_UNDEFINED
type(vector4_t), dimension(:), allocatable :: p_born
type(vector4_t), dimension(:), allocatable :: q_born
type(vector4_t), dimension(:), allocatable :: p_real
type(vector4_t), dimension(:), allocatable :: q_real
type(vector4_t), dimension(:), allocatable :: p_born_tot
type(phs_fks_generator_t) :: generator
real(default) :: r_isr
type(phs_identifier_t), dimension(:), allocatable :: phs_identifiers
contains
<<PHS fks: phs fks: TBP>>
end type phs_fks_t
@ %def phs_fks_t
@
<<PHS fks: interfaces>>=
interface compute_beta
module procedure compute_beta_massless
module procedure compute_beta_massive
end interface
interface get_xi_max_fsr
module procedure get_xi_max_fsr_massless
module procedure get_xi_max_fsr_massive
end interface
@ %def interfaces
@
<<PHS fks: phs fks: TBP>>=
procedure :: write => phs_fks_write
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_write (object, unit, verbose)
class(phs_fks_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
end subroutine phs_fks_write
<<PHS fks: procedures>>=
module subroutine phs_fks_write (object, unit, verbose)
class(phs_fks_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
integer :: u, i, n_id
u = given_output_unit (unit)
call object%base_write ()
n_id = size (object%phs_identifiers)
if (n_id == 0) then
write (u, "(A)") "No phs identifiers allocated! "
else
do i = 1, n_id
call object%phs_identifiers(i)%write (u)
end do
end if
end subroutine phs_fks_write
@ %def phs_fks_write
@ Initializer for the phase space. Calls the initialization of the
corresponding Born phase space, sets up the
channel-emitter-association and allocates space for the momenta.
<<PHS fks: phs fks: TBP>>=
procedure :: init => phs_fks_init
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_init (phs, phs_config)
class(phs_fks_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
end subroutine phs_fks_init
<<PHS fks: procedures>>=
module subroutine phs_fks_init (phs, phs_config)
class(phs_fks_t), intent(out) :: phs
class(phs_config_t), intent(in), target :: phs_config
call phs%base_init (phs_config)
select type (phs_config)
type is (phs_fks_config_t)
phs%config => phs_config
phs%forest = phs_config%forest
end select
select type (phs)
type is (phs_fks_t)
select type (phs_config)
type is (phs_fks_config_t)
phs%mode = phs_config%mode
end select
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
phs%n_r_born = phs%config%n_par - 3
case (PHS_MODE_COLLINEAR_REMNANT)
phs%n_r_born = phs%config%n_par - 1
end select
end select
end subroutine phs_fks_init
@ %def phs_fks_init
@ For real components of $2\to 1$ NLO processes we have to recompute the
flux factor as this has to be the one of the underlying Born.
<<PHS fks: phs fks: TBP>>=
procedure :: compute_flux => phs_fks_compute_flux
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_compute_flux (phs)
class(phs_fks_t), intent(inout) :: phs
end subroutine phs_fks_compute_flux
<<PHS fks: procedures>>=
module subroutine phs_fks_compute_flux (phs)
class(phs_fks_t), intent(inout) :: phs
call phs%compute_base_flux ()
select type (config => phs%config)
type is (phs_fks_config_t)
if (config%born_2_to_1) then
phs%flux = conv * twopi &
/ (2 * config%sqrts ** 2 * phs%m_out(1) ** 2)
end if
end select
end subroutine phs_fks_compute_flux
@ %def phs_fks_compute_flux
@
<<PHS fks: phs fks: TBP>>=
procedure :: allocate_momenta => phs_fks_allocate_momenta
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born)
class(phs_fks_t), intent(inout) :: phs
class(phs_config_t), intent(in) :: phs_config
logical, intent(in) :: data_is_born
end subroutine phs_fks_allocate_momenta
<<PHS fks: procedures>>=
module subroutine phs_fks_allocate_momenta (phs, phs_config, data_is_born)
class(phs_fks_t), intent(inout) :: phs
class(phs_config_t), intent(in) :: phs_config
logical, intent(in) :: data_is_born
integer :: n_out_born
allocate (phs%p_born (phs_config%n_in))
allocate (phs%p_real (phs_config%n_in))
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
if (data_is_born) then
n_out_born = phs_config%n_out
else
n_out_born = phs_config%n_out - 1
end if
allocate (phs%q_born (n_out_born))
allocate (phs%q_real (n_out_born + 1))
allocate (phs%p_born_tot (phs_config%n_in + n_out_born))
end select
end subroutine phs_fks_allocate_momenta
@ %def phs_fks_allocate_momenta
@ Evaluate selected channel. First, the subroutine calls the
evaluation procedure of the underlying Born phase space, using $n_r -
3$ random numbers. Then, the remaining three random numbers are used
to create $\xi$, $y$ and $\phi$, from which the real momenta are
calculated from the Born momenta.
<<PHS fks: phs fks: TBP>>=
procedure :: evaluate_selected_channel => phs_fks_evaluate_selected_channel
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
end subroutine phs_fks_evaluate_selected_channel
<<PHS fks: procedures>>=
module subroutine phs_fks_evaluate_selected_channel (phs, c_in, r_in)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: c_in
real(default), intent(in), dimension(:) :: r_in
integer :: n_in
call phs%phs_wood_t%evaluate_selected_channel (c_in, r_in)
phs%r(:,c_in) = r_in
phs%q_defined = phs%phs_wood_t%q_defined
if (.not. phs%q_defined) return
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
n_in = phs%config%n_in
phs%p_born = phs%phs_wood_t%p
phs%q_born = phs%phs_wood_t%q
phs%p_born_tot (1: n_in) = phs%p_born
phs%p_born_tot (n_in + 1 :) = phs%q_born
call phs%set_reference_frames (.true.)
call phs%set_isr_kinematics (.true.)
case (PHS_MODE_COLLINEAR_REMNANT)
call phs%compute_isr_kinematics (r_in(phs%n_r_born + 1))
phs%r_isr = r_in(phs%n_r_born + 1)
end select
end subroutine phs_fks_evaluate_selected_channel
@ %def phs_fks_evaluate_selected_channel
@
<<PHS fks: phs fks: TBP>>=
procedure :: evaluate_other_channels => phs_fks_evaluate_other_channels
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_evaluate_other_channels (phs, c_in)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: c_in
end subroutine phs_fks_evaluate_other_channels
<<PHS fks: procedures>>=
module subroutine phs_fks_evaluate_other_channels (phs, c_in)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: c_in
call phs%phs_wood_t%evaluate_other_channels (c_in)
phs%r_defined = .true.
end subroutine phs_fks_evaluate_other_channels
@ %def phs_fks_evaluate_other_channels
@
<<PHS fks: phs fks: TBP>>=
procedure :: get_mcpar => phs_fks_get_mcpar
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_get_mcpar (phs, c, r)
class(phs_fks_t), intent(in) :: phs
integer, intent(in) :: c
real(default), dimension(:), intent(out) :: r
end subroutine phs_fks_get_mcpar
<<PHS fks: procedures>>=
module subroutine phs_fks_get_mcpar (phs, c, r)
class(phs_fks_t), intent(in) :: phs
integer, intent(in) :: c
real(default), dimension(:), intent(out) :: r
r(1 : phs%n_r_born) = phs%r(1 : phs%n_r_born,c)
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
r(phs%n_r_born + 1 :) = phs%r_real
case (PHS_MODE_COLLINEAR_REMNANT)
r(phs%n_r_born + 1 :) = phs%r_isr
end select
end subroutine phs_fks_get_mcpar
@ %def phs_fks_get_mcpar
@
<<PHS fks: phs fks: TBP>>=
procedure :: set_beam_energy => phs_fks_set_beam_energy
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_set_beam_energy (phs)
class(phs_fks_t), intent(inout) :: phs
end subroutine phs_fks_set_beam_energy
<<PHS fks: procedures>>=
module subroutine phs_fks_set_beam_energy (phs)
class(phs_fks_t), intent(inout) :: phs
call phs%generator%set_sqrts_hat (phs%config%sqrts)
end subroutine phs_fks_set_beam_energy
@ %def phs_fks_set_beam_energy
@
<<PHS fks: phs fks: TBP>>=
procedure :: set_emitters => phs_fks_set_emitters
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_set_emitters (phs, emitters)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in), dimension(:), allocatable :: emitters
end subroutine phs_fks_set_emitters
<<PHS fks: procedures>>=
module subroutine phs_fks_set_emitters (phs, emitters)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in), dimension(:), allocatable :: emitters
call phs%generator%set_emitters (emitters)
end subroutine phs_fks_set_emitters
@ %def phs_fks_set_emitters
@
<<PHS fks: phs fks: TBP>>=
procedure :: set_momenta => phs_fks_set_momenta
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_set_momenta (phs, p)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), intent(in), dimension(:) :: p
end subroutine phs_fks_set_momenta
<<PHS fks: procedures>>=
module subroutine phs_fks_set_momenta (phs, p)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), intent(in), dimension(:) :: p
integer :: n_in, n_tot_born
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
n_in = phs%config%n_in; n_tot_born = phs%config%n_tot - 1
phs%p_born = p(1 : n_in)
phs%q_born = p(n_in + 1 : n_tot_born)
phs%p_born_tot = p
end select
end subroutine phs_fks_set_momenta
@ %def phs_fks_set_momenta
@
<<PHS fks: phs fks: TBP>>=
procedure :: setup_masses => phs_fks_setup_masses
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_setup_masses (phs, n_tot)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: n_tot
end subroutine phs_fks_setup_masses
<<PHS fks: procedures>>=
module subroutine phs_fks_setup_masses (phs, n_tot)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: n_tot
call phs%generator%setup_masses (n_tot)
end subroutine phs_fks_setup_masses
@ %def phs_fks_setup_masses
@
<<PHS fks: phs fks: TBP>>=
procedure :: get_born_momenta => phs_fks_get_born_momenta
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_get_born_momenta (phs, p)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), intent(out), dimension(:) :: p
end subroutine phs_fks_get_born_momenta
<<PHS fks: procedures>>=
module subroutine phs_fks_get_born_momenta (phs, p)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), intent(out), dimension(:) :: p
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
p(1 : phs%config%n_in) = phs%p_born
p(phs%config%n_in + 1 :) = phs%q_born
case (PHS_MODE_COLLINEAR_REMNANT)
p(1:phs%config%n_in) = phs%phs_wood_t%p
p(phs%config%n_in + 1 : ) = phs%phs_wood_t%q
end select
if (.not. phs%config%lab_is_cm) p = phs%lt_cm_to_lab * p
end subroutine phs_fks_get_born_momenta
@ %def phs_fks_get_born_momenta
@
<<PHS fks: phs fks: TBP>>=
procedure :: get_outgoing_momenta => phs_fks_get_outgoing_momenta
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_get_outgoing_momenta (phs, q)
class(phs_fks_t), intent(in) :: phs
type(vector4_t), intent(out), dimension(:) :: q
end subroutine phs_fks_get_outgoing_momenta
<<PHS fks: procedures>>=
module subroutine phs_fks_get_outgoing_momenta (phs, q)
class(phs_fks_t), intent(in) :: phs
type(vector4_t), intent(out), dimension(:) :: q
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
q = phs%q_real
case (PHS_MODE_COLLINEAR_REMNANT)
q = phs%phs_wood_t%q
end select
end subroutine phs_fks_get_outgoing_momenta
@ %def phs_fks_get_outgoing_momenta
@
<<PHS fks: phs fks: TBP>>=
procedure :: get_incoming_momenta => phs_fks_get_incoming_momenta
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_get_incoming_momenta (phs, p)
class(phs_fks_t), intent(in) :: phs
type(vector4_t), intent(inout), dimension(:), allocatable :: p
end subroutine phs_fks_get_incoming_momenta
<<PHS fks: procedures>>=
module subroutine phs_fks_get_incoming_momenta (phs, p)
class(phs_fks_t), intent(in) :: phs
type(vector4_t), intent(inout), dimension(:), allocatable :: p
p = phs%p_real
end subroutine phs_fks_get_incoming_momenta
@ %def phs_fks_get_incoming_momenta
@
<<PHS fks: phs fks: TBP>>=
procedure :: set_isr_kinematics => phs_fks_set_isr_kinematics
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_set_isr_kinematics (phs, requires_boost)
class(phs_fks_t), intent(inout) :: phs
logical, intent(in) :: requires_boost
end subroutine phs_fks_set_isr_kinematics
<<PHS fks: procedures>>=
module subroutine phs_fks_set_isr_kinematics (phs, requires_boost)
class(phs_fks_t), intent(inout) :: phs
logical, intent(in) :: requires_boost
type(vector4_t), dimension(2) :: p
if (phs%generator%isr_kinematics%isr_mode == SQRTS_VAR) then
if (requires_boost) then
p = phs%lt_cm_to_lab &
* phs%generator%real_kinematics%p_born_cms%phs_point(1)%select ([1,2])
else
p = phs%generator%real_kinematics%p_born_lab%phs_point(1)%select ([1,2])
end if
call phs%generator%set_isr_kinematics (p)
end if
end subroutine phs_fks_set_isr_kinematics
@ %def phs_fks_set_isr_kinematics
@
<<PHS fks: phs fks: TBP>>=
procedure :: generate_radiation_variables => &
phs_fks_generate_radiation_variables
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generate_radiation_variables &
(phs, r_in, threshold)
class(phs_fks_t), intent(inout) :: phs
real(default), intent(in), dimension(:) :: r_in
logical, intent(in) :: threshold
end subroutine phs_fks_generate_radiation_variables
<<PHS fks: procedures>>=
module subroutine phs_fks_generate_radiation_variables &
(phs, r_in, threshold)
class(phs_fks_t), intent(inout) :: phs
real(default), intent(in), dimension(:) :: r_in
logical, intent(in) :: threshold
type(vector4_t), dimension(:), allocatable :: p_born
if (size (r_in) /= 3) call msg_fatal &
("Real kinematics need to be generated using three random numbers!")
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
allocate (p_born (size (phs%p_born_tot)))
if (threshold) then
p_born = phs%get_onshell_projected_momenta ()
else
p_born = phs%p_born_tot
if (.not. phs%lab_is_cm ()) &
p_born = inverse (phs%lt_cm_to_lab) * p_born
end if
call phs%generator%generate_radiation_variables &
(r_in, p_born, phs%phs_identifiers, threshold)
phs%r_real = r_in
end select
end subroutine phs_fks_generate_radiation_variables
@ %def phs_fks_generate_radiation_variables
@
<<PHS fks: phs fks: TBP>>=
procedure :: compute_xi_ref_momenta => phs_fks_compute_xi_ref_momenta
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), intent(in), dimension(:), optional :: p_in
type(resonance_contributors_t), intent(in), dimension(:), optional :: &
contributors
end subroutine phs_fks_compute_xi_ref_momenta
<<PHS fks: procedures>>=
module subroutine phs_fks_compute_xi_ref_momenta (phs, p_in, contributors)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), intent(in), dimension(:), optional :: p_in
type(resonance_contributors_t), intent(in), dimension(:), optional :: &
contributors
if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) then
if (present (p_in)) then
call phs%generator%compute_xi_ref_momenta (p_in, contributors)
else
call phs%generator%compute_xi_ref_momenta &
(phs%p_born_tot, contributors)
end if
end if
end subroutine phs_fks_compute_xi_ref_momenta
@ %def phs_fks_compute_xi_ref_momenta
@
<<PHS fks: phs fks: TBP>>=
procedure :: compute_xi_ref_momenta_threshold => &
phs_fks_compute_xi_ref_momenta_threshold
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_compute_xi_ref_momenta_threshold (phs)
class(phs_fks_t), intent(inout) :: phs
end subroutine phs_fks_compute_xi_ref_momenta_threshold
<<PHS fks: procedures>>=
module subroutine phs_fks_compute_xi_ref_momenta_threshold (phs)
class(phs_fks_t), intent(inout) :: phs
select case (phs%mode)
case (PHS_MODE_ADDITIONAL_PARTICLE)
call phs%generator%compute_xi_ref_momenta_threshold &
(phs%get_onshell_projected_momenta ())
end select
end subroutine phs_fks_compute_xi_ref_momenta_threshold
@ %def phs_fks_compute_xi_ref_momenta
@
<<PHS fks: phs fks: TBP>>=
procedure :: compute_cms_energy => phs_fks_compute_cms_energy
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_compute_cms_energy (phs)
class(phs_fks_t), intent(inout) :: phs
end subroutine phs_fks_compute_cms_energy
<<PHS fks: procedures>>=
module subroutine phs_fks_compute_cms_energy (phs)
class(phs_fks_t), intent(inout) :: phs
if (phs%mode == PHS_MODE_ADDITIONAL_PARTICLE) &
call phs%generator%compute_cms_energy (phs%p_born_tot)
end subroutine phs_fks_compute_cms_energy
@ %def phs_fks_compute_cms_energy
@ When initial-state radiation is involved, either due to beamstrahlung or
QCD/QED corrections, it is important to have access to both the phase
space points in the center-of-mass and lab frame.
<<PHS fks: phs fks: TBP>>=
procedure :: set_reference_frames => phs_fks_set_reference_frames
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_set_reference_frames (phs, is_cms)
class(phs_fks_t), intent(inout) :: phs
logical, intent(in) :: is_cms
end subroutine phs_fks_set_reference_frames
<<PHS fks: procedures>>=
module subroutine phs_fks_set_reference_frames (phs, is_cms)
class(phs_fks_t), intent(inout) :: phs
logical, intent(in) :: is_cms
associate (real_kinematics => phs%generator%real_kinematics)
if (phs%config%lab_is_cm) then
real_kinematics%p_born_cms%phs_point(1) = phs%p_born_tot
real_kinematics%p_born_lab%phs_point(1) = phs%p_born_tot
else
if (is_cms) then
real_kinematics%p_born_cms%phs_point(1) &
= phs%p_born_tot
real_kinematics%p_born_lab%phs_point(1) &
= phs%lt_cm_to_lab * phs%p_born_tot
else
real_kinematics%p_born_cms%phs_point(1) &
= inverse (phs%lt_cm_to_lab) * phs%p_born_tot
real_kinematics%p_born_lab%phs_point(1) &
= phs%p_born_tot
end if
end if
end associate
end subroutine phs_fks_set_reference_frames
@ %def phs_fks_set_reference_frames
@
<<PHS fks: phs fks: TBP>>=
procedure :: i_phs_is_isr => phs_fks_i_phs_is_isr
<<PHS fks: sub interfaces>>=
module function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr)
logical :: is_isr
class(phs_fks_t), intent(in) :: phs
integer, intent(in) :: i_phs
end function phs_fks_i_phs_is_isr
<<PHS fks: procedures>>=
module function phs_fks_i_phs_is_isr (phs, i_phs) result (is_isr)
logical :: is_isr
class(phs_fks_t), intent(in) :: phs
integer, intent(in) :: i_phs
is_isr = phs%phs_identifiers(i_phs)%emitter <= phs%generator%n_in
end function phs_fks_i_phs_is_isr
@ %def phs_fks_i_phs_is_isr
@
\subsection{Creation of the real phase space - FSR}
At this point, the Born phase space has been generated, as well as the
three random variables $\xi$, $y$ and $\phi$. The question is how the
real phase space is generated for a final-state emission
configuration. We work with two different sets of momenta, the Born
configuration $\Bigl\{ \bar{k}_{\oplus}, \bar{k}_{\ominus}, \bar{k}_{1}, ...,
\bar{k}_{n} \Bigr\}$ and the real configuration $\Bigl\{ k_{\oplus},
k_{\ominus}, k_1,..., k_n, k_{n+1} \Bigr\}$. We define the momentum of
the emitter to be on the $n$-th position and the momentum of the
radiated particle to be at position $n+1$. The magnitude of the
spatial component of k is denoted by $\underline{k}$.
For final-state emissions, it is $\bar{k}_\oplus = k_\oplus$ and
$\bar{k}_\ominus = k_\ominus$. Thus, the center-of-mass systems
coincide and it is
\begin{equation}
q = \sum_{i=1}^n \bar{k}_i = \sum_{i=1}^{n+1} k_i,
\end{equation}
with $\vec{q} = 0$ and $q^2 = \left(q^0\right)^2$.
We want to construct the real phase space from the Born phase space
using three random numbers. They are defined as follows:
\begin{itemize}
\item $\xi = \frac{2k_{n+1}^0}{\sqrt{s}} \in [0, \xi_{max}]$, where
$k_{n+1}$ denotes the four-momentum of the radiated particle.
\item $y = \cos\theta = \frac{\vec{k}_n \cdot
\vec{k}_{n+1}}{\underline{k}_n \underline{k}_{n+1}}$ is the
splitting angle.
\item The angle between tho two splitting particles in the transversal
plane, $phi \in [0,2\pi]$.
\end{itemize}
Further, $k_{rec} = \sum_{i=1}^{n-1} k_i$ denotes the sum of all
recoiling momenta.
<<PHS fks: phs fks generator: TBP>>=
generic :: generate_fsr => generate_fsr_default, generate_fsr_resonances
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_fsr_default => phs_fks_generator_generate_fsr_default
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_fsr_default &
(generator, emitter, i_phs, &
p_born, p_real, xi_y_phi, no_jacobians)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
real(default), intent(in), dimension(3), optional :: xi_y_phi
logical, intent(in), optional :: no_jacobians
end subroutine phs_fks_generator_generate_fsr_default
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_fsr_default &
(generator, emitter, i_phs, &
p_born, p_real, xi_y_phi, no_jacobians)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
real(default), intent(in), dimension(3), optional :: xi_y_phi
logical, intent(in), optional :: no_jacobians
real(default) :: q0
call generator%generate_fsr_in (p_born, p_real)
q0 = sum (p_born(1:generator%n_in))**1
generator%i_fsr_first = generator%n_in + 1
call generator%generate_fsr_out (emitter, i_phs, p_born, p_real, q0, &
xi_y_phi = xi_y_phi, no_jacobians = no_jacobians)
if (debug_active (D_PHASESPACE)) then
call vector4_check_momentum_conservation (p_real, generator%n_in, &
rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07)
end if
end subroutine phs_fks_generator_generate_fsr_default
@ %def phs_fks_generator_generate_fsr
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_fsr_resonances => &
phs_fks_generator_generate_fsr_resonances
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_fsr_resonances (generator, &
emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: emitter, i_phs
integer, intent(in) :: i_con
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(inout), dimension(:) :: p_real
real(default), intent(in), dimension(3), optional :: xi_y_phi
logical, intent(in), optional :: no_jacobians
end subroutine phs_fks_generator_generate_fsr_resonances
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_fsr_resonances (generator, &
emitter, i_phs, i_con, p_born, p_real, xi_y_phi, no_jacobians)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: emitter, i_phs
integer, intent(in) :: i_con
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(inout), dimension(:) :: p_real
real(default), intent(in), dimension(3), optional :: xi_y_phi
logical, intent(in), optional :: no_jacobians
integer, dimension(:), allocatable :: resonance_list
integer, dimension(size(p_born)) :: inv_resonance_list
type(vector4_t), dimension(:), allocatable :: p_tmp_born
type(vector4_t), dimension(:), allocatable :: p_tmp_real
type(vector4_t) :: p_resonance
real(default) :: q0
integer :: i, j, nlegborn, nlegreal
integer :: i_emitter
type(lorentz_transformation_t) :: boost_to_resonance
integer :: n_resonant_particles
if (debug_on) call msg_debug2 (D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances")
nlegborn = size (p_born); nlegreal = nlegborn + 1
allocate (resonance_list (size (generator%resonance_contributors(i_con)%c)))
resonance_list = generator%resonance_contributors(i_con)%c
n_resonant_particles = size (resonance_list)
if (.not. any (resonance_list == emitter)) then
call msg_fatal ("Emitter must be included in the resonance list!")
else
do i = 1, n_resonant_particles
if (resonance_list (i) == emitter) i_emitter = i
end do
end if
inv_resonance_list = &
create_inverse_resonance_list (nlegborn, resonance_list)
allocate (p_tmp_born (n_resonant_particles))
allocate (p_tmp_real (n_resonant_particles + 1))
p_tmp_born = vector4_null
p_tmp_real = vector4_null
j = 1
do i = 1, n_resonant_particles
p_tmp_born(j) = p_born(resonance_list(i))
j = j + 1
end do
call generator%generate_fsr_in (p_born, p_real)
p_resonance = generator%real_kinematics%xi_ref_momenta(i_con)
q0 = p_resonance**1
boost_to_resonance = inverse (boost (p_resonance, q0))
p_tmp_born = boost_to_resonance * p_tmp_born
generator%i_fsr_first = 1
call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, p_tmp_real, &
q0, i_emitter, xi_y_phi)
p_tmp_real = inverse (boost_to_resonance) * p_tmp_real
do i = generator%n_in + 1, nlegborn
if (any (resonance_list == i)) then
p_real(i) = p_tmp_real(inv_resonance_list (i))
else
p_real(i) = p_born (i)
end if
end do
p_real(nlegreal) = p_tmp_real (n_resonant_particles + 1)
if (debug_active (D_PHASESPACE)) then
call vector4_check_momentum_conservation (p_real, generator%n_in, &
rel_smallness = 1000 * tiny_07, abs_smallness = tiny_07)
end if
contains
function create_inverse_resonance_list (nlegborn, resonance_list) &
result (inv_resonance_list)
integer, intent(in) :: nlegborn
integer, intent(in), dimension(:) :: resonance_list
integer, dimension(nlegborn) :: inv_resonance_list
integer :: i, j
inv_resonance_list = 0
j = 1
do i = 1, nlegborn
if (any (i == resonance_list)) then
inv_resonance_list (i) = j
j = j + 1
end if
end do
end function create_inverse_resonance_list
function boosted_energy () result (E)
real(default) :: E
type(vector4_t) :: p_boost
p_boost = boost_to_resonance * p_resonance
E = p_boost%p(0)
end function boosted_energy
end subroutine phs_fks_generator_generate_fsr_resonances
@ %def phs_fks_generator_generate_fsr_resonances
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_fsr_threshold => &
phs_fks_generator_generate_fsr_threshold
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_fsr_threshold (generator, &
emitter, i_phs, p_born, p_real, xi_y_phi)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(inout), dimension(:) :: p_real
real(default), intent(in), dimension(3), optional :: xi_y_phi
end subroutine phs_fks_generator_generate_fsr_threshold
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_fsr_threshold (generator, &
emitter, i_phs, p_born, p_real, xi_y_phi)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(inout), dimension(:) :: p_real
real(default), intent(in), dimension(3), optional :: xi_y_phi
type(vector4_t), dimension(2) :: p_tmp_born
type(vector4_t), dimension(3) :: p_tmp_real
integer :: nlegborn, nlegreal
type(vector4_t) :: p_top
real(default) :: q0
type(lorentz_transformation_t) :: boost_to_top
integer :: leg, other_leg
real(default) :: sqrts, mtop
if (debug_on) call msg_debug2 &
(D_PHASESPACE, "phs_fks_generator_generate_fsr_resonances")
nlegborn = size (p_born); nlegreal = nlegborn + 1
leg = thr_leg(emitter); other_leg = 3 - leg
p_tmp_born(1) = p_born (ass_boson(leg))
p_tmp_born(2) = p_born (ass_quark(leg))
call generator%generate_fsr_in (p_born, p_real)
p_top = generator%real_kinematics%xi_ref_momenta(leg)
q0 = p_top**1
sqrts = two * p_born(1)%p(0)
mtop = m1s_to_mpole (sqrts)
if (sqrts**2 - four * mtop**2 > zero) then
boost_to_top = inverse (boost (p_top, q0))
else
boost_to_top = identity
end if
p_tmp_born = boost_to_top * p_tmp_born
generator%i_fsr_first = 1
call generator%generate_fsr_out (emitter, i_phs, p_tmp_born, &
p_tmp_real, q0, 2, xi_y_phi)
p_tmp_real = inverse (boost_to_top) * p_tmp_real
p_real(ass_boson(leg)) = p_tmp_real(1)
p_real(ass_quark(leg)) = p_tmp_real(2)
p_real(ass_boson(other_leg)) = p_born(ass_boson(other_leg))
p_real(ass_quark(other_leg)) = p_born(ass_quark(other_leg))
p_real(THR_POS_GLUON) = p_tmp_real(3)
end subroutine phs_fks_generator_generate_fsr_threshold
@ %def phs_fks_generator_generate_fsr_threshold
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_fsr_in => phs_fks_generator_generate_fsr_in
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_fsr_in &
(generator, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
end subroutine phs_fks_generator_generate_fsr_in
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_fsr_in &
(generator, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
integer :: i
do i = 1, generator%n_in
p_real(i) = p_born(i)
end do
end subroutine phs_fks_generator_generate_fsr_in
@ %def phs_fks_generator_generate_fsr_in
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_fsr_out => phs_fks_generator_generate_fsr_out
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_fsr_out (generator, &
emitter, i_phs, p_born, p_real, q0, p_emitter_index, &
xi_y_phi, no_jacobians)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(inout), dimension(:) :: p_real
real(default), intent(in) :: q0
integer, intent(in), optional :: p_emitter_index
real(default), intent(in), dimension(3), optional :: xi_y_phi
logical, intent(in), optional :: no_jacobians
end subroutine phs_fks_generator_generate_fsr_out
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_fsr_out (generator, &
emitter, i_phs, p_born, p_real, q0, p_emitter_index, &
xi_y_phi, no_jacobians)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(inout), dimension(:) :: p_real
real(default), intent(in) :: q0
integer, intent(in), optional :: p_emitter_index
real(default), intent(in), dimension(3), optional :: xi_y_phi
logical, intent(in), optional :: no_jacobians
real(default) :: xi, y, phi
integer :: nlegborn, nlegreal
real(default) :: uk_np1, uk_n
real(default) :: uk_rec, k_rec0
type(vector3_t) :: k_n_born, k
real(default) :: uk_n_born, uk, k2, k0_n
real(default) :: cpsi, beta
type(vector3_t) :: vec, vec_orth
type(lorentz_transformation_t) :: rot
integer :: i, p_em
logical :: compute_jac
p_em = emitter; if (present (p_emitter_index)) p_em = p_emitter_index
compute_jac = .true.
if (present (no_jacobians)) compute_jac = .not. no_jacobians
if (generator%i_fsr_first < 0) &
call msg_fatal ("FSR generator is called for outgoing particles but "&
&"i_fsr_first is not set!")
if (present (xi_y_phi)) then
xi = xi_y_phi(I_XI)
y = xi_y_phi(I_Y)
phi = xi_y_phi(I_PHI)
else
associate (rad_var => generator%real_kinematics)
xi = rad_var%xi_tilde
if (rad_var%supply_xi_max) xi = xi * rad_var%xi_max(i_phs)
y = rad_var%y(i_phs)
phi = rad_var%phi
end associate
end if
nlegborn = size (p_born)
nlegreal = nlegborn + 1
generator%E_gluon = q0 * xi / two
uk_np1 = generator%E_gluon
k_n_born = p_born(p_em)%p(1:3)
uk_n_born = k_n_born**1
generator%mrec2 = (q0 - p_born(p_em)%p(0))**2 &
- space_part_norm(p_born(p_em))**2
if (generator%is_massive(emitter)) then
call generator%compute_emitter_kinematics (y, emitter, &
i_phs, q0, k0_n, uk_n, uk, compute_jac)
else
call generator%compute_emitter_kinematics (y, q0, uk_n, uk)
generator%real_kinematics%y_soft(i_phs) = y
k0_n = uk_n
end if
if (debug_on) call msg_debug2 &
(D_PHASESPACE, "phs_fks_generator_generate_fsr_out")
call debug_input_values ()
vec = uk_n / uk_n_born * k_n_born
vec_orth = create_orthogonal (vec)
p_real(p_em)%p(0) = k0_n
p_real(p_em)%p(1:3) = vec%p(1:3)
cpsi = (uk_n**2 + uk**2 - uk_np1**2) / (two * uk_n * uk)
!!! This is to catch the case where cpsi = 1, but numerically
!!! turns out to be slightly larger than 1.
call check_cpsi_bound (cpsi)
rot = rotation (cpsi, - sqrt (one - cpsi**2), vec_orth)
p_real(p_em) = rot * p_real(p_em)
vec = uk_np1 / uk_n_born * k_n_born
vec_orth = create_orthogonal (vec)
p_real(nlegreal)%p(0) = uk_np1
p_real(nlegreal)%p(1:3) = vec%p(1:3)
cpsi = (uk_np1**2 + uk**2 - uk_n**2) / (two * uk_np1 * uk)
call check_cpsi_bound (cpsi)
rot = rotation (cpsi, sqrt (one - cpsi**2), vec_orth)
p_real(nlegreal) = rot * p_real(nlegreal)
call construct_recoiling_momenta ()
if (compute_jac) call compute_jacobians ()
contains
<<PHS fks: generator generate fsr out procedures>>
end subroutine phs_fks_generator_generate_fsr_out
@ %def phs_fks_generator_generate_fsr_out
@
<<PHS fks: generator generate fsr out procedures>>=
subroutine debug_input_values ()
if (debug2_active (D_PHASESPACE)) then
call generator%write ()
print *, 'emitter = ', emitter
print *, 'p_born:'
call vector4_write_set (p_born)
print *, 'p_real:'
call vector4_write_set (p_real)
print *, 'q0 = ', q0
if (present(p_emitter_index)) then
print *, 'p_emitter_index = ', p_emitter_index
else
print *, 'p_emitter_index not given'
end if
end if
end subroutine debug_input_values
<<PHS fks: generator generate fsr out procedures>>=
subroutine check_cpsi_bound (cpsi)
real(default), intent(inout) :: cpsi
if (cpsi > one) then
cpsi = one
else if (cpsi < -one) then
cpsi = - one
end if
end subroutine check_cpsi_bound
@ Construction of the recoiling momenta. The reshuffling of momenta
must not change the invariant mass of the recoiling system, which
means $k_{\rm{rec}}^2 = \bar{k_{\rm{rec}}}^2$. Therefore, the momenta
are related by a boost, $\bar{k}_i = \Lambda k_i$. The boost parameter
is
\begin{equation*}
\beta = \frac{q^2 - (k_{\rm{rec}}^0 +
\underline{k}_{\rm{rec}})^2}{q^2 + (k_{\rm{rec}}^0 +
\underline{k}_{\rm{rec}})^2}
\end{equation*}
<<PHS fks: generator generate fsr out procedures>>=
subroutine construct_recoiling_momenta ()
type(lorentz_transformation_t) :: lambda
k_rec0 = q0 - p_real(p_em)%p(0) - p_real(nlegreal)%p(0)
if (k_rec0**2 > generator%mrec2) then
uk_rec = sqrt (k_rec0**2 - generator%mrec2)
else
uk_rec = 0
end if
if (generator%is_massive(emitter)) then
beta = compute_beta (q0**2, k_rec0, uk_rec, &
p_born(p_em)%p(0), uk_n_born)
else
beta = compute_beta (q0**2, k_rec0, uk_rec)
end if
k = p_real(p_em)%p(1:3) + p_real(nlegreal)%p(1:3)
vec%p(1:3) = one / uk * k%p(1:3)
lambda = boost (beta / sqrt(one - beta**2), vec)
do i = generator%i_fsr_first, nlegborn
if (i /= p_em) then
p_real(i) = lambda * p_born(i)
end if
end do
vec%p(1:3) = p_born(p_em)%p(1:3) / uk_n_born
rot = rotation (cos(phi), sin(phi), vec)
p_real(nlegreal) = rot * p_real(nlegreal)
p_real(p_em) = rot * p_real(p_em)
end subroutine construct_recoiling_momenta
@ The factor $\frac{q^2}{(4\pi)^3}$ is not included here since it is
supplied during phase space generation. Also, we already divide by
$\xi$.
<<PHS fks: generator generate fsr out procedures>>=
subroutine compute_jacobians ()
associate (jac => generator%real_kinematics%jac(i_phs))
if (generator%is_massive(emitter)) then
jac%jac(1) = jac%jac(1) * four / q0 / uk_n_born / xi
else
k2 = two * uk_n * uk_np1* (one - y)
jac%jac(1) = uk_n**2 / uk_n_born / (uk_n - k2 / (two * q0))
end if
jac%jac(2) = one
jac%jac(3) = one - xi / two * q0 / uk_n_born
end associate
end subroutine compute_jacobians
@ %def compute_jacobians
@
<<PHS fks: phs fks: TBP>>=
procedure :: generate_fsr_in => phs_fks_generate_fsr_in
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generate_fsr_in (phs)
class(phs_fks_t), intent(inout) :: phs
end subroutine phs_fks_generate_fsr_in
<<PHS fks: procedures>>=
module subroutine phs_fks_generate_fsr_in (phs)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), dimension(:), allocatable :: p
p = phs%generator%real_kinematics%p_born_lab%get_momenta &
(1, phs%generator%n_in)
end subroutine phs_fks_generate_fsr_in
@ %def phs_fks_generate_fsr_in
@
<<PHS fks: phs fks: TBP>>=
procedure :: generate_fsr => phs_fks_generate_fsr
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, &
i_con, xi_y_phi, no_jacobians)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(out), dimension(:) :: p_real
integer, intent(in), optional :: i_con
real(default), intent(in), dimension(3), optional :: xi_y_phi
logical, intent(in), optional :: no_jacobians
end subroutine phs_fks_generate_fsr
<<PHS fks: procedures>>=
module subroutine phs_fks_generate_fsr (phs, emitter, i_phs, p_real, &
i_con, xi_y_phi, no_jacobians)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(out), dimension(:) :: p_real
integer, intent(in), optional :: i_con
real(default), intent(in), dimension(3), optional :: xi_y_phi
logical, intent(in), optional :: no_jacobians
type(vector4_t), dimension(:), allocatable :: p
associate (generator => phs%generator)
p = generator%real_kinematics%p_born_cms%phs_point(1)
generator%real_kinematics%supply_xi_max = .true.
if (present (i_con)) then
call generator%generate_fsr (emitter, i_phs, i_con, p, p_real, &
xi_y_phi, no_jacobians)
else
call generator%generate_fsr (emitter, i_phs, p, p_real, &
xi_y_phi, no_jacobians)
end if
generator%real_kinematics%p_real_cms%phs_point(i_phs) = p_real
if (.not. phs%config%lab_is_cm) p_real = phs%lt_cm_to_lab * p_real
generator%real_kinematics%p_real_lab%phs_point(i_phs) = p_real
end associate
end subroutine phs_fks_generate_fsr
@ %def phs_fks_generate_fsr
@
<<PHS fks: phs fks: TBP>>=
procedure :: get_onshell_projected_momenta => &
phs_fks_get_onshell_projected_momenta
<<PHS fks: sub interfaces>>=
pure module function phs_fks_get_onshell_projected_momenta (phs) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(phs_fks_t), intent(in) :: phs
end function phs_fks_get_onshell_projected_momenta
<<PHS fks: procedures>>=
pure module function phs_fks_get_onshell_projected_momenta (phs) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(phs_fks_t), intent(in) :: phs
p = phs%generator%real_kinematics%p_born_onshell%phs_point(1)
end function phs_fks_get_onshell_projected_momenta
@ %def phs_fks_get_onshell_projected_momenta
@
<<PHS fks: phs fks: TBP>>=
procedure :: generate_fsr_threshold => phs_fks_generate_fsr_threshold
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generate_fsr_threshold &
(phs, emitter, i_phs, p_real)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(inout), dimension(:), optional :: p_real
end subroutine phs_fks_generate_fsr_threshold
<<PHS fks: procedures>>=
module subroutine phs_fks_generate_fsr_threshold &
(phs, emitter, i_phs, p_real)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(inout), dimension(:), optional :: p_real
type(vector4_t), dimension(:), allocatable :: p_born
type(vector4_t), dimension(:), allocatable :: pp
integer :: leg
associate (generator => phs%generator)
generator%real_kinematics%supply_xi_max = .true.
allocate (p_born (1 : generator%real_kinematics%p_born_cms%get_n_particles()))
p_born = generator%real_kinematics%p_born_onshell%get_momenta (1)
allocate (pp (size (p_born) + 1))
call generator%generate_fsr_threshold (emitter, i_phs, p_born, pp)
leg = thr_leg (emitter)
call generator%real_kinematics%p_real_onshell(leg)%set_momenta (i_phs, pp)
if (present (p_real)) p_real = pp
end associate
end subroutine phs_fks_generate_fsr_threshold
@ %def phs_fks_generate_fsr_threshold
@
<<PHS fks: phs fks: TBP>>=
generic :: compute_xi_max => &
compute_xi_max_internal, compute_xi_max_with_output
procedure :: compute_xi_max_internal => phs_fks_compute_xi_max_internal
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_compute_xi_max_internal (phs, p, threshold)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), intent(in), dimension(:) :: p
logical, intent(in) :: threshold
end subroutine phs_fks_compute_xi_max_internal
<<PHS fks: procedures>>=
module subroutine phs_fks_compute_xi_max_internal (phs, p, threshold)
class(phs_fks_t), intent(inout) :: phs
type(vector4_t), intent(in), dimension(:) :: p
logical, intent(in) :: threshold
integer :: i_phs, i_con, emitter
do i_phs = 1, size (phs%phs_identifiers)
associate (phs_id => phs%phs_identifiers(i_phs), generator => phs%generator)
emitter = phs_id%emitter
if (threshold) then
call generator%compute_xi_max (emitter, i_phs, p, &
generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter))
else if (allocated (phs_id%contributors)) then
do i_con = 1, size (phs_id%contributors)
call generator%compute_xi_max (emitter, i_phs, p, &
generator%real_kinematics%xi_max(i_phs), i_con = 1)
end do
else
call generator%compute_xi_max (emitter, i_phs, p, &
generator%real_kinematics%xi_max(i_phs))
end if
end associate
end do
end subroutine phs_fks_compute_xi_max_internal
@ %def phs_fks_compute_xi_max
@
<<PHS fks: phs fks: TBP>>=
procedure :: compute_xi_max_with_output => phs_fks_compute_xi_max_with_output
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_compute_xi_max_with_output &
(phs, emitter, i_phs, y, p, xi_max)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: i_phs, emitter
real(default), intent(in) :: y
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(out) :: xi_max
end subroutine phs_fks_compute_xi_max_with_output
<<PHS fks: procedures>>=
module subroutine phs_fks_compute_xi_max_with_output &
(phs, emitter, i_phs, y, p, xi_max)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: i_phs, emitter
real(default), intent(in) :: y
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(out) :: xi_max
call phs%generator%compute_xi_max (emitter, i_phs, p, xi_max, y_in = y)
end subroutine phs_fks_compute_xi_max_with_output
@ %def phs_fks_compute_xi_max_with_output
@
<<PHS fks: phs fks generator: TBP>>=
generic :: compute_emitter_kinematics => &
compute_emitter_kinematics_massless, &
compute_emitter_kinematics_massive
procedure :: compute_emitter_kinematics_massless => &
phs_fks_generator_compute_emitter_kinematics_massless
procedure :: compute_emitter_kinematics_massive => &
phs_fks_generator_compute_emitter_kinematics_massive
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_emitter_kinematics_massless &
(generator, y, q0, uk_em, uk)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: y, q0
real(default), intent(out) :: uk_em, uk
end subroutine phs_fks_generator_compute_emitter_kinematics_massless
module subroutine phs_fks_generator_compute_emitter_kinematics_massive &
(generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: y
integer, intent(in) :: em, i_phs
real(default), intent(in) :: q0
real(default), intent(inout) :: k0_em, uk_em, uk
logical, intent(in) :: compute_jac
end subroutine phs_fks_generator_compute_emitter_kinematics_massive
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_emitter_kinematics_massless &
(generator, y, q0, uk_em, uk)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: y, q0
real(default), intent(out) :: uk_em, uk
real(default) :: k0_np1, q2
k0_np1 = generator%E_gluon
q2 = q0**2
uk_em = (q2 - generator%mrec2 - two * q0 * k0_np1) / &
(two * (q0 - k0_np1 * (one - y)))
uk = sqrt (uk_em**2 + k0_np1**2 + two * uk_em * k0_np1 * y)
end subroutine phs_fks_generator_compute_emitter_kinematics_massless
module subroutine phs_fks_generator_compute_emitter_kinematics_massive &
(generator, y, em, i_phs, q0, k0_em, uk_em, uk, compute_jac)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: y
integer, intent(in) :: em, i_phs
real(default), intent(in) :: q0
real(default), intent(inout) :: k0_em, uk_em, uk
logical, intent(in) :: compute_jac
real(default) :: k0_np1, q2, mrec2, m2
real(default) :: k0_rec_max, k0_em_max, k0_rec, uk_rec
real(default) :: z, z1, z2
k0_np1 = generator%E_gluon
q2 = q0**2
mrec2 = generator%mrec2
m2 = generator%m2(em)
k0_rec_max = (q2 - m2 + mrec2) / (two * q0)
k0_em_max = (q2 + m2 - mrec2) /(two * q0)
z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0
z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0
z = z2 - (z2 - z1) * (one + y) / two
k0_em = k0_em_max - k0_np1 * z
k0_rec = q0 - k0_np1 - k0_em
uk_em = sqrt(k0_em**2 - m2)
uk_rec = sqrt(k0_rec**2 - mrec2)
uk = uk_rec
if (compute_jac) &
generator%real_kinematics%jac(i_phs)%jac = q0 * (z1 - z2) / four * k0_np1
generator%real_kinematics%y_soft(i_phs) = &
(two * q2 * z - q2 - mrec2 + m2) / (sqrt(k0_em_max**2 - m2) * q0) / two
end subroutine phs_fks_generator_compute_emitter_kinematics_massive
@ %def phs_fks_generator_compute_emitter_kinematics
@
<<PHS fks: procedures>>=
function recompute_xi_max (q0, mrec2, m2, y) result (xi_max)
real(default) :: xi_max
real(default), intent(in) :: q0, mrec2, m2, y
real(default) :: q2, k0_np1_max, k0_rec_max
real(default) :: z1, z2, z
q2 = q0**2
k0_rec_max = (q2 - m2 + mrec2) / (two * q0)
z1 = (k0_rec_max + sqrt (k0_rec_max**2 - mrec2)) / q0
z2 = (k0_rec_max - sqrt (k0_rec_max**2 - mrec2)) / q0
z = z2 - (z2 - z1) * (one + y) / 2
k0_np1_max = - (q2 * z**2 - two * q0 * k0_rec_max * z + mrec2) / (two * q0 * z * (one - z))
xi_max = two * k0_np1_max / q0
end function recompute_xi_max
@ %def recompute_xi_max
@
<<PHS fks: procedures>>=
function compute_beta_massless (q2, k0_rec, uk_rec) result (beta)
real(default), intent(in) :: q2, k0_rec, uk_rec
real(default) :: beta
beta = (q2 - (k0_rec + uk_rec)**2) / (q2 + (k0_rec + uk_rec)**2)
end function compute_beta_massless
function compute_beta_massive (q2, k0_rec, uk_rec, &
k0_em_born, uk_em_born) result (beta)
real(default), intent(in) :: q2, k0_rec, uk_rec
real(default), intent(in) :: k0_em_born, uk_em_born
real(default) :: beta
real(default) :: k0_rec_born, uk_rec_born, alpha
k0_rec_born = sqrt(q2) - k0_em_born
uk_rec_born = uk_em_born
alpha = (k0_rec + uk_rec) / (k0_rec_born + uk_rec_born)
beta = (one - alpha**2) / (one + alpha**2)
end function compute_beta_massive
@ %def compute_beta
@ The momentum of the radiated particle is computed according to
\begin{equation}
\label{eq:phs_fks:compute_k_n}
\underline{k}_n = \frac{q^2 - M_{\rm{rec}}^2 -
2q^0\underline{k}_{n+1}}{2(q^0 - \underline{k}_{n+1}(1-y))},
\end{equation}
with $k = k_n + k_{n+1}$ and $M_{\rm{rec}}^2 = k_{\rm{rec}}^2 =
\left(q-k\right)^2$. Because of $\boldsymbol{\bar{k}}_n \parallel
\boldsymbol{k}_n + \boldsymbol{k}_{n+1}$ we find $M_{\rm{rec}}^2 =
\left(q-\bar{k}_n\right)^2$.
Equation \ref{eq:phs_fks:compute_k_n} follows from the fact that
$\left(\boldsymbol{k} - \boldsymbol{k}_n\right)^2 =
\boldsymbol{k}_{n+1}^2$, which is equivalent to $\boldsymbol{k}_n
\cdot \boldsymbol{k} = \frac{1}{2} \left(\underline{k}_n^2 +
\underline{k}^2 - \underline{k}_{n+1}^2\right)$.\\
$\boldsymbol{k}_n$ and $\boldsymbol{k}_{n+1}$ are obtained by first
setting up vectors parallel to $\boldsymbol{\bar{k}}_n$,
\begin{equation*}
\boldsymbol{k}_n' = \underline{k}_n
\frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n}, \quad \pmb{k}_{n+1}'
= \underline{k}_{n+1}\frac{\bar{\pmb{k}}_n}{\underline{\bar{k}}_n},
\end{equation*}
and then rotating these vectors by an amount of $\cos\psi_n =
\frac{\boldsymbol{k}_n\cdot\pmb{k}}{\underline{k}_n \underline{k}}$.
@ The emitted particle cannot have more momentum than the emitter has
in the Born phase space. Thus, there is an upper bound for $\xi$,
determined by the condition $k_{n+1}^0 = \underline{\bar{k}}_n$, which
is equal to
\begin{equation*}
\xi_{\rm{max}} = \frac{2}{\underline{\bar{k}}_n}{q^0}.
\end{equation*}
<<PHS fks: procedures>>=
pure function get_xi_max_fsr_massless (p_born, q0, emitter) result (xi_max)
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in) :: q0
integer, intent(in) :: emitter
real(default) :: xi_max
real(default) :: uk_n_born
uk_n_born = space_part_norm (p_born(emitter))
xi_max = two * uk_n_born / q0
end function get_xi_max_fsr_massless
@ %def get_xi_max_fsr_massless
@ The computation of $\xi_{\rm{max}}$ for massive emitters is described
in arXiv:1202.0465. Let's recapitulate it here.
We consider the Dalitz-domain created by $k_{n+1}^0$, $k_n^0$ and
$k_{\rm{rec}}^0$ and introduce the parameterization
\begin{equation*}
k_n^0 = \bar{k}_n^0 - zk_{n+1}^0
\end{equation*}
Then, for each value of $z$, there exists a maximum value of
$\underline{k}_{n+1}$ from which $\xi_{\rm{max}}$ can be extracted via
$\xi_{\rm{max}} = 2k_{n+1}^0/q$. It is determined by the condition
\begin{equation*}
\underline{k}_{n+1} \pm \underline{k}_n \pm \underline{k}_{\rm{rec}} = 0.
\end{equation*}
This can be manipulated to yield
\begin{equation*}
\left(\underline{k}_{n+1}^2 + \underline{k}_n^2 -
\underline{k}_{\rm{rec}}^2\right)^2 =
4\underline{k}^2_{n+1}\underline{k}_n^2.
\end{equation*}
Here we can use $\underline{k}_n^2 = \left(k_n^0\right)^2 - m^2$ and
$\underline{k}_{\rm{rec}}^2 = \left(q - k_n^0 - k_{n+1}^0\right)^2 -
M_{\rm{rec}}^2$, as well as the above parameterization of $k_n^0$, to
obtain
\begin{equation*}
4\underline{k}_{n+1}^2\left(2\underline{k}_{n+1}qz(1-z) +
q^2z^2 - 2q\bar{k}_{\rm{rec}}^0z + M_{\rm{rec}}^2\right) = 0.
\end{equation*}
Solving for $k_{n+1}^0$ gives
\begin{equation}
k_{n+1}^0 = \frac{2q\bar{k}^0_{\rm{rec}}z - q^2z^2 - M_{\rm{rec}}^2}{2qz(1-z)}.
\label{XiMaxMassive}
\end{equation}
It is still open how to compute $z$. For this, consider that the
right-hand-side of equation (\ref{XiMaxMassive}) vanishes for
\begin{equation*}
z_{1,2} = \left(\bar{k}_{\rm{rec}}^0 \pm
\sqrt{\left(\bar{k}_{\rm{rec}}^0\right)^2 - M_{\rm{rec}}^2}\right)/q,
\end{equation*}
which corresponds to the borders of the Dalitz-region where the gluon
momentum vanishes. Thus we define
\begin{equation*}
z = z_2 - \frac{1}{2} (z_2 - z_1)(1+y).
\end{equation*}
<<PHS fks: procedures>>=
pure function get_xi_max_fsr_massive (p_born, q0, emitter, m2, y) result (xi_max)
real(default) :: xi_max
type(vector4_t), intent(in), dimension(:) :: p_born
real(default), intent(in) :: q0
integer, intent(in) :: emitter
real(default), intent(in) :: m2, y
real(default) :: mrec2
real(default) :: k0_rec_max
real(default) :: z, z1, z2
real(default) :: k0_np1_max
associate (p => p_born(emitter)%p)
mrec2 = (q0 - p(0))**2 - p(1)**2 - p(2)**2 - p(3)**2
end associate
call compute_dalitz_bounds (q0, m2, mrec2, z1, z2, k0_rec_max)
z = z2 - (z2 - z1) * (one + y) / two
k0_np1_max = - (q0**2 * z**2 - two * q0 * k0_rec_max * z + mrec2) &
/ (two * q0 * z * (one - z))
xi_max = two * k0_np1_max / q0
end function get_xi_max_fsr_massive
@ %def get_xi_max_fsr_massive
@
<<PHS fks: parameters>>=
integer, parameter, public :: I_PLUS = 1
integer, parameter, public :: I_MINUS = 2
@ %def parameters
@ Computes $\xi_{\text{max}}$ in the case of ISR as documented in eq. \ref{eqn:xi_max_isr}.
It is also used for the POWHEG matching.
<<PHS fks: public>>=
public :: get_xi_max_isr
<<PHS fks: sub interfaces>>=
module function get_xi_max_isr (xb, y) result (xi_max)
real(default) :: xi_max
real(default), dimension(2), intent(in) :: xb
real(default), intent(in) :: y
end function get_xi_max_isr
<<PHS fks: procedures>>=
module function get_xi_max_isr (xb, y) result (xi_max)
real(default) :: xi_max
real(default), dimension(2), intent(in) :: xb
real(default), intent(in) :: y
xi_max = one - max (xi_max_isr_plus (xb(I_PLUS), y), xi_max_isr_minus (xb(I_MINUS), y))
contains
function xi_max_isr_plus (x, y)
real(default) :: xi_max_isr_plus
real(default), intent(in) :: x, y
real(default) :: deno
deno = sqrt ((one + x**2)**2 * (one - y)**2 + 16 * y * x**2) + (one - y) * (1 - x**2)
xi_max_isr_plus = two * (one + y) * x**2 / deno
end function xi_max_isr_plus
function xi_max_isr_minus (x, y)
real(default) :: xi_max_isr_minus
real(default), intent(in) :: x, y
real(default) :: deno
deno = sqrt ((one + x**2)**2 * (one + y)**2 - 16 * y * x**2) + (one + y) * (1 - x**2)
xi_max_isr_minus = two * (one - y) * x**2 / deno
end function xi_max_isr_minus
end function get_xi_max_isr
@ %def get_xi_max_isr
@
<<PHS fks: procedures>>=
recursive function get_xi_max_isr_decay (p) result (xi_max)
real(default) :: xi_max
type(vector4_t), dimension(:), intent(in) :: p
integer :: n_tot
type(vector4_t), dimension(:), allocatable :: p_dec_new
n_tot = size (p)
if (n_tot == 3) then
xi_max = xi_max_one_to_two (p(1), p(2), p(3))
else
allocate (p_dec_new (n_tot - 1))
p_dec_new(1) = sum (p (3 : ))
p_dec_new(2 : n_tot - 1) = p (3 : n_tot)
xi_max = min (xi_max_one_to_two (p(1), p(2), sum(p(3 : ))), &
get_xi_max_isr_decay (p_dec_new))
end if
contains
function xi_max_one_to_two (p_in, p_out1, p_out2) result (xi_max)
real(default) :: xi_max
type(vector4_t), intent(in) :: p_in, p_out1, p_out2
real(default) :: m_in, m_out1, m_out2
m_in = p_in**1
m_out1 = p_out1**1; m_out2 = p_out2**1
xi_max = one - (m_out1 + m_out2)**2 / m_in**2
end function xi_max_one_to_two
end function get_xi_max_isr_decay
@ %def get_xi_max_isr_decay
@
\subsection{Creation of the real phase space - ISR}
<<PHS fks: phs fks: TBP>>=
procedure :: generate_isr => phs_fks_generate_isr
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generate_isr (phs, i_phs, p_real)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: i_phs
type(vector4_t), intent(out), dimension(:) :: p_real
end subroutine phs_fks_generate_isr
<<PHS fks: procedures>>=
module subroutine phs_fks_generate_isr (phs, i_phs, p_real)
class(phs_fks_t), intent(inout) :: phs
integer, intent(in) :: i_phs
type(vector4_t), intent(out), dimension(:) :: p_real
type(vector4_t) :: p0, p1
type(lorentz_transformation_t) :: lt
real(default) :: sqrts_hat
type(vector4_t), dimension(:), allocatable :: p_work
associate (generator => phs%generator)
select case (generator%n_in)
case (1)
p_work = generator%real_kinematics%p_born_cms%phs_point(1)
call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real)
phs%config%lab_is_cm = .true.
case (2)
select case (generator%isr_kinematics%isr_mode)
case (SQRTS_FIXED)
p_work = generator%real_kinematics%p_born_cms%phs_point(1)
call generator%generate_isr_fixed_beam_energy (i_phs, p_work, p_real)
case (SQRTS_VAR)
p_work = generator%real_kinematics%p_born_lab%phs_point(1)
call generator%generate_isr (i_phs, p_work, p_real)
end select
end select
generator%real_kinematics%p_real_lab%phs_point(i_phs) = p_real
if (.not. phs%config%lab_is_cm) then
sqrts_hat = (p_real(1) + p_real(2))**1
p0 = p_real(1) + p_real(2)
lt = boost (p0, sqrts_hat)
p1 = inverse(lt) * p_real(1)
lt = lt * rotation_to_2nd (3, space_part (p1))
phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) &
= inverse (lt) * p_real
else
phs%generator%real_kinematics%p_real_cms%phs_point(i_phs) &
= p_real
end if
end associate
end subroutine phs_fks_generate_isr
@ %def phs_fks_generate_isr
@ The real phase space for an inital-state emission involved in a decay
process is generated by first setting the gluon momentum like in the
scattering case by using its angular coordinates $y$ and $\phi$ and then
adjusting the gluon energy with $\xi$. The emitter momentum is kept
identical to the Born case, i.e. $p_{\rm{in}} = \bar{p}_{\rm{in}}$, so
that after the emission it has momentum $p_{\rm{virt}} = p_{\rm{in}} -
p_{\rm{g}}$ and invariant mass $m^2 = p_{\rm{virt}}^2$. Note that the
final state momenta have to remain on-shell, so that $p_1^2 =
\bar{p}_1^2 = m_1^2$ and $p_2^2 = \bar{p}_2^2 = m_2^2$. Let $\Lambda$ be
the boost from into the rest frame of the emitter after emission, i.e.
$\Lambda p_{\rm{virt}} = \left(m, 0, 0, 0\right)$. In this reference
frame, the spatial components of the final-state momenta sum up to zero,
and their magnitude is
\begin{equation*}
p = \frac{\sqrt {\lambda (m^2, m_1^2, m_2^2)}}{2m},
\end{equation*}
a fact already used in the evaluation of the phase space trees of
[[phs_forest]]. Obviously, from this, the final-state energies can be
deferred via $E_i^2 = m_i^2 - p^2$. In the next step, the $p_{1,2}$ are
set up as vectors $(E,0,0,\pm p)$ along the z-axis and then rotated
about the same azimuthal and polar angles as in the Born system.
Finally, the momenta are boosted out of the rest frame by multiplying
with $\Lambda$.
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_isr_fixed_beam_energy => &
phs_fks_generator_generate_isr_fixed_beam_energy
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_isr_fixed_beam_energy &
(generator, i_phs, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
end subroutine phs_fks_generator_generate_isr_fixed_beam_energy
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_isr_fixed_beam_energy &
(generator, i_phs, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
real(default) :: xi_max, xi, y, phi
integer :: nlegborn, nlegreal, i
real(default) :: k0_np1
real(default) :: msq_in
type(vector4_t) :: p_virt
real(default) :: jac_real
associate (rad_var => generator%real_kinematics)
xi_max = rad_var%xi_max(i_phs)
xi = rad_var%xi_tilde * xi_max
y = rad_var%y(i_phs)
phi = rad_var%phi
rad_var%y_soft(i_phs) = y
end associate
nlegborn = size (p_born)
nlegreal = nlegborn + 1
msq_in = sum (p_born(1:generator%n_in))**2
generator%real_kinematics%jac(i_phs)%jac = one
p_real(1) = p_born(1)
if (generator%n_in > 1) p_real(2) = p_born(2)
k0_np1 = zero
do i = 1, generator%n_in
k0_np1 = k0_np1 + p_real(i)%p(0) * xi / two
end do
p_real(nlegreal)%p(0) = k0_np1
p_real(nlegreal)%p(1) = k0_np1 * sqrt(one - y**2) * sin(phi)
p_real(nlegreal)%p(2) = k0_np1 * sqrt(one - y**2) * cos(phi)
p_real(nlegreal)%p(3) = k0_np1 * y
p_virt = sum (p_real(1:generator%n_in)) - p_real(nlegreal)
jac_real = one
call generate_on_shell_decay (p_virt, &
p_born(generator%n_in + 1 : nlegborn), &
p_real(generator%n_in + 1 : nlegreal - 1), 1, msq_in, jac_real)
associate (jac => generator%real_kinematics%jac(i_phs))
jac%jac(1) = jac_real
jac%jac(2) = one
end associate
end subroutine phs_fks_generator_generate_isr_fixed_beam_energy
@ %def phs_fks_generator_generate_isr_fixed_beam_energy
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_isr_factorized => &
phs_fks_generator_generate_isr_factorized
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_isr_factorized &
(generator, i_phs, emitter, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs, emitter
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
end subroutine phs_fks_generator_generate_isr_factorized
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_isr_factorized &
(generator, i_phs, emitter, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs, emitter
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
type(vector4_t), dimension(3) :: p_tmp_born
type(vector4_t), dimension(4) :: p_tmp_real
type(vector4_t) :: p_top
type(lorentz_transformation_t) :: boost_to_rest_frame
integer, parameter :: nlegreal = 7
!!! Factorized phase space so far only required for ee -> bwbw
p_tmp_born = vector4_null; p_tmp_real = vector4_null
p_real(1:2) = p_born(1:2)
if (emitter == THR_POS_B) then
p_top = p_born (THR_POS_WP) + p_born (THR_POS_B)
p_tmp_born(2) = p_born (THR_POS_WP)
p_tmp_born(3) = p_born (THR_POS_B)
else if (emitter == THR_POS_BBAR) then
p_top = p_born (THR_POS_WM) + p_born (THR_POS_BBAR)
p_tmp_born(2) = p_born (THR_POS_WM)
p_tmp_born(3) = p_born (THR_POS_BBAR)
else
call msg_fatal ("Threshold computation requires emitters to be at position 5 and 6 " // &
"Please check if your process specification fulfills this requirement.")
end if
p_tmp_born (1) = p_top
boost_to_rest_frame = inverse (boost (p_top, p_top**1))
p_tmp_born = boost_to_rest_frame * p_tmp_born
call generator%compute_xi_max_isr_factorized (i_phs, p_tmp_born)
call generator%generate_isr_fixed_beam_energy &
(i_phs, p_tmp_born, p_tmp_real)
p_tmp_real = inverse (boost_to_rest_frame) * p_tmp_real
if (emitter == THR_POS_B) then
p_real(THR_POS_WP) = p_tmp_real(2)
p_real(THR_POS_B) = p_tmp_real(3)
p_real(THR_POS_WM) = p_born(THR_POS_WM)
p_real(THR_POS_BBAR) = p_born(THR_POS_BBAR)
!!! Exception has been handled above
else
p_real(THR_POS_WM) = p_tmp_real(2)
p_real(THR_POS_BBAR) = p_tmp_real(3)
p_real(THR_POS_WP) = p_born(THR_POS_WP)
p_real(THR_POS_B) = p_born(THR_POS_B)
end if
p_real(nlegreal) = p_tmp_real(4)
end subroutine phs_fks_generator_generate_isr_factorized
@ %def phs_fks_generator_generate_isr_factorized
@ Construction of the real momenta [[p_real]] in case of ISR.
Follows the discussion in [0709.2092] sec. 5.1.
The sequence of Lorentz boosts required to construct [[p_real]] from
[[p_born]] is as follows:
\begin{enumerate}
\item[\labelitemii] We construct the IS momenta of [[p_real]] from
the Born momenta via rescaling:
[[p_real(1:2)]] $= \frac{x}{\overline{x}} \cdot$ [[p_born(1:2)]].
If the Born momenta are imported in the lab frame, these will define
the real lab frame.
\item[\labelitemii] We construct the momentum of the radiated
particle in the real CMS:
$k_{n+1} = \frac{s \xi}{2} \cdot (1, \sin(\theta) \sin(\phi),
\sin(\theta) \cos(\phi), \cos(\theta))$
\setcounter{enumi}{-1}
\item We first boost the momentum of the radiated particle from the
real CMS to the real lab frame determined from [[p_real(1:2)]].
\item We initialize the non-radiated real FS momenta by a
longitudinal boost of [[p_born]] to a system with zero rapidity,
i.e. zero longitudinal momenum. This is $\mathbb{B}_L$.
\item We boost these momenta in a transverse direction to compensate
the transverse momentum of the radiation. This is
$\mathbb{B}_T$. Note: we switched $\mathbb{B}_T$ and
$\mathbb{B}^{-1}_T$ in Eq. (5.16) and their definition
w.r.t. [0709.2092].
\item We restore longitudinal momentum conservation by applying the
inverse boost of $\mathbb{B}_L$ to all non-radiated real FS momenta.
\end{enumerate}
This way, all components of [[p_real]] are constructed in the real Lab frame.
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_isr => phs_fks_generator_generate_isr
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_isr &
(generator, i_phs, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs
type(vector4_t), intent(in) , dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
end subroutine phs_fks_generator_generate_isr
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_isr &
(generator, i_phs, p_born, p_real)
!!! Important: Import Born momenta in the lab frame
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs
type(vector4_t), intent(in) , dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
real(default) :: xi_max, xi_tilde, xi, y, phi
integer :: nlegborn, nlegreal
real(default) :: sqrts_real
real(default) :: k0_np1
type(lorentz_transformation_t) :: &
lambda_transv, lambda_longit, lambda_longit_inv
real(default) :: x_plus, x_minus, xb_plus, xb_minus
real(default) :: onemy, onepy
integer :: i
real(default) :: xi_plus, xi_minus
real(default) :: beta_gamma
type(vector3_t) :: beta_vec
associate (rad_var => generator%real_kinematics)
xi_max = rad_var%xi_max(i_phs)
xi_tilde = rad_var%xi_tilde
xi = xi_tilde * xi_max
y = rad_var%y(i_phs)
onemy = one - y; onepy = one + y
phi = rad_var%phi
rad_var%y_soft(i_phs) = y
end associate
nlegborn = size (p_born)
nlegreal = nlegborn + 1
generator%isr_kinematics%sqrts_born = (p_born(1) + p_born(2))**1
!!! Initial state real momenta
xb_plus = generator%isr_kinematics%x(I_PLUS)
xb_minus = generator%isr_kinematics%x(I_MINUS)
x_plus = xb_plus / sqrt(one - xi) * sqrt ((two - xi * onemy) / &
(two - xi * onepy))
x_minus = xb_minus / sqrt(one - xi) * sqrt ((two - xi * onepy) / &
(two - xi * onemy))
xi_plus = xi_tilde * (one - xb_plus)
xi_minus = xi_tilde * (one - xb_minus)
p_real(I_PLUS) = x_plus / xb_plus * p_born(I_PLUS)
p_real(I_MINUS) = x_minus / xb_minus * p_born(I_MINUS)
!!! Fraction of momentum fractions in a collinear splitting
generator%isr_kinematics%z(I_PLUS) = (one - xi_plus)
generator%isr_kinematics%z(I_MINUS) = (one - xi_minus)
!!! Create radiation momentum in the real CMS
sqrts_real = generator%isr_kinematics%sqrts_born / sqrt (one - xi)
k0_np1 = sqrts_real * xi / two
p_real(nlegreal)%p(0) = k0_np1
p_real(nlegreal)%p(1) = k0_np1 * sqrt (one - y**2) * sin(phi)
p_real(nlegreal)%p(2) = k0_np1 * sqrt (one - y**2) * cos(phi)
p_real(nlegreal)%p(3) = k0_np1 * y
!!! Boosts the radiation from real CMS to the real LAB frame
call get_boost_parameters (p_real, beta_gamma, beta_vec)
lambda_longit = create_longitudinal_boost &
(beta_gamma, beta_vec, inverse = .true.)
p_real(nlegreal) = lambda_longit * p_real(nlegreal)
call get_boost_parameters (p_born, beta_gamma, beta_vec)
lambda_longit = create_longitudinal_boost &
(beta_gamma, beta_vec, inverse = .false.)
forall (i = 3 : nlegborn) p_real(i) = lambda_longit * p_born(i)
lambda_transv = create_transversal_boost (p_real(nlegreal), xi, sqrts_real)
forall (i = 3 : nlegborn) p_real(i) = lambda_transv * p_real(i)
lambda_longit_inv = create_longitudinal_boost &
(beta_gamma, beta_vec, inverse = .true.)
forall (i = 3 : nlegborn) p_real(i) = lambda_longit_inv * p_real(i)
!!! Compute Jacobians
associate (jac => generator%real_kinematics%jac(i_phs))
!!! Additional 1 / (1 - xi) factor because in the real jacobian,
!!! there is s_real in the numerator
!!! We also have to adapt the flux factor, which is 1/(2s_real) for
!!! the real component
!!! The reweighting factor is s_born / s_real, cancelling the
!!! (1-xi) factor from above
jac%jac(1) = one / (one - xi)
jac%jac(2) = one
jac%jac(3) = one / (one - xi_plus)**2
jac%jac(4) = one / (one - xi_minus)**2
end associate
contains
subroutine get_boost_parameters (p, beta_gamma, beta_vec)
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(out) :: beta_gamma
type(vector3_t), intent(out) :: beta_vec
beta_vec = (p(1)%p(1:3) + p(2)%p(1:3)) / (p(1)%p(0) + p(2)%p(0))
beta_gamma = beta_vec**1 / sqrt (one - beta_vec**2)
beta_vec = beta_vec / beta_vec**1
end subroutine get_boost_parameters
function create_longitudinal_boost &
(beta_gamma, beta_vec, inverse) result (lambda)
real(default), intent(in) :: beta_gamma
type(vector3_t), intent(in) :: beta_vec
logical, intent(in) :: inverse
type(lorentz_transformation_t) :: lambda
if (inverse) then
lambda = boost (beta_gamma, beta_vec)
else
lambda = boost (-beta_gamma, beta_vec)
end if
end function create_longitudinal_boost
function create_transversal_boost (p_rad, xi, sqrts_real) result (lambda)
type(vector4_t), intent(in) :: p_rad
real(default), intent(in) :: xi, sqrts_real
type(lorentz_transformation_t) :: lambda
type(vector3_t) :: vec_transverse
real(default) :: pt2, beta, beta_gamma
pt2 = transverse_part (p_rad)**2
beta = one / sqrt (one + sqrts_real**2 * (one - xi) / pt2)
beta_gamma = beta / sqrt (one - beta**2)
vec_transverse%p(1:2) = p_rad%p(1:2)
vec_transverse%p(3) = zero
vec_transverse = normalize (vec_transverse)
lambda = boost (-beta_gamma, vec_transverse)
end function create_transversal_boost
end subroutine phs_fks_generator_generate_isr
@ %def phs_fks_generator_generate_isr
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: set_sqrts_hat => phs_fks_generator_set_sqrts_hat
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: sqrts
end subroutine phs_fks_generator_set_sqrts_hat
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_set_sqrts_hat (generator, sqrts)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: sqrts
generator%sqrts = sqrts
end subroutine phs_fks_generator_set_sqrts_hat
@ %def phs_fks_generator_set_sqrts_hat
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: set_emitters => phs_fks_generator_set_emitters
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_set_emitters (generator, emitters)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in), dimension(:), allocatable :: emitters
end subroutine phs_fks_generator_set_emitters
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_set_emitters (generator, emitters)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in), dimension(:), allocatable :: emitters
allocate (generator%emitters (size (emitters)))
generator%emitters = emitters
end subroutine phs_fks_generator_set_emitters
@ %def phs_fks_generator_set_emitters
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: setup_masses => phs_fks_generator_setup_masses
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_setup_masses (generator, n_tot)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: n_tot
end subroutine phs_fks_generator_setup_masses
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_setup_masses (generator, n_tot)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: n_tot
if (.not. allocated (generator%m2)) then
allocate (generator%is_massive (n_tot))
allocate (generator%m2 (n_tot))
generator%is_massive = .false.
generator%m2 = zero
end if
end subroutine phs_fks_generator_setup_masses
@ %def phs_fks_generator_setup_masses
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: set_xi_and_y_bounds => phs_fks_generator_set_xi_and_y_bounds
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_set_xi_and_y_bounds &
(generator, fks_xi_min, fks_y_max)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in), optional :: fks_xi_min, fks_y_max
end subroutine phs_fks_generator_set_xi_and_y_bounds
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_set_xi_and_y_bounds &
(generator, fks_xi_min, fks_y_max)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in), optional :: fks_xi_min, fks_y_max
real(default) :: xi_min, y_max
xi_min = zero; y_max = one
if (present (fks_xi_min)) xi_min = fks_xi_min
if (present (fks_y_max)) y_max = fks_y_max
generator%xi_min = min (one, max (xi_min, tiny_07))
generator%y_max = min (abs (y_max), one)
end subroutine phs_fks_generator_set_xi_and_y_bounds
@ %def phs_fks_generator_set_xi_and_y_bounds
@ Sets [[x]] in the [[isr_kinematics]] of the generator.
<<PHS fks: phs fks generator: TBP>>=
procedure :: set_isr_kinematics => phs_fks_generator_set_isr_kinematics
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_set_isr_kinematics (generator, p)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), dimension(2), intent(in) :: p
end subroutine phs_fks_generator_set_isr_kinematics
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_set_isr_kinematics (generator, p)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), dimension(2), intent(in) :: p
if (allocated (generator%isr_kinematics%beam_energy)) then
select case (size (generator%isr_kinematics%beam_energy))
case (1)
generator%isr_kinematics%x = p%p(0) / &
generator%isr_kinematics%beam_energy(1)
case (2)
generator%isr_kinematics%x = p%p(0) / &
generator%isr_kinematics%beam_energy
end select
else
generator%isr_kinematics%x = 0
end if
end subroutine phs_fks_generator_set_isr_kinematics
@ %def phs_fks_generator_set_isr_kinematics
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_radiation_variables => &
phs_fks_generator_generate_radiation_variables
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_radiation_variables &
(generator, r_in, p_born, phs_identifiers, threshold)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in), dimension(:) :: r_in
type(vector4_t), intent(in), dimension(:) :: p_born
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
logical, intent(in), optional :: threshold
end subroutine phs_fks_generator_generate_radiation_variables
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_radiation_variables &
(generator, r_in, p_born, phs_identifiers, threshold)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in), dimension(:) :: r_in
type(vector4_t), intent(in), dimension(:) :: p_born
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
logical, intent(in), optional :: threshold
associate (rad_var => generator%real_kinematics)
rad_var%phi = r_in (I_PHI) * twopi
select case (generator%mode)
case (GEN_REAL_PHASE_SPACE)
rad_var%jac_rand = twopi
call generator%compute_y_real_phs (r_in(I_Y), p_born, phs_identifiers, &
rad_var%jac_rand, rad_var%y, threshold)
case (GEN_SOFT_MISMATCH)
rad_var%jac_mismatch = twopi
call generator%compute_y_mismatch (r_in(I_Y), rad_var%jac_mismatch, &
rad_var%y_mismatch, rad_var%y_soft)
case default
call generator%compute_y_test (rad_var%y)
end select
call generator%compute_xi_tilde (r_in(I_XI))
call generator%set_masses (p_born, phs_identifiers)
end associate
end subroutine phs_fks_generator_generate_radiation_variables
@ %def phs_fks_generator_generate_radiation_variables
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_xi_ref_momenta => &
phs_fks_generator_compute_xi_ref_momenta
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_xi_ref_momenta &
(generator, p_born, resonance_contributors)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), intent(in), dimension(:) :: p_born
type(resonance_contributors_t), intent(in), dimension(:), optional &
:: resonance_contributors
end subroutine phs_fks_generator_compute_xi_ref_momenta
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_xi_ref_momenta &
(generator, p_born, resonance_contributors)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), intent(in), dimension(:) :: p_born
type(resonance_contributors_t), intent(in), dimension(:), optional &
:: resonance_contributors
integer :: i_con, n_contributors
if (present (resonance_contributors)) then
n_contributors = size (resonance_contributors)
if (.not. allocated (generator%resonance_contributors)) &
allocate (generator%resonance_contributors (n_contributors))
do i_con = 1, n_contributors
generator%real_kinematics%xi_ref_momenta(i_con) = &
get_resonance_momentum (p_born, resonance_contributors(i_con)%c)
generator%resonance_contributors(i_con) = &
resonance_contributors(i_con)
end do
else
generator%real_kinematics%xi_ref_momenta(1) = &
sum (p_born(1:generator%n_in))
end if
end subroutine phs_fks_generator_compute_xi_ref_momenta
@ %def phs_fks_generator_compute_xi_ref_momenta
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_xi_ref_momenta_threshold &
=> phs_fks_generator_compute_xi_ref_momenta_threshold
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_xi_ref_momenta_threshold &
(generator, p_born)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), intent(in), dimension(:) :: p_born
end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_xi_ref_momenta_threshold &
(generator, p_born)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), intent(in), dimension(:) :: p_born
generator%real_kinematics%xi_ref_momenta(1) = &
p_born(THR_POS_WP) + p_born(THR_POS_B)
generator%real_kinematics%xi_ref_momenta(2) = &
p_born(THR_POS_WM) + p_born(THR_POS_BBAR)
end subroutine phs_fks_generator_compute_xi_ref_momenta_threshold
@ %def phs_fks_generator_compute_xi_ref_momenta_threshold
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_cms_energy => phs_fks_generator_compute_cms_energy
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_cms_energy (generator, p_born)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), intent(in), dimension(:) :: p_born
end subroutine phs_fks_generator_compute_cms_energy
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_cms_energy (generator, p_born)
class(phs_fks_generator_t), intent(inout) :: generator
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t) :: p_sum
p_sum = sum (p_born (1 : generator%n_in))
generator%real_kinematics%cms_energy2 = p_sum**2
end subroutine phs_fks_generator_compute_cms_energy
@ %def phs_fks_generator_compute_cms_energy
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_xi_max => phs_fks_generator_compute_xi_max
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_xi_max (generator, emitter, &
i_phs, p, xi_max, i_con, y_in)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs, emitter
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(out) :: xi_max
integer, intent(in), optional :: i_con
real(default), intent(in), optional :: y_in
end subroutine phs_fks_generator_compute_xi_max
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_xi_max (generator, emitter, &
i_phs, p, xi_max, i_con, y_in)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs, emitter
type(vector4_t), intent(in), dimension(:) :: p
real(default), intent(out) :: xi_max
integer, intent(in), optional :: i_con
real(default), intent(in), optional :: y_in
real(default) :: q0
type(vector4_t), dimension(:), allocatable :: pp, pp_decay
type(vector4_t) :: p_res
type(lorentz_transformation_t) :: L_to_resonance
real(default) :: y
if (.not. any (generator%emitters == emitter)) return
allocate (pp (size (p)))
associate (rad_var => generator%real_kinematics)
if (present (i_con)) then
q0 = rad_var%xi_ref_momenta(i_con)**1
else
q0 = energy (sum (p(1:generator%n_in)))
end if
if (present (y_in)) then
y = y_in
else
y = rad_var%y(i_phs)
end if
if (present (i_con)) then
p_res = rad_var%xi_ref_momenta(i_con)
L_to_resonance = inverse (boost (p_res, q0))
pp = L_to_resonance * p
else
pp = p
end if
if (emitter <= generator%n_in) then
select case (generator%isr_kinematics%isr_mode)
case (SQRTS_FIXED)
if (generator%n_in > 1) then
allocate (pp_decay (size (pp) - 1))
else
allocate (pp_decay (size (pp)))
end if
pp_decay (1) = sum (pp(1:generator%n_in))
pp_decay (2 : ) = pp (generator%n_in + 1 : )
xi_max = get_xi_max_isr_decay (pp_decay)
deallocate (pp_decay)
case (SQRTS_VAR)
xi_max = get_xi_max_isr (generator%isr_kinematics%x, y)
end select
else
if (generator%is_massive(emitter)) then
xi_max = get_xi_max_fsr (pp, q0, emitter, generator%m2(emitter), y)
else
xi_max = get_xi_max_fsr (pp, q0, emitter)
end if
end if
deallocate (pp)
end associate
end subroutine phs_fks_generator_compute_xi_max
@ %def phs_fks_generator_compute_xi_max
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_xi_max_isr_factorized &
=> phs_fks_generator_compute_xi_max_isr_factorized
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_xi_max_isr_factorized &
(generator, i_phs, p)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs
type(vector4_t), intent(in), dimension(:) :: p
end subroutine phs_fks_generator_compute_xi_max_isr_factorized
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_xi_max_isr_factorized &
(generator, i_phs, p)
class(phs_fks_generator_t), intent(inout) :: generator
integer, intent(in) :: i_phs
type(vector4_t), intent(in), dimension(:) :: p
generator%real_kinematics%xi_max(i_phs) = get_xi_max_isr_decay (p)
end subroutine phs_fks_generator_compute_xi_max_isr_factorized
@ %def phs_fks_generator_compute_xi_max_isr_factorized
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: set_masses => phs_fks_generator_set_masses
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_set_masses &
(generator, p, phs_identifiers)
class(phs_fks_generator_t), intent(inout) :: generator
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
type(vector4_t), intent(in), dimension(:) :: p
end subroutine phs_fks_generator_set_masses
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_set_masses &
(generator, p, phs_identifiers)
class(phs_fks_generator_t), intent(inout) :: generator
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
type(vector4_t), intent(in), dimension(:) :: p
integer :: emitter, i_phs
do i_phs = 1, size (phs_identifiers)
emitter = phs_identifiers(i_phs)%emitter
if (any (generator%emitters == emitter) .and. emitter > 0) then
if (generator%is_massive (emitter) .and. emitter > generator%n_in) &
generator%m2(emitter) = p(emitter)**2
end if
end do
end subroutine phs_fks_generator_set_masses
@ %def phs_fhs_generator_set_masses
@
<<PHS fks: public>>=
public :: compute_y_from_emitter
<<PHS fks: sub interfaces>>=
module subroutine compute_y_from_emitter (r_y, p, n_in, emitter, &
massive, y_max, jac_rand, y, contributors, threshold)
real(default), intent(in) :: r_y
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: n_in
integer, intent(in) :: emitter
logical, intent(in) :: massive
real(default), intent(in) :: y_max
real(default), intent(inout) :: jac_rand
real(default), intent(out) :: y
integer, intent(in), dimension(:), allocatable, optional :: contributors
logical, intent(in), optional :: threshold
end subroutine compute_y_from_emitter
<<PHS fks: procedures>>=
module subroutine compute_y_from_emitter (r_y, p, n_in, emitter, &
massive, y_max, jac_rand, y, contributors, threshold)
real(default), intent(in) :: r_y
type(vector4_t), intent(in), dimension(:) :: p
integer, intent(in) :: n_in
integer, intent(in) :: emitter
logical, intent(in) :: massive
real(default), intent(in) :: y_max
real(default), intent(inout) :: jac_rand
real(default), intent(out) :: y
integer, intent(in), dimension(:), allocatable, optional :: contributors
logical, intent(in), optional :: threshold
logical :: thr, resonance
type(vector4_t) :: p_res, p_em
real(default) :: q0
type(lorentz_transformation_t) :: boost_to_resonance
integer :: i
real(default) :: beta, one_m_beta, one_p_beta
thr = .false.; if (present (threshold)) thr = threshold
p_res = vector4_null
if (present (contributors)) then
resonance = allocated (contributors)
else
resonance = .false.
end if
if (massive) then
if (resonance) then
do i = 1, size (contributors)
p_res = p_res + p(contributors(i))
end do
else if (thr) then
p_res = p(ass_boson(thr_leg(emitter))) + p(ass_quark(thr_leg(emitter)))
else
p_res = sum (p(1:n_in))
end if
q0 = p_res**1
boost_to_resonance = inverse (boost (p_res, q0))
p_em = boost_to_resonance * p(emitter)
beta = beta_emitter (q0, p_em)
one_m_beta = one - beta
one_p_beta = one + beta
y = one / beta * (one - one_p_beta * &
exp ( - r_y * log(one_p_beta / one_m_beta)))
jac_rand = jac_rand * &
(one - beta * y) * log(one_p_beta / one_m_beta) / beta
else
y = (one - two * r_y) * y_max
jac_rand = jac_rand * 3 * (one - y**2) * y_max
y = 1.5_default * (y - y**3 / 3)
end if
end subroutine compute_y_from_emitter
@ %def compute_y_from_emitter
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_y_real_phs => phs_fks_generator_compute_y_real_phs
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_y_real_phs &
(generator, r_y, p, phs_identifiers, &
jac_rand, y, threshold)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: r_y
type(vector4_t), intent(in), dimension(:) :: p
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
real(default), intent(inout), dimension(:) :: jac_rand
real(default), intent(out), dimension(:) :: y
logical, intent(in), optional :: threshold
end subroutine phs_fks_generator_compute_y_real_phs
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_y_real_phs &
(generator, r_y, p, phs_identifiers, &
jac_rand, y, threshold)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: r_y
type(vector4_t), intent(in), dimension(:) :: p
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
real(default), intent(inout), dimension(:) :: jac_rand
real(default), intent(out), dimension(:) :: y
logical, intent(in), optional :: threshold
- real(default) :: beta, one_p_beta, one_m_beta
- type(lorentz_transformation_t) :: boost_to_resonance
- real(default) :: q0
- type(vector4_t) :: p_res, p_em
integer :: i, i_phs, emitter
logical :: thr
logical :: construct_massive_fsr
construct_massive_fsr = .false.
thr = .false.; if (present (threshold)) thr = threshold
do i_phs = 1, size (phs_identifiers)
emitter = phs_identifiers(i_phs)%emitter
!!! We need this additional check because of decay phase spaces
!!! t -> bW has a massive emitter at position 1, which should
!!! not be treated here.
construct_massive_fsr = emitter > generator%n_in
if (construct_massive_fsr) construct_massive_fsr = &
construct_massive_fsr .and. generator%is_massive (emitter)
call compute_y_from_emitter (r_y, p, generator%n_in, &
emitter, construct_massive_fsr, &
generator%y_max, jac_rand(i_phs), y(i_phs), &
phs_identifiers(i_phs)%contributors, threshold)
end do
end subroutine phs_fks_generator_compute_y_real_phs
@ %def phs_fks_generator_compute_y_real_phs
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_y_mismatch => phs_fks_generator_compute_y_mismatch
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_y_mismatch &
(generator, r_y, jac_rand, y, y_soft)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: r_y
real(default), intent(inout) :: jac_rand
real(default), intent(out) :: y
real(default), intent(out), dimension(:) :: y_soft
end subroutine phs_fks_generator_compute_y_mismatch
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_y_mismatch &
(generator, r_y, jac_rand, y, y_soft)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: r_y
real(default), intent(inout) :: jac_rand
real(default), intent(out) :: y
real(default), intent(out), dimension(:) :: y_soft
y = (one - two * r_y) * generator%y_max
jac_rand = jac_rand * 3 * (one - y**2) * generator%y_max
y = 1.5_default * (y - y**3 / 3)
y_soft = y
end subroutine phs_fks_generator_compute_y_mismatch
@ %def phs_fks_generator_compute_y_mismatch
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_y_test => phs_fks_generator_compute_y_test
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_compute_y_test (generator, y)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(out), dimension(:):: y
end subroutine phs_fks_generator_compute_y_test
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_compute_y_test (generator, y)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(out), dimension(:):: y
select case (generator%mode)
case (GEN_SOFT_LIMIT_TEST)
y = y_test_soft
case (GEN_COLL_LIMIT_TEST)
y = y_test_coll
case (GEN_ANTI_COLL_LIMIT_TEST)
y = - y_test_coll
case (GEN_SOFT_COLL_LIMIT_TEST)
y = y_test_coll
case (GEN_SOFT_ANTI_COLL_LIMIT_TEST)
y = - y_test_coll
end select
end subroutine phs_fks_generator_compute_y_test
@ %def phs_fks_generator_compute_y_test
@
<<PHS fks: public>>=
public :: beta_emitter
<<PHS fks: sub interfaces>>=
pure module function beta_emitter (q0, p) result (beta)
real(default), intent(in) :: q0
type(vector4_t), intent(in) :: p
real(default) :: beta
end function beta_emitter
<<PHS fks: procedures>>=
pure module function beta_emitter (q0, p) result (beta)
real(default), intent(in) :: q0
type(vector4_t), intent(in) :: p
real(default) :: beta
real(default) :: m2, mrec2, k0_max
m2 = p**2
mrec2 = (q0 - p%p(0))**2 - p%p(1)**2 - p%p(2)**2 - p%p(3)**2
k0_max = (q0**2 - mrec2 + m2) / (two * q0)
beta = sqrt(one - m2 / k0_max**2)
end function beta_emitter
@ %def beta_emitter
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: compute_xi_tilde => phs_fks_generator_compute_xi_tilde
<<PHS fks: sub interfaces>>=
pure module subroutine phs_fks_generator_compute_xi_tilde (generator, r)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: r
end subroutine phs_fks_generator_compute_xi_tilde
<<PHS fks: procedures>>=
pure module subroutine phs_fks_generator_compute_xi_tilde (generator, r)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: r
real(default) :: deno
associate (rad_var => generator%real_kinematics)
select case (generator%mode)
case (GEN_REAL_PHASE_SPACE)
if (generator%singular_jacobian) then
rad_var%xi_tilde = (one - generator%xi_min) - (one - r)**2 * &
(one - two * generator%xi_min)
rad_var%jac_rand = rad_var%jac_rand * two * (one - r) * &
(one - two * generator%xi_min)
else
rad_var%xi_tilde = generator%xi_min + r * (one - generator%xi_min)
rad_var%jac_rand = rad_var%jac_rand * (one - generator%xi_min)
end if
case (GEN_SOFT_MISMATCH)
deno = one - r
if (deno < tiny_13) deno = tiny_13
rad_var%xi_mismatch = generator%xi_min + r / deno
rad_var%jac_mismatch = rad_var%jac_mismatch / deno**2
case (GEN_SOFT_LIMIT_TEST)
rad_var%xi_tilde = r * two * xi_tilde_test_soft
rad_var%jac_rand = two * xi_tilde_test_soft
case (GEN_COLL_LIMIT_TEST)
rad_var%xi_tilde = xi_tilde_test_coll
rad_var%jac_rand = xi_tilde_test_coll
case (GEN_ANTI_COLL_LIMIT_TEST)
rad_var%xi_tilde = xi_tilde_test_coll
rad_var%jac_rand = xi_tilde_test_coll
case (GEN_SOFT_COLL_LIMIT_TEST)
rad_var%xi_tilde = r * two * xi_tilde_test_soft
rad_var%jac_rand = two * xi_tilde_test_soft
case (GEN_SOFT_ANTI_COLL_LIMIT_TEST)
rad_var%xi_tilde = r * two * xi_tilde_test_soft
rad_var%jac_rand = two * xi_tilde_test_soft
end select
end associate
end subroutine phs_fks_generator_compute_xi_tilde
@ %def phs_fks_generator_compute_xi_tilde
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: prepare_generation => phs_fks_generator_prepare_generation
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_prepare_generation (generator, &
r_in, i_phs, emitter, p_born, phs_identifiers, contributors, i_con)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), dimension(3), intent(in) :: r_in
integer, intent(in) :: i_phs, emitter
type(vector4_t), intent(in), dimension(:) :: p_born
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
type(resonance_contributors_t), intent(in), dimension(:), optional :: &
contributors
integer, intent(in), optional :: i_con
end subroutine phs_fks_generator_prepare_generation
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_prepare_generation (generator, &
r_in, i_phs, emitter, p_born, phs_identifiers, contributors, i_con)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), dimension(3), intent(in) :: r_in
integer, intent(in) :: i_phs, emitter
type(vector4_t), intent(in), dimension(:) :: p_born
type(phs_identifier_t), intent(in), dimension(:) :: phs_identifiers
type(resonance_contributors_t), intent(in), dimension(:), optional :: &
contributors
integer, intent(in), optional :: i_con
call generator%generate_radiation_variables (r_in, p_born, phs_identifiers)
call generator%compute_xi_ref_momenta &
(generator%real_kinematics%p_born_lab%phs_point(1)%get (), &
contributors)
call generator%compute_xi_max (emitter, i_phs, p_born, &
generator%real_kinematics%xi_max(i_phs), i_con = i_con)
end subroutine phs_fks_generator_prepare_generation
@ %def phs_fks_generator_prepare_generation
@ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and
generate an FSR phase space. Note that the flag [[supply_xi_max]] is
set to [[.false.]] because it is assumed that the upper bound on [[xi]]
has already been taken into account during its generation.
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_fsr_from_xi_and_y => &
phs_fks_generator_generate_fsr_from_xi_and_y
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_fsr_from_xi_and_y &
(generator, xi, y, &
phi, emitter, i_phs, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: xi, y, phi
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
end subroutine phs_fks_generator_generate_fsr_from_xi_and_y
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_fsr_from_xi_and_y &
(generator, xi, y, &
phi, emitter, i_phs, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: xi, y, phi
integer, intent(in) :: emitter, i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
associate (rad_var => generator%real_kinematics)
rad_var%supply_xi_max = .false.
rad_var%xi_tilde = xi
rad_var%y(i_phs) = y
rad_var%phi = phi
end associate
call generator%set_sqrts_hat (p_born(1)%p(0) + p_born(2)%p(0))
call generator%generate_fsr (emitter, i_phs, p_born, p_real)
end subroutine phs_fks_generator_generate_fsr_from_xi_and_y
@ %def phs_fks_generator_generate_fsr_from_xi_and_y
@ Get [[xi]] and [[y]] from an external routine (e.g. [[powheg]]) and
generate the ISR phase space.
For this, we need to overwrite all variables of the real kinematics
dependent on $(\xi,y,\phi)$ that we need to compute [[p_real]].
From the [[isr_kinematics]] we just need [[sqme_born]] and [[x]].
Both do not depend on the real radiation so we can leave them as they are.
<<PHS fks: phs fks generator: TBP>>=
procedure :: generate_isr_from_xi_and_y => &
phs_fks_generator_generate_isr_from_xi_and_y
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_generate_isr_from_xi_and_y &
(generator, xi, xi_max, y, phi, i_phs, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: xi, xi_max, y, phi
integer, intent(in) :: i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
end subroutine phs_fks_generator_generate_isr_from_xi_and_y
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_generate_isr_from_xi_and_y &
(generator, xi, xi_max, y, phi, i_phs, p_born, p_real)
class(phs_fks_generator_t), intent(inout) :: generator
real(default), intent(in) :: xi, xi_max, y, phi
integer, intent(in) :: i_phs
type(vector4_t), intent(in), dimension(:) :: p_born
type(vector4_t), intent(out), dimension(:) :: p_real
associate (rad_var => generator%real_kinematics)
rad_var%xi_max(i_phs) = xi_max
rad_var%xi_tilde = xi / xi_max
rad_var%y(i_phs) = y
rad_var%phi = phi
end associate
call generator%generate_isr (i_phs, p_born, p_real)
end subroutine phs_fks_generator_generate_isr_from_xi_and_y
@ %def phs_fks_generator_generate_isr_from_xi_and_y
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: get_radiation_variables => &
phs_fks_generator_get_radiation_variables
<<PHS fks: sub interfaces>>=
pure module subroutine phs_fks_generator_get_radiation_variables &
(generator, i_phs, xi, y, phi)
class(phs_fks_generator_t), intent(in) :: generator
integer, intent(in) :: i_phs
real(default), intent(out) :: xi, y
real(default), intent(out), optional :: phi
end subroutine phs_fks_generator_get_radiation_variables
<<PHS fks: procedures>>=
pure module subroutine phs_fks_generator_get_radiation_variables &
(generator, i_phs, xi, y, phi)
class(phs_fks_generator_t), intent(in) :: generator
integer, intent(in) :: i_phs
real(default), intent(out) :: xi, y
real(default), intent(out), optional :: phi
associate (rad_var => generator%real_kinematics)
xi = rad_var%xi_max(i_phs) * rad_var%xi_tilde
y = rad_var%y(i_phs)
if (present (phi)) phi = rad_var%phi
end associate
end subroutine phs_fks_generator_get_radiation_variables
@ %def phs_fks_generator_get_radiation_variables
@
<<PHS fks: phs fks generator: TBP>>=
procedure :: write => phs_fks_generator_write
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_generator_write (generator, unit)
class(phs_fks_generator_t), intent(in) :: generator
integer, intent(in), optional :: unit
end subroutine phs_fks_generator_write
<<PHS fks: procedures>>=
module subroutine phs_fks_generator_write (generator, unit)
class(phs_fks_generator_t), intent(in) :: generator
integer, intent(in), optional :: unit
integer :: u
type(string_t) :: massive_phsp
u = given_output_unit (unit); if (u < 0) return
if (generator%massive_phsp) then
massive_phsp = " massive "
else
massive_phsp = " massless "
end if
write (u, "(A)") char ("This is a generator for a" &
// massive_phsp // "phase space")
if (associated (generator%real_kinematics)) then
call generator%real_kinematics%write ()
else
write (u, "(A)") "Warning: There are no real " // &
"kinematics associated with this generator"
end if
call write_separator (u)
write (u, "(A," // FMT_17 // ",1X)") "sqrts : ", generator%sqrts
write (u, "(A," // FMT_17 // ",1X)") "E_gluon : ", generator%E_gluon
write (u, "(A," // FMT_17 // ",1X)") "mrec2 : ", generator%mrec2
end subroutine phs_fks_generator_write
@ %def phs_fks_generator_write
@
<<PHS fks: phs fks: TBP>>=
procedure :: compute_isr_kinematics => phs_fks_compute_isr_kinematics
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_compute_isr_kinematics (phs, r)
class(phs_fks_t), intent(inout) :: phs
real(default), intent(in) :: r
end subroutine phs_fks_compute_isr_kinematics
<<PHS fks: procedures>>=
module subroutine phs_fks_compute_isr_kinematics (phs, r)
class(phs_fks_t), intent(inout) :: phs
real(default), intent(in) :: r
if (.not. phs%config%lab_is_cm) then
call phs%generator%compute_isr_kinematics &
(r, phs%lt_cm_to_lab * phs%phs_wood_t%p)
else
call phs%generator%compute_isr_kinematics (r, phs%phs_wood_t%p)
end if
end subroutine phs_fks_compute_isr_kinematics
@ %def phs_fks_compute_isr_kinematics
@
<<PHS fks: phs fks: TBP>>=
procedure :: final => phs_fks_final
<<PHS fks: sub interfaces>>=
module subroutine phs_fks_final (object)
class(phs_fks_t), intent(inout) :: object
end subroutine phs_fks_final
<<PHS fks: procedures>>=
module subroutine phs_fks_final (object)
class(phs_fks_t), intent(inout) :: object
call object%forest%final ()
call object%generator%final ()
end subroutine phs_fks_final
@ %def phs_fks_final
@
<<PHS fks: procedures>>=
subroutine filter_particles_from_resonances &
(res_hist, exclusion_list, &
model, res_hist_filtered)
type(resonance_history_t), intent(in), dimension(:) :: res_hist
type(string_t), intent(in), dimension(:) :: exclusion_list
type(model_t), intent(in) :: model
type(resonance_history_t), intent(out), dimension(:), allocatable :: &
res_hist_filtered
integer :: i_hist, i_flv, i_new, n_orig
logical, dimension(size (res_hist)) :: to_filter
type(flavor_t) :: flv
to_filter = .false.
n_orig = size (res_hist)
do i_flv = 1, size (exclusion_list)
call flv%init (exclusion_list (i_flv), model)
do i_hist = 1, size (res_hist)
if (res_hist(i_hist)%has_flavor (flv)) to_filter (i_hist) = .true.
end do
end do
allocate (res_hist_filtered (n_orig - count (to_filter)))
i_new = 1
do i_hist = 1, size (res_hist)
if (.not. to_filter (i_hist)) then
res_hist_filtered (i_new) = res_hist (i_hist)
i_new = i_new + 1
end if
end do
end subroutine filter_particles_from_resonances
@ %def filter_particles_from_resonances
@
<<PHS fks: procedures>>=
subroutine clean_resonance_histories &
(res_hist, n_in, flv, res_hist_clean, success)
type(resonance_history_t), intent(in), dimension(:) :: res_hist
integer, intent(in) :: n_in
integer, intent(in), dimension(:) :: flv
type(resonance_history_t), intent(out), dimension(:), allocatable :: &
res_hist_clean
logical, intent(out) :: success
integer :: i_hist
type(resonance_history_t), dimension(:), allocatable :: &
res_hist_colored, res_hist_contracted
if (debug_on) call msg_debug (D_SUBTRACTION, "resonance_mapping_init")
if (debug_active (D_SUBTRACTION)) then
call msg_debug (D_SUBTRACTION, "Original resonances:")
do i_hist = 1, size(res_hist)
call res_hist(i_hist)%write ()
end do
end if
call remove_uncolored_resonances ()
call contract_resonances (res_hist_colored, res_hist_contracted)
call remove_subresonances (res_hist_contracted, res_hist_clean)
!!! Here, we are still not sure whether we actually would rather use
!!! call remove_multiple_resonances (res_hist_contracted, res_hist_clean)
if (debug_active (D_SUBTRACTION)) then
call msg_debug (D_SUBTRACTION, "Resonances after removing uncolored and duplicates: ")
do i_hist = 1, size (res_hist_clean)
call res_hist_clean(i_hist)%write ()
end do
end if
if (size (res_hist_clean) == 0) then
call msg_warning ("No resonances found. Proceed in usual FKS mode.")
success = .false.
else
success = .true.
end if
contains
subroutine remove_uncolored_resonances ()
type(resonance_history_t), dimension(:), allocatable :: res_hist_tmp
integer :: n_hist, nleg_out, n_removed
integer :: i_res, i_hist
n_hist = size (res_hist)
nleg_out = size (flv) - n_in
allocate (res_hist_tmp (n_hist))
allocate (res_hist_colored (n_hist))
do i_hist = 1, n_hist
res_hist_tmp(i_hist) = res_hist(i_hist)
call res_hist_tmp(i_hist)%add_offset (n_in)
n_removed = 0
do i_res = 1, res_hist_tmp(i_hist)%n_resonances
associate (resonance => res_hist_tmp(i_hist)%resonances(i_res - n_removed))
if (.not. any (is_colored (flv (resonance%contributors%c))) &
.or. size (resonance%contributors%c) == nleg_out) then
call res_hist_tmp(i_hist)%remove_resonance (i_res - n_removed)
n_removed = n_removed + 1
end if
end associate
end do
if (allocated (res_hist_tmp(i_hist)%resonances)) then
if (any (res_hist_colored == res_hist_tmp(i_hist))) then
cycle
else
do i_res = 1, res_hist_tmp(i_hist)%n_resonances
associate (resonance => res_hist_tmp(i_hist)%resonances(i_res))
call res_hist_colored(i_hist)%add_resonance (resonance)
end associate
end do
end if
end if
end do
end subroutine remove_uncolored_resonances
subroutine contract_resonances (res_history_in, res_history_out)
type(resonance_history_t), intent(in), dimension(:) :: res_history_in
type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
logical, dimension(:), allocatable :: i_non_zero
integer :: n_hist_non_zero, n_hist
integer :: i_hist_new
n_hist = size (res_history_in); n_hist_non_zero = 0
allocate (i_non_zero (n_hist))
i_non_zero = .false.
do i_hist = 1, n_hist
if (res_history_in(i_hist)%n_resonances /= 0) then
n_hist_non_zero = n_hist_non_zero + 1
i_non_zero(i_hist) = .true.
end if
end do
allocate (res_history_out (n_hist_non_zero))
i_hist_new = 1
do i_hist = 1, n_hist
if (i_non_zero (i_hist)) then
res_history_out (i_hist_new) = res_history_in (i_hist)
i_hist_new = i_hist_new + 1
end if
end do
end subroutine contract_resonances
subroutine remove_subresonances (res_history_in, res_history_out)
type(resonance_history_t), intent(in), dimension(:) :: res_history_in
type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
logical, dimension(:), allocatable :: i_non_sub_res
integer :: n_hist, n_hist_non_sub_res
integer :: i_hist1, i_hist2
logical :: is_not_subres
n_hist = size (res_history_in); n_hist_non_sub_res = 0
allocate (i_non_sub_res (n_hist)); i_non_sub_res = .false.
do i_hist1 = 1, n_hist
is_not_subres = .true.
do i_hist2 = 1, n_hist
if (i_hist1 == i_hist2) cycle
is_not_subres = is_not_subres .and. &
.not.(res_history_in(i_hist2) .contains. res_history_in(i_hist1))
end do
if (is_not_subres) then
n_hist_non_sub_res = n_hist_non_sub_res + 1
i_non_sub_res (i_hist1) = .true.
end if
end do
allocate (res_history_out (n_hist_non_sub_res))
i_hist2 = 1
do i_hist1 = 1, n_hist
if (i_non_sub_res (i_hist1)) then
res_history_out (i_hist2) = res_history_in (i_hist1)
i_hist2 = i_hist2 + 1
end if
end do
end subroutine remove_subresonances
subroutine remove_multiple_resonances (res_history_in, res_history_out)
type(resonance_history_t), intent(in), dimension(:) :: res_history_in
type(resonance_history_t), intent(out), dimension(:), allocatable :: res_history_out
integer :: n_hist, n_hist_single
logical, dimension(:), allocatable :: i_hist_single
integer :: i_hist, j
n_hist = size (res_history_in)
n_hist_single = 0
allocate (i_hist_single (n_hist)); i_hist_single = .false.
do i_hist = 1, n_hist
if (res_history_in(i_hist)%n_resonances == 1) then
n_hist_single = n_hist_single + 1
i_hist_single(i_hist) = .true.
end if
end do
allocate (res_history_out (n_hist_single))
j = 1
do i_hist = 1, n_hist
if (i_hist_single(i_hist)) then
res_history_out(j) = res_history_in(i_hist)
j = j + 1
end if
end do
end subroutine remove_multiple_resonances
end subroutine clean_resonance_histories
@ %def clean_resonance_histories
@
<<PHS fks: public>>=
public :: get_filtered_resonance_histories
<<PHS fks: sub interfaces>>=
module subroutine get_filtered_resonance_histories &
(phs_config, n_in, flv_state, model, excluded_resonances, &
resonance_histories_filtered, success)
type(phs_fks_config_t), intent(inout) :: phs_config
integer, intent(in) :: n_in
integer, intent(in), dimension(:,:), allocatable :: flv_state
type(model_t), intent(in) :: model
type(string_t), intent(in), dimension(:), allocatable :: &
excluded_resonances
type(resonance_history_t), intent(out), dimension(:), &
allocatable :: resonance_histories_filtered
logical, intent(out) :: success
end subroutine get_filtered_resonance_histories
<<PHS fks: procedures>>=
module subroutine get_filtered_resonance_histories &
(phs_config, n_in, flv_state, model, excluded_resonances, &
resonance_histories_filtered, success)
type(phs_fks_config_t), intent(inout) :: phs_config
integer, intent(in) :: n_in
integer, intent(in), dimension(:,:), allocatable :: flv_state
type(model_t), intent(in) :: model
type(string_t), intent(in), dimension(:), allocatable :: &
excluded_resonances
type(resonance_history_t), intent(out), dimension(:), &
allocatable :: resonance_histories_filtered
logical, intent(out) :: success
type(resonance_history_t), dimension(:), allocatable :: resonance_histories
type(resonance_history_t), dimension(:), allocatable :: &
resonance_histories_clean!, resonance_histories_filtered
allocate (resonance_histories (size (phs_config%get_resonance_histories ())))
resonance_histories = phs_config%get_resonance_histories ()
call clean_resonance_histories (resonance_histories, &
n_in, flv_state (:,1), resonance_histories_clean, success)
if (success .and. allocated (excluded_resonances)) then
call filter_particles_from_resonances (resonance_histories_clean, &
excluded_resonances, model, resonance_histories_filtered)
else
allocate (resonance_histories_filtered (size (resonance_histories_clean)))
resonance_histories_filtered = resonance_histories_clean
end if
end subroutine get_filtered_resonance_histories
@ %def get_filtered_resonance_histories
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\subsection{Unit tests}
Test module for FKS phase space, followed by the corresponding implementation module.
<<[[phs_fks_ut.f90]]>>=
<<File header>>
module phs_fks_ut
use unit_tests
use phs_fks_uti
<<Standard module head>>
<<PHS fks: public test>>
contains
<<PHS fks: test driver>>
end module phs_fks_ut
@ %def phs_fks_ut
@
<<[[phs_fks_uti.f90]]>>=
<<File header>>
module phs_fks_uti
<<Use kinds>>
use format_utils, only: write_separator, pac_fmt
use format_defs, only: FMT_15, FMT_19
use numeric_utils, only: nearly_equal
use constants, only: tiny_07, zero, one, two
use lorentz
use phs_points, only: assignment(=)
use physics_defs, only: THR_POS_B, THR_POS_BBAR, THR_POS_WP, THR_POS_WM, THR_POS_GLUON
use physics_defs, only: thr_leg
use resonances, only: resonance_contributors_t
use phs_fks
<<Standard module head>>
<<PHS fks: test declarations>>
contains
<<PHS fks: tests>>
end module phs_fks_uti
@ %def phs_fks_uti
@ API: driver for the unit tests below.
<<PHS fks: public test>>=
public :: phs_fks_generator_test
<<PHS fks: test driver>>=
subroutine phs_fks_generator_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
call test(phs_fks_generator_1, "phs_fks_generator_1", &
"Test the generation of FKS phase spaces", u, results)
call test(phs_fks_generator_2, "phs_fks_generator_2", &
"Test the generation of an ISR FKS phase space", u, results)
call test(phs_fks_generator_3, "phs_fks_generator_3", &
"Test the generation of a real phase space for decays", &
u, results)
call test(phs_fks_generator_4, "phs_fks_generator_4", &
"Test the generation of an FSR phase space with "&
&"conserved invariant resonance masses", u, results)
call test(phs_fks_generator_5, "phs_fks_generator_5", &
"Test on-shell projection of a Born phase space and the generation"&
&" of a real phase-space from that", u, results)
call test(phs_fks_generator_6, "phs_fks_generator_6", &
"Test the generation of a real phase space for 1 -> 3 decays", &
u, results)
call test(phs_fks_generator_7, "phs_fks_generator_7", &
"Test the generation of an ISR FKS phase space for fixed beam energy", &
u, results)
end subroutine phs_fks_generator_test
@ %def phs_fks_generator_test
@
<<PHS fks: test declarations>>=
public :: phs_fks_generator_1
<<PHS fks: tests>>=
subroutine phs_fks_generator_1 (u)
integer, intent(in) :: u
type(phs_fks_generator_t) :: generator
type(vector4_t), dimension(:), allocatable :: p_born
type(vector4_t), dimension(:), allocatable :: p_real
integer :: emitter, i_phs
real(default) :: x1, x2, x3
real(default), parameter :: sqrts = 250.0_default
type(phs_identifier_t), dimension(2) :: phs_identifiers
write (u, "(A)") "* Test output: phs_fks_generator_1"
write (u, "(A)") "* Purpose: Create massless fsr phase space"
write (u, "(A)")
allocate (p_born (4))
p_born(1)%p(0) = 125.0_default
p_born(1)%p(1:2) = 0.0_default
p_born(1)%p(3) = 125.0_default
p_born(2)%p(0) = 125.0_default
p_born(2)%p(1:2) = 0.0_default
p_born(2)%p(3) = -125.0_default
p_born(3)%p(0) = 125.0_default
p_born(3)%p(1) = -39.5618_default
p_born(3)%p(2) = -20.0791_default
p_born(3)%p(3) = -114.6957_default
p_born(4)%p(0) = 125.0_default
p_born(4)%p(1:3) = -p_born(3)%p(1:3)
allocate (generator%isr_kinematics)
generator%n_in = 2
generator%isr_kinematics%isr_mode = SQRTS_FIXED
call generator%set_xi_and_y_bounds ()
call generator%set_sqrts_hat (sqrts)
write (u, "(A)") "* Use four-particle phase space containing: "
call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
write (u, "(A)") "***********************"
write (u, "(A)")
x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default
write (u, "(A)" ) "* Use random numbers: "
write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
"x1: ", x1, "x2: ", x2, "x3: ", x3
allocate (generator%real_kinematics)
call generator%real_kinematics%init (4, 2, 2, 1)
allocate (generator%emitters (2))
generator%emitters(1) = 3; generator%emitters(2) = 4
allocate (generator%m2 (4))
generator%m2 = zero
allocate (generator%is_massive (4))
generator%is_massive(1:2) = .false.
generator%is_massive(3:4) = .true.
phs_identifiers(1)%emitter = 3
phs_identifiers(2)%emitter = 4
call generator%compute_xi_ref_momenta (p_born)
call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
do i_phs = 1, 2
emitter = phs_identifiers(i_phs)%emitter
call generator%compute_xi_max (emitter, i_phs, p_born, &
generator%real_kinematics%xi_max(i_phs))
end do
write (u, "(A)") &
"* With these, the following radiation variables have been produced:"
associate (rad_var => generator%real_kinematics)
write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde
write (u, "(A,F3.2)") "y: " , rad_var%y(1)
write (u, "(A,F3.2)") "phi: ", rad_var%phi
end associate
call write_separator (u)
write (u, "(A)") "Produce real momenta: "
i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
allocate (p_real (5))
call generator%generate_fsr (emitter, i_phs, p_born, p_real)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_fks_generator_1"
end subroutine phs_fks_generator_1
@ %def phs_fks_generator_1
@
<<PHS fks: test declarations>>=
public :: phs_fks_generator_2
<<PHS fks: tests>>=
subroutine phs_fks_generator_2 (u)
integer, intent(in) :: u
type(phs_fks_generator_t) :: generator
type(vector4_t), dimension(:), allocatable :: p_born
type(vector4_t), dimension(:), allocatable :: p_real
integer :: emitter, i_phs
real(default) :: x1, x2, x3
real(default), parameter :: sqrts_hadronic = 250.0_default
type(phs_identifier_t), dimension(2) :: phs_identifiers
write (u, "(A)") "* Test output: phs_fks_generator_2"
write (u, "(A)") "* Purpose: Create massless ISR phase space"
write (u, "(A)")
allocate (p_born (4))
p_born(1)%p(0) = 114.661_default
p_born(1)%p(1:2) = 0.0_default
p_born(1)%p(3) = 114.661_default
p_born(2)%p(0) = 121.784_default
p_born(2)%p(1:2) = 0.0_default
p_born(2)%p(3) = -121.784_default
p_born(3)%p(0) = 115.148_default
p_born(3)%p(1) = -46.250_default
p_born(3)%p(2) = -37.711_default
p_born(3)%p(3) = 98.478_default
p_born(4)%p(0) = 121.296_default
p_born(4)%p(1:2) = -p_born(3)%p(1:2)
p_born(4)%p(3) = -105.601_default
phs_identifiers(1)%emitter = 1
phs_identifiers(2)%emitter = 2
allocate (generator%emitters (2))
allocate (generator%isr_kinematics)
generator%emitters(1) = 1; generator%emitters(2) = 2
generator%sqrts = sqrts_hadronic
allocate (generator%isr_kinematics%beam_energy(2))
generator%isr_kinematics%beam_energy = sqrts_hadronic / two
call generator%set_sqrts_hat (sqrts_hadronic)
call generator%set_isr_kinematics (p_born)
generator%n_in = 2
generator%isr_kinematics%isr_mode = SQRTS_VAR
call generator%set_xi_and_y_bounds ()
write (u, "(A)") "* Use four-particle phase space containing: "
call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
write (u, "(A)") "***********************"
write (u, "(A)")
x1=0.5_default; x2=0.25_default; x3=0.65_default
write (u, "(A)" ) "* Use random numbers: "
write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
"x1: ", x1, "x2: ", x2, "x3: ", x3
allocate (generator%real_kinematics)
call generator%real_kinematics%init (4, 2, 2, 1)
call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)
allocate (generator%m2 (2))
generator%m2(1) = 0._default; generator%m2(2) = 0._default
allocate (generator%is_massive (4))
generator%is_massive = .false.
call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
call generator%compute_xi_ref_momenta (p_born)
do i_phs = 1, 2
emitter = phs_identifiers(i_phs)%emitter
call generator%compute_xi_max (emitter, i_phs, p_born, &
generator%real_kinematics%xi_max(i_phs))
end do
write (u, "(A)") &
"* With these, the following radiation variables have been produced:"
associate (rad_var => generator%real_kinematics)
write (u, "(A,F3.2)") "xi_tilde: ", rad_var%xi_tilde
write (u, "(A,F3.2)") "y: " , rad_var%y(1)
write (u, "(A,F3.2)") "phi: ", rad_var%phi
end associate
write (u, "(A)") "Initial-state momentum fractions: "
associate (xb => generator%isr_kinematics%x)
write (u, "(A,F3.2)") "x_born_plus: ", xb(1)
write (u, "(A,F3.2)") "x_born_minus: ", xb(2)
end associate
call write_separator (u)
write (u, "(A)") "Produce real momenta: "
i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
allocate (p_real(5))
call generator%generate_isr (i_phs, p_born, p_real)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_fks_generator_2"
end subroutine phs_fks_generator_2
@ %def phs_fks_generator_2
@
<<PHS fks: test declarations>>=
public :: phs_fks_generator_3
<<PHS fks: tests>>=
subroutine phs_fks_generator_3 (u)
integer, intent(in) :: u
type(phs_fks_generator_t) :: generator
type(vector4_t), dimension(:), allocatable :: p_born
type(vector4_t), dimension(:), allocatable :: p_real
real(default) :: x1, x2, x3
real(default) :: mB, mW, mT
integer :: i, emitter, i_phs
type(phs_identifier_t), dimension(2) :: phs_identifiers
write (u, "(A)") "* Test output: phs_fks_generator_3"
write (u, "(A)") "* Puropse: Create real phase space for particle decays"
write (u, "(A)")
allocate (p_born(3))
p_born(1)%p(0) = 172._default
p_born(1)%p(1) = 0._default
p_born(1)%p(2) = 0._default
p_born(1)%p(3) = 0._default
p_born(2)%p(0) = 104.72866679_default
p_born(2)%p(1) = 45.028053213_default
p_born(2)%p(2) = 29.450337581_default
p_born(2)%p(3) = -5.910229156_default
p_born(3)%p(0) = 67.271333209_default
p_born(3)%p(1:3) = -p_born(2)%p(1:3)
generator%n_in = 1
allocate (generator%isr_kinematics)
generator%isr_kinematics%isr_mode = SQRTS_FIXED
call generator%set_xi_and_y_bounds ()
mB = 4.2_default
mW = 80.376_default
mT = 172._default
generator%sqrts = mT
write (u, "(A)") "* Use three-particle phase space containing: "
call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
write (u, "(A)") "**********************"
write (u, "(A)")
x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
write (u, "(A)") "* Use random numbers: "
write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
"x1: ", x1, "x2: ", x2, "x3: ", x3
allocate (generator%real_kinematics)
call generator%real_kinematics%init (3, 2, 2, 1)
call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)
allocate (generator%emitters(2))
generator%emitters(1) = 1
generator%emitters(2) = 3
allocate (generator%m2 (3), generator%is_massive(3))
generator%m2(1) = mT**2
generator%m2(2) = mW**2
generator%m2(3) = mB**2
generator%is_massive = .true.
phs_identifiers(1)%emitter = 1
phs_identifiers(2)%emitter = 3
call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
call generator%compute_xi_ref_momenta (p_born)
do i_phs = 1, 2
emitter = phs_identifiers(i_phs)%emitter
call generator%compute_xi_max (emitter, i_phs, p_born, &
generator%real_kinematics%xi_max(i_phs))
end do
write (u, "(A)") &
"* With these, the following radiation variables have been produced: "
associate (rad_var => generator%real_kinematics)
write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
do i = 1, 2
write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
end do
write (u, "(A,F4.2)") "phi: ", rad_var%phi
end associate
call write_separator (u)
write (u, "(A)") "Produce real momenta via initial-state emission: "
i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
allocate (p_real (4))
call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
call pacify (p_real, 1E-6_default)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
call write_separator(u)
write (u, "(A)") "Produce real momenta via final-state emisson: "
i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
call generator%generate_fsr (emitter, i_phs, p_born, p_real)
call pacify (p_real, 1E-6_default)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_fks_generator_3"
end subroutine phs_fks_generator_3
@ %def phs_fks_generator_3
@
<<PHS fks: test declarations>>=
public :: phs_fks_generator_4
<<PHS fks: tests>>=
subroutine phs_fks_generator_4 (u)
integer, intent(in) :: u
type(phs_fks_generator_t) :: generator
type(vector4_t), dimension(:), allocatable :: p_born
type(vector4_t), dimension(:), allocatable :: p_real
integer, dimension(:), allocatable :: emitters
integer, dimension(:,:), allocatable :: resonance_lists
type(resonance_contributors_t), dimension(2) :: alr_contributors
real(default) :: x1, x2, x3
real(default), parameter :: sqrts = 250.0_default
integer, parameter :: nlegborn = 6
integer :: i_phs, i_con, emitter
real(default) :: m_inv_born, m_inv_real
character(len=7) :: fmt
type(phs_identifier_t), dimension(2) :: phs_identifiers
call pac_fmt (fmt, FMT_19, FMT_15, .true.)
write (u, "(A)") "* Test output: phs_fks_generator_4"
write (u, "(A)") "* Purpose: Create FSR phase space with fixed resonances"
write (u, "(A)")
allocate (p_born (nlegborn))
p_born(1)%p(0) = 250._default
p_born(1)%p(1) = 0._default
p_born(1)%p(2) = 0._default
p_born(1)%p(3) = 250._default
p_born(2)%p(0) = 250._default
p_born(2)%p(1) = 0._default
p_born(2)%p(2) = 0._default
p_born(2)%p(3) = -250._default
p_born(3)%p(0) = 145.91184486_default
p_born(3)%p(1) = 50.39727589_default
p_born(3)%p(2) = 86.74156041_default
p_born(3)%p(3) = -69.03608748_default
p_born(4)%p(0) = 208.1064784_default
p_born(4)%p(1) = -44.07610020_default
p_born(4)%p(2) = -186.34264578_default
p_born(4)%p(3) = 13.48038407_default
p_born(5)%p(0) = 26.25614471_default
p_born(5)%p(1) = -25.12258068_default
p_born(5)%p(2) = -1.09540228_default
p_born(5)%p(3) = -6.27703505_default
p_born(6)%p(0) = 119.72553196_default
p_born(6)%p(1) = 18.80140499_default
p_born(6)%p(2) = 100.69648766_default
p_born(6)%p(3) = 61.83273846_default
allocate (generator%isr_kinematics)
generator%n_in = 2
generator%isr_kinematics%isr_mode = SQRTS_FIXED
call generator%set_xi_and_y_bounds ()
call generator%set_sqrts_hat (sqrts)
write (u, "(A)") "* Test process: e+ e- -> W+ W- b b~"
write (u, "(A)") "* Resonance pairs: (3,5) and (4,6)"
write (u, "(A)") "* Use four-particle phase space containing: "
call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
write (u, "(A)") "******************************"
write (u, "(A)")
x1 = 0.5_default; x2 = 0.25_default; x3 = 0.75_default
write (u, "(A)") "* Use random numbers: "
write (u, "(A,F3.2,1X,A,F3.2,1X,A,F3.2)") &
"x1: ", x1, "x2: ", x2, "x3: ", x3
allocate (generator%real_kinematics)
call generator%real_kinematics%init (nlegborn, 2, 2, 2)
allocate (generator%emitters (2))
generator%emitters(1) = 5; generator%emitters(2) = 6
allocate (generator%m2 (nlegborn))
generator%m2 = p_born**2
allocate (generator%is_massive (nlegborn))
generator%is_massive (1:2) = .false.
generator%is_massive (3:6) = .true.
phs_identifiers(1)%emitter = 5
phs_identifiers(2)%emitter = 6
do i_phs = 1, 2
allocate (phs_identifiers(i_phs)%contributors (2))
end do
allocate (resonance_lists (2, 2))
resonance_lists (1,:) = [3,5]
resonance_lists (2,:) = [4,6]
!!! Here is obviously some redundance. Surely we can improve on this.
do i_phs = 1, 2
phs_identifiers(i_phs)%contributors = resonance_lists(i_phs,:)
end do
do i_con = 1, 2
allocate (alr_contributors(i_con)%c (size (resonance_lists(i_con,:))))
alr_contributors(i_con)%c = resonance_lists(i_con,:)
end do
call generator%generate_radiation_variables &
([x1, x2, x3], p_born, phs_identifiers)
allocate (p_real(nlegborn + 1))
call generator%compute_xi_ref_momenta (p_born, alr_contributors)
!!! Keep the distinction between i_phs and i_con because in general,
!!! they are not the same.
do i_phs = 1, 2
i_con = i_phs
emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1,1X,A,I1,A,I1,A)") &
"* Generate FSR phase space for emitter ", emitter, &
"and resonance pair (", resonance_lists (i_con, 1), ",", &
resonance_lists (i_con, 2), ")"
call generator%compute_xi_max (emitter, i_phs, p_born, &
generator%real_kinematics%xi_max(i_phs), i_con = i_con)
call generator%generate_fsr (emitter, i_phs, i_con, p_born, p_real)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
call write_separator(u)
write (u, "(A)") "* Check if resonance masses are conserved: "
m_inv_born = compute_resonance_mass (p_born, resonance_lists (i_con,:))
m_inv_real = compute_resonance_mass (p_real, resonance_lists (i_con,:), 7)
write (u, "(A,1X, " // fmt // ")") "m_inv_born = ", m_inv_born
write (u, "(A,1X, " // fmt // ")") "m_inv_real = ", m_inv_real
if (abs (m_inv_born - m_inv_real) < tiny_07) then
write (u, "(A)") " Success! "
else
write (u, "(A)") " Failure! "
end if
call write_separator(u)
call write_separator(u)
end do
deallocate (p_real)
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_fks_generator_4"
end subroutine phs_fks_generator_4
@ %def phs_fks_generator_4
@
<<PHS fks: test declarations>>=
public :: phs_fks_generator_5
<<PHS fks: tests>>=
subroutine phs_fks_generator_5 (u)
use ttv_formfactors, only: init_parameters
integer, intent(in) :: u
type(phs_fks_generator_t) :: generator
type(vector4_t), dimension(:), allocatable :: p_born, pb1
type(vector4_t), dimension(:), allocatable :: p_born_onshell, pb1_os
type(vector4_t), dimension(:), allocatable :: p_real
real(default) :: x1, x2, x3
real(default) :: mB, mW, mtop, mcheck
integer :: i, emitter, i_phs
type(phs_identifier_t), dimension(2) :: phs_identifiers
type(lorentz_transformation_t) :: L_to_cms
real(default), parameter :: sqrts = 360._default
real(default), parameter :: momentum_tolerance = 1E-10_default
real(default) :: mpole, gam_out
write (u, "(A)") "* Test output: phs_fks_generator_5"
write (u, "(A)") "* Puropse: Perform threshold on-shell projection of "
write (u, "(A)") "* Born momenta and create a real phase-space "
write (u, "(A)") "* point from those. "
write (u, "(A)")
allocate (p_born(6), p_born_onshell(6))
p_born(1)%p(0) = sqrts / two
p_born(1)%p(1:2) = zero
p_born(1)%p(3) = sqrts / two
p_born(2)%p(0) = sqrts / two
p_born(2)%p(1:2) = zero
p_born(2)%p(3) = -sqrts / two
p_born(3)%p(0) = 117.1179139230_default
p_born(3)%p(1) = 56.91215483880_default
p_born(3)%p(2) = -40.02386013017_default
p_born(3)%p(3) = -49.07634310496_default
p_born(4)%p(0) = 98.91904548743_default
p_born(4)%p(1) = 56.02241403836_default
p_born(4)%p(2) = -8.302977504723_default
p_born(4)%p(3) = -10.50293716131_default
p_born(5)%p(0) = 62.25884689208_default
p_born(5)%p(1) = -60.00786540278_default
p_born(5)%p(2) = 4.753602375910_default
p_born(5)%p(3) = 15.32916731546_default
p_born(6)%p(0) = 81.70419369751_default
p_born(6)%p(1) = -52.92670347439_default
p_born(6)%p(2) = 43.57323525898_default
p_born(6)%p(3) = 44.25011295081_default
generator%n_in = 2
allocate (generator%isr_kinematics)
generator%isr_kinematics%isr_mode = SQRTS_FIXED
call generator%set_xi_and_y_bounds ()
mB = 4.2_default
mW = 80.376_default
mtop = 172._default
generator%sqrts = sqrts
!!! Dummy-initialization of the threshold model because generate_fsr_threshold
!!! uses m1s_to_mpole to determine if it is above or below threshold.
call init_parameters (mpole, gam_out, mtop, one, one / 1.5_default, 125._default, &
0.47_default, 0.118_default, 91._default, 80._default, 4.2_default, &
one, one, one, one, zero, zero, zero, zero, zero, zero, .false., zero)
write (u, "(A)") "* Use four-particle phase space containing: "
call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
call vector4_check_momentum_conservation &
(p_born, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.)
write (u, "(A)") "**********************"
write (u, "(A)")
allocate (generator%real_kinematics)
call generator%real_kinematics%init (7, 2, 2, 2)
call generator%real_kinematics%init_onshell (7, 2)
generator%real_kinematics%p_born_cms%phs_point(1) = p_born
write (u, "(A)") "Get boost projection system -> CMS: "
L_to_cms = get_boost_for_threshold_projection (p_born, sqrts, mtop)
call L_to_cms%write (u, testflag = .true., ultra = .true.)
write (u, "(A)") "**********************"
write (u, "(A)")
write (u, "(A)") "* Perform onshell-projection:"
pb1 = generator%real_kinematics%p_born_cms%phs_point(1)
call threshold_projection_born (mtop, L_to_cms, pb1, p_born_onshell)
generator%real_kinematics%p_born_onshell%phs_point(1) = p_born_onshell
call generator%real_kinematics%p_born_onshell%write &
(1, unit = u, testflag = .true., ultra = .true.)
pb1_os = generator%real_kinematics%p_born_onshell%phs_point(1)
call check_phsp (pb1_os, 0)
allocate (generator%emitters (2))
generator%emitters(1) = THR_POS_B; generator%emitters(2) = THR_POS_BBAR
allocate (generator%m2 (6), generator%is_massive(6))
generator%m2 = p_born**2
generator%is_massive (1:2) = .false.
generator%is_massive (3:6) = .true.
phs_identifiers(1)%emitter = THR_POS_B
phs_identifiers(2)%emitter = THR_POS_BBAR
x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
write (u, "(A)") "* Use random numbers: "
write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
"x1: ", x1, "x2: ", x2, "x3: ", x3
call generator%generate_radiation_variables ([x1,x2,x3], p_born_onshell, phs_identifiers)
do i_phs = 1, 2
emitter = phs_identifiers(i_phs)%emitter
call generator%compute_xi_ref_momenta_threshold (p_born_onshell)
call generator%compute_xi_max (emitter, i_phs, p_born_onshell, &
generator%real_kinematics%xi_max(i_phs), i_con = thr_leg(emitter))
end do
write (u, "(A)") &
"* With these, the following radiation variables have been produced: "
associate (rad_var => generator%real_kinematics)
write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
write (u, "(A)") "xi_max: "
write (u, "(2F5.2)") rad_var%xi_max(1), rad_var%xi_max(2)
write (u, "(A)") "y: "
write (u, "(2F5.2)") rad_var%y(1), rad_var%y(2)
write (u, "(A,F4.2)") "phi: ", rad_var%phi
end associate
call write_separator (u)
write (u, "(A)") "* Produce real momenta from on-shell phase space: "
allocate (p_real(7))
do i_phs = 1, 2
emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
call generator%generate_fsr_threshold (emitter, i_phs, p_born_onshell, p_real)
call check_phsp (p_real, emitter)
end do
call write_separator(u)
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_fks_generator_5"
contains
subroutine check_phsp (p, emitter)
type(vector4_t), intent(inout), dimension(:) :: p
integer, intent(in) :: emitter
type(vector4_t) :: pp
real(default) :: E_tot
logical :: check
write (u, "(A)") "* Check momentum conservation: "
call vector4_check_momentum_conservation &
(p, 2, unit = u, abs_smallness = momentum_tolerance, verbose = .true.)
write (u, "(A)") "* Check invariant masses: "
write (u, "(A)", advance = "no") "inv(W+, b, gl): "
pp = p(THR_POS_WP) + p(THR_POS_B)
if (emitter == THR_POS_B) pp = pp + p(THR_POS_GLUON)
if (nearly_equal (pp**1, mtop)) then
write (u, "(A)") "CHECK"
else
write (u, "(A,F7.3)") "FAIL: ", pp**1
end if
write (u, "(A)", advance = "no") "inv(W-, bbar): "
pp = p(THR_POS_WM) + p(THR_POS_BBAR)
if (emitter == THR_POS_BBAR) pp = pp + p(THR_POS_GLUON)
if (nearly_equal (pp**1, mtop)) then
write (u, "(A)") "CHECK"
else
write (u, "(A,F7.3)") "FAIL: ", pp**1
end if
write (u, "(A)") "* Sum of energies equal to sqrts?"
E_tot = sum(p(1:2)%p(0)); check = nearly_equal (E_tot, sqrts)
write (u, "(A,L1)") "Initial state: ", check
if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot
if (emitter > 0) then
E_tot = sum(p(3:7)%p(0))
else
E_tot = sum(p(3:6)%p(0))
end if
check = nearly_equal (E_tot, sqrts)
write (u, "(A,L1)") "Final state : ", check
if (.not. check) write (u, "(A,F7.3)") "E_tot: ", E_tot
call pacify (p, 1E-6_default)
call vector4_write_set (p, u, testflag = .true., ultra = .true.)
end subroutine check_phsp
end subroutine phs_fks_generator_5
@ %def phs_fks_generator_5
@
<<PHS fks: test declarations>>=
public :: phs_fks_generator_6
<<PHS fks: tests>>=
subroutine phs_fks_generator_6 (u)
integer, intent(in) :: u
type(phs_fks_generator_t) :: generator
type(vector4_t), dimension(:), allocatable :: p_born
type(vector4_t), dimension(:), allocatable :: p_real
real(default) :: x1, x2, x3
real(default) :: mB, mW, mT
integer :: i, emitter, i_phs
type(phs_identifier_t), dimension(2) :: phs_identifiers
write (u, "(A)") "* Test output: phs_fks_generator_6"
write (u, "(A)") "* Puropse: Create real phase space for particle decays"
write (u, "(A)")
allocate (p_born(4))
p_born(1)%p(0) = 173.1_default
p_born(1)%p(1) = zero
p_born(1)%p(2) = zero
p_born(1)%p(3) = zero
p_born(2)%p(0) = 68.17074462929_default
p_born(2)%p(1) = -37.32578717617_default
p_born(2)%p(2) = 30.99675959336_default
p_born(2)%p(3) = -47.70321718398_default
p_born(3)%p(0) = 65.26639312326_default
p_born(3)%p(1) = -1.362927648502_default
p_born(3)%p(2) = -33.25327150840_default
p_born(3)%p(3) = 56.14324922494_default
p_born(4)%p(0) = 39.66286224745_default
p_born(4)%p(1) = 38.68871482467_default
p_born(4)%p(2) = 2.256511915049_default
p_born(4)%p(3) = -8.440032040958_default
generator%n_in = 1
allocate (generator%isr_kinematics)
generator%isr_kinematics%isr_mode = SQRTS_FIXED
call generator%set_xi_and_y_bounds ()
mB = 4.2_default
mW = 80.376_default
mT = 173.1_default
generator%sqrts = mT
write (u, "(A)") "* Use four-particle phase space containing: "
call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
write (u, "(A)") "**********************"
write (u, "(A)")
x1=0.5_default; x2=0.25_default; x3=0.6_default
write (u, "(A)") "* Use random numbers: "
write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
"x1: ", x1, "x2: ", x2, "x3: ", x3
allocate (generator%real_kinematics)
call generator%real_kinematics%init (3, 2, 2, 1)
call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)
allocate (generator%emitters(2))
generator%emitters(1) = 1
generator%emitters(2) = 2
allocate (generator%m2 (4), generator%is_massive(4))
generator%m2(1) = mT**2
generator%m2(2) = mB**2
generator%m2(3) = zero
generator%m2(4) = zero
generator%is_massive(1:2) = .true.
generator%is_massive(3:4) = .false.
phs_identifiers(1)%emitter = 1
phs_identifiers(2)%emitter = 2
call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
call generator%compute_xi_ref_momenta (p_born)
do i_phs = 1, 2
emitter = phs_identifiers(i_phs)%emitter
call generator%compute_xi_max (emitter, i_phs, p_born, &
generator%real_kinematics%xi_max(i_phs))
end do
write (u, "(A)") &
"* With these, the following radiation variables have been produced: "
associate (rad_var => generator%real_kinematics)
write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
do i = 1, 2
write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
end do
write (u, "(A,F4.2)") "phi: ", rad_var%phi
end associate
call write_separator (u)
write (u, "(A)") "Produce real momenta via initial-state emission: "
i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
allocate (p_real(5))
call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
call pacify (p_real, 1E-6_default)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
call write_separator(u)
write (u, "(A)") "Produce real momenta via final-state emisson: "
i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
call generator%generate_fsr (emitter, i_phs, p_born, p_real)
call pacify (p_real, 1E-6_default)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_fks_generator_6"
end subroutine phs_fks_generator_6
@ %def phs_fks_generator_6
@
<<PHS fks: test declarations>>=
public :: phs_fks_generator_7
<<PHS fks: tests>>=
subroutine phs_fks_generator_7 (u)
integer, intent(in) :: u
type(phs_fks_generator_t) :: generator
type(vector4_t), dimension(:), allocatable :: p_born
type(vector4_t), dimension(:), allocatable :: p_real
real(default) :: x1, x2, x3
integer :: i, emitter, i_phs
type(phs_identifier_t), dimension(2) :: phs_identifiers
real(default), parameter :: sqrts = 1000.0_default
write (u, "(A)") "* Test output: phs_fks_generator_7"
write (u, "(A)") "* Puropse: Create real phase space for scattering ISR"
write (u, "(A)") "* keeping the beam energy fixed."
write (u, "(A)")
allocate (p_born(4))
p_born(1)%p(0) = 500._default
p_born(1)%p(1) = 0._default
p_born(1)%p(2) = 0._default
p_born(1)%p(3) = 500._default
p_born(2)%p(0) = 500._default
p_born(2)%p(1) = 0._default
p_born(2)%p(2) = 0._default
p_born(2)%p(3) = -500._default
p_born(3)%p(0) = 500._default
p_born(3)%p(1) = 11.275563070_default
p_born(3)%p(2) = -13.588797663_default
p_born(3)%p(3) = 486.93070588_default
p_born(4)%p(0) = 500._default
p_born(4)%p(1:3) = -p_born(3)%p(1:3)
phs_identifiers(1)%emitter = 1
phs_identifiers(2)%emitter = 2
allocate (generator%emitters(2))
generator%n_in = 2
allocate (generator%isr_kinematics)
generator%isr_kinematics%isr_mode = SQRTS_FIXED
call generator%set_xi_and_y_bounds ()
generator%emitters(1) = 1; generator%emitters(2) = 2
generator%sqrts = sqrts
write (u, "(A)") "* Use 2 -> 2 phase space containing: "
call vector4_write_set (p_born, u, testflag = .true., ultra = .true.)
write (u, "(A)") "**********************"
write (u, "(A)")
x1 = 0.5_default; x2 = 0.25_default; x3 = 0.6_default
write (u, "(A)") "* Use random numbers: "
write (u, "(A,F3.2,1X,A,F3.2,A,1X,F3.2)") &
"x1: ", x1, "x2: ", x2, "x3: ", x3
allocate (generator%real_kinematics)
call generator%real_kinematics%init (4, 2, 2, 1)
call generator%real_kinematics%p_born_lab%set_momenta (1, p_born)
allocate (generator%m2 (4))
generator%m2 = 0._default
allocate (generator%is_massive(4))
generator%is_massive = .false.
call generator%generate_radiation_variables ([x1,x2,x3], p_born, phs_identifiers)
call generator%compute_xi_ref_momenta (p_born)
do i_phs = 1, 2
emitter = phs_identifiers(i_phs)%emitter
call generator%compute_xi_max (emitter, i_phs, p_born, &
generator%real_kinematics%xi_max(i_phs))
end do
write (u, "(A)") &
"* With these, the following radiation variables have been produced: "
associate (rad_var => generator%real_kinematics)
write (u, "(A,F4.2)") "xi_tilde: ", rad_var%xi_tilde
do i = 1, 2
write (u, "(A,I1,A,F5.2)") "i: ", i, "y: " , rad_var%y(i)
end do
write (u, "(A,F4.2)") "phi: ", rad_var%phi
end associate
call write_separator (u)
write (u, "(A)") "Produce real momenta via initial-state emission: "
i_phs = 1; emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
allocate (p_real(5))
call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
call pacify (p_real, 1E-6_default)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
call write_separator(u)
i_phs = 2; emitter = phs_identifiers(i_phs)%emitter
write (u, "(A,I1)") "emitter: ", emitter
call generator%generate_isr_fixed_beam_energy (i_phs, p_born, p_real)
call pacify (p_real, 1E-6_default)
call vector4_write_set (p_real, u, testflag = .true., ultra = .true.)
write (u, "(A)")
write (u, "(A)") "* Test output end: phs_fks_generator_7"
end subroutine phs_fks_generator_7
@ %def phs_fks_generator_3
@
\section{Dispatch}
<<[[dispatch_phase_space.f90]]>>=
<<File header>>
module dispatch_phase_space
<<Use kinds>>
<<Use strings>>
use variables, only: var_list_t
use os_interface, only: os_data_t
use sf_mappings, only: sf_channel_t
use beam_structures, only: beam_structure_t
use dispatch_beams, only: sf_prop_t, strfun_mode
use mappings
use phs_forests, only: phs_parameters_t
use phs_base
<<Standard module head>>
<<Dispatch phs: public>>
interface
<<Dispatch phs: sub interfaces>>
end interface
end module dispatch_phase_space
@ %def dispatch_phase_space
@
<<[[dispatch_phase_space_sub.f90]]>>=
<<File header>>
submodule (dispatch_phase_space) dispatch_phase_space_s
use io_units, only: free_unit
use diagnostics
use phs_none
use phs_single
use phs_rambo
use phs_wood
use phs_fks
implicit none
contains
<<Dispatch phs: procedures>>
end submodule dispatch_phase_space_s
@ %def dispatch_phase_space_s
@
Allocate a phase-space object according to the variable [[$phs_method]].
<<Dispatch phs: public>>=
public :: dispatch_phs
<<Dispatch phs: sub interfaces>>=
module subroutine dispatch_phs (phs, var_list, os_data, process_id, &
mapping_defaults, phs_par, phs_method_in)
class(phs_config_t), allocatable, intent(inout) :: phs
type(var_list_t), intent(in) :: var_list
type(os_data_t), intent(in) :: os_data
type(string_t), intent(in) :: process_id
type(mapping_defaults_t), intent(in), optional :: mapping_defaults
type(phs_parameters_t), intent(in), optional :: phs_par
type(string_t), intent(in), optional :: phs_method_in
end subroutine dispatch_phs
<<Dispatch phs: procedures>>=
module subroutine dispatch_phs (phs, var_list, os_data, process_id, &
mapping_defaults, phs_par, phs_method_in)
class(phs_config_t), allocatable, intent(inout) :: phs
type(var_list_t), intent(in) :: var_list
type(os_data_t), intent(in) :: os_data
type(string_t), intent(in) :: process_id
type(mapping_defaults_t), intent(in), optional :: mapping_defaults
type(phs_parameters_t), intent(in), optional :: phs_par
type(string_t), intent(in), optional :: phs_method_in
type(string_t) :: phs_method, phs_file, run_id
logical :: use_equivalences, vis_channels, fatal_beam_decay
integer :: u_phs
logical :: exist
if (present (phs_method_in)) then
phs_method = phs_method_in
else
phs_method = &
var_list%get_sval (var_str ("$phs_method"))
end if
phs_file = &
var_list%get_sval (var_str ("$phs_file"))
use_equivalences = &
var_list%get_lval (var_str ("?use_vamp_equivalences"))
vis_channels = &
var_list%get_lval (var_str ("?vis_channels"))
fatal_beam_decay = &
var_list%get_lval (var_str ("?fatal_beam_decay"))
run_id = &
var_list%get_sval (var_str ("$run_id"))
select case (char (phs_method))
case ("none")
allocate (phs_none_config_t :: phs)
case ("single")
allocate (phs_single_config_t :: phs)
if (vis_channels) then
call msg_warning ("Visualizing phase space channels not " // &
"available for method 'single'.")
end if
case ("rambo")
allocate (phs_rambo_config_t :: phs)
if (vis_channels) &
call msg_warning ("Visualizing phase space channels not " // &
"available for method 'rambo'.")
case ("fks")
allocate (phs_fks_config_t :: phs)
if (use_equivalences) then
select type (phs)
type is (phs_fks_config_t)
call phs%enable_equivalences ()
end select
end if
case ("wood", "default", "fast_wood")
call dispatch_wood ()
case default
call msg_fatal ("Phase space: parameterization method '" &
// char (phs_method) // "' not implemented")
end select
contains
<<Dispatch phs: dispatch phs: procedures>>
end subroutine dispatch_phs
@ %def dispatch_phs
@
<<Dispatch phs: dispatch phs: procedures>>=
subroutine dispatch_wood ()
allocate (phs_wood_config_t :: phs)
select type (phs)
type is (phs_wood_config_t)
if (phs_file /= "") then
inquire (file = char (phs_file), exist = exist)
if (exist) then
call msg_message ("Phase space: reading configuration from '" &
// char (phs_file) // "'")
u_phs = free_unit ()
open (u_phs, file = char (phs_file), &
action = "read", status = "old")
call phs%set_input (u_phs)
else
call msg_fatal ("Phase space: configuration file '" &
// char (phs_file) // "' not found")
end if
end if
if (present (phs_par)) &
call phs%set_parameters (phs_par)
if (use_equivalences) &
call phs%enable_equivalences ()
if (present (mapping_defaults)) &
call phs%set_mapping_defaults (mapping_defaults)
if (phs_method == "fast_wood") phs%use_cascades2 = .true.
phs%vis_channels = vis_channels
phs%fatal_beam_decay = fatal_beam_decay
phs%os_data = os_data
phs%run_id = run_id
end select
end subroutine dispatch_wood
@
@ Configure channel mappings, using some conditions
from the phase space configuration. If there are no structure
functions, we enable a default setup with a single (dummy)
structure-function channel. Otherwise, we look at the channel
collection that we got from the phase-space configuration step. Each
entry should be translated into an independent structure-function
channel, where typically there is one default entry, which could be
mapped using a standard s-channel mapping if the structure function
setup recommends this, and other entries with s-channel resonances.
The latter need to be translated into global mappings from the
structure-function chain.
<<Dispatch phs: public>>=
public :: dispatch_sf_channels
<<Dispatch phs: sub interfaces>>=
module subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, &
coll, var_list, sqrts, beam_structure)
type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel
type(string_t), intent(out) :: sf_string
type(sf_prop_t), intent(in) :: sf_prop
type(phs_channel_collection_t), intent(in) :: coll
type(var_list_t), intent(in) :: var_list
real(default), intent(in) :: sqrts
type(beam_structure_t), intent(in) :: beam_structure
end subroutine dispatch_sf_channels
<<Dispatch phs: procedures>>=
module subroutine dispatch_sf_channels (sf_channel, sf_string, sf_prop, &
coll, var_list, sqrts, beam_structure)
type(sf_channel_t), dimension(:), allocatable, intent(out) :: sf_channel
type(string_t), intent(out) :: sf_string
type(sf_prop_t), intent(in) :: sf_prop
type(phs_channel_collection_t), intent(in) :: coll
type(var_list_t), intent(in) :: var_list
real(default), intent(in) :: sqrts
type(beam_structure_t), intent(in) :: beam_structure
type(beam_structure_t) :: beam_structure_tmp
class(channel_prop_t), allocatable :: prop
integer :: n_strfun, n_sf_channel, i
logical :: sf_allow_s_mapping, circe1_map, circe1_generate
logical :: s_mapping_enable, endpoint_mapping, power_mapping
logical :: single_parameter
integer, dimension(:), allocatable :: s_mapping, single_mapping
real(default) :: s_mapping_power
real(default) :: circe1_mapping_slope, endpoint_mapping_slope
real(default) :: power_mapping_eps
beam_structure_tmp = beam_structure
call beam_structure_tmp%expand (strfun_mode)
n_strfun = beam_structure_tmp%get_n_record ()
sf_string = beam_structure_tmp%to_string (sf_only = .true.)
sf_allow_s_mapping = &
var_list%get_lval (var_str ("?sf_allow_s_mapping"))
circe1_generate = &
var_list%get_lval (var_str ("?circe1_generate"))
circe1_map = &
var_list%get_lval (var_str ("?circe1_map"))
circe1_mapping_slope = &
var_list%get_rval (var_str ("circe1_mapping_slope"))
s_mapping_enable = .false.
s_mapping_power = 1
endpoint_mapping = .false.
endpoint_mapping_slope = 1
power_mapping = .false.
single_parameter = .false.
select case (char (sf_string))
case ("", "[any particles]")
case ("pdf_builtin, none", &
"pdf_builtin_photon, none", &
"none, pdf_builtin", &
"none, pdf_builtin_photon", &
"lhapdf, none", &
"lhapdf_photon, none", &
"none, lhapdf", &
"none, lhapdf_photon")
single_parameter = .true.
case ("pdf_builtin, none => none, pdf_builtin", &
"pdf_builtin, none => none, pdf_builtin_photon", &
"pdf_builtin_photon, none => none, pdf_builtin", &
"pdf_builtin_photon, none => none, pdf_builtin_photon", &
"lhapdf, none => none, lhapdf", &
"lhapdf, none => none, lhapdf_photon", &
"lhapdf_photon, none => none, lhapdf", &
"lhapdf_photon, none => none, lhapdf_photon")
allocate (s_mapping (2), source = [1, 2])
s_mapping_enable = .true.
s_mapping_power = 2
case ("pdf_builtin, none => none, pdf_builtin => epa, none => none, epa", &
"pdf_builtin, none => none, pdf_builtin => ewa, none => none, ewa", &
"pdf_builtin, none => none, pdf_builtin => ewa, none => none, epa", &
"pdf_builtin, none => none, pdf_builtin => epa, none => none, ewa")
allocate (s_mapping (2), source = [1, 2])
s_mapping_enable = .true.
s_mapping_power = 2
case ("isr, none", &
"none, isr")
allocate (single_mapping (1), source = [1])
single_parameter = .true.
case ("isr, none => none, isr")
allocate (s_mapping (2), source = [1, 2])
power_mapping = .true.
power_mapping_eps = minval (sf_prop%isr_eps)
case ("isr, none => none, isr => epa, none => none, epa", &
"isr, none => none, isr => ewa, none => none, ewa", &
"isr, none => none, isr => ewa, none => none, epa", &
"isr, none => none, isr => epa, none => none, ewa")
allocate (s_mapping (2), source = [1, 2])
power_mapping = .true.
power_mapping_eps = minval (sf_prop%isr_eps)
case ("circe1 => isr, none => none, isr => epa, none => none, epa", &
"circe1 => isr, none => none, isr => ewa, none => none, ewa", &
"circe1 => isr, none => none, isr => ewa, none => none, epa", &
"circe1 => isr, none => none, isr => epa, none => none, ewa")
if (circe1_generate) then
allocate (s_mapping (2), source = [2, 3])
else
allocate (s_mapping (3), source = [1, 2, 3])
endpoint_mapping = .true.
endpoint_mapping_slope = circe1_mapping_slope
end if
power_mapping = .true.
power_mapping_eps = minval (sf_prop%isr_eps)
case ("pdf_builtin, none => none, isr", &
"pdf_builtin_photon, none => none, isr", &
"lhapdf, none => none, isr", &
"lhapdf_photon, none => none, isr")
allocate (single_mapping (1), source = [2])
case ("isr, none => none, pdf_builtin", &
"isr, none => none, pdf_builtin_photon", &
"isr, none => none, lhapdf", &
"isr, none => none, lhapdf_photon")
allocate (single_mapping (1), source = [1])
case ("epa, none", &
"none, epa")
allocate (single_mapping (1), source = [1])
single_parameter = .true.
case ("epa, none => none, epa")
allocate (single_mapping (2), source = [1, 2])
case ("epa, none => none, isr", &
"isr, none => none, epa", &
"ewa, none => none, isr", &
"isr, none => none, ewa")
allocate (single_mapping (2), source = [1, 2])
case ("pdf_builtin, none => none, epa", &
"pdf_builtin_photon, none => none, epa", &
"lhapdf, none => none, epa", &
"lhapdf_photon, none => none, epa")
allocate (single_mapping (1), source = [2])
case ("pdf_builtin, none => none, ewa", &
"pdf_builtin_photon, none => none, ewa", &
"lhapdf, none => none, ewa", &
"lhapdf_photon, none => none, ewa")
allocate (single_mapping (1), source = [2])
case ("epa, none => none, pdf_builtin", &
"epa, none => none, pdf_builtin_photon", &
"epa, none => none, lhapdf", &
"epa, none => none, lhapdf_photon")
allocate (single_mapping (1), source = [1])
case ("ewa, none => none, pdf_builtin", &
"ewa, none => none, pdf_builtin_photon", &
"ewa, none => none, lhapdf", &
"ewa, none => none, lhapdf_photon")
allocate (single_mapping (1), source = [1])
case ("ewa, none", &
"none, ewa")
allocate (single_mapping (1), source = [1])
single_parameter = .true.
case ("ewa, none => none, ewa")
allocate (single_mapping (2), source = [1, 2])
case ("energy_scan, none => none, energy_scan")
allocate (s_mapping (2), source = [1, 2])
case ("sf_test_1, none => none, sf_test_1")
allocate (s_mapping (2), source = [1, 2])
case ("circe1")
if (circe1_generate) then
!!! no mapping
else if (circe1_map) then
allocate (s_mapping (1), source = [1])
endpoint_mapping = .true.
endpoint_mapping_slope = circe1_mapping_slope
else
allocate (s_mapping (1), source = [1])
s_mapping_enable = .true.
end if
case ("circe1 => isr, none => none, isr")
if (circe1_generate) then
allocate (s_mapping (2), source = [2, 3])
else
allocate (s_mapping (3), source = [1, 2, 3])
endpoint_mapping = .true.
endpoint_mapping_slope = circe1_mapping_slope
end if
power_mapping = .true.
power_mapping_eps = minval (sf_prop%isr_eps)
case ("circe1 => isr, none", &
"circe1 => none, isr")
allocate (single_mapping (1), source = [2])
case ("circe1 => epa, none => none, epa")
if (circe1_generate) then
allocate (single_mapping (2), source = [2, 3])
else
call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
&only")
end if
case ("circe1 => ewa, none => none, ewa")
if (circe1_generate) then
allocate (single_mapping (2), source = [2, 3])
else
call msg_fatal ("CIRCE/EWA: supported with ?circe1_generate=true &
&only")
end if
case ("circe1 => epa, none", &
"circe1 => none, epa")
if (circe1_generate) then
allocate (single_mapping (1), source = [2])
else
call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
&only")
end if
case ("circe1 => epa, none => none, isr", &
"circe1 => isr, none => none, epa", &
"circe1 => ewa, none => none, isr", &
"circe1 => isr, none => none, ewa")
if (circe1_generate) then
allocate (single_mapping (2), source = [2, 3])
else
call msg_fatal ("CIRCE/EPA: supported with ?circe1_generate=true &
&only")
end if
case ("circe2", &
"gaussian", &
"beam_events")
!!! no mapping
case ("circe2 => isr, none => none, isr", &
"gaussian => isr, none => none, isr", &
"beam_events => isr, none => none, isr")
allocate (s_mapping (2), source = [2, 3])
power_mapping = .true.
power_mapping_eps = minval (sf_prop%isr_eps)
case ("circe2 => isr, none", &
"circe2 => none, isr", &
"gaussian => isr, none", &
"gaussian => none, isr", &
"beam_events => isr, none", &
"beam_events => none, isr")
allocate (single_mapping (1), source = [2])
case ("circe2 => epa, none => none, epa", &
"gaussian => epa, none => none, epa", &
"beam_events => epa, none => none, epa")
allocate (single_mapping (2), source = [2, 3])
case ("circe2 => epa, none", &
"circe2 => none, epa", &
"circe2 => ewa, none", &
"circe2 => none, ewa", &
"gaussian => epa, none", &
"gaussian => none, epa", &
"gaussian => ewa, none", &
"gaussian => none, ewa", &
"beam_events => epa, none", &
"beam_events => none, epa", &
"beam_events => ewa, none", &
"beam_events => none, ewa")
allocate (single_mapping (1), source = [2])
case ("circe2 => epa, none => none, isr", &
"circe2 => isr, none => none, epa", &
"circe2 => ewa, none => none, isr", &
"circe2 => isr, none => none, ewa", &
"gaussian => epa, none => none, isr", &
"gaussian => isr, none => none, epa", &
"gaussian => ewa, none => none, isr", &
"gaussian => isr, none => none, ewa", &
"beam_events => epa, none => none, isr", &
"beam_events => isr, none => none, epa", &
"beam_events => ewa, none => none, isr", &
"beam_events => isr, none => none, ewa")
allocate (single_mapping (2), source = [2, 3])
case ("energy_scan")
case default
call msg_fatal ("Beam structure: " &
// char (sf_string) // " not supported")
end select
if (sf_allow_s_mapping .and. coll%n > 0) then
n_sf_channel = coll%n
allocate (sf_channel (n_sf_channel))
do i = 1, n_sf_channel
call sf_channel(i)%init (n_strfun)
if (allocated (single_mapping)) then
call sf_channel(i)%activate_mapping (single_mapping)
end if
if (allocated (prop)) deallocate (prop)
call coll%get_entry (i, prop)
if (allocated (prop)) then
if (endpoint_mapping .and. power_mapping) then
select type (prop)
type is (resonance_t)
call sf_channel(i)%set_eir_mapping (s_mapping, &
a = endpoint_mapping_slope, eps = power_mapping_eps, &
m = prop%mass / sqrts, w = prop%width / sqrts)
type is (on_shell_t)
call sf_channel(i)%set_eio_mapping (s_mapping, &
a = endpoint_mapping_slope, eps = power_mapping_eps, &
m = prop%mass / sqrts)
end select
else if (endpoint_mapping) then
select type (prop)
type is (resonance_t)
call sf_channel(i)%set_epr_mapping (s_mapping, &
a = endpoint_mapping_slope, &
m = prop%mass / sqrts, w = prop%width / sqrts)
type is (on_shell_t)
call sf_channel(i)%set_epo_mapping (s_mapping, &
a = endpoint_mapping_slope, &
m = prop%mass / sqrts)
end select
else if (power_mapping) then
select type (prop)
type is (resonance_t)
call sf_channel(i)%set_ipr_mapping (s_mapping, &
eps = power_mapping_eps, &
m = prop%mass / sqrts, w = prop%width / sqrts)
type is (on_shell_t)
call sf_channel(i)%set_ipo_mapping (s_mapping, &
eps = power_mapping_eps, &
m = prop%mass / sqrts)
end select
else if (allocated (s_mapping)) then
select type (prop)
type is (resonance_t)
call sf_channel(i)%set_res_mapping (s_mapping, &
m = prop%mass / sqrts, w = prop%width / sqrts, &
single = single_parameter)
type is (on_shell_t)
call sf_channel(i)%set_os_mapping (s_mapping, &
m = prop%mass / sqrts, &
single = single_parameter)
end select
else if (allocated (single_mapping)) then
select type (prop)
type is (resonance_t)
call sf_channel(i)%set_res_mapping (single_mapping, &
m = prop%mass / sqrts, w = prop%width / sqrts, &
single = single_parameter)
type is (on_shell_t)
call sf_channel(i)%set_os_mapping (single_mapping, &
m = prop%mass / sqrts, &
single = single_parameter)
end select
end if
else if (endpoint_mapping .and. power_mapping) then
call sf_channel(i)%set_ei_mapping (s_mapping, &
a = endpoint_mapping_slope, eps = power_mapping_eps)
else if (endpoint_mapping .and. .not. allocated (single_mapping)) then
call sf_channel(i)%set_ep_mapping (s_mapping, &
a = endpoint_mapping_slope)
else if (power_mapping .and. .not. allocated (single_mapping)) then
call sf_channel(i)%set_ip_mapping (s_mapping, &
eps = power_mapping_eps)
else if (s_mapping_enable .and. .not. allocated (single_mapping)) then
call sf_channel(i)%set_s_mapping (s_mapping, &
power = s_mapping_power)
end if
end do
else if (sf_allow_s_mapping) then
allocate (sf_channel (1))
call sf_channel(1)%init (n_strfun)
if (allocated (single_mapping)) then
call sf_channel(1)%activate_mapping (single_mapping)
else if (endpoint_mapping .and. power_mapping) then
call sf_channel(i)%set_ei_mapping (s_mapping, &
a = endpoint_mapping_slope, eps = power_mapping_eps)
else if (endpoint_mapping) then
call sf_channel(1)%set_ep_mapping (s_mapping, &
a = endpoint_mapping_slope)
else if (power_mapping) then
call sf_channel(1)%set_ip_mapping (s_mapping, &
eps = power_mapping_eps)
else if (s_mapping_enable) then
call sf_channel(1)%set_s_mapping (s_mapping, &
power = s_mapping_power)
end if
else
allocate (sf_channel (1))
call sf_channel(1)%init (n_strfun)
if (allocated (single_mapping)) then
call sf_channel(1)%activate_mapping (single_mapping)
end if
end if
end subroutine dispatch_sf_channels
@ %def dispatch_sf_channels
@
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[dispatch_phs_ut.f90]]>>=
<<File header>>
module dispatch_phs_ut
use unit_tests
use dispatch_phs_uti
<<Standard module head>>
<<Dispatch phs: public test>>
contains
<<Dispatch phs: test driver>>
end module dispatch_phs_ut
@ %def dispatch_phs_ut
@
<<[[dispatch_phs_uti.f90]]>>=
<<File header>>
module dispatch_phs_uti
<<Use kinds>>
<<Use strings>>
use variables
use io_units, only: free_unit
use os_interface, only: os_data_t
use process_constants
use model_data
use models
use phs_base
use phs_none
use phs_forests
use phs_wood
use mappings
use dispatch_phase_space
<<Standard module head>>
<<Dispatch phs: test declarations>>
contains
<<Dispatch phs: tests>>
end module dispatch_phs_uti
@ %def dispatch_phs_ut
@ API: driver for the unit tests below.
<<Dispatch phs: public test>>=
public ::dispatch_phs_test
<<Dispatch phs: test driver>>=
subroutine dispatch_phs_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Dispatch phs: execute tests>>
end subroutine dispatch_phs_test
@ %def dispatch_phs_test
@
\subsubsection{Select type: phase-space configuration object}
<<Dispatch phs: execute tests>>=
call test (dispatch_phs_1, "dispatch_phs_1", &
"phase-space configuration", &
u, results)
<<Dispatch phs: test declarations>>=
public :: dispatch_phs_1
<<Dispatch phs: tests>>=
subroutine dispatch_phs_1 (u)
integer, intent(in) :: u
type(var_list_t) :: var_list
class(phs_config_t), allocatable :: phs
type(phs_parameters_t) :: phs_par
type(os_data_t) :: os_data
type(mapping_defaults_t) :: mapping_defs
write (u, "(A)") "* Test output: dispatch_phs_1"
write (u, "(A)") "* Purpose: select phase-space configuration method"
write (u, "(A)")
call var_list%init_defaults (0)
write (u, "(A)") "* Allocate PHS as phs_none_t"
write (u, "(A)")
call var_list%set_string (&
var_str ("$phs_method"), &
var_str ("none"), is_known = .true.)
call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
call phs%write (u)
call phs%final ()
deallocate (phs)
write (u, "(A)")
write (u, "(A)") "* Allocate PHS as phs_single_t"
write (u, "(A)")
call var_list%set_string (&
var_str ("$phs_method"), &
var_str ("single"), is_known = .true.)
call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
call phs%write (u)
call phs%final ()
deallocate (phs)
write (u, "(A)")
write (u, "(A)") "* Allocate PHS as phs_wood_t"
write (u, "(A)")
call var_list%set_string (&
var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"))
call phs%write (u)
call phs%final ()
deallocate (phs)
write (u, "(A)")
write (u, "(A)") "* Setting parameters for phs_wood_t"
write (u, "(A)")
phs_par%m_threshold_s = 123
phs_par%m_threshold_t = 456
phs_par%t_channel = 42
phs_par%off_shell = 17
phs_par%keep_nonresonant = .false.
mapping_defs%energy_scale = 987
mapping_defs%invariant_mass_scale = 654
mapping_defs%momentum_transfer_scale = 321
mapping_defs%step_mapping = .false.
mapping_defs%step_mapping_exp = .false.
mapping_defs%enable_s_mapping = .true.
call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_1"), &
mapping_defs, phs_par)
call phs%write (u)
call phs%final ()
call var_list%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: dispatch_phs_1"
end subroutine dispatch_phs_1
@ %def dispatch_phs_1
@
\subsubsection{Phase-space configuration with file}
<<Dispatch phs: execute tests>>=
call test (dispatch_phs_2, "dispatch_phs_2", &
"configure phase space using file", &
u, results)
<<Dispatch phs: test declarations>>=
public :: dispatch_phs_2
<<Dispatch phs: tests>>=
subroutine dispatch_phs_2 (u)
use phs_base_ut, only: init_test_process_data
use phs_wood_ut, only: write_test_phs_file
use phs_forests
integer, intent(in) :: u
type(var_list_t) :: var_list
type(os_data_t) :: os_data
type(process_constants_t) :: process_data
type(model_list_t) :: model_list
type(model_t), pointer :: model
class(phs_config_t), allocatable :: phs
integer :: u_phs
write (u, "(A)") "* Test output: dispatch_phs_2"
write (u, "(A)") "* Purpose: select 'wood' phase-space &
&for a test process"
write (u, "(A)") "* and read phs configuration from file"
write (u, "(A)")
write (u, "(A)") "* Initialize a process"
write (u, "(A)")
call var_list%init_defaults (0)
call os_data%init ()
call syntax_model_file_init ()
call model_list%read_model &
(var_str ("Test"), var_str ("Test.mdl"), os_data, model)
call syntax_phs_forest_init ()
call init_test_process_data (var_str ("dispatch_phs_2"), process_data)
write (u, "(A)") "* Write phase-space file"
u_phs = free_unit ()
open (u_phs, file = "dispatch_phs_2.phs", action = "write", status = "replace")
call write_test_phs_file (u_phs, var_str ("dispatch_phs_2"))
close (u_phs)
write (u, "(A)")
write (u, "(A)") "* Allocate PHS as phs_wood_t"
write (u, "(A)")
call var_list%set_string (&
var_str ("$phs_method"), &
var_str ("wood"), is_known = .true.)
call var_list%set_string (&
var_str ("$phs_file"), &
var_str ("dispatch_phs_2.phs"), is_known = .true.)
call dispatch_phs (phs, var_list, os_data, var_str ("dispatch_phs_2"))
call phs%init (process_data, model)
call phs%configure (sqrts = 1000._default)
call phs%write (u)
write (u, "(A)")
select type (phs)
type is (phs_wood_config_t)
call phs%write_forest (u)
end select
call phs%final ()
call var_list%final ()
call syntax_model_file_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: dispatch_phs_2"
end subroutine dispatch_phs_2
@ %def dispatch_phs_2
@