Page MenuHomeHEPForge
Files F9501556

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
Index: trunk/src/particles/particles.nw
===================================================================
--- trunk/src/particles/particles.nw (revision 8881)
+++ trunk/src/particles/particles.nw (revision 8882)
@@ -1,9697 +1,9715 @@
%% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: particle objects
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Particles}
\includemodulegraph{particles}
This chapter collects modules that implement particle objects, for use in
event records.
While within interactions, all correlations are
manifest, a particle array is derived by selecting a particular
quantum number set. This involves tracing over all other particles,
as far as polarization is concerned. Thus, a particle has definite
flavor, color, and a single-particle density matrix for polarization.
\begin{description}
\item[su\_algebra]
We make use of $su(N)$ generators as the basis for representing
polarization matrices. This module defines the basis and provides
the necessary transformation routines.
\item[bloch\_vectors]
This defines polarization objects in Bloch representation. The
object describes the spin density matrix of a particle,
currently restricted to spin $0\ldots 2$.
\item[polarizations]
This extends the basic polarization object such that it supports
properties of physical particles and appropriate constructors.
\item[particles]
Particle objects and particle lists, as the base of event records.
\end{description}
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{$su(N)$ Algebra}
We need a specific choice of basis for a well-defined component
representation. The matrix elements of $T^a$ are
ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to
lowest weight, for both row and column.
We list first the generators of the $su(2)$ subalgebras which leave
$|m|$ invariant ($|m|\neq 0$):
\begin{equation}
T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3}
\end{equation}
acting on the respective subspace $|m|=\ell,\ell-1,\ldots$ for
$b=0,1,\ldots$. This defines generators $T^a$ for $a=1,\ldots 3N/2$
($\ldots 3(N-1)/2$) for $N$ even (odd), respectively.
The following generators successively extend this to $su(4)$, $su(6)$,
\ldots until $su(N)$ by adding first the missing off-diagonal and then
diagonal generators. The phase conventions are analogous.
(It should be possible to code these conventions for generic spin, but
in the current implementation we restrict ourselves to $s\leq 2$, i.e.,
$N\leq 5$.)
<<[[su_algebra.f90]]>>=
<<File header>>
module su_algebra
<<Use kinds>>
<<Standard module head>>
<<SU algebra: public>>
interface
<<SU algebra: sub interfaces>>
end interface
end module su_algebra
@ %def su_algebra
@
<<[[su_algebra_sub.f90]]>>=
<<File header>>
submodule (su_algebra) su_algebra_s
use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
implicit none
contains
<<SU algebra: procedures>>
end submodule su_algebra_s
@ %def su_algbra_s
@
\subsection{$su(N)$ fundamental representation}
The dimension of the basis for a given spin type. consecutively, starting at
[[SCALAR=1]].
<<SU algebra: public>>=
public :: algebra_dimension
<<SU algebra: sub interfaces>>=
module function algebra_dimension (s) result (n)
integer :: n
integer, intent(in) :: s
end function algebra_dimension
<<SU algebra: procedures>>=
module function algebra_dimension (s) result (n)
integer :: n
integer, intent(in) :: s
n = fundamental_dimension (s) ** 2 - 1
end function algebra_dimension
@ %def algebra_dimension
@ The dimension of the fundamental (defining) representation that we
use. This implementation assumes that the spin type is numerically
equal to the fundamental dimension.
<<SU algebra: public>>=
public :: fundamental_dimension
<<SU algebra: sub interfaces>>=
module function fundamental_dimension (s) result (d)
integer :: d
integer, intent(in) :: s
end function fundamental_dimension
<<SU algebra: procedures>>=
module function fundamental_dimension (s) result (d)
integer :: d
integer, intent(in) :: s
d = s
end function fundamental_dimension
@ %def fundamental_dimension
@
\subsection{Mapping between helicity and matrix index}
Return the helicity that corresponds to a particular entry in the
polarization matrix representation. Helicities are counted downwards,
in integers, and zero helicity is included (omitted) for odd (even)
spin, respectively.
<<SU algebra: public>>=
public :: helicity_value
<<SU algebra: sub interfaces>>=
module function helicity_value (s, i) result (h)
integer :: h
integer, intent(in) :: s, i
end function helicity_value
<<SU algebra: procedures>>=
module function helicity_value (s, i) result (h)
integer :: h
integer, intent(in) :: s, i
integer, dimension(1), parameter :: hh1 = [0]
integer, dimension(2), parameter :: hh2 = [1, -1]
integer, dimension(3), parameter :: hh3 = [1, 0, -1]
integer, dimension(4), parameter :: hh4 = [2, 1, -1, -2]
integer, dimension(5), parameter :: hh5 = [2, 1, 0, -1, -2]
h = 0
select case (s)
case (SCALAR)
select case (i)
case (1:1); h = hh1(i)
end select
case (SPINOR)
select case (i)
case (1:2); h = hh2(i)
end select
case (VECTOR)
select case (i)
case (1:3); h = hh3(i)
end select
case (VECTORSPINOR)
select case (i)
case (1:4); h = hh4(i)
end select
case (TENSOR)
select case (i)
case (1:5); h = hh5(i)
end select
end select
end function helicity_value
@ %def helicity_value
@ Inverse: return the index that corresponds to a certain
helicity value in the chosen representation.
<<SU algebra: public>>=
public :: helicity_index
<<SU algebra: sub interfaces>>=
module function helicity_index (s, h) result (i)
integer, intent(in) :: s, h
integer :: i
end function helicity_index
<<SU algebra: procedures>>=
module function helicity_index (s, h) result (i)
integer, intent(in) :: s, h
integer :: i
integer, dimension(0:0), parameter :: hi1 = [1]
integer, dimension(-1:1), parameter :: hi2 = [2, 0, 1]
integer, dimension(-1:1), parameter :: hi3 = [3, 2, 1]
integer, dimension(-2:2), parameter :: hi4 = [4, 3, 0, 2, 1]
integer, dimension(-2:2), parameter :: hi5 = [5, 4, 3, 2, 1]
select case (s)
case (SCALAR)
i = hi1(h)
case (SPINOR)
i = hi2(h)
case (VECTOR)
i = hi3(h)
case (VECTORSPINOR)
i = hi4(h)
case (TENSOR)
i = hi5(h)
end select
end function helicity_index
@ %def helicity_index
@
\subsection{Generator Basis: Cartan Generators}
For each supported spin type, we return specific properties of the
set of generators via inquiry functions. This is equivalent to using
explicit representations of the generators.
For easy access, the properties are hard-coded and selected via case
expressions.
Return true if the generator \#[[i]] is in the Cartan subalgebra,
i.e., a diagonal matrix for spin type [[s]].
<<SU algebra: public>>=
public :: is_cartan_generator
<<SU algebra: sub interfaces>>=
elemental module function is_cartan_generator (s, i) result (cartan)
logical :: cartan
integer, intent(in) :: s, i
end function is_cartan_generator
<<SU algebra: procedures>>=
elemental module function is_cartan_generator (s, i) result (cartan)
logical :: cartan
integer, intent(in) :: s, i
select case (s)
case (SCALAR)
case (SPINOR)
select case (i)
case (3); cartan = .true.
case default
cartan = .false.
end select
case (VECTOR)
select case (i)
case (3,8); cartan = .true.
case default
cartan = .false.
end select
case (VECTORSPINOR)
select case (i)
case (3,6,15); cartan = .true.
case default
cartan = .false.
end select
case (TENSOR)
select case (i)
case (3,6,15,24); cartan = .true.
case default
cartan = .false.
end select
case default
cartan = .false.
end select
end function is_cartan_generator
@ %def is_cartan_generator
@ Return the index of Cartan generator \#[[k]] in the chosen
representation. This has to conform to [[cartan]] above.
<<SU algebra: public>>=
public :: cartan_index
<<SU algebra: sub interfaces>>=
elemental module function cartan_index (s, k) result (ci)
integer :: ci
integer, intent(in) :: s, k
end function cartan_index
<<SU algebra: procedures>>=
elemental module function cartan_index (s, k) result (ci)
integer :: ci
integer, intent(in) :: s, k
integer, dimension(1), parameter :: ci2 = [3]
integer, dimension(2), parameter :: ci3 = [3,8]
integer, dimension(3), parameter :: ci4 = [3,6,15]
integer, dimension(4), parameter :: ci5 = [3,6,15,24]
select case (s)
case (SPINOR)
ci = ci2(k)
case (VECTOR)
ci = ci3(k)
case (VECTORSPINOR)
ci = ci4(k)
case (TENSOR)
ci = ci5(k)
case default
ci = 0
end select
end function cartan_index
@ %def cartan_index
@ The element \#[[k]] of the result vector [[a]] is equal to the
$(h,h)$ diagonal entry of the generator matrix $T^k$. That is,
evaluating this for all allowed values of [[h]], we recover the set of
Cartan generator matrices.
<<SU algebra: public>>=
public :: cartan_element
<<SU algebra: sub interfaces>>=
module function cartan_element (s, h) result (a)
real(default), dimension(:), allocatable :: a
integer, intent(in) :: s, h
end function cartan_element
<<SU algebra: procedures>>=
module function cartan_element (s, h) result (a)
real(default), dimension(:), allocatable :: a
integer, intent(in) :: s, h
real(default), parameter :: sqrt2 = sqrt (2._default)
real(default), parameter :: sqrt3 = sqrt (3._default)
real(default), parameter :: sqrt10 = sqrt (10._default)
allocate (a (algebra_dimension (s)), source = 0._default)
select case (s)
case (SCALAR)
case (SPINOR)
select case (h)
case (1)
a(3) = 1._default / 2
case (-1)
a(3) = -1._default / 2
end select
case (VECTOR)
select case (h)
case (1)
a(3) = 1._default / 2
a(8) = 1._default / (2 * sqrt3)
case (-1)
a(3) = -1._default / 2
a(8) = 1._default / (2 * sqrt3)
case (0)
a(8) = -1._default / sqrt3
end select
case (VECTORSPINOR)
select case (h)
case (2)
a(3) = 1._default / 2
a(15) = 1._default / (2 * sqrt2)
case (-2)
a(3) = -1._default / 2
a(15) = 1._default / (2 * sqrt2)
case (1)
a(6) = 1._default / 2
a(15) = -1._default / (2 * sqrt2)
case (-1)
a(6) = -1._default / 2
a(15) = -1._default / (2 * sqrt2)
end select
case (TENSOR)
select case (h)
case (2)
a(3) = 1._default / 2
a(15) = 1._default / (2 * sqrt2)
a(24) = 1._default / (2 * sqrt10)
case (-2)
a(3) = -1._default / 2
a(15) = 1._default / (2 * sqrt2)
a(24) = 1._default / (2 * sqrt10)
case (1)
a(6) = 1._default / 2
a(15) = -1._default / (2 * sqrt2)
a(24) = 1._default / (2 * sqrt10)
case (-1)
a(6) = -1._default / 2
a(15) = -1._default / (2 * sqrt2)
a(24) = 1._default / (2 * sqrt10)
case (0)
a(24) = -4._default / (2 * sqrt10)
end select
end select
end function cartan_element
@ %def cartan_element
@ Given an array of diagonal matrix elements [[rd]] of a generator,
compute the array [[a]] of basis coefficients. The array must be
ordered as defined by [[helicity_value]], i.e., highest weight first.
The calculation is organized such that the trace of the generator,
i.e., the sum of [[rd]] values, drops out. The result array [[a]] has
coefficients for all basis generators, but only Cartan generators can
get a nonzero coefficient.
<<SU algebra: public>>=
public :: cartan_coeff
<<SU algebra: sub interfaces>>=
module function cartan_coeff (s, rd) result (a)
real(default), dimension(:), allocatable :: a
integer, intent(in) :: s
real(default), dimension(:), intent(in) :: rd
end function cartan_coeff
<<SU algebra: procedures>>=
module function cartan_coeff (s, rd) result (a)
real(default), dimension(:), allocatable :: a
integer, intent(in) :: s
real(default), dimension(:), intent(in) :: rd
real(default), parameter :: sqrt2 = sqrt (2._default)
real(default), parameter :: sqrt3 = sqrt (3._default)
real(default), parameter :: sqrt10 = sqrt (10._default)
integer :: n
n = algebra_dimension (s)
allocate (a (n), source = 0._default)
select case (s)
case (SPINOR)
a(3) = rd(1) - rd(2)
case (VECTOR)
a(3) = rd(1) - rd(3)
a(8) = (rd(1) - 2 * rd(2) + rd(3)) / sqrt3
case (VECTORSPINOR)
a(3) = rd(1) - rd(4)
a(6) = rd(2) - rd(3)
a(15) = (rd(1) - rd(2) - rd(3) + rd(4)) / sqrt2
case (TENSOR)
a(3) = rd(1) - rd(5)
a(6) = rd(2) - rd(4)
a(15) = (rd(1) - rd(2) - rd(4) + rd(5)) / sqrt2
a(24) = (rd(1) + rd(2) - 4 * rd(3) + rd(4) + rd(5)) / sqrt10
end select
end function cartan_coeff
@ %def cartan_coeff
@
\subsection{Roots (Off-Diagonal Generators)}
Return the appropriate generator index for a given off-diagonal helicity
combination. We require $h_1>h_2$. We return the index of the
appropriate real-valued generator if [[r]] is true, else the
complex-valued one.
This is separate from the [[cartan_coeff]] function above. The reason
is that the off-diagonal generators have only a single nonzero matrix
element, so there is a one-to-one correspondence of helicity and index.
<<SU algebra: public>>=
public :: root_index
<<SU algebra: sub interfaces>>=
module function root_index (s, h1, h2, r) result (ai)
integer :: ai
integer, intent(in) :: s, h1, h2
logical :: r
end function root_index
<<SU algebra: procedures>>=
module function root_index (s, h1, h2, r) result (ai)
integer :: ai
integer, intent(in) :: s, h1, h2
logical :: r
ai = 0
select case (s)
case (SCALAR)
case (SPINOR)
select case (h1)
case (1)
select case (h2)
case (-1); ai = 1
end select
end select
case (VECTOR)
select case (h1)
case (1)
select case (h2)
case (-1); ai = 1
case (0); ai = 4
end select
case (0)
select case (h2)
case (-1); ai = 6
end select
end select
case (VECTORSPINOR)
select case (h1)
case (2)
select case (h2)
case (-2); ai = 1
case (1); ai = 7
case (-1); ai = 11
end select
case (1)
select case (h2)
case (-1); ai = 4
case (-2); ai = 13
end select
case (-1)
select case (h2)
case (-2); ai = 9
end select
end select
case (TENSOR)
select case (h1)
case (2)
select case (h2)
case (-2); ai = 1
case (1); ai = 7
case (-1); ai = 11
case (0); ai = 16
end select
case (1)
select case (h2)
case (-1); ai = 4
case (-2); ai = 13
case (0); ai = 20
end select
case (-1)
select case (h2)
case (-2); ai = 9
end select
case (0)
select case (h2)
case (-2); ai = 18
case (-1); ai = 22
end select
end select
end select
if (ai /= 0 .and. .not. r) ai = ai + 1
end function root_index
@ %def root_index
@ Inverse: return the helicity values ($h_2>h_1$) for an off-diagonal
generator. The flag [[r]] tells whether this is a real or diagonal
generator. The others are Cartan generators.
<<SU algebra: public>>=
public :: root_helicity
<<SU algebra: sub interfaces>>=
module subroutine root_helicity (s, i, h1, h2, r)
integer, intent(in) :: s, i
integer, intent(out) :: h1, h2
logical, intent(out) :: r
end subroutine root_helicity
<<SU algebra: procedures>>=
module subroutine root_helicity (s, i, h1, h2, r)
integer, intent(in) :: s, i
integer, intent(out) :: h1, h2
logical, intent(out) :: r
h1 = 0
h2 = 0
r = .false.
select case (s)
case (SCALAR)
case (SPINOR)
select case (i)
case ( 1, 2); h1 = 1; h2 = -1; r = i == 1
end select
case (VECTOR)
select case (i)
case ( 1, 2); h1 = 1; h2 = -1; r = i == 1
case ( 4, 5); h1 = 1; h2 = 0; r = i == 4
case ( 6, 7); h1 = 0; h2 = -1; r = i == 6
end select
case (VECTORSPINOR)
select case (i)
case ( 1, 2); h1 = 2; h2 = -2; r = i == 1
case ( 4, 5); h1 = 1; h2 = -1; r = i == 4
case ( 7, 8); h1 = 2; h2 = 1; r = i == 7
case ( 9,10); h1 = -1; h2 = -2; r = i == 9
case (11,12); h1 = 2; h2 = -1; r = i ==11
case (13,14); h1 = 1; h2 = -2; r = i ==13
end select
case (TENSOR)
select case (i)
case ( 1, 2); h1 = 2; h2 = -2; r = i == 1
case ( 4, 5); h1 = 1; h2 = -1; r = i == 4
case ( 7, 8); h1 = 2; h2 = 1; r = i == 7
case ( 9,10); h1 = -1; h2 = -2; r = i == 9
case (11,12); h1 = 2; h2 = -1; r = i ==11
case (13,14); h1 = 1; h2 = -2; r = i ==13
case (16,17); h1 = 2; h2 = 0; r = i ==16
case (18,19); h1 = 0; h2 = -2; r = i ==18
case (20,21); h1 = 1; h2 = 0; r = i ==20
case (22,23); h1 = 0; h2 = -1; r = i ==22
end select
end select
end subroutine root_helicity
@ %def root_helicity
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[su_algebra_ut.f90]]>>=
<<File header>>
module su_algebra_ut
use unit_tests
use su_algebra_uti
<<Standard module head>>
<<SU algebra: public test>>
contains
<<SU algebra: test driver>>
end module su_algebra_ut
@ %def su_algebra_ut
@
<<[[su_algebra_uti.f90]]>>=
<<File header>>
module su_algebra_uti
<<Use kinds>>
use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
use su_algebra
<<Standard module head>>
<<SU algebra: test declarations>>
contains
<<SU algebra: tests>>
end module su_algebra_uti
@ %def su_algebra_ut
@ API: driver for the unit tests below.
<<SU algebra: public test>>=
public :: su_algebra_test
<<SU algebra: test driver>>=
subroutine su_algebra_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SU algebra: execute tests>>
end subroutine su_algebra_test
@ %def su_algebra_test
@
\subsubsection{Generator Ordering}
Show the position of Cartan generators in the sequence of basis generators.
<<SU algebra: execute tests>>=
call test (su_algebra_1, "su_algebra_1", &
"generator ordering", &
u, results)
<<SU algebra: test declarations>>=
public :: su_algebra_1
<<SU algebra: tests>>=
subroutine su_algebra_1 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: su_algebra_1"
write (u, "(A)") "* Purpose: test su(N) algebra implementation"
write (u, "(A)")
write (u, "(A)") "* su(N) generators: &
&list and mark Cartan subalgebra"
write (u, "(A)")
write (u, "(A)") "* s = 0"
call cartan_check (SCALAR)
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call cartan_check (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call cartan_check (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call cartan_check (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call cartan_check (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: su_algebra_1"
contains
subroutine cartan_check (s)
integer, intent(in) :: s
integer :: i
write (u, *)
do i = 1, algebra_dimension (s)
write (u, "(1x,L1)", advance="no") is_cartan_generator (s, i)
end do
write (u, *)
end subroutine cartan_check
end subroutine su_algebra_1
@ %def su_algebra_1
@
\subsubsection{Cartan Generator Basis}
Show the explicit matrix representation for all Cartan generators and
check their traces and Killing products.
Also test helicity index mappings.
<<SU algebra: execute tests>>=
call test (su_algebra_2, "su_algebra_2", &
"Cartan generator representation", &
u, results)
<<SU algebra: test declarations>>=
public :: su_algebra_2
<<SU algebra: tests>>=
subroutine su_algebra_2 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: su_algebra_2"
write (u, "(A)") "* Purpose: test su(N) algebra implementation"
write (u, "(A)")
write (u, "(A)") "* diagonal su(N) generators: &
&show explicit representation"
write (u, "(A)") "* and check trace and Killing form"
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call cartan_show (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call cartan_show (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call cartan_show (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call cartan_show (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: su_algebra_2"
contains
subroutine cartan_show (s)
integer, intent(in) :: s
real(default), dimension(:,:), allocatable :: rd
integer, dimension(:), allocatable :: ci
integer :: n, d, h, i, j, k, l
n = algebra_dimension (s)
d = fundamental_dimension (s)
write (u, *)
write (u, "(A2,5X)", advance="no") "h:"
do i = 1, d
j = helicity_index (s, helicity_value (s, i))
write (u, "(1x,I2,5X)", advance="no") helicity_value (s, j)
end do
write (u, "(8X)", advance="no")
write (u, "(1X,A)") "tr"
allocate (rd (n,d), source = 0._default)
do i = 1, d
h = helicity_value (s, i)
rd(:,i) = cartan_element (s, h)
end do
allocate (ci (d-1), source = 0)
do k = 1, d-1
ci(k) = cartan_index (s, k)
end do
write (u, *)
do k = 1, d-1
write (u, "('T',I2,':',1X)", advance="no") ci(k)
do i = 1, d
write (u, 1, advance="no") rd(ci(k),i)
end do
write (u, "(8X)", advance="no")
write (u, 1) sum (rd(ci(k),:))
end do
write (u, *)
write (u, "(6X)", advance="no")
do k = 1, d-1
write (u, "(2X,'T',I2,3X)", advance="no") ci(k)
end do
write (u, *)
do k = 1, d-1
write (u, "('T',I2,2X)", advance="no") ci(k)
do l = 1, d-1
write (u, 1, advance="no") dot_product (rd(ci(k),:), rd(ci(l),:))
end do
write (u, *)
end do
1 format (1x,F7.4)
end subroutine cartan_show
end subroutine su_algebra_2
@ %def su_algebra_2
@
\subsubsection{Bloch Representation: Cartan Generators}
Transform from Bloch vectors to matrix and back, considering Cartan
generators only.
<<SU algebra: execute tests>>=
call test (su_algebra_3, "su_algebra_3", &
"Cartan generator mapping", &
u, results)
<<SU algebra: test declarations>>=
public :: su_algebra_3
<<SU algebra: tests>>=
subroutine su_algebra_3 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: su_algebra_3"
write (u, "(A)") "* Purpose: test su(N) algebra implementation"
write (u, "(A)")
write (u, "(A)") "* diagonal su(N) generators: &
&transform to matrix and back"
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call cartan_expand (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call cartan_expand (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call cartan_expand (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call cartan_expand (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: su_algebra_3"
contains
subroutine cartan_expand (s)
integer, intent(in) :: s
real(default), dimension(:,:), allocatable :: rd
integer, dimension(:), allocatable :: ci
real(default), dimension(:), allocatable :: a
logical, dimension(:), allocatable :: mask
integer :: n, d, h, i, k, l
n = algebra_dimension (s)
d = fundamental_dimension (s)
allocate (rd (n,d), source = 0._default)
do i = 1, d
h = helicity_value (s, i)
rd(:,i) = cartan_element (s, h)
end do
allocate (ci (d-1), source = 0)
do k = 1, d-1
ci(k) = cartan_index (s, k)
end do
allocate (a (n))
write (u, *)
do k = 1, d-1
a(:) = cartan_coeff (s, rd(ci(k),:))
write (u, "('T',I2,':',1X)", advance="no") ci(k)
do i = 1, n
if (is_cartan_generator (s, i)) then
write (u, 1, advance="no") a(i)
else if (a(i) /= 0) then
! this should not happen (nonzero non-Cartan entry)
write (u, "(1X,':',I2,':',3X)", advance="no") i
end if
end do
write (u, *)
end do
1 format (1X,F7.4)
end subroutine cartan_expand
end subroutine su_algebra_3
@ %def su_algebra_3
@
\subsubsection{Bloch Representation: Roots}
List the mapping between helicity transitions and (real) off-diagonal
generators.
<<SU algebra: execute tests>>=
call test (su_algebra_4, "su_algebra_4", &
"Root-helicity mapping", &
u, results)
<<SU algebra: test declarations>>=
public :: su_algebra_4
<<SU algebra: tests>>=
subroutine su_algebra_4 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: su_algebra_4"
write (u, "(A)") "* Purpose: test su(N) algebra implementation"
write (u, "(A)")
write (u, "(A)") "* off-diagonal su(N) generators: &
&mapping from/to helicity pair"
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call root_expand (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call root_expand (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call root_expand (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call root_expand (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: su_algebra_4"
contains
subroutine root_expand (s)
integer, intent(in) :: s
integer :: n, d, i, j, h1, h2
logical :: r
n = algebra_dimension (s)
write (u, *)
do i = 1, n
if (is_cartan_generator (s, i)) cycle
call root_helicity (s, i, h1, h2, r)
j = root_index (s, h1, h2, r)
write (u, "('T',I2,':')", advance="no") j
write (u, "(2(1x,I2))", advance="no") h1, h2
if (r) then
write (u, *)
else
write (u, "('*')")
end if
end do
end subroutine root_expand
end subroutine su_algebra_4
@ %def su_algebra_4
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Bloch Representation}
Particle polarization is determined by a particular quantum state
which has just helicity information. Physically, this is the spin
density matrix $\rho$, where we do not restrict ourselves to pure
states.
We adopt the phase convention for a spin-1/2 particle that
\begin{equation}
\rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma)
\end{equation}
with the polarization axis $\vec\alpha$. For a particle with
arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above
definition to generalized Bloch form
\begin{equation}
\rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right)
\end{equation}
where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra
generators. These $N\times N$ matrices are hermitean, traceless, and
orthogonal via
\begin{equation}
\mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab}
\end{equation}
In the spin-1/2 case, this reduces to the above (standard Bloch)
representation since $T^a = \sigma^a/2$, $a=1,2,3$. For the spin-1
case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices,
\begin{equation}
\rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right),
\end{equation}
The normalization is chosen that $|alpha|\leq 1$ for allowed density
matrix, where $|\alpha|=1$ is a necessary, but not sufficient,
condition for a pure state.
We need a specific choice of basis for a well-defined component
representation. The matrix elements of $T^a$ are
ordered as $m=\ell,\ell-1,\ldots -\ell$, i.e., from highest down to
lowest weight, for both row and column.
We list first the generators of the $su(2)$ subalgebras which leave
$|m|$ invariant ($|m|\neq 0$):
\begin{equation}
T^{b+1,b+2,b+3} \equiv \sigma^{1,2,3}
\end{equation}
acting on the respective subspace $|m|=\ell,\ell-1,\ldots$ for
$b=0,1,\ldots$. This defines generators $T^a$ for $a=1,\ldots 3N/2$
($\ldots 3(N-1)/2$) for $N$ even (odd), respectively.
The following generators successively extend this to $su(4)$, $su(6)$,
\ldots until $su(N)$ by adding first the missing off-diagonal and then
diagonal generators. The phase conventions are analogous.
(It should be possible to code these conventions for generic spin, but
in the current implementation we restrict ourselves to $s\leq 2$, i.e.,
$N\leq 5$.)
Particle polarization is determined by a particular quantum state
which has just helicity information. Physically, this is the spin
density matrix $\rho$, where we do not restrict ourselves to pure
states.
We adopt the phase convention for a spin-1/2 particle that
\begin{equation}
\rho = \tfrac12(1 + \vec\alpha\cdot\vec\sigma)
\end{equation}
with the polarization axis $\vec\alpha$. For a particle with
arbitrary spin $s$, and thus $N=2s+1$ spin states, we extend the above
definition to generalized Bloch form
\begin{equation}
\rho = \frac1N\left(1 + \sqrt{2N(N-1)}\alpha^aT^a\right)
\end{equation}
where the $T^a$ ($a=1,\ldots N^2-1$) are a basis of $su(N)$ algebra
generators. These $N\times N$ matrices are hermitean, traceless, and
orthogonal via
\begin{equation}
\mathop{\rm Tr}T^aT^b = \frac12 \delta^{ab}
\end{equation}
In the spin-1/2 case, this reduces to the above (standard Bloch)
representation since $T^a = \sigma^a/2$, $a=1,2,3$. For the spin-1
case, we could use $T^a = \lambda^a/2$ with the Gell-Mann matrices,
\begin{equation}
\rho = \frac13\left(1 + \sqrt{3}\alpha^a\lambda^a\right),
\end{equation}
The normalization is chosen that $|alpha|\leq 1$ for allowed density
matrix, where $|\alpha|=1$ is a necessary, but not sufficient,
condition for a pure state.
<<[[bloch_vectors.f90]]>>=
<<File header>>
module bloch_vectors
<<Use kinds>>
use physics_defs, only: UNKNOWN
<<Standard module head>>
<<Bloch vectors: public>>
<<Bloch vectors: types>>
interface
<<Bloch vectors: sub interfaces>>
end interface
end module bloch_vectors
@ %def bloch_vectors
@
<<[[bloch_vectors_sub.f90]]>>=
<<File header>>
submodule (bloch_vectors) bloch_vectors_s
use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
use su_algebra
implicit none
contains
<<Bloch vectors: procedures>>
end submodule bloch_vectors_s
@ %def bloch_vectors_s
@
\subsection{Preliminaries}
The normalization factor $\sqrt{2N(N-1)}/N$ that enters the Bloch
representation.
<<Bloch vectors: procedures>>=
function bloch_factor (s) result (f)
real(default) :: f
integer, intent(in) :: s
select case (s)
case (SCALAR)
f = 0
case (SPINOR)
f = 1
case (VECTOR)
f = 2 * sqrt (3._default) / 3
case (VECTORSPINOR)
f = 2 * sqrt (6._default) / 4
case (TENSOR)
f = 2 * sqrt (10._default) / 5
case default
f = 0
end select
end function bloch_factor
@ %def bloch_factor
@
\subsection{The basic polarization type}
The basic polarization object holds just the entries of the Bloch
vector as an allocatable array.
Bloch is active whenever the coefficient array is allocated.
For convenience, we store the spin type ($2s$) and the multiplicity
($N$) together with the coefficient array ($\alpha$). We have to allow for
the massless case where $s$ is arbitrary $>0$ but $N=2$, and
furthermore the chiral massless case where $N=1$. In the latter case,
the array remains deallocated but the chirality is set to $\pm 1$.
In the Bloch vector implementation, we do not distinguish between
particle and antiparticle. If the distinction applies, it must be
made by the caller when transforming between density matrix and Bloch vector.
<<Bloch vectors: public>>=
public :: bloch_vector_t
<<Bloch vectors: types>>=
type :: bloch_vector_t
private
integer :: spin_type = UNKNOWN
real(default), dimension(:), allocatable :: a
contains
<<Bloch vectors: bloch vector: TBP>>
end type bloch_vector_t
@ %def bloch_vector_t
@
\subsection{Direct Access}
This basic initializer just sets the spin type, leaving the Bloch vector
unallocated. The object therefore does not support nonzero polarization.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: init_unpolarized => bloch_vector_init_unpolarized
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_init_unpolarized (pol, spin_type)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
end subroutine bloch_vector_init_unpolarized
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_init_unpolarized (pol, spin_type)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
pol%spin_type = spin_type
end subroutine bloch_vector_init_unpolarized
@ %def bloch_vector_init_unpolarized
@ The standard initializer allocates the Bloch vector and initializes
with zeros, so we can define a polarization later. We make sure that
this works only for the supported spin type. Initializing with
[[UNKNOWN]] spin type resets the Bloch vector to undefined, i.e.,
unpolarized state.
<<Bloch vectors: bloch vector: TBP>>=
generic :: init => bloch_vector_init
procedure, private :: bloch_vector_init
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_init (pol, spin_type)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
end subroutine bloch_vector_init
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_init (pol, spin_type)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
pol%spin_type = spin_type
select case (spin_type)
case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
allocate (pol%a (algebra_dimension (spin_type)), source = 0._default)
end select
end subroutine bloch_vector_init
@ %def bloch_vector_init
@
Fill the Bloch vector from an array, no change of normalization. No
initialization and no check, we assume that the shapes do match.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: from_array => bloch_vector_from_array
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_from_array (pol, a)
class(bloch_vector_t), intent(inout) :: pol
real(default), dimension(:), allocatable, intent(in) :: a
end subroutine bloch_vector_from_array
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_from_array (pol, a)
class(bloch_vector_t), intent(inout) :: pol
real(default), dimension(:), allocatable, intent(in) :: a
pol%a(:) = a
end subroutine bloch_vector_from_array
@ %def bloch_vector_from_array
@
Transform to an array of reals, i.e., extract the Bloch vector as-is.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: to_array => bloch_vector_to_array
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_to_array (pol, a)
class(bloch_vector_t), intent(in) :: pol
real(default), dimension(:), allocatable, intent(out) :: a
end subroutine bloch_vector_to_array
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_to_array (pol, a)
class(bloch_vector_t), intent(in) :: pol
real(default), dimension(:), allocatable, intent(out) :: a
if (pol%is_defined ()) allocate (a (size (pol%a)), source = pol%a)
end subroutine bloch_vector_to_array
@ %def bloch_vector_to_array
@
\subsection{Raw I/O}
<<Bloch vectors: bloch vector: TBP>>=
procedure :: write_raw => bloch_vector_write_raw
procedure :: read_raw => bloch_vector_read_raw
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_write_raw (pol, u)
class(bloch_vector_t), intent(in) :: pol
integer, intent(in) :: u
end subroutine bloch_vector_write_raw
module subroutine bloch_vector_read_raw (pol, u, iostat)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: u
integer, intent(out) :: iostat
end subroutine bloch_vector_read_raw
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_write_raw (pol, u)
class(bloch_vector_t), intent(in) :: pol
integer, intent(in) :: u
write (u) pol%spin_type
write (u) allocated (pol%a)
if (allocated (pol%a)) then
write (u) pol%a
end if
end subroutine bloch_vector_write_raw
module subroutine bloch_vector_read_raw (pol, u, iostat)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: u
integer, intent(out) :: iostat
integer :: s
logical :: polarized
read (u, iostat=iostat) s
read (u, iostat=iostat) polarized
if (iostat /= 0) return
if (polarized) then
call pol%init (s)
read (u, iostat=iostat) pol%a
else
call pol%init_unpolarized (s)
end if
end subroutine bloch_vector_read_raw
@ %def bloch_vector_write_raw
@ %def bloch_vector_read_raw
@
\subsection{Properties}
Re-export algebra functions that depend on the spin type. These
functions do not depend on the Bloch vector being allocated.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: get_n_states
procedure :: get_length
procedure :: hel_index => bv_helicity_index
procedure :: hel_value => bv_helicity_value
procedure :: bloch_factor => bv_factor
<<Bloch vectors: sub interfaces>>=
module function get_n_states (pol) result (n)
class(bloch_vector_t), intent(in) :: pol
integer :: n
end function get_n_states
module function get_length (pol) result (n)
class(bloch_vector_t), intent(in) :: pol
integer :: n
end function get_length
module function bv_helicity_index (pol, h) result (i)
class(bloch_vector_t), intent(in) :: pol
integer, intent(in) :: h
integer :: i
end function bv_helicity_index
module function bv_helicity_value (pol, i) result (h)
class(bloch_vector_t), intent(in) :: pol
integer, intent(in) :: i
integer :: h
end function bv_helicity_value
module function bv_factor (pol) result (f)
class(bloch_vector_t), intent(in) :: pol
real(default) :: f
end function bv_factor
<<Bloch vectors: procedures>>=
module function get_n_states (pol) result (n)
class(bloch_vector_t), intent(in) :: pol
integer :: n
n = fundamental_dimension (pol%spin_type)
end function get_n_states
module function get_length (pol) result (n)
class(bloch_vector_t), intent(in) :: pol
integer :: n
n = algebra_dimension (pol%spin_type)
end function get_length
module function bv_helicity_index (pol, h) result (i)
class(bloch_vector_t), intent(in) :: pol
integer, intent(in) :: h
integer :: i
i = helicity_index (pol%spin_type, h)
end function bv_helicity_index
module function bv_helicity_value (pol, i) result (h)
class(bloch_vector_t), intent(in) :: pol
integer, intent(in) :: i
integer :: h
h = helicity_value (pol%spin_type, i)
end function bv_helicity_value
module function bv_factor (pol) result (f)
class(bloch_vector_t), intent(in) :: pol
real(default) :: f
f = bloch_factor (pol%spin_type)
end function bv_factor
@ %def get_n_states
@ %def helicity_index
@ %def helicity_value
@ If the Bloch vector object is defined, the spin type is anything else but
[[UNKNOWN]]. This allows us the provide the representation-specific
functions above.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: is_defined => bloch_vector_is_defined
<<Bloch vectors: sub interfaces>>=
module function bloch_vector_is_defined (pol) result (flag)
class(bloch_vector_t), intent(in) :: pol
logical :: flag
end function bloch_vector_is_defined
<<Bloch vectors: procedures>>=
module function bloch_vector_is_defined (pol) result (flag)
class(bloch_vector_t), intent(in) :: pol
logical :: flag
flag = pol%spin_type /= UNKNOWN
end function bloch_vector_is_defined
@ %def bloch_vector_is_defined
@ If the Bloch vector object is (technically) polarized, it is
defined, and the vector coefficient array has been allocated.
However, the vector value may be zero.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: is_polarized => bloch_vector_is_polarized
<<Bloch vectors: sub interfaces>>=
module function bloch_vector_is_polarized (pol) result (flag)
class(bloch_vector_t), intent(in) :: pol
logical :: flag
end function bloch_vector_is_polarized
<<Bloch vectors: procedures>>=
module function bloch_vector_is_polarized (pol) result (flag)
class(bloch_vector_t), intent(in) :: pol
logical :: flag
flag = allocated (pol%a)
end function bloch_vector_is_polarized
@ %def bloch_vector_is_polarized
@ Return true if the polarization is diagonal, i.e., all entries in
the density matrix are on the diagonal. This is equivalent to
requiring that only Cartan generator coefficients are nonzero in the
Bloch vector.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: is_diagonal => bloch_vector_is_diagonal
<<Bloch vectors: sub interfaces>>=
module function bloch_vector_is_diagonal (pol) result (diagonal)
class(bloch_vector_t), intent(in) :: pol
logical :: diagonal
end function bloch_vector_is_diagonal
<<Bloch vectors: procedures>>=
module function bloch_vector_is_diagonal (pol) result (diagonal)
class(bloch_vector_t), intent(in) :: pol
logical :: diagonal
integer :: s, i
s = pol%spin_type
diagonal = .true.
if (pol%is_polarized ()) then
do i = 1, size (pol%a)
if (is_cartan_generator (s, i)) cycle
if (pol%a(i) /= 0) then
diagonal = .false.
return
end if
end do
end if
end function bloch_vector_is_diagonal
@ %def bloch_vector_is_diagonal
@
Return the Euclidean norm of the Bloch vector. This is equal to the
Killing form value of the corresponding algebra generator. We assume
that the polarization object has been initialized.
For a pure state, the norm is unity. All other allowed states have a
norm less than unity. (For $s\geq 1$, this is a necessary but not
sufficient condition.)
<<Bloch vectors: bloch vector: TBP>>=
procedure :: get_norm => bloch_vector_get_norm
<<Bloch vectors: sub interfaces>>=
module function bloch_vector_get_norm (pol) result (norm)
class(bloch_vector_t), intent(in) :: pol
real(default) :: norm
end function bloch_vector_get_norm
<<Bloch vectors: procedures>>=
module function bloch_vector_get_norm (pol) result (norm)
class(bloch_vector_t), intent(in) :: pol
real(default) :: norm
select case (pol%spin_type)
case (SPINOR,VECTOR,VECTORSPINOR,TENSOR)
norm = sqrt (dot_product (pol%a, pol%a))
case default
norm = 1
end select
end function bloch_vector_get_norm
@ %def bloch_vector_get_norm
@
\subsection{Diagonal density matrix}
This initializer takes a diagonal density matrix, represented by a
real-valued array. We assume that the trace is unity, and that the
array has the correct shape for the given [[spin_type]].
The [[bloch_factor]] renormalization is necessary such that a pure
state maps to a Bloch vector with unit norm.
<<Bloch vectors: bloch vector: TBP>>=
generic :: init => bloch_vector_init_diagonal
procedure, private :: bloch_vector_init_diagonal
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_init_diagonal (pol, spin_type, rd)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
real(default), dimension(:), intent(in) :: rd
end subroutine bloch_vector_init_diagonal
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_init_diagonal (pol, spin_type, rd)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
real(default), dimension(:), intent(in) :: rd
call pol%init (spin_type)
call pol%set (rd)
end subroutine bloch_vector_init_diagonal
@ %def bloch_vector_init_diagonal
@ Set a Bloch vector, given a diagonal density matrix as a real array.
The Bloch vector must be initialized with correct characteristics.
<<Bloch vectors: bloch vector: TBP>>=
generic :: set => bloch_vector_set_diagonal
procedure, private :: bloch_vector_set_diagonal
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_set_diagonal (pol, rd)
class(bloch_vector_t), intent(inout) :: pol
real(default), dimension(:), intent(in) :: rd
end subroutine bloch_vector_set_diagonal
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_set_diagonal (pol, rd)
class(bloch_vector_t), intent(inout) :: pol
real(default), dimension(:), intent(in) :: rd
integer :: s
s = pol%spin_type
select case (s)
case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
pol%a(:) = cartan_coeff (s, rd) / bloch_factor (s)
end select
end subroutine bloch_vector_set_diagonal
@ %def bloch_vector_set_diagonal
@
@
\subsection{Massless density matrix}
This is a specific variant which initializes an equipartition for
the maximum helicity, corresponding to an unpolarized massless particle.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: init_max_weight => bloch_vector_init_max_weight
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_init_max_weight (pol, spin_type)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
end subroutine bloch_vector_init_max_weight
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_init_max_weight (pol, spin_type)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
call pol%init (spin_type)
select case (spin_type)
case (VECTOR)
call pol%set ([0.5_default, 0._default, 0.5_default])
case (VECTORSPINOR)
call pol%set ([0.5_default, 0._default, 0._default, 0.5_default])
case (TENSOR)
call pol%set ([0.5_default, 0._default, 0._default, 0._default, 0.5_default])
end select
end subroutine bloch_vector_init_max_weight
@ %def bloch_vector_init_max_weight
@ Initialize the maximum-weight submatrix with a three-component Bloch
vector. This is not as trivial as it seems because we need the above
initialization for the generalized Bloch in order to remove the lower
weights from the density matrix.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: init_vector => bloch_vector_init_vector
procedure :: to_vector => bloch_vector_to_vector
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_init_vector (pol, s, a)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: s
real(default), dimension(3), intent(in) :: a
end subroutine bloch_vector_init_vector
module subroutine bloch_vector_to_vector (pol, a)
class(bloch_vector_t), intent(in) :: pol
real(default), dimension(3), intent(out) :: a
end subroutine bloch_vector_to_vector
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_init_vector (pol, s, a)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: s
real(default), dimension(3), intent(in) :: a
call pol%init_max_weight (s)
select case (s)
case (SPINOR, VECTOR, VECTORSPINOR, TENSOR)
pol%a(1:3) = a / bloch_factor (s)
end select
end subroutine bloch_vector_init_vector
module subroutine bloch_vector_to_vector (pol, a)
class(bloch_vector_t), intent(in) :: pol
real(default), dimension(3), intent(out) :: a
integer :: s
s = pol%spin_type
select case (s)
case (SPINOR, VECTOR, VECTORSPINOR, TENSOR)
a = pol%a(1:3) * bloch_factor (s)
case default
a = 0
end select
end subroutine bloch_vector_to_vector
@ %def bloch_vector_init_vector
@ %def bloch_vector_to_vector
@
\subsection{Arbitrary density matrix}
Initialize the Bloch vector from a density matrix. We assume that the
density is valid. In particular, the shape should match, the matrix
should be hermitian, and the trace should be unity.
We first fill the diagonal, then add the off-diagonal parts.
<<Bloch vectors: bloch vector: TBP>>=
generic :: init => bloch_vector_init_matrix
procedure, private :: bloch_vector_init_matrix
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_init_matrix (pol, spin_type, r)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
complex(default), dimension(:,:), intent(in) :: r
end subroutine bloch_vector_init_matrix
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_init_matrix (pol, spin_type, r)
class(bloch_vector_t), intent(out) :: pol
integer, intent(in) :: spin_type
complex(default), dimension(:,:), intent(in) :: r
select case (spin_type)
case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
call pol%init (spin_type)
call pol%set (r)
case default
call pol%init (UNKNOWN)
end select
end subroutine bloch_vector_init_matrix
@ %def bloch_vector_init_matrix
@ Set a Bloch vector, given an arbitrary density matrix as a real
array. The Bloch vector must be initialized with correct
characteristics.
<<Bloch vectors: bloch vector: TBP>>=
generic :: set => bloch_vector_set_matrix
procedure, private :: bloch_vector_set_matrix
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_set_matrix (pol, r)
class(bloch_vector_t), intent(inout) :: pol
complex(default), dimension(:,:), intent(in) :: r
end subroutine bloch_vector_set_matrix
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_set_matrix (pol, r)
class(bloch_vector_t), intent(inout) :: pol
complex(default), dimension(:,:), intent(in) :: r
real(default), dimension(:), allocatable :: rd
integer :: s, d, i, j, h1, h2, ir, ii
s = pol%spin_type
select case (s)
case (SCALAR,SPINOR,VECTOR,VECTORSPINOR,TENSOR)
d = fundamental_dimension (s)
allocate (rd (d))
do i = 1, d
rd(i) = r(i,i)
end do
call pol%set (rd)
do i = 1, d
h1 = helicity_value (s, i)
do j = i+1, d
h2 = helicity_value (s, j)
ir = root_index (s, h1, h2, .true.)
ii = root_index (s, h1, h2, .false.)
pol%a(ir) = real (r(j,i) + r(i,j)) / bloch_factor (s)
pol%a(ii) = aimag (r(j,i) - r(i,j)) / bloch_factor (s)
end do
end do
end select
end subroutine bloch_vector_set_matrix
@ %def bloch_vector_set_matrix
@ Allocate and fill the density matrix [[r]] (with the index ordering as
defined in [[su_algebra]]) that corresponds to a given Bloch vector.
If the optional [[only_max_weight]] is set, the resulting matrix has
entries only for $\pm h_\text{max}$, as appropriate for a massless
particle (for spin $\geq 1$). Note that we always add the unit
matrix, as this is part of the Bloch-vector definition.
<<Bloch vectors: bloch vector: TBP>>=
procedure :: to_matrix => bloch_vector_to_matrix
<<Bloch vectors: sub interfaces>>=
module subroutine bloch_vector_to_matrix (pol, r, only_max_weight)
class(bloch_vector_t), intent(in) :: pol
complex(default), dimension(:,:), intent(out), allocatable :: r
logical, intent(in), optional :: only_max_weight
end subroutine bloch_vector_to_matrix
<<Bloch vectors: procedures>>=
module subroutine bloch_vector_to_matrix (pol, r, only_max_weight)
class(bloch_vector_t), intent(in) :: pol
complex(default), dimension(:,:), intent(out), allocatable :: r
logical, intent(in), optional :: only_max_weight
integer :: d, s, h0, ng, ai, h, h1, h2, i, j
logical :: is_real, only_max
complex(default) :: val
if (.not. pol%is_polarized ()) return
s = pol%spin_type
only_max = .false.
select case (s)
case (VECTOR, VECTORSPINOR, TENSOR)
if (present (only_max_weight)) only_max = only_max_weight
end select
if (only_max) then
ng = 2
h0 = helicity_value (s, 1)
else
ng = algebra_dimension (s)
h0 = 0
end if
d = fundamental_dimension (s)
allocate (r (d, d), source = (0._default, 0._default))
do i = 1, d
h = helicity_value (s, i)
if (abs (h) < h0) cycle
r(i,i) = 1._default / d &
+ dot_product (cartan_element (s, h), pol%a) * bloch_factor (s)
end do
do ai = 1, ng
if (is_cartan_generator (s, ai)) cycle
call root_helicity (s, ai, h1, h2, is_real)
i = helicity_index (s, h1)
j = helicity_index (s, h2)
if (is_real) then
val = cmplx (pol%a(ai) / 2 * bloch_factor (s), 0._default, &
kind=default)
r(i,j) = r(i,j) + val
r(j,i) = r(j,i) + val
else
val = cmplx (0._default, pol%a(ai) / 2 * bloch_factor (s), &
kind=default)
r(i,j) = r(i,j) - val
r(j,i) = r(j,i) + val
end if
end do
end subroutine bloch_vector_to_matrix
@ %def bloch_vector_to_matrix
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[bloch_vectors_ut.f90]]>>=
<<File header>>
module bloch_vectors_ut
use unit_tests
use bloch_vectors_uti
<<Standard module head>>
<<Bloch vectors: public test>>
contains
<<Bloch vectors: test driver>>
end module bloch_vectors_ut
@ %def bloch_vectors_ut
@
<<[[bloch_vectors_uti.f90]]>>=
<<File header>>
module bloch_vectors_uti
<<Use kinds>>
use physics_defs, only: UNKNOWN, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
+ use numeric_utils, only: vanishes
use su_algebra, only: algebra_dimension, fundamental_dimension, helicity_value
use bloch_vectors
<<Standard module head>>
<<Bloch vectors: test declarations>>
contains
<<Bloch vectors: tests>>
end module bloch_vectors_uti
@ %def bloch_vectors_ut
@ API: driver for the unit tests below.
<<Bloch vectors: public test>>=
public :: bloch_vectors_test
<<Bloch vectors: test driver>>=
subroutine bloch_vectors_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Bloch vectors: execute tests>>
end subroutine bloch_vectors_test
@ %def bloch_vectors_test
@
\subsubsection{Initialization}
Initialize the Bloch vector for any spin type. First as unpolarized
(no array), then as polarized but with zero polarization.
<<Bloch vectors: execute tests>>=
call test (bloch_vectors_1, "bloch_vectors_1", &
"initialization", &
u, results)
<<Bloch vectors: test declarations>>=
public :: bloch_vectors_1
<<Bloch vectors: tests>>=
subroutine bloch_vectors_1 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: bloch_vectors_1"
write (u, "(A)") "* Purpose: test Bloch-vector &
&polarization implementation"
write (u, "(A)")
write (u, "(A)") "* Initialization (unpolarized)"
write (u, "(A)")
write (u, "(A)") "* unknown"
call bloch_init (UNKNOWN)
write (u, "(A)")
write (u, "(A)") "* s = 0"
call bloch_init (SCALAR)
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call bloch_init (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call bloch_init (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call bloch_init (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call bloch_init (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: bloch_vectors_1"
contains
subroutine bloch_init (s)
integer, intent(in) :: s
type(bloch_vector_t) :: pol
real(default), dimension(:), allocatable :: a
integer :: i
write (u, *)
write (u, "(1X,L1,L1)", advance="no") &
pol%is_defined (), pol%is_polarized ()
call pol%init_unpolarized (s)
write (u, "(1X,L1,L1)", advance="no") &
pol%is_defined (), pol%is_polarized ()
call pol%init (s)
write (u, "(1X,L1,L1)", advance="no") &
pol%is_defined (), pol%is_polarized ()
write (u, *)
call pol%to_array (a)
if (allocated (a)) then
write (u, "(*(F7.4))") a
a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))]
call pol%from_array (a)
call pol%to_array (a)
write (u, "(*(F7.4))") a
else
write (u, *)
write (u, *)
end if
end subroutine bloch_init
end subroutine bloch_vectors_1
@ %def bloch_vectors_1
@
\subsubsection{Pure state (diagonal)}
Initialize the Bloch vector with a pure state of definite helicity and
check the normalization.
<<Bloch vectors: execute tests>>=
call test (bloch_vectors_2, "bloch_vectors_2", &
"pure state (diagonal)", &
u, results)
<<Bloch vectors: test declarations>>=
public :: bloch_vectors_2
<<Bloch vectors: tests>>=
subroutine bloch_vectors_2 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: bloch_vectors_2"
write (u, "(A)") "* Purpose: test Bloch-vector &
&polarization implementation"
write (u, "(A)")
write (u, "(A)") "* Initialization (polarized, diagonal): &
&display vector and norm"
write (u, "(A)") "* transform back"
write (u, "(A)")
write (u, "(A)") "* s = 0"
call bloch_diagonal (SCALAR)
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call bloch_diagonal (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call bloch_diagonal (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call bloch_diagonal (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call bloch_diagonal (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: bloch_vectors_2"
contains
subroutine bloch_diagonal (s)
integer, intent(in) :: s
type(bloch_vector_t) :: pol
real(default), dimension(:), allocatable :: a
real(default), dimension(:), allocatable :: rd
complex(default), dimension(:,:), allocatable :: r
integer :: i, j, d
real(default) :: rj
real, parameter :: tolerance = 1.E-14_default
d = fundamental_dimension (s)
do i = 1, d
allocate (rd (d), source = 0._default)
rd(i) = 1
call pol%init (s, rd)
call pol%to_array (a)
write (u, *)
write (u, "(A,1X,I2)") "h:", helicity_value (s, i)
write (u, 1, advance="no") a
write (u, "(1X,L1)") pol%is_diagonal ()
write (u, 1) pol%get_norm ()
call pol%to_matrix (r)
do j = 1, d
rj = real (r(j,j))
if (abs (rj) < tolerance) rj = 0
write (u, 1, advance="no") rj
end do
write (u, "(1X,L1)") matrix_is_diagonal (r)
deallocate (a, rd, r)
end do
1 format (99(1X,F7.4,:))
end subroutine bloch_diagonal
function matrix_is_diagonal (r) result (diagonal)
complex(default), dimension(:,:), intent(in) :: r
logical :: diagonal
integer :: i, j
diagonal = .true.
do j = 1, size (r, 2)
do i = 1, size (r, 1)
if (i == j) cycle
if (r(i,j) /= 0) then
diagonal = .false.
return
end if
end do
end do
end function matrix_is_diagonal
end subroutine bloch_vectors_2
@ %def bloch_vectors_2
@
\subsubsection{Pure state (arbitrary)}
Initialize the Bloch vector with an arbitrarily chosen pure state,
check the normalization, and transform back to the density matrix.
<<Bloch vectors: execute tests>>=
call test (bloch_vectors_3, "bloch_vectors_3", &
"pure state (arbitrary)", &
u, results)
<<Bloch vectors: test declarations>>=
public :: bloch_vectors_3
<<Bloch vectors: tests>>=
subroutine bloch_vectors_3 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: bloch_vectors_3"
write (u, "(A)") "* Purpose: test Bloch-vector &
&polarization implementation"
write (u, "(A)")
write (u, "(A)") "* Initialization (pure polarized, arbitrary):"
write (u, "(A)") "* input matrix, transform, display norm, transform back"
write (u, "(A)")
write (u, "(A)") "* s = 0"
call bloch_arbitrary (SCALAR)
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call bloch_arbitrary (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call bloch_arbitrary (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call bloch_arbitrary (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call bloch_arbitrary (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: bloch_vectors_3"
contains
subroutine bloch_arbitrary (s)
integer, intent(in) :: s
type(bloch_vector_t) :: pol
complex(default), dimension(:,:), allocatable :: r
integer :: d
d = fundamental_dimension (s)
write (u, *)
call init_matrix (d, r)
where (abs (aimag (r)) < 1.e-14_default) &
r = cmplx (real(r, kind=default), 0._default, kind=default)
call write_matrix (d, r)
call pol%init (s, r)
write (u, *)
write (u, 2) pol%get_norm (), pol%is_diagonal ()
write (u, *)
call pol%to_matrix (r)
call write_matrix (d, r)
2 format (1X,F7.4,1X,L1)
end subroutine bloch_arbitrary
subroutine init_matrix (d, r)
integer, intent(in) :: d
complex(default), dimension(:,:), allocatable, intent(out) :: r
complex(default), dimension(:), allocatable :: a
real(default) :: norm
integer :: i, j
allocate (a (d))
norm = 0
do i = 1, d
a(i) = cmplx (2*i-1, 2*i, kind=default)
norm = norm + conjg (a(i)) * a(i)
end do
a = a / sqrt (norm)
allocate (r (d,d))
do i = 1, d
do j = 1, d
r(i,j) = conjg (a(i)) * a(j)
end do
end do
end subroutine init_matrix
subroutine write_matrix (d, r)
integer, intent(in) :: d
complex(default), dimension(:,:), intent(in) :: r
integer :: i, j
do i = 1, d
do j = 1, d
- write (u, 1, advance="no") r(i,j)
+ write (u, 1, advance="no") pacify_complex (r(i,j))
end do
write (u, *)
end do
1 format (99(1X,'(',F7.4,',',F7.4,')',:))
end subroutine write_matrix
end subroutine bloch_vectors_3
@ %def bloch_vectors_3
@
\subsubsection{Raw I/O}
Check correct input/output in raw format.
<<Bloch vectors: execute tests>>=
call test (bloch_vectors_4, "bloch_vectors_4", &
"raw I/O", &
u, results)
<<Bloch vectors: test declarations>>=
public :: bloch_vectors_4
<<Bloch vectors: tests>>=
subroutine bloch_vectors_4 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: bloch_vectors_4"
write (u, "(A)") "* Purpose: test Bloch-vector &
&polarization implementation"
write (u, "(A)")
write (u, "(A)") "* Raw I/O"
write (u, "(A)")
write (u, "(A)") "* s = 0"
call bloch_io (SCALAR)
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call bloch_io (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call bloch_io (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call bloch_io (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call bloch_io (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: bloch_vectors_4"
contains
subroutine bloch_io (s)
integer, intent(in) :: s
type(bloch_vector_t) :: pol
real(default), dimension(:), allocatable :: a
integer :: n, i, utmp, iostat
n = algebra_dimension (s)
allocate (a (n))
a(:) = [(real (mod (i, 10), kind=default), i = 1, size (a))]
write (u, *)
write (u, "(*(F7.4))") a
call pol%init (s)
call pol%from_array (a)
open (newunit = utmp, status = "scratch", action = "readwrite", &
form = "unformatted")
call pol%write_raw (utmp)
rewind (utmp)
call pol%read_raw (utmp, iostat=iostat)
close (utmp)
call pol%to_array (a)
write (u, "(*(F7.4))") a
end subroutine bloch_io
end subroutine bloch_vectors_4
@ %def bloch_vectors_4
@
\subsubsection{Convenience Methods}
Check some further TBP that are called by the [[polarizations]]
module.
<<Bloch vectors: execute tests>>=
call test (bloch_vectors_5, "bloch_vectors_5", &
"massless state (unpolarized)", &
u, results)
<<Bloch vectors: test declarations>>=
public :: bloch_vectors_5
<<Bloch vectors: tests>>=
subroutine bloch_vectors_5 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: bloch_vectors_5"
write (u, "(A)") "* Purpose: test Bloch-vector &
&polarization implementation"
write (u, "(A)")
write (u, "(A)") "* Massless states: equipartition"
write (u, "(A)")
write (u, "(A)") "* s = 0"
call bloch_massless_unpol (SCALAR)
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call bloch_massless_unpol (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call bloch_massless_unpol (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call bloch_massless_unpol (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call bloch_massless_unpol (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: bloch_vectors_5"
contains
subroutine bloch_massless_unpol (s)
integer, intent(in) :: s
type(bloch_vector_t) :: pol
complex(default), dimension(:,:), allocatable :: r
real(default), dimension(:), allocatable :: a
integer :: d
d = fundamental_dimension (s)
call pol%init_max_weight (s)
call pol%to_matrix (r, only_max_weight = .false.)
write (u, *)
where (abs (r) < 1.e-14_default) r = 0
call write_matrix (d, r)
call pol%to_matrix (r, only_max_weight = .true.)
write (u, *)
call write_matrix (d, r)
end subroutine bloch_massless_unpol
subroutine write_matrix (d, r)
integer, intent(in) :: d
complex(default), dimension(:,:), intent(in) :: r
integer :: i, j
do i = 1, d
do j = 1, d
- write (u, 1, advance="no") r(i,j)
+ write (u, 1, advance="no") pacify_complex (r(i,j))
end do
write (u, *)
end do
1 format (99(1X,'(',F7.4,',',F7.4,')',:))
end subroutine write_matrix
end subroutine bloch_vectors_5
@ %def bloch_vectors_5
@
\subsubsection{Massless state (arbitrary)}
Initialize the Bloch vector with an arbitrarily chosen pure state
which consists only of highest-weight components. Transform back to
the density matrix.
<<Bloch vectors: execute tests>>=
call test (bloch_vectors_6, "bloch_vectors_6", &
"massless state (arbitrary)", &
u, results)
<<Bloch vectors: test declarations>>=
public :: bloch_vectors_6
<<Bloch vectors: tests>>=
subroutine bloch_vectors_6 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: bloch_vectors_6"
write (u, "(A)") "* Purpose: test Bloch-vector &
&polarization implementation"
write (u, "(A)")
write (u, "(A)") "* Initialization (pure polarized massless, arbitrary):"
write (u, "(A)") "* input matrix, transform, display norm, transform back"
write (u, "(A)")
write (u, "(A)") "* s = 0"
call bloch_massless (SCALAR)
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call bloch_massless (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call bloch_massless (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call bloch_massless (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call bloch_massless (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: bloch_vectors_6"
contains
subroutine bloch_massless (s)
integer, intent(in) :: s
type(bloch_vector_t) :: pol
complex(default), dimension(:,:), allocatable :: r
integer :: d
d = fundamental_dimension (s)
write (u, *)
call init_matrix (d, r)
where (abs (aimag (r)) < 1.e-14_default) &
r = cmplx (real(r, kind=default), 0._default, kind=default)
call write_matrix (d, r)
call pol%init (s, r)
write (u, *)
write (u, 2) pol%get_norm (), pol%is_diagonal ()
write (u, *)
call pol%to_matrix (r, only_max_weight = .true.)
call write_matrix (d, r)
2 format (1X,F7.4,1X,L1)
end subroutine bloch_massless
subroutine init_matrix (d, r)
integer, intent(in) :: d
complex(default), dimension(:,:), allocatable, intent(out) :: r
complex(default), dimension(:), allocatable :: a
real(default) :: norm
integer :: i, j
allocate (a (d), source = (0._default, 0._default))
norm = 0
do i = 1, d, max (d-1, 1)
a(i) = cmplx (2*i-1, 2*i, kind=default)
norm = norm + conjg (a(i)) * a(i)
end do
a = a / sqrt (norm)
allocate (r (d,d), source = (0._default, 0._default))
do i = 1, d, max (d-1, 1)
do j = 1, d, max (d-1, 1)
r(i,j) = conjg (a(i)) * a(j)
end do
end do
end subroutine init_matrix
subroutine write_matrix (d, r)
integer, intent(in) :: d
complex(default), dimension(:,:), intent(in) :: r
integer :: i, j
do i = 1, d
do j = 1, d
write (u, 1, advance="no") r(i,j)
end do
write (u, *)
end do
1 format (99(1X,'(',F7.4,',',F7.4,')',:))
end subroutine write_matrix
end subroutine bloch_vectors_6
@ %def bloch_vectors_6
@
\subsubsection{Massless state (Bloch vector)}
Initialize the (generalized) Bloch vector with an ordinary
three-component Bloch vector that applies to the highest-weight part only.
<<Bloch vectors: execute tests>>=
call test (bloch_vectors_7, "bloch_vectors_7", &
"massless state (vector)", &
u, results)
<<Bloch vectors: test declarations>>=
public :: bloch_vectors_7
<<Bloch vectors: tests>>=
subroutine bloch_vectors_7 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: bloch_vectors_7"
write (u, "(A)") "* Purpose: test Bloch-vector &
&polarization implementation"
write (u, "(A)")
write (u, "(A)") "* Initialization &
&(pure polarized massless, arbitrary Bloch vector):"
write (u, "(A)") "* input vector, transform, display norm, &
&transform back"
write (u, "(A)")
write (u, "(A)") "* s = 0"
call bloch_massless_vector (SCALAR)
write (u, "(A)")
write (u, "(A)") "* s = 1/2"
call bloch_massless_vector (SPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 1"
call bloch_massless_vector (VECTOR)
write (u, "(A)")
write (u, "(A)") "* s = 3/2"
call bloch_massless_vector (VECTORSPINOR)
write (u, "(A)")
write (u, "(A)") "* s = 2"
call bloch_massless_vector (TENSOR)
write (u, "(A)")
write (u, "(A)") "* Test output end: bloch_vectors_7"
contains
subroutine bloch_massless_vector (s)
integer, intent(in) :: s
type(bloch_vector_t) :: pol
real(default), dimension(3) :: a
complex(default), dimension(:,:), allocatable :: r
write (u, *)
a = [1._default, 2._default, 4._default]
a = a / sqrt (sum (a ** 2))
write (u, 2) a
call pol%init_vector (s, a)
write (u, 2) pol%get_norm ()
call pol%to_vector (a)
write (u, 2) a
call pol%to_matrix (r, only_max_weight = .false.)
write (u, *)
where (abs (r) < 1.e-14_default) r = 0
call write_matrix (r)
call pol%to_matrix (r, only_max_weight = .true.)
write (u, *)
call write_matrix (r)
2 format (99(1X,F7.4,:))
end subroutine bloch_massless_vector
subroutine write_matrix (r)
complex(default), dimension(:,:), intent(in) :: r
integer :: i, j
do i = 1, size (r, 1)
do j = 1, size (r, 2)
- write (u, 1, advance="no") r(i,j)
+ write (u, 1, advance="no") pacify_complex (r(i,j))
end do
write (u, *)
end do
1 format (99(1X,'(',F7.4,',',F7.4,')',:))
end subroutine write_matrix
end subroutine bloch_vectors_7
@ %def bloch_vectors_7
@
+<<Bloch vectors: tests>>=
+ elemental function pacify_complex (c_in) result (c_pac)
+ complex(default), intent(in) :: c_in
+ complex(default) :: c_pac
+ c_pac = c_in
+ if (vanishes (real (c_pac))) then
+ c_pac = &
+ cmplx (0._default, aimag(c_pac), kind=default)
+ end if
+ if (vanishes (aimag(c_pac))) then
+ c_pac = &
+ cmplx (real(c_pac), 0._default, kind=default)
+ end if
+ end function pacify_complex
+
+@ %def pacify_complex
+@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Polarization}
Using generalized Bloch vectors and the $su(N)$ algebra (see above)
for the internal representation, we can define various modes of
polarization. For
spin-1/2, and analogously for massless spin-$s$ particles, we introduce
\begin{enumerate}
\item Trivial polarization: $\vec\alpha=0$. [This is unpolarized, but
distinct from the particular undefined polarization matrix which has
the same meaning.]
\item Circular polarization: $\vec\alpha$ points in $\pm z$ direction.
\item Transversal polarization: $\vec\alpha$ points orthogonal to the
$z$ direction, with a phase $\phi$ that is $0$ for the $x$ axis, and
$\pi/2=90^\circ$ for the $y$ axis. For antiparticles, the phase
switches sign, corresponding to complex conjugation.
\item Axis polarization, where we explicitly give $\vec\alpha$.
\end{enumerate}
For higher spin, we retain this definition, but apply it to the two
components with maximum and minimum weight. In effect, we concentrate
on the first three entries in the $\alpha^a$ array. For massless
particles, this is sufficient. For massive particles, we then add the
possibilities:
\begin{enumerate}\setcounter{enumi}{4}
\item Longitudinal polarization: Only the 0-component is set. This is
possible only for bosons.
\item Diagonal polarization: Explicitly specify all components in the
helicity basis. The $su(N)$ representation consists of diagonal
generators only, the Cartan subalgebra.
\end{enumerate}
Obviously, this does not exhaust the possible density matrices for
higher spin, but it should cover practical applications.
<<[[polarizations.f90]]>>=
<<File header>>
module polarizations
<<Use kinds>>
use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
use flavors
use quantum_numbers
use state_matrices
use bloch_vectors
<<Standard module head>>
<<Polarizations: public>>
<<Polarizations: types>>
<<Polarizations: interfaces>>
interface
<<Polarizations: sub interfaces>>
end interface
end module polarizations
@ %def polarizations
@
<<[[polarizations_sub.f90]]>>=
<<File header>>
submodule (polarizations) polarizations_s
use io_units
use format_defs, only: FMT_19
use diagnostics
use helicities
implicit none
contains
<<Polarizations: procedures>>
end submodule polarizations_s
@ %def polarizations_s
@
\subsection{The polarization type}
Polarization is active whenever the coefficient array is allocated.
For convenience, we store the spin type ($2s$) and the multiplicity
($N$) together with the coefficient array ($\alpha$). We have to allow for
the massless case where $s$ is arbitrary $>0$ but $N=2$, and
furthermore the chiral massless case where $N=1$. In the latter case,
the array remains deallocated but the chirality is set to $\pm 1$.
There is a convention that an antiparticle transforms according to the
complex conjugate representation. We apply this only when
transforming from/to polarization defined by a three-vector. For
antiparticles, the two-component flips sign in that case. When
transforming from/to a state matrix or [[pmatrix]] representation, we
do not apply this sign flip.
<<Polarizations: public>>=
public :: polarization_t
<<Polarizations: types>>=
type :: polarization_t
private
integer :: spin_type = SCALAR
integer :: multiplicity = 1
integer :: chirality = 0
logical :: anti = .false.
type(bloch_vector_t) :: bv
contains
<<Polarizations: polarization: TBP>>
end type polarization_t
@ %def polarization_t
@
\subsection{Basic initializer and finalizer}
We need the particle flavor for determining the allowed helicity
values. The Bloch vector is left undefined, so this initializer (in
two versions) creates an unpolarized particle. Exception: a chiral
particle is always polarized with definite helicity, it doesn't need a
Bloch vector.
This is private.
<<Polarizations: polarization: TBP>>=
generic, private :: init => polarization_init, polarization_init_flv
procedure, private :: polarization_init
procedure, private :: polarization_init_flv
<<Polarizations: sub interfaces>>=
module subroutine polarization_init (pol, spin_type, multiplicity, &
anti, left_handed, right_handed)
class(polarization_t), intent(out) :: pol
integer, intent(in) :: spin_type
integer, intent(in) :: multiplicity
logical, intent(in) :: anti
logical, intent(in) :: left_handed
logical, intent(in) :: right_handed
end subroutine polarization_init
module subroutine polarization_init_flv (pol, flv)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
end subroutine polarization_init_flv
<<Polarizations: procedures>>=
module subroutine polarization_init (pol, spin_type, multiplicity, &
anti, left_handed, right_handed)
class(polarization_t), intent(out) :: pol
integer, intent(in) :: spin_type
integer, intent(in) :: multiplicity
logical, intent(in) :: anti
logical, intent(in) :: left_handed
logical, intent(in) :: right_handed
pol%spin_type = spin_type
pol%multiplicity = multiplicity
pol%anti = anti
select case (pol%multiplicity)
case (1)
if (left_handed) then
pol%chirality = -1
else if (right_handed) then
pol%chirality = 1
end if
end select
select case (pol%chirality)
case (0)
call pol%bv%init_unpolarized (spin_type)
end select
end subroutine polarization_init
module subroutine polarization_init_flv (pol, flv)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
call pol%init ( &
spin_type = flv%get_spin_type (), &
multiplicity = flv%get_multiplicity (), &
anti = flv%is_antiparticle (), &
left_handed = flv%is_left_handed (), &
right_handed = flv%is_right_handed ())
end subroutine polarization_init_flv
@ %def polarization_init polarization_init_flv
@ Generic polarization: as before, but create a polarized particle
(Bloch vector defined) with initial polarization zero.
<<Polarizations: polarization: TBP>>=
generic :: init_generic => &
polarization_init_generic, &
polarization_init_generic_flv
procedure, private :: polarization_init_generic
procedure, private :: polarization_init_generic_flv
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_generic (pol, spin_type, multiplicity, &
anti, left_handed, right_handed)
class(polarization_t), intent(out) :: pol
integer, intent(in) :: spin_type
integer, intent(in) :: multiplicity
logical, intent(in) :: anti
logical, intent(in) :: left_handed
logical, intent(in) :: right_handed
end subroutine polarization_init_generic
module subroutine polarization_init_generic_flv (pol, flv)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
end subroutine polarization_init_generic_flv
<<Polarizations: procedures>>=
module subroutine polarization_init_generic (pol, spin_type, multiplicity, &
anti, left_handed, right_handed)
class(polarization_t), intent(out) :: pol
integer, intent(in) :: spin_type
integer, intent(in) :: multiplicity
logical, intent(in) :: anti
logical, intent(in) :: left_handed
logical, intent(in) :: right_handed
call pol%init (spin_type, multiplicity, &
anti, left_handed, right_handed)
select case (pol%chirality)
case (0)
if (pol%multiplicity == pol%bv%get_n_states ()) then
call pol%bv%init (spin_type)
else
call pol%bv%init_max_weight (spin_type)
end if
end select
end subroutine polarization_init_generic
module subroutine polarization_init_generic_flv (pol, flv)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
call pol%init_generic ( &
spin_type = flv%get_spin_type (), &
multiplicity = flv%get_multiplicity (), &
anti = flv%is_antiparticle (), &
left_handed = flv%is_left_handed (), &
right_handed = flv%is_right_handed ())
end subroutine polarization_init_generic_flv
@ %def polarization_init_generic
@ A finalizer is no longer necessary.
\subsection{I/O}
The default setting produces a tabular output of the polarization
vector entries. Optionally, we can create a state matrix and write
its contents, emulating the obsolete original implementation.
If [[all_states]] is true (default), we generate all helity
combinations regardless of the matrix-element value. Otherwise, skip
helicities with zero entry, or absolute value less than [[tolerance]],
if also given.
<<Polarizations: polarization: TBP>>=
procedure :: write => polarization_write
<<Polarizations: sub interfaces>>=
module subroutine polarization_write (pol, unit, state_matrix, all_states, tolerance)
class(polarization_t), intent(in) :: pol
integer, intent(in), optional :: unit
logical, intent(in), optional :: state_matrix, all_states
real(default), intent(in), optional :: tolerance
end subroutine polarization_write
<<Polarizations: procedures>>=
module subroutine polarization_write (pol, unit, state_matrix, all_states, tolerance)
class(polarization_t), intent(in) :: pol
integer, intent(in), optional :: unit
logical, intent(in), optional :: state_matrix, all_states
real(default), intent(in), optional :: tolerance
logical :: state_m
type(state_matrix_t) :: state
real(default), dimension(:), allocatable :: a
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
state_m = .false.; if (present (state_matrix)) state_m = state_matrix
if (pol%anti) then
write (u, "(1x,A,I1,A,I1,A,L1,A)") &
"Polarization: [spin_type = ", pol%spin_type, &
", mult = ", pol%multiplicity, ", anti = ", pol%anti, "]"
else
write (u, "(1x,A,I1,A,I1,A)") &
"Polarization: [spin_type = ", pol%spin_type, &
", mult = ", pol%multiplicity, "]"
end if
if (state_m) then
call pol%to_state (state, all_states, tolerance)
call state%write (unit=unit)
call state%final ()
else if (pol%chirality == 1) then
write (u, "(1x,A)") "chirality = +"
else if (pol%chirality == -1) then
write (u, "(1x,A)") "chirality = -"
else if (pol%bv%is_polarized ()) then
call pol%bv%to_array (a)
do i = 1, size (a)
write (u, "(1x,I2,':',1x,F10.7)") i, a(i)
end do
else
write (u, "(1x,A)") "[unpolarized]"
end if
end subroutine polarization_write
@ %def polarization_write
@ Binary I/O.
<<Polarizations: polarization: TBP>>=
procedure :: write_raw => polarization_write_raw
procedure :: read_raw => polarization_read_raw
<<Polarizations: sub interfaces>>=
module subroutine polarization_write_raw (pol, u)
class(polarization_t), intent(in) :: pol
integer, intent(in) :: u
end subroutine polarization_write_raw
module subroutine polarization_read_raw (pol, u, iostat)
class(polarization_t), intent(out) :: pol
integer, intent(in) :: u
integer, intent(out), optional :: iostat
end subroutine polarization_read_raw
<<Polarizations: procedures>>=
module subroutine polarization_write_raw (pol, u)
class(polarization_t), intent(in) :: pol
integer, intent(in) :: u
write (u) pol%spin_type
write (u) pol%multiplicity
write (u) pol%chirality
write (u) pol%anti
call pol%bv%write_raw (u)
end subroutine polarization_write_raw
module subroutine polarization_read_raw (pol, u, iostat)
class(polarization_t), intent(out) :: pol
integer, intent(in) :: u
integer, intent(out), optional :: iostat
read (u, iostat=iostat) pol%spin_type
read (u, iostat=iostat) pol%multiplicity
read (u, iostat=iostat) pol%chirality
read (u, iostat=iostat) pol%anti
call pol%bv%read_raw (u, iostat)
end subroutine polarization_read_raw
@ %def polarization_read_raw
@
\subsection{Accessing contents}
Return true if the particle is technically polarized. The particle
is either chiral, or its Bloch vector has been defined. The
function returns true even if the Bloch vector is zero or the particle
is scalar.
<<Polarizations: polarization: TBP>>=
procedure :: is_polarized => polarization_is_polarized
<<Polarizations: sub interfaces>>=
module function polarization_is_polarized (pol) result (polarized)
class(polarization_t), intent(in) :: pol
logical :: polarized
end function polarization_is_polarized
<<Polarizations: procedures>>=
module function polarization_is_polarized (pol) result (polarized)
class(polarization_t), intent(in) :: pol
logical :: polarized
polarized = pol%chirality /= 0 .or. pol%bv%is_polarized ()
end function polarization_is_polarized
@ %def polarization_is_polarized
@ Return true if the polarization is diagonal, i.e., all entries in
the density matrix are diagonal. For an unpolarized particle, we also
return [[.true.]] since the density matrix is proportional to the unit
matrix.
<<Polarizations: polarization: TBP>>=
procedure :: is_diagonal => polarization_is_diagonal
<<Polarizations: sub interfaces>>=
module function polarization_is_diagonal (pol) result (diagonal)
class(polarization_t), intent(in) :: pol
logical :: diagonal
end function polarization_is_diagonal
<<Polarizations: procedures>>=
module function polarization_is_diagonal (pol) result (diagonal)
class(polarization_t), intent(in) :: pol
logical :: diagonal
select case (pol%chirality)
case (0)
diagonal = pol%bv%is_diagonal ()
case default
diagonal = .true.
end select
end function polarization_is_diagonal
@ %def polarization_is_diagonal
@
\subsection{Mapping between polarization and state matrix}
Create the polarization object that corresponds to a state matrix. The state
matrix is not necessarily normalized. The result will be either unpolarized,
or a generalized Bloch vector that we compute in terms of the appropriate spin
generator basis. To this end, we first construct the complete density
matrix, then set the Bloch vector with this input.
For a naturally chiral particle (i.e., neutrino), we do not set the
polarization vector, it is implied.
Therefore, we cannot account for any sign flip and transform as-is.
<<Polarizations: polarization: TBP>>=
procedure :: init_state_matrix => polarization_init_state_matrix
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_state_matrix (pol, state)
class(polarization_t), intent(out) :: pol
type(state_matrix_t), intent(in), target :: state
end subroutine polarization_init_state_matrix
<<Polarizations: procedures>>=
module subroutine polarization_init_state_matrix (pol, state)
class(polarization_t), intent(out) :: pol
type(state_matrix_t), intent(in), target :: state
type(state_iterator_t) :: it
type(flavor_t) :: flv
type(helicity_t) :: hel
integer :: d, h1, h2, i, j
complex(default), dimension(:,:), allocatable :: r
complex(default) :: me
real(default) :: trace
call it%init (state)
flv = it%get_flavor (1)
hel = it%get_helicity (1)
if (hel%is_defined ()) then
call pol%init_generic (flv)
select case (pol%chirality)
case (0)
trace = 0
d = pol%bv%get_n_states ()
allocate (r (d, d), source = (0._default, 0._default))
do while (it%is_valid ())
hel = it%get_helicity (1)
call hel%get_indices (h1, h2)
i = pol%bv%hel_index (h1)
j = pol%bv%hel_index (h2)
me = it%get_matrix_element ()
r(i,j) = me
if (i == j) trace = trace + real (me)
call it%advance ()
end do
if (trace /= 0) call pol%bv%set (r / trace)
end select
else
call pol%init (flv)
end if
end subroutine polarization_init_state_matrix
@ %def polarization_init_state_matrix
@ Create the state matrix that corresponds to a given polarization. We make
use of the polarization iterator as defined below, which should iterate
according to the canonical helicity ordering.
<<Polarizations: polarization: TBP>>=
procedure :: to_state => polarization_to_state_matrix
<<Polarizations: sub interfaces>>=
module subroutine polarization_to_state_matrix (pol, state, all_states, tolerance)
class(polarization_t), intent(in), target :: pol
type(state_matrix_t), intent(out) :: state
logical, intent(in), optional :: all_states
real(default), intent(in), optional :: tolerance
end subroutine polarization_to_state_matrix
<<Polarizations: procedures>>=
module subroutine polarization_to_state_matrix (pol, state, all_states, tolerance)
class(polarization_t), intent(in), target :: pol
type(state_matrix_t), intent(out) :: state
logical, intent(in), optional :: all_states
real(default), intent(in), optional :: tolerance
type(polarization_iterator_t) :: it
type(quantum_numbers_t), dimension(1) :: qn
complex(default) :: value
call it%init (pol, all_states, tolerance)
call state%init (store_values = .true.)
do while (it%is_valid ())
value = it%get_value ()
qn(1) = it%get_quantum_numbers ()
call state%add_state (qn, value = value)
call it%advance ()
end do
call state%freeze ()
end subroutine polarization_to_state_matrix
@ %def polarization_to_state_matrix
@
\subsection{Specific initializers}
Unpolarized particle, no nontrivial entries in the density matrix. This
is the default initialization mode.
<<Polarizations: polarization: TBP>>=
procedure :: init_unpolarized => polarization_init_unpolarized
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_unpolarized (pol, flv)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
end subroutine polarization_init_unpolarized
<<Polarizations: procedures>>=
module subroutine polarization_init_unpolarized (pol, flv)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
call pol%init (flv)
end subroutine polarization_init_unpolarized
@ %def polarization_init_unpolarized
@ The following three modes are useful mainly for spin-1/2 particle
and massless particles of any nonzero spin. Only the highest-weight
components are filled.
Circular polarization: The density matrix of the two highest-weight
states is
\begin{equation*}
\rho(f) =
\frac{1-|f|}{2}\mathbf{1} +
|f| \times
\begin{cases}
\begin{pmatrix} 1 & 0 \\ 0 & 0 \end{pmatrix}, & f > 0; \\[6pt]
\begin{pmatrix} 0 & 0 \\ 0 & 1 \end{pmatrix}, & f < 0,
\end{cases}
\end{equation*}
In the generalized Bloch representation, this is an entry for the $T^3$
generator only, regardless of the spin representation.
A chiral particle is not affected.
<<Polarizations: polarization: TBP>>=
procedure :: init_circular => polarization_init_circular
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_circular (pol, flv, f)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), intent(in) :: f
end subroutine polarization_init_circular
<<Polarizations: procedures>>=
module subroutine polarization_init_circular (pol, flv, f)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), intent(in) :: f
call pol%init (flv)
select case (pol%chirality)
case (0)
call pol%bv%init_vector (pol%spin_type, &
[0._default, 0._default, f])
end select
end subroutine polarization_init_circular
@ %def polarization_init_circular
@ Transversal polarization is analogous to circular, but we get a
density matrix
\begin{equation*}
\rho(f,\phi) =
\frac{1-|f|}{2}\mathbf{1}
+ \frac{|f|}{2} \begin{pmatrix} 1 & e^{-i\phi} \\ e^{i\phi} & 1
\end{pmatrix}.
\end{equation*}
for the highest-weight subspace. The lower weights are unaffected.
The phase is $\phi=0$ for the $x$-axis, $\phi=90^\circ$ for the $y$
axis as polarization vector.
For an antiparticle, the phase switches sign, and for $f<0$, the
off-diagonal elements switch sign.
A chiral particle is not affected.
<<Polarizations: polarization: TBP>>=
procedure :: init_transversal => polarization_init_transversal
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_transversal (pol, flv, phi, f)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), intent(in) :: phi, f
end subroutine polarization_init_transversal
<<Polarizations: procedures>>=
module subroutine polarization_init_transversal (pol, flv, phi, f)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), intent(in) :: phi, f
call pol%init (flv)
select case (pol%chirality)
case (0)
if (pol%anti) then
call pol%bv%init_vector (pol%spin_type, &
[f * cos (phi), f * sin (phi), 0._default])
else
call pol%bv%init_vector (pol%spin_type, &
[f * cos (phi),-f * sin (phi), 0._default])
end if
end select
end subroutine polarization_init_transversal
@ %def polarization_init_transversal
@ For axis polarization, we again set only the entries with maximum weight,
which for spin $1/2$ means
\begin{equation*}
\rho(f,\phi) =
\frac{1}{2} \begin{pmatrix}
1 + \alpha_3 & \alpha_1 - i\alpha_2 \\
\alpha_1 + i\alpha_2 & 1 - \alpha_3
\end{pmatrix}.
\end{equation*}
For an antiparticle, the imaginary part proportional to $\alpha_2$ switches
sign (complex conjugate). A chiral particle is not affected.
In the generalized Bloch representation, this translates into coefficients for
$T^{1,2,3}$, all others stay zero.
<<Polarizations: polarization: TBP>>=
procedure :: init_axis => polarization_init_axis
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_axis (pol, flv, alpha)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), dimension(3), intent(in) :: alpha
end subroutine polarization_init_axis
<<Polarizations: procedures>>=
module subroutine polarization_init_axis (pol, flv, alpha)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), dimension(3), intent(in) :: alpha
call pol%init (flv)
select case (pol%chirality)
case (0)
if (pol%anti) then
call pol%bv%init_vector (pol%spin_type, &
[alpha(1), alpha(2), alpha(3)])
else
call pol%bv%init_vector (pol%spin_type, &
[alpha(1),-alpha(2), alpha(3)])
end if
end select
end subroutine polarization_init_axis
@ %def polarization_init_axis
@ This version specifies the polarization axis in terms of $r$
(polarization degree) and $\theta,\phi$ (polar and azimuthal angles).
If one of the angles is a nonzero multiple of $\pi$, roundoff errors
typically will result in tiny contributions to unwanted components.
Therefore, include a catch for small numbers.
<<Polarizations: polarization: TBP>>=
procedure :: init_angles => polarization_init_angles
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_angles (pol, flv, r, theta, phi)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), intent(in) :: r, theta, phi
end subroutine polarization_init_angles
<<Polarizations: procedures>>=
module subroutine polarization_init_angles (pol, flv, r, theta, phi)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), intent(in) :: r, theta, phi
real(default), dimension(3) :: alpha
real(default), parameter :: eps = 10 * epsilon (1._default)
alpha(1) = r * sin (theta) * cos (phi)
alpha(2) = r * sin (theta) * sin (phi)
alpha(3) = r * cos (theta)
where (abs (alpha) < eps) alpha = 0
call pol%init_axis (flv, alpha)
end subroutine polarization_init_angles
@ %def polarization_init_angles
@ Longitudinal polarization is defined only for massive bosons. Only
the zero component is filled. Otherwise, unpolarized.
In the generalized Bloch representation, the zero component corresponds to a
linear combination of all diagonal (Cartan) generators.
<<Polarizations: polarization: TBP>>=
procedure :: init_longitudinal => polarization_init_longitudinal
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_longitudinal (pol, flv, f)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), intent(in) :: f
end subroutine polarization_init_longitudinal
<<Polarizations: procedures>>=
module subroutine polarization_init_longitudinal (pol, flv, f)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), intent(in) :: f
real(default), dimension(:), allocatable :: rd
integer :: s, d
s = flv%get_spin_type ()
select case (s)
case (VECTOR, TENSOR)
call pol%init_generic (flv)
if (pol%bv%is_polarized ()) then
d = pol%bv%get_n_states ()
allocate (rd (d), source = 0._default)
rd(pol%bv%hel_index (0)) = f
call pol%bv%set (rd)
end if
case default
call pol%init_unpolarized (flv)
end select
end subroutine polarization_init_longitudinal
@ %def polarization_init_longitudinal
@ This is diagonal polarization: we specify all components explicitly.
[[rd]] is the array of diagonal elements of the density matrix. We
assume that the length of [[rd]] is equal to the particle
multiplicity.
<<Polarizations: polarization: TBP>>=
procedure :: init_diagonal => polarization_init_diagonal
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_diagonal (pol, flv, rd)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), dimension(:), intent(in) :: rd
end subroutine polarization_init_diagonal
<<Polarizations: procedures>>=
module subroutine polarization_init_diagonal (pol, flv, rd)
class(polarization_t), intent(out) :: pol
type(flavor_t), intent(in) :: flv
real(default), dimension(:), intent(in) :: rd
real(default) :: trace
call pol%init_generic (flv)
if (pol%bv%is_polarized ()) then
trace = sum (rd)
if (trace /= 0) call pol%bv%set (rd / trace)
end if
end subroutine polarization_init_diagonal
@ %def polarization_init_diagonal
@
\subsection{Operations}
Combine polarization states by computing the outer product of the
state matrices.
<<Polarizations: public>>=
public :: combine_polarization_states
<<Polarizations: sub interfaces>>=
module subroutine combine_polarization_states (pol, state)
type(polarization_t), dimension(:), intent(in), target :: pol
type(state_matrix_t), intent(out) :: state
end subroutine combine_polarization_states
<<Polarizations: procedures>>=
module subroutine combine_polarization_states (pol, state)
type(polarization_t), dimension(:), intent(in), target :: pol
type(state_matrix_t), intent(out) :: state
type(state_matrix_t), dimension(size(pol)), target :: pol_state
integer :: i
do i = 1, size (pol)
call pol(i)%to_state (pol_state(i))
end do
call outer_multiply (pol_state, state)
do i = 1, size (pol)
call pol_state(i)%final ()
end do
end subroutine combine_polarization_states
@ %def combine_polarization_states
@ Transform a polarization density matrix into a polarization vector. This is
possible without information loss only for spin-1/2 and for massless
particles. To get a unique answer in all cases, we consider only the
components with highest weight. Obviously, this loses the longitudinal
component of a massive vector, for instance. The norm of the returned axis is
the polarization fraction for the highest-weight subspace. For a scalar
particle, we return a zero vector. The same result applies if the
highest-weight component vanishes.
This is the inverse operation of [[polarization_init_axis]] above,
where the polarization fraction is set to unity.
For an antiparticle, the [[alpha(2)]] coefficient flips sign.
<<Polarizations: polarization: TBP>>=
procedure :: get_axis => polarization_get_axis
<<Polarizations: sub interfaces>>=
module function polarization_get_axis (pol) result (alpha)
class(polarization_t), intent(in), target :: pol
real(default), dimension(3) :: alpha
end function polarization_get_axis
<<Polarizations: procedures>>=
module function polarization_get_axis (pol) result (alpha)
class(polarization_t), intent(in), target :: pol
real(default), dimension(3) :: alpha
select case (pol%chirality)
case (0)
call pol%bv%to_vector (alpha)
if (.not. pol%anti) alpha(2) = - alpha(2)
case (-1)
alpha = [0._default, 0._default, -1._default]
case (1)
alpha = [0._default, 0._default, 1._default]
end select
end function polarization_get_axis
@ %def polarization_get_axis
@ This function returns polarization degree and polar and azimuthal
angles ($\theta,\phi$) of the polarization axis. The same restrictions apply
as above.
Since we call the [[get_axis]] method, the phase flips sign for an
antiparticle.
<<Polarizations: polarization: TBP>>=
procedure :: to_angles => polarization_to_angles
<<Polarizations: sub interfaces>>=
module subroutine polarization_to_angles (pol, r, theta, phi)
class(polarization_t), intent(in) :: pol
real(default), intent(out) :: r, theta, phi
end subroutine polarization_to_angles
<<Polarizations: procedures>>=
module subroutine polarization_to_angles (pol, r, theta, phi)
class(polarization_t), intent(in) :: pol
real(default), intent(out) :: r, theta, phi
real(default), dimension(3) :: alpha
real(default) :: norm, r12
alpha = pol%get_axis ()
norm = sum (alpha**2)
r = sqrt (norm)
if (norm > 0) then
r12 = sqrt (alpha(1)**2 + alpha(2)**2)
theta = atan2 (r12, alpha(3))
if (any (alpha(1:2) /= 0)) then
phi = atan2 (alpha(2), alpha(1))
else
phi = 0
end if
else
theta = 0
phi = 0
end if
end subroutine polarization_to_angles
@ %def polarization_to_angles
@
\subsection{Polarization Iterator}
The iterator acts like a state matrix iterator, i.e., it points to one
helicity combination at a time and can return the corresponding helicity
object and matrix-element value.
Since the polarization is stored as a Bloch vector, we recover the
whole density matrix explicitly upon initialization, store it inside
the iterator object, and then just return its elements one at a time.
For an unpolarized particle, the iterator returns a single state with
undefined helicity. The value is the value of any diagonal density
matrix element, $1/n$ where $n$ is the multiplicity.
<<Polarizations: public>>=
public :: polarization_iterator_t
<<Polarizations: types>>=
type :: polarization_iterator_t
private
type(polarization_t), pointer :: pol => null ()
logical :: polarized = .false.
integer :: h1 = 0
integer :: h2 = 0
integer :: i = 0
integer :: j = 0
complex(default), dimension(:,:), allocatable :: r
complex(default) :: value = 1._default
real(default) :: tolerance = -1._default
logical :: valid = .false.
contains
<<Polarizations: polarization iterator: TBP>>
end type polarization_iterator_t
@ %def polarization_iterator_t
@ Output for debugging purposes only, therefore no format for real/complex.
<<Polarizations: polarization iterator: TBP>>=
procedure :: write => polarization_iterator_write
<<Polarizations: sub interfaces>>=
module subroutine polarization_iterator_write (it, unit)
class(polarization_iterator_t), intent(in) :: it
integer, intent(in), optional :: unit
end subroutine polarization_iterator_write
<<Polarizations: procedures>>=
module subroutine polarization_iterator_write (it, unit)
class(polarization_iterator_t), intent(in) :: it
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1X,A)") "Polarization iterator:"
write (u, "(3X,A,L1)") "assigned = ", associated (it%pol)
write (u, "(3X,A,L1)") "valid = ", it%valid
if (it%valid) then
write (u, "(3X,A,2(1X,I2))") "i, j = ", it%i, it%j
write (u, "(3X,A,2(1X,I2))") "h1, h2 = ", it%h1, it%h2
write (u, "(3X,A)", advance="no") "value = "
write (u, *) it%value
if (allocated (it%r)) then
do i = 1, size (it%r, 2)
write (u, *) it%r(i,:)
end do
end if
end if
end subroutine polarization_iterator_write
@ %def polarization_iterator_write
@ Initialize, i.e., (virtually) point to the first helicity state
supported by the polarization object. If the density matrix is
nontrivial, we calculate it here.
Following the older state-matrix
conventions, the iterator sequence starts at the lowest helicity
value. In the current internal representation, this corresponds to
the highest index value.
If the current matrix-element value is zero, advance the iterator.
Advancing will stop at a nonzero value or if the iterator becomes
invalid.
If [[tolerance]] is given, any state matrix entry less or equal will
be treated as zero, causing the iterator to skip an entry. By
default, the value is negative, so no entry is skipped.
<<Polarizations: polarization iterator: TBP>>=
procedure :: init => polarization_iterator_init
<<Polarizations: sub interfaces>>=
module subroutine polarization_iterator_init (it, pol, all_states, tolerance)
class(polarization_iterator_t), intent(out) :: it
type(polarization_t), intent(in), target :: pol
logical, intent(in), optional :: all_states
real(default), intent(in), optional :: tolerance
end subroutine polarization_iterator_init
<<Polarizations: procedures>>=
module subroutine polarization_iterator_init (it, pol, all_states, tolerance)
class(polarization_iterator_t), intent(out) :: it
type(polarization_t), intent(in), target :: pol
logical, intent(in), optional :: all_states
real(default), intent(in), optional :: tolerance
integer :: d
logical :: only_max_weight
it%pol => pol
if (present (all_states)) then
if (.not. all_states) then
if (present (tolerance)) then
it%tolerance = tolerance
else
it%tolerance = 0
end if
end if
end if
select case (pol%chirality)
case (0)
d = pol%bv%get_n_states ()
only_max_weight = pol%multiplicity < d
it%polarized = pol%bv%is_polarized ()
if (it%polarized) then
it%i = d
it%j = it%i
it%h1 = pol%bv%hel_value (it%i)
it%h2 = it%h1
call pol%bv%to_matrix (it%r, only_max_weight)
it%value = it%r(it%i, it%j)
else
it%value = 1._default / d
end if
it%valid = .true.
case (1,-1)
it%polarized = .true.
select case (pol%spin_type)
case (SPINOR)
it%h1 = pol%chirality
case (VECTORSPINOR)
it%h1 = 2 * pol%chirality
end select
it%h2 = it%h1
it%valid = .true.
end select
if (it%valid .and. abs (it%value) <= it%tolerance) call it%advance ()
end subroutine polarization_iterator_init
@ %def polarization_iterator_init
@ Advance to the next valid helicity state. Repeat if the returned value is
zero.
For an unpolarized object, we iterate through the diagonal helicity
states with a constant value.
<<Polarizations: polarization iterator: TBP>>=
procedure :: advance => polarization_iterator_advance
<<Polarizations: sub interfaces>>=
recursive module subroutine polarization_iterator_advance (it)
class(polarization_iterator_t), intent(inout) :: it
end subroutine polarization_iterator_advance
<<Polarizations: procedures>>=
recursive module subroutine polarization_iterator_advance (it)
class(polarization_iterator_t), intent(inout) :: it
if (it%valid) then
select case (it%pol%chirality)
case (0)
if (it%polarized) then
if (it%j > 1) then
it%j = it%j - 1
it%h2 = it%pol%bv%hel_value (it%j)
it%value = it%r(it%i, it%j)
else if (it%i > 1) then
it%j = it%pol%bv%get_n_states ()
it%h2 = it%pol%bv%hel_value (it%j)
it%i = it%i - 1
it%h1 = it%pol%bv%hel_value (it%i)
it%value = it%r(it%i, it%j)
else
it%valid = .false.
end if
else
it%valid = .false.
end if
case default
it%valid = .false.
end select
if (it%valid .and. abs (it%value) <= it%tolerance) call it%advance ()
end if
end subroutine polarization_iterator_advance
@ %def polarization_iterator_advance
@ This is true as long as the iterator points to a valid helicity state.
<<Polarizations: polarization iterator: TBP>>=
procedure :: is_valid => polarization_iterator_is_valid
<<Polarizations: sub interfaces>>=
module function polarization_iterator_is_valid (it) result (is_valid)
logical :: is_valid
class(polarization_iterator_t), intent(in) :: it
end function polarization_iterator_is_valid
<<Polarizations: procedures>>=
module function polarization_iterator_is_valid (it) result (is_valid)
logical :: is_valid
class(polarization_iterator_t), intent(in) :: it
is_valid = it%valid
end function polarization_iterator_is_valid
@ %def polarization_iterator_is_valid
@ Return the matrix element value for the helicity that we are currently
pointing at.
<<Polarizations: polarization iterator: TBP>>=
procedure :: get_value => polarization_iterator_get_value
<<Polarizations: sub interfaces>>=
module function polarization_iterator_get_value (it) result (value)
complex(default) :: value
class(polarization_iterator_t), intent(in) :: it
end function polarization_iterator_get_value
<<Polarizations: procedures>>=
module function polarization_iterator_get_value (it) result (value)
complex(default) :: value
class(polarization_iterator_t), intent(in) :: it
if (it%valid) then
value = it%value
else
value = 0
end if
end function polarization_iterator_get_value
@ %def polarization_iterator_get_value
@ Return a quantum number object for the helicity that we are currently
pointing at. This is a single quantum number object, not an array.
Note that the [[init]] method of the helicity object has the order reversed.
<<Polarizations: polarization iterator: TBP>>=
procedure :: get_quantum_numbers => polarization_iterator_get_quantum_numbers
<<Polarizations: sub interfaces>>=
module function polarization_iterator_get_quantum_numbers (it) result (qn)
class(polarization_iterator_t), intent(in) :: it
type(quantum_numbers_t) :: qn
end function polarization_iterator_get_quantum_numbers
<<Polarizations: procedures>>=
module function polarization_iterator_get_quantum_numbers (it) result (qn)
class(polarization_iterator_t), intent(in) :: it
type(helicity_t) :: hel
type(quantum_numbers_t) :: qn
if (it%polarized) then
call hel%init (it%h2, it%h1)
end if
call qn%init (hel)
end function polarization_iterator_get_quantum_numbers
@ %def polarization_iterator_get_quantum_numbers
@
\subsection{Sparse Matrix}
We introduce a simple implementation of a sparse matrix that can represent
polarization (or similar concepts) for transfer to I/O within the
program. It consists of an integer array that represents the index
values, and a complex array that represents the nonvanishing entries. The
number of nonvanishing entries must be known for initialization, but the
entries are filled one at a time.
Here is a base type without the special properties of a spin-density matrix.
<<Polarizations: public>>=
public :: smatrix_t
<<Polarizations: types>>=
type :: smatrix_t
private
integer :: dim = 0
integer :: n_entry = 0
integer, dimension(:,:), allocatable :: index
complex(default), dimension(:), allocatable :: value
contains
<<Polarizations: smatrix: TBP>>
end type smatrix_t
@ %def smatrix_t
@ Output.
<<Polarizations: smatrix: TBP>>=
procedure :: write => smatrix_write
<<Polarizations: sub interfaces>>=
module subroutine smatrix_write (object, unit, indent)
class(smatrix_t), intent(in) :: object
integer, intent(in), optional :: unit, indent
end subroutine smatrix_write
<<Polarizations: procedures>>=
module subroutine smatrix_write (object, unit, indent)
class(smatrix_t), intent(in) :: object
integer, intent(in), optional :: unit, indent
integer :: u, i, ind
u = given_output_unit (unit)
ind = 0; if (present (indent)) ind = indent
if (allocated (object%value)) then
if (size (object%value) > 0) then
do i = 1, object%n_entry
write (u, "(1x,A,'@(')", advance="no") repeat (" ", ind)
write (u, "(SP,9999(I2.1,':',1x))", advance="no") &
object%index(:,i)
write (u, "('('," // FMT_19 // ",','," // FMT_19 // &
",'))')") object%value(i)
end do
else
write (u, "(1x,A)", advance="no") repeat (" ", ind)
write (u, "(A)") "[empty matrix]"
end if
else
write (u, "(1x,A)", advance="no") repeat (" ", ind)
write (u, "(A)") "[undefined matrix]"
end if
end subroutine smatrix_write
@ %def smatrix_write
@ Initialization: allocate arrays to the correct size. We specify both the
dimension of the matrix (if different from two, this is rather a generic
tensor) and the number of nonvanishing entries.
<<Polarizations: smatrix: TBP>>=
procedure :: init => smatrix_init
<<Polarizations: sub interfaces>>=
module subroutine smatrix_init (smatrix, dim, n_entry)
class(smatrix_t), intent(out) :: smatrix
integer, intent(in) :: dim
integer, intent(in) :: n_entry
end subroutine smatrix_init
<<Polarizations: procedures>>=
module subroutine smatrix_init (smatrix, dim, n_entry)
class(smatrix_t), intent(out) :: smatrix
integer, intent(in) :: dim
integer, intent(in) :: n_entry
smatrix%dim = dim
smatrix%n_entry = n_entry
allocate (smatrix%index (dim, n_entry))
allocate (smatrix%value (n_entry))
end subroutine smatrix_init
@ %def smatrix_init
@ Fill: one entry at a time.
<<Polarizations: smatrix: TBP>>=
procedure :: set_entry => smatrix_set_entry
<<Polarizations: sub interfaces>>=
module subroutine smatrix_set_entry (smatrix, i, index, value)
class(smatrix_t), intent(inout) :: smatrix
integer, intent(in) :: i
integer, dimension(:), intent(in) :: index
complex(default), intent(in) :: value
end subroutine smatrix_set_entry
<<Polarizations: procedures>>=
module subroutine smatrix_set_entry (smatrix, i, index, value)
class(smatrix_t), intent(inout) :: smatrix
integer, intent(in) :: i
integer, dimension(:), intent(in) :: index
complex(default), intent(in) :: value
smatrix%index(:,i) = index
smatrix%value(i) = value
end subroutine smatrix_set_entry
@ %def smatrix_set_entry
@
<<Polarizations: smatrix: TBP>>=
procedure :: exists => smatrix_exists
<<Polarizations: sub interfaces>>=
elemental module function smatrix_exists (smatrix) result (exist)
logical :: exist
class(smatrix_t), intent(in) :: smatrix
end function smatrix_exists
<<Polarizations: procedures>>=
elemental module function smatrix_exists (smatrix) result (exist)
logical :: exist
class(smatrix_t), intent(in) :: smatrix
exist = .not. all (smatrix%value == 0)
end function smatrix_exists
@ %def smatrix_exists
@
\subsection{Polarization Matrix}
As an extension of the more generic [[smatrix]] type, we implement a proper
spin-density matrix. After the matrix has been filled, we can fix spin type
and multiplicity for a particle, check the matrix for consistency, and
normalize it if necessary.
This implementation does not have an antiparticle flag, just
like the state matrix object. We therefore cannot account for sign
flips when using this object.
TODO: The [[pure]] flag is for informational purposes only, and it
only represents a necessary condition if spin is greater than $1/2$.
We may either check purity for all spins or drop this.
<<Polarizations: public>>=
public :: pmatrix_t
<<Polarizations: types>>=
type, extends (smatrix_t) :: pmatrix_t
private
integer :: spin_type = 0
integer :: multiplicity = 0
logical :: massive = .true.
integer :: chirality = 0
real(default) :: degree = 1
logical :: pure = .false.
contains
<<Polarizations: pmatrix: TBP>>
end type pmatrix_t
@ %def pmatrix_t
@ Output, including extra data. (The [[indent]] argument is ignored.)
<<Polarizations: pmatrix: TBP>>=
procedure :: write => pmatrix_write
<<Polarizations: sub interfaces>>=
module subroutine pmatrix_write (object, unit, indent)
class(pmatrix_t), intent(in) :: object
integer, intent(in), optional :: unit, indent
end subroutine pmatrix_write
<<Polarizations: procedures>>=
module subroutine pmatrix_write (object, unit, indent)
class(pmatrix_t), intent(in) :: object
integer, intent(in), optional :: unit, indent
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Polarization: spin density matrix"
write (u, "(3x,A,I0)") "spin type = ", object%spin_type
write (u, "(3x,A,I0)") "multiplicity = ", object%multiplicity
write (u, "(3x,A,L1)") "massive = ", object%massive
write (u, "(3x,A,I0)") "chirality = ", object%chirality
write (u, "(3x,A,F10.7)") "pol.degree =", object%degree
write (u, "(3x,A,L1)") "pure state = ", object%pure
call object%smatrix_t%write (u, 1)
end subroutine pmatrix_write
@ %def pmatrix_write
@ This assignment is trivial, but must be coded explicitly.
<<Polarizations: pmatrix: TBP>>=
generic :: assignment(=) => pmatrix_assign_from_smatrix
procedure, private :: pmatrix_assign_from_smatrix
<<Polarizations: sub interfaces>>=
module subroutine pmatrix_assign_from_smatrix (pmatrix, smatrix)
class(pmatrix_t), intent(out) :: pmatrix
type(smatrix_t), intent(in) :: smatrix
end subroutine pmatrix_assign_from_smatrix
<<Polarizations: procedures>>=
module subroutine pmatrix_assign_from_smatrix (pmatrix, smatrix)
class(pmatrix_t), intent(out) :: pmatrix
type(smatrix_t), intent(in) :: smatrix
pmatrix%smatrix_t = smatrix
end subroutine pmatrix_assign_from_smatrix
@ %def pmatrix_assign_from_smatrix
@ Declare spin, multiplicity, and polarization degree. Check whether all
entries fit, and whether this is a valid matrix.
The required properties are:
\begin{enumerate}
\item all entries apply to the given spin and mass type
\item the diagonal is real
\item only the upper of corresponding off-diagonal elements is specified,
i.e., the row index is less than the column index
\item the trace is nonnegative and equal to the polarization degree (the
remainder, proportional to the unit matrix, is understood to be present)
\item the trace of the matrix square is positive and less or equal
to the trace of the matrix itself, which is the polarization degree.
\item If the trace of the matrix square and the trace of the matrix are unity,
we may have a pure state. (For spin up to $1/2$, this is actually
sufficient.)
\end{enumerate}
<<Polarizations: pmatrix: TBP>>=
procedure :: normalize => pmatrix_normalize
<<Polarizations: sub interfaces>>=
module subroutine pmatrix_normalize (pmatrix, flv, degree, tolerance)
class(pmatrix_t), intent(inout) :: pmatrix
type(flavor_t), intent(in) :: flv
real(default), intent(in), optional :: degree
real(default), intent(in), optional :: tolerance
end subroutine pmatrix_normalize
<<Polarizations: procedures>>=
module subroutine pmatrix_normalize (pmatrix, flv, degree, tolerance)
class(pmatrix_t), intent(inout) :: pmatrix
type(flavor_t), intent(in) :: flv
real(default), intent(in), optional :: degree
real(default), intent(in), optional :: tolerance
integer :: i, hmax
logical :: fermion, ok
real(default) :: trace, trace_sq
real(default) :: tol
tol = 0; if (present (tolerance)) tol = tolerance
pmatrix%spin_type = flv%get_spin_type ()
pmatrix%massive = flv%get_mass () /= 0
if (.not. pmatrix%massive) then
if (flv%is_left_handed ()) then
pmatrix%chirality = -1
else if (flv%is_right_handed ()) then
pmatrix%chirality = +1
end if
end if
if (pmatrix%spin_type == SCALAR) then
pmatrix%multiplicity = 1
else if (pmatrix%massive) then
pmatrix%multiplicity = pmatrix%spin_type
else if (pmatrix%chirality == 0) then
pmatrix%multiplicity = 2
else
pmatrix%multiplicity = 1
end if
if (present (degree)) then
if (degree < 0 .or. degree > 1) &
call msg_error ("polarization degree must be between 0 and 1")
pmatrix%degree = degree
end if
if (size (pmatrix%index, 1) /= 2) call error ("wrong array rank")
fermion = mod (pmatrix%spin_type, 2) == 0
hmax = pmatrix%spin_type / 2
if (pmatrix%n_entry > 0) then
if (fermion) then
if (pmatrix%massive) then
ok = all (pmatrix%index /= 0) &
.and. all (abs (pmatrix%index) <= hmax)
else if (pmatrix%chirality == -1) then
ok = all (pmatrix%index == -hmax)
else if (pmatrix%chirality == +1) then
ok = all (pmatrix%index == +hmax)
else
ok = all (abs (pmatrix%index) == hmax)
end if
else
if (pmatrix%massive) then
ok = all (abs (pmatrix%index) <= hmax)
else
ok = all (abs (pmatrix%index) == hmax)
end if
end if
if (.not. ok) call error ("illegal index value")
else
pmatrix%degree = 0
pmatrix%pure = pmatrix%multiplicity == 1
return
end if
trace = 0
do i = 1, pmatrix%n_entry
associate (index => pmatrix%index(:,i), value => pmatrix%value(i))
if (index(1) == index(2)) then
if (abs (aimag (value)) > tol) call error ("diagonal must be real")
value = real (value, kind=default)
trace = trace + value
else if (any (pmatrix%index(1,:) == index(2) &
.and. pmatrix%index(2,:) == index(1))) then
call error ("redundant off-diagonal entry")
else if (index(2) < index (1)) then
index = index([2,1])
value = conjg (value)
end if
end associate
end do
if (abs (trace) <= tol) call error ("trace must not vanish")
trace = real (trace, kind=default)
pmatrix%value = pmatrix%value / trace * pmatrix%degree
trace_sq = (1 - pmatrix%degree ** 2) / pmatrix%multiplicity
do i = 1, pmatrix%n_entry
associate (index => pmatrix%index(:,i), value => pmatrix%value(i))
if (index(1) == index(2)) then
trace_sq = trace_sq + abs (value) ** 2
else
trace_sq = trace_sq + 2 * abs (value) ** 2
end if
end associate
end do
if (pmatrix%multiplicity == 1) then
pmatrix%pure = .true.
else if (abs (trace_sq - 1) <= tol) then
pmatrix%pure = .true.
else if (trace_sq - 1 > tol .or. trace_sq < -tol) then
print *, "Trace of matrix square = ", trace_sq
call error ("not permissible as density matrix")
end if
contains
subroutine error (msg)
character(*), intent(in) :: msg
call pmatrix%write ()
call msg_fatal ("Spin density matrix: " // msg)
end subroutine error
end subroutine pmatrix_normalize
@ %def pmatrix_normalize
@
A polarized matrix is defined as one with a positive polarization degree, even
if the actual matrix is trivial.
<<Polarizations: pmatrix: TBP>>=
procedure :: is_polarized => pmatrix_is_polarized
<<Polarizations: sub interfaces>>=
elemental module function pmatrix_is_polarized (pmatrix) result (flag)
class(pmatrix_t), intent(in) :: pmatrix
logical :: flag
end function pmatrix_is_polarized
<<Polarizations: procedures>>=
elemental module function pmatrix_is_polarized (pmatrix) result (flag)
class(pmatrix_t), intent(in) :: pmatrix
logical :: flag
flag = pmatrix%degree > 0
end function pmatrix_is_polarized
@ %def pmatrix_is_polarized
@
Check if there are only diagonal entries.
<<Polarizations: pmatrix: TBP>>=
procedure :: is_diagonal => pmatrix_is_diagonal
<<Polarizations: sub interfaces>>=
elemental module function pmatrix_is_diagonal (pmatrix) result (flag)
class(pmatrix_t), intent(in) :: pmatrix
logical :: flag
end function pmatrix_is_diagonal
<<Polarizations: procedures>>=
elemental module function pmatrix_is_diagonal (pmatrix) result (flag)
class(pmatrix_t), intent(in) :: pmatrix
logical :: flag
flag = all (pmatrix%index(1,:) == pmatrix%index(2,:))
end function pmatrix_is_diagonal
@ %def pmatrix_is_diagonal
@
Check if there are only diagonal entries.
<<Polarizations: pmatrix: TBP>>=
procedure :: get_simple_pol => pmatrix_get_simple_pol
<<Polarizations: sub interfaces>>=
elemental module function pmatrix_get_simple_pol (pmatrix) result (pol)
class(pmatrix_t), intent(in) :: pmatrix
real(default) :: pol
end function pmatrix_get_simple_pol
<<Polarizations: procedures>>=
elemental module function pmatrix_get_simple_pol (pmatrix) result (pol)
class(pmatrix_t), intent(in) :: pmatrix
real(default) :: pol
if (pmatrix%is_polarized ()) then
select case (size (pmatrix%value))
case (0)
pol = 0
case (1)
pol = pmatrix%index (1,1) * pmatrix%degree
case (2)
pol = 42
end select
else
pol = 0
end if
end function pmatrix_get_simple_pol
@ %def pmatrix_get_simple_pol
@
\subsection{Data Transformation}
Create a [[polarization_t]] object from the contents of a normalized
[[pmatrix_t]] object. We scan the entries as present in [[pmatrix]] and
transform them into a density matrix, if necessary. The density
matrix then initializes the Bloch vector. This is
analogous to [[polarization_init_state_matrix]].
There is a subtlety associated with massless particles. Since the
[[pmatrix]] doesn't contain the full density matrix but just the
nontrivial part, we have to initialize the polarization object with
the massless equipartion, which contains nonzero entries for the
Cartan generators. The [[set]] method therefore should not erase
those initial contents. This is a constraint for the implementation
of [[set]], as applied to the Bloch vector.
As mentioned above, [[pmatrix_t]] does not support an
antiparticle flag.
<<Polarizations: polarization: TBP>>=
procedure :: init_pmatrix => polarization_init_pmatrix
<<Polarizations: sub interfaces>>=
module subroutine polarization_init_pmatrix (pol, pmatrix)
class(polarization_t), intent(out) :: pol
type(pmatrix_t), intent(in) :: pmatrix
end subroutine polarization_init_pmatrix
<<Polarizations: procedures>>=
module subroutine polarization_init_pmatrix (pol, pmatrix)
class(polarization_t), intent(out) :: pol
type(pmatrix_t), intent(in) :: pmatrix
integer :: d, i, j, k, h1, h2
complex(default), dimension(:,:), allocatable :: r
call pol%init_generic ( &
spin_type = pmatrix%spin_type, &
multiplicity = pmatrix%multiplicity, &
anti = .false., & !!! SUFFICIENT?
left_handed = pmatrix%chirality < 0, &
right_handed = pmatrix%chirality > 0)
if (pol%bv%is_polarized ()) then
d = pol%bv%get_n_states ()
allocate (r (d, d), source = (0._default, 0._default))
if (d == pmatrix%multiplicity) then
do i = 1, d
r(i,i) = (1 - pmatrix%degree) / d
end do
else if (d > pmatrix%multiplicity) then
r(1,1) = (1 - pmatrix%degree) / 2
r(d,d) = r(1,1)
end if
do k = 1, size (pmatrix%value)
h1 = pmatrix%index(1,k)
h2 = pmatrix%index(2,k)
i = pol%bv%hel_index (h1)
j = pol%bv%hel_index (h2)
r(i,j) = r(i,j) + pmatrix%value(k)
r(j,i) = conjg (r(i,j))
end do
call pol%bv%set (r)
end if
end subroutine polarization_init_pmatrix
@ %def polarization_init_pmatrix
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[polarizations_ut.f90]]>>=
<<File header>>
module polarizations_ut
use unit_tests
use polarizations_uti
<<Standard module head>>
<<Polarizations: public test>>
contains
<<Polarizations: test driver>>
end module polarizations_ut
@ %def polarizations_ut
@
<<[[polarizations_uti.f90]]>>=
<<File header>>
module polarizations_uti
<<Use kinds>>
use flavors
use model_data
use polarizations
<<Standard module head>>
<<Polarizations: test declarations>>
contains
<<Polarizations: tests>>
end module polarizations_uti
@ %def polarizations_ut
@ API: driver for the unit tests below.
<<Polarizations: public test>>=
public :: polarizations_test
<<Polarizations: test driver>>=
subroutine polarizations_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Polarizations: execute tests>>
end subroutine polarizations_test
@ %def polarizations_test
@
\subsubsection{Polarization type}
Checking the setup for polarization.
<<Polarizations: execute tests>>=
call test (polarization_1, "polarization_1", &
"check polarization setup", &
u, results)
<<Polarizations: test declarations>>=
public :: polarization_1
<<Polarizations: tests>>=
subroutine polarization_1 (u)
use os_interface
integer, intent(in) :: u
type(model_data_t), target :: model
type(polarization_t) :: pol
type(flavor_t) :: flv
real(default), dimension(3) :: alpha
real(default) :: r, theta, phi
real(default), parameter :: tolerance = 1.E-14_default
write (u, "(A)") "* Test output: polarization_1"
write (u, "(A)") "* Purpose: test polarization setup"
write (u, "(A)")
write (u, "(A)") "* Reading model file"
write (u, "(A)")
call model%init_sm_test ()
write (u, "(A)") "* Unpolarized fermion"
write (u, "(A)")
call flv%init (1, model)
call pol%init_unpolarized (flv)
call pol%write (u, state_matrix = .true.)
write (u, "(A,L1)") " diagonal =", pol%is_diagonal ()
write (u, "(A)")
write (u, "(A)") "* Unpolarized fermion"
write (u, "(A)")
call pol%init_circular (flv, 0._default)
call pol%write (u, state_matrix = .true., all_states = .false.)
write (u, "(A)")
write (u, "(A)") "* Transversally polarized fermion, phi=0"
write (u, "(A)")
call pol%init_transversal (flv, 0._default, 1._default)
call pol%write (u, state_matrix = .true.)
write (u, "(A,L1)") " diagonal =", pol%is_diagonal ()
write (u, "(A)")
write (u, "(A)") "* Transversally polarized fermion, phi=0.9, frac=0.8"
write (u, "(A)")
call pol%init_transversal (flv, 0.9_default, 0.8_default)
call pol%write (u, state_matrix = .true.)
write (u, "(A,L1)") " diagonal =", pol%is_diagonal ()
write (u, "(A)")
write (u, "(A)") "* All polarization directions of a fermion"
write (u, "(A)")
call pol%init_generic (flv)
call pol%write (u, state_matrix = .true.)
call flv%init (21, model)
write (u, "(A)")
write (u, "(A)") "* Circularly polarized gluon, frac=0.3"
write (u, "(A)")
call pol%init_circular (flv, 0.3_default)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
call flv%init (23, model)
write (u, "(A)")
write (u, "(A)") "* Circularly polarized massive vector, frac=-0.7"
write (u, "(A)")
call pol%init_circular (flv, -0.7_default)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
write (u, "(A)")
write (u, "(A)") "* Circularly polarized massive vector"
write (u, "(A)")
call pol%init_circular (flv, 1._default)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
write (u, "(A)")
write (u, "(A)") "* Longitudinally polarized massive vector, frac=0.4"
write (u, "(A)")
call pol%init_longitudinal (flv, 0.4_default)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
write (u, "(A)")
write (u, "(A)") "* Longitudinally polarized massive vector"
write (u, "(A)")
call pol%init_longitudinal (flv, 1._default)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
write (u, "(A)")
write (u, "(A)") "* Diagonally polarized massive vector"
write (u, "(A)")
call pol%init_diagonal &
(flv, [2._default, 1._default, 0._default])
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
write (u, "(A)")
write (u, "(A)") "* All polarization directions of a massive vector"
write (u, "(A)")
call pol%init_generic (flv)
call pol%write (u, state_matrix = .true.)
call flv%init (21, model)
write (u, "(A)")
write (u, "(A)") "* Axis polarization (0.2, 0.4, 0.6)"
write (u, "(A)")
alpha = [0.2_default, 0.4_default, 0.6_default]
call pol%init_axis (flv, alpha)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
write (u, "(A)")
write (u, "(1X,A)") "Recovered axis:"
alpha = pol%get_axis ()
write (u, "(3(1X,F10.7))") alpha
write (u, "(A)")
write (u, "(A)") "* Angle polarization (0.5, 0.6, -1)"
r = 0.5_default
theta = 0.6_default
phi = -1._default
call pol%init_angles (flv, r, theta, phi)
write (u, "(A)")
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
write (u, "(A)")
write (u, "(1X,A)") "Recovered parameters (r, theta, phi):"
call pol%to_angles (r, theta, phi)
write (u, "(3(1x,F10.7))") r, theta, phi
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: polarization_1"
end subroutine polarization_1
@ %def polarization_1
@
\subsubsection{Sparse-Matrix type}
Use a sparse density matrix universally as the input for setting up
polarization.
<<Polarizations: execute tests>>=
call test (polarization_2, "polarization_2", &
"matrix polarization setup", &
u, results)
<<Polarizations: test declarations>>=
public :: polarization_2
<<Polarizations: tests>>=
subroutine polarization_2 (u)
use os_interface
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t) :: flv
type(polarization_t) :: pol
real(default), dimension(3) :: alpha
type(pmatrix_t) :: pmatrix
real(default), parameter :: tolerance = 1e-8_default
write (u, "(A)") "* Test output: polarization_2"
write (u, "(A)") "* Purpose: matrix polarization setup"
write (u, "(A)")
write (u, "(A)") "* Reading model file"
write (u, "(A)")
call model%init_sm_test ()
write (u, "(A)") "* Unpolarized fermion"
write (u, "(A)")
call flv%init (1, model)
call pmatrix%init (2, 0)
call pmatrix%normalize (flv, 0._default, tolerance)
call pmatrix%write (u)
write (u, *)
write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Transversally polarized fermion, phi=0"
write (u, "(A)")
call pmatrix%init (2, 3)
call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default))
call pmatrix%set_entry (3, [-1,+1], (1._default, 0._default))
call pmatrix%normalize (flv, 1._default, tolerance)
call pmatrix%write (u)
write (u, *)
write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Transversally polarized fermion, phi=0.9, frac=0.8"
write (u, "(A)")
call pmatrix%init (2, 3)
call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
call pmatrix%set_entry (2, [+1,+1], (1._default, 0._default))
call pmatrix%set_entry (3, [-1,+1], exp ((0._default, -0.9_default)))
call pmatrix%normalize (flv, 0.8_default, tolerance)
call pmatrix%write (u)
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true.)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Left-handed massive fermion, frac=1"
write (u, "(A)")
call flv%init (11, model)
call pmatrix%init (2, 1)
call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
call pmatrix%normalize (flv, 1._default, tolerance)
call pmatrix%write (u)
write (u, *)
write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Left-handed massive fermion, frac=0.8"
write (u, "(A)")
call flv%init (11, model)
call pmatrix%init (2, 1)
call pmatrix%set_entry (1, [-1,-1], (1._default, 0._default))
call pmatrix%normalize (flv, 0.8_default, tolerance)
call pmatrix%write (u)
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Left-handed massless fermion"
write (u, "(A)")
call flv%init (12, model)
call pmatrix%init (2, 0)
call pmatrix%normalize (flv, 1._default, tolerance)
call pmatrix%write (u)
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true.)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Right-handed massless fermion, frac=0.5"
write (u, "(A)")
call flv%init (-12, model)
call pmatrix%init (2, 1)
call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
call pmatrix%normalize (flv, 0.5_default, tolerance)
call pmatrix%write (u)
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true.)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Circularly polarized gluon, frac=0.3"
write (u, "(A)")
call flv%init (21, model)
call pmatrix%init (2, 1)
call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
call pmatrix%normalize (flv, 0.3_default, tolerance)
call pmatrix%write (u)
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Circularly polarized massive vector, frac=0.7"
write (u, "(A)")
call flv%init (23, model)
call pmatrix%init (2, 1)
call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
call pmatrix%normalize (flv, 0.7_default, tolerance)
call pmatrix%write (u)
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Circularly polarized massive vector"
write (u, "(A)")
call flv%init (23, model)
call pmatrix%init (2, 1)
call pmatrix%set_entry (1, [1,1], (1._default, 0._default))
call pmatrix%normalize (flv, 1._default, tolerance)
call pmatrix%write (u)
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Longitudinally polarized massive vector, frac=0.4"
write (u, "(A)")
call flv%init (23, model)
call pmatrix%init (2, 1)
call pmatrix%set_entry (1, [0,0], (1._default, 0._default))
call pmatrix%normalize (flv, 0.4_default, tolerance)
call pmatrix%write (u)
write (u, *)
write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Longitudinally polarized massive vector"
write (u, "(A)")
call flv%init (23, model)
call pmatrix%init (2, 1)
call pmatrix%set_entry (1, [0,0], (1._default, 0._default))
call pmatrix%normalize (flv, 1._default, tolerance)
call pmatrix%write (u)
write (u, *)
write (u, "(1x,A,L1)") "polarized = ", pmatrix%is_polarized ()
write (u, "(1x,A,L1)") "diagonal = ", pmatrix%is_diagonal ()
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true., &
all_states = .false., tolerance = tolerance)
! call pol%final ()
write (u, "(A)")
write (u, "(A)") "* Axis polarization (0.2, 0.4, 0.6)"
write (u, "(A)")
call flv%init (11, model)
alpha = [0.2_default, 0.4_default, 0.6_default]
alpha = alpha / sqrt (sum (alpha**2))
call pmatrix%init (2, 3)
call pmatrix%set_entry (1, [-1,-1], cmplx (1 - alpha(3), kind=default))
call pmatrix%set_entry (2, [1,-1], &
cmplx (alpha(1),-alpha(2), kind=default))
call pmatrix%set_entry (3, [1,1], cmplx (1 + alpha(3), kind=default))
call pmatrix%normalize (flv, 1._default, tolerance)
call pmatrix%write (u)
write (u, *)
call pol%init_pmatrix (pmatrix)
call pol%write (u, state_matrix = .true.)
! call pol%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: polarization_2"
end subroutine polarization_2
@ %def polarization_2
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Particles}
This module defines the [[particle_t]] object type, and the methods
and operations that deal with it.
<<[[particles.f90]]>>=
<<File header>>
module particles
<<Use kinds with double>>
<<Use strings>>
<<Use debug>>
use lorentz
use phs_points, only: phs_point_t, assignment(=)
use model_data
use flavors
use colors
use helicities
use quantum_numbers
use state_matrices
use interactions
use subevents
use polarizations
<<Standard module head>>
<<Particles: public>>
<<Particles: parameters>>
<<Particles: types>>
<<Particles: interfaces>>
interface
<<Particles: sub interfaces>>
end interface
end module particles
@ %def particles
@
<<[[particles_sub.f90]]>>=
<<File header>>
submodule (particles) particles_s
use io_units
use format_utils, only: write_compressed_integer_array, write_separator
use format_utils, only: pac_fmt
use format_defs, only: FMT_16, FMT_19
use numeric_utils
use diagnostics
use pdg_arrays, only: is_quark, is_gluon
implicit none
contains
<<Particles: procedures>>
end submodule particles_s
@ %def particles_s
@
\subsection{The particle type}
\subsubsection{Particle status codes}
The overall status codes (incoming/outgoing etc.) are inherited from
the module [[subevents]].
Polarization status:
<<Particles: parameters>>=
integer, parameter, public :: PRT_UNPOLARIZED = 0
integer, parameter, public :: PRT_DEFINITE_HELICITY = 1
integer, parameter, public :: PRT_GENERIC_POLARIZATION = 2
@ %def PRT_UNPOLARIZED PRT_DEFINITE_HELICITY PRT_GENERIC_POLARIZATION
@
\subsubsection{Definition}
The quantum numbers are flavor (from which invariant particle
properties can be derived), color, and polarization. The particle may
be unpolarized. In this case, [[hel]] and [[pol]] are unspecified.
If it has a definite helicity, the [[hel]] component is defined. If
it has a generic polarization, the [[pol]] component is defined. For
each particle we store the four-momentum and the invariant mass
squared, i.e., the squared norm of the four-momentum. There is also
an optional list of parent and child particles, for bookkeeping in
physical events. The [[vertex]] is an optional component that consists of
a Lorentz 4-vector, denoting the position and time of the vertex
(displaced vertex/time). [[lifetime]] is an optional component that
accounts for the finite lifetime $\tau$ of a decaying particle. In
case there is no magnetic field etc., the true decay vertex of a
particle in the detector would be $\vec{v}^\prime = \vec{v} + \tau
\times \vec{p}/p^0$, where $p^0$ and $\vec{p}$ are the energy and
3-momentum of the particle.
<<Particles: public>>=
public :: particle_t
<<Particles: types>>=
type :: particle_t
!private
integer :: status = PRT_UNDEFINED
integer :: polarization = PRT_UNPOLARIZED
type(flavor_t) :: flv
type(color_t) :: col
type(helicity_t) :: hel
type(polarization_t) :: pol
type(vector4_t) :: p = vector4_null
real(default) :: p2 = 0
type(vector4_t), allocatable :: vertex
real(default), allocatable :: lifetime
integer, dimension(:), allocatable :: parent
integer, dimension(:), allocatable :: child
contains
<<Particles: particle: TBP>>
end type particle_t
@ %def particle_t
@ Copy a particle. (Deep copy) This excludes the parent-child
relations.
<<Particles: particle: TBP>>=
generic :: init => init_particle
procedure :: init_particle => particle_init_particle
<<Particles: sub interfaces>>=
module subroutine particle_init_particle (prt_out, prt_in)
class(particle_t), intent(out) :: prt_out
type(particle_t), intent(in) :: prt_in
end subroutine particle_init_particle
<<Particles: procedures>>=
module subroutine particle_init_particle (prt_out, prt_in)
class(particle_t), intent(out) :: prt_out
type(particle_t), intent(in) :: prt_in
prt_out%status = prt_in%status
prt_out%polarization = prt_in%polarization
prt_out%flv = prt_in%flv
prt_out%col = prt_in%col
prt_out%hel = prt_in%hel
prt_out%pol = prt_in%pol
prt_out%p = prt_in%p
prt_out%p2 = prt_in%p2
if (allocated (prt_in%vertex)) &
allocate (prt_out%vertex, source=prt_in%vertex)
if (allocated (prt_in%lifetime)) &
allocate (prt_out%lifetime, source=prt_in%lifetime)
end subroutine particle_init_particle
@ %def particle_init_particle
@ Initialize a particle using external information.
<<Particles: particle: TBP>>=
generic :: init => init_external
procedure :: init_external => particle_init_external
<<Particles: sub interfaces>>=
module subroutine particle_init_external &
(particle, status, pdg, model, col, anti_col, mom)
class(particle_t), intent(out) :: particle
integer, intent(in) :: status, pdg, col, anti_col
class(model_data_t), pointer, intent(in) :: model
type(vector4_t), intent(in) :: mom
end subroutine particle_init_external
<<Particles: procedures>>=
module subroutine particle_init_external &
(particle, status, pdg, model, col, anti_col, mom)
class(particle_t), intent(out) :: particle
integer, intent(in) :: status, pdg, col, anti_col
class(model_data_t), pointer, intent(in) :: model
type(vector4_t), intent(in) :: mom
type(flavor_t) :: flavor
type(color_t) :: color
call flavor%init (pdg, model)
call particle%set_flavor (flavor)
call color%init_col_acl (col, anti_col)
call particle%set_color (color)
call particle%set_status (status)
call particle%set_momentum (mom)
end subroutine particle_init_external
@ %def particle_init_external
@ Initialize a particle using a single-particle state matrix which
determines flavor, color, and polarization. The state matrix must
have unique flavor and color. The factorization mode determines
whether the particle is unpolarized, has definite helicity, or generic
polarization. This mode is translated into the polarization status.
<<Particles: particle: TBP>>=
generic :: init => init_state
procedure :: init_state => particle_init_state
<<Particles: sub interfaces>>=
module subroutine particle_init_state (prt, state, status, mode)
class(particle_t), intent(out) :: prt
type(state_matrix_t), intent(in), target :: state
integer, intent(in) :: status, mode
end subroutine particle_init_state
<<Particles: procedures>>=
module subroutine particle_init_state (prt, state, status, mode)
class(particle_t), intent(out) :: prt
type(state_matrix_t), intent(in), target :: state
integer, intent(in) :: status, mode
type(state_iterator_t) :: it
prt%status = status
call it%init (state)
prt%flv = it%get_flavor (1)
if (prt%flv%is_radiated ()) prt%status = PRT_BEAM_REMNANT
prt%col = it%get_color (1)
select case (mode)
case (FM_SELECT_HELICITY)
prt%hel = it%get_helicity (1)
if (prt%hel%is_defined ()) then
prt%polarization = PRT_DEFINITE_HELICITY
end if
case (FM_FACTOR_HELICITY)
call prt%pol%init_state_matrix (state)
prt%polarization = PRT_GENERIC_POLARIZATION
end select
end subroutine particle_init_state
@ %def particle_init_state
@ Finalizer.
<<Particles: particle: TBP>>=
procedure :: final => particle_final
<<Particles: sub interfaces>>=
module subroutine particle_final (prt)
class(particle_t), intent(inout) :: prt
end subroutine particle_final
<<Particles: procedures>>=
module subroutine particle_final (prt)
class(particle_t), intent(inout) :: prt
if (allocated (prt%vertex)) deallocate (prt%vertex)
if (allocated (prt%lifetime)) deallocate (prt%lifetime)
end subroutine particle_final
@ %def particle_final
@
\subsubsection{I/O}
<<Particles: particle: TBP>>=
procedure :: write => particle_write
<<Particles: sub interfaces>>=
module subroutine particle_write (prt, unit, testflag, compressed, polarization)
class(particle_t), intent(in) :: prt
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag, compressed, polarization
end subroutine particle_write
<<Particles: procedures>>=
module subroutine particle_write (prt, unit, testflag, compressed, polarization)
class(particle_t), intent(in) :: prt
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag, compressed, polarization
logical :: comp, pacified, pol
integer :: u, h1, h2
real(default) :: pp2
character(len=7) :: fmt
character(len=20) :: buffer
comp = .false.; if (present (compressed)) comp = compressed
pacified = .false.; if (present (testflag)) pacified = testflag
pol = .true.; if (present (polarization)) pol = polarization
call pac_fmt (fmt, FMT_19, FMT_16, testflag)
u = given_output_unit (unit); if (u < 0) return
pp2 = prt%p2
if (pacified) call pacify (pp2, tolerance = 1E-10_default)
select case (prt%status)
case (PRT_UNDEFINED); write (u, "(1x, A)", advance="no") "[-]"
case (PRT_BEAM); write (u, "(1x, A)", advance="no") "[b]"
case (PRT_INCOMING); write (u, "(1x, A)", advance="no") "[i]"
case (PRT_OUTGOING); write (u, "(1x, A)", advance="no") "[o]"
case (PRT_VIRTUAL); write (u, "(1x, A)", advance="no") "[v]"
case (PRT_RESONANT); write (u, "(1x, A)", advance="no") "[r]"
case (PRT_BEAM_REMNANT); write (u, "(1x, A)", advance="no") "[x]"
end select
write (u, "(1x)", advance="no")
if (comp) then
write (u, "(A7,1X)", advance="no") char (prt%flv%get_name ())
if (pol) then
select case (prt%polarization)
case (PRT_DEFINITE_HELICITY)
! Integer helicity, assumed diagonal
call prt%hel%get_indices (h1, h2)
write (u, "(I2,1X)", advance="no") h1
case (PRT_GENERIC_POLARIZATION)
! No space for full density matrix here
write (u, "(A2,1X)", advance="no") "*"
case default
! Blank entry if helicity is undefined
write (u, "(A2,1X)", advance="no") " "
end select
end if
write (u, "(2(I4,1X))", advance="no") &
prt%col%get_col (), prt%col%get_acl ()
call write_compressed_integer_array (buffer, prt%parent)
write (u, "(A,1X)", advance="no") buffer
call write_compressed_integer_array (buffer, prt%child)
write (u, "(A,1X)", advance="no") buffer
call prt%p%write(u, testflag = testflag, compressed = comp)
write (u, "(F12.3)") pp2
else
call prt%flv%write (unit)
if (prt%col%is_nonzero ()) then
call color_write (prt%col, unit)
end if
if (pol) then
select case (prt%polarization)
case (PRT_DEFINITE_HELICITY)
call prt%hel%write (unit)
write (u, *)
case (PRT_GENERIC_POLARIZATION)
write (u, *)
call prt%pol%write (unit, state_matrix = .true.)
case default
write (u, *)
end select
else
write (u, *)
end if
call prt%p%write (unit, testflag = testflag)
write (u, "(1x,A,1x," // fmt // ")") "T = ", pp2
if (allocated (prt%parent)) then
if (size (prt%parent) /= 0) then
write (u, "(1x,A,40(1x,I0))") "Parents: ", prt%parent
end if
end if
if (allocated (prt%child)) then
if (size (prt%child) /= 0) then
write (u, "(1x,A,40(1x,I0))") "Children:", prt%child
end if
end if
if (allocated (prt%vertex)) then
write (u, "(1x,A,1x," // fmt // ")") "Vtx t = ", prt%vertex%p(0)
write (u, "(1x,A,1x," // fmt // ")") "Vtx x = ", prt%vertex%p(1)
write (u, "(1x,A,1x," // fmt // ")") "Vtx y = ", prt%vertex%p(2)
write (u, "(1x,A,1x," // fmt // ")") "Vtx z = ", prt%vertex%p(3)
end if
if (allocated (prt%lifetime)) then
write (u, "(1x,A,1x," // fmt // ")") "Lifetime = ", &
prt%lifetime
end if
end if
end subroutine particle_write
@ %def particle_write
@ Binary I/O:
<<Particles: particle: TBP>>=
procedure :: write_raw => particle_write_raw
procedure :: read_raw => particle_read_raw
<<Particles: sub interfaces>>=
module subroutine particle_write_raw (prt, u)
class(particle_t), intent(in) :: prt
integer, intent(in) :: u
end subroutine particle_write_raw
module subroutine particle_read_raw (prt, u, iostat)
class(particle_t), intent(out) :: prt
integer, intent(in) :: u
integer, intent(out) :: iostat
end subroutine particle_read_raw
<<Particles: procedures>>=
module subroutine particle_write_raw (prt, u)
class(particle_t), intent(in) :: prt
integer, intent(in) :: u
write (u) prt%status, prt%polarization
call prt%flv%write_raw (u)
call prt%col%write_raw (u)
select case (prt%polarization)
case (PRT_DEFINITE_HELICITY)
call prt%hel%write_raw (u)
case (PRT_GENERIC_POLARIZATION)
call prt%pol%write_raw (u)
end select
call vector4_write_raw (prt%p, u)
write (u) prt%p2
write (u) allocated (prt%parent)
if (allocated (prt%parent)) then
write (u) size (prt%parent)
write (u) prt%parent
end if
write (u) allocated (prt%child)
if (allocated (prt%child)) then
write (u) size (prt%child)
write (u) prt%child
end if
write (u) allocated (prt%vertex)
if (allocated (prt%vertex)) then
call vector4_write_raw (prt%vertex, u)
end if
write (u) allocated (prt%lifetime)
if (allocated (prt%lifetime)) then
write (u) prt%lifetime
end if
end subroutine particle_write_raw
module subroutine particle_read_raw (prt, u, iostat)
class(particle_t), intent(out) :: prt
integer, intent(in) :: u
integer, intent(out) :: iostat
logical :: allocated_parent, allocated_child
logical :: allocated_vertex, allocated_lifetime
integer :: size_parent, size_child
read (u, iostat=iostat) prt%status, prt%polarization
call prt%flv%read_raw (u, iostat=iostat)
call prt%col%read_raw (u, iostat=iostat)
select case (prt%polarization)
case (PRT_DEFINITE_HELICITY)
call prt%hel%read_raw (u, iostat=iostat)
case (PRT_GENERIC_POLARIZATION)
call prt%pol%read_raw (u, iostat=iostat)
end select
call vector4_read_raw (prt%p, u, iostat=iostat)
read (u, iostat=iostat) prt%p2
read (u, iostat=iostat) allocated_parent
if (allocated_parent) then
read (u, iostat=iostat) size_parent
allocate (prt%parent (size_parent))
read (u, iostat=iostat) prt%parent
end if
read (u, iostat=iostat) allocated_child
if (allocated_child) then
read (u, iostat=iostat) size_child
allocate (prt%child (size_child))
read (u, iostat=iostat) prt%child
end if
read (u, iostat=iostat) allocated_vertex
if (allocated_vertex) then
allocate (prt%vertex)
read (u, iostat=iostat) prt%vertex%p
end if
read (u, iostat=iostat) allocated_lifetime
if (allocated_lifetime) then
allocate (prt%lifetime)
read (u, iostat=iostat) prt%lifetime
end if
end subroutine particle_read_raw
@ %def particle_write_raw particle_read_raw
@
\subsubsection{Setting contents}
Reset the status code. Where applicable, set $p^2$ assuming that the
particle is on-shell.
<<Particles: particle: TBP>>=
procedure :: reset_status => particle_reset_status
<<Particles: sub interfaces>>=
elemental module subroutine particle_reset_status (prt, status)
class(particle_t), intent(inout) :: prt
integer, intent(in) :: status
end subroutine particle_reset_status
<<Particles: procedures>>=
elemental module subroutine particle_reset_status (prt, status)
class(particle_t), intent(inout) :: prt
integer, intent(in) :: status
prt%status = status
select case (status)
case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING)
prt%p2 = prt%flv%get_mass () ** 2
end select
end subroutine particle_reset_status
@ %def particle_reset_status
@ The color can be given explicitly.
<<Particles: particle: TBP>>=
procedure :: set_color => particle_set_color
<<Particles: sub interfaces>>=
elemental module subroutine particle_set_color (prt, col)
class(particle_t), intent(inout) :: prt
type(color_t), intent(in) :: col
end subroutine particle_set_color
<<Particles: procedures>>=
elemental module subroutine particle_set_color (prt, col)
class(particle_t), intent(inout) :: prt
type(color_t), intent(in) :: col
prt%col = col
end subroutine particle_set_color
@ %def particle_set_color
@ The flavor can be given explicitly.
<<Particles: particle: TBP>>=
procedure :: set_flavor => particle_set_flavor
<<Particles: sub interfaces>>=
module subroutine particle_set_flavor (prt, flv)
class(particle_t), intent(inout) :: prt
type(flavor_t), intent(in) :: flv
end subroutine particle_set_flavor
<<Particles: procedures>>=
module subroutine particle_set_flavor (prt, flv)
class(particle_t), intent(inout) :: prt
type(flavor_t), intent(in) :: flv
prt%flv = flv
end subroutine particle_set_flavor
@ %def particle_set_flavor
@ As can the helicity.
<<Particles: particle: TBP>>=
procedure :: set_helicity => particle_set_helicity
<<Particles: sub interfaces>>=
module subroutine particle_set_helicity (prt, hel)
class(particle_t), intent(inout) :: prt
type(helicity_t), intent(in) :: hel
end subroutine particle_set_helicity
<<Particles: procedures>>=
module subroutine particle_set_helicity (prt, hel)
class(particle_t), intent(inout) :: prt
type(helicity_t), intent(in) :: hel
prt%hel = hel
end subroutine particle_set_helicity
@ %def particle_set_helicity
@ And the polarization.
<<Particles: particle: TBP>>=
procedure :: set_pol => particle_set_pol
<<Particles: sub interfaces>>=
module subroutine particle_set_pol (prt, pol)
class(particle_t), intent(inout) :: prt
type(polarization_t), intent(in) :: pol
end subroutine particle_set_pol
<<Particles: procedures>>=
module subroutine particle_set_pol (prt, pol)
class(particle_t), intent(inout) :: prt
type(polarization_t), intent(in) :: pol
prt%pol = pol
end subroutine particle_set_pol
@ %def particle_set_pol
@ Manually set the model for the particle flavor. This is required, e.g., if
the particle has been read from file.
<<Particles: particle: TBP>>=
procedure :: set_model => particle_set_model
<<Particles: sub interfaces>>=
module subroutine particle_set_model (prt, model)
class(particle_t), intent(inout) :: prt
class(model_data_t), intent(in), target :: model
end subroutine particle_set_model
<<Particles: procedures>>=
module subroutine particle_set_model (prt, model)
class(particle_t), intent(inout) :: prt
class(model_data_t), intent(in), target :: model
call prt%flv%set_model (model)
end subroutine particle_set_model
@ %def particle_set_model
@ The momentum is set independent of the quantum numbers.
<<Particles: particle: TBP>>=
procedure :: set_momentum => particle_set_momentum
<<Particles: sub interfaces>>=
elemental module subroutine particle_set_momentum (prt, p, p2, on_shell)
class(particle_t), intent(inout) :: prt
type(vector4_t), intent(in) :: p
real(default), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
end subroutine particle_set_momentum
<<Particles: procedures>>=
elemental module subroutine particle_set_momentum (prt, p, p2, on_shell)
class(particle_t), intent(inout) :: prt
type(vector4_t), intent(in) :: p
real(default), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
prt%p = p
if (present (on_shell)) then
if (on_shell) then
if (prt%flv%is_associated ()) then
prt%p2 = prt%flv%get_mass () ** 2
return
end if
end if
end if
if (present (p2)) then
prt%p2 = p2
else
prt%p2 = p ** 2
end if
end subroutine particle_set_momentum
@ %def particle_set_momentum
@ Set resonance information. This should be done after momentum
assignment, because we need to know wheter the particle is spacelike
or timelike. The resonance flag is defined only for virtual
particles.
<<Particles: particle: TBP>>=
procedure :: set_resonance_flag => particle_set_resonance_flag
<<Particles: sub interfaces>>=
elemental module subroutine particle_set_resonance_flag (prt, resonant)
class(particle_t), intent(inout) :: prt
logical, intent(in) :: resonant
end subroutine particle_set_resonance_flag
<<Particles: procedures>>=
elemental module subroutine particle_set_resonance_flag (prt, resonant)
class(particle_t), intent(inout) :: prt
logical, intent(in) :: resonant
select case (prt%status)
case (PRT_VIRTUAL)
if (resonant) prt%status = PRT_RESONANT
end select
end subroutine particle_set_resonance_flag
@ %def particle_set_resonance_flag
@ Set children and parents information.
<<Particles: particle: TBP>>=
procedure :: set_children => particle_set_children
procedure :: set_parents => particle_set_parents
<<Particles: sub interfaces>>=
module subroutine particle_set_children (prt, idx)
class(particle_t), intent(inout) :: prt
integer, dimension(:), intent(in) :: idx
end subroutine particle_set_children
module subroutine particle_set_parents (prt, idx)
class(particle_t), intent(inout) :: prt
integer, dimension(:), intent(in) :: idx
end subroutine particle_set_parents
<<Particles: procedures>>=
module subroutine particle_set_children (prt, idx)
class(particle_t), intent(inout) :: prt
integer, dimension(:), intent(in) :: idx
if (allocated (prt%child)) deallocate (prt%child)
allocate (prt%child (count (idx /= 0)))
prt%child = pack (idx, idx /= 0)
end subroutine particle_set_children
module subroutine particle_set_parents (prt, idx)
class(particle_t), intent(inout) :: prt
integer, dimension(:), intent(in) :: idx
if (allocated (prt%parent)) deallocate (prt%parent)
allocate (prt%parent (count (idx /= 0)))
prt%parent = pack (idx, idx /= 0)
end subroutine particle_set_parents
@ %def particle_set_children particle_set_parents
@
<<Particles: particle: TBP>>=
procedure :: add_child => particle_add_child
<<Particles: sub interfaces>>=
module subroutine particle_add_child (prt, new_child)
class(particle_t), intent(inout) :: prt
integer, intent(in) :: new_child
end subroutine particle_add_child
<<Particles: procedures>>=
module subroutine particle_add_child (prt, new_child)
class(particle_t), intent(inout) :: prt
integer, intent(in) :: new_child
integer, dimension(:), allocatable :: idx
integer :: n, i
n = prt%get_n_children()
if (n == 0) then
call prt%set_children ([new_child])
else
do i = 1, n
if (prt%child(i) == new_child) then
return
end if
end do
allocate (idx (1:n+1))
idx(1:n) = prt%get_children ()
idx(n+1) = new_child
call prt%set_children (idx)
end if
end subroutine particle_add_child
@ %def particle_add_child
@
<<Particles: particle: TBP>>=
procedure :: add_children => particle_add_children
<<Particles: sub interfaces>>=
module subroutine particle_add_children (prt, new_child)
class(particle_t), intent(inout) :: prt
integer, dimension(:), intent(in) :: new_child
end subroutine particle_add_children
<<Particles: procedures>>=
module subroutine particle_add_children (prt, new_child)
class(particle_t), intent(inout) :: prt
integer, dimension(:), intent(in) :: new_child
integer, dimension(:), allocatable :: idx
integer :: n
n = prt%get_n_children()
if (n == 0) then
call prt%set_children (new_child)
else
allocate (idx (1:n+size(new_child)))
idx(1:n) = prt%get_children ()
idx(n+1:n+size(new_child)) = new_child
call prt%set_children (idx)
end if
end subroutine particle_add_children
@ %def particle_add_children
@
<<Particles: particle: TBP>>=
procedure :: set_status => particle_set_status
<<Particles: sub interfaces>>=
elemental module subroutine particle_set_status (prt, status)
class(particle_t), intent(inout) :: prt
integer, intent(in) :: status
end subroutine particle_set_status
<<Particles: procedures>>=
elemental module subroutine particle_set_status (prt, status)
class(particle_t), intent(inout) :: prt
integer, intent(in) :: status
prt%status = status
end subroutine particle_set_status
@ %def particle_set_status
@
<<Particles: particle: TBP>>=
procedure :: set_polarization => particle_set_polarization
<<Particles: sub interfaces>>=
module subroutine particle_set_polarization (prt, polarization)
class(particle_t), intent(inout) :: prt
integer, intent(in) :: polarization
end subroutine particle_set_polarization
<<Particles: procedures>>=
module subroutine particle_set_polarization (prt, polarization)
class(particle_t), intent(inout) :: prt
integer, intent(in) :: polarization
prt%polarization = polarization
end subroutine particle_set_polarization
@ %def particle_set_polarization
@
<<Particles: particle: TBP>>=
generic :: set_vertex => set_vertex_from_vector3, set_vertex_from_xyz, &
set_vertex_from_vector4, set_vertex_from_xyzt
procedure :: set_vertex_from_vector4 => particle_set_vertex_from_vector4
procedure :: set_vertex_from_vector3 => particle_set_vertex_from_vector3
procedure :: set_vertex_from_xyzt => particle_set_vertex_from_xyzt
procedure :: set_vertex_from_xyz => particle_set_vertex_from_xyz
<<Particles: sub interfaces>>=
module subroutine particle_set_vertex_from_vector4 (prt, vertex)
class(particle_t), intent(inout) :: prt
type(vector4_t), intent(in) :: vertex
end subroutine particle_set_vertex_from_vector4
module subroutine particle_set_vertex_from_vector3 (prt, vertex)
class(particle_t), intent(inout) :: prt
type(vector3_t), intent(in) :: vertex
end subroutine particle_set_vertex_from_vector3
module subroutine particle_set_vertex_from_xyzt (prt, vx, vy, vz, t)
class(particle_t), intent(inout) :: prt
real(default), intent(in) :: vx, vy, vz, t
end subroutine particle_set_vertex_from_xyzt
module subroutine particle_set_vertex_from_xyz (prt, vx, vy, vz)
class(particle_t), intent(inout) :: prt
real(default), intent(in) :: vx, vy, vz
end subroutine particle_set_vertex_from_xyz
<<Particles: procedures>>=
module subroutine particle_set_vertex_from_vector4 (prt, vertex)
class(particle_t), intent(inout) :: prt
type(vector4_t), intent(in) :: vertex
if (allocated (prt%vertex)) deallocate (prt%vertex)
allocate (prt%vertex, source=vertex)
end subroutine particle_set_vertex_from_vector4
module subroutine particle_set_vertex_from_vector3 (prt, vertex)
class(particle_t), intent(inout) :: prt
type(vector3_t), intent(in) :: vertex
type(vector4_t) :: vtx
vtx = vector4_moving (0._default, vertex)
if (allocated (prt%vertex)) deallocate (prt%vertex)
allocate (prt%vertex, source=vtx)
end subroutine particle_set_vertex_from_vector3
module subroutine particle_set_vertex_from_xyzt (prt, vx, vy, vz, t)
class(particle_t), intent(inout) :: prt
real(default), intent(in) :: vx, vy, vz, t
type(vector4_t) :: vertex
if (allocated (prt%vertex)) deallocate (prt%vertex)
vertex = vector4_moving (t, vector3_moving ([vx, vy, vz]))
allocate (prt%vertex, source=vertex)
end subroutine particle_set_vertex_from_xyzt
module subroutine particle_set_vertex_from_xyz (prt, vx, vy, vz)
class(particle_t), intent(inout) :: prt
real(default), intent(in) :: vx, vy, vz
type(vector4_t) :: vertex
if (allocated (prt%vertex)) deallocate (prt%vertex)
vertex = vector4_moving (0._default, vector3_moving ([vx, vy, vz]))
allocate (prt%vertex, source=vertex)
end subroutine particle_set_vertex_from_xyz
@ %def particle_set_vertex_from_vector3
@ %def particle_set_vertex_from_vector4
@ %def particle_set_vertex_from_xyz
@ %def particle_set_vertex_from_xyzt
@ Set the lifetime of a particle.
<<Particles: particle: TBP>>=
procedure :: set_lifetime => particle_set_lifetime
<<Particles: sub interfaces>>=
elemental module subroutine particle_set_lifetime (prt, lifetime)
class(particle_t), intent(inout) :: prt
real(default), intent(in) :: lifetime
end subroutine particle_set_lifetime
<<Particles: procedures>>=
elemental module subroutine particle_set_lifetime (prt, lifetime)
class(particle_t), intent(inout) :: prt
real(default), intent(in) :: lifetime
if (allocated (prt%lifetime)) deallocate (prt%lifetime)
allocate (prt%lifetime, source=lifetime)
end subroutine particle_set_lifetime
@ %def particle_set_lifetime
@
\subsubsection{Accessing contents}
The status code.
<<Particles: particle: TBP>>=
procedure :: get_status => particle_get_status
<<Particles: sub interfaces>>=
elemental module function particle_get_status (prt) result (status)
integer :: status
class(particle_t), intent(in) :: prt
end function particle_get_status
<<Particles: procedures>>=
elemental module function particle_get_status (prt) result (status)
integer :: status
class(particle_t), intent(in) :: prt
status = prt%status
end function particle_get_status
@ %def particle_get_status
@ Return true if the status is either [[INCOMING]],
[[OUTGOING]] or [[RESONANT]]. [[BEAM]] is kept, if
[[keep_beams]] is set true.
<<Particles: particle: TBP>>=
procedure :: is_real => particle_is_real
<<Particles: sub interfaces>>=
elemental module function particle_is_real (prt, keep_beams) result (flag)
logical :: flag, kb
class(particle_t), intent(in) :: prt
logical, intent(in), optional :: keep_beams
end function particle_is_real
<<Particles: procedures>>=
elemental module function particle_is_real (prt, keep_beams) result (flag)
logical :: flag, kb
class(particle_t), intent(in) :: prt
logical, intent(in), optional :: keep_beams
kb = .false.
if (present (keep_beams)) kb = keep_beams
select case (prt%status)
case (PRT_INCOMING, PRT_OUTGOING, PRT_RESONANT)
flag = .true.
case (PRT_BEAM)
flag = kb
case default
flag = .false.
end select
end function particle_is_real
@ %def particle_is_real
@
<<Particles: particle: TBP>>=
procedure :: is_colored => particle_is_colored
<<Particles: sub interfaces>>=
elemental module function particle_is_colored (particle) result (flag)
logical :: flag
class(particle_t), intent(in) :: particle
end function particle_is_colored
<<Particles: procedures>>=
elemental module function particle_is_colored (particle) result (flag)
logical :: flag
class(particle_t), intent(in) :: particle
flag = particle%col%is_nonzero ()
end function particle_is_colored
@ %def particle_is_colored
@ $[90,100]$ hopefully catches all of them and not too many.
<<Particles: particle: TBP>>=
procedure :: is_hadronic_beam_remnant => particle_is_hadronic_beam_remnant
<<Particles: sub interfaces>>=
elemental module function particle_is_hadronic_beam_remnant (particle) result (flag)
class(particle_t), intent(in) :: particle
logical :: flag
end function particle_is_hadronic_beam_remnant
<<Particles: procedures>>=
elemental module function particle_is_hadronic_beam_remnant (particle) result (flag)
class(particle_t), intent(in) :: particle
logical :: flag
integer :: pdg
pdg = particle%flv%get_pdg ()
flag = particle%status == PRT_BEAM_REMNANT .and. &
abs(pdg) >= 90 .and. abs(pdg) <= 100
end function particle_is_hadronic_beam_remnant
@ %def particle_is_hadronic_beam_remnant
@
<<Particles: particle: TBP>>=
procedure :: is_beam_remnant => particle_is_beam_remnant
<<Particles: sub interfaces>>=
elemental module function particle_is_beam_remnant (particle) result (flag)
class(particle_t), intent(in) :: particle
logical :: flag
end function particle_is_beam_remnant
<<Particles: procedures>>=
elemental module function particle_is_beam_remnant (particle) result (flag)
class(particle_t), intent(in) :: particle
logical :: flag
flag = particle%status == PRT_BEAM_REMNANT
end function particle_is_beam_remnant
@ %def particle_is_beam_remnant
@ Polarization status.
<<Particles: particle: TBP>>=
procedure :: get_polarization_status => particle_get_polarization_status
<<Particles: sub interfaces>>=
elemental module function particle_get_polarization_status (prt) result (status)
integer :: status
class(particle_t), intent(in) :: prt
end function particle_get_polarization_status
<<Particles: procedures>>=
elemental module function particle_get_polarization_status (prt) result (status)
integer :: status
class(particle_t), intent(in) :: prt
status = prt%polarization
end function particle_get_polarization_status
@ %def particle_get_polarization_status
@ Return the PDG code from the flavor component directly.
<<Particles: particle: TBP>>=
procedure :: get_pdg => particle_get_pdg
<<Particles: sub interfaces>>=
elemental module function particle_get_pdg (prt) result (pdg)
integer :: pdg
class(particle_t), intent(in) :: prt
end function particle_get_pdg
<<Particles: procedures>>=
elemental module function particle_get_pdg (prt) result (pdg)
integer :: pdg
class(particle_t), intent(in) :: prt
pdg = prt%flv%get_pdg ()
end function particle_get_pdg
@ %def particle_get_pdg
@ Return the color and anticolor quantum numbers.
<<Particles: particle: TBP>>=
procedure :: get_color => particle_get_color
<<Particles: sub interfaces>>=
pure module function particle_get_color (prt) result (col)
integer, dimension(2) :: col
class(particle_t), intent(in) :: prt
end function particle_get_color
<<Particles: procedures>>=
pure module function particle_get_color (prt) result (col)
integer, dimension(2) :: col
class(particle_t), intent(in) :: prt
col(1) = prt%col%get_col ()
col(2) = prt%col%get_acl ()
end function particle_get_color
@ %def particle_get_color
@ Return a copy of the polarization density matrix.
<<Particles: particle: TBP>>=
procedure :: get_polarization => particle_get_polarization
<<Particles: sub interfaces>>=
module function particle_get_polarization (prt) result (pol)
class(particle_t), intent(in) :: prt
type(polarization_t) :: pol
end function particle_get_polarization
<<Particles: procedures>>=
module function particle_get_polarization (prt) result (pol)
class(particle_t), intent(in) :: prt
type(polarization_t) :: pol
pol = prt%pol
end function particle_get_polarization
@ %def particle_get_polarization
@ Return the flavor, color and helicity.
<<Particles: particle: TBP>>=
procedure :: get_flv => particle_get_flv
procedure :: get_col => particle_get_col
procedure :: get_hel => particle_get_hel
<<Particles: sub interfaces>>=
module function particle_get_flv (prt) result (flv)
class(particle_t), intent(in) :: prt
type(flavor_t) :: flv
end function particle_get_flv
module function particle_get_col (prt) result (col)
class(particle_t), intent(in) :: prt
type(color_t) :: col
end function particle_get_col
module function particle_get_hel (prt) result (hel)
class(particle_t), intent(in) :: prt
type(helicity_t) :: hel
end function particle_get_hel
<<Particles: procedures>>=
module function particle_get_flv (prt) result (flv)
class(particle_t), intent(in) :: prt
type(flavor_t) :: flv
flv = prt%flv
end function particle_get_flv
module function particle_get_col (prt) result (col)
class(particle_t), intent(in) :: prt
type(color_t) :: col
col = prt%col
end function particle_get_col
module function particle_get_hel (prt) result (hel)
class(particle_t), intent(in) :: prt
type(helicity_t) :: hel
hel = prt%hel
end function particle_get_hel
@ %def particle_get_flv particle_get_col particle_get_hel
@ Return the helicity (if defined and diagonal).
<<Particles: particle: TBP>>=
procedure :: get_helicity => particle_get_helicity
<<Particles: sub interfaces>>=
elemental module function particle_get_helicity (prt) result (hel)
integer :: hel
class(particle_t), intent(in) :: prt
end function particle_get_helicity
<<Particles: procedures>>=
elemental module function particle_get_helicity (prt) result (hel)
integer :: hel
integer, dimension(2) :: hel_arr
class(particle_t), intent(in) :: prt
hel = 0
if (prt%hel%is_defined () .and. prt%hel%is_diagonal ()) then
hel_arr = prt%hel%to_pair ()
hel = hel_arr (1)
end if
end function particle_get_helicity
@ %def particle_get_helicity
@ Return the number of children/parents
<<Particles: particle: TBP>>=
procedure :: get_n_parents => particle_get_n_parents
procedure :: get_n_children => particle_get_n_children
<<Particles: sub interfaces>>=
elemental module function particle_get_n_parents (prt) result (n)
integer :: n
class(particle_t), intent(in) :: prt
end function particle_get_n_parents
elemental module function particle_get_n_children (prt) result (n)
integer :: n
class(particle_t), intent(in) :: prt
end function particle_get_n_children
<<Particles: procedures>>=
elemental module function particle_get_n_parents (prt) result (n)
integer :: n
class(particle_t), intent(in) :: prt
if (allocated (prt%parent)) then
n = size (prt%parent)
else
n = 0
end if
end function particle_get_n_parents
elemental module function particle_get_n_children (prt) result (n)
integer :: n
class(particle_t), intent(in) :: prt
if (allocated (prt%child)) then
n = size (prt%child)
else
n = 0
end if
end function particle_get_n_children
@ %def particle_get_n_parents particle_get_n_children
@ Return the array of parents/children.
<<Particles: particle: TBP>>=
procedure :: get_parents => particle_get_parents
procedure :: get_children => particle_get_children
<<Particles: sub interfaces>>=
module function particle_get_parents (prt) result (parent)
class(particle_t), intent(in) :: prt
integer, dimension(:), allocatable :: parent
end function particle_get_parents
module function particle_get_children (prt) result (child)
class(particle_t), intent(in) :: prt
integer, dimension(:), allocatable :: child
end function particle_get_children
<<Particles: procedures>>=
module function particle_get_parents (prt) result (parent)
class(particle_t), intent(in) :: prt
integer, dimension(:), allocatable :: parent
if (allocated (prt%parent)) then
allocate (parent (size (prt%parent)))
parent = prt%parent
else
allocate (parent (0))
end if
end function particle_get_parents
module function particle_get_children (prt) result (child)
class(particle_t), intent(in) :: prt
integer, dimension(:), allocatable :: child
if (allocated (prt%child)) then
allocate (child (size (prt%child)))
child = prt%child
else
allocate (child (0))
end if
end function particle_get_children
@ %def particle_get_children
@
<<Particles: particle: TBP>>=
procedure :: has_children => particle_has_children
<<Particles: sub interfaces>>=
elemental module function particle_has_children (prt) result (has_children)
logical :: has_children
class(particle_t), intent(in) :: prt
end function particle_has_children
<<Particles: procedures>>=
elemental module function particle_has_children (prt) result (has_children)
logical :: has_children
class(particle_t), intent(in) :: prt
has_children = .false.
if (allocated (prt%child)) then
has_children = size (prt%child) > 0
end if
end function particle_has_children
@ %def particle_has_children
@
<<Particles: particle: TBP>>=
procedure :: has_parents => particle_has_parents
<<Particles: sub interfaces>>=
elemental module function particle_has_parents (prt) result (has_parents)
logical :: has_parents
class(particle_t), intent(in) :: prt
end function particle_has_parents
<<Particles: procedures>>=
elemental module function particle_has_parents (prt) result (has_parents)
logical :: has_parents
class(particle_t), intent(in) :: prt
has_parents = .false.
if (allocated (prt%parent)) then
has_parents = size (prt%parent) > 0
end if
end function particle_has_parents
@ %def particle_has_parents
@ Return momentum and momentum squared.
<<Particles: particle: TBP>>=
procedure :: get_momentum => particle_get_momentum
procedure :: get_p2 => particle_get_p2
<<Particles: sub interfaces>>=
elemental module function particle_get_momentum (prt) result (p)
type(vector4_t) :: p
class(particle_t), intent(in) :: prt
end function particle_get_momentum
elemental module function particle_get_p2 (prt) result (p2)
real(default) :: p2
class(particle_t), intent(in) :: prt
end function particle_get_p2
<<Particles: procedures>>=
elemental module function particle_get_momentum (prt) result (p)
type(vector4_t) :: p
class(particle_t), intent(in) :: prt
p = prt%p
end function particle_get_momentum
elemental module function particle_get_p2 (prt) result (p2)
real(default) :: p2
class(particle_t), intent(in) :: prt
p2 = prt%p2
end function particle_get_p2
@ %def particle_get_momentum particle_get_p2
@ Return the particle vertex, if allocated.
<<Particles: particle: TBP>>=
procedure :: get_vertex => particle_get_vertex
<<Particles: sub interfaces>>=
elemental module function particle_get_vertex (prt) result (vtx)
type(vector4_t) :: vtx
class(particle_t), intent(in) :: prt
end function particle_get_vertex
<<Particles: procedures>>=
elemental module function particle_get_vertex (prt) result (vtx)
type(vector4_t) :: vtx
class(particle_t), intent(in) :: prt
if (allocated (prt%vertex)) then
vtx = prt%vertex
else
vtx = vector4_null
end if
end function particle_get_vertex
@ %def particle_get_vertex
@ Return the lifetime of a particle.
<<Particles: particle: TBP>>=
procedure :: get_lifetime => particle_get_lifetime
<<Particles: sub interfaces>>=
elemental module function particle_get_lifetime (prt) result (lifetime)
real(default) :: lifetime
class(particle_t), intent(in) :: prt
end function particle_get_lifetime
<<Particles: procedures>>=
elemental module function particle_get_lifetime (prt) result (lifetime)
real(default) :: lifetime
class(particle_t), intent(in) :: prt
if (allocated (prt%lifetime)) then
lifetime = prt%lifetime
else
lifetime = 0
end if
end function particle_get_lifetime
@ %def particle_get_lifetime
@
<<Particles: particle: TBP>>=
procedure :: momentum_to_pythia6 => particle_momentum_to_pythia6
<<Particles: sub interfaces>>=
pure module function particle_momentum_to_pythia6 (prt) result (p)
real(double), dimension(1:5) :: p
class(particle_t), intent(in) :: prt
end function particle_momentum_to_pythia6
<<Particles: procedures>>=
pure module function particle_momentum_to_pythia6 (prt) result (p)
real(double), dimension(1:5) :: p
class(particle_t), intent(in) :: prt
p = prt%p%to_pythia6 (sqrt (prt%p2))
end function particle_momentum_to_pythia6
@ %def particle_momentum_to_pythia6
@
\subsection{Particle sets}
A particle set is what is usually called an event: an array of
particles. The individual particle entries carry momentum, quantum
numbers, polarization, and optionally connections. There is (also
optionally) a correlated state-density matrix that maintains spin
correlations that are lost in the individual particle entries.
<<Particles: public>>=
public :: particle_set_t
<<Particles: types>>=
type :: particle_set_t
! private !!!
integer :: n_beam = 0
integer :: n_in = 0
integer :: n_vir = 0
integer :: n_out = 0
integer :: n_tot = 0
integer :: factorization_mode = FM_IGNORE_HELICITY
type(particle_t), dimension(:), allocatable :: prt
type(state_matrix_t) :: correlated_state
contains
<<Particles: particle set: TBP>>
end type particle_set_t
@ %def particle_set_t
@ A particle set can be initialized from an interaction or from a
HepMC event record.
<<Particles: particle set: TBP>>=
generic :: init => init_interaction
procedure :: init_interaction => particle_set_init_interaction
@ When a particle set is initialized from a given interaction, we have
to determine the branch within the original state matrix that fixes
the particle quantum numbers. This is done with the appropriate
probabilities, based on a random number [[x]]. The [[mode]]
determines whether the individual particles become unpolarized, or
take a definite (diagonal) helicity, or acquire single-particle
polarization matrices. The flag [[keep_correlations]] tells whether
the spin-correlation matrix is to be calculated and stored in addition
to the particles. The flag [[keep_virtual]] tells whether virtual
particles should be dropped. Note that if virtual particles are
dropped, the spin-correlation matrix makes no sense, and parent-child
relations are not set.
For a correct disentangling of color and flavor (in the presence of
helicity), we consider two interactions. [[int]] has no color
information, and is used to select a flavor state. Consequently, we
trace over helicities here. [[int_flows]] contains color-flow and
potentially helicity information, but is useful only after the flavor
combination has been chosen. So this interaction is used to select
helicity and color, but restricted to the selected flavor combination.
[[int]] and [[int_flows]] may be identical if there is only a single
(or no) color flow. If there is just a single flavor combination,
[[x(1)]] can be set to zero.
The current algorithm of evaluator convolution requires that the beam
particles are assumed outgoing (in the beam interaction) and become
virtual in all derived interactions. In the particle set they should
be re-identified as incoming. The optional integer [[n_incoming]]
can be used to perform this correction.
The flag [[is_valid]] is false if factorization of the state is not
possible, in particular if the squared matrix element is zero.
<<Particles: sub interfaces>>=
module subroutine particle_set_init_interaction &
(particle_set, is_valid, int, int_flows, mode, x, &
keep_correlations, keep_virtual, n_incoming, qn_select)
class(particle_set_t), intent(out) :: particle_set
logical, intent(out) :: is_valid
type(interaction_t), intent(in), target :: int, int_flows
integer, intent(in) :: mode
real(default), dimension(2), intent(in) :: x
logical, intent(in) :: keep_correlations, keep_virtual
integer, intent(in), optional :: n_incoming
type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select
end subroutine particle_set_init_interaction
<<Particles: procedures>>=
module subroutine particle_set_init_interaction &
(particle_set, is_valid, int, int_flows, mode, x, &
keep_correlations, keep_virtual, n_incoming, qn_select)
class(particle_set_t), intent(out) :: particle_set
logical, intent(out) :: is_valid
type(interaction_t), intent(in), target :: int, int_flows
integer, intent(in) :: mode
real(default), dimension(2), intent(in) :: x
logical, intent(in) :: keep_correlations, keep_virtual
integer, intent(in), optional :: n_incoming
type(quantum_numbers_t), dimension(:), intent(in), optional :: qn_select
type(state_matrix_t), dimension(:), allocatable, target :: flavor_state
type(state_matrix_t), dimension(:), allocatable, target :: single_state
integer :: n_in, n_vir, n_out, n_tot
type(quantum_numbers_t), dimension(:,:), allocatable :: qn
logical :: ok
integer :: i, j
if (present (n_incoming)) then
n_in = n_incoming
n_vir = int%get_n_vir () - n_incoming
else
n_in = int%get_n_in ()
n_vir = int%get_n_vir ()
end if
n_out = int%get_n_out ()
n_tot = int%get_n_tot ()
particle_set%n_in = n_in
particle_set%n_out = n_out
if (keep_virtual) then
particle_set%n_vir = n_vir
particle_set%n_tot = n_tot
else
particle_set%n_vir = 0
particle_set%n_tot = n_in + n_out
end if
particle_set%factorization_mode = mode
allocate (qn (n_tot, 1))
if (.not. present (qn_select)) then
call int%factorize &
(FM_IGNORE_HELICITY, x(1), is_valid, flavor_state)
do i = 1, n_tot
qn(i,:) = flavor_state(i)%get_quantum_number (1)
end do
else
do i = 1, n_tot
qn(i,:) = qn_select(i)
end do
is_valid = .true.
end if
if (keep_correlations .and. keep_virtual) then
call particle_set%correlated_state%final ()
call int_flows%factorize (mode, x(2), ok, &
single_state, particle_set%correlated_state, qn(:,1))
else
call int_flows%factorize (mode, x(2), ok, &
single_state, qn_in=qn(:,1))
end if
is_valid = is_valid .and. ok
allocate (particle_set%prt (particle_set%n_tot))
j = 1
do i = 1, n_tot
if (i <= n_in) then
call particle_set%prt(j)%init (single_state(i), PRT_INCOMING, mode)
call particle_set%prt(j)%set_momentum (int%get_momentum (i))
else if (i <= n_in + n_vir) then
if (.not. keep_virtual) cycle
call particle_set%prt(j)%init &
(single_state(i), PRT_VIRTUAL, mode)
call particle_set%prt(j)%set_momentum (int%get_momentum (i))
else
call particle_set%prt(j)%init (single_state(i), PRT_OUTGOING, mode)
call particle_set%prt(j)%set_momentum &
(int%get_momentum (i), on_shell = .true.)
end if
if (keep_virtual) then
call particle_set%prt(j)%set_children (int%get_children (i))
call particle_set%prt(j)%set_parents (int%get_parents (i))
end if
j = j + 1
end do
if (keep_virtual) then
call particle_set_resonance_flag &
(particle_set%prt, int%get_resonance_flags ())
end if
if (allocated (flavor_state)) then
do i = 1, size(flavor_state)
call flavor_state(i)%final ()
end do
end if
do i = 1, size(single_state)
call single_state(i)%final ()
end do
end subroutine particle_set_init_interaction
@ %def particle_set_init_interaction
@ Duplicate generic binding, to make sure that assignment works as it should.
<<Particles: particle set: TBP>>=
generic :: assignment(=) => init_particle_set
generic :: init => init_particle_set
procedure :: init_particle_set => particle_set_init_particle_set
<<Particles: sub interfaces>>=
module subroutine particle_set_init_particle_set (pset_out, pset_in)
class(particle_set_t), intent(out) :: pset_out
type(particle_set_t), intent(in) :: pset_in
end subroutine particle_set_init_particle_set
<<Particles: procedures>>=
module subroutine particle_set_init_particle_set (pset_out, pset_in)
class(particle_set_t), intent(out) :: pset_out
type(particle_set_t), intent(in) :: pset_in
integer :: i
pset_out%n_beam = pset_in%n_beam
pset_out%n_in = pset_in%n_in
pset_out%n_vir = pset_in%n_vir
pset_out%n_out = pset_in%n_out
pset_out%n_tot = pset_in%n_tot
pset_out%factorization_mode = pset_in%factorization_mode
if (allocated (pset_in%prt)) then
allocate (pset_out%prt (size (pset_in%prt)))
do i = 1, size (pset_in%prt)
pset_out%prt(i) = pset_in%prt(i)
end do
end if
pset_out%correlated_state = pset_in%correlated_state
end subroutine particle_set_init_particle_set
@ %def particle_set_init_particle_set
@ Manually set the model for the stored particles.
<<Particles: particle set: TBP>>=
procedure :: set_model => particle_set_set_model
<<Particles: sub interfaces>>=
module subroutine particle_set_set_model (particle_set, model)
class(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model
end subroutine particle_set_set_model
<<Particles: procedures>>=
module subroutine particle_set_set_model (particle_set, model)
class(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model
integer :: i
do i = 1, particle_set%n_tot
call particle_set%prt(i)%set_model (model)
end do
call particle_set%correlated_state%set_model (model)
end subroutine particle_set_set_model
@ %def particle_set_set_model
@ Pointer components are hidden inside the particle polarization, and
in the correlated state matrix.
<<Particles: particle set: TBP>>=
procedure :: final => particle_set_final
<<Particles: sub interfaces>>=
module subroutine particle_set_final (particle_set)
class(particle_set_t), intent(inout) :: particle_set
end subroutine particle_set_final
<<Particles: procedures>>=
module subroutine particle_set_final (particle_set)
class(particle_set_t), intent(inout) :: particle_set
integer :: i
if (allocated (particle_set%prt)) then
do i = 1, size(particle_set%prt)
call particle_set%prt(i)%final ()
end do
deallocate (particle_set%prt)
end if
call particle_set%correlated_state%final ()
end subroutine particle_set_final
@ %def particle_set_final
@
\subsection{Manual build}
Basic initialization. Just allocate with a given number of beam, incoming,
virtual, and outgoing particles.
<<Particles: particle set: TBP>>=
procedure :: basic_init => particle_set_basic_init
<<Particles: sub interfaces>>=
module subroutine particle_set_basic_init (particle_set, n_beam, n_in, n_vir, n_out)
class(particle_set_t), intent(out) :: particle_set
integer, intent(in) :: n_beam, n_in, n_vir, n_out
end subroutine particle_set_basic_init
<<Particles: procedures>>=
module subroutine particle_set_basic_init (particle_set, n_beam, n_in, n_vir, n_out)
class(particle_set_t), intent(out) :: particle_set
integer, intent(in) :: n_beam, n_in, n_vir, n_out
particle_set%n_beam = n_beam
particle_set%n_in = n_in
particle_set%n_vir = n_vir
particle_set%n_out = n_out
particle_set%n_tot = n_beam + n_in + n_vir + n_out
allocate (particle_set%prt (particle_set%n_tot))
end subroutine particle_set_basic_init
@ %def particle_set_basic_init
@
Build a particle set from scratch. This is used for testing
purposes. The ordering of particles in the result is
beam-incoming-remnant-virtual-outgoing.
Parent-child relations:
\begin{itemize}
\item
Beams are parents of incoming and beam remnants. The assignment is
alternating (first beam, second beam).
\item
Incoming are parents of virtual and outgoing, collectively.
\end{itemize}
More specific settings, such as resonance histories, cannot be set
this way.
Beam-remnant particles are counted as virtual, but have a different
status code.
We assume that the [[pdg]] array has the correct size.
<<Particles: particle set: TBP>>=
procedure :: init_direct => particle_set_init_direct
<<Particles: sub interfaces>>=
module subroutine particle_set_init_direct (particle_set, &
n_beam, n_in, n_rem, n_vir, n_out, pdg, model)
class(particle_set_t), intent(out) :: particle_set
integer, intent(in) :: n_beam
integer, intent(in) :: n_in
integer, intent(in) :: n_rem
integer, intent(in) :: n_vir
integer, intent(in) :: n_out
integer, dimension(:), intent(in) :: pdg
class(model_data_t), intent(in), target :: model
end subroutine particle_set_init_direct
<<Particles: procedures>>=
module subroutine particle_set_init_direct (particle_set, &
n_beam, n_in, n_rem, n_vir, n_out, pdg, model)
class(particle_set_t), intent(out) :: particle_set
integer, intent(in) :: n_beam
integer, intent(in) :: n_in
integer, intent(in) :: n_rem
integer, intent(in) :: n_vir
integer, intent(in) :: n_out
integer, dimension(:), intent(in) :: pdg
class(model_data_t), intent(in), target :: model
type(flavor_t), dimension(:), allocatable :: flv
integer :: i, k, n
call particle_set%basic_init (n_beam, n_in, n_rem+n_vir, n_out)
n = 0
call particle_set%prt(n+1:n+n_beam)%reset_status (PRT_BEAM)
do i = n+1, n+n_beam
call particle_set%prt(i)%set_children &
([(k, k=i+n_beam, n+n_beam+n_in+n_rem, 2)])
end do
n = n + n_beam
call particle_set%prt(n+1:n+n_in)%reset_status (PRT_INCOMING)
do i = n+1, n+n_in
if (n_beam > 0) then
call particle_set%prt(i)%set_parents &
([i-n_beam])
end if
call particle_set%prt(i)%set_children &
([(k, k=n+n_in+n_rem+1, n+n_in+n_rem+n_vir+n_out)])
end do
n = n + n_in
call particle_set%prt(n+1:n+n_rem)%reset_status (PRT_BEAM_REMNANT)
do i = n+1, n+n_rem
if (n_beam > 0) then
call particle_set%prt(i)%set_parents &
([i-n_in-n_beam])
end if
end do
n = n + n_rem
call particle_set%prt(n+1:n+n_vir)%reset_status (PRT_VIRTUAL)
do i = n+1, n+n_vir
call particle_set%prt(i)%set_parents &
([(k, k=n-n_rem-n_in+1, n-n_rem)])
end do
n = n + n_vir
call particle_set%prt(n+1:n+n_out)%reset_status (PRT_OUTGOING)
do i = n+1, n+n_out
call particle_set%prt(i)%set_parents &
([(k, k=n-n_vir-n_rem-n_in+1, n-n_vir-n_rem)])
end do
allocate (flv (particle_set%n_tot))
call flv%init (pdg, model)
do k = n_beam+n_in+1, n_beam+n_in+n_rem
call flv(k)%tag_radiated ()
end do
do i = 1, particle_set%n_tot
call particle_set%prt(i)%set_flavor (flv(i))
end do
end subroutine particle_set_init_direct
@ %def particle_set_init_direct
@ Copy a particle set into a new, extended one. Use the mapping array to
determine the new positions of particles. The new set contains [[n_new]]
additional entries. Count the new, undefined particles as
virtual.
<<Particles: particle set: TBP>>=
procedure :: transfer => particle_set_transfer
<<Particles: sub interfaces>>=
module subroutine particle_set_transfer (pset, source, n_new, map)
class(particle_set_t), intent(out) :: pset
class(particle_set_t), intent(in) :: source
integer, intent(in) :: n_new
integer, dimension(:), intent(in) :: map
end subroutine particle_set_transfer
<<Particles: procedures>>=
module subroutine particle_set_transfer (pset, source, n_new, map)
class(particle_set_t), intent(out) :: pset
class(particle_set_t), intent(in) :: source
integer, intent(in) :: n_new
integer, dimension(:), intent(in) :: map
integer :: i
call pset%basic_init &
(source%n_beam, source%n_in, source%n_vir + n_new, source%n_out)
pset%factorization_mode = source%factorization_mode
do i = 1, source%n_tot
call pset%prt(map(i))%reset_status (source%prt(i)%get_status ())
call pset%prt(map(i))%set_flavor (source%prt(i)%get_flv ())
call pset%prt(map(i))%set_color (source%prt(i)%get_col ())
call pset%prt(map(i))%set_parents (map (source%prt(i)%get_parents ()))
call pset%prt(map(i))%set_children (map (source%prt(i)%get_children ()))
call pset%prt(map(i))%set_polarization &
(source%prt(i)%get_polarization_status ())
select case (source%prt(i)%get_polarization_status ())
case (PRT_DEFINITE_HELICITY)
call pset%prt(map(i))%set_helicity (source%prt(i)%get_hel ())
case (PRT_GENERIC_POLARIZATION)
call pset%prt(map(i))%set_pol (source%prt(i)%get_polarization ())
end select
end do
end subroutine particle_set_transfer
@ %def particle_set_transfer
@ Insert a new particle as an intermediate into a previously empty position.
Flavor and status are just set. Color is not set (but see below).
The complicated part is reassigning parent-child relations. The
inserted particle comes with an array [[child]] of its children which
are supposed to be existing particles.
We first scan all particles that come before the new insertion.
Whenever a particle has children that coincide with the children of
the new particle, those child entries are removed. (a) If the new
particle has no parent entry yet, those child entries are replaced by
the index of the new particle and simultaneously, the particle is
registered as a parent of the new particle. (b) If the current particle
already has a parent entry, those child entries are removed.
When this is done, the new particle is registered as the (only) parent of its
children.
<<Particles: particle set: TBP>>=
procedure :: insert => particle_set_insert
<<Particles: sub interfaces>>=
module subroutine particle_set_insert (pset, i, status, flv, child)
class(particle_set_t), intent(inout) :: pset
integer, intent(in) :: i
integer, intent(in) :: status
type(flavor_t), intent(in) :: flv
integer, dimension(:), intent(in) :: child
end subroutine particle_set_insert
<<Particles: procedures>>=
module subroutine particle_set_insert (pset, i, status, flv, child)
class(particle_set_t), intent(inout) :: pset
integer, intent(in) :: i
integer, intent(in) :: status
type(flavor_t), intent(in) :: flv
integer, dimension(:), intent(in) :: child
integer, dimension(:), allocatable :: p_child, parent
integer :: j, k, c, n_parent
logical :: no_match
call pset%prt(i)%reset_status (status)
call pset%prt(i)%set_flavor (flv)
call pset%prt(i)%set_children (child)
n_parent = pset%prt(i)%get_n_parents ()
do j = 1, i - 1
p_child = pset%prt(j)%get_children ()
no_match = .true.
do k = 1, size (p_child)
if (any (p_child(k) == child)) then
if (n_parent == 0 .and. no_match) then
if (.not. allocated (parent)) then
parent = [j]
else
parent = [parent, j]
end if
p_child(k) = i
else
p_child(k) = 0
end if
no_match = .false.
end if
end do
if (.not. no_match) then
p_child = pack (p_child, p_child /= 0)
call pset%prt(j)%set_children (p_child)
end if
end do
if (n_parent == 0) then
call pset%prt(i)%set_parents (parent)
end if
do j = 1, size (child)
c = child(j)
call pset%prt(c)%set_parents ([i])
end do
end subroutine particle_set_insert
@ %def particle_set_insert
@ This should be done after completing all insertions: recover color
assignments for the inserted particles, working backwards from
children to parents. A single call to the routine recovers the color
and anticolor line indices for a single particle.
<<Particles: particle set: TBP>>=
procedure :: recover_color => particle_set_recover_color
<<Particles: sub interfaces>>=
module subroutine particle_set_recover_color (pset, i)
class(particle_set_t), intent(inout) :: pset
integer, intent(in) :: i
end subroutine particle_set_recover_color
<<Particles: procedures>>=
module subroutine particle_set_recover_color (pset, i)
class(particle_set_t), intent(inout) :: pset
integer, intent(in) :: i
type(color_t) :: col
integer, dimension(:), allocatable :: child
integer :: j
child = pset%prt(i)%get_children ()
if (size (child) > 0) then
col = pset%prt(child(1))%get_col ()
do j = 2, size (child)
col = col .fuse. pset%prt(child(j))%get_col ()
end do
call pset%prt(i)%set_color (col)
end if
end subroutine particle_set_recover_color
@ %def particle_set_recover_color
@
\subsection{Extract/modify contents}
<<Particles: particle set: TBP>>=
generic :: get_color => get_color_all
generic :: get_color => get_color_indices
procedure :: get_color_all => particle_set_get_color_all
procedure :: get_color_indices => particle_set_get_color_indices
<<Particles: sub interfaces>>=
module function particle_set_get_color_all (particle_set) result (col)
class(particle_set_t), intent(in) :: particle_set
type(color_t), dimension(:), allocatable :: col
end function particle_set_get_color_all
<<Particles: procedures>>=
module function particle_set_get_color_all (particle_set) result (col)
class(particle_set_t), intent(in) :: particle_set
type(color_t), dimension(:), allocatable :: col
allocate (col (size (particle_set%prt)))
col = particle_set%prt%col
end function particle_set_get_color_all
@ %def particle_set_get_color_all
@
<<Particles: sub interfaces>>=
module function particle_set_get_color_indices (particle_set, indices) result (col)
type(color_t), dimension(:), allocatable :: col
class(particle_set_t), intent(in) :: particle_set
integer, intent(in), dimension(:), allocatable :: indices
end function particle_set_get_color_indices
<<Particles: procedures>>=
module function particle_set_get_color_indices (particle_set, indices) result (col)
type(color_t), dimension(:), allocatable :: col
class(particle_set_t), intent(in) :: particle_set
integer, intent(in), dimension(:), allocatable :: indices
integer :: i
allocate (col (size (indices)))
do i = 1, size (indices)
col(i) = particle_set%prt(indices(i))%col
end do
end function particle_set_get_color_indices
@ %def particle_set_get_color_indices
@ Set a single or all color components. This is a wrapper around the
corresponding [[particle_t]] method, with the same options. We assume
that the particle array is allocated.
<<Particles: particle set: TBP>>=
generic :: set_color => set_color_single
generic :: set_color => set_color_indices
generic :: set_color => set_color_all
procedure :: set_color_single => particle_set_set_color_single
procedure :: set_color_indices => particle_set_set_color_indices
procedure :: set_color_all => particle_set_set_color_all
<<Particles: sub interfaces>>=
module subroutine particle_set_set_color_single (particle_set, i, col)
class(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: i
type(color_t), intent(in) :: col
end subroutine particle_set_set_color_single
module subroutine particle_set_set_color_indices (particle_set, indices, col)
class(particle_set_t), intent(inout) :: particle_set
integer, dimension(:), intent(in) :: indices
type(color_t), dimension(:), intent(in) :: col
end subroutine particle_set_set_color_indices
module subroutine particle_set_set_color_all (particle_set, col)
class(particle_set_t), intent(inout) :: particle_set
type(color_t), dimension(:), intent(in) :: col
end subroutine particle_set_set_color_all
<<Particles: procedures>>=
module subroutine particle_set_set_color_single (particle_set, i, col)
class(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: i
type(color_t), intent(in) :: col
call particle_set%prt(i)%set_color (col)
end subroutine particle_set_set_color_single
module subroutine particle_set_set_color_indices (particle_set, indices, col)
class(particle_set_t), intent(inout) :: particle_set
integer, dimension(:), intent(in) :: indices
type(color_t), dimension(:), intent(in) :: col
integer :: i
do i = 1, size (indices)
call particle_set%prt(indices(i))%set_color (col(i))
end do
end subroutine particle_set_set_color_indices
module subroutine particle_set_set_color_all (particle_set, col)
class(particle_set_t), intent(inout) :: particle_set
type(color_t), dimension(:), intent(in) :: col
call particle_set%prt%set_color (col)
end subroutine particle_set_set_color_all
@ %def particle_set_set_color
@ Assigning particles manually may result in color mismatches. This is
checked here for all particles in the set. The color object is
compared against the color type that belongs to the flavor object.
The return value is an allocatable array which consists of the particles
with invalid color assignments. If the array size is zero, all is fine.
<<Particles: particle set: TBP>>=
procedure :: find_prt_invalid_color => particle_set_find_prt_invalid_color
<<Particles: sub interfaces>>=
module subroutine particle_set_find_prt_invalid_color (particle_set, index, prt)
class(particle_set_t), intent(in) :: particle_set
integer, dimension(:), allocatable, intent(out) :: index
type(particle_t), dimension(:), allocatable, intent(out), optional :: prt
end subroutine particle_set_find_prt_invalid_color
<<Particles: procedures>>=
module subroutine particle_set_find_prt_invalid_color (particle_set, index, prt)
class(particle_set_t), intent(in) :: particle_set
integer, dimension(:), allocatable, intent(out) :: index
type(particle_t), dimension(:), allocatable, intent(out), optional :: prt
type(flavor_t) :: flv
type(color_t) :: col
logical, dimension(:), allocatable :: mask
integer :: i, n, n_invalid
n = size (particle_set%prt)
allocate (mask (n))
do i = 1, n
associate (prt => particle_set%prt(i))
flv = prt%get_flv ()
col = prt%get_col ()
mask(i) = flv%get_color_type () /= col%get_type ()
end associate
end do
index = pack ([(i, i = 1, n)], mask)
if (present (prt)) prt = pack (particle_set%prt, mask)
end subroutine particle_set_find_prt_invalid_color
@ %def particle_set_find_prt_invalid_color
@
<<Particles: particle set: TBP>>=
generic :: get_momenta => get_momenta_all
generic :: get_momenta => get_momenta_indices
procedure :: get_momenta_all => particle_set_get_momenta_all
procedure :: get_momenta_indices => particle_set_get_momenta_indices
<<Particles: sub interfaces>>=
module function particle_set_get_momenta_all (particle_set) result (p)
class(particle_set_t), intent(in) :: particle_set
type(vector4_t), dimension(:), allocatable :: p
end function particle_set_get_momenta_all
<<Particles: procedures>>=
module function particle_set_get_momenta_all (particle_set) result (p)
class(particle_set_t), intent(in) :: particle_set
type(vector4_t), dimension(:), allocatable :: p
allocate (p (size (particle_set%prt)))
p = particle_set%prt%p
end function particle_set_get_momenta_all
@ %def particle_set_get_momenta_all
@
<<Particles: sub interfaces>>=
module function particle_set_get_momenta_indices (particle_set, indices) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(particle_set_t), intent(in) :: particle_set
integer, intent(in), dimension(:), allocatable :: indices
end function particle_set_get_momenta_indices
<<Particles: procedures>>=
module function particle_set_get_momenta_indices (particle_set, indices) result (p)
type(vector4_t), dimension(:), allocatable :: p
class(particle_set_t), intent(in) :: particle_set
integer, intent(in), dimension(:), allocatable :: indices
integer :: i
allocate (p (size (indices)))
do i = 1, size (indices)
p(i) = particle_set%prt(indices(i))%p
end do
end function particle_set_get_momenta_indices
@ %def particle_set_get_momenta_indices
@ Replace a single or all momenta. This is a wrapper around the
corresponding [[particle_t]] method, with the same options. We assume
that the particle array is allocated.
<<Particles: particle set: TBP>>=
generic :: set_momentum => set_momentum_single
generic :: set_momentum => set_momentum_indices
generic :: set_momentum => set_momentum_all
procedure :: set_momentum_single => particle_set_set_momentum_single
procedure :: set_momentum_indices => particle_set_set_momentum_indices
procedure :: set_momentum_all => particle_set_set_momentum_all
<<Particles: sub interfaces>>=
module subroutine particle_set_set_momentum_single &
(particle_set, i, p, p2, on_shell)
class(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: i
type(vector4_t), intent(in) :: p
real(default), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
end subroutine particle_set_set_momentum_single
module subroutine particle_set_set_momentum_indices &
(particle_set, indices, p, p2, on_shell)
class(particle_set_t), intent(inout) :: particle_set
integer, dimension(:), intent(in) :: indices
type(vector4_t), dimension(:), intent(in) :: p
real(default), dimension(:), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
end subroutine particle_set_set_momentum_indices
module subroutine particle_set_set_momentum_all (particle_set, p, p2, on_shell)
class(particle_set_t), intent(inout) :: particle_set
type(vector4_t), dimension(:), intent(in) :: p
real(default), dimension(:), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
end subroutine particle_set_set_momentum_all
<<Particles: procedures>>=
module subroutine particle_set_set_momentum_single &
(particle_set, i, p, p2, on_shell)
class(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: i
type(vector4_t), intent(in) :: p
real(default), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
call particle_set%prt(i)%set_momentum (p, p2, on_shell)
end subroutine particle_set_set_momentum_single
module subroutine particle_set_set_momentum_indices &
(particle_set, indices, p, p2, on_shell)
class(particle_set_t), intent(inout) :: particle_set
integer, dimension(:), intent(in) :: indices
type(vector4_t), dimension(:), intent(in) :: p
real(default), dimension(:), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
integer :: i
if (present (p2)) then
do i = 1, size (indices)
call particle_set%prt(indices(i))%set_momentum (p(i), p2(i), on_shell)
end do
else
do i = 1, size (indices)
call particle_set%prt(indices(i))%set_momentum &
(p(i), on_shell=on_shell)
end do
end if
end subroutine particle_set_set_momentum_indices
module subroutine particle_set_set_momentum_all (particle_set, p, p2, on_shell)
class(particle_set_t), intent(inout) :: particle_set
type(vector4_t), dimension(:), intent(in) :: p
real(default), dimension(:), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
call particle_set%prt%set_momentum (p, p2, on_shell)
end subroutine particle_set_set_momentum_all
@ %def particle_set_set_momentum
@ Recover a momentum by recombining from children, assuming that this
is possible. The reconstructed momentum is not projected on-shell.
<<Particles: particle set: TBP>>=
procedure :: recover_momentum => particle_set_recover_momentum
<<Particles: sub interfaces>>=
module subroutine particle_set_recover_momentum (particle_set, i)
class(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: i
end subroutine particle_set_recover_momentum
<<Particles: procedures>>=
module subroutine particle_set_recover_momentum (particle_set, i)
class(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: i
type(vector4_t), dimension(:), allocatable :: p
integer, dimension(:), allocatable :: index
index = particle_set%prt(i)%get_children ()
p = particle_set%get_momenta (index)
call particle_set%set_momentum (i, sum (p))
end subroutine particle_set_recover_momentum
@ %def particle_set_recover_momentum
@
<<Particles: particle set: TBP>>=
procedure :: replace_incoming_momenta => particle_set_replace_incoming_momenta
<<Particles: sub interfaces>>=
module subroutine particle_set_replace_incoming_momenta (particle_set, p)
class(particle_set_t), intent(inout) :: particle_set
type(vector4_t), intent(in), dimension(:) :: p
end subroutine particle_set_replace_incoming_momenta
<<Particles: procedures>>=
module subroutine particle_set_replace_incoming_momenta (particle_set, p)
class(particle_set_t), intent(inout) :: particle_set
type(vector4_t), intent(in), dimension(:) :: p
integer :: i, j
i = 1
do j = 1, particle_set%get_n_tot ()
if (particle_set%prt(j)%get_status () == PRT_INCOMING) then
particle_set%prt(j)%p = p(i)
i = i + 1
if (i > particle_set%n_in) exit
end if
end do
end subroutine particle_set_replace_incoming_momenta
@ %def particle_set_replace_incoming_momenta
@
<<Particles: particle set: TBP>>=
procedure :: replace_outgoing_momenta => particle_set_replace_outgoing_momenta
<<Particles: sub interfaces>>=
module subroutine particle_set_replace_outgoing_momenta (particle_set, p)
class(particle_set_t), intent(inout) :: particle_set
type(vector4_t), intent(in), dimension(:) :: p
end subroutine particle_set_replace_outgoing_momenta
<<Particles: procedures>>=
module subroutine particle_set_replace_outgoing_momenta (particle_set, p)
class(particle_set_t), intent(inout) :: particle_set
type(vector4_t), intent(in), dimension(:) :: p
integer :: i, j
i = particle_set%n_in + 1
do j = 1, particle_set%n_tot
if (particle_set%prt(j)%get_status () == PRT_OUTGOING) then
particle_set%prt(j)%p = p(i)
i = i + 1
end if
end do
end subroutine particle_set_replace_outgoing_momenta
@ %def particle_set_replace_outgoing_momenta
@
<<Particles: particle set: TBP>>=
procedure :: get_outgoing_momenta => particle_set_get_outgoing_momenta
<<Particles: sub interfaces>>=
module function particle_set_get_outgoing_momenta (particle_set) result (p)
class(particle_set_t), intent(in) :: particle_set
type(vector4_t), dimension(:), allocatable :: p
end function particle_set_get_outgoing_momenta
<<Particles: procedures>>=
module function particle_set_get_outgoing_momenta (particle_set) result (p)
class(particle_set_t), intent(in) :: particle_set
type(vector4_t), dimension(:), allocatable :: p
integer :: i, k
allocate (p (count (particle_set%prt%get_status () == PRT_OUTGOING)))
k = 0
do i = 1, size (particle_set%prt)
if (particle_set%prt(i)%get_status () == PRT_OUTGOING) then
k = k + 1
p(k) = particle_set%prt(i)%get_momentum ()
end if
end do
end function particle_set_get_outgoing_momenta
@ %def particle_set_get_outgoing_momenta
@
<<Particles: particle set: TBP>>=
procedure :: parent_add_child => particle_set_parent_add_child
<<Particles: sub interfaces>>=
module subroutine particle_set_parent_add_child (particle_set, parent, child)
class(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: parent, child
end subroutine particle_set_parent_add_child
<<Particles: procedures>>=
module subroutine particle_set_parent_add_child (particle_set, parent, child)
class(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: parent, child
call particle_set%prt(child)%set_parents ([parent])
call particle_set%prt(parent)%add_child (child)
end subroutine particle_set_parent_add_child
@ %def particle_set_parent_add_child
@ Given the [[particle_set]] before radiation, the new momenta
[[p_radiated]], the [[emitter]] and the [[flv_radiated]] as well as the
[[model]] and a random number [[r_color]] for chosing a color in
ambiguous cases, we update the [[particle_set]].
The reference for this procedure is [0709.2092], Sec. 4.5.1.
We do not (yet) account for helicities and polarisations here nor do we
update the beam remnant color and momenta.
<<Particles: particle set: TBP>>=
procedure :: build_radiation => particle_set_build_radiation
<<Particles: sub interfaces>>=
module subroutine particle_set_build_radiation (particle_set, p_radiated, &
emitter, flv_radiated, model, r_color)
class(particle_set_t), intent(inout) :: particle_set
type(vector4_t), intent(in), dimension(:) :: p_radiated
integer, intent(in) :: emitter
integer, intent(in), dimension(:) :: flv_radiated
class(model_data_t), intent(in), target :: model
real(default), intent(in) :: r_color
end subroutine particle_set_build_radiation
<<Particles: procedures>>=
module subroutine particle_set_build_radiation (particle_set, p_radiated, &
emitter, flv_radiated, model, r_color)
class(particle_set_t), intent(inout) :: particle_set
type(vector4_t), intent(in), dimension(:) :: p_radiated
integer, intent(in) :: emitter
integer, intent(in), dimension(:) :: flv_radiated
class(model_data_t), intent(in), target :: model
real(default), intent(in) :: r_color
type(particle_set_t) :: new_particle_set
type(particle_t) :: new_particle
integer :: i, j, pdg_index_emitter, pdg_index_radiation, new_color_index
integer, dimension(:), allocatable :: parents, children
type(vector4_t) :: mom_sum_children
type(flavor_t) :: new_flv, real_emitter_flavor
logical, dimension(:), allocatable :: status_mask
integer, dimension(:), allocatable :: &
i_in1, i_beam1, i_remnant1, i_virt1, i_res1, i_out1
integer, dimension(:), allocatable :: &
i_in2, i_beam2, i_remnant2, i_virt2, i_res2, i_out2
integer :: n_in1, n_beam1, n_remnant1, n_virt1, n_res1, n_out1
integer :: n_in2, n_beam2, n_remnant2, n_virt2, n_res2, n_out2
integer :: n, n_tot, i_emitter
logical :: is_fsr
n = particle_set%get_n_tot ()
allocate (status_mask (n))
do i = 1, n
status_mask(i) = particle_set%prt(i)%get_status () == PRT_INCOMING
end do
n_in1 = count (status_mask)
allocate (i_in1 (n_in1))
i_in1 = particle_set%get_indices (status_mask)
do i = 1, n
status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM
end do
n_beam1 = count (status_mask)
allocate (i_beam1 (n_beam1))
i_beam1 = particle_set%get_indices (status_mask)
do i = 1, n
status_mask(i) = particle_set%prt(i)%get_status () == PRT_BEAM_REMNANT
end do
n_remnant1 = count (status_mask)
allocate (i_remnant1 (n_remnant1))
i_remnant1 = particle_set%get_indices (status_mask)
do i = 1, n
status_mask(i) = particle_set%prt(i)%get_status () == PRT_VIRTUAL
end do
n_virt1 = count (status_mask)
allocate (i_virt1 (n_virt1))
i_virt1 = particle_set%get_indices (status_mask)
do i = 1, n
status_mask(i) = particle_set%prt(i)%get_status () == PRT_RESONANT
end do
n_res1 = count (status_mask)
allocate (i_res1 (n_res1))
i_res1 = particle_set%get_indices (status_mask)
do i = 1, n
status_mask(i) = particle_set%prt(i)%get_status () == PRT_OUTGOING
end do
n_out1 = count (status_mask)
allocate (i_out1 (n_out1))
i_out1 = particle_set%get_indices (status_mask)
n_in2 = n_in1; n_beam2 = n_beam1; n_remnant2 = n_remnant1; n_res2 = n_res1
n_virt2 = n_virt1
n_out2 = n_out1 + 1
n_tot = n_in2 + n_beam2 + n_remnant2 + n_virt2 + n_res2 + n_out2
allocate (i_in2 (n_in2), i_beam2 (n_beam2), i_remnant2 (n_remnant2), i_res2 (n_res2))
i_in2 = i_in1; i_beam2 = i_beam1; i_remnant2 = i_remnant1; i_res2 = i_res1
allocate (i_virt2 (n_virt2))
i_virt2(1 : n_virt1) = i_virt1
allocate (i_out2 (n_out2))
i_out2(1 : n_out1) = i_out1(1 : n_out1)
i_out2(n_out2) = n_tot
new_particle_set%n_beam = n_beam2
new_particle_set%n_in = n_in2
new_particle_set%n_vir = n_virt2 + n_res2
new_particle_set%n_out = n_out2
new_particle_set%n_tot = n_tot
new_particle_set%correlated_state = particle_set%correlated_state
allocate (new_particle_set%prt (n_tot))
if (size (i_beam1) > 0) new_particle_set%prt(i_beam2) = particle_set%prt(i_beam1)
if (size (i_remnant1) > 0) new_particle_set%prt(i_remnant2) = particle_set%prt(i_remnant1)
if (size (i_res1) > 0) new_particle_set%prt(i_res2) = particle_set%prt(i_res1)
do i = 1, n_virt1
new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_virt1(i))
end do
do i = 1, n_in2
new_particle_set%prt(i_in2(i)) = particle_set%prt(i_in1(i))
new_particle_set%prt(i_in2(i))%p = p_radiated (i)
end do
do i = 1, n_out2 - 1
new_particle_set%prt(i_out2(i)) = particle_set%prt(i_out1(i))
new_particle_set%prt(i_out2(i))%p = p_radiated(i + n_in2)
call new_particle_set%prt(i_out2(i))%reset_status (PRT_OUTGOING)
end do
call new_particle%reset_status (PRT_OUTGOING)
call new_particle%set_momentum (p_radiated (n_in2 + n_out2))
!!! Helicity and polarization handling is missing at this point
!!! Also, no helicities or polarizations yet
pdg_index_emitter = flv_radiated (emitter)
pdg_index_radiation = flv_radiated (n_in2 + n_out2)
call new_flv%init (pdg_index_radiation, model)
is_fsr = emitter > n_in1
if (is_fsr) then
i_emitter = emitter + n_virt2 + n_res2 + n_remnant2 + n_beam2
else
i_emitter = emitter + n_beam2
end if
call real_emitter_flavor%init (pdg_index_emitter, model)
call new_particle_set%prt(i_emitter)%set_flavor(real_emitter_flavor)
new_color_index = 0
do i = 1, n_tot - 1
new_color_index = max(maxval(abs(particle_set%prt(i)%get_color())), new_color_index)
end do
new_color_index = new_color_index + 1
call reassign_colors (new_particle, new_particle_set%prt(i_emitter), &
pdg_index_radiation, pdg_index_emitter, new_color_index, is_fsr, r_color)
call new_particle%set_flavor (new_flv)
new_particle_set%prt(n_tot) = new_particle
!!! Set proper parents for outgoing particles
if (is_fsr) then
call new_particle_set%prt(n_tot)%set_parents ( &
new_particle_set%prt(i_emitter)%get_parents ())
else
call new_particle_set%prt(n_tot)%set_parents (i_in2)
end if
do i = n_in2 + n_beam2 + n_remnant2 + n_virt1 + 1, &
n_in2 + n_beam2 + n_remnant2 + n_virt2 + n_res2
allocate(children(0))
mom_sum_children = vector4_null
do j = n_in2 + n_beam2 + n_remnant2, n_tot
if (any(new_particle_set%prt(j)%get_parents() == i)) then
children = [children, j]
if (new_particle_set%prt(j)%get_status () == PRT_OUTGOING) then
mom_sum_children = mom_sum_children &
+ new_particle_set%prt(j)%get_momentum ()
end if
end if
end do
call new_particle_set%prt(i)%set_children (children)
if (mom_sum_children /= vector4_null) then
call new_particle_set%set_momentum (i, mom_sum_children)
end if
deallocate(children)
end do
call particle_set%init (new_particle_set)
contains
<<build radiation: set color offset>>
subroutine reassign_colors (prt_radiated, prt_emitter, flv_rad, flv_em, &
new_color_index, is_fsr, r_col)
type(particle_t), intent(inout) :: prt_radiated, prt_emitter
integer, intent(in) :: flv_rad, flv_em, new_color_index
logical, intent(in) :: is_fsr
real(default), intent(in) :: r_col
type(color_t) :: col_rad, col_em
if (is_fsr) then
if (is_quark (flv_em) .and. is_gluon (flv_rad)) then
call reassign_colors_q_to_qg_fsr (prt_emitter, new_color_index, col_rad, col_em)
else if (is_gluon (flv_em) .and. is_gluon (flv_rad)) then
call reassign_colors_g_to_gg_fsr (prt_emitter, r_col, new_color_index, col_rad, col_em)
else if (is_quark (flv_em) .and. is_quark (flv_rad)) then
call reassign_colors_g_to_qq_fsr (prt_emitter, flv_em, col_rad, col_em)
else
call msg_fatal ("reassign_colors: invalid splitting")
end if
else
if (is_quark (flv_em) .and. is_gluon (flv_rad)) then
call reassign_colors_q_to_qg_isr (prt_emitter, new_color_index, col_rad, col_em)
else if (is_quark (flv_em) .and. is_quark (flv_rad)) then
call reassign_colors_g_to_qq_isr (prt_emitter, flv_rad, col_rad, col_em)
else if (is_gluon (flv_em) .and. is_quark (flv_rad)) then
call reassign_colors_q_to_gq_isr (prt_emitter, flv_rad, new_color_index, col_rad, col_em)
else if (is_gluon (flv_em) .and. is_gluon (flv_rad)) then
call reassign_colors_g_to_gg_isr (prt_emitter, r_col, new_color_index, col_rad, col_em)
else
call msg_fatal ("reassign_colors: invalid splitting")
end if
end if
call prt_emitter%set_color (col_em)
call prt_radiated%set_color (col_rad)
end subroutine reassign_colors
subroutine reassign_colors_q_to_qg_fsr (prt_emitter, new_color_index, &
col_rad, col_em)
type(particle_t), intent(in) :: prt_emitter
integer, intent(in) :: new_color_index
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
logical :: is_anti_quark
color_em = prt_emitter%get_color ()
i1 = 1; i2 = 2
is_anti_quark = color_em(2) /= 0
if (is_anti_quark) then
i1 = 2; i2 = 1
end if
color_rad(i1) = color_em(i1)
color_rad(i2) = new_color_index
color_em(i1) = new_color_index
call col_em%init_col_acl (color_em(1), color_em(2))
call col_rad%init_col_acl (color_rad(1), color_rad(2))
end subroutine reassign_colors_q_to_qg_fsr
subroutine reassign_colors_g_to_gg_fsr (prt_emitter, random, new_color_index, &
col_rad, col_em)
type(particle_t), intent(in) :: prt_emitter
real(default), intent(in) :: random
integer, intent(in) :: new_color_index
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
color_em = prt_emitter%get_color ()
i1 = 1; i2 = 2
if (random < 0.5) then
i1 = 2; i2 = 1
end if
color_rad(i1) = new_color_index
color_rad(i2) = color_em(i2)
color_em(i2) = new_color_index
call col_em%init_col_acl (color_em(1), color_em(2))
call col_rad%init_col_acl (color_rad(1), color_rad(2))
end subroutine reassign_colors_g_to_gg_fsr
subroutine reassign_colors_g_to_qq_fsr (prt_emitter, pdg_emitter, col_rad, col_em)
type(particle_t), intent(in) :: prt_emitter
integer, intent(in) :: pdg_emitter
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
logical :: is_anti_quark
color_em = prt_emitter%get_color ()
i1 = 1; i2 = 2
is_anti_quark = pdg_emitter < 0
if (is_anti_quark) then
i1 = 2; i1 = 1
end if
color_em(i2) = 0
color_rad(i1) = 0
color_rad(i2) = color_em(i1)
call col_em%init_col_acl (color_em(1), color_em(2))
call col_rad%init_col_acl (color_rad(1), color_rad(2))
end subroutine reassign_colors_g_to_qq_fsr
subroutine reassign_colors_q_to_qg_isr (prt_emitter, new_color_index, &
col_rad, col_em)
type(particle_t), intent(in) :: prt_emitter
integer, intent(in) :: new_color_index
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
logical :: is_anti_quark
color_em = prt_emitter%get_color ()
i1 = 1; i2 = 2
is_anti_quark = color_em(2) /= 0
if (is_anti_quark) then
i1 = 2; i2 = 1
end if
color_rad(i2) = color_em(i1)
color_rad(i1) = new_color_index
color_em(i1) = new_color_index
call col_em%init_col_acl (color_em(1), color_em(2))
call col_rad%init_col_acl (color_rad(1), color_rad(2))
end subroutine reassign_colors_q_to_qg_isr
subroutine reassign_colors_g_to_qq_isr (prt_emitter, pdg_rad, col_rad, col_em)
type(particle_t), intent(in) :: prt_emitter
integer, intent(in) :: pdg_rad
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
logical :: is_anti_quark
color_em = prt_emitter%get_color ()
i1 = 1; i2 = 2
is_anti_quark = pdg_rad < 0
if (is_anti_quark) then
i1 = 2; i2 = 1
end if
color_rad(i1) = color_em(i2)
color_rad(i2) = 0
color_em(i2) = 0
call col_em%init_col_acl (color_em(1), color_em(2))
call col_rad%init_col_acl (color_rad(1), color_rad(2))
end subroutine reassign_colors_g_to_qq_isr
subroutine reassign_colors_q_to_gq_isr (prt_emitter, pdg_rad, new_color_index, &
col_rad, col_em)
type(particle_t), intent(in) :: prt_emitter
integer, intent(in) :: pdg_rad, new_color_index
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
logical :: rad_is_quark
color_em = prt_emitter%get_color ()
i1 = 1; i2 = 2
rad_is_quark = pdg_rad > 0
if (rad_is_quark) then
i1 = 2; i2 = 1
end if
color_rad(i1) = 0
color_rad(i2) = new_color_index
color_em(i2) = new_color_index
call col_em%init_col_acl (color_em(1), color_em(2))
call col_rad%init_col_acl (color_rad(1), color_rad(2))
end subroutine reassign_colors_q_to_gq_isr
subroutine reassign_colors_g_to_gg_isr (prt_emitter, random, new_color_index, &
col_rad, col_em)
type(particle_t), intent(in) :: prt_emitter
real(default), intent(in) :: random
integer, intent(in) :: new_color_index
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
color_em = prt_emitter%get_color ()
i1 = 1; i2 = 2
if (random < 0.5) then
i1 = 2; i2 = 1
end if
color_rad(i2) = new_color_index
color_rad(i1) = color_em(i2)
color_em(i2) = new_color_index
call col_em%init_col_acl (color_em(1), color_em(2))
call col_rad%init_col_acl (color_rad(1), color_rad(2))
end subroutine reassign_colors_g_to_gg_isr
end subroutine particle_set_build_radiation
@ %def particle_set_build_radiation
@ Increments the color indices of all particles by their maximal value to distinguish them
from the record-keeping Born particles in the LHE-output if the virtual entries are kept.
<<build radiation: set color offset>>=
subroutine set_color_offset (particle_set)
type(particle_set_t), intent(inout) :: particle_set
integer, dimension(2) :: color
integer :: i, i_color_max
type(color_t) :: new_color
i_color_max = 0
do i = 1, size (particle_set%prt)
associate (prt => particle_set%prt(i))
if (prt%get_status () <= PRT_INCOMING) cycle
color = prt%get_color ()
i_color_max = maxval([i_color_max, color(1), color(2)])
end associate
end do
do i = 1, size (particle_set%prt)
associate (prt => particle_set%prt(i))
if (prt%get_status () /= PRT_OUTGOING) cycle
color = prt%get_color ()
where (color /= 0) color = color + i_color_max
call new_color%init_col_acl (color(1), color(2))
call prt%set_color (new_color)
end associate
end do
end subroutine set_color_offset
@ %def set_color_offset
@ Output (default format)
<<Particles: particle set: TBP>>=
procedure :: write => particle_set_write
<<Particles: sub interfaces>>=
module subroutine particle_set_write &
(particle_set, unit, testflag, summary, compressed)
class(particle_set_t), intent(in) :: particle_set
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag, summary, compressed
end subroutine particle_set_write
<<Particles: procedures>>=
module subroutine particle_set_write &
(particle_set, unit, testflag, summary, compressed)
class(particle_set_t), intent(in) :: particle_set
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag, summary, compressed
logical :: summ, comp, pol
type(vector4_t) :: sum_vec
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
summ = .false.; if (present (summary)) summ = summary
comp = .false.; if (present (compressed)) comp = compressed
pol = particle_set%factorization_mode /= FM_IGNORE_HELICITY
write (u, "(1x,A)") "Particle set:"
call write_separator (u)
if (comp) then
if (pol) then
write (u, &
"((A4,1X),(A6,1X),(A7,1X),(A3),2(A4,1X),2(A20,1X),5(A12,1X))") &
"Nr", "Status", "Flavor", "Hel", "Col", "ACol", &
"Parents", "Children", &
"P(0)", "P(1)", "P(2)", "P(3)", "P^2"
else
write (u, &
"((A4,1X),(A6,1X),(A7,1X),2(A4,1X),2(A20,1X),5(A12,1X))") &
"Nr", "Status", "Flavor", "Col", "ACol", &
"Parents", "Children", &
"P(0)", "P(1)", "P(2)", "P(3)", "P^2"
end if
end if
if (particle_set%n_tot /= 0) then
do i = 1, particle_set%n_tot
if (comp) then
write (u, "(I4,1X,2X)", advance="no") i
else
write (u, "(1x,A,1x,I0)", advance="no") "Particle", i
end if
call particle_set%prt(i)%write (u, testflag = testflag, &
compressed = comp, polarization = pol)
end do
if (particle_set%correlated_state%is_defined ()) then
call write_separator (u)
write (u, *) "Correlated state density matrix:"
call particle_set%correlated_state%write (u)
end if
if (summ) then
call write_separator (u)
write (u, "(A)", advance="no") &
"Sum of incoming momenta: p(0:3) = "
sum_vec = sum (particle_set%prt%p, &
mask=particle_set%prt%get_status () == PRT_INCOMING)
call pacify (sum_vec, tolerance = 1E-3_default)
call sum_vec%write (u, compressed=.true.)
write (u, *)
write (u, "(A)", advance="no") &
"Sum of beam remnant momenta: p(0:3) = "
sum_vec = sum (particle_set%prt%p, &
mask=particle_set%prt%get_status () == PRT_BEAM_REMNANT)
call pacify (sum_vec, tolerance = 1E-3_default)
call sum_vec%write (u, compressed=.true.)
write (u, *)
write (u, "(A)", advance="no") &
"Sum of outgoing momenta: p(0:3) = "
sum_vec = sum (particle_set%prt%p, &
mask=particle_set%prt%get_status () == PRT_OUTGOING)
call pacify (sum_vec, tolerance = 1E-3_default)
call sum_vec%write (u, compressed=.true.)
write (u, "(A)") ""
end if
else
write (u, "(3x,A)") "[empty]"
end if
end subroutine particle_set_write
@ %def particle_set_write
@
\subsection{I/O formats}
Here, we define input/output of particle sets in various formats.
This is the right place since particle sets contain most of the event
information.
All write/read routines take as first argument the object, as second
argument the I/O unit which in this case is a mandatory argument.
Then follow further event data.
\subsubsection{Internal binary format}
This format is supposed to contain the complete information, so
the particle data set can be fully reconstructed. The exception is
the model part of the particle flavors; this is unassigned for the
flavor values read from file.
<<Particles: particle set: TBP>>=
procedure :: write_raw => particle_set_write_raw
procedure :: read_raw => particle_set_read_raw
<<Particles: sub interfaces>>=
module subroutine particle_set_write_raw (particle_set, u)
class(particle_set_t), intent(in) :: particle_set
integer, intent(in) :: u
end subroutine particle_set_write_raw
module subroutine particle_set_read_raw (particle_set, u, iostat)
class(particle_set_t), intent(out) :: particle_set
integer, intent(in) :: u
integer, intent(out) :: iostat
end subroutine particle_set_read_raw
<<Particles: procedures>>=
module subroutine particle_set_write_raw (particle_set, u)
class(particle_set_t), intent(in) :: particle_set
integer, intent(in) :: u
integer :: i
write (u) &
particle_set%n_beam, particle_set%n_in, &
particle_set%n_vir, particle_set%n_out
write (u) particle_set%factorization_mode
write (u) particle_set%n_tot
do i = 1, particle_set%n_tot
call particle_set%prt(i)%write_raw (u)
end do
call particle_set%correlated_state%write_raw (u)
end subroutine particle_set_write_raw
module subroutine particle_set_read_raw (particle_set, u, iostat)
class(particle_set_t), intent(out) :: particle_set
integer, intent(in) :: u
integer, intent(out) :: iostat
integer :: i
read (u, iostat=iostat) &
particle_set%n_beam, particle_set%n_in, &
particle_set%n_vir, particle_set%n_out
read (u, iostat=iostat) particle_set%factorization_mode
read (u, iostat=iostat) particle_set%n_tot
allocate (particle_set%prt (particle_set%n_tot))
do i = 1, size (particle_set%prt)
call particle_set%prt(i)%read_raw (u, iostat=iostat)
end do
call particle_set%correlated_state%read_raw (u, iostat=iostat)
end subroutine particle_set_read_raw
@ %def particle_set_write_raw particle_set_read_raw
@
\subsubsection{Get contents}
Find parents/children of a particular particle recursively; the
search terminates if a parent/child has status [[BEAM]], [[INCOMING]],
[[OUTGOING]] or [[RESONANT]].
<<Particles: particle set: TBP>>=
procedure :: get_real_parents => particle_set_get_real_parents
procedure :: get_real_children => particle_set_get_real_children
<<Particles: sub interfaces>>=
module function particle_set_get_real_parents (pset, i, keep_beams) result (parent)
integer, dimension(:), allocatable :: parent
class(particle_set_t), intent(in) :: pset
integer, intent(in) :: i
logical, intent(in), optional :: keep_beams
end function particle_set_get_real_parents
module function particle_set_get_real_children (pset, i, keep_beams) result (child)
integer, dimension(:), allocatable :: child
class(particle_set_t), intent(in) :: pset
integer, intent(in) :: i
logical, intent(in), optional :: keep_beams
end function particle_set_get_real_children
<<Particles: procedures>>=
module function particle_set_get_real_parents (pset, i, keep_beams) result (parent)
integer, dimension(:), allocatable :: parent
class(particle_set_t), intent(in) :: pset
integer, intent(in) :: i
logical, intent(in), optional :: keep_beams
logical, dimension(:), allocatable :: is_real
logical, dimension(:), allocatable :: is_parent, is_real_parent
logical :: kb
integer :: j, k
kb = .false.
if (present (keep_beams)) kb = keep_beams
allocate (is_real (pset%n_tot))
is_real = pset%prt%is_real (kb)
allocate (is_parent (pset%n_tot), is_real_parent (pset%n_tot))
is_real_parent = .false.
is_parent = .false.
is_parent(pset%prt(i)%get_parents()) = .true.
do while (any (is_parent))
where (is_real .and. is_parent)
is_real_parent = .true.
is_parent = .false.
end where
mark_next_parent: do j = size (is_parent), 1, -1
if (is_parent(j)) then
is_parent(pset%prt(j)%get_parents()) = .true.
is_parent(j) = .false.
exit mark_next_parent
end if
end do mark_next_parent
end do
allocate (parent (count (is_real_parent)))
j = 0
do k = 1, size (is_parent)
if (is_real_parent(k)) then
j = j + 1
parent(j) = k
end if
end do
end function particle_set_get_real_parents
module function particle_set_get_real_children (pset, i, keep_beams) result (child)
integer, dimension(:), allocatable :: child
class(particle_set_t), intent(in) :: pset
integer, intent(in) :: i
logical, dimension(:), allocatable :: is_real
logical, dimension(:), allocatable :: is_child, is_real_child
logical, intent(in), optional :: keep_beams
integer :: j, k
logical :: kb
kb = .false.
if (present (keep_beams)) kb = keep_beams
allocate (is_real (pset%n_tot))
is_real = pset%prt%is_real (kb)
is_real = pset%prt%is_real (kb)
allocate (is_child (pset%n_tot), is_real_child (pset%n_tot))
is_real_child = .false.
is_child = .false.
is_child(pset%prt(i)%get_children()) = .true.
do while (any (is_child))
where (is_real .and. is_child)
is_real_child = .true.
is_child = .false.
end where
mark_next_child: do j = 1, size (is_child)
if (is_child(j)) then
is_child(pset%prt(j)%get_children()) = .true.
is_child(j) = .false.
exit mark_next_child
end if
end do mark_next_child
end do
allocate (child (count (is_real_child)))
j = 0
do k = 1, size (is_child)
if (is_real_child(k)) then
j = j + 1
child(j) = k
end if
end do
end function particle_set_get_real_children
@ %def particle_set_get_real_parents
@ %def particle_set_get_real_children
@ Get the [[n_tot]], [[n_in]], and [[n_out]] values out of the
particle set.
<<Particles: particle set: TBP>>=
procedure :: get_n_beam => particle_set_get_n_beam
procedure :: get_n_in => particle_set_get_n_in
procedure :: get_n_vir => particle_set_get_n_vir
procedure :: get_n_out => particle_set_get_n_out
procedure :: get_n_tot => particle_set_get_n_tot
procedure :: get_n_remnants => particle_set_get_n_remnants
<<Particles: sub interfaces>>=
module function particle_set_get_n_beam (pset) result (n_beam)
class(particle_set_t), intent(in) :: pset
integer :: n_beam
end function particle_set_get_n_beam
module function particle_set_get_n_in (pset) result (n_in)
class(particle_set_t), intent(in) :: pset
integer :: n_in
end function particle_set_get_n_in
module function particle_set_get_n_vir (pset) result (n_vir)
class(particle_set_t), intent(in) :: pset
integer :: n_vir
end function particle_set_get_n_vir
module function particle_set_get_n_out (pset) result (n_out)
class(particle_set_t), intent(in) :: pset
integer :: n_out
end function particle_set_get_n_out
module function particle_set_get_n_tot (pset) result (n_tot)
class(particle_set_t), intent(in) :: pset
integer :: n_tot
end function particle_set_get_n_tot
module function particle_set_get_n_remnants (pset) result (n_remn)
class(particle_set_t), intent(in) :: pset
integer :: n_remn
end function particle_set_get_n_remnants
<<Particles: procedures>>=
module function particle_set_get_n_beam (pset) result (n_beam)
class(particle_set_t), intent(in) :: pset
integer :: n_beam
n_beam = pset%n_beam
end function particle_set_get_n_beam
module function particle_set_get_n_in (pset) result (n_in)
class(particle_set_t), intent(in) :: pset
integer :: n_in
n_in = pset%n_in
end function particle_set_get_n_in
module function particle_set_get_n_vir (pset) result (n_vir)
class(particle_set_t), intent(in) :: pset
integer :: n_vir
n_vir = pset%n_vir
end function particle_set_get_n_vir
module function particle_set_get_n_out (pset) result (n_out)
class(particle_set_t), intent(in) :: pset
integer :: n_out
n_out = pset%n_out
end function particle_set_get_n_out
module function particle_set_get_n_tot (pset) result (n_tot)
class(particle_set_t), intent(in) :: pset
integer :: n_tot
n_tot = pset%n_tot
end function particle_set_get_n_tot
module function particle_set_get_n_remnants (pset) result (n_remn)
class(particle_set_t), intent(in) :: pset
integer :: n_remn
if (allocated (pset%prt)) then
n_remn = count (pset%prt%get_status () == PRT_BEAM_REMNANT)
else
n_remn = 0
end if
end function particle_set_get_n_remnants
@ %def particle_set_get_n_beam
@ %def particle_set_get_n_in
@ %def particle_set_get_n_vir
@ %def particle_set_get_n_out
@ %def particle_set_get_n_tot
@ %def particle_set_get_n_remnants
@ Return a pointer to the particle corresponding to the number
<<Particles: particle set: TBP>>=
procedure :: get_particle => particle_set_get_particle
<<Particles: sub interfaces>>=
module function particle_set_get_particle (pset, index) result (particle)
class(particle_set_t), intent(in) :: pset
integer, intent(in) :: index
type(particle_t) :: particle
end function particle_set_get_particle
<<Particles: procedures>>=
module function particle_set_get_particle (pset, index) result (particle)
class(particle_set_t), intent(in) :: pset
integer, intent(in) :: index
type(particle_t) :: particle
particle = pset%prt(index)
end function particle_set_get_particle
@ %def particle_set_get_particle
@
<<Particles: particle set: TBP>>=
procedure :: get_indices => particle_set_get_indices
<<Particles: sub interfaces>>=
pure module function particle_set_get_indices (pset, mask) result (finals)
integer, dimension(:), allocatable :: finals
class(particle_set_t), intent(in) :: pset
logical, dimension(:), intent(in) :: mask
end function particle_set_get_indices
<<Particles: procedures>>=
pure module function particle_set_get_indices (pset, mask) result (finals)
integer, dimension(:), allocatable :: finals
class(particle_set_t), intent(in) :: pset
logical, dimension(:), intent(in) :: mask
integer, dimension(size(mask)) :: indices
integer :: i
allocate (finals (count (mask)))
indices = [(i, i=1, pset%n_tot)]
finals = pack (indices, mask)
end function particle_set_get_indices
@ %def particle_set_get_indices
@ Copy the subset of physical momenta to a [[phs_point]] container.
<<Particles: particle set: TBP>>=
procedure :: get_in_and_out_momenta => particle_set_get_in_and_out_momenta
<<Particles: sub interfaces>>=
module function particle_set_get_in_and_out_momenta (pset) result (phs_point)
type(phs_point_t) :: phs_point
class(particle_set_t), intent(in) :: pset
end function particle_set_get_in_and_out_momenta
<<Particles: procedures>>=
module function particle_set_get_in_and_out_momenta (pset) result (phs_point)
type(phs_point_t) :: phs_point
class(particle_set_t), intent(in) :: pset
logical, dimension(:), allocatable :: mask
integer, dimension(:), allocatable :: indices
type(vector4_t), dimension(:), allocatable :: p
allocate (mask (pset%get_n_tot ()))
allocate (p (size (pset%prt)))
mask = pset%prt%status == PRT_INCOMING .or. &
pset%prt%status == PRT_OUTGOING
allocate (indices (count (mask)))
indices = pset%get_indices (mask)
phs_point = pset%get_momenta (indices)
end function particle_set_get_in_and_out_momenta
@ %def particle_set_get_in_and_out_momenta
@
\subsubsection{Tools}
Build a new particles array without hadronic remnants but with
[[n_extra]] additional spots. We also update the mother-daughter
relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]].
<<Particles: particle set: TBP>>=
procedure :: without_hadronic_remnants => &
particle_set_without_hadronic_remnants
<<Particles: sub interfaces>>=
module subroutine particle_set_without_hadronic_remnants &
(particle_set, particles, n_particles, n_extra)
class(particle_set_t), intent(inout) :: particle_set
type(particle_t), dimension(:), allocatable, intent(out) :: particles
integer, intent(out) :: n_particles
integer, intent(in) :: n_extra
end subroutine particle_set_without_hadronic_remnants
<<Particles: procedures>>=
module subroutine particle_set_without_hadronic_remnants &
(particle_set, particles, n_particles, n_extra)
class(particle_set_t), intent(inout) :: particle_set
type(particle_t), dimension(:), allocatable, intent(out) :: particles
integer, intent(out) :: n_particles
integer, intent(in) :: n_extra
logical, dimension(:), allocatable :: no_hadronic_remnants, &
no_hadronic_children
integer, dimension(:), allocatable :: children, new_children
integer :: i, j, k, first_remnant
first_remnant = particle_set%n_tot
do i = 1, particle_set%n_tot
if (particle_set%prt(i)%is_hadronic_beam_remnant ()) then
first_remnant = i
exit
end if
end do
n_particles = count (.not. particle_set%prt%is_hadronic_beam_remnant ())
allocate (no_hadronic_remnants (particle_set%n_tot))
no_hadronic_remnants = .not. particle_set%prt%is_hadronic_beam_remnant ()
allocate (particles (n_particles + n_extra))
k = 1
do i = 1, particle_set%n_tot
if (no_hadronic_remnants(i)) then
particles(k) = particle_set%prt(i)
k = k + 1
end if
end do
if (n_particles /= particle_set%n_tot) then
do i = 1, n_particles
select case (particles(i)%get_status ())
case (PRT_BEAM)
if (allocated (children)) deallocate (children)
allocate (children (particles(i)%get_n_children ()))
children = particles(i)%get_children ()
if (allocated (no_hadronic_children)) &
deallocate (no_hadronic_children)
allocate (no_hadronic_children (particles(i)%get_n_children ()))
no_hadronic_children = .not. &
particle_set%prt(children)%is_hadronic_beam_remnant ()
if (allocated (new_children)) deallocate (new_children)
allocate (new_children (count (no_hadronic_children)))
new_children = pack (children, no_hadronic_children)
call particles(i)%set_children (new_children)
case (PRT_INCOMING, PRT_RESONANT)
<<update children after remnant>>
case (PRT_OUTGOING, PRT_BEAM_REMNANT)
case default
end select
end do
end if
end subroutine particle_set_without_hadronic_remnants
@ %def particle_set_without_hadronic_remnants
<<update children after remnant>>=
if (allocated (children)) deallocate (children)
allocate (children (particles(i)%get_n_children ()))
children = particles(i)%get_children ()
do j = 1, size (children)
if (children(j) > first_remnant) then
children(j) = children (j) - &
(particle_set%n_tot - n_particles)
end if
end do
call particles(i)%set_children (children)
@
Build a new particles array without remnants but with
[[n_extra]] additional spots. We also update the mother-daughter
relations assuming the ordering [[b]], [[i]], [[r]], [[x]], [[o]].
<<Particles: particle set: TBP>>=
procedure :: without_remnants => particle_set_without_remnants
<<Particles: sub interfaces>>=
module subroutine particle_set_without_remnants &
(particle_set, particles, n_particles, n_extra)
class(particle_set_t), intent(inout) :: particle_set
type(particle_t), dimension(:), allocatable, intent(out) :: particles
integer, intent(in) :: n_extra
integer, intent(out) :: n_particles
end subroutine particle_set_without_remnants
<<Particles: procedures>>=
module subroutine particle_set_without_remnants &
(particle_set, particles, n_particles, n_extra)
class(particle_set_t), intent(inout) :: particle_set
type(particle_t), dimension(:), allocatable, intent(out) :: particles
integer, intent(in) :: n_extra
integer, intent(out) :: n_particles
logical, dimension(:), allocatable :: no_remnants, no_children
integer, dimension(:), allocatable :: children, new_children
integer :: i,j, k, first_remnant
first_remnant = particle_set%n_tot
do i = 1, particle_set%n_tot
if (particle_set%prt(i)%is_beam_remnant ()) then
first_remnant = i
exit
end if
end do
allocate (no_remnants (particle_set%n_tot))
no_remnants = .not. (particle_set%prt%is_beam_remnant ())
n_particles = count (no_remnants)
allocate (particles (n_particles + n_extra))
k = 1
do i = 1, particle_set%n_tot
if (no_remnants(i)) then
particles(k) = particle_set%prt(i)
k = k + 1
end if
end do
if (n_particles /= particle_set%n_tot) then
do i = 1, n_particles
select case (particles(i)%get_status ())
case (PRT_BEAM)
if (allocated (children)) deallocate (children)
allocate (children (particles(i)%get_n_children ()))
children = particles(i)%get_children ()
if (allocated (no_children)) deallocate (no_children)
allocate (no_children (particles(i)%get_n_children ()))
no_children = .not. (particle_set%prt(children)%is_beam_remnant ())
if (allocated (new_children)) deallocate (new_children)
allocate (new_children (count (no_children)))
new_children = pack (children, no_children)
call particles(i)%set_children (new_children)
case (PRT_INCOMING, PRT_RESONANT)
<<update children after remnant>>
case (PRT_OUTGOING, PRT_BEAM_REMNANT)
case default
end select
end do
end if
end subroutine particle_set_without_remnants
@ %def particle_set_without_remnants
@
<<Particles: particle set: TBP>>=
procedure :: find_particle => particle_set_find_particle
<<Particles: sub interfaces>>=
pure module function particle_set_find_particle (particle_set, pdg, &
momentum, abs_smallness, rel_smallness) result (idx)
integer :: idx
class(particle_set_t), intent(in) :: particle_set
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: momentum
real(default), intent(in), optional :: abs_smallness, rel_smallness
end function particle_set_find_particle
<<Particles: procedures>>=
pure module function particle_set_find_particle (particle_set, pdg, &
momentum, abs_smallness, rel_smallness) result (idx)
integer :: idx
class(particle_set_t), intent(in) :: particle_set
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: momentum
real(default), intent(in), optional :: abs_smallness, rel_smallness
integer :: i
logical, dimension(0:3) :: equals
idx = 0
do i = 1, size (particle_set%prt)
if (particle_set%prt(i)%flv%get_pdg () == pdg) then
equals = nearly_equal (particle_set%prt(i)%p%p, momentum%p, &
abs_smallness, rel_smallness)
if (all (equals)) then
idx = i
return
end if
end if
end do
end function particle_set_find_particle
@ %def particle_set_find_particle
<<Particles: particle set: TBP>>=
procedure :: reverse_find_particle => particle_set_reverse_find_particle
<<Particles: sub interfaces>>=
pure module function particle_set_reverse_find_particle &
(particle_set, pdg, momentum, abs_smallness, rel_smallness) result (idx)
integer :: idx
class(particle_set_t), intent(in) :: particle_set
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: momentum
real(default), intent(in), optional :: abs_smallness, rel_smallness
end function particle_set_reverse_find_particle
<<Particles: procedures>>=
pure module function particle_set_reverse_find_particle &
(particle_set, pdg, momentum, abs_smallness, rel_smallness) result (idx)
integer :: idx
class(particle_set_t), intent(in) :: particle_set
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: momentum
real(default), intent(in), optional :: abs_smallness, rel_smallness
integer :: i
idx = 0
do i = size (particle_set%prt), 1, -1
if (particle_set%prt(i)%flv%get_pdg () == pdg) then
if (all (nearly_equal (particle_set%prt(i)%p%p, momentum%p, &
abs_smallness, rel_smallness))) then
idx = i
return
end if
end if
end do
end function particle_set_reverse_find_particle
@ %def particle_set_reverse_find_particle
@ This connects broken links of the form
$\text{something} \to i \to \text{none or} j$ and
$\text{none} \to j \to \text{something or none}$ where the particles $i$ and $j$
are \emph{identical}. It also works if $i \to j$, directly, and thus
removes duplicates. We are removing $j$ and connect the possible
daughters to $i$.
<<Particles: particle set: TBP>>=
procedure :: remove_duplicates => particle_set_remove_duplicates
<<Particles: sub interfaces>>=
module subroutine particle_set_remove_duplicates (particle_set, smallness)
class(particle_set_t), intent(inout) :: particle_set
real(default), intent(in) :: smallness
end subroutine particle_set_remove_duplicates
<<Particles: procedures>>=
module subroutine particle_set_remove_duplicates (particle_set, smallness)
class(particle_set_t), intent(inout) :: particle_set
real(default), intent(in) :: smallness
integer :: n_removals
integer, dimension(particle_set%n_tot) :: to_remove
type(particle_t), dimension(:), allocatable :: particles
type(vector4_t) :: p_i
integer, dimension(:), allocatable :: map
to_remove = 0
call find_duplicates ()
n_removals = count (to_remove > 0)
if (n_removals > 0) then
call strip_duplicates (particles)
call particle_set%replace (particles)
end if
contains
<<Particles: remove duplicates: procedures>>
end subroutine particle_set_remove_duplicates
@ %def particle_set_remove_duplicates
@ This does not catch all cases. Missing are splittings of the type
$i \to \text{something and} j$.
<<Particles: remove duplicates: procedures>>=
subroutine find_duplicates ()
integer :: pdg_i, child_i, i, j
OUTER: do i = 1, particle_set%n_tot
if (particle_set%prt(i)%status == PRT_OUTGOING .or. &
particle_set%prt(i)%status == PRT_VIRTUAL .or. &
particle_set%prt(i)%status == PRT_RESONANT) then
if (allocated (particle_set%prt(i)%child)) then
if (size (particle_set%prt(i)%child) > 1) cycle OUTER
if (size (particle_set%prt(i)%child) == 1) then
child_i = particle_set%prt(i)%child(1)
else
child_i = 0
end if
else
child_i = 0
end if
pdg_i = particle_set%prt(i)%flv%get_pdg ()
p_i = particle_set%prt(i)%p
do j = i + 1, particle_set%n_tot
if (pdg_i == particle_set%prt(j)%flv%get_pdg ()) then
if (all (nearly_equal (particle_set%prt(j)%p%p, p_i%p, &
abs_smallness = smallness, &
rel_smallness = 1E4_default * smallness))) then
if (child_i == 0 .or. j == child_i) then
to_remove(j) = i
if (debug_on) call msg_debug2 (D_PARTICLES, &
"Particles: Will remove duplicate of i", i)
if (debug_on) call msg_debug2 (D_PARTICLES, &
"Particles: j", j)
end if
cycle OUTER
end if
end if
end do
end if
end do OUTER
end subroutine find_duplicates
@
<<Particles: remove duplicates: procedures>>=
recursive function get_alive_index (try) result (alive)
integer :: alive
integer :: try
if (map(try) > 0) then
alive = map(try)
else
alive = get_alive_index (to_remove(try))
end if
end function get_alive_index
@
<<Particles: remove duplicates: procedures>>=
subroutine strip_duplicates (particles)
type(particle_t), dimension(:), allocatable, intent(out) :: particles
integer :: kept, removed, i, j
integer, dimension(:), allocatable :: old_children
logical, dimension(:), allocatable :: parent_set
if (debug_on) call msg_debug (D_PARTICLES, "Particles: Removing duplicates")
if (debug_on) call msg_debug (D_PARTICLES, "Particles: n_removals", n_removals)
if (debug2_active (D_PARTICLES)) then
call msg_debug2 (D_PARTICLES, "Particles: Given set before removing:")
call particle_set%write (summary=.true., compressed=.true.)
end if
allocate (particles (particle_set%n_tot - n_removals))
allocate (map (particle_set%n_tot))
allocate (parent_set (particle_set%n_tot))
parent_set = .false.
map = 0
j = 0
do i = 1, particle_set%n_tot
if (to_remove(i) == 0) then
j = j + 1
map(i) = j
call particles(j)%init (particle_set%prt(i))
end if
end do
do i = 1, particle_set%n_tot
if (map(i) /= 0) then
if (.not. parent_set(map(i))) then
call particles(map(i))%set_parents &
(map (particle_set%prt(i)%get_parents ()))
end if
call particles(map(i))%set_children &
(map (particle_set%prt(i)%get_children ()))
else
removed = i
kept = to_remove(i)
if (particle_set%prt(removed)%has_children ()) then
old_children = particle_set%prt(removed)%get_children ()
do j = 1, size (old_children)
if (map(old_children(j)) > 0) then
call particles(map(old_children(j)))%set_parents &
([get_alive_index (kept)])
parent_set(map(old_children(j))) = .true.
call particles(get_alive_index (kept))%add_child &
(map(old_children(j)))
end if
end do
particles(get_alive_index (kept))%status = PRT_RESONANT
else
particles(get_alive_index (kept))%status = PRT_OUTGOING
end if
end if
end do
end subroutine strip_duplicates
@ Given a subevent, reset status codes. If the new status is beam,
incoming, or outgoing, we also make sure that the stored $p^2$ value
is equal to the on-shell mass squared.
<<Particles: particle set: TBP>>=
procedure :: reset_status => particle_set_reset_status
<<Particles: sub interfaces>>=
module subroutine particle_set_reset_status (particle_set, index, status)
class(particle_set_t), intent(inout) :: particle_set
integer, dimension(:), intent(in) :: index
integer, intent(in) :: status
end subroutine particle_set_reset_status
<<Particles: procedures>>=
module subroutine particle_set_reset_status (particle_set, index, status)
class(particle_set_t), intent(inout) :: particle_set
integer, dimension(:), intent(in) :: index
integer, intent(in) :: status
integer :: i
if (allocated (particle_set%prt)) then
do i = 1, size (index)
call particle_set%prt(index(i))%reset_status (status)
end do
end if
particle_set%n_beam = &
count (particle_set%prt%get_status () == PRT_BEAM)
particle_set%n_in = &
count (particle_set%prt%get_status () == PRT_INCOMING)
particle_set%n_out = &
count (particle_set%prt%get_status () == PRT_OUTGOING)
particle_set%n_vir = particle_set%n_tot &
- particle_set%n_beam - particle_set%n_in - particle_set%n_out
end subroutine particle_set_reset_status
@ %def particle_set_reset_status
@ Reduce a particle set to the essential entries. The entries kept
are those with status [[INCOMING]], [[OUTGOING]] or
[[RESONANT]]. [[BEAM]] is kept if [[keep_beams]] is true. Other
entries are skipped. The correlated state matrix, if any, is also
ignored.
<<Particles: particle set: TBP>>=
procedure :: reduce => particle_set_reduce
<<Particles: sub interfaces>>=
module subroutine particle_set_reduce (pset_in, pset_out, keep_beams)
class(particle_set_t), intent(in) :: pset_in
type(particle_set_t), intent(out) :: pset_out
logical, intent(in), optional :: keep_beams
end subroutine particle_set_reduce
<<Particles: procedures>>=
module subroutine particle_set_reduce (pset_in, pset_out, keep_beams)
class(particle_set_t), intent(in) :: pset_in
type(particle_set_t), intent(out) :: pset_out
logical, intent(in), optional :: keep_beams
integer, dimension(:), allocatable :: status, map
integer :: i, j
logical :: kb
kb = .false.; if (present (keep_beams)) kb = keep_beams
allocate (status (pset_in%n_tot))
pset_out%factorization_mode = pset_in%factorization_mode
status = pset_in%prt%get_status ()
if (kb) pset_out%n_beam = count (status == PRT_BEAM)
pset_out%n_in = count (status == PRT_INCOMING)
pset_out%n_vir = count (status == PRT_RESONANT)
pset_out%n_out = count (status == PRT_OUTGOING)
pset_out%n_tot = &
pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out
allocate (pset_out%prt (pset_out%n_tot))
allocate (map (pset_in%n_tot))
map = 0
j = 0
if (kb) call copy_particles (PRT_BEAM)
call copy_particles (PRT_INCOMING)
call copy_particles (PRT_RESONANT)
call copy_particles (PRT_OUTGOING)
do i = 1, pset_in%n_tot
if (map(i) == 0) cycle
call pset_out%prt(map(i))%set_parents &
(pset_in%get_real_parents (i, kb))
call pset_out%prt(map(i))%set_parents &
(map (pset_out%prt(map(i))%parent))
call pset_out%prt(map(i))%set_children &
(pset_in%get_real_children (i, kb))
call pset_out%prt(map(i))%set_children &
(map (pset_out%prt(map(i))%child))
end do
contains
subroutine copy_particles (stat)
integer, intent(in) :: stat
integer :: i
do i = 1, pset_in%n_tot
if (status(i) == stat) then
j = j + 1
map(i) = j
call particle_init_particle (pset_out%prt(j), pset_in%prt(i))
end if
end do
end subroutine copy_particles
end subroutine particle_set_reduce
@ %def particles_set_reduce
@ Remove the beam particles and beam remnants from the particle set if the
keep beams flag is false. If keep beams is not given, the beam particles
and the beam remnants are removed.
The correlated state matrix, if any, is also ignored.
<<Particles: particle set: TBP>>=
procedure :: filter_particles => particle_set_filter_particles
<<Particles: sub interfaces>>=
module subroutine particle_set_filter_particles &
(pset_in, pset_out, keep_beams, real_parents, keep_virtuals)
class(particle_set_t), intent(in) :: pset_in
type(particle_set_t), intent(out) :: pset_out
logical, intent(in), optional :: keep_beams, real_parents, keep_virtuals
end subroutine particle_set_filter_particles
<<Particles: procedures>>=
module subroutine particle_set_filter_particles &
(pset_in, pset_out, keep_beams, real_parents, keep_virtuals)
class(particle_set_t), intent(in) :: pset_in
type(particle_set_t), intent(out) :: pset_out
logical, intent(in), optional :: keep_beams, real_parents, keep_virtuals
integer, dimension(:), allocatable :: status, map
logical, dimension(:), allocatable :: filter
integer :: i, j
logical :: kb, rp, kv
kb = .false.; if (present (keep_beams)) kb = keep_beams
rp = .false.; if (present (real_parents)) rp = real_parents
kv = .true.; if (present (keep_virtuals)) kv = keep_virtuals
if (debug_on) call msg_debug (D_PARTICLES, "filter_particles")
if (debug2_active (D_PARTICLES)) then
print *, 'keep_beams = ', kb
print *, 'real_parents = ', rp
print *, 'keep_virtuals = ', kv
print *, '>>> pset_in : '
call pset_in%write(compressed=.true.)
end if
call count_and_allocate()
map = 0
j = 0
filter = .false.
if (.not. kb) filter = status == PRT_BEAM .or. status == PRT_BEAM_REMNANT
if (.not. kv) filter = filter .or. status == PRT_VIRTUAL
call copy_particles ()
do i = 1, pset_in%n_tot
if (map(i) == 0) cycle
if (rp) then
call pset_out%prt(map(i))%set_parents &
(map (pset_in%get_real_parents (i, kb)))
call pset_out%prt(map(i))%set_children &
(map (pset_in%get_real_children (i, kb)))
else
call pset_out%prt(map(i))%set_parents &
(map (pset_in%prt(i)%get_parents ()))
call pset_out%prt(map(i))%set_children &
(map (pset_in%prt(i)%get_children ()))
end if
end do
if (debug2_active (D_PARTICLES)) then
print *, '>>> pset_out : '
call pset_out%write(compressed=.true.)
end if
contains
<<filter particles: procedures>>
end subroutine particle_set_filter_particles
@ %def particles_set_filter_particles
<<filter particles: procedures>>=
subroutine copy_particles ()
integer :: i
do i = 1, pset_in%n_tot
if (.not. filter(i)) then
j = j + 1
map(i) = j
call particle_init_particle (pset_out%prt(j), pset_in%prt(i))
end if
end do
end subroutine copy_particles
<<filter particles: procedures>>=
subroutine count_and_allocate
allocate (status (pset_in%n_tot))
status = particle_get_status (pset_in%prt)
if (kb) pset_out%n_beam = count (status == PRT_BEAM)
pset_out%n_in = count (status == PRT_INCOMING)
if (kb .and. kv) then
pset_out%n_vir = count (status == PRT_VIRTUAL) + &
count (status == PRT_RESONANT) + &
count (status == PRT_BEAM_REMNANT)
else if (kb .and. .not. kv) then
pset_out%n_vir = count (status == PRT_RESONANT) + &
count (status == PRT_BEAM_REMNANT)
else if (.not. kb .and. kv) then
pset_out%n_vir = count (status == PRT_VIRTUAL) + &
count (status == PRT_RESONANT)
else
pset_out%n_vir = count (status == PRT_RESONANT)
end if
pset_out%n_out = count (status == PRT_OUTGOING)
pset_out%n_tot = &
pset_out%n_beam + pset_out%n_in + pset_out%n_vir + pset_out%n_out
allocate (pset_out%prt (pset_out%n_tot))
allocate (map (pset_in%n_tot))
allocate (filter (pset_in%n_tot))
end subroutine count_and_allocate
@ Transform a particle set into HEPEVT-compatible form. In this form, for each
particle, the parents and the children are contiguous in the particle array.
Usually, this requires to clone some particles.
We do not know in advance how many particles the canonical form will have.
To be on the safe side, allocate four times the original size.
<<Particles: types>>=
type :: particle_entry_t
integer :: src = 0
integer :: status = 0
integer :: orig = 0
integer :: copy = 0
end type particle_entry_t
<<Particles: particle set: TBP>>=
procedure :: to_hepevt_form => particle_set_to_hepevt_form
<<Particles: sub interfaces>>=
module subroutine particle_set_to_hepevt_form (pset_in, pset_out)
class(particle_set_t), intent(in) :: pset_in
type(particle_set_t), intent(out) :: pset_out
end subroutine particle_set_to_hepevt_form
<<Particles: procedures>>=
module subroutine particle_set_to_hepevt_form (pset_in, pset_out)
class(particle_set_t), intent(in) :: pset_in
type(particle_set_t), intent(out) :: pset_out
type(particle_entry_t), dimension(:), allocatable :: prt
integer, dimension(:), allocatable :: map1, map2
integer, dimension(:), allocatable :: parent, child
integer :: n_tot, n_parents, n_children, i, j, c, n
n_tot = pset_in%n_tot
allocate (prt (4 * n_tot))
allocate (map1(4 * n_tot))
allocate (map2(4 * n_tot))
map1 = 0
map2 = 0
allocate (child (n_tot))
allocate (parent (n_tot))
n = 0
do i = 1, n_tot
if (pset_in%prt(i)%get_n_parents () == 0) then
call append (i)
end if
end do
do i = 1, n_tot
n_children = pset_in%prt(i)%get_n_children ()
if (n_children > 0) then
child(1:n_children) = pset_in%prt(i)%get_children ()
c = child(1)
if (map1(c) == 0) then
n_parents = pset_in%prt(c)%get_n_parents ()
if (n_parents > 1) then
parent(1:n_parents) = pset_in%prt(c)%get_parents ()
if (i == parent(1) .and. &
any( [(map1(i)+j-1, j=1,n_parents)] /= &
map1(parent(1:n_parents)))) then
do j = 1, n_parents
call append (parent(j))
end do
end if
else if (map1(i) == 0) then
call append (i)
end if
do j = 1, n_children
call append (child(j))
end do
end if
else if (map1(i) == 0) then
call append (i)
end if
end do
do i = n, 1, -1
if (prt(i)%status /= PRT_OUTGOING) then
do j = 1, i-1
if (prt(j)%status == PRT_OUTGOING) then
call append(prt(j)%src)
end if
end do
exit
end if
end do
pset_out%n_beam = count (prt(1:n)%status == PRT_BEAM)
pset_out%n_in = count (prt(1:n)%status == PRT_INCOMING)
pset_out%n_vir = count (prt(1:n)%status == PRT_RESONANT)
pset_out%n_out = count (prt(1:n)%status == PRT_OUTGOING)
pset_out%n_tot = n
allocate (pset_out%prt (n))
do i = 1, n
call particle_init_particle (pset_out%prt(i), pset_in%prt(prt(i)%src))
call pset_out%prt(i)%reset_status (prt(i)%status)
if (prt(i)%orig == 0) then
call pset_out%prt(i)%set_parents &
(map2 (pset_in%prt(prt(i)%src)%get_parents ()))
else
call pset_out%prt(i)%set_parents ([ prt(i)%orig ])
end if
if (prt(i)%copy == 0) then
call pset_out%prt(i)%set_children &
(map1 (pset_in%prt(prt(i)%src)%get_children ()))
else
call pset_out%prt(i)%set_children ([ prt(i)%copy ])
end if
end do
contains
subroutine append (i)
integer, intent(in) :: i
n = n + 1
if (n > size (prt)) &
call msg_bug ("Particle set transform to HEPEVT: insufficient space")
prt(n)%src = i
prt(n)%status = pset_in%prt(i)%get_status ()
if (map1(i) == 0) then
map1(i) = n
else
prt(map2(i))%status = PRT_VIRTUAL
prt(map2(i))%copy = n
prt(n)%orig = map2(i)
end if
map2(i) = n
end subroutine append
end subroutine particle_set_to_hepevt_form
@ %def particle_set_to_hepevt_form
@ This procedure aims at reconstructing the momenta of an interaction,
given a particle set. The main task is to find the original hard process, by
following the event history.
In-state: take those particles which are flagged as [[PRT_INCOMING]]
Out-state: try to be smart by checking the immediate children of the incoming
particles. If the [[state_flv]] table is present, check any [[PRT_RESONANT]]
particles that we get this way, whether they are potential out-particles by
their PDG codes. If not, replace them by their children, recursively.
(Resonances may have been inserted by the corresponding event transform.)
[WK 21-02-16] Revised the algorithm for the case [[recover_beams]] = false,
i.e., the particle set contains beams and radiation. This does not mean that
the particle set contains the complete radiation history. To make up for
missing information, we follow the history in the interaction one step
backwards and do a bit of guesswork to match this to the possibly incomplete
history in the particle set. [The current implementation allows only for one
stage of radiation; this could be improved by iterating the procedure!]
[WK 21-03-21] Amended the [[find_hard_process_in_pset]] algorithm as follows:
Occasionally, PYTHIA adds a stepchild to the decay of a resonance that WHIZARD
has inserted, a shower object that also has other particles in the event as
parents. Such objects must not enter the hard-process record. Therefore,
resonance child particle objects are ignored if they have more than one
parent.
<<Particles: particle set: TBP>>=
procedure :: fill_interaction => particle_set_fill_interaction
<<Particles: sub interfaces>>=
module subroutine particle_set_fill_interaction &
(pset, int, n_in, recover_beams, check_match, state_flv, success)
class(particle_set_t), intent(in) :: pset
type(interaction_t), intent(inout) :: int
integer, intent(in) :: n_in
logical, intent(in), optional :: recover_beams, check_match
type(state_flv_content_t), intent(in), optional :: state_flv
logical, intent(out), optional :: success
end subroutine particle_set_fill_interaction
<<Particles: procedures>>=
module subroutine particle_set_fill_interaction &
(pset, int, n_in, recover_beams, check_match, state_flv, success)
class(particle_set_t), intent(in) :: pset
type(interaction_t), intent(inout) :: int
integer, intent(in) :: n_in
logical, intent(in), optional :: recover_beams, check_match
type(state_flv_content_t), intent(in), optional :: state_flv
logical, intent(out), optional :: success
integer, dimension(:), allocatable :: map, pdg
integer, dimension(:), allocatable :: i_in, i_out, p_in, p_out
logical, dimension(:), allocatable :: i_set
integer :: n_out, i, p
logical :: r_beams, check
r_beams = .false.; if (present (recover_beams)) r_beams = recover_beams
check = .true.; if (present (check_match)) check = check_match
if (check) then
call find_hard_process_in_int (i_in, i_out)
call find_hard_process_in_pset (p_in, p_out, state_flv, success)
if (present (success)) then
if (size (i_in) /= n_in) success = .false.
if (size (p_in) /= n_in) success = .false.
if (size (p_out) /= n_out) success = .false.
if (.not. success) return
else
if (size (i_in) /= n_in) call err_int_n_in
if (size (p_in) /= n_in) call err_pset_n_in
if (size (p_out) /= n_out) call err_pset_n_out
end if
call extract_hard_process_from_pset (pdg)
call determine_map_for_hard_process (map, state_flv, success)
if (present (success)) then
if (.not. success) return
end if
call map_handle_duplicates (map)
if (.not. r_beams) then
call determine_map_for_beams (map)
call map_handle_duplicates (map)
call determine_map_for_radiation (map, i_in, p_in)
call map_handle_duplicates (map)
end if
else
allocate (map (int%get_n_tot ()))
map = [(i, i = 1, size (map))]
r_beams = .false.
end if
allocate (i_set (int%get_n_tot ()), source = .false.)
do p = 1, size (map)
if (map(p) /= 0) then
if (.not. i_set(map(p))) then
call int%set_momentum (pset%prt(p)%get_momentum (), map(p))
i_set(map(p)) = .true.
end if
end if
end do
if (r_beams) then
do i = 1, n_in
call reconstruct_beam_and_radiation (i, i_set)
end do
else
do i = int%get_n_tot (), 1, -1
if (.not. i_set(i)) call reconstruct_missing (i, i_set)
end do
end if
if (any (.not. i_set)) then
if (present (success)) then
success = .false.
else
call err_map
end if
end if
contains
subroutine find_hard_process_in_int (i_in, i_out)
integer, dimension(:), allocatable, intent(out) :: i_in, i_out
integer :: n_in_i
integer :: i
i = int%get_n_tot ()
n_in_i = int%get_n_parents (i)
if (n_in_i /= n_in) call err_int_n_in
allocate (i_in (n_in))
i_in = int%get_parents (i)
i = i_in(1)
n_out = int%get_n_children (i)
allocate (i_out (n_out))
i_out = int%get_children (i)
end subroutine find_hard_process_in_int
subroutine find_hard_process_in_pset (p_in, p_out, state_flv, success)
integer, dimension(:), allocatable, intent(out) :: p_in, p_out
type(state_flv_content_t), intent(in), optional :: state_flv
logical, intent(out), optional :: success
integer, dimension(:), allocatable :: p_status, p_idx, p_child
integer :: n_out_p, n_child, n_shift
integer :: i, k, c
allocate (p_status (pset%n_tot), p_idx (pset%n_tot), p_child (pset%n_tot))
p_status = pset%prt%get_status ()
p_idx = [(i, i = 1, pset%n_tot)]
allocate (p_in (n_in))
p_in = pack (p_idx, p_status == PRT_INCOMING)
if (size (p_in) == 0) call err_pset_hard
i = p_in(1)
allocate (p_out (n_out))
n_out_p = pset%prt(i)%get_n_children ()
p_out(1:n_out_p) = particle_get_children (pset%prt(i))
do k = 1, size (p_out)
i = p_out(k)
if (present (state_flv)) then
do while (pset%prt(i)%get_status () == PRT_RESONANT)
if (state_flv%contains (pset%prt(i)%get_pdg ())) exit
n_child = pset%prt(i)%get_n_children ()
p_child(1:n_child) = particle_get_children (pset%prt(i))
n_shift = -1
do c = 1, n_child
if (pset%prt(p_child(c))%get_n_parents () == 1) then
n_shift = n_shift + 1
else
p_child(c) = 0
end if
end do
if (n_shift < 0) then
if (present (success)) then
success = .false.
return
else
call err_mismatch
end if
end if
p_out(k+1+n_shift:n_out_p+n_shift) = p_out(k+1:n_out_p)
n_out_p = n_out_p + n_shift
do c = 1, n_child
if (p_child(c) /= 0) then
p_out(k+c-1) = p_child(c)
end if
end do
i = p_out(k)
end do
end if
end do
if (present (success)) success = .true.
end subroutine find_hard_process_in_pset
subroutine extract_hard_process_from_pset (pdg)
integer, dimension(:), allocatable, intent(out) :: pdg
integer, dimension(:), allocatable :: pdg_p
logical, dimension(:), allocatable :: mask_p
integer :: i
allocate (pdg_p (pset%n_tot))
pdg_p = pset%prt%get_pdg ()
allocate (mask_p (pset%n_tot), source = .false.)
mask_p (p_in) = .true.
mask_p (p_out) = .true.
allocate (pdg (n_in + n_out))
pdg = pack (pdg_p, mask_p)
end subroutine extract_hard_process_from_pset
subroutine determine_map_for_hard_process (map, state_flv, success)
integer, dimension(:), allocatable, intent(out) :: map
type(state_flv_content_t), intent(in), optional :: state_flv
logical, intent(out), optional :: success
integer, dimension(:), allocatable :: pdg_i, map_i
integer :: n_tot
logical, dimension(:), allocatable :: mask_i, mask_p
logical :: match
n_tot = int%get_n_tot ()
if (present (state_flv)) then
allocate (mask_i (n_tot), source = .false.)
mask_i (i_in) = .true.
mask_i (i_out) = .true.
allocate (pdg_i (n_tot), map_i (n_tot))
pdg_i = unpack (pdg, mask_i, 0)
call state_flv%match (pdg_i, match, map_i)
if (present (success)) then
success = match
end if
if (.not. match) then
if (present (success)) then
return
else
call err_mismatch
end if
end if
allocate (mask_p (pset%n_tot), source = .false.)
mask_p (p_in) = .true.
mask_p (p_out) = .true.
allocate (map (size (mask_p)), &
source = unpack (pack (map_i, mask_i), mask_p, 0))
else
allocate (map (n_tot), source = 0)
map(p_in) = i_in
map(p_out) = i_out
end if
end subroutine determine_map_for_hard_process
subroutine map_handle_duplicates (map)
integer, dimension(:), intent(inout) :: map
integer, dimension(1) :: p_parent, p_child
integer :: p
do p = 1, pset%n_tot
if (map(p) == 0) then
if (pset%prt(p)%get_n_parents () == 1) then
p_parent = pset%prt(p)%get_parents ()
if (map(p_parent(1)) /= 0) then
if (pset%prt(p_parent(1))%get_n_children () == 1) then
map(p) = map(p_parent(1))
end if
end if
end if
end if
end do
do p = pset%n_tot, 1, -1
if (map(p) == 0) then
if (pset%prt(p)%get_n_children () == 1) then
p_child = pset%prt(p)%get_children ()
if (map(p_child(1)) /= 0) then
if (pset%prt(p_child(1))%get_n_parents () == 1) then
map(p) = map(p_child(1))
end if
end if
end if
end if
end do
end subroutine map_handle_duplicates
subroutine determine_map_for_beams (map)
integer, dimension(:), intent(inout) :: map
select case (n_in)
case (1); map(1) = 1
case (2); map(1:2) = [1,2]
end select
end subroutine determine_map_for_beams
subroutine determine_map_for_radiation (map, i_in, p_in)
integer, dimension(:), intent(inout) :: map
integer, dimension(:), intent(in) :: i_in
integer, dimension(:), intent(in) :: p_in
integer, dimension(:), allocatable :: i_cur, p_cur
integer, dimension(:), allocatable :: i_par, p_par, i_rad, p_rad
integer :: i, p
integer :: b, r
i_cur = i_in
p_cur = p_in
do b = 1, n_in
i = i_cur(b)
p = p_cur(b)
i_par = int%get_parents (i)
p_par = pset%prt(p)%get_parents ()
if (size (i_par) == 0 .or. size (p_par) == 0) cycle
if (size (p_par) == 1) then
if (pset%prt(p_par(1))%get_n_children () == 1) then
p_par = pset%prt(p_par(1))%get_parents () ! copy of entry
end if
end if
i_rad = int%get_children (i_par(1))
p_rad = pset%prt(p_par(1))%get_children ()
do r = 1, size (i_rad)
if (any (map == i_rad(r))) i_rad(r) = 0
end do
i_rad = pack (i_rad, i_rad /= 0)
do r = 1, size (p_rad)
if (map(p_rad(r)) /= 0) p_rad(r) = 0
end do
p_rad = pack (p_rad, p_rad /= 0)
do r = 1, min (size (i_rad), size (p_rad))
map(p_rad(r)) = i_rad(r)
end do
end do
do b = 1, min (size (p_par), size (i_par))
if (map(p_par(b)) == 0 .and. all (map /= i_par(b))) then
map(p_par(b)) = i_par(b)
end if
end do
end subroutine determine_map_for_radiation
subroutine reconstruct_beam_and_radiation (k, i_set)
integer, intent(in) :: k
logical, dimension(:), intent(inout) :: i_set
integer :: k_src, k_pre, k_in, k_rad
type(interaction_t), pointer :: int_src
integer, dimension(2) :: i_child
logical, dimension(2) :: is_final
integer :: i
call int%find_source (k, int_src, k_src)
k_pre = 0
k_in = k
do while (.not. i_set (k_in))
if (k_pre == 0) then
call int%set_momentum (int_src%get_momentum (k_src), k_in)
else
call int%set_momentum (int%get_momentum (k_pre), k_in)
end if
i_set(k_in) = .true.
if (n_in == 2) then
k_pre = k_in
i_child = int%get_children (k_pre)
do i = 1, 2
is_final(i) = int%get_n_children (i_child(i)) == 0
end do
if (all (.not. is_final)) then
k_in = i_child(k); k_rad = 0
else if (is_final(2)) then
k_in = i_child(1); k_rad = i_child(2)
else if (is_final(1)) then
k_in = i_child(2); k_rad = i_child(1)
else
call err_beams
end if
if (k_rad /= 0) then
if (i_set (k_in)) then
call int%set_momentum &
(int%get_momentum (k) - int%get_momentum (k_in), k_rad)
i_set(k_rad) = .true.
else
call err_beams_norad
end if
end if
end if
end do
end subroutine reconstruct_beam_and_radiation
subroutine reconstruct_missing (i, i_set)
integer, intent(in) :: i
logical, dimension(:), intent(inout) :: i_set
integer, dimension(:), allocatable :: i_child, i_parent, i_sibling
integer :: s
i_child = int%get_children (i)
i_parent = int%get_parents (i)
if (size (i_child) > 0 .and. all (i_set(i_child))) then
call int%set_momentum (sum (int%get_momenta (i_child)), i)
else if (size (i_parent) > 0 .and. all (i_set(i_parent))) then
i_sibling = int%get_children (i_parent(1))
call int%set_momentum (sum (int%get_momenta (i_parent)), i)
do s = 1, size (i_sibling)
if (i_sibling(s) == i) cycle
if (i_set(i_sibling(s))) then
call int%set_momentum (int%get_momentum (i) &
- int%get_momentum (i_sibling(s)), i)
else
call err_beams_norad
end if
end do
else
call err_beams_norad
end if
i_set(i) = .true.
end subroutine reconstruct_missing
subroutine err_pset_hard
call msg_fatal ("Reading particle set: no particles marked as incoming")
end subroutine err_pset_hard
subroutine err_int_n_in
integer :: n
if (allocated (i_in)) then
n = size (i_in)
else
n = 0
end if
write (msg_buffer, "(A,I0,A,I0)") &
"Filling hard process from particle set: expect ", n_in, &
" incoming particle(s), found ", n
call msg_bug
end subroutine err_int_n_in
subroutine err_pset_n_in
write (msg_buffer, "(A,I0,A,I0)") &
"Reading hard-process particle set: should contain ", n_in, &
" incoming particle(s), found ", size (p_in)
call msg_fatal
end subroutine err_pset_n_in
subroutine err_pset_n_out
write (msg_buffer, "(A,I0,A,I0)") &
"Reading hard-process particle set: should contain ", n_out, &
" outgoing particle(s), found ", size (p_out)
call msg_fatal
end subroutine err_pset_n_out
subroutine err_mismatch
call pset%write ()
call state_flv%write ()
call msg_fatal ("Reading particle set: Flavor combination " &
// "does not match requested process")
end subroutine err_mismatch
subroutine err_map
call pset%write ()
call int%basic_write ()
call msg_fatal ("Reading hard-process particle set: " &
// "Incomplete mapping from particle set to interaction")
end subroutine err_map
subroutine err_beams
call pset%write ()
call int%basic_write ()
call msg_fatal ("Reading particle set: Beam structure " &
// "does not match requested process")
end subroutine err_beams
subroutine err_beams_norad
call pset%write ()
call int%basic_write ()
call msg_fatal ("Reading particle set: Beam structure " &
// "cannot be reconstructed for this configuration")
end subroutine err_beams_norad
subroutine err_radiation
call int%basic_write ()
call msg_bug ("Reading particle set: Interaction " &
// "contains inconsistent radiation pattern.")
end subroutine err_radiation
end subroutine particle_set_fill_interaction
@ %def particle_set_fill_interaction
@
This procedure reconstructs an array of vertex indices from the
parent-child information in the particle entries, according to the
HepMC scheme. For each particle, we determine which vertex it comes
from and which vertex it goes to. We return the two arrays and the
maximum vertex index.
For each particle in the list, we first check its parents. If for any
parent the vertex where it goes to is already known, this vertex index
is assigned as the current 'from' vertex. Otherwise, a new index is
created, assigned as the current 'from' vertex, and as the 'to' vertex
for all parents.
Then, the analogous procedure is done for the children.
Furthermore, we assign to each vertex the vertex position from the
parent(s). We check that these vertex positions coincide, and if not
return a null vector.
<<Particles: particle set: TBP>>=
procedure :: assign_vertices => particle_set_assign_vertices
<<Particles: sub interfaces>>=
module subroutine particle_set_assign_vertices &
(particle_set, v_from, v_to, n_vertices)
class(particle_set_t), intent(in) :: particle_set
integer, dimension(:), intent(out) :: v_from, v_to
integer, intent(out) :: n_vertices
end subroutine particle_set_assign_vertices
<<Particles: procedures>>=
module subroutine particle_set_assign_vertices &
(particle_set, v_from, v_to, n_vertices)
class(particle_set_t), intent(in) :: particle_set
integer, dimension(:), intent(out) :: v_from, v_to
integer, intent(out) :: n_vertices
integer, dimension(:), allocatable :: parent, child
integer :: n_parents, n_children, vf, vt
integer :: i, j, v
v_from = 0
v_to = 0
vf = 0
vt = 0
do i = 1, particle_set%n_tot
n_parents = particle_set%prt(i)%get_n_parents ()
if (n_parents /= 0) then
allocate (parent (n_parents))
parent = particle_set%prt(i)%get_parents ()
SCAN_PARENTS: do j = 1, size (parent)
v = v_to(parent(j))
if (v /= 0) then
v_from(i) = v; exit SCAN_PARENTS
end if
end do SCAN_PARENTS
if (v_from(i) == 0) then
vf = vf + 1; v_from(i) = vf
v_to(parent) = vf
end if
deallocate (parent)
end if
n_children = particle_set%prt(i)%get_n_children ()
if (n_children /= 0) then
allocate (child (n_children))
child = particle_set%prt(i)%get_children ()
SCAN_CHILDREN: do j = 1, size (child)
v = v_from(child(j))
if (v /= 0) then
v_to(i) = v; exit SCAN_CHILDREN
end if
end do SCAN_CHILDREN
if (v_to(i) == 0) then
vt = vt + 1; v_to(i) = vt
v_from(child) = vt
end if
deallocate (child)
end if
end do
n_vertices = max (vf, vt)
end subroutine particle_set_assign_vertices
@ %def particle_set_assign_vertices
@
\subsection{Expression interface}
This converts a [[particle_set]] object as defined here to a more
concise [[subevt]] object that can be used as the event root of an
expression. In particular, the latter lacks virtual particles, spin
correlations and parent-child relations.
We keep beam particles, incoming partons, and outgoing partons.
Furthermore, we keep radiated particles (a.k.a.\ beam remnants) if
they have no children in the current particle set, and mark them as
outgoing particles.
If [[colorize]] is set and true, mark all particles in the subevent as
colorized, and set color/anticolor flow indices where they are defined.
Colorless particles do not get indices but are still marked as colorized, for
consistency.
<<Particles: particle set: TBP>>=
procedure :: to_subevt => particle_set_to_subevt
<<Particles: sub interfaces>>=
module subroutine particle_set_to_subevt (particle_set, subevt, colorize)
class(particle_set_t), intent(in) :: particle_set
type(subevt_t), intent(out) :: subevt
logical, intent(in), optional :: colorize
end subroutine particle_set_to_subevt
<<Particles: procedures>>=
module subroutine particle_set_to_subevt (particle_set, subevt, colorize)
class(particle_set_t), intent(in) :: particle_set
type(subevt_t), intent(out) :: subevt
logical, intent(in), optional :: colorize
integer :: n_tot, n_beam, n_in, n_out, n_rad
integer :: i, k, n_active
integer, dimension(2) :: hel
logical :: keep
n_tot = particle_set_get_n_tot (particle_set)
n_beam = particle_set_get_n_beam (particle_set)
n_in = particle_set_get_n_in (particle_set)
n_out = particle_set_get_n_out (particle_set)
n_rad = particle_set_get_n_remnants (particle_set)
call subevt_init (subevt, n_beam + n_rad + n_in + n_out)
k = 0
do i = 1, n_tot
associate (prt => particle_set%prt(i))
keep = .false.
select case (particle_get_status (prt))
case (PRT_BEAM)
k = k + 1
call subevt%set_beam (k, &
particle_get_pdg (prt), &
particle_get_momentum (prt), &
particle_get_p2 (prt))
keep = .true.
case (PRT_INCOMING)
k = k + 1
call subevt%set_incoming (k, &
particle_get_pdg (prt), &
particle_get_momentum (prt), &
particle_get_p2 (prt))
keep = .true.
case (PRT_OUTGOING)
k = k + 1
call subevt%set_outgoing (k, &
particle_get_pdg (prt), &
particle_get_momentum (prt), &
particle_get_p2 (prt))
keep = .true.
case (PRT_BEAM_REMNANT)
if (prt%get_n_children () == 0) then
k = k + 1
call subevt%set_outgoing (k, &
particle_get_pdg (prt), &
particle_get_momentum (prt), &
particle_get_p2 (prt))
keep = .true.
end if
end select
if (keep) then
if (prt%polarization == PRT_DEFINITE_HELICITY) then
if (prt%hel%is_diagonal ()) then
hel = prt%hel%to_pair ()
call subevt_polarize (subevt, k, hel(1))
end if
end if
end if
if (present (colorize)) then
if (colorize) then
call subevt_colorize &
(subevt, i, prt%col%get_col (), prt%col%get_acl ())
end if
end if
end associate
n_active = k
end do
call subevt%reset (n_active)
end subroutine particle_set_to_subevt
@ %def particle_set_to_subevt
@
This replaces the [[particle\_set\%prt array]] with a given array of particles
<<Particles: particle set: TBP>>=
procedure :: replace => particle_set_replace
<<Particles: sub interfaces>>=
module subroutine particle_set_replace (particle_set, newprt)
class(particle_set_t), intent(inout) :: particle_set
type(particle_t), intent(in), dimension(:), allocatable :: newprt
end subroutine particle_set_replace
<<Particles: procedures>>=
module subroutine particle_set_replace (particle_set, newprt)
class(particle_set_t), intent(inout) :: particle_set
type(particle_t), intent(in), dimension(:), allocatable :: newprt
if (allocated (particle_set%prt)) deallocate (particle_set%prt)
allocate (particle_set%prt(size (newprt)))
particle_set%prt = newprt
particle_set%n_tot = size (newprt)
particle_set%n_beam = count (particle_get_status (newprt) == PRT_BEAM)
particle_set%n_in = count (particle_get_status (newprt) == PRT_INCOMING)
particle_set%n_out = count (particle_get_status (newprt) == PRT_OUTGOING)
particle_set%n_vir = particle_set%n_tot &
- particle_set%n_beam - particle_set%n_in - particle_set%n_out
end subroutine particle_set_replace
@ %def particle_set_replace
@ This routines orders the outgoing particles into clusters of
colorless particles and such of particles ordered corresponding to the
indices of the color lines. All outgoing particles in the ordered set
appear as child of the corresponding outgoing particle in the
unordered set, including colored beam remnants. We always start
continue via the anti-color line, such that color flows within each
Lund string system is always continued from the anticolor of one
particle to the identical color index of another particle.
<<Particles: particle set: TBP>>=
procedure :: order_color_lines => particle_set_order_color_lines
<<Particles: sub interfaces>>=
module subroutine particle_set_order_color_lines (pset_out, pset_in)
class(particle_set_t), intent(inout) :: pset_out
type(particle_set_t), intent(in) :: pset_in
end subroutine particle_set_order_color_lines
<<Particles: procedures>>=
module subroutine particle_set_order_color_lines (pset_out, pset_in)
class(particle_set_t), intent(inout) :: pset_out
type(particle_set_t), intent(in) :: pset_in
integer :: i, n, n_col_rem
n_col_rem = 0
do i = 1, pset_in%n_tot
if (pset_in%prt(i)%get_status () == PRT_BEAM_REMNANT .and. &
any (pset_in%prt(i)%get_color () /= 0)) then
n_col_rem = n_col_rem + 1
end if
end do
pset_out%n_beam = pset_in%n_beam
pset_out%n_in = pset_in%n_in
pset_out%n_vir = pset_in%n_vir + pset_in%n_out + n_col_rem
pset_out%n_out = pset_in%n_out
pset_out%n_tot = pset_in%n_tot + pset_in%n_out + n_col_rem
pset_out%correlated_state = pset_in%correlated_state
pset_out%factorization_mode = pset_in%factorization_mode
allocate (pset_out%prt (pset_out%n_tot))
do i = 1, pset_in%n_tot
call pset_out%prt(i)%init (pset_in%prt(i))
call pset_out%prt(i)%set_children (pset_in%prt(i)%child)
call pset_out%prt(i)%set_parents (pset_in%prt(i)%parent)
end do
n = pset_in%n_tot
do i = 1, pset_in%n_tot
if (pset_out%prt(i)%get_status () == PRT_OUTGOING .and. &
all (pset_out%prt(i)%get_color () == 0) .and. &
.not. pset_out%prt(i)%has_children ()) then
n = n + 1
call pset_out%prt(n)%init (pset_out%prt(i))
call pset_out%prt(i)%reset_status (PRT_VIRTUAL)
call pset_out%prt(i)%add_child (n)
call pset_out%prt(i)%set_parents ([i])
end if
end do
if (n_col_rem > 0) then
do i = 1, n_col_rem
end do
end if
end subroutine particle_set_order_color_lines
@ %def particle_set_order_color_lines
@
Eliminate numerical noise
<<Particles: public>>=
public :: pacify
<<Particles: interfaces>>=
interface pacify
module procedure pacify_particle
module procedure pacify_particle_set
end interface pacify
<<Particles: sub interfaces>>=
module subroutine pacify_particle (prt)
class(particle_t), intent(inout) :: prt
end subroutine pacify_particle
module subroutine pacify_particle_set (pset)
class(particle_set_t), intent(inout) :: pset
end subroutine pacify_particle_set
<<Particles: procedures>>=
module subroutine pacify_particle (prt)
class(particle_t), intent(inout) :: prt
real(default) :: e
e = epsilon (1._default) * energy (prt%p)
call pacify (prt%p, 10 * e)
call pacify (prt%p2, 1e4 * e)
end subroutine pacify_particle
module subroutine pacify_particle_set (pset)
class(particle_set_t), intent(inout) :: pset
integer :: i
do i = 1, pset%n_tot
call pacify (pset%prt(i))
end do
end subroutine pacify_particle_set
@ %def pacify
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[particles_ut.f90]]>>=
<<File header>>
module particles_ut
use unit_tests
use particles_uti
<<Standard module head>>
<<Particles: public test>>
contains
<<Particles: test driver>>
end module particles_ut
@ %def particles_ut
@
<<[[particles_uti.f90]]>>=
<<File header>>
module particles_uti
<<Use kinds>>
use io_units
use numeric_utils
use constants, only: one, tiny_07
use lorentz
use flavors
use colors
use helicities
use quantum_numbers
use state_matrices
use interactions
use evaluators
use model_data
use subevents
use particles
<<Standard module head>>
<<Particles: test declarations>>
contains
<<Particles: tests>>
<<Particles: test auxiliary>>
end module particles_uti
@ %def particles_ut
@ API: driver for the unit tests below.
<<Particles: public test>>=
public :: particles_test
<<Particles: test driver>>=
subroutine particles_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Particles: execute tests>>
end subroutine particles_test
@ %def particles_test
@
Check the basic setup of the [[particle_set_t]] type:
Set up a chain of production and decay and factorize the result into
particles. The process is $d\bar d \to Z \to q\bar q$.
<<Particles: execute tests>>=
call test (particles_1, "particles_1", &
"check particle_set routines", &
u, results)
<<Particles: test declarations>>=
public :: particles_1
<<Particles: tests>>=
subroutine particles_1 (u)
use os_interface
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t), dimension(3) :: flv
type(color_t), dimension(3) :: col
type(helicity_t), dimension(3) :: hel
type(quantum_numbers_t), dimension(3) :: qn
type(vector4_t), dimension(3) :: p
type(interaction_t), target :: int1, int2
type(quantum_numbers_mask_t) :: qn_mask_conn
type(evaluator_t), target :: eval
type(interaction_t) :: int
type(particle_set_t) :: particle_set1, particle_set2
type(particle_set_t) :: particle_set3, particle_set4
type(subevt_t) :: subevt
logical :: ok
integer :: unit, iostat
write (u, "(A)") "* Test output: Particles"
write (u, "(A)") "* Purpose: test particle_set routines"
write (u, "(A)")
write (u, "(A)") "* Reading model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Initializing production process"
call int1%basic_init (2, 0, 1, set_relations=.true.)
call flv%init ([1, -1, 23], model)
call col%init_col_acl ([0, 0, 0], [0, 0, 0])
call hel(3)%init (1, 1)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0.25_default, 0._default))
call hel(3)%init (1,-1)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0._default, 0.25_default))
call hel(3)%init (-1, 1)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0._default,-0.25_default))
call hel(3)%init (-1,-1)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0.25_default, 0._default))
call hel(3)%init (0, 0)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0.5_default, 0._default))
call int1%freeze ()
p(1) = vector4_moving (45._default, 45._default, 3)
p(2) = vector4_moving (45._default,-45._default, 3)
p(3) = p(1) + p(2)
call int1%set_momenta (p)
write (u, "(A)")
write (u, "(A)") "* Setup decay process"
call int2%basic_init (1, 0, 2, set_relations=.true.)
call flv%init ([23, 1, -1], model)
call col%init_col_acl ([0, 501, 0], [0, 0, 501])
call hel%init ([1, 1, 1], [1, 1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(1._default, 0._default))
call hel%init ([1, 1, 1], [-1,-1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(0._default, 0.1_default))
call hel%init ([-1,-1,-1], [1, 1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(0._default,-0.1_default))
call hel%init ([-1,-1,-1], [-1,-1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(1._default, 0._default))
call hel%init ([0, 1,-1], [0, 1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(4._default, 0._default))
call hel%init ([0,-1, 1], [0, 1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(2._default, 0._default))
call hel%init ([0, 1,-1], [0,-1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(2._default, 0._default))
call hel%init ([0,-1, 1], [0,-1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(4._default, 0._default))
call flv%init ([23, 2, -2], model)
call hel%init ([0, 1,-1], [0, 1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(0.5_default, 0._default))
call hel%init ([0,-1, 1], [0,-1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(0.5_default, 0._default))
call int2%freeze ()
p(2) = vector4_moving (45._default, 45._default, 2)
p(3) = vector4_moving (45._default,-45._default, 2)
call int2%set_momenta (p)
call int2%set_source_link (1, int1, 3)
call int1%basic_write (u)
call int2%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Concatenate production and decay"
call eval%init_product (int1, int2, qn_mask_conn, &
connections_are_resonant=.true.)
call eval%receive_momenta ()
call eval%evaluate ()
call eval%write (u)
write (u, "(A)")
write (u, "(A)") "* Factorize as subevent (complete, polarized)"
write (u, "(A)")
int = eval%interaction_t
call particle_set1%init &
(ok, int, int, FM_FACTOR_HELICITY, &
[0.2_default, 0.2_default], .false., .true.)
call particle_set1%write (u)
write (u, "(A)")
write (u, "(A)") "* Factorize as subevent (in/out only, selected helicity)"
write (u, "(A)")
int = eval%interaction_t
call particle_set2%init &
(ok, int, int, FM_SELECT_HELICITY, &
[0.9_default, 0.9_default], .false., .false.)
call particle_set2%write (u)
call particle_set2%final ()
write (u, "(A)")
write (u, "(A)") "* Factorize as subevent (complete, selected helicity)"
write (u, "(A)")
int = eval%interaction_t
call particle_set2%init &
(ok, int, int, FM_SELECT_HELICITY, &
[0.7_default, 0.7_default], .false., .true.)
call particle_set2%write (u)
write (u, "(A)")
write (u, "(A)") &
"* Factorize (complete, polarized, correlated); write and read again"
write (u, "(A)")
int = eval%interaction_t
call particle_set3%init &
(ok, int, int, FM_FACTOR_HELICITY, &
[0.7_default, 0.7_default], .true., .true.)
call particle_set3%write (u)
unit = free_unit ()
open (unit, action="readwrite", form="unformatted", status="scratch")
call particle_set3%write_raw (unit)
rewind (unit)
call particle_set4%read_raw (unit, iostat=iostat)
call particle_set4%set_model (model)
close (unit)
write (u, "(A)")
write (u, "(A)") "* Result from reading"
write (u, "(A)")
call particle_set4%write (u)
write (u, "(A)")
write (u, "(A)") "* Transform to a subevt object"
write (u, "(A)")
call particle_set4%to_subevt (subevt)
call subevt%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call particle_set1%final ()
call particle_set2%final ()
call particle_set3%final ()
call particle_set4%final ()
call eval%final ()
call int1%final ()
call int2%final ()
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: particles_1"
end subroutine particles_1
@ %def particles_1
@
Reconstruct a hard interaction from a particle set.
<<Particles: execute tests>>=
call test (particles_2, "particles_2", &
"reconstruct hard interaction", &
u, results)
<<Particles: test declarations>>=
public :: particles_2
<<Particles: tests>>=
subroutine particles_2 (u)
integer, intent(in) :: u
type(interaction_t) :: int
type(state_flv_content_t) :: state_flv
type(particle_set_t) :: pset
type(flavor_t), dimension(:), allocatable :: flv
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: i, j
write (u, "(A)") "* Test output: Particles"
write (u, "(A)") "* Purpose: reconstruct simple interaction"
write (u, "(A)")
write (u, "(A)") "* Set up a 2 -> 3 interaction"
write (u, "(A)") " + incoming partons marked as virtual"
write (u, "(A)") " + no quantum numbers"
write (u, "(A)")
call reset_interaction_counter ()
call int%basic_init (0, 2, 3)
do i = 1, 2
do j = 3, 5
call int%relate (i, j)
end do
end do
allocate (qn (5))
call int%add_state (qn)
call int%freeze ()
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Manually set up a flavor-content record"
write (u, "(A)")
call state_flv%init (1, &
mask = [.false., .false., .true., .true., .true.])
call state_flv%set_entry (1, &
pdg = [11, 12, 3, 4, 5], &
map = [1, 2, 3, 4, 5])
call state_flv%write (u)
write (u, "(A)")
write (u, "(A)") "* Manually create a matching particle set"
write (u, "(A)")
pset%n_beam = 0
pset%n_in = 2
pset%n_vir = 0
pset%n_out = 3
pset%n_tot = 5
allocate (pset%prt (pset%n_tot))
do i = 1, 2
call pset%prt(i)%reset_status (PRT_INCOMING)
call pset%prt(i)%set_children ([3,4,5])
end do
do i = 3, 5
call pset%prt(i)%reset_status (PRT_OUTGOING)
call pset%prt(i)%set_parents ([1,2])
end do
call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
call pset%prt(3)%set_momentum (vector4_at_rest (5._default))
call pset%prt(4)%set_momentum (vector4_at_rest (4._default))
call pset%prt(5)%set_momentum (vector4_at_rest (3._default))
allocate (flv (5))
call flv%init ([11,12,5,4,3])
do i = 1, 5
call pset%prt(i)%set_flavor (flv(i))
end do
call pset%write (u)
write (u, "(A)")
write (u, "(A)") "* Fill interaction from particle set"
write (u, "(A)")
call pset%fill_interaction (int, 2, state_flv=state_flv)
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call int%final ()
call pset%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: particles_2"
end subroutine particles_2
@ %def particles_2
@
Reconstruct an interaction with beam structure, e.g., a hadronic
interaction, from a particle set.
<<Particles: execute tests>>=
call test (particles_3, "particles_3", &
"reconstruct interaction with beam structure", &
u, results)
<<Particles: test declarations>>=
public :: particles_3
<<Particles: tests>>=
subroutine particles_3 (u)
integer, intent(in) :: u
type(interaction_t) :: int
type(state_flv_content_t) :: state_flv
type(particle_set_t) :: pset
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: i, j
write (u, "(A)") "* Test output: Particles"
write (u, "(A)") "* Purpose: reconstruct simple interaction"
write (u, "(A)")
write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation"
write (u, "(A)") " + no quantum numbers"
write (u, "(A)")
call reset_interaction_counter ()
call int%basic_init (0, 6, 3)
call int%relate (1, 3)
call int%relate (1, 4)
call int%relate (2, 5)
call int%relate (2, 6)
do i = 4, 6, 2
do j = 7, 9
call int%relate (i, j)
end do
end do
allocate (qn (9))
call int%add_state (qn)
call int%freeze ()
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Manually set up a flavor-content record"
write (u, "(A)")
call state_flv%init (1, &
mask = [.false., .false., .false., .false., .false., .false., &
.true., .true., .true.])
call state_flv%set_entry (1, &
pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
map = [1, 2, 3, 4, 5, 6, 7, 8, 9])
call state_flv%write (u)
write (u, "(A)")
write (u, "(A)") "* Manually create a matching particle set"
write (u, "(A)")
call create_test_particle_set_1 (pset)
call pset%write (u)
write (u, "(A)")
write (u, "(A)") "* Fill interaction from particle set"
write (u, "(A)")
call pset%fill_interaction (int, 2, state_flv=state_flv)
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call int%final ()
call pset%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: particles_3"
end subroutine particles_3
@ %def particles_3
@
<<Particles: test auxiliary>>=
subroutine create_test_particle_set_1 (pset)
type(particle_set_t), intent(out) :: pset
type(flavor_t), dimension(:), allocatable :: flv
integer :: i
pset%n_beam = 2
pset%n_in = 2
pset%n_vir = 2
pset%n_out = 3
pset%n_tot = 9
allocate (pset%prt (pset%n_tot))
call pset%prt(1)%reset_status (PRT_BEAM)
call pset%prt(2)%reset_status (PRT_BEAM)
call pset%prt(3)%reset_status (PRT_INCOMING)
call pset%prt(4)%reset_status (PRT_INCOMING)
call pset%prt(5)%reset_status (PRT_BEAM_REMNANT)
call pset%prt(6)%reset_status (PRT_BEAM_REMNANT)
call pset%prt(7)%reset_status (PRT_OUTGOING)
call pset%prt(8)%reset_status (PRT_OUTGOING)
call pset%prt(9)%reset_status (PRT_OUTGOING)
call pset%prt(1)%set_children ([3,5])
call pset%prt(2)%set_children ([4,6])
call pset%prt(3)%set_children ([7,8,9])
call pset%prt(4)%set_children ([7,8,9])
call pset%prt(3)%set_parents ([1])
call pset%prt(4)%set_parents ([2])
call pset%prt(5)%set_parents ([1])
call pset%prt(6)%set_parents ([2])
call pset%prt(7)%set_parents ([3,4])
call pset%prt(8)%set_parents ([3,4])
call pset%prt(9)%set_parents ([3,4])
call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
call pset%prt(3)%set_momentum (vector4_at_rest (4._default))
call pset%prt(4)%set_momentum (vector4_at_rest (6._default))
call pset%prt(5)%set_momentum (vector4_at_rest (3._default))
call pset%prt(6)%set_momentum (vector4_at_rest (5._default))
call pset%prt(7)%set_momentum (vector4_at_rest (7._default))
call pset%prt(8)%set_momentum (vector4_at_rest (8._default))
call pset%prt(9)%set_momentum (vector4_at_rest (9._default))
allocate (flv (9))
call flv%init ([2011, 2012, 11, 12, 91, 92, 3, 4, 5])
do i = 1, 9
call pset%prt(i)%set_flavor (flv(i))
end do
end subroutine create_test_particle_set_1
@ %def create_test_particle_set_1
@
Reconstruct an interaction with beam structure, e.g., a hadronic
interaction, from a particle set that is missing the beam information.
<<Particles: execute tests>>=
call test (particles_4, "particles_4", &
"reconstruct interaction with missing beams", &
u, results)
<<Particles: test declarations>>=
public :: particles_4
<<Particles: tests>>=
subroutine particles_4 (u)
integer, intent(in) :: u
type(interaction_t) :: int
type(interaction_t), target :: int_beams
type(state_flv_content_t) :: state_flv
type(particle_set_t) :: pset
type(flavor_t), dimension(:), allocatable :: flv
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: i, j
write (u, "(A)") "* Test output: Particles"
write (u, "(A)") "* Purpose: reconstruct beams"
write (u, "(A)")
call reset_interaction_counter ()
write (u, "(A)") "* Set up an interaction that contains beams only"
write (u, "(A)")
call int_beams%basic_init (0, 0, 2)
call int_beams%set_momentum (vector4_at_rest (1._default), 1)
call int_beams%set_momentum (vector4_at_rest (2._default), 2)
allocate (qn (2))
call int_beams%add_state (qn)
call int_beams%freeze ()
call int_beams%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation"
write (u, "(A)") " + no quantum numbers"
write (u, "(A)")
call int%basic_init (0, 6, 3)
call int%relate (1, 3)
call int%relate (1, 4)
call int%relate (2, 5)
call int%relate (2, 6)
do i = 4, 6, 2
do j = 7, 9
call int%relate (i, j)
end do
end do
do i = 1, 2
call int%set_source_link (i, int_beams, i)
end do
deallocate (qn)
allocate (qn (9))
call int%add_state (qn)
call int%freeze ()
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Manually set up a flavor-content record"
write (u, "(A)")
call state_flv%init (1, &
mask = [.false., .false., .false., .false., .false., .false., &
.true., .true., .true.])
call state_flv%set_entry (1, &
pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
map = [1, 2, 3, 4, 5, 6, 7, 8, 9])
call state_flv%write (u)
write (u, "(A)")
write (u, "(A)") "* Manually create a matching particle set"
write (u, "(A)")
pset%n_beam = 0
pset%n_in = 2
pset%n_vir = 0
pset%n_out = 3
pset%n_tot = 5
allocate (pset%prt (pset%n_tot))
call pset%prt(1)%reset_status (PRT_INCOMING)
call pset%prt(2)%reset_status (PRT_INCOMING)
call pset%prt(3)%reset_status (PRT_OUTGOING)
call pset%prt(4)%reset_status (PRT_OUTGOING)
call pset%prt(5)%reset_status (PRT_OUTGOING)
call pset%prt(1)%set_children ([3,4,5])
call pset%prt(2)%set_children ([3,4,5])
call pset%prt(3)%set_parents ([1,2])
call pset%prt(4)%set_parents ([1,2])
call pset%prt(5)%set_parents ([1,2])
call pset%prt(1)%set_momentum (vector4_at_rest (6._default))
call pset%prt(2)%set_momentum (vector4_at_rest (6._default))
call pset%prt(3)%set_momentum (vector4_at_rest (3._default))
call pset%prt(4)%set_momentum (vector4_at_rest (4._default))
call pset%prt(5)%set_momentum (vector4_at_rest (5._default))
allocate (flv (5))
call flv%init ([11, 12, 3, 4, 5])
do i = 1, 5
call pset%prt(i)%set_flavor (flv(i))
end do
call pset%write (u)
write (u, "(A)")
write (u, "(A)") "* Fill interaction from particle set"
write (u, "(A)")
call pset%fill_interaction (int, 2, state_flv=state_flv, &
recover_beams = .true.)
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call int%final ()
call pset%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: particles_4"
end subroutine particles_4
@ %def particles_4
@
Reconstruct an interaction with beam structure and cloned particles
(radiated particles repeated in the event record, to maintain some
canonical ordering).
<<Particles: execute tests>>=
call test (particles_5, "particles_5", &
"reconstruct interaction with beams and duplicate entries", &
u, results)
<<Particles: test declarations>>=
public :: particles_5
<<Particles: tests>>=
subroutine particles_5 (u)
integer, intent(in) :: u
type(interaction_t) :: int
type(state_flv_content_t) :: state_flv
type(particle_set_t) :: pset
type(flavor_t), dimension(:), allocatable :: flv
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: i, j
write (u, "(A)") "* Test output: Particles"
write (u, "(A)") "* Purpose: reconstruct event with duplicate entries"
write (u, "(A)")
write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation"
write (u, "(A)") " + no quantum numbers"
write (u, "(A)")
call reset_interaction_counter ()
call int%basic_init (0, 6, 3)
call int%relate (1, 3)
call int%relate (1, 4)
call int%relate (2, 5)
call int%relate (2, 6)
do i = 4, 6, 2
do j = 7, 9
call int%relate (i, j)
end do
end do
allocate (qn (9))
call int%add_state (qn)
call int%freeze ()
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Manually set up a flavor-content record"
write (u, "(A)")
call state_flv%init (1, &
mask = [.false., .false., .false., .false., .false., .false., &
.true., .true., .true.])
call state_flv%set_entry (1, &
pdg = [2011, 2012, 91, 11, 92, 12, 3, 4, 5], &
map = [1, 2, 3, 4, 5, 6, 7, 8, 9])
call state_flv%write (u)
write (u, "(A)")
write (u, "(A)") "* Manually create a matching particle set"
write (u, "(A)")
pset%n_beam = 2
pset%n_in = 2
pset%n_vir = 4
pset%n_out = 5
pset%n_tot = 13
allocate (pset%prt (pset%n_tot))
call pset%prt(1)%reset_status (PRT_BEAM)
call pset%prt(2)%reset_status (PRT_BEAM)
call pset%prt(3)%reset_status (PRT_VIRTUAL)
call pset%prt(4)%reset_status (PRT_VIRTUAL)
call pset%prt(5)%reset_status (PRT_VIRTUAL)
call pset%prt(6)%reset_status (PRT_VIRTUAL)
call pset%prt(7)%reset_status (PRT_INCOMING)
call pset%prt(8)%reset_status (PRT_INCOMING)
call pset%prt( 9)%reset_status (PRT_OUTGOING)
call pset%prt(10)%reset_status (PRT_OUTGOING)
call pset%prt(11)%reset_status (PRT_OUTGOING)
call pset%prt(12)%reset_status (PRT_OUTGOING)
call pset%prt(13)%reset_status (PRT_OUTGOING)
call pset%prt(1)%set_children ([3,4])
call pset%prt(2)%set_children ([5,6])
call pset%prt(3)%set_children ([ 7])
call pset%prt(4)%set_children ([ 9])
call pset%prt(5)%set_children ([ 8])
call pset%prt(6)%set_children ([10])
call pset%prt(7)%set_children ([11,12,13])
call pset%prt(8)%set_children ([11,12,13])
call pset%prt(3)%set_parents ([1])
call pset%prt(4)%set_parents ([1])
call pset%prt(5)%set_parents ([2])
call pset%prt(6)%set_parents ([2])
call pset%prt( 7)%set_parents ([3])
call pset%prt( 8)%set_parents ([5])
call pset%prt( 9)%set_parents ([4])
call pset%prt(10)%set_parents ([6])
call pset%prt(11)%set_parents ([7,8])
call pset%prt(12)%set_parents ([7,8])
call pset%prt(13)%set_parents ([7,8])
call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
call pset%prt(3)%set_momentum (vector4_at_rest (4._default))
call pset%prt(4)%set_momentum (vector4_at_rest (3._default))
call pset%prt(5)%set_momentum (vector4_at_rest (6._default))
call pset%prt(6)%set_momentum (vector4_at_rest (5._default))
call pset%prt(7)%set_momentum (vector4_at_rest (4._default))
call pset%prt(8)%set_momentum (vector4_at_rest (6._default))
call pset%prt( 9)%set_momentum (vector4_at_rest (3._default))
call pset%prt(10)%set_momentum (vector4_at_rest (5._default))
call pset%prt(11)%set_momentum (vector4_at_rest (7._default))
call pset%prt(12)%set_momentum (vector4_at_rest (8._default))
call pset%prt(13)%set_momentum (vector4_at_rest (9._default))
allocate (flv (13))
call flv%init ([2011, 2012, 11, 91, 12, 92, 11, 12, 91, 92, 3, 4, 5])
do i = 1, 13
call pset%prt(i)%set_flavor (flv(i))
end do
call pset%write (u)
write (u, "(A)")
write (u, "(A)") "* Fill interaction from particle set"
write (u, "(A)")
call pset%fill_interaction (int, 2, state_flv=state_flv)
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call int%final ()
call pset%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: particles_5"
end subroutine particles_5
@ %def particles_5
@
Reconstruct an interaction with pair spectrum, e.g., beamstrahlung from a
particle set.
<<Particles: execute tests>>=
call test (particles_6, "particles_6", &
"reconstruct interaction with pair spectrum", &
u, results)
<<Particles: test declarations>>=
public :: particles_6
<<Particles: tests>>=
subroutine particles_6 (u)
integer, intent(in) :: u
type(interaction_t) :: int
type(state_flv_content_t) :: state_flv
type(particle_set_t) :: pset
type(flavor_t), dimension(:), allocatable :: flv
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: i, j
write (u, "(A)") "* Test output: Particles"
write (u, "(A)") "* Purpose: reconstruct interaction with pair spectrum"
write (u, "(A)")
write (u, "(A)") "* Set up a 2 -> 2 -> 3 interaction with radiation"
write (u, "(A)") " + no quantum numbers"
write (u, "(A)")
call reset_interaction_counter ()
call int%basic_init (0, 6, 3)
do i = 1, 2
do j = 3, 6
call int%relate (i, j)
end do
end do
do i = 5, 6
do j = 7, 9
call int%relate (i, j)
end do
end do
allocate (qn (9))
call int%add_state (qn)
call int%freeze ()
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Manually set up a flavor-content record"
write (u, "(A)")
call state_flv%init (1, &
mask = [.false., .false., .false., .false., .false., .false., &
.true., .true., .true.])
call state_flv%set_entry (1, &
pdg = [1011, 1012, 21, 22, 11, 12, 3, 4, 5], &
map = [1, 2, 3, 4, 5, 6, 7, 8, 9])
call state_flv%write (u)
write (u, "(A)")
write (u, "(A)") "* Manually create a matching particle set"
write (u, "(A)")
pset%n_beam = 2
pset%n_in = 2
pset%n_vir = 2
pset%n_out = 3
pset%n_tot = 9
allocate (pset%prt (pset%n_tot))
call pset%prt(1)%reset_status (PRT_BEAM)
call pset%prt(2)%reset_status (PRT_BEAM)
call pset%prt(3)%reset_status (PRT_INCOMING)
call pset%prt(4)%reset_status (PRT_INCOMING)
call pset%prt(5)%reset_status (PRT_OUTGOING)
call pset%prt(6)%reset_status (PRT_OUTGOING)
call pset%prt(7)%reset_status (PRT_OUTGOING)
call pset%prt(8)%reset_status (PRT_OUTGOING)
call pset%prt(9)%reset_status (PRT_OUTGOING)
call pset%prt(1)%set_children ([3,4,5,6])
call pset%prt(2)%set_children ([3,4,5,6])
call pset%prt(3)%set_children ([7,8,9])
call pset%prt(4)%set_children ([7,8,9])
call pset%prt(3)%set_parents ([1,2])
call pset%prt(4)%set_parents ([1,2])
call pset%prt(5)%set_parents ([1,2])
call pset%prt(6)%set_parents ([1,2])
call pset%prt(7)%set_parents ([3,4])
call pset%prt(8)%set_parents ([3,4])
call pset%prt(9)%set_parents ([3,4])
call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
call pset%prt(2)%set_momentum (vector4_at_rest (2._default))
call pset%prt(3)%set_momentum (vector4_at_rest (5._default))
call pset%prt(4)%set_momentum (vector4_at_rest (6._default))
call pset%prt(5)%set_momentum (vector4_at_rest (3._default))
call pset%prt(6)%set_momentum (vector4_at_rest (4._default))
call pset%prt(7)%set_momentum (vector4_at_rest (7._default))
call pset%prt(8)%set_momentum (vector4_at_rest (8._default))
call pset%prt(9)%set_momentum (vector4_at_rest (9._default))
allocate (flv (9))
call flv%init ([1011, 1012, 11, 12, 21, 22, 3, 4, 5])
do i = 1, 9
call pset%prt(i)%set_flavor (flv(i))
end do
call pset%write (u)
write (u, "(A)")
write (u, "(A)") "* Fill interaction from particle set"
write (u, "(A)")
call pset%fill_interaction (int, 2, state_flv=state_flv)
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call int%final ()
call pset%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: particles_6"
end subroutine particles_6
@ %def particles_6
@
Reconstruct a hard decay interaction from a shuffled particle set.
<<Particles: execute tests>>=
call test (particles_7, "particles_7", &
"reconstruct decay interaction with reordering", &
u, results)
<<Particles: test declarations>>=
public :: particles_7
<<Particles: tests>>=
subroutine particles_7 (u)
integer, intent(in) :: u
type(interaction_t) :: int
type(state_flv_content_t) :: state_flv
type(particle_set_t) :: pset
type(flavor_t), dimension(:), allocatable :: flv
type(quantum_numbers_t), dimension(:), allocatable :: qn
integer :: i, j
write (u, "(A)") "* Test output: Particles"
write (u, "(A)") "* Purpose: reconstruct decay interaction with reordering"
write (u, "(A)")
write (u, "(A)") "* Set up a 1 -> 3 interaction"
write (u, "(A)") " + no quantum numbers"
write (u, "(A)")
call reset_interaction_counter ()
call int%basic_init (0, 1, 3)
do j = 2, 4
call int%relate (1, j)
end do
allocate (qn (4))
call int%add_state (qn)
call int%freeze ()
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Manually set up a flavor-content record"
write (u, "(A)") "* assumed interaction: 6 12 5 -11"
write (u, "(A)")
call state_flv%init (1, &
mask = [.false., .true., .true., .true.])
call state_flv%set_entry (1, &
pdg = [6, 5, -11, 12], &
map = [1, 4, 2, 3])
call state_flv%write (u)
write (u, "(A)")
write (u, "(A)") "* Manually create a matching particle set"
write (u, "(A)")
pset%n_beam = 0
pset%n_in = 1
pset%n_vir = 0
pset%n_out = 3
pset%n_tot = 4
allocate (pset%prt (pset%n_tot))
do i = 1, 1
call pset%prt(i)%reset_status (PRT_INCOMING)
call pset%prt(i)%set_children ([2,3,4])
end do
do i = 2, 4
call pset%prt(i)%reset_status (PRT_OUTGOING)
call pset%prt(i)%set_parents ([1])
end do
call pset%prt(1)%set_momentum (vector4_at_rest (1._default))
call pset%prt(2)%set_momentum (vector4_at_rest (3._default))
call pset%prt(3)%set_momentum (vector4_at_rest (2._default))
call pset%prt(4)%set_momentum (vector4_at_rest (4._default))
allocate (flv (4))
call flv%init ([6,5,12,-11])
do i = 1, 4
call pset%prt(i)%set_flavor (flv(i))
end do
call pset%write (u)
write (u, "(A)")
write (u, "(A)") "* Fill interaction from particle set"
write (u, "(A)")
call pset%fill_interaction (int, 1, state_flv=state_flv)
call int%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call int%final ()
call pset%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: particles_7"
end subroutine particles_7
@ %def particles_7
@
<<Particles: execute tests>>=
call test (particles_8, "particles_8", &
"Test functions on particle sets", u, results)
<<Particles: test declarations>>=
public :: particles_8
<<Particles: tests>>=
subroutine particles_8 (u)
integer, intent(in) :: u
type(particle_set_t) :: particle_set
type(particle_t), dimension(:), allocatable :: particles
integer, allocatable, dimension(:) :: children, parents
integer :: n_particles, i
write (u, "(A)") "* Test output: particles_8"
write (u, "(A)") "* Purpose: Test functions on particle sets"
write (u, "(A)")
call create_test_particle_set_1 (particle_set)
call particle_set%write (u)
call assert_equal (u, particle_set%n_tot, 9)
call assert_equal (u, particle_set%n_beam, 2)
allocate (children (particle_set%prt(3)%get_n_children ()))
children = particle_set%prt(3)%get_children()
call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3)
call assert_equal (u, size (particle_set%prt(1)%get_children ()), 2)
call assert_equal (u, size (particle_set%prt(2)%get_children ()), 2)
call particle_set%without_hadronic_remnants &
(particles, n_particles, 3)
call particle_set%replace (particles)
write (u, "(A)")
call particle_set%write (u)
call assert_equal (u, n_particles, 7)
call assert_equal (u, size(particles), 10)
call assert_equal (u, particle_set%n_tot, 10)
call assert_equal (u, particle_set%n_beam, 2)
do i = 3, 4
if (allocated (children)) deallocate (children)
allocate (children (particle_set%prt(i)%get_n_children ()))
children = particle_set%prt(i)%get_children()
call assert_equal (u, particle_set%prt(children(1))%get_pdg (), 3)
call assert_equal (u, particle_set%prt(children(2))%get_pdg (), 4)
call assert_equal (u, particle_set%prt(children(3))%get_pdg (), 5)
end do
do i = 5, 7
if (allocated (parents)) deallocate (parents)
allocate (parents (particle_set%prt(i)%get_n_parents ()))
parents = particle_set%prt(i)%get_parents()
call assert_equal (u, particle_set%prt(parents(1))%get_pdg (), 11)
call assert_equal (u, particle_set%prt(parents(2))%get_pdg (), 12)
end do
call assert_equal (u, size (particle_set%prt(1)%get_children ()), &
1, "get children of 1")
call assert_equal (u, size (particle_set%prt(2)%get_children ()), &
1, "get children of 2")
call assert_equal (u, particle_set%find_particle &
(particle_set%prt(1)%get_pdg (), particle_set%prt(1)%p), &
1, "find 1st particle")
call assert_equal (u, particle_set%find_particle &
(particle_set%prt(2)%get_pdg (), particle_set%prt(2)%p * &
(one + tiny_07), rel_smallness=1.0E-6_default), &
2, "find 2nd particle fuzzy")
write (u, "(A)")
write (u, "(A)") "* Test output end: particles_8"
end subroutine particles_8
@ %def particles_8
@
Order color lines into Lund string systems, without colored beam
remnants first.
<<Particles: execute tests>>=
call test (particles_9, "particles_9", &
"order into Lund strings, uncolored beam remnants", &
u, results)
<<Particles: test declarations>>=
public :: particles_9
<<Particles: tests>>=
subroutine particles_9 (u)
integer, intent(in) :: u
write (u, "(A)") "* Test output: particles_9"
write (u, "(A)") "* Purpose: Order into Lund strings, "
write (u, "(A)") "* uncolored beam remnants"
write (u, "(A)")
end subroutine particles_9
@ %def particles_9

File Metadata

Mime Type
text/x-diff
Expires
Sun, Feb 23, 2:40 PM (22 h, 40 m)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
4486675
Default Alt Text
(350 KB)

Event Timeline