Page MenuHomeHEPForge
Files F7877687

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
Index: trunk/src/particles/Makefile.am
===================================================================
--- trunk/src/particles/Makefile.am (revision 8780)
+++ trunk/src/particles/Makefile.am (revision 8781)
@@ -1,204 +1,221 @@
## Makefile.am -- Makefile for WHIZARD
##
## Process this file with automake to produce Makefile.in
#
# Copyright (C) 1999-2022 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# with contributions from
# cf. main AUTHORS file
#
# WHIZARD is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# WHIZARD is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
########################################################################
## The files in this directory implement quantum field theory concepts
## such as model representation and quantum numbers.
## We create a library which is still to be combined with auxiliary libs.
noinst_LTLIBRARIES = libparticles.la
check_LTLIBRARIES = libparticles_ut.la
libparticles_la_SOURCES = \
+ $(PARTICLES_MODULES) \
+ $(PARTICLES_SUBMODULES)
+
+PARTICLES_MODULES = \
su_algebra.f90 \
bloch_vectors.f90 \
polarizations.f90 \
particles.f90
+PARTICLES_SUBMODULES = \
+ su_algebra_sub.f90 \
+ bloch_vectors_sub.f90 \
+ polarizations_sub.f90 \
+ particles_sub.f90
+
libparticles_ut_la_SOURCES = \
su_algebra_uti.f90 su_algebra_ut.f90 \
bloch_vectors_uti.f90 bloch_vectors_ut.f90 \
polarizations_uti.f90 polarizations_ut.f90 \
particles_uti.f90 particles_ut.f90
## Omitting this would exclude it from the distribution
dist_noinst_DATA = particles.nw
# Modules and installation
# Dump module names into file Modules
execmoddir = $(fmoddir)/whizard
nodist_execmod_HEADERS = \
- ${libparticles_la_SOURCES:.f90=.$(FCMOD)}
+ ${PARTICLES_MODULES:.f90=.$(FCMOD)}
+# Submodules must not be included here
libparticles_Modules = \
- ${libparticles_la_SOURCES:.f90=} \
+ ${PARTICLES_MODULES:.f90=} \
${libparticles_ut_la_SOURCES:.f90=}
Modules: Makefile
@for module in $(libparticles_Modules); do \
echo $$module >> $@.new; \
done
@if diff $@ $@.new -q >/dev/null; then \
rm $@.new; \
else \
mv $@.new $@; echo "Modules updated"; \
fi
BUILT_SOURCES = Modules
## Fortran module dependencies
# Get module lists from other directories
module_lists = \
../basics/Modules \
../utilities/Modules \
../testing/Modules \
../system/Modules \
../physics/Modules \
../qft/Modules \
../types/Modules
$(module_lists):
$(MAKE) -C `dirname $@` Modules
Module_dependencies.sed: $(libparticles_la_SOURCES) $(libparticles_ut_la_SOURCES)
Module_dependencies.sed: $(module_lists)
@rm -f $@
echo 's/, *only:.*//' >> $@
echo 's/, *&//' >> $@
echo 's/, *.*=>.*//' >> $@
echo 's/$$/.lo/' >> $@
for list in $(module_lists); do \
dir="`dirname $$list`"; \
for mod in `cat $$list`; do \
echo 's!: '$$mod'.lo$$!': $$dir/$$mod'.lo!' >> $@; \
done \
done
DISTCLEANFILES = Module_dependencies.sed
# The following line just says
# include Makefile.depend
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
@am__include@ @am__quote@Makefile.depend@am__quote@
Makefile.depend: Module_dependencies.sed
Makefile.depend: $(libparticles_la_SOURCES) $(libparticles_ut_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-f Module_dependencies.sed; \
done > $@
DISTCLEANFILES += Makefile.depend
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
AM_FCFLAGS = -I../basics -I../utilities -I../testing -I../system -I../combinatorics -I../physics -I../fastjet -I../qft -I../types
+########################################################################
+# For the moment, the submodule dependencies will be hard-coded
+su_algebra_sub.lo: su_algebra.lo
+bloch_vectors_sub.lo: bloch_vectors.lo
+polarizations_sub.lo: polarizations.lo
+particles_sub.lo: particles.lo
########################################################################
## Default Fortran compiler options
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
# MPI
if FC_USE_MPI
AM_FCFLAGS += $(FCFLAGS_MPI)
endif
########################################################################
## Non-standard targets and dependencies
## (Re)create F90 sources from NOWEB source.
if NOWEB_AVAILABLE
PRELUDE = $(top_srcdir)/src/noweb-frame/whizard-prelude.nw
POSTLUDE = $(top_srcdir)/src/noweb-frame/whizard-postlude.nw
particles.stamp: $(PRELUDE) $(srcdir)/particles.nw $(POSTLUDE)
@rm -f particles.tmp
@touch particles.tmp
for src in \
$(libparticles_la_SOURCES) \
$(libparticles_ut_la_SOURCES); do \
$(NOTANGLE) -R[[$$src]] $^ | $(CPIF) $$src; \
done
@mv -f particles.tmp particles.stamp
$(libparticles_la_SOURCES) $(libparticles_ut_la_SOURCES): particles.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f particles.stamp; \
$(MAKE) $(AM_MAKEFLAGS) particles.stamp; \
fi
endif
########################################################################
## Non-standard cleanup tasks
## Remove sources that can be recreated using NOWEB
if NOWEB_AVAILABLE
maintainer-clean-noweb:
-rm -f *.f90 *.c
endif
.PHONY: maintainer-clean-noweb
## Remove those sources also if builddir and srcdir are different
if NOWEB_AVAILABLE
clean-noweb:
test "$(srcdir)" != "." && rm -f *.f90 *.c || true
endif
.PHONY: clean-noweb
## Remove F90 module files
clean-local: clean-noweb
-rm -f particles.stamp particles.tmp
-rm -f *.$(FCMOD)
if FC_SUBMODULES
- -rm -f *.smod
+ -rm -f *.smod *.sub
endif
## Remove backup files
maintainer-clean-backup:
-rm -f *~
.PHONY: maintainer-clean-backup
## Register additional clean targets
maintainer-clean-local: maintainer-clean-noweb maintainer-clean-backup
Index: trunk/src/particles/particles.nw
===================================================================
--- trunk/src/particles/particles.nw (revision 8780)
+++ trunk/src/particles/particles.nw (revision 8781)
@@ -1,8523 +1,9556 @@
%% -*- 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>>
- use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
<<Standard module head>>
-<<su algebra: public>>
-
-contains
+<<SU algebra: public>>
-<<su algebra: procedures>>
+ 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>>=
+<<SU algebra: public>>=
public :: algebra_dimension
-<<su algebra: procedures>>=
- function algebra_dimension (s) result (n)
+<<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>>=
+<<SU algebra: public>>=
public :: fundamental_dimension
-<<su algebra: procedures>>=
- function fundamental_dimension (s) result (d)
+<<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>>=
+<<SU algebra: public>>=
public :: helicity_value
-<<su algebra: procedures>>=
- function helicity_value (s, i) result (h)
+<<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>>=
+<<SU algebra: public>>=
public :: helicity_index
-<<su algebra: procedures>>=
- function helicity_index (s, h) result (i)
+<<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>>=
+<<SU algebra: public>>=
public :: is_cartan_generator
-<<su algebra: procedures>>=
- elemental function is_cartan_generator (s, i) result (cartan)
+<<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>>=
+<<SU algebra: public>>=
public :: cartan_index
-<<su algebra: procedures>>=
- elemental function cartan_index (s, k) result (ci)
+<<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>>=
+<<SU algebra: public>>=
public :: cartan_element
-<<su algebra: procedures>>=
- function cartan_element (s, h) result (a)
+<<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>>=
+<<SU algebra: public>>=
public :: cartan_coeff
-<<su algebra: procedures>>=
- function cartan_coeff (s, rd) result (a)
+<<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>>=
+<<SU algebra: public>>=
public :: root_index
-<<su algebra: procedures>>=
- function root_index (s, h1, h2, r) result (ai)
+<<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>>=
+<<SU algebra: public>>=
public :: root_helicity
-<<su algebra: procedures>>=
- subroutine root_helicity (s, i, h1, h2, r)
+<<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>>
+<<SU algebra: public test>>
contains
-<<su algebra: test driver>>
+<<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>>
+<<SU algebra: test declarations>>
contains
-<<su algebra: tests>>
+<<SU algebra: tests>>
end module su_algebra_uti
@ %def su_algebra_ut
@ API: driver for the unit tests below.
-<<su algebra: public test>>=
+<<SU algebra: public test>>=
public :: su_algebra_test
-<<su algebra: test driver>>=
+<<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>>
+ <<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>>=
+<<SU algebra: execute tests>>=
call test (su_algebra_1, "su_algebra_1", &
"generator ordering", &
u, results)
-<<su algebra: test declarations>>=
+<<SU algebra: test declarations>>=
public :: su_algebra_1
-<<su algebra: tests>>=
+<<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>>=
+<<SU algebra: execute tests>>=
call test (su_algebra_2, "su_algebra_2", &
"Cartan generator representation", &
u, results)
-<<su algebra: test declarations>>=
+<<SU algebra: test declarations>>=
public :: su_algebra_2
-<<su algebra: tests>>=
+<<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>>=
+<<SU algebra: execute tests>>=
call test (su_algebra_3, "su_algebra_3", &
"Cartan generator mapping", &
u, results)
-<<su algebra: test declarations>>=
+<<SU algebra: test declarations>>=
public :: su_algebra_3
-<<su algebra: tests>>=
+<<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>>=
+<<SU algebra: execute tests>>=
call test (su_algebra_4, "su_algebra_4", &
"Root-helicity mapping", &
u, results)
-<<su algebra: test declarations>>=
+<<SU algebra: test declarations>>=
public :: su_algebra_4
-<<su algebra: tests>>=
+<<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, SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
- use su_algebra
+ 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 module bloch_vectors
-@ %def bloch_vectors
+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>>=
- subroutine bloch_vector_init_unpolarized (pol, spin_type)
+ 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>>=
- subroutine bloch_vector_init (pol, spin_type)
+ 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>>=
- subroutine bloch_vector_from_array (pol, a)
+ 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>>=
- subroutine bloch_vector_to_array (pol, a)
+ 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>>=
- subroutine bloch_vector_write_raw (pol, u)
+ 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
- subroutine bloch_vector_read_raw (pol, u, iostat)
+ 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>>=
- function get_n_states (pol) result (n)
+ 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
- function get_length (pol) result (n)
+ 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
- function bv_helicity_index (pol, h) result (i)
+ 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
- function bv_helicity_value (pol, i) result (h)
+ 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
- function bv_factor (pol) result (f)
+ 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>>=
- function bloch_vector_is_defined (pol) result (flag)
+ 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>>=
- function bloch_vector_is_polarized (pol) result (flag)
+ 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>>=
- function bloch_vector_is_diagonal (pol) result (diagonal)
+ 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>>=
- function bloch_vector_get_norm (pol) result (norm)
+ 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>>=
- subroutine bloch_vector_init_diagonal (pol, spin_type, rd)
+ 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>>=
- subroutine bloch_vector_set_diagonal (pol, rd)
+ 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>>=
- subroutine bloch_vector_init_max_weight (pol, spin_type)
+ 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>>=
- subroutine bloch_vector_init_vector (pol, s, a)
+ 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
- subroutine bloch_vector_to_vector (pol, a)
+ 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>>=
- subroutine bloch_vector_init_matrix (pol, spin_type, r)
+ 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>>=
- subroutine bloch_vector_set_matrix (pol, r)
+ 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>>=
- subroutine bloch_vector_to_matrix (pol, r, only_max_weight)
+ 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 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)
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)
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)
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)
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)
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
@
\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 io_units
- use format_defs, only: FMT_19
- use diagnostics
use physics_defs, only: SCALAR, SPINOR, VECTOR, VECTORSPINOR, TENSOR
use flavors
- use helicities
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 module polarizations
-@ %def polarizations
+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>>=
- subroutine polarization_init (pol, spin_type, multiplicity, &
+ 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
- subroutine polarization_init_flv (pol, flv)
+ 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>>=
- subroutine polarization_init_generic (pol, spin_type, multiplicity, &
+ 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
- subroutine polarization_init_generic_flv (pol, flv)
+ 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>>=
- subroutine polarization_write (pol, unit, state_matrix, all_states, tolerance)
+ 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>>=
- subroutine polarization_write_raw (pol, u)
+ 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
- subroutine polarization_read_raw (pol, u, iostat)
+ 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>>=
- function polarization_is_polarized (pol) result (polarized)
+ 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>>=
- function polarization_is_diagonal (pol) result (diagonal)
+ 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>>=
- subroutine polarization_init_state_matrix (pol, state)
+ 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>>=
- subroutine polarization_to_state_matrix (pol, state, all_states, tolerance)
+ 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>>=
- subroutine polarization_init_unpolarized (pol, flv)
+ 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>>=
- subroutine polarization_init_circular (pol, flv, f)
+ 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>>=
- subroutine polarization_init_transversal (pol, flv, phi, f)
+ 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>>=
- subroutine polarization_init_axis (pol, flv, alpha)
+ 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>>=
- subroutine polarization_init_angles (pol, flv, r, theta, phi)
+ 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>>=
- subroutine polarization_init_longitudinal (pol, flv, f)
+ 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>>=
- subroutine polarization_init_diagonal (pol, flv, rd)
+ 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>>=
- subroutine combine_polarization_states (pol, state)
+ 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>>=
- function polarization_get_axis (pol) result (alpha)
+ 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>>=
- subroutine polarization_to_angles (pol, r, theta, phi)
+ 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>>=
- subroutine polarization_iterator_write (it, unit)
+ 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>>=
- subroutine polarization_iterator_init (it, pol, all_states, tolerance)
+ 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 subroutine polarization_iterator_advance (it)
+ 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>>=
- function polarization_iterator_is_valid (it) result (is_valid)
+ 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>>=
- function polarization_iterator_get_value (it) result (value)
+ 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>>=
- function polarization_iterator_get_quantum_numbers (it) result (qn)
+ 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>>=
- subroutine smatrix_write (object, unit, indent)
+ 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>>=
- subroutine smatrix_init (smatrix, dim, n_entry)
+ 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>>=
- subroutine smatrix_set_entry (smatrix, i, index, value)
+ 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 function smatrix_exists (smatrix) result (exist)
+ 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>>=
- subroutine pmatrix_write (object, unit, indent)
+ 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>>=
- subroutine pmatrix_assign_from_smatrix (pmatrix, smatrix)
+ 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>>=
- subroutine pmatrix_normalize (pmatrix, flv, degree, tolerance)
+ 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 function pmatrix_is_polarized (pmatrix) result (flag)
+ 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 function pmatrix_is_diagonal (pmatrix) result (flag)
+ 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 function pmatrix_get_simple_pol (pmatrix) result (pol)
+ 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>>=
- subroutine polarization_init_pmatrix (pol, pmatrix)
+ 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 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 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
- use pdg_arrays, only: is_quark, is_gluon
<<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 module particles
-@ %def particles
+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>>=
- subroutine particle_init_particle (prt_out, prt_in)
+ 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>>=
- subroutine particle_init_external &
+ 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>>=
- subroutine particle_init_state (prt, state, status, mode)
+ 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>>=
- subroutine particle_final (prt)
+ 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>>=
- subroutine particle_write (prt, unit, testflag, compressed, polarization)
+ 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>>=
- subroutine particle_write_raw (prt, u)
+ 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
- subroutine particle_read_raw (prt, u, iostat)
+ 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 subroutine particle_reset_status (prt, status)
+ 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 subroutine particle_set_color (prt, col)
+ 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>>=
- subroutine particle_set_flavor (prt, flv)
+ 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>>=
- subroutine particle_set_helicity (prt, hel)
+ 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>>=
- subroutine particle_set_pol (prt, pol)
+ 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>>=
- subroutine particle_set_model (prt, model)
+ 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 subroutine particle_set_momentum (prt, p, p2, on_shell)
+ 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.
<<Particle: particle: TBP>>=
procedure :: set_resonance_flag => particle_set_resonance_flag
<<Particles: procedures>>=
elemental 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>>=
- subroutine particle_set_children (prt, idx)
+ 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
- subroutine particle_set_parents (prt, idx)
+ 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>>=
- subroutine particle_add_child (prt, new_child)
+ 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>>=
- subroutine particle_add_children (prt, new_child)
+ 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 subroutine particle_set_status (prt, status)
+ 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>>=
- subroutine particle_set_polarization (prt, polarization)
+ 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>>=
- subroutine particle_set_vertex_from_vector4 (prt, vertex)
+ 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
- subroutine particle_set_vertex_from_vector3 (prt, vertex)
+ 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
- subroutine particle_set_vertex_from_xyzt (prt, vx, vy, vz, t)
+ 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
- subroutine particle_set_vertex_from_xyz (prt, vx, vy, vz)
+ 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 subroutine particle_set_lifetime (prt, lifetime)
+ 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 function particle_get_status (prt) result (status)
+ 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 function particle_is_real (prt, keep_beams) result (flag)
+ 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 function particle_is_colored (particle) result (flag)
+ 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 function particle_is_hadronic_beam_remnant (particle) result (flag)
+ 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 function particle_is_beam_remnant (particle) result (flag)
+ 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 function particle_get_polarization_status (prt) result (status)
+ 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 function particle_get_pdg (prt) result (pdg)
+ 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 function particle_get_color (prt) result (col)
+ 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>>=
- function particle_get_polarization (prt) result (pol)
+ 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>>=
- function particle_get_flv (prt) result (flv)
+ 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
- function particle_get_col (prt) result (col)
+ 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
- function particle_get_hel (prt) result (hel)
+ 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 function particle_get_helicity (prt) result (hel)
+ 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 function particle_get_n_parents (prt) result (n)
+ 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 function particle_get_n_children (prt) result (n)
+ 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>>=
- function particle_get_parents (prt) result (parent)
+ 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
- function particle_get_children (prt) result (child)
+ 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 function particle_has_children (prt) result (has_children)
+ 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 function particle_has_parents (prt) result (has_parents)
+ 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 function particle_get_momentum (prt) result (p)
+ 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 function particle_get_p2 (prt) result (p2)
+ 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 function particle_get_vertex (prt) result (vtx)
+ 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 function particle_get_lifetime (prt) result (lifetime)
+ 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 function particle_momentum_to_pythia6 (prt) result (p)
+ 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>>=
- subroutine particle_set_init_interaction &
+ 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>>=
- subroutine particle_set_init_particle_set (pset_out, pset_in)
+ 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>>=
- subroutine particle_set_set_model (particle_set, model)
+ 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>>=
- subroutine particle_set_final (particle_set)
+ 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>>=
- subroutine particle_set_basic_init (particle_set, n_beam, n_in, n_vir, n_out)
+ 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>>=
- subroutine particle_set_init_direct (particle_set, &
+ 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>>=
- subroutine particle_set_transfer (pset, source, n_new, map)
+ 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>>=
- subroutine particle_set_insert (pset, i, status, flv, child)
+ 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>>=
- subroutine particle_set_recover_color (pset, i)
+ 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>>=
- function particle_set_get_color_all (particle_set) result (col)
+ 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>>=
- 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
+ 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>>=
- subroutine particle_set_set_color_single (particle_set, i, col)
+ 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
- subroutine particle_set_set_color_indices (particle_set, indices, col)
+ 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
- subroutine particle_set_set_color_all (particle_set, col)
+ 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>>=
- subroutine particle_set_find_prt_invalid_color (particle_set, index, prt)
+ 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>>=
- function particle_set_get_momenta_all (particle_set) result (p)
+ 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>>=
- function particle_set_get_momenta_indices (particle_set, indices) result (p)
+ 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>>=
- subroutine particle_set_set_momentum_single &
+ 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
- subroutine particle_set_set_momentum_indices &
+ 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
- subroutine particle_set_set_momentum_all (particle_set, p, p2, on_shell)
+ 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>>=
- subroutine particle_set_recover_momentum (particle_set, i)
+ 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>>=
- subroutine particle_set_replace_incoming_momenta (particle_set, p)
+ 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>>=
- subroutine particle_set_replace_outgoing_momenta (particle_set, p)
+ 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>>=
- function particle_set_get_outgoing_momenta (particle_set) result (p)
+ 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>>=
- subroutine particle_set_parent_add_child (particle_set, parent, child)
+ 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, we update
the [[particle_set]].
<<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>>=
- 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
- integer :: pdg_index_emitter, pdg_index_radiation
- integer, dimension(:), allocatable :: parents, children
- type(flavor_t) :: new_flv
- logical, dimension(:), allocatable :: status_mask
- integer, dimension(:), allocatable :: &
- i_in1, i_beam1, i_remnant1, i_virt1, i_out1
- integer, dimension(:), allocatable :: &
- i_in2, i_beam2, i_remnant2, i_virt2, i_out2
- integer :: n_in1, n_beam1, n_remnant1, n_virt1, n_out1
- integer :: n_in2, n_beam2, n_remnant2, n_virt2, n_out2
- integer :: n, n_tot
- integer :: i_emitter
-
- 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_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_virt2 = n_virt1 + n_out1
- n_out2 = n_out1 + 1
- n_tot = n_in2 + n_beam2 + n_remnant2 + n_virt2 + n_out2
-
- allocate (i_in2 (n_in2), i_beam2 (n_beam2), i_remnant2 (n_remnant2))
- i_in2 = i_in1; i_beam2 = i_beam1; i_remnant2 = i_remnant1
-
- allocate (i_virt2 (n_virt2))
- i_virt2(1 : n_virt1) = i_virt1
- i_virt2(n_virt1 + 1 : n_virt2) = i_out1
-
- allocate (i_out2 (n_out2))
- i_out2(1 : n_out1) = i_out1(1 : n_out1) + 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
- 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)
- do i = 1, n_virt1
- new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_virt1(i))
- end do
-
- do i = n_virt1 + 1, n_virt2
- new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_out1(i - n_virt1))
- call new_particle_set%prt(i_virt2(i))%reset_status (PRT_VIRTUAL)
- 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)
- i_emitter = emitter + n_virt2 + n_remnant2 + n_beam2
-
- call reassign_colors (new_particle, new_particle_set%prt(i_emitter), &
- pdg_index_radiation, pdg_index_emitter, r_color)
-
- call new_particle%set_flavor (new_flv)
- new_particle_set%prt(n_tot) = new_particle
-
- allocate (children (n_out2))
- children = i_out2
- do i = n_in2 + n_beam2 + n_remnant2 + n_virt1 + 1, n_in2 + n_beam2 + n_remnant2 + n_virt2
- call new_particle_set%prt(i)%set_children (children)
- end do
+ 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
+ integer :: pdg_index_emitter, pdg_index_radiation
+ integer, dimension(:), allocatable :: parents, children
+ type(flavor_t) :: new_flv
+ logical, dimension(:), allocatable :: status_mask
+ integer, dimension(:), allocatable :: &
+ i_in1, i_beam1, i_remnant1, i_virt1, i_out1
+ integer, dimension(:), allocatable :: &
+ i_in2, i_beam2, i_remnant2, i_virt2, i_out2
+ integer :: n_in1, n_beam1, n_remnant1, n_virt1, n_out1
+ integer :: n_in2, n_beam2, n_remnant2, n_virt2, n_out2
+ integer :: n, n_tot
+ integer :: i_emitter
- !!! Set proper parents for outgoing particles
- allocate (parents (n_out1))
- parents = i_out1
- do i = n_in2 + n_beam2 + n_remnant2 + n_virt2 + 1, n_tot
- call new_particle_set%prt(i)%set_parents (parents)
- end do
- call particle_set%init (new_particle_set)
+ 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_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_virt2 = n_virt1 + n_out1
+ n_out2 = n_out1 + 1
+ n_tot = n_in2 + n_beam2 + n_remnant2 + n_virt2 + n_out2
+
+ allocate (i_in2 (n_in2), i_beam2 (n_beam2), i_remnant2 (n_remnant2))
+ i_in2 = i_in1; i_beam2 = i_beam1; i_remnant2 = i_remnant1
+
+ allocate (i_virt2 (n_virt2))
+ i_virt2(1 : n_virt1) = i_virt1
+ i_virt2(n_virt1 + 1 : n_virt2) = i_out1
+
+ allocate (i_out2 (n_out2))
+ i_out2(1 : n_out1) = i_out1(1 : n_out1) + 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
+ 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)
+ do i = 1, n_virt1
+ new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_virt1(i))
+ end do
+
+ do i = n_virt1 + 1, n_virt2
+ new_particle_set%prt(i_virt2(i)) = particle_set%prt(i_out1(i - n_virt1))
+ call new_particle_set%prt(i_virt2(i))%reset_status (PRT_VIRTUAL)
+ 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)
+ i_emitter = emitter + n_virt2 + n_remnant2 + n_beam2
+
+ call reassign_colors (new_particle, new_particle_set%prt(i_emitter), &
+ pdg_index_radiation, pdg_index_emitter, r_color)
+
+ call new_particle%set_flavor (new_flv)
+ new_particle_set%prt(n_tot) = new_particle
+
+ allocate (children (n_out2))
+ children = i_out2
+ do i = n_in2 + n_beam2 + n_remnant2 + n_virt1 + 1, n_in2 + n_beam2 + n_remnant2 + n_virt2
+ call new_particle_set%prt(i)%set_children (children)
+ end do
+
+ !!! Set proper parents for outgoing particles
+ allocate (parents (n_out1))
+ parents = i_out1
+ do i = n_in2 + n_beam2 + n_remnant2 + n_virt2 + 1, n_tot
+ call new_particle_set%prt(i)%set_parents (parents)
+ end do
+ call particle_set%init (new_particle_set)
contains
<<build radiation: set color offset>>
subroutine reassign_colors (prt_radiated, prt_emitter, i_rad, i_em, r_col)
type(particle_t), intent(inout) :: prt_radiated, prt_emitter
integer, intent(in) :: i_rad, i_em
real(default), intent(in) :: r_col
type(color_t) :: col_rad, col_em
if (is_quark (i_em) .and. is_gluon (i_rad)) then
call reassign_colors_qg (prt_emitter, col_rad, col_em)
else if (is_gluon (i_em) .and. is_gluon (i_rad)) then
call reassign_colors_gg (prt_emitter, r_col, col_rad, col_em)
else if (is_gluon (i_em) .and. is_quark (i_rad)) then
call reassign_colors_qq (prt_emitter, i_em, col_rad, col_em)
else
call msg_fatal ("Invalid splitting")
end if
call prt_emitter%set_color (col_em)
call prt_radiated%set_color (col_rad)
end subroutine reassign_colors
subroutine reassign_colors_qg (prt_emitter, col_rad, col_em)
type(particle_t), intent(in) :: prt_emitter
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
integer :: new_color_index
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
new_color_index = color_em(i1)+1
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_qg
subroutine reassign_colors_gg (prt_emitter, random, col_rad, col_em)
!!! NOT TESTED YET
type(particle_t), intent(in) :: prt_emitter
real(default), intent(in) :: random
type(color_t), intent(out) :: col_rad, col_em
integer, dimension(2) :: color_rad, color_em
integer :: i1, i2
integer :: new_color_index
color_em = prt_emitter%get_color ()
new_color_index = maxval (abs (color_em))
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_gg
subroutine reassign_colors_qq (prt_emitter, pdg_emitter, col_rad, col_em)
!!! NOT TESTED YET
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_qq
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>>=
- subroutine particle_set_write &
+ 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>>=
- subroutine particle_set_write_raw (particle_set, u)
+ 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
- subroutine particle_set_read_raw (particle_set, u, iostat)
+ 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>>=
- function particle_set_get_real_parents (pset, i, keep_beams) result (parent)
+ 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
- function particle_set_get_real_children (pset, i, keep_beams) result (child)
+ 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>>=
- function particle_set_get_n_beam (pset) result (n_beam)
+ 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
- function particle_set_get_n_in (pset) result (n_in)
+ 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
- function particle_set_get_n_vir (pset) result (n_vir)
+ 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
- function particle_set_get_n_out (pset) result (n_out)
+ 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
- function particle_set_get_n_tot (pset) result (n_tot)
+ 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
- function particle_set_get_n_remnants (pset) result (n_remn)
+ 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>>=
- function particle_set_get_particle (pset, index) result (particle)
+ 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 function particle_set_get_indices (pset, mask) result (finals)
+ 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>>=
- function particle_set_get_in_and_out_momenta (pset) result (phs_point)
+ 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>>=
- subroutine particle_set_without_hadronic_remnants &
+ 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>>=
- subroutine particle_set_without_remnants &
+ 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 function particle_set_find_particle (particle_set, pdg, &
+ 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: procedures>>=
- pure function 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>>=
- subroutine particle_set_remove_duplicates (particle_set, smallness)
+ 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>>=
- subroutine particle_set_reset_status (particle_set, index, status)
+ 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>>=
- subroutine particle_set_reduce (pset_in, pset_out, keep_beams)
+ 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>>=
- subroutine particle_set_filter_particles &
+ 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>>=
- subroutine particle_set_to_hepevt_form (pset_in, pset_out)
+ 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
- integer :: src = 0
- integer :: status = 0
- integer :: orig = 0
- integer :: copy = 0
- end type particle_entry_t
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>>=
- subroutine particle_set_fill_interaction &
+ 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>>=
- subroutine particle_set_assign_vertices &
+ 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>>=
- subroutine particle_set_to_subevt (particle_set, subevt, colorize)
+ 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>>=
- subroutine particle_set_replace (particle_set, newprt)
+ 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>>=
- subroutine particle_set_order_color_lines (pset_out, pset_in)
+ 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>>=
- subroutine pacify_particle (prt)
+ 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
- subroutine pacify_particle_set (pset)
+ 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
Index: trunk/share/debug/Makefile_full
===================================================================
--- trunk/share/debug/Makefile_full (revision 8780)
+++ trunk/share/debug/Makefile_full (revision 8781)
@@ -1,574 +1,580 @@
FC=pgfortran_2019
FCFLAGS=-Mbackslash
CC=gcc
CCFLAGS=
MODELS = \
SM.mdl \
SM_hadrons.mdl \
Test.mdl
CC_SRC = \
sprintf_interface.c \
signal_interface.c
F77_SRC = \
pythia.F \
pythia_pdf.f \
pythia6_up.f \
toppik.f \
toppik_axial.f
FC0_SRC =
FC_SRC = \
format_defs.f90 \
io_units.f90 \
kinds.f90 \
constants.f90 \
iso_varying_string.f90 \
unit_tests.f90 \
unit_tests_sub.f90 \
numeric_utils.f90 \
numeric_utils_sub.f90 \
system_dependencies.f90 \
string_utils.f90 \
string_utils_sub.f90 \
system_defs.f90 \
system_defs_sub.f90 \
debug_master.f90 \
diagnostics.f90 \
diagnostics_sub.f90 \
sorting.f90 \
physics_defs.f90 \
physics_defs_sub.f90 \
pdg_arrays.f90 \
bytes.f90 \
hashes.f90 \
md5.f90 \
model_data.f90 \
model_data_sub.f90 \
auto_components.f90 \
var_base.f90 \
model_testbed.f90 \
auto_components_uti.f90 \
auto_components_ut.f90 \
os_interface.f90 \
os_interface_sub.f90 \
c_particles.f90 \
c_particles_sub.f90 \
format_utils.f90 \
lorentz.f90 \
lorentz_sub.f90 \
phs_points.f90 \
phs_points_sub.f90 \
colors.f90 \
colors_sub.f90 \
flavors.f90 \
flavors_sub.f90 \
helicities.f90 \
helicities_sub.f90 \
quantum_numbers.f90 \
quantum_numbers_sub.f90 \
state_matrices.f90 \
state_matrices_sub.f90 \
interactions.f90 \
interactions_sub.f90 \
CppStringsWrap_dummy.f90 \
FastjetWrap_dummy.f90 \
cpp_strings.f90 \
cpp_strings_sub.f90 \
fastjet.f90 \
fastjet_sub.f90 \
jets.f90 \
subevents.f90 \
su_algebra.f90 \
+ su_algebra_sub.f90 \
bloch_vectors.f90 \
+ bloch_vectors_sub.f90 \
polarizations.f90 \
+ polarizations_sub.f90 \
particles.f90 \
+ particles_sub.f90 \
event_base.f90 \
eio_data.f90 \
event_handles.f90 \
eio_base.f90 \
eio_base_uti.f90 \
eio_base_ut.f90 \
variables.f90 \
rng_base.f90 \
tao_random_numbers.f90 \
rng_tao.f90 \
rng_stream.f90 \
rng_base_uti.f90 \
rng_base_ut.f90 \
dispatch_rng.f90 \
dispatch_rng_uti.f90 \
dispatch_rng_ut.f90 \
beam_structures.f90 \
evaluators.f90 \
evaluators_sub.f90 \
beams.f90 \
sm_physics.f90 \
sm_physics_sub.f90 \
file_registries.f90 \
file_registries_sub.f90 \
sf_aux.f90 \
sf_mappings.f90 \
sf_base.f90 \
electron_pdfs.f90 \
sf_isr.f90 \
sf_epa.f90 \
sf_ewa.f90 \
sf_escan.f90 \
sf_gaussian.f90 \
sf_beam_events.f90 \
circe1.f90 \
sf_circe1.f90 \
circe2.f90 \
selectors.f90 \
sf_circe2.f90 \
sm_qcd.f90 \
sm_qcd_sub.f90 \
sm_qed.f90 \
sm_qed_sub.f90 \
mrst2004qed.f90 \
cteq6pdf.f90 \
mstwpdf.f90 \
ct10pdf.f90 \
CJpdf.f90 \
ct14pdf.f90 \
pdf_builtin.f90 \
pdf_builtin_sub.f90 \
LHAPDFWrap_dummy.f90 \
lhapdf5_full_dummy.f90 \
lhapdf5_has_photon_dummy.f90 \
lhapdf.f90 \
hoppet_dummy.f90 \
hoppet_interface.f90 \
sf_pdf_builtin.f90 \
sf_lhapdf.f90 \
dispatch_beams.f90 \
process_constants.f90 \
prclib_interfaces.f90 \
prc_core_def.f90 \
particle_specifiers.f90 \
process_libraries.f90 \
prc_test.f90 \
prc_core.f90 \
prc_test_core.f90 \
sm_qed.f90 \
prc_omega.f90 \
phs_base.f90 \
ifiles.f90 \
lexers.f90 \
syntax_rules.f90 \
parser.f90 \
expr_base.f90 \
formats.f90 \
formats_sub.f90 \
analysis.f90 \
user_code_interface.f90 \
observables.f90 \
eval_trees.f90 \
interpolation.f90 \
+ interpolation_sub.f90 \
nr_tools.f90 \
ttv_formfactors.f90 \
+ ttv_formfactors_use.f90 \
ttv_formfactors_uti.f90 \
ttv_formfactors_ut.f90 \
models.f90 \
prclib_stacks.f90 \
user_files.f90 \
cputime.f90 \
cputime_sub.f90 \
mci_base.f90 \
integration_results.f90 \
integration_results_uti.f90 \
integration_results_ut.f90 \
mappings.f90 \
permutations.f90 \
resonances.f90 \
phs_trees.f90 \
phs_forests.f90 \
prc_external.f90 \
blha_config.f90 \
blha_olp_interfaces.f90 \
prc_openloops.f90 \
prc_threshold.f90 \
process_config.f90 \
process_counter.f90 \
process_mci.f90 \
pcm_base.f90 \
nlo_data.f90 \
cascades.f90 \
cascades2_lexer.f90 \
cascades2_lexer_uti.f90 \
cascades2_lexer_ut.f90 \
cascades2.f90 \
cascades2_uti.f90 \
cascades2_ut.f90 \
phs_none.f90 \
phs_rambo.f90 \
phs_wood.f90 \
phs_fks.f90 \
phs_single.f90 \
fks_regions.f90 \
virtual.f90 \
pdf.f90 \
real_subtraction.f90 \
dglap_remnant.f90 \
dispatch_fks.f90 \
dispatch_phase_space.f90 \
pcm.f90 \
recola_wrapper_dummy.f90 \
prc_recola.f90 \
subevt_expr.f90 \
parton_states.f90 \
prc_template_me.f90 \
process.f90 \
process_stacks.f90 \
iterations.f90 \
rt_data.f90 \
file_utils.f90 \
file_utils_sub.f90 \
prc_gosam.f90 \
dispatch_me_methods.f90 \
sf_base_uti.f90 \
sf_base_ut.f90 \
dispatch_uti.f90 \
dispatch_ut.f90 \
formats_uti.f90 \
formats_ut.f90 \
md5_uti.f90 \
md5_ut.f90 \
os_interface_uti.f90 \
os_interface_ut.f90 \
sorting_uti.f90 \
sorting_ut.f90 \
grids.f90 \
grids_uti.f90 \
grids_ut.f90 \
solver.f90 \
solver_uti.f90 \
solver_ut.f90 \
cputime_uti.f90 \
cputime_ut.f90 \
sm_qcd_uti.f90 \
sm_qcd_ut.f90 \
sm_physics_uti.f90 \
sm_physics_ut.f90 \
lexers_uti.f90 \
lexers_ut.f90 \
parser_uti.f90 \
parser_ut.f90 \
xml.f90 \
xml_uti.f90 \
xml_ut.f90 \
colors_uti.f90 \
colors_ut.f90 \
state_matrices_uti.f90 \
state_matrices_ut.f90 \
analysis_uti.f90 \
analysis_ut.f90 \
particles_uti.f90 \
particles_ut.f90 \
radiation_generator.f90 \
radiation_generator_uti.f90 \
radiation_generator_ut.f90 \
blha_uti.f90 \
blha_ut.f90 \
evaluators_uti.f90 \
evaluators_ut.f90 \
models_uti.f90 \
models_ut.f90 \
eval_trees_uti.f90 \
eval_trees_ut.f90 \
resonances_uti.f90 \
resonances_ut.f90 \
phs_trees_uti.f90 \
phs_trees_ut.f90 \
phs_forests_uti.f90 \
phs_forests_ut.f90 \
beams_uti.f90 \
beams_ut.f90 \
su_algebra_uti.f90 \
su_algebra_ut.f90 \
bloch_vectors_uti.f90 \
bloch_vectors_ut.f90 \
polarizations_uti.f90 \
polarizations_ut.f90 \
sf_aux_uti.f90 \
sf_aux_ut.f90 \
sf_mappings_uti.f90 \
sf_mappings_ut.f90 \
sf_pdf_builtin_uti.f90 \
sf_pdf_builtin_ut.f90 \
sf_lhapdf_uti.f90 \
sf_lhapdf_ut.f90 \
sf_isr_uti.f90 \
sf_isr_ut.f90 \
sf_epa_uti.f90 \
sf_epa_ut.f90 \
sf_ewa_uti.f90 \
sf_ewa_ut.f90 \
sf_circe1_uti.f90 \
sf_circe1_ut.f90 \
sf_circe2_uti.f90 \
sf_circe2_ut.f90 \
sf_gaussian_uti.f90 \
sf_gaussian_ut.f90 \
sf_beam_events_uti.f90 \
sf_beam_events_ut.f90 \
sf_escan_uti.f90 \
sf_escan_ut.f90 \
phs_base_uti.f90 \
phs_base_ut.f90 \
phs_none_uti.f90 \
phs_none_ut.f90 \
phs_single_uti.f90 \
phs_single_ut.f90 \
phs_rambo_uti.f90 \
phs_rambo_ut.f90 \
phs_wood_uti.f90 \
phs_wood_ut.f90 \
phs_fks_uti.f90 \
phs_fks_ut.f90 \
fks_regions_uti.f90 \
fks_regions_ut.f90 \
mci_midpoint.f90 \
mci_base_uti.f90 \
mci_base_ut.f90 \
mci_midpoint_uti.f90 \
mci_midpoint_ut.f90 \
kinematics.f90 \
instances.f90 \
mci_none.f90 \
mci_none_uti.f90 \
mci_none_ut.f90 \
processes_uti.f90 \
processes_ut.f90 \
process_stacks_uti.f90 \
process_stacks_ut.f90 \
prc_recola_uti.f90 \
prc_recola_ut.f90 \
rng_tao_uti.f90 \
rng_tao_ut.f90 \
rng_stream_uti.f90 \
rng_stream_ut.f90 \
selectors_uti.f90 \
selectors_ut.f90 \
vegas.f90 \
vegas_uti.f90 \
vegas_ut.f90 \
vamp2.f90 \
vamp2_uti.f90 \
vamp2_ut.f90 \
exceptions.f90 \
vamp_stat.f90 \
utils.f90 \
divisions.f90 \
linalg.f90 \
vamp.f90 \
mci_vamp.f90 \
mci_vamp_uti.f90 \
mci_vamp_ut.f90 \
mci_vamp2.f90 \
mci_vamp2_uti.f90 \
mci_vamp2_ut.f90 \
prclib_interfaces_uti.f90 \
prclib_interfaces_ut.f90 \
particle_specifiers_uti.f90 \
particle_specifiers_ut.f90 \
process_libraries_uti.f90 \
process_libraries_ut.f90 \
prclib_stacks_uti.f90 \
prclib_stacks_ut.f90 \
slha_interface.f90 \
slha_interface_uti.f90 \
slha_interface_ut.f90 \
cascades_uti.f90 \
cascades_ut.f90 \
prc_test_uti.f90 \
prc_test_ut.f90 \
prc_template_me_uti.f90 \
prc_template_me_ut.f90 \
prc_omega_uti.f90 \
prc_omega_ut.f90 \
event_transforms.f90 \
event_transforms_uti.f90 \
event_transforms_ut.f90 \
hep_common.f90 \
hepev4_aux.f90 \
tauola_dummy.f90 \
tauola_interface.f90 \
shower_base.f90 \
shower_partons.f90 \
muli.f90 \
matching_base.f90 \
powheg_matching.f90 \
shower_core.f90 \
shower_base_uti.f90 \
shower_base_ut.f90 \
shower.f90 \
shower_uti.f90 \
shower_ut.f90 \
shower_pythia6.f90 \
whizard_lha.f90 \
whizard_lha_uti.f90 \
whizard_lha_ut.f90 \
LHAWhizard_dummy.f90 \
Pythia8Wrap_dummy.f90 \
pythia8.f90 \
pythia8_uti.f90 \
pythia8_ut.f90 \
shower_pythia8.f90 \
hadrons.f90 \
ktclus.f90 \
mlm_matching.f90 \
ckkw_matching.f90 \
jets_uti.f90 \
jets_ut.f90 \
pdg_arrays_uti.f90 \
pdg_arrays_ut.f90 \
interactions_uti.f90 \
interactions_ut.f90 \
decays.f90 \
decays_uti.f90 \
decays_ut.f90 \
evt_nlo.f90 \
events.f90 \
events_uti.f90 \
events_ut.f90 \
HepMCWrap_dummy.f90 \
hepmc_interface.f90 \
hepmc_interface_uti.f90 \
hepmc_interface_ut.f90 \
LCIOWrap_dummy.f90 \
lcio_interface.f90 \
lcio_interface_uti.f90 \
lcio_interface_ut.f90 \
hep_events.f90 \
hep_events_uti.f90 \
hep_events_ut.f90 \
expr_tests_uti.f90 \
expr_tests_ut.f90 \
parton_states_uti.f90 \
parton_states_ut.f90 \
eio_data_uti.f90 \
eio_data_ut.f90 \
eio_raw.f90 \
eio_raw_uti.f90 \
eio_raw_ut.f90 \
eio_checkpoints.f90 \
eio_checkpoints_uti.f90 \
eio_checkpoints_ut.f90 \
eio_lhef.f90 \
eio_lhef_uti.f90 \
eio_lhef_ut.f90 \
eio_hepmc.f90 \
eio_hepmc_uti.f90 \
eio_hepmc_ut.f90 \
eio_lcio.f90 \
eio_lcio_uti.f90 \
eio_lcio_ut.f90 \
stdhep_dummy.f90 \
xdr_wo_stdhep.f90 \
eio_stdhep.f90 \
eio_stdhep_uti.f90 \
eio_stdhep_ut.f90 \
eio_ascii.f90 \
eio_ascii_uti.f90 \
eio_ascii_ut.f90 \
eio_weights.f90 \
eio_weights_uti.f90 \
eio_weights_ut.f90 \
eio_dump.f90 \
eio_dump_uti.f90 \
eio_dump_ut.f90 \
eio_callback.f90 \
real_subtraction_uti.f90 \
real_subtraction_ut.f90 \
iterations_uti.f90 \
iterations_ut.f90 \
rt_data_uti.f90 \
rt_data_ut.f90 \
dispatch_mci.f90 \
dispatch_mci_uti.f90 \
dispatch_mci_ut.f90 \
dispatch_phs_uti.f90 \
dispatch_phs_ut.f90 \
resonance_insertion.f90 \
resonance_insertion_uti.f90 \
resonance_insertion_ut.f90 \
recoil_kinematics.f90 \
recoil_kinematics_uti.f90 \
recoil_kinematics_ut.f90 \
isr_epa_handler.f90 \
isr_epa_handler_uti.f90 \
isr_epa_handler_ut.f90 \
dispatch_transforms.f90 \
dispatch_transforms_uti.f90 \
dispatch_transforms_ut.f90 \
beam_structures_uti.f90 \
beam_structures_ut.f90 \
process_configurations.f90 \
process_configurations_uti.f90 \
process_configurations_ut.f90 \
compilations.f90 \
compilations_uti.f90 \
compilations_ut.f90 \
integrations.f90 \
integrations_uti.f90 \
integrations_ut.f90 \
event_streams.f90 \
event_streams_uti.f90 \
event_streams_ut.f90 \
restricted_subprocesses.f90 \
eio_direct.f90 \
eio_direct_uti.f90 \
eio_direct_ut.f90 \
simulations.f90 \
restricted_subprocesses_uti.f90 \
restricted_subprocesses_ut.f90 \
simulations_uti.f90 \
simulations_ut.f90 \
commands.f90 \
commands_uti.f90 \
commands_ut.f90 \
cmdline_options.f90 \
libmanager.f90 \
features.f90 \
whizard.f90 \
api.f90 \
api_hepmc_uti.f90 \
api_hepmc_ut.f90 \
api_lcio_uti.f90 \
api_lcio_ut.f90 \
api_uti.f90 \
api_ut.f90
FC_OBJ = $(FC0_SRC:.f90=.o) $(F77_SRC:.f=.o) $(FC_SRC:.f90=.o)
CC_OBJ = $(CC_SRC:.c=.o)
all: whizard_test
check: whizard_test
./whizard_test --check resonances
whizard_test: $(FC_OBJ) $(CC_OBJ) main_ut.f90
$(FC) $(FC_OBJ) $(CC_OBJ) -ldl -o $@ main_ut.f90
whizard: $(FC_OBJ) $(CC_OBJ) main.f90
$(FC) $(FC_OBJ) $(CC_OBJ) -ldl -o $@ main.f90
%.o: %.f90
$(FC) $(FCFLAGS) -c $<
%.o: %.f
$(FC) $(FCFLAGS) -c $<
%.o: %.c
$(CC) $(CCFLAGS) -c $<
tar: $(FC_SRC) $(F77_SRC) $(FC0_SRC) $(CC_SRC) $(MODELS)
tar cvvzf whizard-`date +%y%m%d`-`date +%H%M`.tar.gz $(FC_SRC) $(FC0_SRC) \
$(F77_SRC) $(CC_SRC) main_ut.f90 Makefile $(MODELS)
clean:
rm -f *.mod *.o whizard_test

File Metadata

Mime Type
text/x-diff
Expires
Tue, Nov 19, 4:11 PM (1 d, 15 h)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
3805092
Default Alt Text
(379 KB)

Event Timeline