Index: trunk/src/types/types.nw
===================================================================
--- trunk/src/types/types.nw (revision 8512)
+++ trunk/src/types/types.nw (revision 8513)
@@ -1,7993 +1,7993 @@
%% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: common types and objects
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Sindarin Built-In Types}
\includemodulegraph{types}
Here, we define a couple of types and objects which are useful both
internally for \whizard, and visible to the user, so they correspond
to Sindarin types.
\begin{description}
\item[particle\_specifiers]
Expressions for particles and particle alternatives, involving
particle names.
\item[pdg\_arrays]
Integer (PDG) codes for particles. Useful for particle aliases
(e.g., 'quark' for $u,d,s$ etc.).
\item[jets]
Define (pseudo)jets as objects. Functional only if the [[fastjet]] library
is linked. (This may change in the future.)
\item[subevents]
Particle collections built from event records, for use in analysis and other
Sindarin expressions
\item[analysis]
Observables, histograms, and plots.
\end{description}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Particle Specifiers}
In this module we introduce a type for specifying a particle or particle
alternative. In addition to the particle specifiers (strings separated by
colons), the type contains an optional flag [[polarized]] and a string
[[decay]]. If the [[polarized]] flag is set, particle polarization
information should be kept when generating events for this process. If the
[[decay]] string is set, it is the ID of a decay process which should be
applied to this particle when generating events.
In input/output form, the [[polarized]] flag is indicated by an asterisk
[[(*)]] in brackets, and the [[decay]] is indicated by its ID in brackets.
The [[read]] and [[write]] procedures in this module are not type-bound but
generic procedures which handle scalar and array arguments.
<<[[particle_specifiers.f90]]>>=
<<File header>>
module particle_specifiers
<<Use strings>>
use io_units
use diagnostics
<<Standard module head>>
<<Particle specifiers: public>>
<<Particle specifiers: types>>
<<Particle specifiers: interfaces>>
contains
<<Particle specifiers: procedures>>
end module particle_specifiers
@ %def particle_specifiers
@
\subsection{Base type}
This is an abstract type which can hold a single particle or an expression.
<<Particle specifiers: types>>=
type, abstract :: prt_spec_expr_t
contains
<<Particle specifiers: prt spec expr: TBP>>
end type prt_spec_expr_t
@ %def prt_expr_t
@ Output, as a string.
<<Particle specifiers: prt spec expr: TBP>>=
procedure (prt_spec_expr_to_string), deferred :: to_string
<<Particle specifiers: interfaces>>=
abstract interface
function prt_spec_expr_to_string (object) result (string)
import
class(prt_spec_expr_t), intent(in) :: object
type(string_t) :: string
end function prt_spec_expr_to_string
end interface
@ %def prt_spec_expr_to_string
@ Call an [[expand]] method for all enclosed subexpressions (before handling
the current expression).
<<Particle specifiers: prt spec expr: TBP>>=
procedure (prt_spec_expr_expand_sub), deferred :: expand_sub
<<Particle specifiers: interfaces>>=
abstract interface
subroutine prt_spec_expr_expand_sub (object)
import
class(prt_spec_expr_t), intent(inout) :: object
end subroutine prt_spec_expr_expand_sub
end interface
@ %def prt_spec_expr_expand_sub
@
\subsection{Wrapper type}
This wrapper can hold a particle expression of any kind. We need it so we can
make variadic arrays.
<<Particle specifiers: public>>=
public :: prt_expr_t
<<Particle specifiers: types>>=
type :: prt_expr_t
class(prt_spec_expr_t), allocatable :: x
contains
<<Particle specifiers: prt expr: TBP>>
end type prt_expr_t
@ %def prt_expr_t
@ Output as a string: delegate.
<<Particle specifiers: prt expr: TBP>>=
procedure :: to_string => prt_expr_to_string
<<Particle specifiers: procedures>>=
recursive function prt_expr_to_string (object) result (string)
class(prt_expr_t), intent(in) :: object
type(string_t) :: string
if (allocated (object%x)) then
string = object%x%to_string ()
else
string = ""
end if
end function prt_expr_to_string
@ %def prt_expr_to_string
@ Allocate the expression as a particle specifier and copy the value.
<<Particle specifiers: prt expr: TBP>>=
procedure :: init_spec => prt_expr_init_spec
<<Particle specifiers: procedures>>=
subroutine prt_expr_init_spec (object, spec)
class(prt_expr_t), intent(out) :: object
type(prt_spec_t), intent(in) :: spec
allocate (prt_spec_t :: object%x)
select type (x => object%x)
type is (prt_spec_t)
x = spec
end select
end subroutine prt_expr_init_spec
@ %def prt_expr_init_spec
@ Allocate as a list/sum and allocate for a given length
<<Particle specifiers: prt expr: TBP>>=
procedure :: init_list => prt_expr_init_list
procedure :: init_sum => prt_expr_init_sum
<<Particle specifiers: procedures>>=
subroutine prt_expr_init_list (object, n)
class(prt_expr_t), intent(out) :: object
integer, intent(in) :: n
allocate (prt_spec_list_t :: object%x)
select type (x => object%x)
type is (prt_spec_list_t)
allocate (x%expr (n))
end select
end subroutine prt_expr_init_list
subroutine prt_expr_init_sum (object, n)
class(prt_expr_t), intent(out) :: object
integer, intent(in) :: n
allocate (prt_spec_sum_t :: object%x)
select type (x => object%x)
type is (prt_spec_sum_t)
allocate (x%expr (n))
end select
end subroutine prt_expr_init_sum
@ %def prt_expr_init_list
@ %def prt_expr_init_sum
@ Return the number of terms. This is unity, except if the expression is a
sum.
<<Particle specifiers: prt expr: TBP>>=
procedure :: get_n_terms => prt_expr_get_n_terms
<<Particle specifiers: procedures>>=
function prt_expr_get_n_terms (object) result (n)
class(prt_expr_t), intent(in) :: object
integer :: n
if (allocated (object%x)) then
select type (x => object%x)
type is (prt_spec_sum_t)
n = size (x%expr)
class default
n = 1
end select
else
n = 0
end if
end function prt_expr_get_n_terms
@ %def prt_expr_get_n_terms
@ Transform one of the terms, as returned by the previous method, to an array
of particle specifiers. The array has more than one entry if the selected
term is a list. This makes sense only if the expression has been completely
expanded, so the list contains only atoms.
<<Particle specifiers: prt expr: TBP>>=
procedure :: term_to_array => prt_expr_term_to_array
<<Particle specifiers: procedures>>=
recursive subroutine prt_expr_term_to_array (object, array, i)
class(prt_expr_t), intent(in) :: object
type(prt_spec_t), dimension(:), intent(inout), allocatable :: array
integer, intent(in) :: i
integer :: j
if (allocated (array)) deallocate (array)
select type (x => object%x)
type is (prt_spec_t)
allocate (array (1))
array(1) = x
type is (prt_spec_list_t)
allocate (array (size (x%expr)))
do j = 1, size (array)
select type (y => x%expr(j)%x)
type is (prt_spec_t)
array(j) = y
end select
end do
type is (prt_spec_sum_t)
call x%expr(i)%term_to_array (array, 1)
end select
end subroutine prt_expr_term_to_array
@ %def prt_expr_term_to_array
@
\subsection{The atomic type}
The trivial case is a single particle, including optional decay and
polarization attributes.
\subsubsection{Definition}
The particle is unstable if the [[decay]] array is allocated. The
[[polarized]] flag and decays may not be set simultaneously.
<<Particle specifiers: public>>=
public :: prt_spec_t
<<Particle specifiers: types>>=
type, extends (prt_spec_expr_t) :: prt_spec_t
private
type(string_t) :: name
logical :: polarized = .false.
type(string_t), dimension(:), allocatable :: decay
contains
<<Particle specifiers: prt spec: TBP>>
end type prt_spec_t
@ %def prt_spec_t
@
\subsubsection{I/O}
Output. Old-style subroutines.
<<Particle specifiers: public>>=
public :: prt_spec_write
<<Particle specifiers: interfaces>>=
interface prt_spec_write
module procedure prt_spec_write1
module procedure prt_spec_write2
end interface prt_spec_write
<<Particle specifiers: procedures>>=
subroutine prt_spec_write1 (object, unit, advance)
type(prt_spec_t), intent(in) :: object
integer, intent(in), optional :: unit
character(len=*), intent(in), optional :: advance
character(3) :: adv
integer :: u
u = given_output_unit (unit)
adv = "yes"; if (present (advance)) adv = advance
write (u, "(A)", advance = adv) char (object%to_string ())
end subroutine prt_spec_write1
@ %def prt_spec_write1
@ Write an array as a list of particle specifiers.
<<Particle specifiers: procedures>>=
subroutine prt_spec_write2 (prt_spec, unit, advance)
type(prt_spec_t), dimension(:), intent(in) :: prt_spec
integer, intent(in), optional :: unit
character(len=*), intent(in), optional :: advance
character(3) :: adv
integer :: u, i
u = given_output_unit (unit)
adv = "yes"; if (present (advance)) adv = advance
do i = 1, size (prt_spec)
if (i > 1) write (u, "(A)", advance="no") ", "
call prt_spec_write (prt_spec(i), u, advance="no")
end do
write (u, "(A)", advance = adv)
end subroutine prt_spec_write2
@ %def prt_spec_write2
@ Read. Input may be string or array of strings.
<<Particle specifiers: public>>=
public :: prt_spec_read
<<Particle specifiers: interfaces>>=
interface prt_spec_read
module procedure prt_spec_read1
module procedure prt_spec_read2
end interface prt_spec_read
@ Read a single particle specifier
<<Particle specifiers: procedures>>=
pure subroutine prt_spec_read1 (prt_spec, string)
type(prt_spec_t), intent(out) :: prt_spec
type(string_t), intent(in) :: string
type(string_t) :: arg, buffer
integer :: b1, b2, c, n, i
b1 = scan (string, "(")
b2 = scan (string, ")")
if (b1 == 0) then
prt_spec%name = trim (adjustl (string))
else
prt_spec%name = trim (adjustl (extract (string, 1, b1-1)))
arg = trim (adjustl (extract (string, b1+1, b2-1)))
if (arg == "*") then
prt_spec%polarized = .true.
else
n = 0
buffer = arg
do
if (verify (buffer, " ") == 0) exit
n = n + 1
c = scan (buffer, "+")
if (c == 0) exit
buffer = extract (buffer, c+1)
end do
allocate (prt_spec%decay (n))
buffer = arg
do i = 1, n
c = scan (buffer, "+")
if (c == 0) c = len (buffer) + 1
prt_spec%decay(i) = trim (adjustl (extract (buffer, 1, c-1)))
buffer = extract (buffer, c+1)
end do
end if
end if
end subroutine prt_spec_read1
@ %def prt_spec_read1
@ Read a particle specifier array, given as a single string. The
array is allocated to the correct size.
<<Particle specifiers: procedures>>=
pure subroutine prt_spec_read2 (prt_spec, string)
type(prt_spec_t), dimension(:), intent(out), allocatable :: prt_spec
type(string_t), intent(in) :: string
type(string_t) :: buffer
integer :: c, i, n
n = 0
buffer = string
do
n = n + 1
c = scan (buffer, ",")
if (c == 0) exit
buffer = extract (buffer, c+1)
end do
allocate (prt_spec (n))
buffer = string
do i = 1, size (prt_spec)
c = scan (buffer, ",")
if (c == 0) c = len (buffer) + 1
call prt_spec_read (prt_spec(i), &
trim (adjustl (extract (buffer, 1, c-1))))
buffer = extract (buffer, c+1)
end do
end subroutine prt_spec_read2
@ %def prt_spec_read2
@
\subsubsection{Constructor}
Initialize a particle specifier.
<<Particle specifiers: public>>=
public :: new_prt_spec
<<Particle specifiers: interfaces>>=
interface new_prt_spec
module procedure new_prt_spec
module procedure new_prt_spec_polarized
module procedure new_prt_spec_unstable
end interface new_prt_spec
<<Particle specifiers: procedures>>=
elemental function new_prt_spec (name) result (prt_spec)
type(string_t), intent(in) :: name
type(prt_spec_t) :: prt_spec
prt_spec%name = name
end function new_prt_spec
elemental function new_prt_spec_polarized (name, polarized) result (prt_spec)
type(string_t), intent(in) :: name
logical, intent(in) :: polarized
type(prt_spec_t) :: prt_spec
prt_spec%name = name
prt_spec%polarized = polarized
end function new_prt_spec_polarized
pure function new_prt_spec_unstable (name, decay) result (prt_spec)
type(string_t), intent(in) :: name
type(string_t), dimension(:), intent(in) :: decay
type(prt_spec_t) :: prt_spec
prt_spec%name = name
allocate (prt_spec%decay (size (decay)))
prt_spec%decay = decay
end function new_prt_spec_unstable
@ %def new_prt_spec
@
\subsubsection{Access Methods}
Return the particle name without qualifiers
<<Particle specifiers: prt spec: TBP>>=
procedure :: get_name => prt_spec_get_name
<<Particle specifiers: procedures>>=
elemental function prt_spec_get_name (prt_spec) result (name)
class(prt_spec_t), intent(in) :: prt_spec
type(string_t) :: name
name = prt_spec%name
end function prt_spec_get_name
@ %def prt_spec_get_name
@ Return the name with qualifiers
<<Particle specifiers: prt spec: TBP>>=
procedure :: to_string => prt_spec_to_string
<<Particle specifiers: procedures>>=
function prt_spec_to_string (object) result (string)
class(prt_spec_t), intent(in) :: object
type(string_t) :: string
integer :: i
string = object%name
if (allocated (object%decay)) then
string = string // "("
do i = 1, size (object%decay)
if (i > 1) string = string // " + "
string = string // object%decay(i)
end do
string = string // ")"
else if (object%polarized) then
string = string // "(*)"
end if
end function prt_spec_to_string
@ %def prt_spec_to_string
@ Return the polarization flag
<<Particle specifiers: prt spec: TBP>>=
procedure :: is_polarized => prt_spec_is_polarized
<<Particle specifiers: procedures>>=
elemental function prt_spec_is_polarized (prt_spec) result (flag)
class(prt_spec_t), intent(in) :: prt_spec
logical :: flag
flag = prt_spec%polarized
end function prt_spec_is_polarized
@ %def prt_spec_is_polarized
@ The particle is unstable if there is a decay array.
<<Particle specifiers: prt spec: TBP>>=
procedure :: is_unstable => prt_spec_is_unstable
<<Particle specifiers: procedures>>=
elemental function prt_spec_is_unstable (prt_spec) result (flag)
class(prt_spec_t), intent(in) :: prt_spec
logical :: flag
flag = allocated (prt_spec%decay)
end function prt_spec_is_unstable
@ %def prt_spec_is_unstable
@ Return the number of decay channels
<<Particle specifiers: prt spec: TBP>>=
procedure :: get_n_decays => prt_spec_get_n_decays
<<Particle specifiers: procedures>>=
elemental function prt_spec_get_n_decays (prt_spec) result (n)
class(prt_spec_t), intent(in) :: prt_spec
integer :: n
if (allocated (prt_spec%decay)) then
n = size (prt_spec%decay)
else
n = 0
end if
end function prt_spec_get_n_decays
@ %def prt_spec_get_n_decays
@ Return the decay channels
<<Particle specifiers: prt spec: TBP>>=
procedure :: get_decays => prt_spec_get_decays
<<Particle specifiers: procedures>>=
subroutine prt_spec_get_decays (prt_spec, decay)
class(prt_spec_t), intent(in) :: prt_spec
type(string_t), dimension(:), allocatable, intent(out) :: decay
if (allocated (prt_spec%decay)) then
allocate (decay (size (prt_spec%decay)))
decay = prt_spec%decay
else
allocate (decay (0))
end if
end subroutine prt_spec_get_decays
@ %def prt_spec_get_decays
@
\subsubsection{Miscellaneous}
There is nothing to expand here:
<<Particle specifiers: prt spec: TBP>>=
procedure :: expand_sub => prt_spec_expand_sub
<<Particle specifiers: procedures>>=
subroutine prt_spec_expand_sub (object)
class(prt_spec_t), intent(inout) :: object
end subroutine prt_spec_expand_sub
@ %def prt_spec_expand_sub
@
\subsection{List}
A list of particle specifiers, indicating, e.g., the final state of a
process.
<<Particle specifiers: public>>=
public :: prt_spec_list_t
<<Particle specifiers: types>>=
type, extends (prt_spec_expr_t) :: prt_spec_list_t
type(prt_expr_t), dimension(:), allocatable :: expr
contains
<<Particle specifiers: prt spec list: TBP>>
end type prt_spec_list_t
@ %def prt_spec_list_t
@ Output: Concatenate the components. Insert brackets if the component is
also a list. The components of the [[expr]] array, if any, should all be
filled.
<<Particle specifiers: prt spec list: TBP>>=
procedure :: to_string => prt_spec_list_to_string
<<Particle specifiers: procedures>>=
recursive function prt_spec_list_to_string (object) result (string)
class(prt_spec_list_t), intent(in) :: object
type(string_t) :: string
integer :: i
string = ""
if (allocated (object%expr)) then
do i = 1, size (object%expr)
if (i > 1) string = string // ", "
select type (x => object%expr(i)%x)
type is (prt_spec_list_t)
string = string // "(" // x%to_string () // ")"
class default
string = string // x%to_string ()
end select
end do
end if
end function prt_spec_list_to_string
@ %def prt_spec_list_to_string
@ Flatten: if there is a subexpression which is also a list, include the
components as direct members of the current list.
<<Particle specifiers: prt spec list: TBP>>=
procedure :: flatten => prt_spec_list_flatten
<<Particle specifiers: procedures>>=
subroutine prt_spec_list_flatten (object)
class(prt_spec_list_t), intent(inout) :: object
type(prt_expr_t), dimension(:), allocatable :: tmp_expr
integer :: i, n_flat, i_flat
n_flat = 0
do i = 1, size (object%expr)
select type (y => object%expr(i)%x)
type is (prt_spec_list_t)
n_flat = n_flat + size (y%expr)
class default
n_flat = n_flat + 1
end select
end do
if (n_flat > size (object%expr)) then
allocate (tmp_expr (n_flat))
i_flat = 0
do i = 1, size (object%expr)
select type (y => object%expr(i)%x)
type is (prt_spec_list_t)
tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr
i_flat = i_flat + size (y%expr)
class default
tmp_expr (i_flat + 1) = object%expr(i)
i_flat = i_flat + 1
end select
end do
end if
if (allocated (tmp_expr)) &
call move_alloc (from = tmp_expr, to = object%expr)
end subroutine prt_spec_list_flatten
@ %def prt_spec_list_flatten
@ Convert a list of sums into a sum of lists. (Subexpressions which are not
sums are left untouched.)
<<Particle specifiers: procedures>>=
subroutine distribute_prt_spec_list (object)
class(prt_spec_expr_t), intent(inout), allocatable :: object
class(prt_spec_expr_t), allocatable :: new_object
integer, dimension(:), allocatable :: n, ii
integer :: k, n_expr, n_terms, i_term
select type (object)
type is (prt_spec_list_t)
n_expr = size (object%expr)
allocate (n (n_expr), source = 1)
allocate (ii (n_expr), source = 1)
do k = 1, size (object%expr)
select type (y => object%expr(k)%x)
type is (prt_spec_sum_t)
n(k) = size (y%expr)
end select
end do
n_terms = product (n)
if (n_terms > 1) then
allocate (prt_spec_sum_t :: new_object)
select type (new_object)
type is (prt_spec_sum_t)
allocate (new_object%expr (n_terms))
do i_term = 1, n_terms
allocate (prt_spec_list_t :: new_object%expr(i_term)%x)
select type (x => new_object%expr(i_term)%x)
type is (prt_spec_list_t)
allocate (x%expr (n_expr))
do k = 1, n_expr
select type (y => object%expr(k)%x)
type is (prt_spec_sum_t)
x%expr(k) = y%expr(ii(k))
class default
x%expr(k) = object%expr(k)
end select
end do
end select
INCR_INDEX: do k = n_expr, 1, -1
if (ii(k) < n(k)) then
ii(k) = ii(k) + 1
exit INCR_INDEX
else
ii(k) = 1
end if
end do INCR_INDEX
end do
end select
end if
end select
if (allocated (new_object)) call move_alloc (from = new_object, to = object)
end subroutine distribute_prt_spec_list
@ %def distribute_prt_spec_list
@ Apply [[expand]] to all components of the list.
<<Particle specifiers: prt spec list: TBP>>=
procedure :: expand_sub => prt_spec_list_expand_sub
<<Particle specifiers: procedures>>=
recursive subroutine prt_spec_list_expand_sub (object)
class(prt_spec_list_t), intent(inout) :: object
integer :: i
if (allocated (object%expr)) then
do i = 1, size (object%expr)
call object%expr(i)%expand ()
end do
end if
end subroutine prt_spec_list_expand_sub
@ %def prt_spec_list_expand_sub
@
\subsection{Sum}
A sum of particle specifiers, indicating, e.g., a sum of final states.
<<Particle specifiers: public>>=
public :: prt_spec_sum_t
<<Particle specifiers: types>>=
type, extends (prt_spec_expr_t) :: prt_spec_sum_t
type(prt_expr_t), dimension(:), allocatable :: expr
contains
<<Particle specifiers: prt spec sum: TBP>>
end type prt_spec_sum_t
@ %def prt_spec_sum_t
@ Output: Concatenate the components. Insert brackets if the component is
a list or also a sum. The components of the [[expr]] array, if any, should
all be filled.
<<Particle specifiers: prt spec sum: TBP>>=
procedure :: to_string => prt_spec_sum_to_string
<<Particle specifiers: procedures>>=
recursive function prt_spec_sum_to_string (object) result (string)
class(prt_spec_sum_t), intent(in) :: object
type(string_t) :: string
integer :: i
string = ""
if (allocated (object%expr)) then
do i = 1, size (object%expr)
if (i > 1) string = string // " + "
select type (x => object%expr(i)%x)
type is (prt_spec_list_t)
string = string // "(" // x%to_string () // ")"
type is (prt_spec_sum_t)
string = string // "(" // x%to_string () // ")"
class default
string = string // x%to_string ()
end select
end do
end if
end function prt_spec_sum_to_string
@ %def prt_spec_sum_to_string
@ Flatten: if there is a subexpression which is also a sum, include the
components as direct members of the current sum.
This is identical to [[prt_spec_list_flatten]] above, except for the type.
<<Particle specifiers: prt spec sum: TBP>>=
procedure :: flatten => prt_spec_sum_flatten
<<Particle specifiers: procedures>>=
subroutine prt_spec_sum_flatten (object)
class(prt_spec_sum_t), intent(inout) :: object
type(prt_expr_t), dimension(:), allocatable :: tmp_expr
integer :: i, n_flat, i_flat
n_flat = 0
do i = 1, size (object%expr)
select type (y => object%expr(i)%x)
type is (prt_spec_sum_t)
n_flat = n_flat + size (y%expr)
class default
n_flat = n_flat + 1
end select
end do
if (n_flat > size (object%expr)) then
allocate (tmp_expr (n_flat))
i_flat = 0
do i = 1, size (object%expr)
select type (y => object%expr(i)%x)
type is (prt_spec_sum_t)
tmp_expr (i_flat + 1 : i_flat + size (y%expr)) = y%expr
i_flat = i_flat + size (y%expr)
class default
tmp_expr (i_flat + 1) = object%expr(i)
i_flat = i_flat + 1
end select
end do
end if
if (allocated (tmp_expr)) &
call move_alloc (from = tmp_expr, to = object%expr)
end subroutine prt_spec_sum_flatten
@ %def prt_spec_sum_flatten
@ Apply [[expand]] to all terms in the sum.
<<Particle specifiers: prt spec sum: TBP>>=
procedure :: expand_sub => prt_spec_sum_expand_sub
<<Particle specifiers: procedures>>=
recursive subroutine prt_spec_sum_expand_sub (object)
class(prt_spec_sum_t), intent(inout) :: object
integer :: i
if (allocated (object%expr)) then
do i = 1, size (object%expr)
call object%expr(i)%expand ()
end do
end if
end subroutine prt_spec_sum_expand_sub
@ %def prt_spec_sum_expand_sub
@
\subsection{Expression Expansion}
The [[expand]] method transforms each particle specifier expression into a sum
of lists, according to the rules
\begin{align}
a, (b, c) &\to a, b, c
\\
a + (b + c) &\to a + b + c
\\
a, b + c &\to (a, b) + (a, c)
\end{align}
Note that the precedence of comma and plus are opposite to this expansion, so
the parentheses in the final expression are necessary.
We assume that subexpressions are filled, i.e., arrays are allocated.
<<Particle specifiers: prt expr: TBP>>=
procedure :: expand => prt_expr_expand
<<Particle specifiers: procedures>>=
recursive subroutine prt_expr_expand (expr)
class(prt_expr_t), intent(inout) :: expr
if (allocated (expr%x)) then
call distribute_prt_spec_list (expr%x)
call expr%x%expand_sub ()
select type (x => expr%x)
type is (prt_spec_list_t)
call x%flatten ()
type is (prt_spec_sum_t)
call x%flatten ()
end select
end if
end subroutine prt_expr_expand
@ %def prt_expr_expand
@
\subsection{Unit Tests}
Test module, followed by the corresponding implementation module.
<<[[particle_specifiers_ut.f90]]>>=
<<File header>>
module particle_specifiers_ut
use unit_tests
use particle_specifiers_uti
<<Standard module head>>
<<Particle specifiers: public test>>
contains
<<Particle specifiers: test driver>>
end module particle_specifiers_ut
@ %def particle_specifiers_ut
@
<<[[particle_specifiers_uti.f90]]>>=
<<File header>>
module particle_specifiers_uti
<<Use strings>>
use particle_specifiers
<<Standard module head>>
<<Particle specifiers: test declarations>>
contains
<<Particle specifiers: tests>>
end module particle_specifiers_uti
@ %def particle_specifiers_ut
@ API: driver for the unit tests below.
<<Particle specifiers: public test>>=
public :: particle_specifiers_test
<<Particle specifiers: test driver>>=
subroutine particle_specifiers_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Particle specifiers: execute tests>>
end subroutine particle_specifiers_test
@ %def particle_specifiers_test
@
\subsubsection{Particle specifier array}
Define, read and write an array of particle specifiers.
<<Particle specifiers: execute tests>>=
call test (particle_specifiers_1, "particle_specifiers_1", &
"Handle particle specifiers", &
u, results)
<<Particle specifiers: test declarations>>=
public :: particle_specifiers_1
<<Particle specifiers: tests>>=
subroutine particle_specifiers_1 (u)
integer, intent(in) :: u
type(prt_spec_t), dimension(:), allocatable :: prt_spec
type(string_t), dimension(:), allocatable :: decay
type(string_t), dimension(0) :: no_decay
integer :: i, j
write (u, "(A)") "* Test output: particle_specifiers_1"
write (u, "(A)") "* Purpose: Read and write a particle specifier array"
write (u, "(A)")
allocate (prt_spec (5))
prt_spec = [ &
new_prt_spec (var_str ("a")), &
new_prt_spec (var_str ("b"), .true.), &
new_prt_spec (var_str ("c"), [var_str ("dec1")]), &
new_prt_spec (var_str ("d"), [var_str ("dec1"), var_str ("dec2")]), &
new_prt_spec (var_str ("e"), no_decay) &
]
do i = 1, size (prt_spec)
write (u, "(A)") char (prt_spec(i)%to_string ())
end do
write (u, "(A)")
call prt_spec_read (prt_spec, &
var_str (" a, b( *), c( dec1), d (dec1 + dec2 ), e()"))
call prt_spec_write (prt_spec, u)
do i = 1, size (prt_spec)
write (u, "(A)")
write (u, "(A,A)") char (prt_spec(i)%get_name ()), ":"
write (u, "(A,L1)") "polarized = ", prt_spec(i)%is_polarized ()
write (u, "(A,L1)") "unstable = ", prt_spec(i)%is_unstable ()
write (u, "(A,I0)") "n_decays = ", prt_spec(i)%get_n_decays ()
call prt_spec(i)%get_decays (decay)
write (u, "(A)", advance="no") "decays ="
do j = 1, size (decay)
write (u, "(1x,A)", advance="no") char (decay(j))
end do
write (u, "(A)")
end do
write (u, "(A)")
write (u, "(A)") "* Test output end: particle_specifiers_1"
end subroutine particle_specifiers_1
@ %def particle_specifiers_1
@
\subsubsection{Particle specifier expressions}
Nested expressions (only basic particles, no decay specs).
<<Particle specifiers: execute tests>>=
call test (particle_specifiers_2, "particle_specifiers_2", &
"Particle specifier expressions", &
u, results)
<<Particle specifiers: test declarations>>=
public :: particle_specifiers_2
<<Particle specifiers: tests>>=
subroutine particle_specifiers_2 (u)
integer, intent(in) :: u
type(prt_spec_t) :: a, b, c, d, e, f
type(prt_expr_t) :: pe1, pe2, pe3
type(prt_expr_t) :: pe4, pe5, pe6, pe7, pe8, pe9
integer :: i
type(prt_spec_t), dimension(:), allocatable :: pa
write (u, "(A)") "* Test output: particle_specifiers_2"
write (u, "(A)") "* Purpose: Create and display particle expressions"
write (u, "(A)")
write (u, "(A)") "* Basic expressions"
write (u, *)
a = new_prt_spec (var_str ("a"))
b = new_prt_spec (var_str ("b"))
c = new_prt_spec (var_str ("c"))
d = new_prt_spec (var_str ("d"))
e = new_prt_spec (var_str ("e"))
f = new_prt_spec (var_str ("f"))
call pe1%init_spec (a)
write (u, "(A)") char (pe1%to_string ())
call pe2%init_sum (2)
select type (x => pe2%x)
type is (prt_spec_sum_t)
call x%expr(1)%init_spec (a)
call x%expr(2)%init_spec (b)
end select
write (u, "(A)") char (pe2%to_string ())
call pe3%init_list (2)
select type (x => pe3%x)
type is (prt_spec_list_t)
call x%expr(1)%init_spec (a)
call x%expr(2)%init_spec (b)
end select
write (u, "(A)") char (pe3%to_string ())
write (u, *)
write (u, "(A)") "* Nested expressions"
write (u, *)
call pe4%init_list (2)
select type (x => pe4%x)
type is (prt_spec_list_t)
call x%expr(1)%init_sum (2)
select type (y => x%expr(1)%x)
type is (prt_spec_sum_t)
call y%expr(1)%init_spec (a)
call y%expr(2)%init_spec (b)
end select
call x%expr(2)%init_spec (c)
end select
write (u, "(A)") char (pe4%to_string ())
call pe5%init_list (2)
select type (x => pe5%x)
type is (prt_spec_list_t)
call x%expr(1)%init_list (2)
select type (y => x%expr(1)%x)
type is (prt_spec_list_t)
call y%expr(1)%init_spec (a)
call y%expr(2)%init_spec (b)
end select
call x%expr(2)%init_spec (c)
end select
write (u, "(A)") char (pe5%to_string ())
call pe6%init_sum (2)
select type (x => pe6%x)
type is (prt_spec_sum_t)
call x%expr(1)%init_spec (a)
call x%expr(2)%init_sum (2)
select type (y => x%expr(2)%x)
type is (prt_spec_sum_t)
call y%expr(1)%init_spec (b)
call y%expr(2)%init_spec (c)
end select
end select
write (u, "(A)") char (pe6%to_string ())
call pe7%init_list (2)
select type (x => pe7%x)
type is (prt_spec_list_t)
call x%expr(1)%init_sum (2)
select type (y => x%expr(1)%x)
type is (prt_spec_sum_t)
call y%expr(1)%init_spec (a)
call y%expr(2)%init_list (2)
select type (z => y%expr(2)%x)
type is (prt_spec_list_t)
call z%expr(1)%init_spec (b)
call z%expr(2)%init_spec (c)
end select
end select
call x%expr(2)%init_spec (d)
end select
write (u, "(A)") char (pe7%to_string ())
call pe8%init_sum (2)
select type (x => pe8%x)
type is (prt_spec_sum_t)
call x%expr(1)%init_list (2)
select type (y => x%expr(1)%x)
type is (prt_spec_list_t)
call y%expr(1)%init_spec (a)
call y%expr(2)%init_spec (b)
end select
call x%expr(2)%init_list (2)
select type (y => x%expr(2)%x)
type is (prt_spec_list_t)
call y%expr(1)%init_spec (c)
call y%expr(2)%init_spec (d)
end select
end select
write (u, "(A)") char (pe8%to_string ())
call pe9%init_list (3)
select type (x => pe9%x)
type is (prt_spec_list_t)
call x%expr(1)%init_sum (2)
select type (y => x%expr(1)%x)
type is (prt_spec_sum_t)
call y%expr(1)%init_spec (a)
call y%expr(2)%init_spec (b)
end select
call x%expr(2)%init_spec (c)
call x%expr(3)%init_sum (3)
select type (y => x%expr(3)%x)
type is (prt_spec_sum_t)
call y%expr(1)%init_spec (d)
call y%expr(2)%init_spec (e)
call y%expr(3)%init_spec (f)
end select
end select
write (u, "(A)") char (pe9%to_string ())
write (u, *)
write (u, "(A)") "* Expand as sum"
write (u, *)
call pe1%expand ()
write (u, "(A)") char (pe1%to_string ())
call pe4%expand ()
write (u, "(A)") char (pe4%to_string ())
call pe5%expand ()
write (u, "(A)") char (pe5%to_string ())
call pe6%expand ()
write (u, "(A)") char (pe6%to_string ())
call pe7%expand ()
write (u, "(A)") char (pe7%to_string ())
call pe8%expand ()
write (u, "(A)") char (pe8%to_string ())
call pe9%expand ()
write (u, "(A)") char (pe9%to_string ())
write (u, *)
write (u, "(A)") "* Transform to arrays:"
write (u, "(A)") "* Atomic specifier"
do i = 1, pe1%get_n_terms ()
call pe1%term_to_array (pa, i)
call prt_spec_write (pa, u)
end do
write (u, *)
write (u, "(A)") "* List"
do i = 1, pe5%get_n_terms ()
call pe5%term_to_array (pa, i)
call prt_spec_write (pa, u)
end do
write (u, *)
write (u, "(A)") "* Sum of atoms"
do i = 1, pe6%get_n_terms ()
call pe6%term_to_array (pa, i)
call prt_spec_write (pa, u)
end do
write (u, *)
write (u, "(A)") "* Sum of lists"
do i = 1, pe9%get_n_terms ()
call pe9%term_to_array (pa, i)
call prt_spec_write (pa, u)
end do
write (u, "(A)")
write (u, "(A)") "* Test output end: particle_specifiers_2"
end subroutine particle_specifiers_2
@ %def particle_specifiers_2
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{PDG arrays}
For defining aliases, we introduce a special type which holds a set of
(integer) PDG codes.
<<[[pdg_arrays.f90]]>>=
<<File header>>
module pdg_arrays
use io_units
use sorting
use physics_defs, only: UNDEFINED
<<Standard module head>>
<<PDG arrays: public>>
<<PDG arrays: types>>
<<PDG arrays: interfaces>>
contains
<<PDG arrays: procedures>>
end module pdg_arrays
@ %def pdg_arrays
@
\subsection{Type definition}
Using an allocatable array eliminates the need for initializer and/or
finalizer.
<<PDG arrays: public>>=
public :: pdg_array_t
<<PDG arrays: types>>=
type :: pdg_array_t
private
integer, dimension(:), allocatable :: pdg
contains
<<PDG arrays: pdg array: TBP>>
end type pdg_array_t
@ %def pdg_array_t
@ Output
<<PDG arrays: public>>=
public :: pdg_array_write
<<PDG arrays: pdg array: TBP>>=
procedure :: write => pdg_array_write
<<PDG arrays: procedures>>=
subroutine pdg_array_write (aval, unit)
class(pdg_array_t), intent(in) :: aval
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)", advance="no") "PDG("
if (allocated (aval%pdg)) then
do i = 1, size (aval%pdg)
if (i > 1) write (u, "(A)", advance="no") ", "
write (u, "(I0)", advance="no") aval%pdg(i)
end do
end if
write (u, "(A)", advance="no") ")"
end subroutine pdg_array_write
@ %def pdg_array_write
@
<<PDG arrays: public>>=
public :: pdg_array_write_set
<<PDG arrays: procedures>>=
subroutine pdg_array_write_set (aval, unit)
type(pdg_array_t), intent(in), dimension(:) :: aval
integer, intent(in), optional :: unit
integer :: i
do i = 1, size (aval)
call aval(i)%write (unit)
print *, ''
end do
end subroutine pdg_array_write_set
@ %def pdg_array_write_set
@
\subsection{Basic operations}
Assignment. We define assignment from and to an integer array.
Note that the integer array, if it is the l.h.s., must be declared
allocatable by the caller.
<<PDG arrays: public>>=
public :: assignment(=)
<<PDG arrays: interfaces>>=
interface assignment(=)
module procedure pdg_array_from_int_array
module procedure pdg_array_from_int
module procedure int_array_from_pdg_array
end interface
<<PDG arrays: procedures>>=
subroutine pdg_array_from_int_array (aval, iarray)
type(pdg_array_t), intent(out) :: aval
integer, dimension(:), intent(in) :: iarray
allocate (aval%pdg (size (iarray)))
aval%pdg = iarray
end subroutine pdg_array_from_int_array
elemental subroutine pdg_array_from_int (aval, int)
type(pdg_array_t), intent(out) :: aval
integer, intent(in) :: int
allocate (aval%pdg (1))
aval%pdg = int
end subroutine pdg_array_from_int
subroutine int_array_from_pdg_array (iarray, aval)
integer, dimension(:), allocatable, intent(out) :: iarray
type(pdg_array_t), intent(in) :: aval
if (allocated (aval%pdg)) then
allocate (iarray (size (aval%pdg)))
iarray = aval%pdg
else
allocate (iarray (0))
end if
end subroutine int_array_from_pdg_array
@ %def pdg_array_from_int_array pdg_array_from_int int_array_from_pdg_array
@ Allocate space for a PDG array
<<PDG arrays: public>>=
public :: pdg_array_init
<<PDG arrays: procedures>>=
subroutine pdg_array_init (aval, n_elements)
type(pdg_array_t), intent(inout) :: aval
integer, intent(in) :: n_elements
allocate(aval%pdg(n_elements))
end subroutine pdg_array_init
@ %def pdg_array_init
@ Deallocate a previously allocated pdg array
<<PDG arrays: public>>=
public :: pdg_array_delete
<<PDG arrays: procedures>>=
subroutine pdg_array_delete (aval)
type(pdg_array_t), intent(inout) :: aval
if (allocated (aval%pdg)) deallocate (aval%pdg)
end subroutine pdg_array_delete
@ %def pdg_array_delete
@ Merge two pdg arrays, i.e. append a particle string to another leaving out doublettes
<<PDG arrays: public>>=
public :: pdg_array_merge
<<PDG arrays: procedures>>=
subroutine pdg_array_merge (aval1, aval2)
type(pdg_array_t), intent(inout) :: aval1
type(pdg_array_t), intent(in) :: aval2
type(pdg_array_t) :: aval
if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
if (.not. any (aval1%pdg == aval2%pdg)) aval = aval1 // aval2
else if (allocated (aval1%pdg)) then
aval = aval1
else if (allocated (aval2%pdg)) then
aval = aval2
end if
call pdg_array_delete (aval1)
aval1 = aval%pdg
end subroutine pdg_array_merge
@ %def pdg_array_merge
@ Length of the array.
<<PDG arrays: public>>=
public :: pdg_array_get_length
<<PDG arrays: pdg array: TBP>>=
procedure :: get_length => pdg_array_get_length
<<PDG arrays: procedures>>=
elemental function pdg_array_get_length (aval) result (n)
class(pdg_array_t), intent(in) :: aval
integer :: n
if (allocated (aval%pdg)) then
n = size (aval%pdg)
else
n = 0
end if
end function pdg_array_get_length
@ %def pdg_array_get_length
@ Return the element with index i.
<<PDG arrays: public>>=
public :: pdg_array_get
<<PDG arrays: pdg array: TBP>>=
procedure :: get => pdg_array_get
<<PDG arrays: procedures>>=
elemental function pdg_array_get (aval, i) result (pdg)
class(pdg_array_t), intent(in) :: aval
integer, intent(in), optional :: i
integer :: pdg
if (present (i)) then
pdg = aval%pdg(i)
else
pdg = aval%pdg(1)
end if
end function pdg_array_get
@ %def pdg_array_get
@ Explicitly set the element with index i.
<<PDG arrays: pdg array: TBP>>=
procedure :: set => pdg_array_set
<<PDG arrays: procedures>>=
subroutine pdg_array_set (aval, i, pdg)
class(pdg_array_t), intent(inout) :: aval
integer, intent(in) :: i
integer, intent(in) :: pdg
aval%pdg(i) = pdg
end subroutine pdg_array_set
@ %def pdg_array_set
@
<<PDG arrays: pdg array: TBP>>=
procedure :: add => pdg_array_add
<<PDG arrays: procedures>>=
function pdg_array_add (aval, aval_add) result (aval_out)
type(pdg_array_t) :: aval_out
class(pdg_array_t), intent(in) :: aval
type(pdg_array_t), intent(in) :: aval_add
integer :: n, n_add, i
n = size (aval%pdg)
n_add = size (aval_add%pdg)
allocate (aval_out%pdg (n + n_add))
aval_out%pdg(1:n) = aval%pdg
do i = 1, n_add
aval_out%pdg(n+i) = aval_add%pdg(i)
end do
end function pdg_array_add
@ %def pdg_array_add
@ Replace element with index [[i]] by a new array of elements.
<<PDG arrays: public>>=
public :: pdg_array_replace
<<PDG arrays: pdg array: TBP>>=
procedure :: replace => pdg_array_replace
<<PDG arrays: procedures>>=
function pdg_array_replace (aval, i, pdg_new) result (aval_new)
class(pdg_array_t), intent(in) :: aval
integer, intent(in) :: i
integer, dimension(:), intent(in) :: pdg_new
type(pdg_array_t) :: aval_new
integer :: n, l
n = size (aval%pdg)
l = size (pdg_new)
allocate (aval_new%pdg (n + l - 1))
aval_new%pdg(:i-1) = aval%pdg(:i-1)
aval_new%pdg(i:i+l-1) = pdg_new
aval_new%pdg(i+l:) = aval%pdg(i+1:)
end function pdg_array_replace
@ %def pdg_array_replace
@ Concatenate two PDG arrays
<<PDG arrays: public>>=
public :: operator(//)
<<PDG arrays: interfaces>>=
interface operator(//)
module procedure concat_pdg_arrays
end interface
<<PDG arrays: procedures>>=
function concat_pdg_arrays (aval1, aval2) result (aval)
type(pdg_array_t) :: aval
type(pdg_array_t), intent(in) :: aval1, aval2
integer :: n1, n2
if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
n1 = size (aval1%pdg)
n2 = size (aval2%pdg)
allocate (aval%pdg (n1 + n2))
aval%pdg(:n1) = aval1%pdg
aval%pdg(n1+1:) = aval2%pdg
else if (allocated (aval1%pdg)) then
aval = aval1
else if (allocated (aval2%pdg)) then
aval = aval2
end if
end function concat_pdg_arrays
@ %def concat_pdg_arrays
@
\subsection{Matching}
A PDG array matches a given PDG code if the code is present within the
array. If either one is zero (UNDEFINED), the match also succeeds.
<<PDG arrays: public>>=
public :: operator(.match.)
<<PDG arrays: interfaces>>=
interface operator(.match.)
module procedure pdg_array_match_integer
module procedure pdg_array_match_pdg_array
end interface
@ %def .match.
@ Match a single code against the array.
<<PDG arrays: procedures>>=
elemental function pdg_array_match_integer (aval, pdg) result (flag)
logical :: flag
type(pdg_array_t), intent(in) :: aval
integer, intent(in) :: pdg
if (allocated (aval%pdg)) then
flag = pdg == UNDEFINED &
.or. any (aval%pdg == UNDEFINED) &
.or. any (aval%pdg == pdg)
else
flag = .false.
end if
end function pdg_array_match_integer
@ %def pdg_array_match_integer
@ Check if the pdg-number corresponds to a quark
<<PDG arrays: public>>=
public :: is_quark
<<PDG arrays: procedures>>=
elemental function is_quark (pdg_nr)
logical :: is_quark
integer, intent(in) :: pdg_nr
if (abs (pdg_nr) >= 1 .and. abs (pdg_nr) <= 6) then
is_quark = .true.
else
is_quark = .false.
end if
end function is_quark
@ %def is_quark
@ Check if pdg-number corresponds to a gluon
<<PDG arrays: public>>=
public :: is_gluon
<<PDG arrays: procedures>>=
elemental function is_gluon (pdg_nr)
logical :: is_gluon
integer, intent(in) :: pdg_nr
if (pdg_nr == 21) then
is_gluon = .true.
else
is_gluon = .false.
end if
end function is_gluon
@ %def is_gluon
@ Check if pdg-number corresponds to a photon
<<PDG arrays: public>>=
public :: is_photon
<<PDG arrays: procedures>>=
elemental function is_photon (pdg_nr)
logical :: is_photon
integer, intent(in) :: pdg_nr
if (pdg_nr == 22) then
is_photon = .true.
else
is_photon = .false.
end if
end function is_photon
@ %def is_photon
@ Check if pdg-number corresponds to a colored particle
<<PDG arrays: public>>=
public :: is_colored
<<PDG arrays: procedures>>=
elemental function is_colored (pdg_nr)
logical :: is_colored
integer, intent(in) :: pdg_nr
is_colored = is_quark (pdg_nr) .or. is_gluon (pdg_nr)
end function is_colored
@ %def is_colored
@ Check if the pdg-number corresponds to a lepton
<<PDG arrays: public>>=
public :: is_lepton
<<PDG arrays: procedures>>=
elemental function is_lepton (pdg_nr)
logical :: is_lepton
integer, intent(in) :: pdg_nr
if (abs (pdg_nr) >= 11 .and. abs (pdg_nr) <= 16) then
is_lepton = .true.
else
is_lepton = .false.
end if
end function is_lepton
@ %def is_lepton
@
<<PDG arrays: public>>=
public :: is_fermion
<<PDG arrays: procedures>>=
elemental function is_fermion (pdg_nr)
logical :: is_fermion
integer, intent(in) :: pdg_nr
is_fermion = is_lepton(pdg_nr) .or. is_quark(pdg_nr)
end function is_fermion
@ %def is_fermion
@ Check if the pdg-number corresponds to a massless vector boson
<<PDG arrays: public>>=
public :: is_massless_vector
<<PDG arrays: procedures>>=
elemental function is_massless_vector (pdg_nr)
integer, intent(in) :: pdg_nr
logical :: is_massless_vector
if (pdg_nr == 21 .or. pdg_nr == 22) then
is_massless_vector = .true.
else
is_massless_vector = .false.
end if
end function is_massless_vector
@ %def is_massless_vector
@ Check if pdg-number corresponds to a massive vector boson
<<PDG arrays: public>>=
public :: is_massive_vector
<<PDG arrays: procedures>>=
elemental function is_massive_vector (pdg_nr)
integer, intent(in) :: pdg_nr
logical :: is_massive_vector
if (abs (pdg_nr) == 23 .or. abs (pdg_nr) == 24) then
is_massive_vector = .true.
else
is_massive_vector = .false.
end if
end function is_massive_vector
@ %def is massive_vector
@ Check if pdg-number corresponds to a vector boson
<<PDG arrays: public>>=
public :: is_vector
<<PDG arrays: procedures>>=
elemental function is_vector (pdg_nr)
integer, intent(in) :: pdg_nr
logical :: is_vector
if (is_massless_vector (pdg_nr) .or. is_massive_vector (pdg_nr)) then
is_vector = .true.
else
is_vector = .false.
end if
end function is_vector
@ %def is vector
@ Check if particle is elementary.
<<PDG arrays: public>>=
public :: is_elementary
<<PDG arrays: procedures>>=
elemental function is_elementary (pdg_nr)
integer, intent(in) :: pdg_nr
logical :: is_elementary
if (is_vector (pdg_nr) .or. is_fermion (pdg_nr) .or. pdg_nr == 25) then
is_elementary = .true.
else
is_elementary = .false.
end if
end function is_elementary
@ %def is_elementary
@ Check if particle is strongly interacting
<<PDG arrays: pdg array: TBP>>=
procedure :: has_colored_particles => pdg_array_has_colored_particles
<<PDG arrays: procedures>>=
function pdg_array_has_colored_particles (pdg) result (colored)
class(pdg_array_t), intent(in) :: pdg
logical :: colored
integer :: i, pdg_nr
colored = .false.
do i = 1, size (pdg%pdg)
pdg_nr = pdg%pdg(i)
if (is_quark (pdg_nr) .or. is_gluon (pdg_nr)) then
colored = .true.
exit
end if
end do
end function pdg_array_has_colored_particles
@ %def pdg_array_has_colored_particles
@ Match two arrays. Succeeds if any pair of entries matches.
<<PDG arrays: procedures>>=
function pdg_array_match_pdg_array (aval1, aval2) result (flag)
logical :: flag
type(pdg_array_t), intent(in) :: aval1, aval2
if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
flag = any (aval1 .match. aval2%pdg)
else
flag = .false.
end if
end function pdg_array_match_pdg_array
@ %def pdg_array_match_pdg_array
@ Comparison. Here, we take the PDG arrays as-is, assuming that they
are sorted.
The ordering is a bit odd: first, we look only at the absolute values
of the PDG codes. If they all match, the particle comes before the
antiparticle, scanning from left to right.
<<PDG arrays: public>>=
public :: operator(<)
public :: operator(>)
public :: operator(<=)
public :: operator(>=)
public :: operator(==)
public :: operator(/=)
<<PDG arrays: interfaces>>=
interface operator(<)
module procedure pdg_array_lt
end interface
interface operator(>)
module procedure pdg_array_gt
end interface
interface operator(<=)
module procedure pdg_array_le
end interface
interface operator(>=)
module procedure pdg_array_ge
end interface
interface operator(==)
module procedure pdg_array_eq
end interface
interface operator(/=)
module procedure pdg_array_ne
end interface
<<PDG arrays: procedures>>=
elemental function pdg_array_lt (aval1, aval2) result (flag)
type(pdg_array_t), intent(in) :: aval1, aval2
logical :: flag
integer :: i
if (size (aval1%pdg) /= size (aval2%pdg)) then
flag = size (aval1%pdg) < size (aval2%pdg)
else
do i = 1, size (aval1%pdg)
if (abs (aval1%pdg(i)) /= abs (aval2%pdg(i))) then
flag = abs (aval1%pdg(i)) < abs (aval2%pdg(i))
return
end if
end do
do i = 1, size (aval1%pdg)
if (aval1%pdg(i) /= aval2%pdg(i)) then
flag = aval1%pdg(i) > aval2%pdg(i)
return
end if
end do
flag = .false.
end if
end function pdg_array_lt
elemental function pdg_array_gt (aval1, aval2) result (flag)
type(pdg_array_t), intent(in) :: aval1, aval2
logical :: flag
flag = .not. (aval1 < aval2 .or. aval1 == aval2)
end function pdg_array_gt
elemental function pdg_array_le (aval1, aval2) result (flag)
type(pdg_array_t), intent(in) :: aval1, aval2
logical :: flag
flag = aval1 < aval2 .or. aval1 == aval2
end function pdg_array_le
elemental function pdg_array_ge (aval1, aval2) result (flag)
type(pdg_array_t), intent(in) :: aval1, aval2
logical :: flag
flag = .not. (aval1 < aval2)
end function pdg_array_ge
elemental function pdg_array_eq (aval1, aval2) result (flag)
type(pdg_array_t), intent(in) :: aval1, aval2
logical :: flag
if (size (aval1%pdg) /= size (aval2%pdg)) then
flag = .false.
else
flag = all (aval1%pdg == aval2%pdg)
end if
end function pdg_array_eq
elemental function pdg_array_ne (aval1, aval2) result (flag)
type(pdg_array_t), intent(in) :: aval1, aval2
logical :: flag
flag = .not. (aval1 == aval2)
end function pdg_array_ne
@ Equivalence. Two PDG arrays are equivalent if either one contains
[[UNDEFINED]] or if each element of array 1 is present in array 2, and
vice versa.
<<PDG arrays: public>>=
public :: operator(.eqv.)
public :: operator(.neqv.)
<<PDG arrays: interfaces>>=
interface operator(.eqv.)
module procedure pdg_array_equivalent
end interface
interface operator(.neqv.)
module procedure pdg_array_inequivalent
end interface
<<PDG arrays: procedures>>=
elemental function pdg_array_equivalent (aval1, aval2) result (eq)
logical :: eq
type(pdg_array_t), intent(in) :: aval1, aval2
logical, dimension(:), allocatable :: match1, match2
integer :: i
if (allocated (aval1%pdg) .and. allocated (aval2%pdg)) then
eq = any (aval1%pdg == UNDEFINED) &
.or. any (aval2%pdg == UNDEFINED)
if (.not. eq) then
allocate (match1 (size (aval1%pdg)))
allocate (match2 (size (aval2%pdg)))
match1 = .false.
match2 = .false.
do i = 1, size (aval1%pdg)
match2 = match2 .or. aval1%pdg(i) == aval2%pdg
end do
do i = 1, size (aval2%pdg)
match1 = match1 .or. aval2%pdg(i) == aval1%pdg
end do
eq = all (match1) .and. all (match2)
end if
else
eq = .false.
end if
end function pdg_array_equivalent
elemental function pdg_array_inequivalent (aval1, aval2) result (neq)
logical :: neq
type(pdg_array_t), intent(in) :: aval1, aval2
neq = .not. pdg_array_equivalent (aval1, aval2)
end function pdg_array_inequivalent
@ %def pdg_array_equivalent
@
\subsection{Sorting}
Sort a PDG array by absolute value, particle before antiparticle. After
sorting, we eliminate double entries.
<<PDG arrays: public>>=
public :: sort_abs
<<PDG arrays: interfaces>>=
interface sort_abs
module procedure pdg_array_sort_abs
end interface
<<PDG arrays: pdg array: TBP>>=
procedure :: sort_abs => pdg_array_sort_abs
<<PDG arrays: procedures>>=
function pdg_array_sort_abs (aval1, unique) result (aval2)
class(pdg_array_t), intent(in) :: aval1
logical, intent(in), optional :: unique
type(pdg_array_t) :: aval2
integer, dimension(:), allocatable :: tmp
logical, dimension(:), allocatable :: mask
integer :: i, n
logical :: uni
uni = .false.; if (present (unique)) uni = unique
n = size (aval1%pdg)
if (uni) then
allocate (tmp (n), mask(n))
tmp = sort_abs (aval1%pdg)
mask(1) = .true.
do i = 2, n
mask(i) = tmp(i) /= tmp(i-1)
end do
allocate (aval2%pdg (count (mask)))
aval2%pdg = pack (tmp, mask)
else
allocate (aval2%pdg (n))
aval2%pdg = sort_abs (aval1%pdg)
end if
end function pdg_array_sort_abs
@ %def sort_abs
@
<<PDG arrays: pdg array: TBP>>=
procedure :: intersect => pdg_array_intersect
<<PDG arrays: procedures>>=
function pdg_array_intersect (aval1, match) result (aval2)
class(pdg_array_t), intent(in) :: aval1
integer, dimension(:) :: match
type(pdg_array_t) :: aval2
integer, dimension(:), allocatable :: isec
integer :: i
isec = pack (aval1%pdg, [(any(aval1%pdg(i) == match), i=1,size(aval1%pdg))])
aval2 = isec
end function pdg_array_intersect
@ %def pdg_array_intersect
@
<<PDG arrays: pdg array: TBP>>=
procedure :: search_for_particle => pdg_array_search_for_particle
<<PDG arrays: procedures>>=
elemental function pdg_array_search_for_particle (pdg, i_part) result (found)
class(pdg_array_t), intent(in) :: pdg
integer, intent(in) :: i_part
logical :: found
found = any (pdg%pdg == i_part)
end function pdg_array_search_for_particle
@ %def pdg_array_search_for_particle
@
<<PDG arrays: pdg array: TBP>>=
procedure :: invert => pdg_array_invert
<<PDG arrays: procedures>>=
function pdg_array_invert (pdg) result (pdg_inverse)
class(pdg_array_t), intent(in) :: pdg
type(pdg_array_t) :: pdg_inverse
integer :: i, n
n = size (pdg%pdg)
allocate (pdg_inverse%pdg (n))
do i = 1, n
select case (pdg%pdg(i))
case (21, 22, 23, 25)
pdg_inverse%pdg(i) = pdg%pdg(i)
case default
pdg_inverse%pdg(i) = -pdg%pdg(i)
end select
end do
end function pdg_array_invert
@ %def pdg_array_invert
@
\subsection{PDG array list}
A PDG array list, or PDG list, is an array of PDG-array objects with
some convenience methods.
<<PDG arrays: public>>=
public :: pdg_list_t
<<PDG arrays: types>>=
type :: pdg_list_t
type(pdg_array_t), dimension(:), allocatable :: a
contains
<<PDG arrays: pdg list: TBP>>
end type pdg_list_t
@ %def pdg_list_t
@ Output, as a comma-separated list without advancing I/O.
<<PDG arrays: pdg list: TBP>>=
procedure :: write => pdg_list_write
<<PDG arrays: procedures>>=
subroutine pdg_list_write (object, unit)
class(pdg_list_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
if (allocated (object%a)) then
do i = 1, size (object%a)
if (i > 1) write (u, "(A)", advance="no") ", "
call object%a(i)%write (u)
end do
end if
end subroutine pdg_list_write
@ %def pdg_list_write
@ Initialize for a certain size. The entries are initially empty PDG arrays.
<<PDG arrays: pdg list: TBP>>=
generic :: init => pdg_list_init_size
procedure, private :: pdg_list_init_size
<<PDG arrays: procedures>>=
subroutine pdg_list_init_size (pl, n)
class(pdg_list_t), intent(out) :: pl
integer, intent(in) :: n
allocate (pl%a (n))
end subroutine pdg_list_init_size
@ %def pdg_list_init_size
@ Initialize with a definite array of PDG codes. That is, each entry
in the list becomes a single-particle PDG array.
<<PDG arrays: pdg list: TBP>>=
generic :: init => pdg_list_init_int_array
procedure, private :: pdg_list_init_int_array
<<PDG arrays: procedures>>=
subroutine pdg_list_init_int_array (pl, pdg)
class(pdg_list_t), intent(out) :: pl
integer, dimension(:), intent(in) :: pdg
integer :: i
allocate (pl%a (size (pdg)))
do i = 1, size (pdg)
pl%a(i) = pdg(i)
end do
end subroutine pdg_list_init_int_array
@ %def pdg_list_init_array
@ Set one of the entries. No bounds-check.
<<PDG arrays: pdg list: TBP>>=
generic :: set => pdg_list_set_int
generic :: set => pdg_list_set_int_array
generic :: set => pdg_list_set_pdg_array
procedure, private :: pdg_list_set_int
procedure, private :: pdg_list_set_int_array
procedure, private :: pdg_list_set_pdg_array
<<PDG arrays: procedures>>=
subroutine pdg_list_set_int (pl, i, pdg)
class(pdg_list_t), intent(inout) :: pl
integer, intent(in) :: i
integer, intent(in) :: pdg
pl%a(i) = pdg
end subroutine pdg_list_set_int
subroutine pdg_list_set_int_array (pl, i, pdg)
class(pdg_list_t), intent(inout) :: pl
integer, intent(in) :: i
integer, dimension(:), intent(in) :: pdg
pl%a(i) = pdg
end subroutine pdg_list_set_int_array
subroutine pdg_list_set_pdg_array (pl, i, pa)
class(pdg_list_t), intent(inout) :: pl
integer, intent(in) :: i
type(pdg_array_t), intent(in) :: pa
pl%a(i) = pa
end subroutine pdg_list_set_pdg_array
@ %def pdg_list_set
@ Array size, not the length of individual entries
<<PDG arrays: pdg list: TBP>>=
procedure :: get_size => pdg_list_get_size
<<PDG arrays: procedures>>=
function pdg_list_get_size (pl) result (n)
class(pdg_list_t), intent(in) :: pl
integer :: n
if (allocated (pl%a)) then
n = size (pl%a)
else
n = 0
end if
end function pdg_list_get_size
@ %def pdg_list_get_size
@ Return an entry, as a PDG array.
<<PDG arrays: pdg list: TBP>>=
procedure :: get => pdg_list_get
<<PDG arrays: procedures>>=
function pdg_list_get (pl, i) result (pa)
type(pdg_array_t) :: pa
class(pdg_list_t), intent(in) :: pl
integer, intent(in) :: i
pa = pl%a(i)
end function pdg_list_get
@ %def pdg_list_get
@ Check if the list entries are all either mutually disjoint or identical.
The individual entries (PDG arrays) should already be sorted, so we can test
for equality.
<<PDG arrays: pdg list: TBP>>=
procedure :: is_regular => pdg_list_is_regular
<<PDG arrays: procedures>>=
function pdg_list_is_regular (pl) result (flag)
class(pdg_list_t), intent(in) :: pl
logical :: flag
integer :: i, j, s
s = pl%get_size ()
flag = .true.
do i = 1, s
do j = i + 1, s
if (pl%a(i) .match. pl%a(j)) then
if (pl%a(i) /= pl%a(j)) then
flag = .false.
return
end if
end if
end do
end do
end function pdg_list_is_regular
@ %def pdg_list_is_regular
@ Sort the list. First, each entry gets sorted, including elimination
of doublers. Then, we sort the list, using the first member of each
PDG array as the marker. No removal of doublers at this stage.
If [[n_in]] is supplied, we do not reorder the first [[n_in]] particle
entries.
<<PDG arrays: pdg list: TBP>>=
procedure :: sort_abs => pdg_list_sort_abs
<<PDG arrays: procedures>>=
function pdg_list_sort_abs (pl, n_in) result (pl_sorted)
class(pdg_list_t), intent(in) :: pl
integer, intent(in), optional :: n_in
type(pdg_list_t) :: pl_sorted
type(pdg_array_t), dimension(:), allocatable :: pa
integer, dimension(:), allocatable :: pdg, map
integer :: i, n0
call pl_sorted%init (pl%get_size ())
if (allocated (pl%a)) then
allocate (pa (size (pl%a)))
do i = 1, size (pl%a)
pa(i) = pl%a(i)%sort_abs (unique = .true.)
end do
allocate (pdg (size (pa)), source = 0)
do i = 1, size (pa)
if (allocated (pa(i)%pdg)) then
if (size (pa(i)%pdg) > 0) then
pdg(i) = pa(i)%pdg(1)
end if
end if
end do
if (present (n_in)) then
n0 = n_in
else
n0 = 0
end if
allocate (map (size (pdg)))
map(:n0) = [(i, i = 1, n0)]
map(n0+1:) = n0 + order_abs (pdg(n0+1:))
do i = 1, size (pa)
call pl_sorted%set (i, pa(map(i)))
end do
end if
end function pdg_list_sort_abs
@ %def pdg_list_sort_abs
@ Compare sorted lists: equality. The result is undefined if some entries
are not allocated.
<<PDG arrays: pdg list: TBP>>=
generic :: operator (==) => pdg_list_eq
procedure, private :: pdg_list_eq
<<PDG arrays: procedures>>=
function pdg_list_eq (pl1, pl2) result (flag)
class(pdg_list_t), intent(in) :: pl1, pl2
logical :: flag
integer :: i
flag = .false.
if (allocated (pl1%a) .and. allocated (pl2%a)) then
if (size (pl1%a) == size (pl2%a)) then
do i = 1, size (pl1%a)
associate (a1 => pl1%a(i), a2 => pl2%a(i))
if (allocated (a1%pdg) .and. allocated (a2%pdg)) then
if (size (a1%pdg) == size (a2%pdg)) then
if (size (a1%pdg) > 0) then
if (a1%pdg(1) /= a2%pdg(1)) return
end if
else
return
end if
else
return
end if
end associate
end do
flag = .true.
end if
end if
end function pdg_list_eq
@ %def pdg_list_eq
@ Compare sorted lists. The result is undefined if some entries
are not allocated.
The ordering is quite complicated. First, a shorter list comes before
a longer list. Comparing entry by entry, a shorter entry comes
first. Next, we check the first PDG code within corresponding
entries. This is compared by absolute value. If equal, particle
comes before antiparticle. Finally, if all is equal, the result is
false.
<<PDG arrays: pdg list: TBP>>=
generic :: operator (<) => pdg_list_lt
procedure, private :: pdg_list_lt
<<PDG arrays: procedures>>=
function pdg_list_lt (pl1, pl2) result (flag)
class(pdg_list_t), intent(in) :: pl1, pl2
logical :: flag
integer :: i
flag = .false.
if (allocated (pl1%a) .and. allocated (pl2%a)) then
if (size (pl1%a) < size (pl2%a)) then
flag = .true.; return
else if (size (pl1%a) > size (pl2%a)) then
return
else
do i = 1, size (pl1%a)
associate (a1 => pl1%a(i), a2 => pl2%a(i))
if (allocated (a1%pdg) .and. allocated (a2%pdg)) then
if (size (a1%pdg) < size (a2%pdg)) then
flag = .true.; return
else if (size (a1%pdg) > size (a2%pdg)) then
return
else
if (size (a1%pdg) > 0) then
if (abs (a1%pdg(1)) < abs (a2%pdg(1))) then
flag = .true.; return
else if (abs (a1%pdg(1)) > abs (a2%pdg(1))) then
return
else if (a1%pdg(1) > 0 .and. a2%pdg(1) < 0) then
flag = .true.; return
else if (a1%pdg(1) < 0 .and. a2%pdg(1) > 0) then
return
end if
end if
end if
else
return
end if
end associate
end do
flag = .false.
end if
end if
end function pdg_list_lt
@ %def pdg_list_lt
@ Replace an entry. In the result, the entry [[#i]] is replaced by
the contents of the second argument. The result is not sorted.
If [[n_in]] is also set and [[i]] is less or equal to [[n_in]],
replace [[#i]] only by the first entry of [[pl_insert]], and insert
the remainder after entry [[n_in]].
<<PDG arrays: pdg list: TBP>>=
procedure :: replace => pdg_list_replace
<<PDG arrays: procedures>>=
function pdg_list_replace (pl, i, pl_insert, n_in) result (pl_out)
type(pdg_list_t) :: pl_out
class(pdg_list_t), intent(in) :: pl
integer, intent(in) :: i
class(pdg_list_t), intent(in) :: pl_insert
integer, intent(in), optional :: n_in
integer :: n, n_insert, n_out, k
n = pl%get_size ()
n_insert = pl_insert%get_size ()
n_out = n + n_insert - 1
call pl_out%init (n_out)
! if (allocated (pl%a)) then
do k = 1, i - 1
pl_out%a(k) = pl%a(k)
end do
! end if
if (present (n_in)) then
pl_out%a(i) = pl_insert%a(1)
do k = i + 1, n_in
pl_out%a(k) = pl%a(k)
end do
do k = 1, n_insert - 1
pl_out%a(n_in+k) = pl_insert%a(1+k)
end do
do k = 1, n - n_in
pl_out%a(n_in+k+n_insert-1) = pl%a(n_in+k)
end do
else
! if (allocated (pl_insert%a)) then
do k = 1, n_insert
pl_out%a(i-1+k) = pl_insert%a(k)
end do
! end if
! if (allocated (pl%a)) then
do k = 1, n - i
pl_out%a(i+n_insert-1+k) = pl%a(i+k)
end do
end if
! end if
end function pdg_list_replace
@ %def pdg_list_replace
@
<<PDG arrays: pdg list: TBP>>=
procedure :: fusion => pdg_list_fusion
<<PDG arrays: procedures>>=
function pdg_list_fusion (pl, pl_insert, i, check_if_existing) result (pl_out)
type(pdg_list_t) :: pl_out
class(pdg_list_t), intent(in) :: pl
type(pdg_list_t), intent(in) :: pl_insert
integer, intent(in) :: i
logical, intent(in) :: check_if_existing
integer :: n, n_insert, k, n_out
logical :: new_pdg
n = pl%get_size ()
n_insert = pl_insert%get_size ()
new_pdg = .not. check_if_existing .or. &
(.not. any (pl%search_for_particle (pl_insert%a(1)%pdg)))
call pl_out%init (n + n_insert - 1)
do k = 1, n
if (new_pdg .and. k == i) then
pl_out%a(k) = pl%a(k)%add (pl_insert%a(1))
else
pl_out%a(k) = pl%a(k)
end if
end do
do k = n + 1, n + n_insert - 1
pl_out%a(k) = pl_insert%a(k-n)
end do
end function pdg_list_fusion
@ %def pdg_list_fusion
@
<<PDG arrays: pdg list: TBP>>=
procedure :: get_pdg_sizes => pdg_list_get_pdg_sizes
<<PDG arrays: procedures>>=
function pdg_list_get_pdg_sizes (pl) result (i_size)
integer, dimension(:), allocatable :: i_size
class(pdg_list_t), intent(in) :: pl
integer :: i, n
n = pl%get_size ()
allocate (i_size (n))
do i = 1, n
i_size(i) = size (pl%a(i)%pdg)
end do
end function pdg_list_get_pdg_sizes
@ %def pdg_list_get_pdg_sizes
@ Replace the entries of [[pl]] by the matching entries of [[pl_match]], one by
one. This is done in-place. If there is no match, return failure.
<<PDG arrays: pdg list: TBP>>=
procedure :: match_replace => pdg_list_match_replace
<<PDG arrays: procedures>>=
subroutine pdg_list_match_replace (pl, pl_match, success)
class(pdg_list_t), intent(inout) :: pl
class(pdg_list_t), intent(in) :: pl_match
logical, intent(out) :: success
integer :: i, j
success = .true.
SCAN_ENTRIES: do i = 1, size (pl%a)
do j = 1, size (pl_match%a)
if (pl%a(i) .match. pl_match%a(j)) then
pl%a(i) = pl_match%a(j)
cycle SCAN_ENTRIES
end if
end do
success = .false.
return
end do SCAN_ENTRIES
end subroutine pdg_list_match_replace
@ %def pdg_list_match_replace
@ Just check if a PDG array matches any entry in the PDG list. The second
version returns the position of the match within the list. An optional mask
indicates the list elements that should be checked.
<<PDG arrays: pdg list: TBP>>=
generic :: operator (.match.) => pdg_list_match_pdg_array
procedure, private :: pdg_list_match_pdg_array
procedure :: find_match => pdg_list_find_match_pdg_array
<<PDG arrays: procedures>>=
function pdg_list_match_pdg_array (pl, pa) result (flag)
class(pdg_list_t), intent(in) :: pl
type(pdg_array_t), intent(in) :: pa
logical :: flag
flag = pl%find_match (pa) /= 0
end function pdg_list_match_pdg_array
function pdg_list_find_match_pdg_array (pl, pa, mask) result (i)
class(pdg_list_t), intent(in) :: pl
type(pdg_array_t), intent(in) :: pa
logical, dimension(:), intent(in), optional :: mask
integer :: i
do i = 1, size (pl%a)
if (present (mask)) then
if (.not. mask(i)) cycle
end if
if (pl%a(i) .match. pa) return
end do
i = 0
end function pdg_list_find_match_pdg_array
@ %def pdg_list_match_pdg_array
@ %def pdg_list_find_match_pdg_array
@ Some old compilers have problems with allocatable arrays as
intent(out) or as function result, so be conservative here:
<<PDG arrays: pdg list: TBP>>=
procedure :: create_pdg_array => pdg_list_create_pdg_array
<<PDG arrays: procedures>>=
subroutine pdg_list_create_pdg_array (pl, pdg)
class(pdg_list_t), intent(in) :: pl
type(pdg_array_t), dimension(:), intent(inout), allocatable :: pdg
integer :: n_elements
integer :: i
associate (a => pl%a)
n_elements = size (a)
if (allocated (pdg)) deallocate (pdg)
allocate (pdg (n_elements))
do i = 1, n_elements
pdg(i) = a(i)
end do
end associate
end subroutine pdg_list_create_pdg_array
@ %def pdg_list_create_pdg_array
@
<<PDG arrays: pdg list: TBP>>=
procedure :: create_antiparticles => pdg_list_create_antiparticles
<<PDG arrays: procedures>>=
subroutine pdg_list_create_antiparticles (pl, pl_anti, n_new_particles)
class(pdg_list_t), intent(in) :: pl
type(pdg_list_t), intent(out) :: pl_anti
integer, intent(out) :: n_new_particles
type(pdg_list_t) :: pl_inverse
integer :: i, n
integer :: n_identical
logical, dimension(:), allocatable :: collect
n = pl%get_size (); n_identical = 0
allocate (collect (n)); collect = .true.
call pl_inverse%init (n)
do i = 1, n
pl_inverse%a(i) = pl%a(i)%invert()
end do
do i = 1, n
if (any (pl_inverse%a(i) == pl%a)) then
collect(i) = .false.
n_identical = n_identical + 1
end if
end do
n_new_particles = n - n_identical
if (n_new_particles > 0) then
call pl_anti%init (n_new_particles)
do i = 1, n
if (collect (i)) pl_anti%a(i) = pl_inverse%a(i)
end do
end if
end subroutine pdg_list_create_antiparticles
@ %def pdg_list_create_antiparticles
@
<<PDG arrays: pdg list: TBP>>=
procedure :: search_for_particle => pdg_list_search_for_particle
<<PDG arrays: procedures>>=
elemental function pdg_list_search_for_particle (pl, i_part) result (found)
logical :: found
class(pdg_list_t), intent(in) :: pl
integer, intent(in) :: i_part
integer :: i_pl
do i_pl = 1, size (pl%a)
found = pl%a(i_pl)%search_for_particle (i_part)
if (found) return
end do
end function pdg_list_search_for_particle
@ %def pdg_list_search_for_particle
@
<<PDG arrays: pdg list: TBP>>=
procedure :: contains_colored_particles => pdg_list_contains_colored_particles
<<PDG arrays: procedures>>=
function pdg_list_contains_colored_particles (pl) result (colored)
class(pdg_list_t), intent(in) :: pl
logical :: colored
integer :: i
colored = .false.
do i = 1, size (pl%a)
if (pl%a(i)%has_colored_particles()) then
colored = .true.
exit
end if
end do
end function pdg_list_contains_colored_particles
@ %def pdg_list_contains_colored_particles
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[pdg_arrays_ut.f90]]>>=
<<File header>>
module pdg_arrays_ut
use unit_tests
use pdg_arrays_uti
<<Standard module head>>
<<PDG arrays: public test>>
contains
<<PDG arrays: test driver>>
end module pdg_arrays_ut
@ %def pdg_arrays_ut
@
<<[[pdg_arrays_uti.f90]]>>=
<<File header>>
module pdg_arrays_uti
use pdg_arrays
<<Standard module head>>
<<PDG arrays: test declarations>>
contains
<<PDG arrays: tests>>
end module pdg_arrays_uti
@ %def pdg_arrays_ut
@ API: driver for the unit tests below.
<<PDG arrays: public test>>=
public :: pdg_arrays_test
<<PDG arrays: test driver>>=
subroutine pdg_arrays_test (u, results)
integer, intent(in) :: u
type (test_results_t), intent(inout) :: results
<<PDG arrays: execute tests>>
end subroutine pdg_arrays_test
@ %def pdg_arrays_test
@ Basic functionality.
<<PDG arrays: execute tests>>=
call test (pdg_arrays_1, "pdg_arrays_1", &
"create and sort PDG array", &
u, results)
<<PDG arrays: test declarations>>=
public :: pdg_arrays_1
<<PDG arrays: tests>>=
subroutine pdg_arrays_1 (u)
integer, intent(in) :: u
type(pdg_array_t) :: pa, pa1, pa2, pa3, pa4, pa5, pa6
integer, dimension(:), allocatable :: pdg
write (u, "(A)") "* Test output: pdg_arrays_1"
write (u, "(A)") "* Purpose: create and sort PDG arrays"
write (u, "(A)")
write (u, "(A)") "* Assignment"
write (u, "(A)")
call pa%write (u)
write (u, *)
write (u, "(A,I0)") "length = ", pa%get_length ()
pdg = pa
write (u, "(A,3(1x,I0))") "contents = ", pdg
write (u, *)
pa = 1
call pa%write (u)
write (u, *)
write (u, "(A,I0)") "length = ", pa%get_length ()
pdg = pa
write (u, "(A,3(1x,I0))") "contents = ", pdg
write (u, *)
pa = [1, 2, 3]
call pa%write (u)
write (u, *)
write (u, "(A,I0)") "length = ", pa%get_length ()
pdg = pa
write (u, "(A,3(1x,I0))") "contents = ", pdg
write (u, "(A,I0)") "element #2 = ", pa%get (2)
write (u, *)
write (u, "(A)") "* Replace"
write (u, *)
pa = pa%replace (2, [-5, 5, -7])
call pa%write (u)
write (u, *)
write (u, *)
write (u, "(A)") "* Sort"
write (u, *)
pa = [1, -7, 3, -5, 5, 3]
call pa%write (u)
write (u, *)
pa1 = pa%sort_abs ()
pa2 = pa%sort_abs (unique = .true.)
call pa1%write (u)
write (u, *)
call pa2%write (u)
write (u, *)
write (u, *)
write (u, "(A)") "* Compare"
write (u, *)
pa1 = [1, 3]
pa2 = [1, 2, -2]
pa3 = [1, 2, 4]
pa4 = [1, 2, 4]
pa5 = [1, 2, -4]
pa6 = [1, 2, -3]
write (u, "(A,6(1x,L1))") "< ", &
pa1 < pa2, pa2 < pa3, pa3 < pa4, pa4 < pa5, pa5 < pa6, pa6 < pa1
write (u, "(A,6(1x,L1))") "> ", &
pa1 > pa2, pa2 > pa3, pa3 > pa4, pa4 > pa5, pa5 > pa6, pa6 > pa1
write (u, "(A,6(1x,L1))") "<=", &
pa1 <= pa2, pa2 <= pa3, pa3 <= pa4, pa4 <= pa5, pa5 <= pa6, pa6 <= pa1
write (u, "(A,6(1x,L1))") ">=", &
pa1 >= pa2, pa2 >= pa3, pa3 >= pa4, pa4 >= pa5, pa5 >= pa6, pa6 >= pa1
write (u, "(A,6(1x,L1))") "==", &
pa1 == pa2, pa2 == pa3, pa3 == pa4, pa4 == pa5, pa5 == pa6, pa6 == pa1
write (u, "(A,6(1x,L1))") "/=", &
pa1 /= pa2, pa2 /= pa3, pa3 /= pa4, pa4 /= pa5, pa5 /= pa6, pa6 /= pa1
write (u, *)
pa1 = [0]
pa2 = [1, 2]
pa3 = [1, -2]
write (u, "(A,6(1x,L1))") "eqv ", &
pa1 .eqv. pa1, pa1 .eqv. pa2, &
pa2 .eqv. pa2, pa2 .eqv. pa3
write (u, "(A,6(1x,L1))") "neqv", &
pa1 .neqv. pa1, pa1 .neqv. pa2, &
pa2 .neqv. pa2, pa2 .neqv. pa3
write (u, *)
write (u, "(A,6(1x,L1))") "match", &
pa1 .match. 0, pa1 .match. 1, &
pa2 .match. 0, pa2 .match. 1, pa2 .match. 3
write (u, "(A)")
write (u, "(A)") "* Test output end: pdg_arrays_1"
end subroutine pdg_arrays_1
@ %def pdg_arrays_1
@ PDG array list, i.e., arrays of arrays.
<<PDG arrays: execute tests>>=
call test (pdg_arrays_2, "pdg_arrays_2", &
"create and sort PDG lists", &
u, results)
<<PDG arrays: test declarations>>=
public :: pdg_arrays_2
<<PDG arrays: tests>>=
subroutine pdg_arrays_2 (u)
integer, intent(in) :: u
type(pdg_array_t) :: pa
type(pdg_list_t) :: pl, pl1
write (u, "(A)") "* Test output: pdg_arrays_2"
write (u, "(A)") "* Purpose: create and sort PDG lists"
write (u, "(A)")
write (u, "(A)") "* Assignment"
write (u, "(A)")
call pl%init (3)
call pl%set (1, 42)
call pl%set (2, [3, 2])
pa = [5, -5]
call pl%set (3, pa)
call pl%write (u)
write (u, *)
write (u, "(A,I0)") "size = ", pl%get_size ()
write (u, "(A)")
write (u, "(A)") "* Sort"
write (u, "(A)")
pl = pl%sort_abs ()
call pl%write (u)
write (u, *)
write (u, "(A)")
write (u, "(A)") "* Extract item #3"
write (u, "(A)")
pa = pl%get (3)
call pa%write (u)
write (u, *)
write (u, "(A)")
write (u, "(A)") "* Replace item #3"
write (u, "(A)")
call pl1%init (2)
call pl1%set (1, [2, 4])
call pl1%set (2, -7)
pl = pl%replace (3, pl1)
call pl%write (u)
write (u, *)
write (u, "(A)")
write (u, "(A)") "* Test output end: pdg_arrays_2"
end subroutine pdg_arrays_2
@ %def pdg_arrays_2
@ Check if a (sorted) PDG array lists is regular. The entries (PDG arrays)
must not overlap, unless they are identical.
<<PDG arrays: execute tests>>=
call test (pdg_arrays_3, "pdg_arrays_3", &
"check PDG lists", &
u, results)
<<PDG arrays: test declarations>>=
public :: pdg_arrays_3
<<PDG arrays: tests>>=
subroutine pdg_arrays_3 (u)
integer, intent(in) :: u
type(pdg_list_t) :: pl
write (u, "(A)") "* Test output: pdg_arrays_3"
write (u, "(A)") "* Purpose: check for regular PDG lists"
write (u, "(A)")
write (u, "(A)") "* Regular list"
write (u, "(A)")
call pl%init (4)
call pl%set (1, [1, 2])
call pl%set (2, [1, 2])
call pl%set (3, [5, -5])
call pl%set (4, 42)
call pl%write (u)
write (u, *)
write (u, "(L1)") pl%is_regular ()
write (u, "(A)")
write (u, "(A)") "* Irregular list"
write (u, "(A)")
call pl%init (4)
call pl%set (1, [1, 2])
call pl%set (2, [1, 2])
call pl%set (3, [2, 5, -5])
call pl%set (4, 42)
call pl%write (u)
write (u, *)
write (u, "(L1)") pl%is_regular ()
write (u, "(A)")
write (u, "(A)") "* Test output end: pdg_arrays_3"
end subroutine pdg_arrays_3
@ %def pdg_arrays_3
@ Compare PDG array lists. The lists must be regular, i.e., sorted and with
non-overlapping (or identical) entries.
<<PDG arrays: execute tests>>=
call test (pdg_arrays_4, "pdg_arrays_4", &
"compare PDG lists", &
u, results)
<<PDG arrays: test declarations>>=
public :: pdg_arrays_4
<<PDG arrays: tests>>=
subroutine pdg_arrays_4 (u)
integer, intent(in) :: u
type(pdg_list_t) :: pl1, pl2, pl3
write (u, "(A)") "* Test output: pdg_arrays_4"
write (u, "(A)") "* Purpose: check for regular PDG lists"
write (u, "(A)")
write (u, "(A)") "* Create lists"
write (u, "(A)")
call pl1%init (4)
call pl1%set (1, [1, 2])
call pl1%set (2, [1, 2])
call pl1%set (3, [5, -5])
call pl1%set (4, 42)
write (u, "(I1,1x)", advance = "no") 1
call pl1%write (u)
write (u, *)
call pl2%init (2)
call pl2%set (1, 3)
call pl2%set (2, [5, -5])
write (u, "(I1,1x)", advance = "no") 2
call pl2%write (u)
write (u, *)
call pl3%init (2)
call pl3%set (1, 4)
call pl3%set (2, [5, -5])
write (u, "(I1,1x)", advance = "no") 3
call pl3%write (u)
write (u, *)
write (u, "(A)")
write (u, "(A)") "* a == b"
write (u, "(A)")
write (u, "(2x,A)") "123"
write (u, *)
write (u, "(I1,1x,4L1)") 1, pl1 == pl1, pl1 == pl2, pl1 == pl3
write (u, "(I1,1x,4L1)") 2, pl2 == pl1, pl2 == pl2, pl2 == pl3
write (u, "(I1,1x,4L1)") 3, pl3 == pl1, pl3 == pl2, pl3 == pl3
write (u, "(A)")
write (u, "(A)") "* a < b"
write (u, "(A)")
write (u, "(2x,A)") "123"
write (u, *)
write (u, "(I1,1x,4L1)") 1, pl1 < pl1, pl1 < pl2, pl1 < pl3
write (u, "(I1,1x,4L1)") 2, pl2 < pl1, pl2 < pl2, pl2 < pl3
write (u, "(I1,1x,4L1)") 3, pl3 < pl1, pl3 < pl2, pl3 < pl3
write (u, "(A)")
write (u, "(A)") "* Test output end: pdg_arrays_4"
end subroutine pdg_arrays_4
@ %def pdg_arrays_4
@ Match-replace: translate all entries in the first list into the
matching entries of the second list, if there is a match.
<<PDG arrays: execute tests>>=
call test (pdg_arrays_5, "pdg_arrays_5", &
"match PDG lists", &
u, results)
<<PDG arrays: test declarations>>=
public :: pdg_arrays_5
<<PDG arrays: tests>>=
subroutine pdg_arrays_5 (u)
integer, intent(in) :: u
type(pdg_list_t) :: pl1, pl2, pl3
logical :: success
write (u, "(A)") "* Test output: pdg_arrays_5"
write (u, "(A)") "* Purpose: match-replace"
write (u, "(A)")
write (u, "(A)") "* Create lists"
write (u, "(A)")
call pl1%init (2)
call pl1%set (1, [1, 2])
call pl1%set (2, 42)
call pl1%write (u)
write (u, *)
call pl3%init (2)
call pl3%set (1, [42, -42])
call pl3%set (2, [1, 2, 3, 4])
call pl1%match_replace (pl3, success)
call pl3%write (u)
write (u, "(1x,A,1x,L1,':',1x)", advance="no") "=>", success
call pl1%write (u)
write (u, *)
write (u, *)
call pl2%init (2)
call pl2%set (1, 9)
call pl2%set (2, 42)
call pl2%write (u)
write (u, *)
call pl2%match_replace (pl3, success)
call pl3%write (u)
write (u, "(1x,A,1x,L1,':',1x)", advance="no") "=>", success
call pl2%write (u)
write (u, *)
write (u, "(A)")
write (u, "(A)") "* Test output end: pdg_arrays_5"
end subroutine pdg_arrays_5
@ %def pdg_arrays_5
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Jets}
The FastJet library is linked externally, if available. The wrapper code is
also in a separate directory. Here, we define \whizard-specific procedures
and tests.
<<[[jets.f90]]>>=
<<File header>>
module jets
use fastjet !NODEP!
<<Standard module head>>
<<Jets: public>>
contains
<<Jets: procedures>>
end module jets
@ %def jets
@
\subsection{Re-exported symbols}
We use this module as a proxy for the FastJet interface, therefore we
re-export some symbols.
<<Jets: public>>=
public :: fastjet_available
public :: fastjet_init
public :: jet_definition_t
public :: pseudojet_t
public :: pseudojet_vector_t
public :: cluster_sequence_t
public :: assignment (=)
@ %def jet_definition_t pseudojet_t pseudojet_vector_t cluster_sequence_t
@ The initialization routine prints the banner.
<<Jets: procedures>>=
subroutine fastjet_init ()
call print_banner ()
end subroutine fastjet_init
@ %def fastjet_init
@ The jet algorithm codes (actually, integers)
<<Jets: public>>=
public :: kt_algorithm
public :: cambridge_algorithm
public :: antikt_algorithm
public :: genkt_algorithm
public :: cambridge_for_passive_algorithm
public :: genkt_for_passive_algorithm
public :: ee_kt_algorithm
public :: ee_genkt_algorithm
public :: plugin_algorithm
public :: undefined_jet_algorithm
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[jets_ut.f90]]>>=
<<File header>>
module jets_ut
use unit_tests
use jets_uti
<<Standard module head>>
<<Jets: public test>>
contains
<<Jets: test driver>>
end module jets_ut
@ %def jets_ut
@
<<[[jets_uti.f90]]>>=
<<File header>>
module jets_uti
<<Use kinds>>
use fastjet !NODEP!
use jets
<<Standard module head>>
<<Jets: test declarations>>
contains
<<Jets: tests>>
end module jets_uti
@ %def jets_ut
@ API: driver for the unit tests below.
<<Jets: public test>>=
public :: jets_test
<<Jets: test driver>>=
subroutine jets_test (u, results)
integer, intent(in) :: u
type (test_results_t), intent(inout) :: results
<<Jets: execute tests>>
end subroutine jets_test
@ %def jets_test
@ This test is actually the minimal example from the FastJet manual,
translated to Fortran.
Note that FastJet creates pseudojet vectors, which we mirror in the
[[pseudojet_vector_t]], but immediately assign to pseudojet arrays. Without
automatic finalization available in the compilers, we should avoid this in
actual code and rather introduce intermediate variables for those objects,
which we can finalize explicitly.
<<Jets: execute tests>>=
call test (jets_1, "jets_1", &
"basic FastJet functionality", &
u, results)
<<Jets: test declarations>>=
public :: jets_1
<<Jets: tests>>=
subroutine jets_1 (u)
integer, intent(in) :: u
type(pseudojet_t), dimension(:), allocatable :: prt, jets, constituents
type(jet_definition_t) :: jet_def
type(cluster_sequence_t) :: cs
integer, parameter :: dp = default
integer :: i, j
write (u, "(A)") "* Test output: jets_1"
write (u, "(A)") "* Purpose: test basic FastJet functionality"
write (u, "(A)")
write (u, "(A)") "* Print banner"
call print_banner ()
write (u, *)
write (u, "(A)") "* Prepare input particles"
allocate (prt (3))
call prt(1)%init ( 99._dp, 0.1_dp, 0._dp, 100._dp)
call prt(2)%init ( 4._dp,-0.1_dp, 0._dp, 5._dp)
call prt(3)%init (-99._dp, 0._dp, 0._dp, 99._dp)
write (u, *)
write (u, "(A)") "* Define jet algorithm"
call jet_def%init (antikt_algorithm, 0.7_dp)
write (u, *)
write (u, "(A)") "* Cluster particles according to jet algorithm"
write (u, *)
write (u, "(A,A)") "Clustering with ", jet_def%description ()
call cs%init (pseudojet_vector (prt), jet_def)
write (u, *)
write (u, "(A)") "* Sort output jets"
jets = sorted_by_pt (cs%inclusive_jets ())
write (u, *)
write (u, "(A)") "* Print jet observables and constituents"
write (u, *)
write (u, "(4x,3(7x,A3))") "pt", "y", "phi"
do i = 1, size (jets)
write (u, "(A,1x,I0,A,3(1x,F9.5))") &
"jet", i, ":", jets(i)%perp (), jets(i)%rap (), jets(i)%phi ()
constituents = jets(i)%constituents ()
do j = 1, size (constituents)
write (u, "(4x,A,1x,I0,A,F9.5)") &
"constituent", j, "'s pt:", constituents(j)%perp ()
end do
do j = 1, size (constituents)
call constituents(j)%final ()
end do
end do
write (u, *)
write (u, "(A)") "* Cleanup"
do i = 1, size (prt)
call prt(i)%final ()
end do
do i = 1, size (jets)
call jets(i)%final ()
end do
call jet_def%final ()
call cs%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: jets_1"
end subroutine jets_1
@ %def jets_1
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Subevents}
The purpose of subevents is to store the relevant part of the physical
event (either partonic or hadronic), and to hold particle selections
and combinations which are constructed in cut or analysis expressions.
<<[[subevents.f90]]>>=
<<File header>>
module subevents
use, intrinsic :: iso_c_binding !NODEP!
<<Use kinds>>
use io_units
use format_defs, only: FMT_14, FMT_19
use format_utils, only: pac_fmt
use physics_defs
use sorting
use c_particles
use lorentz
use pdg_arrays
use jets
<<Standard module head>>
<<Subevents: public>>
<<Subevents: parameters>>
<<Subevents: types>>
<<Subevents: interfaces>>
contains
<<Subevents: procedures>>
end module subevents
@ %def subevents
@
\subsection{Particles}
For the purpose of this module, a particle has a type which can
indicate a beam, incoming, outgoing, or composite particle, flavor and
helicity codes (integer, undefined for composite), four-momentum and
invariant mass squared. (Other particles types are used in extended
event types, but also defined here.) Furthermore, each particle has
an allocatable array of ancestors -- particle indices which indicate
the building blocks of a composite particle. For an incoming/outgoing
particle, the array contains only the index of the particle itself.
For incoming particles, the momentum is inverted before storing it in
the particle object.
<<Subevents: parameters>>=
integer, parameter, public :: PRT_UNDEFINED = 0
integer, parameter, public :: PRT_BEAM = -9
integer, parameter, public :: PRT_INCOMING = 1
integer, parameter, public :: PRT_OUTGOING = 2
integer, parameter, public :: PRT_COMPOSITE = 3
integer, parameter, public :: PRT_VIRTUAL = 4
integer, parameter, public :: PRT_RESONANT = 5
integer, parameter, public :: PRT_BEAM_REMNANT = 9
@ %def PRT_UNDEFINED PRT_BEAM
@ %def PRT_INCOMING PRT_OUTGOING PRT_COMPOSITE
@ %def PRT_COMPOSITE PRT_VIRTUAL PRT_RESONANT
@ %def PRT_BEAM_REMNANT
@
\subsubsection{The type}
We initialize only the type here and mark as unpolarized. The
initializers below do the rest. The logicals [[is_b_jet]] and
[[is_c_jet]] are true only if [[prt_t]] comes out of the
[[subevt_cluster]] routine and fulfils the correct flavor content.
<<Subevents: public>>=
public :: prt_t
<<Subevents: types>>=
type :: prt_t
private
integer :: type = PRT_UNDEFINED
integer :: pdg
logical :: polarized = .false.
logical :: colorized = .false.
logical :: clustered = .false.
logical :: is_b_jet = .false.
logical :: is_c_jet = .false.
integer :: h
type(vector4_t) :: p
real(default) :: p2
integer, dimension(:), allocatable :: src
integer, dimension(:), allocatable :: col
integer, dimension(:), allocatable :: acl
end type prt_t
@ %def prt_t
@ Initializers. Polarization is set separately. Finalizers are not
needed.
<<Subevents: procedures>>=
subroutine prt_init_beam (prt, pdg, p, p2, src)
type(prt_t), intent(out) :: prt
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: p
real(default), intent(in) :: p2
integer, dimension(:), intent(in) :: src
prt%type = PRT_BEAM
call prt_set (prt, pdg, - p, p2, src)
end subroutine prt_init_beam
subroutine prt_init_incoming (prt, pdg, p, p2, src)
type(prt_t), intent(out) :: prt
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: p
real(default), intent(in) :: p2
integer, dimension(:), intent(in) :: src
prt%type = PRT_INCOMING
call prt_set (prt, pdg, - p, p2, src)
end subroutine prt_init_incoming
subroutine prt_init_outgoing (prt, pdg, p, p2, src)
type(prt_t), intent(out) :: prt
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: p
real(default), intent(in) :: p2
integer, dimension(:), intent(in) :: src
prt%type = PRT_OUTGOING
call prt_set (prt, pdg, p, p2, src)
end subroutine prt_init_outgoing
subroutine prt_init_composite (prt, p, src)
type(prt_t), intent(out) :: prt
type(vector4_t), intent(in) :: p
integer, dimension(:), intent(in) :: src
prt%type = PRT_COMPOSITE
call prt_set (prt, 0, p, p**2, src)
end subroutine prt_init_composite
@ %def prt_init_beam prt_init_incoming prt_init_outgoing prt_init_composite
@
This version is for temporary particle objects, so the [[src]] array
is not set.
<<Subevents: public>>=
public :: prt_init_combine
<<Subevents: procedures>>=
subroutine prt_init_combine (prt, prt1, prt2)
type(prt_t), intent(out) :: prt
type(prt_t), intent(in) :: prt1, prt2
type(vector4_t) :: p
integer, dimension(0) :: src
prt%type = PRT_COMPOSITE
p = prt1%p + prt2%p
call prt_set (prt, 0, p, p**2, src)
end subroutine prt_init_combine
@ %def prt_init_combine
@ Init from a pseudojet object.
<<Subevents: procedures>>=
subroutine prt_init_pseudojet (prt, jet, src, pdg, is_b_jet, is_c_jet)
type(prt_t), intent(out) :: prt
type(pseudojet_t), intent(in) :: jet
integer, dimension(:), intent(in) :: src
integer, intent(in) :: pdg
logical, intent(in) :: is_b_jet, is_c_jet
type(vector4_t) :: p
prt%type = PRT_COMPOSITE
p = vector4_moving (jet%e(), &
vector3_moving ([jet%px(), jet%py(), jet%pz()]))
call prt_set (prt, pdg, p, p**2, src)
prt%is_b_jet = is_b_jet
prt%is_c_jet = is_c_jet
prt%clustered = .true.
end subroutine prt_init_pseudojet
@ %def prt_init_pseudojet
@
\subsubsection{Accessing contents}
<<Subevents: public>>=
public :: prt_get_pdg
<<Subevents: procedures>>=
elemental function prt_get_pdg (prt) result (pdg)
integer :: pdg
type(prt_t), intent(in) :: prt
pdg = prt%pdg
end function prt_get_pdg
@ %def prt_get_pdg
<<Subevents: public>>=
public :: prt_get_momentum
<<Subevents: procedures>>=
elemental function prt_get_momentum (prt) result (p)
type(vector4_t) :: p
type(prt_t), intent(in) :: prt
p = prt%p
end function prt_get_momentum
@ %def prt_get_momentum
<<Subevents: public>>=
public :: prt_get_msq
<<Subevents: procedures>>=
elemental function prt_get_msq (prt) result (msq)
real(default) :: msq
type(prt_t), intent(in) :: prt
msq = prt%p2
end function prt_get_msq
@ %def prt_get_msq
<<Subevents: public>>=
public :: prt_is_polarized
<<Subevents: procedures>>=
elemental function prt_is_polarized (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = prt%polarized
end function prt_is_polarized
@ %def prt_is_polarized
<<Subevents: public>>=
public :: prt_get_helicity
<<Subevents: procedures>>=
elemental function prt_get_helicity (prt) result (h)
integer :: h
type(prt_t), intent(in) :: prt
h = prt%h
end function prt_get_helicity
@ %def prt_get_helicity
<<Subevents: public>>=
public :: prt_is_colorized
<<Subevents: procedures>>=
elemental function prt_is_colorized (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = prt%colorized
end function prt_is_colorized
@ %def prt_is_colorized
<<Subevents: public>>=
public :: prt_is_clustered
<<Subevents: procedures>>=
elemental function prt_is_clustered (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = prt%clustered
end function prt_is_clustered
@ %def prt_is_clustered
<<Subevents: public>>=
public :: prt_is_recombinable
<<Subevents: procedures>>=
elemental function prt_is_recombinable (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = prt_is_parton (prt) .or. &
abs(prt%pdg) == TOP_Q .or. &
prt_is_lepton (prt)
end function prt_is_recombinable
@ %def prt_is_recombinable
<<Subevents: public>>=
public :: prt_is_photon
<<Subevents: procedures>>=
elemental function prt_is_photon (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = prt%pdg == PHOTON
end function prt_is_photon
@ %def prt_is_photon
We do not take the top quark into account here.
<<Subevents: public>>=
public :: prt_is_parton
<<Subevents: procedures>>=
elemental function prt_is_parton (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = abs(prt%pdg) == DOWN_Q .or. &
abs(prt%pdg) == UP_Q .or. &
abs(prt%pdg) == STRANGE_Q .or. &
abs(prt%pdg) == CHARM_Q .or. &
abs(prt%pdg) == BOTTOM_Q .or. &
prt%pdg == GLUON
end function prt_is_parton
@ %def prt_is_parton
<<Subevents: public>>=
public :: prt_is_lepton
<<Subevents: procedures>>=
elemental function prt_is_lepton (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = abs(prt%pdg) == ELECTRON .or. &
abs(prt%pdg) == MUON .or. &
abs(prt%pdg) == TAU
end function prt_is_lepton
@ %def prt_is_lepton
<<Subevents: public>>=
public :: prt_is_b_jet
<<Subevents: procedures>>=
elemental function prt_is_b_jet (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = prt%is_b_jet
end function prt_is_b_jet
@ %def prt_is_b_jet
<<Subevents: public>>=
public :: prt_is_c_jet
<<Subevents: procedures>>=
elemental function prt_is_c_jet (prt) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt
flag = prt%is_c_jet
end function prt_is_c_jet
@ %def prt_is_c_jet
@ The number of open color (anticolor) lines. We inspect the list of color
(anticolor) lines and count the entries that do not appear in the list
of anticolors (colors). (There is no check against duplicates; we assume that
color line indices are unique.)
<<Subevents: public>>=
public :: prt_get_n_col
public :: prt_get_n_acl
<<Subevents: procedures>>=
elemental function prt_get_n_col (prt) result (n)
integer :: n
type(prt_t), intent(in) :: prt
integer, dimension(:), allocatable :: col, acl
integer :: i
n = 0
if (prt%colorized) then
do i = 1, size (prt%col)
if (all (prt%col(i) /= prt%acl)) n = n + 1
end do
end if
end function prt_get_n_col
elemental function prt_get_n_acl (prt) result (n)
integer :: n
type(prt_t), intent(in) :: prt
integer, dimension(:), allocatable :: col, acl
integer :: i
n = 0
if (prt%colorized) then
do i = 1, size (prt%acl)
if (all (prt%acl(i) /= prt%col)) n = n + 1
end do
end if
end function prt_get_n_acl
@ %def prt_get_n_col
@ %def prt_get_n_acl
@ Return the color and anticolor-flow line indices explicitly.
<<Subevents: public>>=
public :: prt_get_color_indices
<<Subevents: procedures>>=
subroutine prt_get_color_indices (prt, col, acl)
type(prt_t), intent(in) :: prt
integer, dimension(:), allocatable, intent(out) :: col, acl
if (prt%colorized) then
col = prt%col
acl = prt%acl
else
col = [integer::]
acl = [integer::]
end if
end subroutine prt_get_color_indices
@ %def prt_get_color_indices
@
\subsubsection{Setting data}
Set the PDG, momentum and momentum squared, and ancestors. If
allocate-on-assignment is available, this can be simplified.
<<Subevents: procedures>>=
subroutine prt_set (prt, pdg, p, p2, src)
type(prt_t), intent(inout) :: prt
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: p
real(default), intent(in) :: p2
integer, dimension(:), intent(in) :: src
prt%pdg = pdg
prt%p = p
prt%p2 = p2
if (allocated (prt%src)) then
if (size (src) /= size (prt%src)) then
deallocate (prt%src)
allocate (prt%src (size (src)))
end if
else
allocate (prt%src (size (src)))
end if
prt%src = src
end subroutine prt_set
@ %def prt_set
@ Set the particle PDG code separately.
<<Subevents: procedures>>=
elemental subroutine prt_set_pdg (prt, pdg)
type(prt_t), intent(inout) :: prt
integer, intent(in) :: pdg
prt%pdg = pdg
end subroutine prt_set_pdg
@ %def prt_set_pdg
@ Set the momentum separately.
<<Subevents: procedures>>=
elemental subroutine prt_set_p (prt, p)
type(prt_t), intent(inout) :: prt
type(vector4_t), intent(in) :: p
prt%p = p
end subroutine prt_set_p
@ %def prt_set_p
@ Set the squared invariant mass separately.
<<Subevents: procedures>>=
elemental subroutine prt_set_p2 (prt, p2)
type(prt_t), intent(inout) :: prt
real(default), intent(in) :: p2
prt%p2 = p2
end subroutine prt_set_p2
@ %def prt_set_p2
@ Set helicity (optional).
<<Subevents: procedures>>=
subroutine prt_polarize (prt, h)
type(prt_t), intent(inout) :: prt
integer, intent(in) :: h
prt%polarized = .true.
prt%h = h
end subroutine prt_polarize
@ %def prt_polarize
@ Set color-flow indices (optional).
<<Subevents: procedures>>=
subroutine prt_colorize (prt, col, acl)
type(prt_t), intent(inout) :: prt
integer, dimension(:), intent(in) :: col, acl
prt%colorized = .true.
prt%col = col
prt%acl = acl
end subroutine prt_colorize
@ %def prt_colorize
@
\subsubsection{Conversion}
Transform a [[prt_t]] object into a [[c_prt_t]] object.
<<Subevents: public>>=
public :: c_prt
<<Subevents: interfaces>>=
interface c_prt
module procedure c_prt_from_prt
end interface
@ %def c_prt
<<Subevents: procedures>>=
elemental function c_prt_from_prt (prt) result (c_prt)
type(c_prt_t) :: c_prt
type(prt_t), intent(in) :: prt
c_prt = prt%p
c_prt%type = prt%type
c_prt%pdg = prt%pdg
if (prt%polarized) then
c_prt%polarized = 1
else
c_prt%polarized = 0
end if
c_prt%h = prt%h
end function c_prt_from_prt
@ %def c_prt_from_prt
@
\subsubsection{Output}
<<Subevents: public>>=
public :: prt_write
<<Subevents: procedures>>=
subroutine prt_write (prt, unit, testflag)
type(prt_t), intent(in) :: prt
integer, intent(in), optional :: unit
logical, intent(in), optional :: testflag
logical :: pacified
type(prt_t) :: tmp
character(len=7) :: fmt
integer :: u, i
call pac_fmt (fmt, FMT_19, FMT_14, testflag)
u = given_output_unit (unit); if (u < 0) return
pacified = .false. ; if (present (testflag)) pacified = testflag
tmp = prt
if (pacified) call pacify (tmp)
write (u, "(1x,A)", advance="no") "prt("
select case (prt%type)
case (PRT_UNDEFINED); write (u, "('?')", advance="no")
case (PRT_BEAM); write (u, "('b:')", advance="no")
case (PRT_INCOMING); write (u, "('i:')", advance="no")
case (PRT_OUTGOING); write (u, "('o:')", advance="no")
case (PRT_COMPOSITE); write (u, "('c:')", advance="no")
end select
select case (prt%type)
case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING)
if (prt%polarized) then
write (u, "(I0,'/',I0,'|')", advance="no") prt%pdg, prt%h
else
write (u, "(I0,'|')", advance="no") prt%pdg
end if
end select
select case (prt%type)
case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE)
if (prt%colorized) then
write (u, "(*(I0,:,','))", advance="no") prt%col
write (u, "('/')", advance="no")
write (u, "(*(I0,:,','))", advance="no") prt%acl
write (u, "('|')", advance="no")
end if
end select
select case (prt%type)
case (PRT_BEAM, PRT_INCOMING, PRT_OUTGOING, PRT_COMPOSITE)
write (u, "(" // FMT_14 // ",';'," // FMT_14 // ",','," // &
FMT_14 // ",','," // FMT_14 // ")", advance="no") tmp%p
write (u, "('|'," // fmt // ")", advance="no") tmp%p2
end select
if (allocated (prt%src)) then
write (u, "('|')", advance="no")
do i = 1, size (prt%src)
write (u, "(1x,I0)", advance="no") prt%src(i)
end do
end if
if (prt%is_b_jet) then
write (u, "('|b jet')", advance="no")
end if
if (prt%is_c_jet) then
write (u, "('|c jet')", advance="no")
end if
write (u, "(A)") ")"
end subroutine prt_write
@ %def prt_write
@
\subsubsection{Tools}
Two particles match if their [[src]] arrays are the same.
<<Subevents: public>>=
public :: operator(.match.)
<<Subevents: interfaces>>=
interface operator(.match.)
module procedure prt_match
end interface
@ %def .match.
<<Subevents: procedures>>=
elemental function prt_match (prt1, prt2) result (match)
logical :: match
type(prt_t), intent(in) :: prt1, prt2
if (size (prt1%src) == size (prt2%src)) then
match = all (prt1%src == prt2%src)
else
match = .false.
end if
end function prt_match
@ %def prt_match
@ The combine operation makes a pseudoparticle whose momentum is the
result of adding (the momenta of) the pair of input particles. We
trace the particles from which a particle is built by storing a
[[src]] array. Each particle entry in the [[src]] list contains a
list of indices which indicates its building blocks. The indices
refer to an original list of particles. Index lists are sorted, and
they contain no element more than once.
We thus require that in a given pseudoparticle, each original particle
occurs at most once.
The result is intent(inout), so it will not be initialized when the
subroutine is entered.
If the particles carry color, we recall that the combined particle is a
composite which is understood as outgoing. If one of the arguments is an
incoming particle, is color entries must be reversed.
<<Subevents: procedures>>=
subroutine prt_combine (prt, prt_in1, prt_in2, ok)
type(prt_t), intent(inout) :: prt
type(prt_t), intent(in) :: prt_in1, prt_in2
logical :: ok
integer, dimension(:), allocatable :: src
integer, dimension(:), allocatable :: col1, acl1, col2, acl2
call combine_index_lists (src, prt_in1%src, prt_in2%src)
ok = allocated (src)
if (ok) then
call prt_init_composite (prt, prt_in1%p + prt_in2%p, src)
if (prt_in1%colorized .or. prt_in2%colorized) then
select case (prt_in1%type)
case default
call prt_get_color_indices (prt_in1, col1, acl1)
case (PRT_BEAM, PRT_INCOMING)
call prt_get_color_indices (prt_in1, acl1, col1)
end select
select case (prt_in2%type)
case default
call prt_get_color_indices (prt_in2, col2, acl2)
case (PRT_BEAM, PRT_INCOMING)
call prt_get_color_indices (prt_in2, acl2, col2)
end select
call prt_colorize (prt, [col1, col2], [acl1, acl2])
end if
end if
end subroutine prt_combine
@ %def prt_combine
@ This variant does not produce the combined particle, it just checks
whether the combination is valid (no common [[src]] entry).
<<Subevents: public>>=
public :: are_disjoint
<<Subevents: procedures>>=
function are_disjoint (prt_in1, prt_in2) result (flag)
logical :: flag
type(prt_t), intent(in) :: prt_in1, prt_in2
flag = index_lists_are_disjoint (prt_in1%src, prt_in2%src)
end function are_disjoint
@ %def are_disjoint
@ [[src]] Lists with length $>1$ are built by a [[combine]] operation
which merges the lists in a sorted manner. If the result would have a
duplicate entry, it is discarded, and the result is unallocated.
<<Subevents: procedures>>=
subroutine combine_index_lists (res, src1, src2)
integer, dimension(:), intent(in) :: src1, src2
integer, dimension(:), allocatable :: res
integer :: i1, i2, i
allocate (res (size (src1) + size (src2)))
if (size (src1) == 0) then
res = src2
return
else if (size (src2) == 0) then
res = src1
return
end if
i1 = 1
i2 = 1
LOOP: do i = 1, size (res)
if (src1(i1) < src2(i2)) then
res(i) = src1(i1); i1 = i1 + 1
if (i1 > size (src1)) then
res(i+1:) = src2(i2:)
exit LOOP
end if
else if (src1(i1) > src2(i2)) then
res(i) = src2(i2); i2 = i2 + 1
if (i2 > size (src2)) then
res(i+1:) = src1(i1:)
exit LOOP
end if
else
deallocate (res)
exit LOOP
end if
end do LOOP
end subroutine combine_index_lists
@ %def combine_index_lists
@ This function is similar, but it does not actually merge the list,
it just checks whether they are disjoint (no common [[src]] entry).
<<Subevents: procedures>>=
function index_lists_are_disjoint (src1, src2) result (flag)
logical :: flag
integer, dimension(:), intent(in) :: src1, src2
integer :: i1, i2, i
flag = .true.
i1 = 1
i2 = 1
LOOP: do i = 1, size (src1) + size (src2)
if (src1(i1) < src2(i2)) then
i1 = i1 + 1
if (i1 > size (src1)) then
exit LOOP
end if
else if (src1(i1) > src2(i2)) then
i2 = i2 + 1
if (i2 > size (src2)) then
exit LOOP
end if
else
flag = .false.
exit LOOP
end if
end do LOOP
end function index_lists_are_disjoint
@ %def index_lists_are_disjoint
@
\subsection{subevents}
Particles are collected in subevents. This type is implemented as a
dynamically allocated array, which need not be completely filled. The
value [[n_active]] determines the number of meaningful entries.
\subsubsection{Type definition}
<<Subevents: public>>=
public :: subevt_t
<<Subevents: types>>=
type :: subevt_t
private
integer :: n_active = 0
type(prt_t), dimension(:), allocatable :: prt
contains
<<Subevents: subevt: TBP>>
end type subevt_t
@ %def subevt_t
@ Initialize, allocating with size zero (default) or given size. The
number of contained particles is set equal to the size.
<<Subevents: public>>=
public :: subevt_init
<<Subevents: procedures>>=
subroutine subevt_init (subevt, n_active)
type(subevt_t), intent(out) :: subevt
integer, intent(in), optional :: n_active
if (present (n_active)) subevt%n_active = n_active
allocate (subevt%prt (subevt%n_active))
end subroutine subevt_init
@ %def subevt_init
@ (Re-)allocate the subevent with some given size. If the size
is greater than the previous one, do a real reallocation. Otherwise,
just reset the recorded size. Contents are untouched, but become
invalid.
<<Subevents: public>>=
public :: subevt_reset
<<Subevents: procedures>>=
subroutine subevt_reset (subevt, n_active)
type(subevt_t), intent(inout) :: subevt
integer, intent(in) :: n_active
subevt%n_active = n_active
if (subevt%n_active > size (subevt%prt)) then
deallocate (subevt%prt)
allocate (subevt%prt (subevt%n_active))
end if
end subroutine subevt_reset
@ %def subevt_reset
@ Output. No prefix for the headline 'subevt', because this will usually be
printed appending to a previous line.
<<Subevents: public>>=
public :: subevt_write
<<Subevents: subevt: TBP>>=
procedure :: write => subevt_write
<<Subevents: procedures>>=
subroutine subevt_write (object, unit, prefix, pacified)
class(subevt_t), intent(in) :: object
integer, intent(in), optional :: unit
character(*), intent(in), optional :: prefix
logical, intent(in), optional :: pacified
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "subevent:"
do i = 1, object%n_active
if (present (prefix)) write (u, "(A)", advance="no") prefix
write (u, "(1x,I0)", advance="no") i
call prt_write (object%prt(i), unit = unit, testflag = pacified)
end do
end subroutine subevt_write
@ %def subevt_write
@ Defined assignment: transfer only meaningful entries. This is a
deep copy (as would be default assignment).
<<Subevents: interfaces>>=
interface assignment(=)
module procedure subevt_assign
end interface
@ %def =
<<Subevents: procedures>>=
subroutine subevt_assign (subevt, subevt_in)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: subevt_in
if (.not. allocated (subevt%prt)) then
call subevt_init (subevt, subevt_in%n_active)
else
call subevt_reset (subevt, subevt_in%n_active)
end if
subevt%prt(:subevt%n_active) = subevt_in%prt(:subevt%n_active)
end subroutine subevt_assign
@ %def subevt_assign
@
\subsubsection{Fill contents}
Store incoming/outgoing particles which are completely defined.
<<Subevents: public>>=
public :: subevt_set_beam
public :: subevt_set_incoming
public :: subevt_set_outgoing
public :: subevt_set_composite
<<Subevents: procedures>>=
subroutine subevt_set_beam (subevt, i, pdg, p, p2, src)
type(subevt_t), intent(inout) :: subevt
integer, intent(in) :: i
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: p
real(default), intent(in) :: p2
integer, dimension(:), intent(in), optional :: src
if (present (src)) then
call prt_init_beam (subevt%prt(i), pdg, p, p2, src)
else
call prt_init_beam (subevt%prt(i), pdg, p, p2, [i])
end if
end subroutine subevt_set_beam
subroutine subevt_set_incoming (subevt, i, pdg, p, p2, src)
type(subevt_t), intent(inout) :: subevt
integer, intent(in) :: i
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: p
real(default), intent(in) :: p2
integer, dimension(:), intent(in), optional :: src
if (present (src)) then
call prt_init_incoming (subevt%prt(i), pdg, p, p2, src)
else
call prt_init_incoming (subevt%prt(i), pdg, p, p2, [i])
end if
end subroutine subevt_set_incoming
subroutine subevt_set_outgoing (subevt, i, pdg, p, p2, src)
type(subevt_t), intent(inout) :: subevt
integer, intent(in) :: i
integer, intent(in) :: pdg
type(vector4_t), intent(in) :: p
real(default), intent(in) :: p2
integer, dimension(:), intent(in), optional :: src
if (present (src)) then
call prt_init_outgoing (subevt%prt(i), pdg, p, p2, src)
else
call prt_init_outgoing (subevt%prt(i), pdg, p, p2, [i])
end if
end subroutine subevt_set_outgoing
subroutine subevt_set_composite (subevt, i, p, src)
type(subevt_t), intent(inout) :: subevt
integer, intent(in) :: i
type(vector4_t), intent(in) :: p
integer, dimension(:), intent(in) :: src
call prt_init_composite (subevt%prt(i), p, src)
end subroutine subevt_set_composite
@ %def subevt_set_incoming subevt_set_outgoing subevt_set_composite
@ Separately assign flavors, simultaneously for all incoming/outgoing
particles.
<<Subevents: public>>=
public :: subevt_set_pdg_beam
public :: subevt_set_pdg_incoming
public :: subevt_set_pdg_outgoing
<<Subevents: procedures>>=
subroutine subevt_set_pdg_beam (subevt, pdg)
type(subevt_t), intent(inout) :: subevt
integer, dimension(:), intent(in) :: pdg
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_BEAM) then
call prt_set_pdg (subevt%prt(i), pdg(j))
j = j + 1
if (j > size (pdg)) exit
end if
end do
end subroutine subevt_set_pdg_beam
subroutine subevt_set_pdg_incoming (subevt, pdg)
type(subevt_t), intent(inout) :: subevt
integer, dimension(:), intent(in) :: pdg
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_INCOMING) then
call prt_set_pdg (subevt%prt(i), pdg(j))
j = j + 1
if (j > size (pdg)) exit
end if
end do
end subroutine subevt_set_pdg_incoming
subroutine subevt_set_pdg_outgoing (subevt, pdg)
type(subevt_t), intent(inout) :: subevt
integer, dimension(:), intent(in) :: pdg
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_OUTGOING) then
call prt_set_pdg (subevt%prt(i), pdg(j))
j = j + 1
if (j > size (pdg)) exit
end if
end do
end subroutine subevt_set_pdg_outgoing
@ %def subevt_set_pdg_beam
@ %def subevt_set_pdg_incoming
@ %def subevt_set_pdg_outgoing
@ Separately assign momenta, simultaneously for all incoming/outgoing
particles.
<<Subevents: public>>=
public :: subevt_set_p_beam
public :: subevt_set_p_incoming
public :: subevt_set_p_outgoing
<<Subevents: procedures>>=
subroutine subevt_set_p_beam (subevt, p)
type(subevt_t), intent(inout) :: subevt
type(vector4_t), dimension(:), intent(in) :: p
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_BEAM) then
call prt_set_p (subevt%prt(i), p(j))
j = j + 1
if (j > size (p)) exit
end if
end do
end subroutine subevt_set_p_beam
subroutine subevt_set_p_incoming (subevt, p)
type(subevt_t), intent(inout) :: subevt
type(vector4_t), dimension(:), intent(in) :: p
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_INCOMING) then
call prt_set_p (subevt%prt(i), p(j))
j = j + 1
if (j > size (p)) exit
end if
end do
end subroutine subevt_set_p_incoming
subroutine subevt_set_p_outgoing (subevt, p)
type(subevt_t), intent(inout) :: subevt
type(vector4_t), dimension(:), intent(in) :: p
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_OUTGOING) then
call prt_set_p (subevt%prt(i), p(j))
j = j + 1
if (j > size (p)) exit
end if
end do
end subroutine subevt_set_p_outgoing
@ %def subevt_set_p_beam
@ %def subevt_set_p_incoming
@ %def subevt_set_p_outgoing
@ Separately assign the squared invariant mass, simultaneously for all
incoming/outgoing particles.
<<Subevents: public>>=
public :: subevt_set_p2_beam
public :: subevt_set_p2_incoming
public :: subevt_set_p2_outgoing
<<Subevents: procedures>>=
subroutine subevt_set_p2_beam (subevt, p2)
type(subevt_t), intent(inout) :: subevt
real(default), dimension(:), intent(in) :: p2
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_BEAM) then
call prt_set_p2 (subevt%prt(i), p2(j))
j = j + 1
if (j > size (p2)) exit
end if
end do
end subroutine subevt_set_p2_beam
subroutine subevt_set_p2_incoming (subevt, p2)
type(subevt_t), intent(inout) :: subevt
real(default), dimension(:), intent(in) :: p2
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_INCOMING) then
call prt_set_p2 (subevt%prt(i), p2(j))
j = j + 1
if (j > size (p2)) exit
end if
end do
end subroutine subevt_set_p2_incoming
subroutine subevt_set_p2_outgoing (subevt, p2)
type(subevt_t), intent(inout) :: subevt
real(default), dimension(:), intent(in) :: p2
integer :: i, j
j = 1
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_OUTGOING) then
call prt_set_p2 (subevt%prt(i), p2(j))
j = j + 1
if (j > size (p2)) exit
end if
end do
end subroutine subevt_set_p2_outgoing
@ %def subevt_set_p2_beam
@ %def subevt_set_p2_incoming
@ %def subevt_set_p2_outgoing
@ Set polarization for an entry
<<Subevents: public>>=
public :: subevt_polarize
<<Subevents: procedures>>=
subroutine subevt_polarize (subevt, i, h)
type(subevt_t), intent(inout) :: subevt
integer, intent(in) :: i, h
call prt_polarize (subevt%prt(i), h)
end subroutine subevt_polarize
@ %def subevt_polarize
@ Set color-flow indices for an entry
<<Subevents: public>>=
public :: subevt_colorize
<<Subevents: procedures>>=
subroutine subevt_colorize (subevt, i, col, acl)
type(subevt_t), intent(inout) :: subevt
integer, intent(in) :: i, col, acl
if (col > 0 .and. acl > 0) then
call prt_colorize (subevt%prt(i), [col], [acl])
else if (col > 0) then
call prt_colorize (subevt%prt(i), [col], [integer ::])
else if (acl > 0) then
call prt_colorize (subevt%prt(i), [integer ::], [acl])
else
call prt_colorize (subevt%prt(i), [integer ::], [integer ::])
end if
end subroutine subevt_colorize
@ %def subevt_colorize
@
\subsubsection{Accessing contents}
Return true if the subevent has entries.
<<Subevents: public>>=
public :: subevt_is_nonempty
<<Subevents: procedures>>=
function subevt_is_nonempty (subevt) result (flag)
logical :: flag
type(subevt_t), intent(in) :: subevt
flag = subevt%n_active /= 0
end function subevt_is_nonempty
@ %def subevt_is_nonempty
@ Return the number of entries
<<Subevents: public>>=
public :: subevt_get_length
<<Subevents: procedures>>=
function subevt_get_length (subevt) result (length)
integer :: length
type(subevt_t), intent(in) :: subevt
length = subevt%n_active
end function subevt_get_length
@ %def subevt_get_length
@ Return a specific particle. The index is not checked for validity.
<<Subevents: public>>=
public :: subevt_get_prt
<<Subevents: procedures>>=
function subevt_get_prt (subevt, i) result (prt)
type(prt_t) :: prt
type(subevt_t), intent(in) :: subevt
integer, intent(in) :: i
prt = subevt%prt(i)
end function subevt_get_prt
@ %def subevt_get_prt
@ Return the partonic energy squared. We take the particles with flag
[[PRT_INCOMING]] and compute their total invariant mass.
<<Subevents: public>>=
public :: subevt_get_sqrts_hat
<<Subevents: procedures>>=
function subevt_get_sqrts_hat (subevt) result (sqrts_hat)
type(subevt_t), intent(in) :: subevt
real(default) :: sqrts_hat
type(vector4_t) :: p
integer :: i
do i = 1, subevt%n_active
if (subevt%prt(i)%type == PRT_INCOMING) then
p = p + prt_get_momentum (subevt%prt(i))
end if
end do
sqrts_hat = p ** 1
end function subevt_get_sqrts_hat
@ %def subevt_get_sqrts_hat
@ Return the number of incoming (outgoing) particles, respectively.
Beam particles or composites are not counted.
<<Subevents: public>>=
public :: subevt_get_n_in
public :: subevt_get_n_out
<<Subevents: procedures>>=
function subevt_get_n_in (subevt) result (n_in)
type(subevt_t), intent(in) :: subevt
integer :: n_in
n_in = count (subevt%prt(:subevt%n_active)%type == PRT_INCOMING)
end function subevt_get_n_in
function subevt_get_n_out (subevt) result (n_out)
type(subevt_t), intent(in) :: subevt
integer :: n_out
n_out = count (subevt%prt(:subevt%n_active)%type == PRT_OUTGOING)
end function subevt_get_n_out
@ %def subevt_get_n_in
@ %def subevt_get_n_out
@
<<Subevents: interfaces>>=
interface c_prt
module procedure c_prt_from_subevt
module procedure c_prt_array_from_subevt
end interface
@ %def c_prt
<<Subevents: procedures>>=
function c_prt_from_subevt (subevt, i) result (c_prt)
type(c_prt_t) :: c_prt
type(subevt_t), intent(in) :: subevt
integer, intent(in) :: i
c_prt = c_prt_from_prt (subevt%prt(i))
end function c_prt_from_subevt
function c_prt_array_from_subevt (subevt) result (c_prt_array)
type(subevt_t), intent(in) :: subevt
type(c_prt_t), dimension(subevt%n_active) :: c_prt_array
c_prt_array = c_prt_from_prt (subevt%prt(1:subevt%n_active))
end function c_prt_array_from_subevt
@ %def c_prt_from_subevt
@ %def c_prt_array_from_subevt
@
\subsubsection{Operations with subevents}
The join operation joins two subevents. When appending the
elements of the second list, we check for each particle whether it is
already in the first list. If yes, it is discarded. The result list
should be initialized already.
If a mask is present, it refers to the second subevent.
Particles where the mask is not set are discarded.
<<Subevents: public>>=
public :: subevt_join
<<Subevents: procedures>>=
subroutine subevt_join (subevt, pl1, pl2, mask2)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl1, pl2
logical, dimension(:), intent(in), optional :: mask2
integer :: n1, n2, i, n
n1 = pl1%n_active
n2 = pl2%n_active
call subevt_reset (subevt, n1 + n2)
subevt%prt(:n1) = pl1%prt(:n1)
n = n1
if (present (mask2)) then
do i = 1, pl2%n_active
if (mask2(i)) then
if (disjoint (i)) then
n = n + 1
subevt%prt(n) = pl2%prt(i)
end if
end if
end do
else
do i = 1, pl2%n_active
if (disjoint (i)) then
n = n + 1
subevt%prt(n) = pl2%prt(i)
end if
end do
end if
subevt%n_active = n
contains
function disjoint (i) result (flag)
integer, intent(in) :: i
logical :: flag
integer :: j
do j = 1, pl1%n_active
if (.not. are_disjoint (pl1%prt(j), pl2%prt(i))) then
flag = .false.
return
end if
end do
flag = .true.
end function disjoint
end subroutine subevt_join
@ %def subevt_join
@ The combine operation makes a subevent whose entries are the
result of adding (the momenta of) each pair of particles in the input
lists. We trace the particles from which a particles is built by
storing a [[src]] array. Each particle entry in the [[src]] list
contains a list of indices which indicates its building blocks. The
indices refer to an original list of particles. Index lists are sorted,
and they contain no element more than once.
We thus require that in a given pseudoparticle, each original particle
occurs at most once.
<<Subevents: public>>=
public :: subevt_combine
<<Subevents: procedures>>=
subroutine subevt_combine (subevt, pl1, pl2, mask12)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl1, pl2
logical, dimension(:,:), intent(in), optional :: mask12
integer :: n1, n2, i1, i2, n, j
logical :: ok
n1 = pl1%n_active
n2 = pl2%n_active
call subevt_reset (subevt, n1 * n2)
n = 1
do i1 = 1, n1
do i2 = 1, n2
if (present (mask12)) then
ok = mask12(i1,i2)
else
ok = .true.
end if
if (ok) call prt_combine &
(subevt%prt(n), pl1%prt(i1), pl2%prt(i2), ok)
if (ok) then
CHECK_DOUBLES: do j = 1, n - 1
if (subevt%prt(n) .match. subevt%prt(j)) then
ok = .false.; exit CHECK_DOUBLES
end if
end do CHECK_DOUBLES
if (ok) n = n + 1
end if
end do
end do
subevt%n_active = n - 1
end subroutine subevt_combine
@ %def subevt_combine
@ The collect operation makes a single-entry subevent which
results from combining (the momenta of) all particles in the input
list. As above, the result does not contain an original particle more
than once; this is checked for each particle when it is collected.
Furthermore, each entry has a mask; where the mask is false, the entry
is dropped.
(Thus, if the input particles are already composite, there is some
chance that the result depends on the order of the input list and is
not as expected. This situation should be avoided.)
<<Subevents: public>>=
public :: subevt_collect
<<Subevents: procedures>>=
subroutine subevt_collect (subevt, pl1, mask1)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl1
logical, dimension(:), intent(in) :: mask1
type(prt_t) :: prt
integer :: i
logical :: ok
call subevt_reset (subevt, 1)
subevt%n_active = 0
do i = 1, pl1%n_active
if (mask1(i)) then
if (subevt%n_active == 0) then
subevt%n_active = 1
subevt%prt(1) = pl1%prt(i)
else
call prt_combine (prt, subevt%prt(1), pl1%prt(i), ok)
if (ok) subevt%prt(1) = prt
end if
end if
end do
end subroutine subevt_collect
@ %def subevt_collect
@ The cluster operation is similar to [[collect]], but applies a jet
algorithm. The result is a subevent consisting of jets and, possibly,
unclustered extra particles. As above, the result does not contain an
original particle more than once; this is checked for each particle when it is
collected. Furthermore, each entry has a mask; where the mask is false, the
entry is dropped.
The algorithm: first determine the (pseudo)particles that participate in the
clustering. They should not overlap, and the mask entry must be set. We then
cluster the particles, using the given jet definition. The result particles are
retrieved from the cluster sequence. We still have to determine the source
indices for each jet: for each input particle, we get the jet index.
Accumulating the source entries for all particles that are part of a given
jet, we derive the jet source entries. Finally, we delete the C structures
that have been constructed by FastJet and its interface.
<<Subevents: public>>=
public :: subevt_cluster
<<Subevents: procedures>>=
subroutine subevt_cluster (subevt, pl1, dcut, mask1, jet_def, &
keep_jets, exclusive)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl1
real(default), intent(in) :: dcut
logical, dimension(:), intent(in) :: mask1
type(jet_definition_t), intent(in) :: jet_def
logical, intent(in) :: keep_jets, exclusive
integer, dimension(:), allocatable :: map, jet_index
type(pseudojet_t), dimension(:), allocatable :: jet_in, jet_out
type(pseudojet_vector_t) :: jv_in, jv_out
type(cluster_sequence_t) :: cs
integer :: i, n_src, n_active
call map_prt_index (pl1, mask1, n_src, map)
n_active = count (map /= 0)
allocate (jet_in (n_active))
allocate (jet_index (n_active))
do i = 1, n_active
call jet_in(i)%init (prt_get_momentum (pl1%prt(map(i))))
end do
call jv_in%init (jet_in)
call cs%init (jv_in, jet_def)
if (exclusive) then
jv_out = cs%exclusive_jets (dcut)
else
jv_out = cs%inclusive_jets ()
end if
call cs%assign_jet_indices (jv_out, jet_index)
allocate (jet_out (jv_out%size ()))
jet_out = jv_out
call fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map)
do i = 1, size (jet_out)
call jet_out(i)%final ()
end do
call jv_out%final ()
call cs%final ()
call jv_in%final ()
do i = 1, size (jet_in)
call jet_in(i)%final ()
end do
contains
! Uniquely combine sources and add map those new indices to the old ones
subroutine map_prt_index (pl1, mask1, n_src, map)
type(subevt_t), intent(in) :: pl1
logical, dimension(:), intent(in) :: mask1
integer, intent(out) :: n_src
integer, dimension(:), allocatable, intent(out) :: map
integer, dimension(:), allocatable :: src, src_tmp
integer :: i
allocate (src(0))
allocate (map (pl1%n_active), source = 0)
n_active = 0
do i = 1, pl1%n_active
if (.not. mask1(i)) cycle
call combine_index_lists (src_tmp, src, pl1%prt(i)%src)
if (.not. allocated (src_tmp)) cycle
call move_alloc (from=src_tmp, to=src)
n_active = n_active + 1
map(n_active) = i
end do
n_src = size (src)
end subroutine map_prt_index
! Retrieve source(s) of a jet and fill corresponding subevent
subroutine fill_pseudojet (subevt, pl1, jet_out, jet_index, n_src, map)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl1
type(pseudojet_t), dimension(:), intent(in) :: jet_out
integer, dimension(:), intent(in) :: jet_index
integer, dimension(:), intent(in) :: map
integer, intent(in) :: n_src
integer, dimension(n_src) :: src_fill
integer :: i, jet, k, combined_pdg, pdg, n_quarks, n_src_fill
logical :: is_b, is_c
call subevt_reset (subevt, size (jet_out))
do jet = 1, size (jet_out)
pdg = 0; src_fill = 0; n_src_fill = 0; combined_pdg = 0; n_quarks = 0
is_b = .false.; is_c = .false.
PARTICLE: do i = 1, size (jet_index)
if (jet_index(i) /= jet) cycle PARTICLE
associate (prt => pl1%prt(map(i)), n_src_prt => size(pl1%prt(map(i))%src))
do k = 1, n_src_prt
src_fill(n_src_fill + k) = prt%src(k)
end do
n_src_fill = n_src_fill + n_src_prt
if (is_quark (prt%pdg)) then
n_quarks = n_quarks + 1
if (.not. is_b) then
if (abs (prt%pdg) == 5) then
is_b = .true.
is_c = .false.
else if (abs (prt%pdg) == 4) then
is_c = .true.
end if
end if
if (combined_pdg == 0) combined_pdg = prt%pdg
end if
end associate
end do PARTICLE
if (keep_jets .and. n_quarks == 1) pdg = combined_pdg
call prt_init_pseudojet (subevt%prt(jet), jet_out(jet), &
src_fill(:n_src_fill), pdg, is_b, is_c)
end do
end subroutine fill_pseudojet
end subroutine subevt_cluster
@ %def subevt_cluster
@ Do recombination.
<<Subevents: public>>=
public :: subevt_recombine
<<Subevents: procedures>>=
subroutine subevt_recombine (subevt, pl, prt, mask1, reco_r0, keep_flv)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl
type(prt_t), intent(in) :: prt
logical, intent(in) :: mask1, keep_flv
real(default), intent(in) :: reco_r0
real(default), dimension(:), allocatable :: del_rij
integer, dimension(:), allocatable :: i_sortr
type(prt_t) :: prt_comb
logical :: ok
integer :: i, n, pdg_orig
n = subevt_get_length (pl)
allocate (del_rij (n), i_sortr (n))
do i = 1, n
del_rij(i) = eta_phi_distance(prt_get_momentum (prt), &
prt_get_momentum (pl%prt(i)))
end do
i_sortr = order (del_rij)
call subevt_reset (subevt, pl%n_active)
do i = 1, n
- if (i == i_sortr(n)) then
- if (del_rij (i_sortr (n)) <= reco_r0 .and. mask1) then
- pdg_orig = prt_get_pdg (pl%prt (i_sortr (n)))
- call prt_combine (prt_comb, prt, pl%prt(i_sortr (n)), ok)
+ if (i == i_sortr(1)) then
+ if (del_rij (i_sortr (1)) <= reco_r0 .and. mask1) then
+ pdg_orig = prt_get_pdg (pl%prt (i_sortr (1)))
+ call prt_combine (prt_comb, prt, pl%prt(i_sortr (1)), ok)
if (ok) then
- subevt%prt(i_sortr (n)) = prt_comb
+ subevt%prt(i_sortr (1)) = prt_comb
if (keep_flv) call prt_set_pdg &
- (subevt%prt(i_sortr (n)), pdg_orig)
+ (subevt%prt(i_sortr (1)), pdg_orig)
end if
end if
else
subevt%prt(i) = pl%prt(i)
end if
end do
end subroutine subevt_recombine
@ %def subevt_recombine
@ Return a list of all particles for which the mask is true.
<<Subevents: public>>=
public :: subevt_select
<<Subevents: procedures>>=
subroutine subevt_select (subevt, pl, mask1)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl
logical, dimension(:), intent(in) :: mask1
integer :: i, n
call subevt_reset (subevt, pl%n_active)
n = 0
do i = 1, pl%n_active
if (mask1(i)) then
n = n + 1
subevt%prt(n) = pl%prt(i)
end if
end do
subevt%n_active = n
end subroutine subevt_select
@ %def subevt_select
@ Return a subevent which consists of the single particle with
specified [[index]]. If [[index]] is negative, count from the end.
If it is out of bounds, return an empty list.
<<Subevents: public>>=
public :: subevt_extract
<<Subevents: procedures>>=
subroutine subevt_extract (subevt, pl, index)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl
integer, intent(in) :: index
if (index > 0) then
if (index <= pl%n_active) then
call subevt_reset (subevt, 1)
subevt%prt(1) = pl%prt(index)
else
call subevt_reset (subevt, 0)
end if
else if (index < 0) then
if (abs (index) <= pl%n_active) then
call subevt_reset (subevt, 1)
subevt%prt(1) = pl%prt(pl%n_active + 1 + index)
else
call subevt_reset (subevt, 0)
end if
else
call subevt_reset (subevt, 0)
end if
end subroutine subevt_extract
@ %def subevt_extract
@ Return the list of particles sorted according to increasing values
of the provided integer or real array. If no array is given, sort by
PDG value.
<<Subevents: public>>=
public :: subevt_sort
<<Subevents: interfaces>>=
interface subevt_sort
module procedure subevt_sort_pdg
module procedure subevt_sort_int
module procedure subevt_sort_real
end interface
<<Subevents: procedures>>=
subroutine subevt_sort_pdg (subevt, pl)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl
integer :: n
n = subevt%n_active
call subevt_sort_int (subevt, pl, abs (3 * subevt%prt(:n)%pdg - 1))
end subroutine subevt_sort_pdg
subroutine subevt_sort_int (subevt, pl, ival)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl
integer, dimension(:), intent(in) :: ival
call subevt_reset (subevt, pl%n_active)
subevt%n_active = pl%n_active
subevt%prt = pl%prt( order (ival) )
end subroutine subevt_sort_int
subroutine subevt_sort_real (subevt, pl, rval)
type(subevt_t), intent(inout) :: subevt
type(subevt_t), intent(in) :: pl
real(default), dimension(:), intent(in) :: rval
integer :: i
integer, dimension(size(rval)) :: idx
call subevt_reset (subevt, pl%n_active)
subevt%n_active = pl%n_active
if (allocated (subevt%prt)) deallocate (subevt%prt)
allocate (subevt%prt (size(pl%prt)))
idx = order (rval)
do i = 1, size (idx)
subevt%prt(i) = pl%prt (idx(i))
end do
end subroutine subevt_sort_real
@ %def subevt_sort
@ Return the list of particles which have any of the specified PDG
codes (and optionally particle type: beam, incoming, outgoing).
<<Subevents: public>>=
public :: subevt_select_pdg_code
<<Subevents: procedures>>=
subroutine subevt_select_pdg_code (subevt, aval, subevt_in, prt_type)
type(subevt_t), intent(inout) :: subevt
type(pdg_array_t), intent(in) :: aval
type(subevt_t), intent(in) :: subevt_in
integer, intent(in), optional :: prt_type
integer :: n_active, n_match
logical, dimension(:), allocatable :: mask
integer :: i, j
n_active = subevt_in%n_active
allocate (mask (n_active))
forall (i = 1:n_active) &
mask(i) = aval .match. subevt_in%prt(i)%pdg
if (present (prt_type)) &
mask = mask .and. subevt_in%prt(:n_active)%type == prt_type
n_match = count (mask)
call subevt_reset (subevt, n_match)
j = 0
do i = 1, n_active
if (mask(i)) then
j = j + 1
subevt%prt(j) = subevt_in%prt(i)
end if
end do
end subroutine subevt_select_pdg_code
@ %def subevt_select_pdg_code
@
\subsection{Eliminate numerical noise}
This is useful for testing purposes: set entries to zero that are smaller in
absolute values than a given tolerance parameter.
Note: instead of setting the tolerance in terms of EPSILON
(kind-dependent), we fix it to $10^{-16}$, which is the typical value
for double precision. The reason is that there are situations where
intermediate representations (external libraries, files) are limited
to double precision, even if the main program uses higher precision.
<<Subevents: public>>=
public :: pacify
<<Subevents: interfaces>>=
interface pacify
module procedure pacify_prt
module procedure pacify_subevt
end interface pacify
@ %def pacify
<<Subevents: procedures>>=
subroutine pacify_prt (prt)
class(prt_t), intent(inout) :: prt
real(default) :: e
e = max (1E-10_default * energy (prt%p), 1E-13_default)
call pacify (prt%p, e)
call pacify (prt%p2, 1E3_default * e)
end subroutine pacify_prt
subroutine pacify_subevt (subevt)
class(subevt_t), intent(inout) :: subevt
integer :: i
do i = 1, subevt%n_active
call pacify (subevt%prt(i))
end do
end subroutine pacify_subevt
@ %def pacify_prt
@ %def pacify_subevt
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Analysis tools}
This module defines structures useful for data analysis. These
include observables, histograms, and plots.
Observables are quantities that are calculated and summed up event by
event. At the end, one can compute the average and error.
Histograms have their bins in addition to the observable properties.
Histograms are usually written out in tables and displayed
graphically.
In plots, each record creates its own entry in a table. This can be
used for scatter plots if called event by event, or for plotting
dependencies on parameters if called once per integration run.
Graphs are container for histograms and plots, which carry their own graphics
options.
The type layout is still somewhat obfuscated. This would become much simpler
if type extension could be used.
<<[[analysis.f90]]>>=
<<File header>>
module analysis
<<Use kinds>>
<<Use strings>>
use io_units
use format_utils, only: quote_underscore, tex_format
use system_defs, only: TAB
use diagnostics
use os_interface
use ifiles
<<Standard module head>>
<<Analysis: public>>
<<Analysis: parameters>>
<<Analysis: types>>
<<Analysis: interfaces>>
<<Analysis: variables>>
contains
<<Analysis: procedures>>
end module analysis
@ %def analysis
@
\subsection{Output formats}
These formats share a common field width (alignment).
<<Analysis: parameters>>=
character(*), parameter, public :: HISTOGRAM_HEAD_FORMAT = "1x,A15,3x"
character(*), parameter, public :: HISTOGRAM_INTG_FORMAT = "3x,I9,3x"
character(*), parameter, public :: HISTOGRAM_DATA_FORMAT = "ES19.12"
@ %def HISTOGRAM_HEAD_FORMAT HISTOGRAM_INTG_FORMAT HISTOGRAM_DATA_FORMAT
@
\subsection{Graph options}
These parameters are used for displaying data. They apply to a whole graph,
which may contain more than one plot element.
The GAMELAN code chunks are part of both [[graph_options]] and
[[drawing_options]]. The [[drawing_options]] copy is used in histograms and
plots, also as graph elements. The [[graph_options]] copy is used for
[[graph]] objects as a whole. Both copies are usually identical.
<<Analysis: public>>=
public :: graph_options_t
<<Analysis: types>>=
type :: graph_options_t
private
type(string_t) :: id
type(string_t) :: title
type(string_t) :: description
type(string_t) :: x_label
type(string_t) :: y_label
integer :: width_mm = 130
integer :: height_mm = 90
logical :: x_log = .false.
logical :: y_log = .false.
real(default) :: x_min = 0
real(default) :: x_max = 1
real(default) :: y_min = 0
real(default) :: y_max = 1
logical :: x_min_set = .false.
logical :: x_max_set = .false.
logical :: y_min_set = .false.
logical :: y_max_set = .false.
type(string_t) :: gmlcode_bg
type(string_t) :: gmlcode_fg
end type graph_options_t
@ %def graph_options_t
@ Initialize the record, all strings are empty. The limits are undefined.
<<Analysis: public>>=
public :: graph_options_init
<<Analysis: procedures>>=
subroutine graph_options_init (graph_options)
type(graph_options_t), intent(out) :: graph_options
graph_options%id = ""
graph_options%title = ""
graph_options%description = ""
graph_options%x_label = ""
graph_options%y_label = ""
graph_options%gmlcode_bg = ""
graph_options%gmlcode_fg = ""
end subroutine graph_options_init
@ %def graph_options_init
@ Set individual options.
<<Analysis: public>>=
public :: graph_options_set
<<Analysis: procedures>>=
subroutine graph_options_set (graph_options, id, &
title, description, x_label, y_label, width_mm, height_mm, &
x_log, y_log, x_min, x_max, y_min, y_max, &
gmlcode_bg, gmlcode_fg)
type(graph_options_t), intent(inout) :: graph_options
type(string_t), intent(in), optional :: id
type(string_t), intent(in), optional :: title
type(string_t), intent(in), optional :: description
type(string_t), intent(in), optional :: x_label, y_label
integer, intent(in), optional :: width_mm, height_mm
logical, intent(in), optional :: x_log, y_log
real(default), intent(in), optional :: x_min, x_max, y_min, y_max
type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg
if (present (id)) graph_options%id = id
if (present (title)) graph_options%title = title
if (present (description)) graph_options%description = description
if (present (x_label)) graph_options%x_label = x_label
if (present (y_label)) graph_options%y_label = y_label
if (present (width_mm)) graph_options%width_mm = width_mm
if (present (height_mm)) graph_options%height_mm = height_mm
if (present (x_log)) graph_options%x_log = x_log
if (present (y_log)) graph_options%y_log = y_log
if (present (x_min)) graph_options%x_min = x_min
if (present (x_max)) graph_options%x_max = x_max
if (present (y_min)) graph_options%y_min = y_min
if (present (y_max)) graph_options%y_max = y_max
if (present (x_min)) graph_options%x_min_set = .true.
if (present (x_max)) graph_options%x_max_set = .true.
if (present (y_min)) graph_options%y_min_set = .true.
if (present (y_max)) graph_options%y_max_set = .true.
if (present (gmlcode_bg)) graph_options%gmlcode_bg = gmlcode_bg
if (present (gmlcode_fg)) graph_options%gmlcode_fg = gmlcode_fg
end subroutine graph_options_set
@ %def graph_options_set
@ Write a simple account of all options.
<<Analysis: public>>=
public :: graph_options_write
<<Analysis: procedures>>=
subroutine graph_options_write (gro, unit)
type(graph_options_t), intent(in) :: gro
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
1 format (A,1x,'"',A,'"')
2 format (A,1x,L1)
3 format (A,1x,ES19.12)
4 format (A,1x,I0)
5 format (A,1x,'[undefined]')
write (u, 1) "title =", char (gro%title)
write (u, 1) "description =", char (gro%description)
write (u, 1) "x_label =", char (gro%x_label)
write (u, 1) "y_label =", char (gro%y_label)
write (u, 2) "x_log =", gro%x_log
write (u, 2) "y_log =", gro%y_log
if (gro%x_min_set) then
write (u, 3) "x_min =", gro%x_min
else
write (u, 5) "x_min ="
end if
if (gro%x_max_set) then
write (u, 3) "x_max =", gro%x_max
else
write (u, 5) "x_max ="
end if
if (gro%y_min_set) then
write (u, 3) "y_min =", gro%y_min
else
write (u, 5) "y_min ="
end if
if (gro%y_max_set) then
write (u, 3) "y_max =", gro%y_max
else
write (u, 5) "y_max ="
end if
write (u, 4) "width_mm =", gro%width_mm
write (u, 4) "height_mm =", gro%height_mm
write (u, 1) "gmlcode_bg =", char (gro%gmlcode_bg)
write (u, 1) "gmlcode_fg =", char (gro%gmlcode_fg)
end subroutine graph_options_write
@ %def graph_options_write
@ Write a \LaTeX\ header/footer for the analysis file.
<<Analysis: procedures>>=
subroutine graph_options_write_tex_header (gro, unit)
type(graph_options_t), intent(in) :: gro
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
if (gro%title /= "") then
write (u, "(A)")
write (u, "(A)") "\section{" // char (gro%title) // "}"
else
write (u, "(A)") "\section{" // char (quote_underscore (gro%id)) // "}"
end if
if (gro%description /= "") then
write (u, "(A)") char (gro%description)
write (u, *)
write (u, "(A)") "\vspace*{\baselineskip}"
end if
write (u, "(A)") "\vspace*{\baselineskip}"
write (u, "(A)") "\unitlength 1mm"
write (u, "(A,I0,',',I0,A)") &
"\begin{gmlgraph*}(", &
gro%width_mm, gro%height_mm, &
")[dat]"
end subroutine graph_options_write_tex_header
subroutine graph_options_write_tex_footer (gro, unit)
type(graph_options_t), intent(in) :: gro
integer, intent(in), optional :: unit
integer :: u, width, height
width = gro%width_mm - 10
height = gro%height_mm - 10
u = given_output_unit (unit)
write (u, "(A)") " begingmleps ""Whizard-Logo.eps"";"
write (u, "(A,I0,A,I0,A)") &
" base := (", width, "*unitlength,", height, "*unitlength);"
write (u, "(A)") " height := 9.6*unitlength;"
write (u, "(A)") " width := 11.2*unitlength;"
write (u, "(A)") " endgmleps;"
write (u, "(A)") "\end{gmlgraph*}"
end subroutine graph_options_write_tex_footer
@ %def graph_options_write_tex_header
@ %def graph_options_write_tex_footer
@ Return the analysis object ID.
<<Analysis: procedures>>=
function graph_options_get_id (gro) result (id)
type(string_t) :: id
type(graph_options_t), intent(in) :: gro
id = gro%id
end function graph_options_get_id
@ %def graph_options_get_id
@ Create an appropriate [[setup]] command (linear/log).
<<Analysis: procedures>>=
function graph_options_get_gml_setup (gro) result (cmd)
type(string_t) :: cmd
type(graph_options_t), intent(in) :: gro
type(string_t) :: x_str, y_str
if (gro%x_log) then
x_str = "log"
else
x_str = "linear"
end if
if (gro%y_log) then
y_str = "log"
else
y_str = "linear"
end if
cmd = "setup (" // x_str // ", " // y_str // ");"
end function graph_options_get_gml_setup
@ %def graph_options_get_gml_setup
@ Return the labels in GAMELAN form.
<<Analysis: procedures>>=
function graph_options_get_gml_x_label (gro) result (cmd)
type(string_t) :: cmd
type(graph_options_t), intent(in) :: gro
cmd = 'label.bot (<' // '<' // gro%x_label // '>' // '>, out);'
end function graph_options_get_gml_x_label
function graph_options_get_gml_y_label (gro) result (cmd)
type(string_t) :: cmd
type(graph_options_t), intent(in) :: gro
cmd = 'label.ulft (<' // '<' // gro%y_label // '>' // '>, out);'
end function graph_options_get_gml_y_label
@ %def graph_options_get_gml_x_label
@ %def graph_options_get_gml_y_label
@ Create an appropriate [[graphrange]] statement for the given graph options.
Where the graph options are not set, use the supplied arguments, if any,
otherwise set the undefined value.
<<Analysis: procedures>>=
function graph_options_get_gml_graphrange &
(gro, x_min, x_max, y_min, y_max) result (cmd)
type(string_t) :: cmd
type(graph_options_t), intent(in) :: gro
real(default), intent(in), optional :: x_min, x_max, y_min, y_max
type(string_t) :: x_min_str, x_max_str, y_min_str, y_max_str
character(*), parameter :: fmt = "(ES15.8)"
if (gro%x_min_set) then
x_min_str = "#" // trim (adjustl (real2string (gro%x_min, fmt)))
else if (present (x_min)) then
x_min_str = "#" // trim (adjustl (real2string (x_min, fmt)))
else
x_min_str = "??"
end if
if (gro%x_max_set) then
x_max_str = "#" // trim (adjustl (real2string (gro%x_max, fmt)))
else if (present (x_max)) then
x_max_str = "#" // trim (adjustl (real2string (x_max, fmt)))
else
x_max_str = "??"
end if
if (gro%y_min_set) then
y_min_str = "#" // trim (adjustl (real2string (gro%y_min, fmt)))
else if (present (y_min)) then
y_min_str = "#" // trim (adjustl (real2string (y_min, fmt)))
else
y_min_str = "??"
end if
if (gro%y_max_set) then
y_max_str = "#" // trim (adjustl (real2string (gro%y_max, fmt)))
else if (present (y_max)) then
y_max_str = "#" // trim (adjustl (real2string (y_max, fmt)))
else
y_max_str = "??"
end if
cmd = "graphrange (" // x_min_str // ", " // y_min_str // "), " &
// "(" // x_max_str // ", " // y_max_str // ");"
end function graph_options_get_gml_graphrange
@ %def graph_options_get_gml_graphrange
@ Get extra GAMELAN code to be executed before and after the usual drawing
commands.
<<Analysis: procedures>>=
function graph_options_get_gml_bg_command (gro) result (cmd)
type(string_t) :: cmd
type(graph_options_t), intent(in) :: gro
cmd = gro%gmlcode_bg
end function graph_options_get_gml_bg_command
function graph_options_get_gml_fg_command (gro) result (cmd)
type(string_t) :: cmd
type(graph_options_t), intent(in) :: gro
cmd = gro%gmlcode_fg
end function graph_options_get_gml_fg_command
@ %def graph_options_get_gml_bg_command
@ %def graph_options_get_gml_fg_command
@ Append the header for generic data output in ifile format. We print only
labels, not graphics parameters.
<<Analysis: procedures>>=
subroutine graph_options_get_header (pl, header, comment)
type(graph_options_t), intent(in) :: pl
type(ifile_t), intent(inout) :: header
type(string_t), intent(in), optional :: comment
type(string_t) :: c
if (present (comment)) then
c = comment
else
c = ""
end if
call ifile_append (header, &
c // "ID: " // pl%id)
call ifile_append (header, &
c // "title: " // pl%title)
call ifile_append (header, &
c // "description: " // pl%description)
call ifile_append (header, &
c // "x axis label: " // pl%x_label)
call ifile_append (header, &
c // "y axis label: " // pl%y_label)
end subroutine graph_options_get_header
@ %def graph_options_get_header
@
\subsection{Drawing options}
These options apply to an individual graph element (histogram or plot).
<<Analysis: public>>=
public :: drawing_options_t
<<Analysis: types>>=
type :: drawing_options_t
type(string_t) :: dataset
logical :: with_hbars = .false.
logical :: with_base = .false.
logical :: piecewise = .false.
logical :: fill = .false.
logical :: draw = .false.
logical :: err = .false.
logical :: symbols = .false.
type(string_t) :: fill_options
type(string_t) :: draw_options
type(string_t) :: err_options
type(string_t) :: symbol
type(string_t) :: gmlcode_bg
type(string_t) :: gmlcode_fg
end type drawing_options_t
@ %def drawing_options_t
@ Write a simple account of all options.
<<Analysis: public>>=
public :: drawing_options_write
<<Analysis: procedures>>=
subroutine drawing_options_write (dro, unit)
type(drawing_options_t), intent(in) :: dro
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
1 format (A,1x,'"',A,'"')
2 format (A,1x,L1)
write (u, 2) "with_hbars =", dro%with_hbars
write (u, 2) "with_base =", dro%with_base
write (u, 2) "piecewise =", dro%piecewise
write (u, 2) "fill =", dro%fill
write (u, 2) "draw =", dro%draw
write (u, 2) "err =", dro%err
write (u, 2) "symbols =", dro%symbols
write (u, 1) "fill_options=", char (dro%fill_options)
write (u, 1) "draw_options=", char (dro%draw_options)
write (u, 1) "err_options =", char (dro%err_options)
write (u, 1) "symbol =", char (dro%symbol)
write (u, 1) "gmlcode_bg =", char (dro%gmlcode_bg)
write (u, 1) "gmlcode_fg =", char (dro%gmlcode_fg)
end subroutine drawing_options_write
@ %def drawing_options_write
@ Init with empty strings and default options, appropriate for either
histogram or plot.
<<Analysis: public>>=
public :: drawing_options_init_histogram
public :: drawing_options_init_plot
<<Analysis: procedures>>=
subroutine drawing_options_init_histogram (dro)
type(drawing_options_t), intent(out) :: dro
dro%dataset = "dat"
dro%with_hbars = .true.
dro%with_base = .true.
dro%piecewise = .true.
dro%fill = .true.
dro%draw = .true.
dro%fill_options = "withcolor col.default"
dro%draw_options = ""
dro%err_options = ""
dro%symbol = "fshape(circle scaled 1mm)()"
dro%gmlcode_bg = ""
dro%gmlcode_fg = ""
end subroutine drawing_options_init_histogram
subroutine drawing_options_init_plot (dro)
type(drawing_options_t), intent(out) :: dro
dro%dataset = "dat"
dro%draw = .true.
dro%fill_options = "withcolor col.default"
dro%draw_options = ""
dro%err_options = ""
dro%symbol = "fshape(circle scaled 1mm)()"
dro%gmlcode_bg = ""
dro%gmlcode_fg = ""
end subroutine drawing_options_init_plot
@ %def drawing_options_init_histogram
@ %def drawing_options_init_plot
@ Set individual options.
<<Analysis: public>>=
public :: drawing_options_set
<<Analysis: procedures>>=
subroutine drawing_options_set (dro, dataset, &
with_hbars, with_base, piecewise, fill, draw, err, symbols, &
fill_options, draw_options, err_options, symbol, &
gmlcode_bg, gmlcode_fg)
type(drawing_options_t), intent(inout) :: dro
type(string_t), intent(in), optional :: dataset
logical, intent(in), optional :: with_hbars, with_base, piecewise
logical, intent(in), optional :: fill, draw, err, symbols
type(string_t), intent(in), optional :: fill_options, draw_options
type(string_t), intent(in), optional :: err_options, symbol
type(string_t), intent(in), optional :: gmlcode_bg, gmlcode_fg
if (present (dataset)) dro%dataset = dataset
if (present (with_hbars)) dro%with_hbars = with_hbars
if (present (with_base)) dro%with_base = with_base
if (present (piecewise)) dro%piecewise = piecewise
if (present (fill)) dro%fill = fill
if (present (draw)) dro%draw = draw
if (present (err)) dro%err = err
if (present (symbols)) dro%symbols = symbols
if (present (fill_options)) dro%fill_options = fill_options
if (present (draw_options)) dro%draw_options = draw_options
if (present (err_options)) dro%err_options = err_options
if (present (symbol)) dro%symbol = symbol
if (present (gmlcode_bg)) dro%gmlcode_bg = gmlcode_bg
if (present (gmlcode_fg)) dro%gmlcode_fg = gmlcode_fg
end subroutine drawing_options_set
@ %def drawing_options_set
@ There are sepate commands for drawing the
curve and for drawing errors. The symbols are applied to the latter. First
of all, we may have to compute a baseline:
<<Analysis: procedures>>=
function drawing_options_get_calc_command (dro) result (cmd)
type(string_t) :: cmd
type(drawing_options_t), intent(in) :: dro
if (dro%with_base) then
cmd = "calculate " // dro%dataset // ".base (" // dro%dataset // ") " &
// "(x, #0);"
else
cmd = ""
end if
end function drawing_options_get_calc_command
@ %def drawing_options_get_calc_command
@ Return the drawing command.
<<Analysis: procedures>>=
function drawing_options_get_draw_command (dro) result (cmd)
type(string_t) :: cmd
type(drawing_options_t), intent(in) :: dro
if (dro%fill) then
cmd = "fill"
else if (dro%draw) then
cmd = "draw"
else
cmd = ""
end if
if (dro%fill .or. dro%draw) then
if (dro%piecewise) cmd = cmd // " piecewise"
if (dro%draw .and. dro%with_base) cmd = cmd // " cyclic"
cmd = cmd // " from (" // dro%dataset
if (dro%with_base) then
if (dro%piecewise) then
cmd = cmd // ", " // dro%dataset // ".base/\" ! "
else
cmd = cmd // " ~ " // dro%dataset // ".base\" ! "
end if
end if
cmd = cmd // ")"
if (dro%fill) then
cmd = cmd // " " // dro%fill_options
if (dro%draw) cmd = cmd // " outlined"
end if
if (dro%draw) cmd = cmd // " " // dro%draw_options
cmd = cmd // ";"
end if
end function drawing_options_get_draw_command
@ %def drawing_options_get_draw_command
@ The error command draws error bars, if any.
<<Analysis: procedures>>=
function drawing_options_get_err_command (dro) result (cmd)
type(string_t) :: cmd
type(drawing_options_t), intent(in) :: dro
if (dro%err) then
cmd = "draw piecewise " &
// "from (" // dro%dataset // ".err)" &
// " " // dro%err_options // ";"
else
cmd = ""
end if
end function drawing_options_get_err_command
@ %def drawing_options_get_err_command
@ The symbol command draws symbols, if any.
<<Analysis: procedures>>=
function drawing_options_get_symb_command (dro) result (cmd)
type(string_t) :: cmd
type(drawing_options_t), intent(in) :: dro
if (dro%symbols) then
cmd = "phantom" &
// " from (" // dro%dataset // ")" &
// " withsymbol (" // dro%symbol // ");"
else
cmd = ""
end if
end function drawing_options_get_symb_command
@ %def drawing_options_get_symb_command
@ Get extra GAMELAN code to be executed before and after the usual drawing
commands.
<<Analysis: procedures>>=
function drawing_options_get_gml_bg_command (dro) result (cmd)
type(string_t) :: cmd
type(drawing_options_t), intent(in) :: dro
cmd = dro%gmlcode_bg
end function drawing_options_get_gml_bg_command
function drawing_options_get_gml_fg_command (dro) result (cmd)
type(string_t) :: cmd
type(drawing_options_t), intent(in) :: dro
cmd = dro%gmlcode_fg
end function drawing_options_get_gml_fg_command
@ %def drawing_options_get_gml_bg_command
@ %def drawing_options_get_gml_fg_command
@
\subsection{Observables}
The observable type holds the accumulated observable values and weight
sums which are necessary for proper averaging.
<<Analysis: types>>=
type :: observable_t
private
real(default) :: sum_values = 0
real(default) :: sum_squared_values = 0
real(default) :: sum_weights = 0
real(default) :: sum_squared_weights = 0
integer :: count = 0
type(string_t) :: obs_label
type(string_t) :: obs_unit
type(graph_options_t) :: graph_options
end type observable_t
@ %def observable_t
@ Initialize with defined properties
<<Analysis: procedures>>=
subroutine observable_init (obs, obs_label, obs_unit, graph_options)
type(observable_t), intent(out) :: obs
type(string_t), intent(in), optional :: obs_label, obs_unit
type(graph_options_t), intent(in), optional :: graph_options
if (present (obs_label)) then
obs%obs_label = obs_label
else
obs%obs_label = ""
end if
if (present (obs_unit)) then
obs%obs_unit = obs_unit
else
obs%obs_unit = ""
end if
if (present (graph_options)) then
obs%graph_options = graph_options
else
call graph_options_init (obs%graph_options)
end if
end subroutine observable_init
@ %def observable_init
@ Reset all numeric entries.
<<Analysis: procedures>>=
subroutine observable_clear (obs)
type(observable_t), intent(inout) :: obs
obs%sum_values = 0
obs%sum_squared_values = 0
obs%sum_weights = 0
obs%sum_squared_weights = 0
obs%count = 0
end subroutine observable_clear
@ %def observable_clear
@ Record a value. Always successful for observables.
<<Analysis: interfaces>>=
interface observable_record_value
module procedure observable_record_value_unweighted
module procedure observable_record_value_weighted
end interface
<<Analysis: procedures>>=
subroutine observable_record_value_unweighted (obs, value, success)
type(observable_t), intent(inout) :: obs
real(default), intent(in) :: value
logical, intent(out), optional :: success
obs%sum_values = obs%sum_values + value
obs%sum_squared_values = obs%sum_squared_values + value**2
obs%sum_weights = obs%sum_weights + 1
obs%sum_squared_weights = obs%sum_squared_weights + 1
obs%count = obs%count + 1
if (present (success)) success = .true.
end subroutine observable_record_value_unweighted
subroutine observable_record_value_weighted (obs, value, weight, success)
type(observable_t), intent(inout) :: obs
real(default), intent(in) :: value, weight
logical, intent(out), optional :: success
obs%sum_values = obs%sum_values + value * weight
obs%sum_squared_values = obs%sum_squared_values + value**2 * weight
obs%sum_weights = obs%sum_weights + weight
obs%sum_squared_weights = obs%sum_squared_weights + weight**2
obs%count = obs%count + 1
if (present (success)) success = .true.
end subroutine observable_record_value_weighted
@ %def observable_record_value
@ Here are the statistics formulas:
\begin{enumerate}
\item Unweighted case:
Given a sample of $n$ values $x_i$, the average is
\begin{equation}
\langle x \rangle = \frac{\sum x_i}{n}
\end{equation}
and the error estimate
\begin{align}
\Delta x &= \sqrt{\frac{1}{n-1}\langle{\sum(x_i - \langle x\rangle)^2}}
\\
&= \sqrt{\frac{1}{n-1}
\left(\frac{\sum x_i^2}{n} - \frac{(\sum x_i)^2}{n^2}\right)}
\end{align}
\item Weighted case:
Instead of weight 1, each event comes with weight $w_i$.
\begin{equation}
\langle x \rangle = \frac{\sum x_i w_i}{\sum w_i}
\end{equation}
and
\begin{equation}
\Delta x
= \sqrt{\frac{1}{n-1}
\left(\frac{\sum x_i^2 w_i}{\sum w_i}
- \frac{(\sum x_i w_i)^2}{(\sum w_i)^2}\right)}
\end{equation}
For $w_i=1$, this specializes to the previous formula.
\end{enumerate}
<<Analysis: procedures>>=
function observable_get_n_entries (obs) result (n)
integer :: n
type(observable_t), intent(in) :: obs
n = obs%count
end function observable_get_n_entries
function observable_get_average (obs) result (avg)
real(default) :: avg
type(observable_t), intent(in) :: obs
if (obs%sum_weights /= 0) then
avg = obs%sum_values / obs%sum_weights
else
avg = 0
end if
end function observable_get_average
function observable_get_error (obs) result (err)
real(default) :: err
type(observable_t), intent(in) :: obs
real(default) :: var, n
if (obs%sum_weights /= 0) then
select case (obs%count)
case (0:1)
err = 0
case default
n = obs%count
var = obs%sum_squared_values / obs%sum_weights &
- (obs%sum_values / obs%sum_weights) ** 2
err = sqrt (max (var, 0._default) / (n - 1))
end select
else
err = 0
end if
end function observable_get_error
@ %def observable_get_n_entries
@ %def observable_get_sum
@ %def observable_get_average
@ %def observable_get_error
@ Write label and/or physical unit to a string.
<<Analysis: procedures>>=
function observable_get_label (obs, wl, wu) result (string)
type(string_t) :: string
type(observable_t), intent(in) :: obs
logical, intent(in) :: wl, wu
type(string_t) :: obs_label, obs_unit
if (wl) then
if (obs%obs_label /= "") then
obs_label = obs%obs_label
else
obs_label = "\textrm{Observable}"
end if
else
obs_label = ""
end if
if (wu) then
if (obs%obs_unit /= "") then
if (wl) then
obs_unit = "\;[" // obs%obs_unit // "]"
else
obs_unit = obs%obs_unit
end if
else
obs_unit = ""
end if
else
obs_unit = ""
end if
string = obs_label // obs_unit
end function observable_get_label
@ %def observable_get_label
@
\subsection{Output}
<<Analysis: procedures>>=
subroutine observable_write (obs, unit)
type(observable_t), intent(in) :: obs
integer, intent(in), optional :: unit
real(default) :: avg, err, relerr
integer :: n
integer :: u
u = given_output_unit (unit); if (u < 0) return
avg = observable_get_average (obs)
err = observable_get_error (obs)
if (avg /= 0) then
relerr = err / abs (avg)
else
relerr = 0
end if
n = observable_get_n_entries (obs)
if (obs%graph_options%title /= "") then
write (u, "(A,1x,3A)") &
"title =", '"', char (obs%graph_options%title), '"'
end if
if (obs%graph_options%title /= "") then
write (u, "(A,1x,3A)") &
"description =", '"', char (obs%graph_options%description), '"'
end if
write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") &
"average =", avg
call write_unit ()
write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")", advance = "no") &
"error[abs] =", err
call write_unit ()
write (u, "(A,1x," // HISTOGRAM_DATA_FORMAT // ")") &
"error[rel] =", relerr
write (u, "(A,1x,I0)") &
"n_entries =", n
contains
subroutine write_unit ()
if (obs%obs_unit /= "") then
write (u, "(1x,A)") char (obs%obs_unit)
else
write (u, *)
end if
end subroutine write_unit
end subroutine observable_write
@ %def observable_write
@ \LaTeX\ output.
<<Analysis: procedures>>=
subroutine observable_write_driver (obs, unit, write_heading)
type(observable_t), intent(in) :: obs
integer, intent(in), optional :: unit
logical, intent(in), optional :: write_heading
real(default) :: avg, err
integer :: n_digits
logical :: heading
integer :: u
u = given_output_unit (unit); if (u < 0) return
heading = .true.; if (present (write_heading)) heading = write_heading
avg = observable_get_average (obs)
err = observable_get_error (obs)
if (avg /= 0 .and. err /= 0) then
n_digits = max (2, 2 - int (log10 (abs (err / real (avg, default)))))
else if (avg /= 0) then
n_digits = 100
else
n_digits = 1
end if
if (heading) then
write (u, "(A)")
if (obs%graph_options%title /= "") then
write (u, "(A)") "\section{" // char (obs%graph_options%title) &
// "}"
else
write (u, "(A)") "\section{Observable}"
end if
if (obs%graph_options%description /= "") then
write (u, "(A)") char (obs%graph_options%description)
write (u, *)
end if
write (u, "(A)") "\begin{flushleft}"
end if
write (u, "(A)", advance="no") " $\langle{" ! $ sign
write (u, "(A)", advance="no") char (observable_get_label (obs, wl=.true., wu=.false.))
write (u, "(A)", advance="no") "}\rangle = "
write (u, "(A)", advance="no") char (tex_format (avg, n_digits))
write (u, "(A)", advance="no") "\pm"
write (u, "(A)", advance="no") char (tex_format (err, 2))
write (u, "(A)", advance="no") "\;{"
write (u, "(A)", advance="no") char (observable_get_label (obs, wl=.false., wu=.true.))
write (u, "(A)") "}"
write (u, "(A)", advance="no") " \quad[n_{\text{entries}} = "
write (u, "(I0)",advance="no") observable_get_n_entries (obs)
write (u, "(A)") "]$" ! $ fool Emacs' noweb mode
if (heading) then
write (u, "(A)") "\end{flushleft}"
end if
end subroutine observable_write_driver
@ %def observable_write_driver
@
\subsection{Histograms}
\subsubsection{Bins}
<<Analysis: types>>=
type :: bin_t
private
real(default) :: midpoint = 0
real(default) :: width = 0
real(default) :: sum_weights = 0
real(default) :: sum_squared_weights = 0
real(default) :: sum_excess_weights = 0
integer :: count = 0
end type bin_t
@ %def bin_t
<<Analysis: procedures>>=
subroutine bin_init (bin, midpoint, width)
type(bin_t), intent(out) :: bin
real(default), intent(in) :: midpoint, width
bin%midpoint = midpoint
bin%width = width
end subroutine bin_init
@ %def bin_init
<<Analysis: procedures>>=
elemental subroutine bin_clear (bin)
type(bin_t), intent(inout) :: bin
bin%sum_weights = 0
bin%sum_squared_weights = 0
bin%sum_excess_weights = 0
bin%count = 0
end subroutine bin_clear
@ %def bin_clear
<<Analysis: procedures>>=
subroutine bin_record_value (bin, normalize, weight, excess)
type(bin_t), intent(inout) :: bin
logical, intent(in) :: normalize
real(default), intent(in) :: weight
real(default), intent(in), optional :: excess
real(default) :: w, e
if (normalize) then
if (bin%width /= 0) then
w = weight / bin%width
if (present (excess)) e = excess / bin%width
else
w = 0
if (present (excess)) e = 0
end if
else
w = weight
if (present (excess)) e = excess
end if
bin%sum_weights = bin%sum_weights + w
bin%sum_squared_weights = bin%sum_squared_weights + w ** 2
if (present (excess)) &
bin%sum_excess_weights = bin%sum_excess_weights + abs (e)
bin%count = bin%count + 1
end subroutine bin_record_value
@ %def bin_record_value
<<Analysis: procedures>>=
function bin_get_midpoint (bin) result (x)
real(default) :: x
type(bin_t), intent(in) :: bin
x = bin%midpoint
end function bin_get_midpoint
function bin_get_width (bin) result (w)
real(default) :: w
type(bin_t), intent(in) :: bin
w = bin%width
end function bin_get_width
function bin_get_n_entries (bin) result (n)
integer :: n
type(bin_t), intent(in) :: bin
n = bin%count
end function bin_get_n_entries
function bin_get_sum (bin) result (s)
real(default) :: s
type(bin_t), intent(in) :: bin
s = bin%sum_weights
end function bin_get_sum
function bin_get_error (bin) result (err)
real(default) :: err
type(bin_t), intent(in) :: bin
err = sqrt (bin%sum_squared_weights)
end function bin_get_error
function bin_get_excess (bin) result (excess)
real(default) :: excess
type(bin_t), intent(in) :: bin
excess = bin%sum_excess_weights
end function bin_get_excess
@ %def bin_get_midpoint
@ %def bin_get_width
@ %def bin_get_n_entries
@ %def bin_get_sum
@ %def bin_get_error
@ %def bin_get_excess
<<Analysis: procedures>>=
subroutine bin_write_header (unit)
integer, intent(in), optional :: unit
character(120) :: buffer
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (buffer, "(A,4(1x," //HISTOGRAM_HEAD_FORMAT // "),2x,A)") &
"#", "bin midpoint", "value ", "error ", &
"excess ", "n"
write (u, "(A)") trim (buffer)
end subroutine bin_write_header
subroutine bin_write (bin, unit)
type(bin_t), intent(in) :: bin
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "),2x,I0)") &
bin_get_midpoint (bin), &
bin_get_sum (bin), &
bin_get_error (bin), &
bin_get_excess (bin), &
bin_get_n_entries (bin)
end subroutine bin_write
@ %def bin_write_header
@ %def bin_write
@
\subsubsection{Histograms}
<<Analysis: types>>=
type :: histogram_t
private
real(default) :: lower_bound = 0
real(default) :: upper_bound = 0
real(default) :: width = 0
integer :: n_bins = 0
logical :: normalize_bins = .false.
type(observable_t) :: obs
type(observable_t) :: obs_within_bounds
type(bin_t) :: underflow
type(bin_t), dimension(:), allocatable :: bin
type(bin_t) :: overflow
type(graph_options_t) :: graph_options
type(drawing_options_t) :: drawing_options
end type histogram_t
@ %def histogram_t
@
\subsubsection{Initializer/finalizer}
Initialize a histogram. We may provide either the bin width or the
number of bins. A finalizer is not needed, since the histogram contains no
pointer (sub)components.
<<Analysis: interfaces>>=
interface histogram_init
module procedure histogram_init_n_bins
module procedure histogram_init_bin_width
end interface
<<Analysis: procedures>>=
subroutine histogram_init_n_bins (h, id, &
lower_bound, upper_bound, n_bins, normalize_bins, &
obs_label, obs_unit, graph_options, drawing_options)
type(histogram_t), intent(out) :: h
type(string_t), intent(in) :: id
real(default), intent(in) :: lower_bound, upper_bound
integer, intent(in) :: n_bins
logical, intent(in) :: normalize_bins
type(string_t), intent(in), optional :: obs_label, obs_unit
type(graph_options_t), intent(in), optional :: graph_options
type(drawing_options_t), intent(in), optional :: drawing_options
real(default) :: bin_width
integer :: i
call observable_init (h%obs_within_bounds, obs_label, obs_unit)
call observable_init (h%obs, obs_label, obs_unit)
h%lower_bound = lower_bound
h%upper_bound = upper_bound
h%n_bins = max (n_bins, 1)
h%width = h%upper_bound - h%lower_bound
h%normalize_bins = normalize_bins
bin_width = h%width / h%n_bins
allocate (h%bin (h%n_bins))
call bin_init (h%underflow, h%lower_bound, 0._default)
do i = 1, h%n_bins
call bin_init (h%bin(i), &
h%lower_bound - bin_width/2 + i * bin_width, bin_width)
end do
call bin_init (h%overflow, h%upper_bound, 0._default)
if (present (graph_options)) then
h%graph_options = graph_options
else
call graph_options_init (h%graph_options)
end if
call graph_options_set (h%graph_options, id = id)
if (present (drawing_options)) then
h%drawing_options = drawing_options
else
call drawing_options_init_histogram (h%drawing_options)
end if
end subroutine histogram_init_n_bins
subroutine histogram_init_bin_width (h, id, &
lower_bound, upper_bound, bin_width, normalize_bins, &
obs_label, obs_unit, graph_options, drawing_options)
type(histogram_t), intent(out) :: h
type(string_t), intent(in) :: id
real(default), intent(in) :: lower_bound, upper_bound, bin_width
logical, intent(in) :: normalize_bins
type(string_t), intent(in), optional :: obs_label, obs_unit
type(graph_options_t), intent(in), optional :: graph_options
type(drawing_options_t), intent(in), optional :: drawing_options
integer :: n_bins
if (bin_width /= 0) then
n_bins = nint ((upper_bound - lower_bound) / bin_width)
else
n_bins = 1
end if
call histogram_init_n_bins (h, id, &
lower_bound, upper_bound, n_bins, normalize_bins, &
obs_label, obs_unit, graph_options, drawing_options)
end subroutine histogram_init_bin_width
@ %def histogram_init
@ Initialize a histogram by copying another one.
Since [[h]] has no pointer (sub)components, intrinsic assignment is
sufficient. Optionally, we replace the drawing options.
<<Analysis: procedures>>=
subroutine histogram_init_histogram (h, h_in, drawing_options)
type(histogram_t), intent(out) :: h
type(histogram_t), intent(in) :: h_in
type(drawing_options_t), intent(in), optional :: drawing_options
h = h_in
if (present (drawing_options)) then
h%drawing_options = drawing_options
end if
end subroutine histogram_init_histogram
@ %def histogram_init_histogram
@
\subsubsection{Fill histograms}
Clear the histogram contents, but do not modify the structure.
<<Analysis: procedures>>=
subroutine histogram_clear (h)
type(histogram_t), intent(inout) :: h
call observable_clear (h%obs)
call observable_clear (h%obs_within_bounds)
call bin_clear (h%underflow)
if (allocated (h%bin)) call bin_clear (h%bin)
call bin_clear (h%overflow)
end subroutine histogram_clear
@ %def histogram_clear
@ Record a value. Successful if the value is within bounds, otherwise
it is recorded as under-/overflow. Optionally, we may provide an
excess weight that could be returned by the unweighting procedure.
<<Analysis: procedures>>=
subroutine histogram_record_value_unweighted (h, value, excess, success)
type(histogram_t), intent(inout) :: h
real(default), intent(in) :: value
real(default), intent(in), optional :: excess
logical, intent(out), optional :: success
integer :: i_bin
call observable_record_value (h%obs, value)
if (h%width /= 0) then
i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1
else
i_bin = 0
end if
if (i_bin <= 0) then
call bin_record_value (h%underflow, .false., 1._default, excess)
if (present (success)) success = .false.
else if (i_bin <= h%n_bins) then
call observable_record_value (h%obs_within_bounds, value)
call bin_record_value &
(h%bin(i_bin), h%normalize_bins, 1._default, excess)
if (present (success)) success = .true.
else
call bin_record_value (h%overflow, .false., 1._default, excess)
if (present (success)) success = .false.
end if
end subroutine histogram_record_value_unweighted
@ %def histogram_record_value_unweighted
@ Weighted events: analogous, but no excess weight.
<<Analysis: procedures>>=
subroutine histogram_record_value_weighted (h, value, weight, success)
type(histogram_t), intent(inout) :: h
real(default), intent(in) :: value, weight
logical, intent(out), optional :: success
integer :: i_bin
call observable_record_value (h%obs, value, weight)
if (h%width /= 0) then
i_bin = floor (((value - h%lower_bound) / h%width) * h%n_bins) + 1
else
i_bin = 0
end if
if (i_bin <= 0) then
call bin_record_value (h%underflow, .false., weight)
if (present (success)) success = .false.
else if (i_bin <= h%n_bins) then
call observable_record_value (h%obs_within_bounds, value, weight)
call bin_record_value (h%bin(i_bin), h%normalize_bins, weight)
if (present (success)) success = .true.
else
call bin_record_value (h%overflow, .false., weight)
if (present (success)) success = .false.
end if
end subroutine histogram_record_value_weighted
@ %def histogram_record_value_weighted
@
\subsubsection{Access contents}
Inherited from the observable component (all-over average etc.)
<<Analysis: procedures>>=
function histogram_get_n_entries (h) result (n)
integer :: n
type(histogram_t), intent(in) :: h
n = observable_get_n_entries (h%obs)
end function histogram_get_n_entries
function histogram_get_average (h) result (avg)
real(default) :: avg
type(histogram_t), intent(in) :: h
avg = observable_get_average (h%obs)
end function histogram_get_average
function histogram_get_error (h) result (err)
real(default) :: err
type(histogram_t), intent(in) :: h
err = observable_get_error (h%obs)
end function histogram_get_error
@ %def histogram_get_n_entries
@ %def histogram_get_average
@ %def histogram_get_error
@ Analogous, but applied only to events within bounds.
<<Analysis: procedures>>=
function histogram_get_n_entries_within_bounds (h) result (n)
integer :: n
type(histogram_t), intent(in) :: h
n = observable_get_n_entries (h%obs_within_bounds)
end function histogram_get_n_entries_within_bounds
function histogram_get_average_within_bounds (h) result (avg)
real(default) :: avg
type(histogram_t), intent(in) :: h
avg = observable_get_average (h%obs_within_bounds)
end function histogram_get_average_within_bounds
function histogram_get_error_within_bounds (h) result (err)
real(default) :: err
type(histogram_t), intent(in) :: h
err = observable_get_error (h%obs_within_bounds)
end function histogram_get_error_within_bounds
@ %def histogram_get_n_entries_within_bounds
@ %def histogram_get_average_within_bounds
@ %def histogram_get_error_within_bounds
Get the number of bins
<<Analysis: procedures>>=
function histogram_get_n_bins (h) result (n)
type(histogram_t), intent(in) :: h
integer :: n
n = h%n_bins
end function histogram_get_n_bins
@ %def histogram_get_n_bins
@ Check bins. If the index is zero or above the limit, return the
results for underflow or overflow, respectively.
<<Analysis: procedures>>=
function histogram_get_n_entries_for_bin (h, i) result (n)
integer :: n
type(histogram_t), intent(in) :: h
integer, intent(in) :: i
if (i <= 0) then
n = bin_get_n_entries (h%underflow)
else if (i <= h%n_bins) then
n = bin_get_n_entries (h%bin(i))
else
n = bin_get_n_entries (h%overflow)
end if
end function histogram_get_n_entries_for_bin
function histogram_get_sum_for_bin (h, i) result (avg)
real(default) :: avg
type(histogram_t), intent(in) :: h
integer, intent(in) :: i
if (i <= 0) then
avg = bin_get_sum (h%underflow)
else if (i <= h%n_bins) then
avg = bin_get_sum (h%bin(i))
else
avg = bin_get_sum (h%overflow)
end if
end function histogram_get_sum_for_bin
function histogram_get_error_for_bin (h, i) result (err)
real(default) :: err
type(histogram_t), intent(in) :: h
integer, intent(in) :: i
if (i <= 0) then
err = bin_get_error (h%underflow)
else if (i <= h%n_bins) then
err = bin_get_error (h%bin(i))
else
err = bin_get_error (h%overflow)
end if
end function histogram_get_error_for_bin
function histogram_get_excess_for_bin (h, i) result (err)
real(default) :: err
type(histogram_t), intent(in) :: h
integer, intent(in) :: i
if (i <= 0) then
err = bin_get_excess (h%underflow)
else if (i <= h%n_bins) then
err = bin_get_excess (h%bin(i))
else
err = bin_get_excess (h%overflow)
end if
end function histogram_get_excess_for_bin
@ %def histogram_get_n_entries_for_bin
@ %def histogram_get_sum_for_bin
@ %def histogram_get_error_for_bin
@ %def histogram_get_excess_for_bin
@ Return a pointer to the graph options.
<<Analysis: procedures>>=
function histogram_get_graph_options_ptr (h) result (ptr)
type(graph_options_t), pointer :: ptr
type(histogram_t), intent(in), target :: h
ptr => h%graph_options
end function histogram_get_graph_options_ptr
@ %def histogram_get_graph_options_ptr
@ Return a pointer to the drawing options.
<<Analysis: procedures>>=
function histogram_get_drawing_options_ptr (h) result (ptr)
type(drawing_options_t), pointer :: ptr
type(histogram_t), intent(in), target :: h
ptr => h%drawing_options
end function histogram_get_drawing_options_ptr
@ %def histogram_get_drawing_options_ptr
@
\subsubsection{Output}
<<Analysis: procedures>>=
subroutine histogram_write (h, unit)
type(histogram_t), intent(in) :: h
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call bin_write_header (u)
if (allocated (h%bin)) then
do i = 1, h%n_bins
call bin_write (h%bin(i), u)
end do
end if
write (u, "(A)")
write (u, "(A,1x,A)") "#", "Underflow:"
call bin_write (h%underflow, u)
write (u, "(A)")
write (u, "(A,1x,A)") "#", "Overflow:"
call bin_write (h%overflow, u)
write (u, "(A)")
write (u, "(A,1x,A)") "#", "Summary: data within bounds"
call observable_write (h%obs_within_bounds, u)
write (u, "(A)")
write (u, "(A,1x,A)") "#", "Summary: all data"
call observable_write (h%obs, u)
write (u, "(A)")
end subroutine histogram_write
@ %def histogram_write
@ Write the GAMELAN reader for histogram contents.
<<Analysis: procedures>>=
subroutine histogram_write_gml_reader (h, filename, unit)
type(histogram_t), intent(in) :: h
type(string_t), intent(in) :: filename
integer, intent(in), optional :: unit
character(*), parameter :: fmt = "(ES15.8)"
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(2x,A)") 'fromfile "' // char (filename) // '":'
write (u, "(4x,A)") 'key "# Histogram:";'
write (u, "(4x,A)") 'dx := #' &
// real2char (h%width / h%n_bins / 2, fmt) // ';'
write (u, "(4x,A)") 'for i withinblock:'
write (u, "(6x,A)") 'get x, y, y.d, y.n, y.e;'
if (h%drawing_options%with_hbars) then
write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) &
// ') (x,y) hbar dx;'
else
write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) &
// ') (x,y);'
end if
if (h%drawing_options%err) then
write (u, "(6x,A)") 'plot (' // char (h%drawing_options%dataset) &
// '.err) ' &
// '(x,y) vbar y.d;'
end if
!!! Future excess options for plots
! write (u, "(6x,A)") 'if show_excess: ' // &
! & 'plot(dat.e)(x, y plus y.e) hbar dx; fi'
write (u, "(4x,A)") 'endfor'
write (u, "(2x,A)") 'endfrom'
end subroutine histogram_write_gml_reader
@ %def histogram_write_gml_reader
@ \LaTeX\ and GAMELAN output.
<<Analysis: procedures>>=
subroutine histogram_write_gml_driver (h, filename, unit)
type(histogram_t), intent(in) :: h
type(string_t), intent(in) :: filename
integer, intent(in), optional :: unit
type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
integer :: u
u = given_output_unit (unit); if (u < 0) return
call graph_options_write_tex_header (h%graph_options, unit)
write (u, "(2x,A)") char (graph_options_get_gml_setup (h%graph_options))
write (u, "(2x,A)") char (graph_options_get_gml_graphrange &
(h%graph_options, x_min=h%lower_bound, x_max=h%upper_bound))
call histogram_write_gml_reader (h, filename, unit)
calc_cmd = drawing_options_get_calc_command (h%drawing_options)
if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd)
bg_cmd = drawing_options_get_gml_bg_command (h%drawing_options)
if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd)
draw_cmd = drawing_options_get_draw_command (h%drawing_options)
if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd)
err_cmd = drawing_options_get_err_command (h%drawing_options)
if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd)
symb_cmd = drawing_options_get_symb_command (h%drawing_options)
if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd)
fg_cmd = drawing_options_get_gml_fg_command (h%drawing_options)
if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd)
write (u, "(2x,A)") char (graph_options_get_gml_x_label (h%graph_options))
write (u, "(2x,A)") char (graph_options_get_gml_y_label (h%graph_options))
call graph_options_write_tex_footer (h%graph_options, unit)
write (u, "(A)") "\vspace*{2\baselineskip}"
write (u, "(A)") "\begin{flushleft}"
write (u, "(A)") "\textbf{Data within bounds:} \\"
call observable_write_driver (h%obs_within_bounds, unit, &
write_heading=.false.)
write (u, "(A)") "\\[0.5\baselineskip]"
write (u, "(A)") "\textbf{All data:} \\"
call observable_write_driver (h%obs, unit, write_heading=.false.)
write (u, "(A)") "\end{flushleft}"
end subroutine histogram_write_gml_driver
@ %def histogram_write_gml_driver
@ Return the header for generic data output as an ifile.
<<Analysis: procedures>>=
subroutine histogram_get_header (h, header, comment)
type(histogram_t), intent(in) :: h
type(ifile_t), intent(inout) :: header
type(string_t), intent(in), optional :: comment
type(string_t) :: c
if (present (comment)) then
c = comment
else
c = ""
end if
call ifile_append (header, c // "WHIZARD histogram data")
call graph_options_get_header (h%graph_options, header, comment)
call ifile_append (header, &
c // "range: " // real2string (h%lower_bound) &
// " - " // real2string (h%upper_bound))
call ifile_append (header, &
c // "counts total: " &
// int2char (histogram_get_n_entries_within_bounds (h)))
call ifile_append (header, &
c // "total average: " &
// real2string (histogram_get_average_within_bounds (h)) // " +- " &
// real2string (histogram_get_error_within_bounds (h)))
end subroutine histogram_get_header
@ %def histogram_get_header
@
\subsection{Plots}
\subsubsection{Points}
<<Analysis: types>>=
type :: point_t
private
real(default) :: x = 0
real(default) :: y = 0
real(default) :: yerr = 0
real(default) :: xerr = 0
type(point_t), pointer :: next => null ()
end type point_t
@ %def point_t
<<Analysis: interfaces>>=
interface point_init
module procedure point_init_contents
module procedure point_init_point
end interface
<<Analysis: procedures>>=
subroutine point_init_contents (point, x, y, yerr, xerr)
type(point_t), intent(out) :: point
real(default), intent(in) :: x, y
real(default), intent(in), optional :: yerr, xerr
point%x = x
point%y = y
if (present (yerr)) point%yerr = yerr
if (present (xerr)) point%xerr = xerr
end subroutine point_init_contents
subroutine point_init_point (point, point_in)
type(point_t), intent(out) :: point
type(point_t), intent(in) :: point_in
point%x = point_in%x
point%y = point_in%y
point%yerr = point_in%yerr
point%xerr = point_in%xerr
end subroutine point_init_point
@ %def point_init
<<Analysis: procedures>>=
function point_get_x (point) result (x)
real(default) :: x
type(point_t), intent(in) :: point
x = point%x
end function point_get_x
function point_get_y (point) result (y)
real(default) :: y
type(point_t), intent(in) :: point
y = point%y
end function point_get_y
function point_get_xerr (point) result (xerr)
real(default) :: xerr
type(point_t), intent(in) :: point
xerr = point%xerr
end function point_get_xerr
function point_get_yerr (point) result (yerr)
real(default) :: yerr
type(point_t), intent(in) :: point
yerr = point%yerr
end function point_get_yerr
@ %def point_get_x
@ %def point_get_y
@ %def point_get_xerr
@ %def point_get_yerr
<<Analysis: procedures>>=
subroutine point_write_header (unit)
integer, intent(in) :: unit
character(120) :: buffer
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (buffer, "(A,4(1x," // HISTOGRAM_HEAD_FORMAT // "))") &
"#", "x ", "y ", "yerr ", "xerr "
write (u, "(A)") trim (buffer)
end subroutine point_write_header
subroutine point_write (point, unit)
type(point_t), intent(in) :: point
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,4(1x," // HISTOGRAM_DATA_FORMAT // "))") &
point_get_x (point), &
point_get_y (point), &
point_get_yerr (point), &
point_get_xerr (point)
end subroutine point_write
@ %def point_write
@
\subsubsection{Plots}
<<Analysis: types>>=
type :: plot_t
private
type(point_t), pointer :: first => null ()
type(point_t), pointer :: last => null ()
integer :: count = 0
type(graph_options_t) :: graph_options
type(drawing_options_t) :: drawing_options
end type plot_t
@ %def plot_t
@
\subsubsection{Initializer/finalizer}
Initialize a plot. We provide the lower and upper bound in the $x$
direction.
<<Analysis: interfaces>>=
interface plot_init
module procedure plot_init_empty
module procedure plot_init_plot
end interface
<<Analysis: procedures>>=
subroutine plot_init_empty (p, id, graph_options, drawing_options)
type(plot_t), intent(out) :: p
type(string_t), intent(in) :: id
type(graph_options_t), intent(in), optional :: graph_options
type(drawing_options_t), intent(in), optional :: drawing_options
if (present (graph_options)) then
p%graph_options = graph_options
else
call graph_options_init (p%graph_options)
end if
call graph_options_set (p%graph_options, id = id)
if (present (drawing_options)) then
p%drawing_options = drawing_options
else
call drawing_options_init_plot (p%drawing_options)
end if
end subroutine plot_init_empty
@ %def plot_init
@ Initialize a plot by copying another one, optionally merging in a new
set of drawing options.
Since [[p]] has pointer (sub)components, we have to explicitly deep-copy the
original.
<<Analysis: procedures>>=
subroutine plot_init_plot (p, p_in, drawing_options)
type(plot_t), intent(out) :: p
type(plot_t), intent(in) :: p_in
type(drawing_options_t), intent(in), optional :: drawing_options
type(point_t), pointer :: current, new
current => p_in%first
do while (associated (current))
allocate (new)
call point_init (new, current)
if (associated (p%last)) then
p%last%next => new
else
p%first => new
end if
p%last => new
current => current%next
end do
p%count = p_in%count
p%graph_options = p_in%graph_options
if (present (drawing_options)) then
p%drawing_options = drawing_options
else
p%drawing_options = p_in%drawing_options
end if
end subroutine plot_init_plot
@ %def plot_init_plot
@ Finalize the plot by deallocating the list of points.
<<Analysis: procedures>>=
subroutine plot_final (plot)
type(plot_t), intent(inout) :: plot
type(point_t), pointer :: current
do while (associated (plot%first))
current => plot%first
plot%first => current%next
deallocate (current)
end do
plot%last => null ()
end subroutine plot_final
@ %def plot_final
@
\subsubsection{Fill plots}
Clear the plot contents, but do not modify the structure.
<<Analysis: procedures>>=
subroutine plot_clear (plot)
type(plot_t), intent(inout) :: plot
plot%count = 0
call plot_final (plot)
end subroutine plot_clear
@ %def plot_clear
@ Record a value. Successful if the value is within bounds, otherwise
it is recorded as under-/overflow.
<<Analysis: procedures>>=
subroutine plot_record_value (plot, x, y, yerr, xerr, success)
type(plot_t), intent(inout) :: plot
real(default), intent(in) :: x, y
real(default), intent(in), optional :: yerr, xerr
logical, intent(out), optional :: success
type(point_t), pointer :: point
plot%count = plot%count + 1
allocate (point)
call point_init (point, x, y, yerr, xerr)
if (associated (plot%first)) then
plot%last%next => point
else
plot%first => point
end if
plot%last => point
if (present (success)) success = .true.
end subroutine plot_record_value
@ %def plot_record_value
@
\subsubsection{Access contents}
The number of points.
<<Analysis: procedures>>=
function plot_get_n_entries (plot) result (n)
integer :: n
type(plot_t), intent(in) :: plot
n = plot%count
end function plot_get_n_entries
@ %def plot_get_n_entries
@ Return a pointer to the graph options.
<<Analysis: procedures>>=
function plot_get_graph_options_ptr (p) result (ptr)
type(graph_options_t), pointer :: ptr
type(plot_t), intent(in), target :: p
ptr => p%graph_options
end function plot_get_graph_options_ptr
@ %def plot_get_graph_options_ptr
@ Return a pointer to the drawing options.
<<Analysis: procedures>>=
function plot_get_drawing_options_ptr (p) result (ptr)
type(drawing_options_t), pointer :: ptr
type(plot_t), intent(in), target :: p
ptr => p%drawing_options
end function plot_get_drawing_options_ptr
@ %def plot_get_drawing_options_ptr
@
\subsubsection{Output}
This output format is used by the GAMELAN driver below.
<<Analysis: procedures>>=
subroutine plot_write (plot, unit)
type(plot_t), intent(in) :: plot
integer, intent(in), optional :: unit
type(point_t), pointer :: point
integer :: u
u = given_output_unit (unit); if (u < 0) return
call point_write_header (u)
point => plot%first
do while (associated (point))
call point_write (point, unit)
point => point%next
end do
write (u, *)
write (u, "(A,1x,A)") "#", "Summary:"
write (u, "(A,1x,I0)") &
"n_entries =", plot_get_n_entries (plot)
write (u, *)
end subroutine plot_write
@ %def plot_write
@ Write the GAMELAN reader for plot contents.
<<Analysis: procedures>>=
subroutine plot_write_gml_reader (p, filename, unit)
type(plot_t), intent(in) :: p
type(string_t), intent(in) :: filename
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(2x,A)") 'fromfile "' // char (filename) // '":'
write (u, "(4x,A)") 'key "# Plot:";'
write (u, "(4x,A)") 'for i withinblock:'
write (u, "(6x,A)") 'get x, y, y.err, x.err;'
write (u, "(6x,A)") 'plot (' // char (p%drawing_options%dataset) &
// ') (x,y);'
if (p%drawing_options%err) then
write (u, "(6x,A)") 'plot (' // char (p%drawing_options%dataset) &
// '.err) (x,y) vbar y.err hbar x.err;'
end if
write (u, "(4x,A)") 'endfor'
write (u, "(2x,A)") 'endfrom'
end subroutine plot_write_gml_reader
@ %def plot_write_gml_header
@ \LaTeX\ and GAMELAN output. Analogous to histogram output.
<<Analysis: procedures>>=
subroutine plot_write_gml_driver (p, filename, unit)
type(plot_t), intent(in) :: p
type(string_t), intent(in) :: filename
integer, intent(in), optional :: unit
type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
integer :: u
u = given_output_unit (unit); if (u < 0) return
call graph_options_write_tex_header (p%graph_options, unit)
write (u, "(2x,A)") &
char (graph_options_get_gml_setup (p%graph_options))
write (u, "(2x,A)") &
char (graph_options_get_gml_graphrange (p%graph_options))
call plot_write_gml_reader (p, filename, unit)
calc_cmd = drawing_options_get_calc_command (p%drawing_options)
if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd)
bg_cmd = drawing_options_get_gml_bg_command (p%drawing_options)
if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd)
draw_cmd = drawing_options_get_draw_command (p%drawing_options)
if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd)
err_cmd = drawing_options_get_err_command (p%drawing_options)
if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd)
symb_cmd = drawing_options_get_symb_command (p%drawing_options)
if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd)
fg_cmd = drawing_options_get_gml_fg_command (p%drawing_options)
if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd)
write (u, "(2x,A)") char (graph_options_get_gml_x_label (p%graph_options))
write (u, "(2x,A)") char (graph_options_get_gml_y_label (p%graph_options))
call graph_options_write_tex_footer (p%graph_options, unit)
end subroutine plot_write_gml_driver
@ %def plot_write_driver
@ Append header for generic data output in ifile format.
<<Analysis: procedures>>=
subroutine plot_get_header (plot, header, comment)
type(plot_t), intent(in) :: plot
type(ifile_t), intent(inout) :: header
type(string_t), intent(in), optional :: comment
type(string_t) :: c
if (present (comment)) then
c = comment
else
c = ""
end if
call ifile_append (header, c // "WHIZARD plot data")
call graph_options_get_header (plot%graph_options, header, comment)
call ifile_append (header, &
c // "number of points: " &
// int2char (plot_get_n_entries (plot)))
end subroutine plot_get_header
@ %def plot_get_header
@
\subsection{Graphs}
A graph is a container for several graph elements. Each graph element is
either a plot or a histogram. There is an appropriate base type below
(the [[analysis_object_t]]), but to avoid recursion, we define a separate base
type here. Note that there is no actual recursion: a graph is an analysis
object, but a graph cannot contain graphs.
(If we could use type extension, the implementation would be much more
transparent.)
\subsubsection{Graph elements}
Graph elements cannot be filled by the [[record]] command directly. The
contents are always copied from elementary histograms or plots.
<<Analysis: types>>=
type :: graph_element_t
private
integer :: type = AN_UNDEFINED
type(histogram_t), pointer :: h => null ()
type(plot_t), pointer :: p => null ()
end type graph_element_t
@ %def graph_element_t
<<Analysis: procedures>>=
subroutine graph_element_final (el)
type(graph_element_t), intent(inout) :: el
select case (el%type)
case (AN_HISTOGRAM)
deallocate (el%h)
case (AN_PLOT)
call plot_final (el%p)
deallocate (el%p)
end select
el%type = AN_UNDEFINED
end subroutine graph_element_final
@ %def graph_element_final
@ Return the number of entries in the graph element:
<<Analysis: procedures>>=
function graph_element_get_n_entries (el) result (n)
integer :: n
type(graph_element_t), intent(in) :: el
select case (el%type)
case (AN_HISTOGRAM); n = histogram_get_n_entries (el%h)
case (AN_PLOT); n = plot_get_n_entries (el%p)
case default; n = 0
end select
end function graph_element_get_n_entries
@ %def graph_element_get_n_entries
@ Return a pointer to the graph / drawing options.
<<Analysis: procedures>>=
function graph_element_get_graph_options_ptr (el) result (ptr)
type(graph_options_t), pointer :: ptr
type(graph_element_t), intent(in) :: el
select case (el%type)
case (AN_HISTOGRAM); ptr => histogram_get_graph_options_ptr (el%h)
case (AN_PLOT); ptr => plot_get_graph_options_ptr (el%p)
case default; ptr => null ()
end select
end function graph_element_get_graph_options_ptr
function graph_element_get_drawing_options_ptr (el) result (ptr)
type(drawing_options_t), pointer :: ptr
type(graph_element_t), intent(in) :: el
select case (el%type)
case (AN_HISTOGRAM); ptr => histogram_get_drawing_options_ptr (el%h)
case (AN_PLOT); ptr => plot_get_drawing_options_ptr (el%p)
case default; ptr => null ()
end select
end function graph_element_get_drawing_options_ptr
@ %def graph_element_get_graph_options_ptr
@ %def graph_element_get_drawing_options_ptr
@ Output, simple wrapper for the plot/histogram writer.
<<Analysis: procedures>>=
subroutine graph_element_write (el, unit)
type(graph_element_t), intent(in) :: el
integer, intent(in), optional :: unit
type(graph_options_t), pointer :: gro
type(string_t) :: id
integer :: u
u = given_output_unit (unit); if (u < 0) return
gro => graph_element_get_graph_options_ptr (el)
id = graph_options_get_id (gro)
write (u, "(A,A)") '#', repeat ("-", 78)
select case (el%type)
case (AN_HISTOGRAM)
write (u, "(A)", advance="no") "# Histogram: "
write (u, "(1x,A)") char (id)
call histogram_write (el%h, unit)
case (AN_PLOT)
write (u, "(A)", advance="no") "# Plot: "
write (u, "(1x,A)") char (id)
call plot_write (el%p, unit)
end select
end subroutine graph_element_write
@ %def graph_element_write
<<Analysis: procedures>>=
subroutine graph_element_write_gml_reader (el, filename, unit)
type(graph_element_t), intent(in) :: el
type(string_t), intent(in) :: filename
integer, intent(in), optional :: unit
select case (el%type)
case (AN_HISTOGRAM); call histogram_write_gml_reader (el%h, filename, unit)
case (AN_PLOT); call plot_write_gml_reader (el%p, filename, unit)
end select
end subroutine graph_element_write_gml_reader
@ %def graph_element_write_gml_reader
@
\subsubsection{The graph type}
The actual graph type contains its own [[graph_options]], which override the
individual settings. The [[drawing_options]] are set in the graph elements.
This distinction motivates the separation of the two types.
<<Analysis: types>>=
type :: graph_t
private
type(graph_element_t), dimension(:), allocatable :: el
type(graph_options_t) :: graph_options
end type graph_t
@ %def graph_t
@
\subsubsection{Initializer/finalizer}
The graph is created with a definite number of elements. The elements are
filled one by one, optionally with modified drawing options.
<<Analysis: procedures>>=
subroutine graph_init (g, id, n_elements, graph_options)
type(graph_t), intent(out) :: g
type(string_t), intent(in) :: id
integer, intent(in) :: n_elements
type(graph_options_t), intent(in), optional :: graph_options
allocate (g%el (n_elements))
if (present (graph_options)) then
g%graph_options = graph_options
else
call graph_options_init (g%graph_options)
end if
call graph_options_set (g%graph_options, id = id)
end subroutine graph_init
@ %def graph_init
<<Analysis: procedures>>=
subroutine graph_insert_histogram (g, i, h, drawing_options)
type(graph_t), intent(inout), target :: g
integer, intent(in) :: i
type(histogram_t), intent(in) :: h
type(drawing_options_t), intent(in), optional :: drawing_options
type(graph_options_t), pointer :: gro
type(drawing_options_t), pointer :: dro
type(string_t) :: id
g%el(i)%type = AN_HISTOGRAM
allocate (g%el(i)%h)
call histogram_init_histogram (g%el(i)%h, h, drawing_options)
gro => histogram_get_graph_options_ptr (g%el(i)%h)
dro => histogram_get_drawing_options_ptr (g%el(i)%h)
id = graph_options_get_id (gro)
call drawing_options_set (dro, dataset = "dat." // id)
end subroutine graph_insert_histogram
@ %def graph_insert_histogram
<<Analysis: procedures>>=
subroutine graph_insert_plot (g, i, p, drawing_options)
type(graph_t), intent(inout) :: g
integer, intent(in) :: i
type(plot_t), intent(in) :: p
type(drawing_options_t), intent(in), optional :: drawing_options
type(graph_options_t), pointer :: gro
type(drawing_options_t), pointer :: dro
type(string_t) :: id
g%el(i)%type = AN_PLOT
allocate (g%el(i)%p)
call plot_init_plot (g%el(i)%p, p, drawing_options)
gro => plot_get_graph_options_ptr (g%el(i)%p)
dro => plot_get_drawing_options_ptr (g%el(i)%p)
id = graph_options_get_id (gro)
call drawing_options_set (dro, dataset = "dat." // id)
end subroutine graph_insert_plot
@ %def graph_insert_plot
@ Finalizer.
<<Analysis: procedures>>=
subroutine graph_final (g)
type(graph_t), intent(inout) :: g
integer :: i
do i = 1, size (g%el)
call graph_element_final (g%el(i))
end do
deallocate (g%el)
end subroutine graph_final
@ %def graph_final
@
\subsubsection{Access contents}
The number of elements.
<<Analysis: procedures>>=
function graph_get_n_elements (graph) result (n)
integer :: n
type(graph_t), intent(in) :: graph
n = size (graph%el)
end function graph_get_n_elements
@ %def graph_get_n_elements
@ Retrieve a pointer to the drawing options of an element, so they can be
modified. (The [[target]] attribute is not actually needed because the
components are pointers.)
<<Analysis: procedures>>=
function graph_get_drawing_options_ptr (g, i) result (ptr)
type(drawing_options_t), pointer :: ptr
type(graph_t), intent(in), target :: g
integer, intent(in) :: i
ptr => graph_element_get_drawing_options_ptr (g%el(i))
end function graph_get_drawing_options_ptr
@ %def graph_get_drawing_options_ptr
@
\subsubsection{Output}
The default output format just writes histogram and plot data.
<<Analysis: procedures>>=
subroutine graph_write (graph, unit)
type(graph_t), intent(in) :: graph
integer, intent(in), optional :: unit
integer :: i
do i = 1, size (graph%el)
call graph_element_write (graph%el(i), unit)
end do
end subroutine graph_write
@ %def graph_write
@ The GAMELAN driver is not a simple wrapper, but it writes the plot/histogram
contents embedded the complete graph. First, data are read in, global
background commands next, then individual elements, then global foreground
commands.
<<Analysis: procedures>>=
subroutine graph_write_gml_driver (g, filename, unit)
type(graph_t), intent(in) :: g
type(string_t), intent(in) :: filename
type(string_t) :: calc_cmd, bg_cmd, draw_cmd, err_cmd, symb_cmd, fg_cmd
integer, intent(in), optional :: unit
type(drawing_options_t), pointer :: dro
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call graph_options_write_tex_header (g%graph_options, unit)
write (u, "(2x,A)") &
char (graph_options_get_gml_setup (g%graph_options))
write (u, "(2x,A)") &
char (graph_options_get_gml_graphrange (g%graph_options))
do i = 1, size (g%el)
call graph_element_write_gml_reader (g%el(i), filename, unit)
calc_cmd = drawing_options_get_calc_command &
(graph_element_get_drawing_options_ptr (g%el(i)))
if (calc_cmd /= "") write (u, "(2x,A)") char (calc_cmd)
end do
bg_cmd = graph_options_get_gml_bg_command (g%graph_options)
if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd)
do i = 1, size (g%el)
dro => graph_element_get_drawing_options_ptr (g%el(i))
bg_cmd = drawing_options_get_gml_bg_command (dro)
if (bg_cmd /= "") write (u, "(2x,A)") char (bg_cmd)
draw_cmd = drawing_options_get_draw_command (dro)
if (draw_cmd /= "") write (u, "(2x,A)") char (draw_cmd)
err_cmd = drawing_options_get_err_command (dro)
if (err_cmd /= "") write (u, "(2x,A)") char (err_cmd)
symb_cmd = drawing_options_get_symb_command (dro)
if (symb_cmd /= "") write (u, "(2x,A)") char (symb_cmd)
fg_cmd = drawing_options_get_gml_fg_command (dro)
if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd)
end do
fg_cmd = graph_options_get_gml_fg_command (g%graph_options)
if (fg_cmd /= "") write (u, "(2x,A)") char (fg_cmd)
write (u, "(2x,A)") char (graph_options_get_gml_x_label (g%graph_options))
write (u, "(2x,A)") char (graph_options_get_gml_y_label (g%graph_options))
call graph_options_write_tex_footer (g%graph_options, unit)
end subroutine graph_write_gml_driver
@ %def graph_write_gml_driver
@ Append header for generic data output in ifile format.
<<Analysis: procedures>>=
subroutine graph_get_header (graph, header, comment)
type(graph_t), intent(in) :: graph
type(ifile_t), intent(inout) :: header
type(string_t), intent(in), optional :: comment
type(string_t) :: c
if (present (comment)) then
c = comment
else
c = ""
end if
call ifile_append (header, c // "WHIZARD graph data")
call graph_options_get_header (graph%graph_options, header, comment)
call ifile_append (header, &
c // "number of graph elements: " &
// int2char (graph_get_n_elements (graph)))
end subroutine graph_get_header
@ %def graph_get_header
@
\subsection{Analysis objects}
This data structure holds all observables, histograms and such that
are currently active. We have one global store; individual items are
identified by their ID strings.
(This should rather be coded by type extension.)
<<Analysis: parameters>>=
integer, parameter :: AN_UNDEFINED = 0
integer, parameter :: AN_OBSERVABLE = 1
integer, parameter :: AN_HISTOGRAM = 2
integer, parameter :: AN_PLOT = 3
integer, parameter :: AN_GRAPH = 4
<<Analysis: public>>=
public :: AN_UNDEFINED, AN_HISTOGRAM, AN_OBSERVABLE, AN_PLOT, AN_GRAPH
@ %def AN_UNDEFINED
@ %def AN_OBSERVABLE AN_HISTOGRAM AN_PLOT AN_GRAPH
<<Analysis: types>>=
type :: analysis_object_t
private
type(string_t) :: id
integer :: type = AN_UNDEFINED
type(observable_t), pointer :: obs => null ()
type(histogram_t), pointer :: h => null ()
type(plot_t), pointer :: p => null ()
type(graph_t), pointer :: g => null ()
type(analysis_object_t), pointer :: next => null ()
end type analysis_object_t
@ %def analysis_object_t
@
\subsubsection{Initializer/finalizer}
Allocate with the correct type but do not fill initial values.
<<Analysis: procedures>>=
subroutine analysis_object_init (obj, id, type)
type(analysis_object_t), intent(out) :: obj
type(string_t), intent(in) :: id
integer, intent(in) :: type
obj%id = id
obj%type = type
select case (obj%type)
case (AN_OBSERVABLE); allocate (obj%obs)
case (AN_HISTOGRAM); allocate (obj%h)
case (AN_PLOT); allocate (obj%p)
case (AN_GRAPH); allocate (obj%g)
end select
end subroutine analysis_object_init
@ %def analysis_object_init
<<Analysis: procedures>>=
subroutine analysis_object_final (obj)
type(analysis_object_t), intent(inout) :: obj
select case (obj%type)
case (AN_OBSERVABLE)
deallocate (obj%obs)
case (AN_HISTOGRAM)
deallocate (obj%h)
case (AN_PLOT)
call plot_final (obj%p)
deallocate (obj%p)
case (AN_GRAPH)
call graph_final (obj%g)
deallocate (obj%g)
end select
obj%type = AN_UNDEFINED
end subroutine analysis_object_final
@ %def analysis_object_final
@ Clear the analysis object, i.e., reset it to its initial state. Not
applicable to graphs, which are always combinations of other existing
objects.
<<Analysis: procedures>>=
subroutine analysis_object_clear (obj)
type(analysis_object_t), intent(inout) :: obj
select case (obj%type)
case (AN_OBSERVABLE)
call observable_clear (obj%obs)
case (AN_HISTOGRAM)
call histogram_clear (obj%h)
case (AN_PLOT)
call plot_clear (obj%p)
end select
end subroutine analysis_object_clear
@ %def analysis_object_clear
@
\subsubsection{Fill with data}
Record data. The effect depends on the type of analysis object.
<<Analysis: procedures>>=
subroutine analysis_object_record_data (obj, &
x, y, yerr, xerr, weight, excess, success)
type(analysis_object_t), intent(inout) :: obj
real(default), intent(in) :: x
real(default), intent(in), optional :: y, yerr, xerr, weight, excess
logical, intent(out), optional :: success
select case (obj%type)
case (AN_OBSERVABLE)
if (present (weight)) then
call observable_record_value_weighted (obj%obs, x, weight, success)
else
call observable_record_value_unweighted (obj%obs, x, success)
end if
case (AN_HISTOGRAM)
if (present (weight)) then
call histogram_record_value_weighted (obj%h, x, weight, success)
else
call histogram_record_value_unweighted (obj%h, x, excess, success)
end if
case (AN_PLOT)
if (present (y)) then
call plot_record_value (obj%p, x, y, yerr, xerr, success)
else
if (present (success)) success = .false.
end if
case default
if (present (success)) success = .false.
end select
end subroutine analysis_object_record_data
@ %def analysis_object_record_data
@ Explicitly set the pointer to the next object in the list.
<<Analysis: procedures>>=
subroutine analysis_object_set_next_ptr (obj, next)
type(analysis_object_t), intent(inout) :: obj
type(analysis_object_t), pointer :: next
obj%next => next
end subroutine analysis_object_set_next_ptr
@ %def analysis_object_set_next_ptr
@
\subsubsection{Access contents}
Return a pointer to the next object in the list.
<<Analysis: procedures>>=
function analysis_object_get_next_ptr (obj) result (next)
type(analysis_object_t), pointer :: next
type(analysis_object_t), intent(in) :: obj
next => obj%next
end function analysis_object_get_next_ptr
@ %def analysis_object_get_next_ptr
@ Return data as appropriate for the object type.
<<Analysis: procedures>>=
function analysis_object_get_n_elements (obj) result (n)
integer :: n
type(analysis_object_t), intent(in) :: obj
select case (obj%type)
case (AN_HISTOGRAM)
n = 1
case (AN_PLOT)
n = 1
case (AN_GRAPH)
n = graph_get_n_elements (obj%g)
case default
n = 0
end select
end function analysis_object_get_n_elements
function analysis_object_get_n_entries (obj, within_bounds) result (n)
integer :: n
type(analysis_object_t), intent(in) :: obj
logical, intent(in), optional :: within_bounds
logical :: wb
select case (obj%type)
case (AN_OBSERVABLE)
n = observable_get_n_entries (obj%obs)
case (AN_HISTOGRAM)
wb = .false.; if (present (within_bounds)) wb = within_bounds
if (wb) then
n = histogram_get_n_entries_within_bounds (obj%h)
else
n = histogram_get_n_entries (obj%h)
end if
case (AN_PLOT)
n = plot_get_n_entries (obj%p)
case default
n = 0
end select
end function analysis_object_get_n_entries
function analysis_object_get_average (obj, within_bounds) result (avg)
real(default) :: avg
type(analysis_object_t), intent(in) :: obj
logical, intent(in), optional :: within_bounds
logical :: wb
select case (obj%type)
case (AN_OBSERVABLE)
avg = observable_get_average (obj%obs)
case (AN_HISTOGRAM)
wb = .false.; if (present (within_bounds)) wb = within_bounds
if (wb) then
avg = histogram_get_average_within_bounds (obj%h)
else
avg = histogram_get_average (obj%h)
end if
case default
avg = 0
end select
end function analysis_object_get_average
function analysis_object_get_error (obj, within_bounds) result (err)
real(default) :: err
type(analysis_object_t), intent(in) :: obj
logical, intent(in), optional :: within_bounds
logical :: wb
select case (obj%type)
case (AN_OBSERVABLE)
err = observable_get_error (obj%obs)
case (AN_HISTOGRAM)
wb = .false.; if (present (within_bounds)) wb = within_bounds
if (wb) then
err = histogram_get_error_within_bounds (obj%h)
else
err = histogram_get_error (obj%h)
end if
case default
err = 0
end select
end function analysis_object_get_error
@ %def analysis_object_get_n_elements
@ %def analysis_object_get_n_entries
@ %def analysis_object_get_average
@ %def analysis_object_get_error
@ Return pointers to the actual contents:
<<Analysis: procedures>>=
function analysis_object_get_observable_ptr (obj) result (obs)
type(observable_t), pointer :: obs
type(analysis_object_t), intent(in) :: obj
select case (obj%type)
case (AN_OBSERVABLE); obs => obj%obs
case default; obs => null ()
end select
end function analysis_object_get_observable_ptr
function analysis_object_get_histogram_ptr (obj) result (h)
type(histogram_t), pointer :: h
type(analysis_object_t), intent(in) :: obj
select case (obj%type)
case (AN_HISTOGRAM); h => obj%h
case default; h => null ()
end select
end function analysis_object_get_histogram_ptr
function analysis_object_get_plot_ptr (obj) result (plot)
type(plot_t), pointer :: plot
type(analysis_object_t), intent(in) :: obj
select case (obj%type)
case (AN_PLOT); plot => obj%p
case default; plot => null ()
end select
end function analysis_object_get_plot_ptr
function analysis_object_get_graph_ptr (obj) result (g)
type(graph_t), pointer :: g
type(analysis_object_t), intent(in) :: obj
select case (obj%type)
case (AN_GRAPH); g => obj%g
case default; g => null ()
end select
end function analysis_object_get_graph_ptr
@ %def analysis_object_get_observable_ptr
@ %def analysis_object_get_histogram_ptr
@ %def analysis_object_get_plot_ptr
@ %def analysis_object_get_graph_ptr
@ Return true if the object has a graphical representation:
<<Analysis: procedures>>=
function analysis_object_has_plot (obj) result (flag)
logical :: flag
type(analysis_object_t), intent(in) :: obj
select case (obj%type)
case (AN_HISTOGRAM); flag = .true.
case (AN_PLOT); flag = .true.
case (AN_GRAPH); flag = .true.
case default; flag = .false.
end select
end function analysis_object_has_plot
@ %def analysis_object_has_plot
@
\subsubsection{Output}
<<Analysis: procedures>>=
subroutine analysis_object_write (obj, unit, verbose)
type(analysis_object_t), intent(in) :: obj
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
logical :: verb
integer :: u
u = given_output_unit (unit); if (u < 0) return
verb = .false.; if (present (verbose)) verb = verbose
write (u, "(A)") repeat ("#", 79)
select case (obj%type)
case (AN_OBSERVABLE)
write (u, "(A)", advance="no") "# Observable:"
case (AN_HISTOGRAM)
write (u, "(A)", advance="no") "# Histogram: "
case (AN_PLOT)
write (u, "(A)", advance="no") "# Plot: "
case (AN_GRAPH)
write (u, "(A)", advance="no") "# Graph: "
case default
write (u, "(A)") "# [undefined analysis object]"
return
end select
write (u, "(1x,A)") char (obj%id)
select case (obj%type)
case (AN_OBSERVABLE)
call observable_write (obj%obs, unit)
case (AN_HISTOGRAM)
if (verb) then
call graph_options_write (obj%h%graph_options, unit)
write (u, *)
call drawing_options_write (obj%h%drawing_options, unit)
write (u, *)
end if
call histogram_write (obj%h, unit)
case (AN_PLOT)
if (verb) then
call graph_options_write (obj%p%graph_options, unit)
write (u, *)
call drawing_options_write (obj%p%drawing_options, unit)
write (u, *)
end if
call plot_write (obj%p, unit)
case (AN_GRAPH)
call graph_write (obj%g, unit)
end select
end subroutine analysis_object_write
@ %def analysis_object_write
@ Write the object part of the \LaTeX\ driver file.
<<Analysis: procedures>>=
subroutine analysis_object_write_driver (obj, filename, unit)
type(analysis_object_t), intent(in) :: obj
type(string_t), intent(in) :: filename
integer, intent(in), optional :: unit
select case (obj%type)
case (AN_OBSERVABLE)
call observable_write_driver (obj%obs, unit)
case (AN_HISTOGRAM)
call histogram_write_gml_driver (obj%h, filename, unit)
case (AN_PLOT)
call plot_write_gml_driver (obj%p, filename, unit)
case (AN_GRAPH)
call graph_write_gml_driver (obj%g, filename, unit)
end select
end subroutine analysis_object_write_driver
@ %def analysis_object_write_driver
@ Return a data header for external formats, in ifile form.
<<Analysis: procedures>>=
subroutine analysis_object_get_header (obj, header, comment)
type(analysis_object_t), intent(in) :: obj
type(ifile_t), intent(inout) :: header
type(string_t), intent(in), optional :: comment
select case (obj%type)
case (AN_HISTOGRAM)
call histogram_get_header (obj%h, header, comment)
case (AN_PLOT)
call plot_get_header (obj%p, header, comment)
end select
end subroutine analysis_object_get_header
@ %def analysis_object_get_header
@
\subsection{Analysis object iterator}
Analysis objects are containers which have iterable data structures:
histograms/bins and plots/points. If they are to be treated on a common
basis, it is useful to have an iterator which hides the implementation
details.
The iterator is used only for elementary analysis objects that contain plot
data: histograms or plots. It is invalid for meta-objects (graphs) and
non-graphical objects (observables).
<<Analysis: public>>=
public :: analysis_iterator_t
<<Analysis: types>>=
type :: analysis_iterator_t
private
integer :: type = AN_UNDEFINED
type(analysis_object_t), pointer :: object => null ()
integer :: index = 1
type(point_t), pointer :: point => null ()
end type
@ %def analysis_iterator_t
@ The initializer places the iterator at the beginning of the analysis object.
<<Analysis: procedures>>=
subroutine analysis_iterator_init (iterator, object)
type(analysis_iterator_t), intent(out) :: iterator
type(analysis_object_t), intent(in), target :: object
iterator%object => object
if (associated (iterator%object)) then
iterator%type = iterator%object%type
select case (iterator%type)
case (AN_PLOT)
iterator%point => iterator%object%p%first
end select
end if
end subroutine analysis_iterator_init
@ %def analysis_iterator_init
@ The iterator is valid as long as it points to an existing entry. An
iterator for a data object without array data (observable) is always invalid.
<<Analysis: public>>=
public :: analysis_iterator_is_valid
<<Analysis: procedures>>=
function analysis_iterator_is_valid (iterator) result (valid)
logical :: valid
type(analysis_iterator_t), intent(in) :: iterator
if (associated (iterator%object)) then
select case (iterator%type)
case (AN_HISTOGRAM)
valid = iterator%index <= histogram_get_n_bins (iterator%object%h)
case (AN_PLOT)
valid = associated (iterator%point)
case default
valid = .false.
end select
else
valid = .false.
end if
end function analysis_iterator_is_valid
@ %def analysis_iterator_is_valid
@ Advance the iterator.
<<Analysis: public>>=
public :: analysis_iterator_advance
<<Analysis: procedures>>=
subroutine analysis_iterator_advance (iterator)
type(analysis_iterator_t), intent(inout) :: iterator
if (associated (iterator%object)) then
select case (iterator%type)
case (AN_PLOT)
iterator%point => iterator%point%next
end select
iterator%index = iterator%index + 1
end if
end subroutine analysis_iterator_advance
@ %def analysis_iterator_advance
@ Retrieve the object type:
<<Analysis: public>>=
public :: analysis_iterator_get_type
<<Analysis: procedures>>=
function analysis_iterator_get_type (iterator) result (type)
integer :: type
type(analysis_iterator_t), intent(in) :: iterator
type = iterator%type
end function analysis_iterator_get_type
@ %def analysis_iterator_get_type
@ Use the iterator to retrieve data. We implement a common routine which
takes the data descriptors as optional arguments. Data which do not occur in
the selected type trigger to an error condition.
The iterator must point to a valid entry.
<<Analysis: public>>=
public :: analysis_iterator_get_data
<<Analysis: procedures>>=
subroutine analysis_iterator_get_data (iterator, &
x, y, yerr, xerr, width, excess, index, n_total)
type(analysis_iterator_t), intent(in) :: iterator
real(default), intent(out), optional :: x, y, yerr, xerr, width, excess
integer, intent(out), optional :: index, n_total
select case (iterator%type)
case (AN_HISTOGRAM)
if (present (x)) &
x = bin_get_midpoint (iterator%object%h%bin(iterator%index))
if (present (y)) &
y = bin_get_sum (iterator%object%h%bin(iterator%index))
if (present (yerr)) &
yerr = bin_get_error (iterator%object%h%bin(iterator%index))
if (present (xerr)) &
call invalid ("histogram", "xerr")
if (present (width)) &
width = bin_get_width (iterator%object%h%bin(iterator%index))
if (present (excess)) &
excess = bin_get_excess (iterator%object%h%bin(iterator%index))
if (present (index)) &
index = iterator%index
if (present (n_total)) &
n_total = histogram_get_n_bins (iterator%object%h)
case (AN_PLOT)
if (present (x)) &
x = point_get_x (iterator%point)
if (present (y)) &
y = point_get_y (iterator%point)
if (present (yerr)) &
yerr = point_get_yerr (iterator%point)
if (present (xerr)) &
xerr = point_get_xerr (iterator%point)
if (present (width)) &
call invalid ("plot", "width")
if (present (excess)) &
call invalid ("plot", "excess")
if (present (index)) &
index = iterator%index
if (present (n_total)) &
n_total = plot_get_n_entries (iterator%object%p)
case default
call msg_bug ("analysis_iterator_get_data: called " &
// "for unsupported analysis object type")
end select
contains
subroutine invalid (typestr, objstr)
character(*), intent(in) :: typestr, objstr
call msg_bug ("analysis_iterator_get_data: attempt to get '" &
// objstr // "' for type '" // typestr // "'")
end subroutine invalid
end subroutine analysis_iterator_get_data
@ %def analysis_iterator_get_data
@
\subsection{Analysis store}
This data structure holds all observables, histograms and such that
are currently active. We have one global store; individual items are
identified by their ID strings and types.
<<Analysis: variables>>=
type(analysis_store_t), save :: analysis_store
@ %def analysis_store
<<Analysis: types>>=
type :: analysis_store_t
private
type(analysis_object_t), pointer :: first => null ()
type(analysis_object_t), pointer :: last => null ()
end type analysis_store_t
@ %def analysis_store_t
@ Delete the analysis store
<<Analysis: public>>=
public :: analysis_final
<<Analysis: procedures>>=
subroutine analysis_final ()
type(analysis_object_t), pointer :: current
do while (associated (analysis_store%first))
current => analysis_store%first
analysis_store%first => current%next
call analysis_object_final (current)
end do
analysis_store%last => null ()
end subroutine analysis_final
@ %def analysis_final
@ Append a new analysis object
<<Analysis: procedures>>=
subroutine analysis_store_append_object (id, type)
type(string_t), intent(in) :: id
integer, intent(in) :: type
type(analysis_object_t), pointer :: obj
allocate (obj)
call analysis_object_init (obj, id, type)
if (associated (analysis_store%last)) then
analysis_store%last%next => obj
else
analysis_store%first => obj
end if
analysis_store%last => obj
end subroutine analysis_store_append_object
@ %def analysis_store_append_object
@ Return a pointer to the analysis object with given ID.
<<Analysis: procedures>>=
function analysis_store_get_object_ptr (id) result (obj)
type(string_t), intent(in) :: id
type(analysis_object_t), pointer :: obj
obj => analysis_store%first
do while (associated (obj))
if (obj%id == id) return
obj => obj%next
end do
end function analysis_store_get_object_ptr
@ %def analysis_store_get_object_ptr
@ Initialize an analysis object: either reset it if present, or append
a new entry.
<<Analysis: procedures>>=
subroutine analysis_store_init_object (id, type, obj)
type(string_t), intent(in) :: id
integer, intent(in) :: type
type(analysis_object_t), pointer :: obj, next
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) then
next => analysis_object_get_next_ptr (obj)
call analysis_object_final (obj)
call analysis_object_init (obj, id, type)
call analysis_object_set_next_ptr (obj, next)
else
call analysis_store_append_object (id, type)
obj => analysis_store%last
end if
end subroutine analysis_store_init_object
@ %def analysis_store_init_object
@ Get the type of a analysis object
<<Analysis: public>>=
public :: analysis_store_get_object_type
<<Analysis: procedures>>=
function analysis_store_get_object_type (id) result (type)
type(string_t), intent(in) :: id
integer :: type
type(analysis_object_t), pointer :: object
object => analysis_store_get_object_ptr (id)
if (associated (object)) then
type = object%type
else
type = AN_UNDEFINED
end if
end function analysis_store_get_object_type
@ %def analysis_store_get_object_type
@ Return the number of objects in the store.
<<Analysis: procedures>>=
function analysis_store_get_n_objects () result (n)
integer :: n
type(analysis_object_t), pointer :: current
n = 0
current => analysis_store%first
do while (associated (current))
n = n + 1
current => current%next
end do
end function analysis_store_get_n_objects
@ %def analysis_store_get_n_objects
@ Allocate an array and fill it with all existing IDs.
<<Analysis: public>>=
public :: analysis_store_get_ids
<<Analysis: procedures>>=
subroutine analysis_store_get_ids (id)
type(string_t), dimension(:), allocatable, intent(out) :: id
type(analysis_object_t), pointer :: current
integer :: i
allocate (id (analysis_store_get_n_objects()))
i = 0
current => analysis_store%first
do while (associated (current))
i = i + 1
id(i) = current%id
current => current%next
end do
end subroutine analysis_store_get_ids
@ %def analysis_store_get_ids
@
\subsection{\LaTeX\ driver file}
Write a driver file for all objects in the store.
<<Analysis: procedures>>=
subroutine analysis_store_write_driver_all (filename_data, unit)
type(string_t), intent(in) :: filename_data
integer, intent(in), optional :: unit
type(analysis_object_t), pointer :: obj
call analysis_store_write_driver_header (unit)
obj => analysis_store%first
do while (associated (obj))
call analysis_object_write_driver (obj, filename_data, unit)
obj => obj%next
end do
call analysis_store_write_driver_footer (unit)
end subroutine analysis_store_write_driver_all
@ %def analysis_store_write_driver_all
@
Write a driver file for an array of objects.
<<Analysis: procedures>>=
subroutine analysis_store_write_driver_obj (filename_data, id, unit)
type(string_t), intent(in) :: filename_data
type(string_t), dimension(:), intent(in) :: id
integer, intent(in), optional :: unit
type(analysis_object_t), pointer :: obj
integer :: i
call analysis_store_write_driver_header (unit)
do i = 1, size (id)
obj => analysis_store_get_object_ptr (id(i))
if (associated (obj)) &
call analysis_object_write_driver (obj, filename_data, unit)
end do
call analysis_store_write_driver_footer (unit)
end subroutine analysis_store_write_driver_obj
@ %def analysis_store_write_driver_obj
@ The beginning of the driver file.
<<Analysis: procedures>>=
subroutine analysis_store_write_driver_header (unit)
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, '(A)') "\documentclass[12pt]{article}"
write (u, *)
write (u, '(A)') "\usepackage{gamelan}"
write (u, '(A)') "\usepackage{amsmath}"
write (u, '(A)') "\usepackage{ifpdf}"
write (u, '(A)') "\ifpdf"
write (u, '(A)') " \DeclareGraphicsRule{*}{mps}{*}{}"
write (u, '(A)') "\else"
write (u, '(A)') " \DeclareGraphicsRule{*}{eps}{*}{}"
write (u, '(A)') "\fi"
write (u, *)
write (u, '(A)') "\begin{document}"
write (u, '(A)') "\begin{gmlfile}"
write (u, *)
write (u, '(A)') "\begin{gmlcode}"
write (u, '(A)') " color col.default, col.excess;"
write (u, '(A)') " col.default = 0.9white;"
write (u, '(A)') " col.excess = red;"
write (u, '(A)') " boolean show_excess;"
!!! Future excess options for plots
! if (mcs(1)%plot_excess .and. mcs(1)%unweighted) then
! write (u, '(A)') " show_excess = true;"
! else
write (u, '(A)') " show_excess = false;"
! end if
write (u, '(A)') "\end{gmlcode}"
write (u, *)
end subroutine analysis_store_write_driver_header
@ %def analysis_store_write_driver_header
@ The end of the driver file.
<<Analysis: procedures>>=
subroutine analysis_store_write_driver_footer (unit)
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write(u, *)
write(u, '(A)') "\end{gmlfile}"
write(u, '(A)') "\end{document}"
end subroutine analysis_store_write_driver_footer
@ %def analysis_store_write_driver_footer
@
\subsection{API}
\subsubsection{Creating new objects}
The specific versions below:
<<Analysis: public>>=
public :: analysis_init_observable
<<Analysis: procedures>>=
subroutine analysis_init_observable (id, obs_label, obs_unit, graph_options)
type(string_t), intent(in) :: id
type(string_t), intent(in), optional :: obs_label, obs_unit
type(graph_options_t), intent(in), optional :: graph_options
type(analysis_object_t), pointer :: obj
type(observable_t), pointer :: obs
call analysis_store_init_object (id, AN_OBSERVABLE, obj)
obs => analysis_object_get_observable_ptr (obj)
call observable_init (obs, obs_label, obs_unit, graph_options)
end subroutine analysis_init_observable
@ %def analysis_init_observable
<<Analysis: public>>=
public :: analysis_init_histogram
<<Analysis: interfaces>>=
interface analysis_init_histogram
module procedure analysis_init_histogram_n_bins
module procedure analysis_init_histogram_bin_width
end interface
<<Analysis: procedures>>=
subroutine analysis_init_histogram_n_bins &
(id, lower_bound, upper_bound, n_bins, normalize_bins, &
obs_label, obs_unit, graph_options, drawing_options)
type(string_t), intent(in) :: id
real(default), intent(in) :: lower_bound, upper_bound
integer, intent(in) :: n_bins
logical, intent(in) :: normalize_bins
type(string_t), intent(in), optional :: obs_label, obs_unit
type(graph_options_t), intent(in), optional :: graph_options
type(drawing_options_t), intent(in), optional :: drawing_options
type(analysis_object_t), pointer :: obj
type(histogram_t), pointer :: h
call analysis_store_init_object (id, AN_HISTOGRAM, obj)
h => analysis_object_get_histogram_ptr (obj)
call histogram_init (h, id, &
lower_bound, upper_bound, n_bins, normalize_bins, &
obs_label, obs_unit, graph_options, drawing_options)
end subroutine analysis_init_histogram_n_bins
subroutine analysis_init_histogram_bin_width &
(id, lower_bound, upper_bound, bin_width, normalize_bins, &
obs_label, obs_unit, graph_options, drawing_options)
type(string_t), intent(in) :: id
real(default), intent(in) :: lower_bound, upper_bound, bin_width
logical, intent(in) :: normalize_bins
type(string_t), intent(in), optional :: obs_label, obs_unit
type(graph_options_t), intent(in), optional :: graph_options
type(drawing_options_t), intent(in), optional :: drawing_options
type(analysis_object_t), pointer :: obj
type(histogram_t), pointer :: h
call analysis_store_init_object (id, AN_HISTOGRAM, obj)
h => analysis_object_get_histogram_ptr (obj)
call histogram_init (h, id, &
lower_bound, upper_bound, bin_width, normalize_bins, &
obs_label, obs_unit, graph_options, drawing_options)
end subroutine analysis_init_histogram_bin_width
@ %def analysis_init_histogram_n_bins
@ %def analysis_init_histogram_bin_width
<<Analysis: public>>=
public :: analysis_init_plot
<<Analysis: procedures>>=
subroutine analysis_init_plot (id, graph_options, drawing_options)
type(string_t), intent(in) :: id
type(graph_options_t), intent(in), optional :: graph_options
type(drawing_options_t), intent(in), optional :: drawing_options
type(analysis_object_t), pointer :: obj
type(plot_t), pointer :: plot
call analysis_store_init_object (id, AN_PLOT, obj)
plot => analysis_object_get_plot_ptr (obj)
call plot_init (plot, id, graph_options, drawing_options)
end subroutine analysis_init_plot
@ %def analysis_init_plot
<<Analysis: public>>=
public :: analysis_init_graph
<<Analysis: procedures>>=
subroutine analysis_init_graph (id, n_elements, graph_options)
type(string_t), intent(in) :: id
integer, intent(in) :: n_elements
type(graph_options_t), intent(in), optional :: graph_options
type(analysis_object_t), pointer :: obj
type(graph_t), pointer :: graph
call analysis_store_init_object (id, AN_GRAPH, obj)
graph => analysis_object_get_graph_ptr (obj)
call graph_init (graph, id, n_elements, graph_options)
end subroutine analysis_init_graph
@ %def analysis_init_graph
@
\subsubsection{Recording data}
This procedure resets an object or the whole store to its initial
state.
<<Analysis: public>>=
public :: analysis_clear
<<Analysis: interfaces>>=
interface analysis_clear
module procedure analysis_store_clear_obj
module procedure analysis_store_clear_all
end interface
<<Analysis: procedures>>=
subroutine analysis_store_clear_obj (id)
type(string_t), intent(in) :: id
type(analysis_object_t), pointer :: obj
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) then
call analysis_object_clear (obj)
end if
end subroutine analysis_store_clear_obj
subroutine analysis_store_clear_all ()
type(analysis_object_t), pointer :: obj
obj => analysis_store%first
do while (associated (obj))
call analysis_object_clear (obj)
obj => obj%next
end do
end subroutine analysis_store_clear_all
@ %def analysis_clear
@
There is one generic recording function whose behavior depends on the
type of analysis object.
<<Analysis: public>>=
public :: analysis_record_data
<<Analysis: procedures>>=
subroutine analysis_record_data (id, x, y, yerr, xerr, &
weight, excess, success, exist)
type(string_t), intent(in) :: id
real(default), intent(in) :: x
real(default), intent(in), optional :: y, yerr, xerr, weight, excess
logical, intent(out), optional :: success, exist
type(analysis_object_t), pointer :: obj
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) then
call analysis_object_record_data (obj, x, y, yerr, xerr, &
weight, excess, success)
if (present (exist)) exist = .true.
else
if (present (success)) success = .false.
if (present (exist)) exist = .false.
end if
end subroutine analysis_record_data
@ %def analysis_record_data
@
\subsubsection{Build a graph}
This routine sets up the array of graph elements by copying the graph elements
given as input. The object must exist and already be initialized as a graph.
<<Analysis: public>>=
public :: analysis_fill_graph
<<Analysis: procedures>>=
subroutine analysis_fill_graph (id, i, id_in, drawing_options)
type(string_t), intent(in) :: id
integer, intent(in) :: i
type(string_t), intent(in) :: id_in
type(drawing_options_t), intent(in), optional :: drawing_options
type(analysis_object_t), pointer :: obj
type(graph_t), pointer :: g
type(histogram_t), pointer :: h
type(plot_t), pointer :: p
obj => analysis_store_get_object_ptr (id)
g => analysis_object_get_graph_ptr (obj)
obj => analysis_store_get_object_ptr (id_in)
if (associated (obj)) then
select case (obj%type)
case (AN_HISTOGRAM)
h => analysis_object_get_histogram_ptr (obj)
call graph_insert_histogram (g, i, h, drawing_options)
case (AN_PLOT)
p => analysis_object_get_plot_ptr (obj)
call graph_insert_plot (g, i, p, drawing_options)
case default
call msg_error ("Graph '" // char (id) // "': Element '" &
// char (id_in) // "' is neither histogram nor plot.")
end select
else
call msg_error ("Graph '" // char (id) // "': Element '" &
// char (id_in) // "' is undefined.")
end if
end subroutine analysis_fill_graph
@ %def analysis_fill_graph
@
\subsubsection{Retrieve generic results}
Check if a named object exists.
<<Analysis: public>>=
public :: analysis_exists
<<Analysis: procedures>>=
function analysis_exists (id) result (flag)
type(string_t), intent(in) :: id
logical :: flag
type(analysis_object_t), pointer :: obj
flag = .true.
obj => analysis_store%first
do while (associated (obj))
if (obj%id == id) return
obj => obj%next
end do
flag = .false.
end function analysis_exists
@ %def analysis_exists
@ The following functions should work for all kinds of analysis object:
<<Analysis: public>>=
public :: analysis_get_n_elements
public :: analysis_get_n_entries
public :: analysis_get_average
public :: analysis_get_error
<<Analysis: procedures>>=
function analysis_get_n_elements (id) result (n)
integer :: n
type(string_t), intent(in) :: id
type(analysis_object_t), pointer :: obj
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) then
n = analysis_object_get_n_elements (obj)
else
n = 0
end if
end function analysis_get_n_elements
function analysis_get_n_entries (id, within_bounds) result (n)
integer :: n
type(string_t), intent(in) :: id
logical, intent(in), optional :: within_bounds
type(analysis_object_t), pointer :: obj
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) then
n = analysis_object_get_n_entries (obj, within_bounds)
else
n = 0
end if
end function analysis_get_n_entries
function analysis_get_average (id, within_bounds) result (avg)
real(default) :: avg
type(string_t), intent(in) :: id
type(analysis_object_t), pointer :: obj
logical, intent(in), optional :: within_bounds
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) then
avg = analysis_object_get_average (obj, within_bounds)
else
avg = 0
end if
end function analysis_get_average
function analysis_get_error (id, within_bounds) result (err)
real(default) :: err
type(string_t), intent(in) :: id
type(analysis_object_t), pointer :: obj
logical, intent(in), optional :: within_bounds
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) then
err = analysis_object_get_error (obj, within_bounds)
else
err = 0
end if
end function analysis_get_error
@ %def analysis_get_n_elements
@ %def analysis_get_n_entries
@ %def analysis_get_average
@ %def analysis_get_error
@ Return true if any analysis object is graphical
<<Analysis: public>>=
public :: analysis_has_plots
<<Analysis: interfaces>>=
interface analysis_has_plots
module procedure analysis_has_plots_any
module procedure analysis_has_plots_obj
end interface
<<Analysis: procedures>>=
function analysis_has_plots_any () result (flag)
logical :: flag
type(analysis_object_t), pointer :: obj
flag = .false.
obj => analysis_store%first
do while (associated (obj))
flag = analysis_object_has_plot (obj)
if (flag) return
end do
end function analysis_has_plots_any
function analysis_has_plots_obj (id) result (flag)
logical :: flag
type(string_t), dimension(:), intent(in) :: id
type(analysis_object_t), pointer :: obj
integer :: i
flag = .false.
do i = 1, size (id)
obj => analysis_store_get_object_ptr (id(i))
if (associated (obj)) then
flag = analysis_object_has_plot (obj)
if (flag) return
end if
end do
end function analysis_has_plots_obj
@ %def analysis_has_plots
@
\subsubsection{Iterators}
Initialize an iterator for the given object. If the object does not exist or
has wrong type, the iterator will be invalid.
<<Analysis: public>>=
public :: analysis_init_iterator
<<Analysis: procedures>>=
subroutine analysis_init_iterator (id, iterator)
type(string_t), intent(in) :: id
type(analysis_iterator_t), intent(out) :: iterator
type(analysis_object_t), pointer :: obj
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) call analysis_iterator_init (iterator, obj)
end subroutine analysis_init_iterator
@ %def analysis_init_iterator
@
\subsubsection{Output}
<<Analysis: public>>=
public :: analysis_write
<<Analysis: interfaces>>=
interface analysis_write
module procedure analysis_write_object
module procedure analysis_write_all
end interface
@ %def interface
<<Analysis: procedures>>=
subroutine analysis_write_object (id, unit, verbose)
type(string_t), intent(in) :: id
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
type(analysis_object_t), pointer :: obj
obj => analysis_store_get_object_ptr (id)
if (associated (obj)) then
call analysis_object_write (obj, unit, verbose)
else
call msg_error ("Analysis object '" // char (id) // "' not found")
end if
end subroutine analysis_write_object
subroutine analysis_write_all (unit, verbose)
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
type(analysis_object_t), pointer :: obj
integer :: u
u = given_output_unit (unit); if (u < 0) return
obj => analysis_store%first
do while (associated (obj))
call analysis_object_write (obj, unit, verbose)
obj => obj%next
end do
end subroutine analysis_write_all
@ %def analysis_write_object
@ %def analysis_write_all
<<Analysis: public>>=
public :: analysis_write_driver
<<Analysis: procedures>>=
subroutine analysis_write_driver (filename_data, id, unit)
type(string_t), intent(in) :: filename_data
type(string_t), dimension(:), intent(in), optional :: id
integer, intent(in), optional :: unit
if (present (id)) then
call analysis_store_write_driver_obj (filename_data, id, unit)
else
call analysis_store_write_driver_all (filename_data, unit)
end if
end subroutine analysis_write_driver
@ %def analysis_write_driver
<<Analysis: public>>=
public :: analysis_compile_tex
<<Analysis: procedures>>=
subroutine analysis_compile_tex (file, has_gmlcode, os_data)
type(string_t), intent(in) :: file
logical, intent(in) :: has_gmlcode
type(os_data_t), intent(in) :: os_data
integer :: status
if (os_data%event_analysis_ps) then
call os_system_call ("make compile " // os_data%makeflags // " -f " // &
char (file) // "_ana.makefile", status)
if (status /= 0) then
call msg_error ("Unable to compile analysis output file")
end if
else
call msg_warning ("Skipping results display because " &
// "latex/mpost/dvips is not available")
end if
end subroutine analysis_compile_tex
@ %def analysis_compile_tex
@ Write header for generic data output to an ifile.
<<Analysis: public>>=
public :: analysis_get_header
<<Analysis: procedures>>=
subroutine analysis_get_header (id, header, comment)
type(string_t), intent(in) :: id
type(ifile_t), intent(inout) :: header
type(string_t), intent(in), optional :: comment
type(analysis_object_t), pointer :: object
object => analysis_store_get_object_ptr (id)
if (associated (object)) then
call analysis_object_get_header (object, header, comment)
end if
end subroutine analysis_get_header
@ %def analysis_get_header
@ Write a makefile in order to do the compile steps.
<<Analysis: public>>=
public :: analysis_write_makefile
<<Analysis: procedures>>=
subroutine analysis_write_makefile (filename, unit, has_gmlcode, os_data)
type(string_t), intent(in) :: filename
integer, intent(in) :: unit
logical, intent(in) :: has_gmlcode
type(os_data_t), intent(in) :: os_data
write (unit, "(3A)") "# WHIZARD: Makefile for analysis '", &
char (filename), "'"
write (unit, "(A)") "# Automatically generated file, do not edit"
write (unit, "(A)") ""
write (unit, "(A)") "# LaTeX setup"
write (unit, "(A)") "LATEX = " // char (os_data%latex)
write (unit, "(A)") "MPOST = " // char (os_data%mpost)
write (unit, "(A)") "GML = " // char (os_data%gml)
write (unit, "(A)") "DVIPS = " // char (os_data%dvips)
write (unit, "(A)") "PS2PDF = " // char (os_data%ps2pdf)
write (unit, "(A)") 'TEX_FLAGS = "$$TEXINPUTS:' // &
char(os_data%whizard_texpath) // '"'
write (unit, "(A)") 'MP_FLAGS = "$$MPINPUTS:' // &
char(os_data%whizard_texpath) // '"'
write (unit, "(A)") ""
write (unit, "(5A)") "TEX_SOURCES = ", char (filename), ".tex"
if (os_data%event_analysis_pdf) then
write (unit, "(5A)") "TEX_OBJECTS = ", char (filename), ".pdf"
else
write (unit, "(5A)") "TEX_OBJECTS = ", char (filename), ".ps"
end if
if (os_data%event_analysis_ps) then
if (os_data%event_analysis_pdf) then
write (unit, "(5A)") char (filename), ".pdf: ", &
char (filename), ".tex"
else
write (unit, "(5A)") char (filename), ".ps: ", &
char (filename), ".tex"
end if
write (unit, "(5A)") TAB, "-TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
char (filename) // ".tex"
if (has_gmlcode) then
write (unit, "(5A)") TAB, "$(GML) " // char (filename)
write (unit, "(5A)") TAB, "TEXINPUTS=$(TEX_FLAGS) $(LATEX) " // &
char (filename) // ".tex"
end if
write (unit, "(5A)") TAB, "$(DVIPS) -o " // char (filename) // ".ps " // &
char (filename) // ".dvi"
if (os_data%event_analysis_pdf) then
write (unit, "(5A)") TAB, "$(PS2PDF) " // char (filename) // ".ps"
end if
end if
write (unit, "(A)")
write (unit, "(A)") "compile: $(TEX_OBJECTS)"
write (unit, "(A)") ".PHONY: compile"
write (unit, "(A)")
write (unit, "(5A)") "CLEAN_OBJECTS = ", char (filename), ".aux"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".log"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".dvi"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".out"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9]"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9]"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".[1-9][0-9][0-9]"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9]"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9]"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".t[1-9][0-9][0-9]"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".ltp"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".mp"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".mpx"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".dvi"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".ps"
write (unit, "(5A)") "CLEAN_OBJECTS += ", char (filename), ".pdf"
write (unit, "(A)")
write (unit, "(A)") "# Generic cleanup targets"
write (unit, "(A)") "clean-objects:"
write (unit, "(A)") TAB // "rm -f $(CLEAN_OBJECTS)"
write (unit, "(A)") ""
write (unit, "(A)") "clean: clean-objects"
write (unit, "(A)") ".PHONY: clean"
end subroutine analysis_write_makefile
@ %def analysis_write_makefile
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[analysis_ut.f90]]>>=
<<File header>>
module analysis_ut
use unit_tests
use analysis_uti
<<Standard module head>>
<<Analysis: public test>>
contains
<<Analysis: test driver>>
end module analysis_ut
@ %def analysis_ut
@
<<[[analysis_uti.f90]]>>=
<<File header>>
module analysis_uti
<<Use kinds>>
<<Use strings>>
use format_defs, only: FMT_19
use analysis
<<Standard module head>>
<<Analysis: test declarations>>
contains
<<Analysis: tests>>
end module analysis_uti
@ %def analysis_ut
@ API: driver for the unit tests below.
<<Analysis: public test>>=
public :: analysis_test
<<Analysis: test driver>>=
subroutine analysis_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Analysis: execute tests>>
end subroutine analysis_test
@ %def analysis_test
<<Analysis: execute tests>>=
call test (analysis_1, "analysis_1", &
"check elementary analysis building blocks", &
u, results)
<<Analysis: test declarations>>=
public :: analysis_1
<<Analysis: tests>>=
subroutine analysis_1 (u)
integer, intent(in) :: u
type(string_t) :: id1, id2, id3, id4
integer :: i
id1 = "foo"
id2 = "bar"
id3 = "hist"
id4 = "plot"
write (u, "(A)") "* Test output: Analysis"
write (u, "(A)") "* Purpose: test the analysis routines"
write (u, "(A)")
call analysis_init_observable (id1)
call analysis_init_observable (id2)
call analysis_init_histogram &
(id3, 0.5_default, 5.5_default, 1._default, normalize_bins=.false.)
call analysis_init_plot (id4)
do i = 1, 3
write (u, "(A,1x," // FMT_19 // ")") "data = ", real(i,default)
call analysis_record_data (id1, real(i,default))
call analysis_record_data (id2, real(i,default), &
weight=real(i,default))
call analysis_record_data (id3, real(i,default))
call analysis_record_data (id4, real(i,default), real(i,default)**2)
end do
write (u, "(A,10(1x,I5))") "n_entries = ", &
analysis_get_n_entries (id1), &
analysis_get_n_entries (id2), &
analysis_get_n_entries (id3), &
analysis_get_n_entries (id3, within_bounds = .true.), &
analysis_get_n_entries (id4), &
analysis_get_n_entries (id4, within_bounds = .true.)
write (u, "(A,10(1x," // FMT_19 // "))") "average = ", &
analysis_get_average (id1), &
analysis_get_average (id2), &
analysis_get_average (id3), &
analysis_get_average (id3, within_bounds = .true.)
write (u, "(A,10(1x," // FMT_19 // "))") "error = ", &
analysis_get_error (id1), &
analysis_get_error (id2), &
analysis_get_error (id3), &
analysis_get_error (id3, within_bounds = .true.)
write (u, "(A)")
write (u, "(A)") "* Clear analysis #2"
write (u, "(A)")
call analysis_clear (id2)
do i = 4, 6
print *, "data = ", real(i,default)
call analysis_record_data (id1, real(i,default))
call analysis_record_data (id2, real(i,default), &
weight=real(i,default))
call analysis_record_data (id3, real(i,default))
call analysis_record_data (id4, real(i,default), real(i,default)**2)
end do
write (u, "(A,10(1x,I5))") "n_entries = ", &
analysis_get_n_entries (id1), &
analysis_get_n_entries (id2), &
analysis_get_n_entries (id3), &
analysis_get_n_entries (id3, within_bounds = .true.), &
analysis_get_n_entries (id4), &
analysis_get_n_entries (id4, within_bounds = .true.)
write (u, "(A,10(1x," // FMT_19 // "))") "average = ", &
analysis_get_average (id1), &
analysis_get_average (id2), &
analysis_get_average (id3), &
analysis_get_average (id3, within_bounds = .true.)
write (u, "(A,10(1x," // FMT_19 // "))") "error = ", &
analysis_get_error (id1), &
analysis_get_error (id2), &
analysis_get_error (id3), &
analysis_get_error (id3, within_bounds = .true.)
write (u, "(A)")
call analysis_write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call analysis_clear ()
call analysis_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: analysis_1"
end subroutine analysis_1
@ %def analysis_1
Index: trunk/src/model_features/model_features.nw
===================================================================
--- trunk/src/model_features/model_features.nw (revision 8512)
+++ trunk/src/model_features/model_features.nw (revision 8513)
@@ -1,17324 +1,17328 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: model features
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Model Handling and Features}
\includemodulegraph{model_features}
These modules deal with process definitions and physics models.
These modules use the [[model_data]] methods to automatically generate
process definitions.
\begin{description}
\item[auto\_components]
Generic process-definition generator. We can specify a basic
process or initial particle(s) and some rules to extend this
process, given a model definition with particle names and vertex
structures.
\item[radiation\_generator]
Applies the generic generator to the specific problem of generating
NLO corrections in a restricted setup.
\end{description}
Model construction:
\begin{description}
\item[eval\_trees]
Implementation of the generic [[expr_t]] type for the concrete
evaluation of expressions that access user variables.
This module is actually part of the Sindarin language implementation, and
should be moved elsewhere. Currently, the [[models]] module relies
on it.
\item[models]
Extends the [[model_data_t]] structure by user-variable objects for
easy access, and provides the means to read a model definition from file.
\item[slha\_interface]
Read/write a SUSY model in the standardized SLHA format. The format
defines fields and parameters, but no vertices.
\end{description}
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Automatic generation of process components}
This module provides the functionality for automatically generating radiation
corrections or decays, provided as lists of PDG codes.
<<[[auto_components.f90]]>>=
<<File header>>
module auto_components
<<Use kinds>>
<<Use strings>>
use io_units
use diagnostics
use model_data
use pdg_arrays
use physics_defs, only: PHOTON, GLUON, Z_BOSON, W_BOSON
use numeric_utils, only: extend_integer_array
<<Standard module head>>
<<Auto components: public>>
<<Auto components: parameters>>
<<Auto components: types>>
<<Auto components: interfaces>>
contains
<<Auto components: procedures>>
end module auto_components
@ %def auto_components
@
\subsection{Constraints: Abstract types}
An abstract type that denotes a constraint on the automatically generated
states. The concrete objects are applied as visitor objects at certain hooks
during the splitting algorithm.
<<Auto components: types>>=
type, abstract :: split_constraint_t
contains
<<Auto components: split constraint: TBP>>
end type split_constraint_t
@ %def split_constraint_t
@ By default, all checks return true.
<<Auto components: split constraint: TBP>>=
procedure :: check_before_split => split_constraint_check_before_split
procedure :: check_before_insert => split_constraint_check_before_insert
procedure :: check_before_record => split_constraint_check_before_record
<<Auto components: procedures>>=
subroutine split_constraint_check_before_split (c, table, pl, k, passed)
class(split_constraint_t), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: k
logical, intent(out) :: passed
passed = .true.
end subroutine split_constraint_check_before_split
subroutine split_constraint_check_before_insert (c, table, pa, pl, passed)
class(split_constraint_t), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_array_t), intent(in) :: pa
type(pdg_list_t), intent(inout) :: pl
logical, intent(out) :: passed
passed = .true.
end subroutine split_constraint_check_before_insert
subroutine split_constraint_check_before_record (c, table, pl, n_loop, passed)
class(split_constraint_t), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop
logical, intent(out) :: passed
passed = .true.
end subroutine split_constraint_check_before_record
@ %def check_before_split
@ %def check_before_insert
@ %def check_before_record
@ A transparent wrapper, so we can collect constraints of different type.
<<Auto components: types>>=
type :: split_constraint_wrap_t
class(split_constraint_t), allocatable :: c
end type split_constraint_wrap_t
@ %def split_constraint_wrap_t
@ A collection of constraints.
<<Auto components: public>>=
public :: split_constraints_t
<<Auto components: types>>=
type :: split_constraints_t
class(split_constraint_wrap_t), dimension(:), allocatable :: cc
contains
<<Auto components: split constraints: TBP>>
end type split_constraints_t
@ %def split_constraints_t
@ Initialize the constraints set with a specific number of elements.
<<Auto components: split constraints: TBP>>=
procedure :: init => split_constraints_init
<<Auto components: procedures>>=
subroutine split_constraints_init (constraints, n)
class(split_constraints_t), intent(out) :: constraints
integer, intent(in) :: n
allocate (constraints%cc (n))
end subroutine split_constraints_init
@ %def split_constraints_init
@ Set a constraint.
<<Auto components: split constraints: TBP>>=
procedure :: set => split_constraints_set
<<Auto components: procedures>>=
subroutine split_constraints_set (constraints, i, c)
class(split_constraints_t), intent(inout) :: constraints
integer, intent(in) :: i
class(split_constraint_t), intent(in) :: c
allocate (constraints%cc(i)%c, source = c)
end subroutine split_constraints_set
@ %def split_constraints_set
@ Apply checks.
[[check_before_split]] is applied to the particle list that we want
to split.
[[check_before_insert]] is applied to the particle list [[pl]] that is to
replace the particle [[pa]] that is split. This check may transform the
particle list.
[[check_before_record]] is applied to the complete new particle list that
results from splitting before it is recorded.
<<Auto components: split constraints: TBP>>=
procedure :: check_before_split => split_constraints_check_before_split
procedure :: check_before_insert => split_constraints_check_before_insert
procedure :: check_before_record => split_constraints_check_before_record
<<Auto components: procedures>>=
subroutine split_constraints_check_before_split &
(constraints, table, pl, k, passed)
class(split_constraints_t), intent(in) :: constraints
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: k
logical, intent(out) :: passed
integer :: i
passed = .true.
do i = 1, size (constraints%cc)
call constraints%cc(i)%c%check_before_split (table, pl, k, passed)
if (.not. passed) return
end do
end subroutine split_constraints_check_before_split
subroutine split_constraints_check_before_insert &
(constraints, table, pa, pl, passed)
class(split_constraints_t), intent(in) :: constraints
class(ps_table_t), intent(in) :: table
type(pdg_array_t), intent(in) :: pa
type(pdg_list_t), intent(inout) :: pl
logical, intent(out) :: passed
integer :: i
passed = .true.
do i = 1, size (constraints%cc)
call constraints%cc(i)%c%check_before_insert (table, pa, pl, passed)
if (.not. passed) return
end do
end subroutine split_constraints_check_before_insert
subroutine split_constraints_check_before_record &
(constraints, table, pl, n_loop, passed)
class(split_constraints_t), intent(in) :: constraints
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop
logical, intent(out) :: passed
integer :: i
passed = .true.
do i = 1, size (constraints%cc)
call constraints%cc(i)%c%check_before_record (table, pl, n_loop, passed)
if (.not. passed) return
end do
end subroutine split_constraints_check_before_record
@ %def split_constraints_check_before_split
@ %def split_constraints_check_before_insert
@ %def split_constraints_check_before_record
@
\subsection{Specific constraints}
\subsubsection{Number of particles}
Specific constraint: The number of particles plus the number of loops, if
any, must remain less than the given limit. Note that the number of loops is
defined only when we are recording the entry.
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_n_tot
private
integer :: n_max = 0
contains
procedure :: check_before_split => constraint_n_tot_check_before_split
procedure :: check_before_record => constraint_n_tot_check_before_record
end type constraint_n_tot
@ %def constraint_n_tot
<<Auto components: public>>=
public :: constrain_n_tot
<<Auto components: procedures>>=
function constrain_n_tot (n_max) result (c)
integer, intent(in) :: n_max
type(constraint_n_tot) :: c
c%n_max = n_max
end function constrain_n_tot
subroutine constraint_n_tot_check_before_split (c, table, pl, k, passed)
class(constraint_n_tot), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: k
logical, intent(out) :: passed
passed = pl%get_size () < c%n_max
end subroutine constraint_n_tot_check_before_split
subroutine constraint_n_tot_check_before_record (c, table, pl, n_loop, passed)
class(constraint_n_tot), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop
logical, intent(out) :: passed
passed = pl%get_size () + n_loop <= c%n_max
end subroutine constraint_n_tot_check_before_record
@ %def constrain_n_tot
@ %def constraint_n_tot_check_before_insert
@
\subsubsection{Number of loops}
Specific constraint: The number of loops is limited, independent of the
total number of particles.
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_n_loop
private
integer :: n_loop_max = 0
contains
procedure :: check_before_record => constraint_n_loop_check_before_record
end type constraint_n_loop
@ %def constraint_n_loop
<<Auto components: public>>=
public :: constrain_n_loop
<<Auto components: procedures>>=
function constrain_n_loop (n_loop_max) result (c)
integer, intent(in) :: n_loop_max
type(constraint_n_loop) :: c
c%n_loop_max = n_loop_max
end function constrain_n_loop
subroutine constraint_n_loop_check_before_record &
(c, table, pl, n_loop, passed)
class(constraint_n_loop), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop
logical, intent(out) :: passed
passed = n_loop <= c%n_loop_max
end subroutine constraint_n_loop_check_before_record
@ %def constrain_n_loop
@ %def constraint_n_loop_check_before_insert
@
\subsubsection{Particles allowed in splitting}
Specific constraint: The entries in the particle list ready for insertion
are matched to a given list of particle patterns. If a match occurs, the
entry is replaced by the corresponding pattern. If there is no match, the
check fails. If a massless gauge boson splitting is detected, the splitting
partners are checked against a list of excluded particles. If a match
occurs, the check fails.
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_splittings
private
type(pdg_list_t) :: pl_match, pl_excluded_gauge_splittings
contains
procedure :: check_before_insert => constraint_splittings_check_before_insert
end type constraint_splittings
@ %def constraint_splittings
<<Auto components: public>>=
public :: constrain_splittings
<<Auto components: procedures>>=
function constrain_splittings (pl_match, pl_excluded_gauge_splittings) result (c)
type(pdg_list_t), intent(in) :: pl_match
type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings
type(constraint_splittings) :: c
c%pl_match = pl_match
c%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings
end function constrain_splittings
subroutine constraint_splittings_check_before_insert (c, table, pa, pl, passed)
class(constraint_splittings), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_array_t), intent(in) :: pa
type(pdg_list_t), intent(inout) :: pl
logical, intent(out) :: passed
logical :: has_massless_vector
integer :: i
has_massless_vector = .false.
do i = 1, pa%get_length ()
if (is_massless_vector(pa%get(i))) then
has_massless_vector = .true.
exit
end if
end do
passed = .false.
if (has_massless_vector .and. count (is_fermion(pl%a%get ())) == 2) then
do i = 1, c%pl_excluded_gauge_splittings%get_size ()
if (pl .match. c%pl_excluded_gauge_splittings%a(i)) return
end do
call pl%match_replace (c%pl_match, passed)
passed = .true.
else
call pl%match_replace (c%pl_match, passed)
end if
end subroutine constraint_splittings_check_before_insert
@ %def constrain_splittings
@ %def constraint_splittings_check_before_insert
@
Specific constraint: The entries in the particle list ready for insertion
are matched to a given list of particle patterns. If a match occurs, the
entry is replaced by the corresponding pattern. If there is no match, the
check fails.
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_insert
private
type(pdg_list_t) :: pl_match
contains
procedure :: check_before_insert => constraint_insert_check_before_insert
end type constraint_insert
@ %def constraint_insert
<<Auto components: public>>=
public :: constrain_insert
<<Auto components: procedures>>=
function constrain_insert (pl_match) result (c)
type(pdg_list_t), intent(in) :: pl_match
type(constraint_insert) :: c
c%pl_match = pl_match
end function constrain_insert
subroutine constraint_insert_check_before_insert (c, table, pa, pl, passed)
class(constraint_insert), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_array_t), intent(in) :: pa
type(pdg_list_t), intent(inout) :: pl
logical, intent(out) :: passed
call pl%match_replace (c%pl_match, passed)
end subroutine constraint_insert_check_before_insert
@ %def constrain_insert
@ %def constraint_insert_check_before_insert
@
\subsubsection{Particles required in final state}
Specific constraint: The entries in the recorded state must be a superset of
the entries in the given list (for instance, the lowest-order
state).
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_require
private
type(pdg_list_t) :: pl
contains
procedure :: check_before_record => constraint_require_check_before_record
end type constraint_require
@ %def constraint_require
@ We check the current state by matching all particle entries against the
stored particle list, and crossing out the particles in the latter list when a
match is found. The constraint passed if all entries have been crossed out.
For an [[if_table]] in particular, we check the final state only.
<<Auto components: public>>=
public :: constrain_require
<<Auto components: procedures>>=
function constrain_require (pl) result (c)
type(pdg_list_t), intent(in) :: pl
type(constraint_require) :: c
c%pl = pl
end function constrain_require
subroutine constraint_require_check_before_record &
(c, table, pl, n_loop, passed)
class(constraint_require), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop
logical, intent(out) :: passed
logical, dimension(:), allocatable :: mask
integer :: i, k, n_in
select type (table)
type is (if_table_t)
if (table%proc_type > 0) then
select case (table%proc_type)
case (PROC_DECAY)
n_in = 1
case (PROC_SCATTER)
n_in = 2
end select
else
call msg_fatal ("Neither a decay nor a scattering process")
end if
class default
n_in = 0
end select
allocate (mask (c%pl%get_size ()), source = .true.)
do i = n_in + 1, pl%get_size ()
k = c%pl%find_match (pl%get (i), mask)
if (k /= 0) mask(k) = .false.
end do
passed = .not. any (mask)
end subroutine constraint_require_check_before_record
@ %def constrain_require
@ %def constraint_require_check_before_record
@
\subsubsection{Radiation}
Specific constraint: We have radiation pattern if the original particle
matches an entry in the list of particles that should replace it. The
constraint prohibits this situation.
<<Auto components: public>>=
public :: constrain_radiation
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_radiation
private
contains
procedure :: check_before_insert => &
constraint_radiation_check_before_insert
end type constraint_radiation
@ %def constraint_radiation
<<Auto components: procedures>>=
function constrain_radiation () result (c)
type(constraint_radiation) :: c
end function constrain_radiation
subroutine constraint_radiation_check_before_insert (c, table, pa, pl, passed)
class(constraint_radiation), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_array_t), intent(in) :: pa
type(pdg_list_t), intent(inout) :: pl
logical, intent(out) :: passed
passed = .not. (pl .match. pa)
end subroutine constraint_radiation_check_before_insert
@ %def constrain_radiation
@ %def constraint_radiation_check_before_insert
@
\subsubsection{Mass sum}
Specific constraint: The sum of masses within the particle list must
be smaller than a given limit. For in/out state combinations, we
check initial and final state separately.
If we specify [[margin]] in the initialization, the sum must be
strictly less than the limit minus the given margin (which may be
zero). If not, equality is allowed.
<<Auto components: public>>=
public :: constrain_mass_sum
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_mass_sum
private
real(default) :: mass_limit = 0
logical :: strictly_less = .false.
real(default) :: margin = 0
contains
procedure :: check_before_record => constraint_mass_sum_check_before_record
end type constraint_mass_sum
@ %def contraint_mass_sum
<<Auto components: procedures>>=
function constrain_mass_sum (mass_limit, margin) result (c)
real(default), intent(in) :: mass_limit
real(default), intent(in), optional :: margin
type(constraint_mass_sum) :: c
c%mass_limit = mass_limit
if (present (margin)) then
c%strictly_less = .true.
c%margin = margin
end if
end function constrain_mass_sum
subroutine constraint_mass_sum_check_before_record &
(c, table, pl, n_loop, passed)
class(constraint_mass_sum), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop
logical, intent(out) :: passed
real(default) :: limit
if (c%strictly_less) then
limit = c%mass_limit - c%margin
select type (table)
type is (if_table_t)
passed = mass_sum (pl, 1, 2, table%model) < limit &
.and. mass_sum (pl, 3, pl%get_size (), table%model) < limit
class default
passed = mass_sum (pl, 1, pl%get_size (), table%model) < limit
end select
else
limit = c%mass_limit
select type (table)
type is (if_table_t)
passed = mass_sum (pl, 1, 2, table%model) <= limit &
.and. mass_sum (pl, 3, pl%get_size (), table%model) <= limit
class default
passed = mass_sum (pl, 1, pl%get_size (), table%model) <= limit
end select
end if
end subroutine constraint_mass_sum_check_before_record
@ %def constrain_mass_sum
@ %def constraint_mass_sum_check_before_record
@
\subsubsection{Initial state particles}
Specific constraint: The two incoming particles must both match the given
particle list. This is checked for the generated particle list, just before
it is recorded.
<<Auto components: public>>=
public :: constrain_in_state
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_in_state
private
type(pdg_list_t) :: pl
contains
procedure :: check_before_record => constraint_in_state_check_before_record
end type constraint_in_state
@ %def constraint_in_state
<<Auto components: procedures>>=
function constrain_in_state (pl) result (c)
type(pdg_list_t), intent(in) :: pl
type(constraint_in_state) :: c
c%pl = pl
end function constrain_in_state
subroutine constraint_in_state_check_before_record &
(c, table, pl, n_loop, passed)
class(constraint_in_state), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop
logical, intent(out) :: passed
integer :: i
select type (table)
type is (if_table_t)
passed = .false.
do i = 1, 2
if (.not. (c%pl .match. pl%get (i))) return
end do
end select
passed = .true.
end subroutine constraint_in_state_check_before_record
@ %def constrain_in_state
@ %def constraint_in_state_check_before_record
@
\subsubsection{Photon induced processes}
If set, filter out photon induced processes.
<<Auto components: public>>=
public :: constrain_photon_induced_processes
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_photon_induced_processes
private
integer :: n_in
contains
procedure :: check_before_record => &
constraint_photon_induced_processes_check_before_record
end type constraint_photon_induced_processes
@ %def constraint_photon_induced_processes
<<Auto components: procedures>>=
function constrain_photon_induced_processes (n_in) result (c)
integer, intent(in) :: n_in
type(constraint_photon_induced_processes) :: c
c%n_in = n_in
end function constrain_photon_induced_processes
subroutine constraint_photon_induced_processes_check_before_record &
(c, table, pl, n_loop, passed)
class(constraint_photon_induced_processes), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop
logical, intent(out) :: passed
integer :: i
select type (table)
type is (if_table_t)
passed = .false.
do i = 1, c%n_in
if (pl%a(i)%get () == 22) return
end do
end select
passed = .true.
end subroutine constraint_photon_induced_processes_check_before_record
@ %def constrain_photon_induced_processes
@ %def constraint_photon_induced_processes_check_before_record
@
\subsubsection{Coupling constraint}
Filters vertices which do not match the desired NLO pattern.
<<Auto components: types>>=
type, extends (split_constraint_t) :: constraint_coupling_t
private
logical :: qed = .false.
logical :: qcd = .true.
logical :: ew = .false.
integer :: n_nlo_correction_types
contains
<<Auto components: constraint coupling: TBP>>
end type constraint_coupling_t
@ %def constraint_coupling_t
@
<<Auto components: public>>=
public :: constrain_couplings
<<Auto components: procedures>>=
function constrain_couplings (qcd, qed, n_nlo_correction_types) result (c)
type(constraint_coupling_t) :: c
logical, intent(in) :: qcd, qed
integer, intent(in) :: n_nlo_correction_types
c%qcd = qcd; c%qed = qed
c%n_nlo_correction_types = n_nlo_correction_types
end function constrain_couplings
@ %def constrain_couplings
@
<<Auto components: constraint coupling: TBP>>=
procedure :: check_before_insert => constraint_coupling_check_before_insert
<<Auto components: procedures>>=
subroutine constraint_coupling_check_before_insert (c, table, pa, pl, passed)
class(constraint_coupling_t), intent(in) :: c
class(ps_table_t), intent(in) :: table
type(pdg_array_t), intent(in) :: pa
type(pdg_list_t), intent(inout) :: pl
logical, intent(out) :: passed
type(pdg_list_t) :: pl_vertex
type(pdg_array_t) :: pdg_gluon, pdg_photon, pdg_W_Z, pdg_gauge_bosons
integer :: i, j
pdg_gluon = GLUON; pdg_photon = PHOTON
pdg_W_Z = [W_BOSON,-W_BOSON, Z_BOSON]
if (c%qcd) pdg_gauge_bosons = pdg_gauge_bosons // pdg_gluon
if (c%qed) pdg_gauge_bosons = pdg_gauge_bosons // pdg_photon
if (c%ew) pdg_gauge_bosons = pdg_gauge_bosons // pdg_W_Z
do j = 1, pa%get_length ()
call pl_vertex%init (pl%get_size () + 1)
call pl_vertex%set (1, pa%get(j))
do i = 1, pl%get_size ()
call pl_vertex%set (i + 1, pl%get(i))
end do
if (pl_vertex%get_size () > 3) then
passed = .false.
cycle
end if
if (is_massless_vector(pa%get(j))) then
if (.not. table%model%check_vertex &
(pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then
passed = .false.
cycle
end if
else if (.not. table%model%check_vertex &
(- pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then
passed = .false.
cycle
end if
if (.not. (pl_vertex .match. pdg_gauge_bosons)) then
passed = .false.
cycle
end if
passed = .true.
exit
end do
end subroutine constraint_coupling_check_before_insert
@ %def constraint_coupling_check_before_insert
@
\subsection{Tables of states}
Automatically generate a list of possible process components for a given
initial set (a single massive particle or a preset list of states).
The set of process components are generated by recursive splitting, applying
constraints on the fly that control and limit the process. The generated
states are accumulated in a table that we can read out after completion.
<<Auto components: types>>=
type, extends (pdg_list_t) :: ps_entry_t
integer :: n_loop = 0
integer :: n_rad = 0
type(ps_entry_t), pointer :: previous => null ()
type(ps_entry_t), pointer :: next => null ()
end type ps_entry_t
@ %def ps_entry_t
@
<<Auto components: parameters>>=
integer, parameter :: PROC_UNDEFINED = 0
integer, parameter :: PROC_DECAY = 1
integer, parameter :: PROC_SCATTER = 2
@ %def auto_components parameters
@ This is the wrapper type for the decay tree for the list of final
states and the final array. First, an abstract base type:
<<Auto components: public>>=
public :: ps_table_t
<<Auto components: types>>=
type, abstract :: ps_table_t
private
class(model_data_t), pointer :: model => null ()
logical :: loops = .false.
type(ps_entry_t), pointer :: first => null ()
type(ps_entry_t), pointer :: last => null ()
integer :: proc_type
contains
<<Auto components: ps table: TBP>>
end type ps_table_t
@ %def ps_table_t
@ The extensions: one for decay, one for generic final states. The decay-state
table stores the initial particle. The final-state table is
indifferent, and the initial/final state table treats the first two
particles in its list as incoming antiparticles.
<<Auto components: public>>=
public :: ds_table_t
public :: fs_table_t
public :: if_table_t
<<Auto components: types>>=
type, extends (ps_table_t) :: ds_table_t
private
integer :: pdg_in = 0
contains
<<Auto components: ds table: TBP>>
end type ds_table_t
type, extends (ps_table_t) :: fs_table_t
contains
<<Auto components: fs table: TBP>>
end type fs_table_t
type, extends (fs_table_t) :: if_table_t
contains
<<Auto components: if table: TBP>>
end type if_table_t
@ %def ds_table_t fs_table_t if_table_t
@ Finalizer: we must deallocate the embedded list.
<<Auto components: ps table: TBP>>=
procedure :: final => ps_table_final
<<Auto components: procedures>>=
subroutine ps_table_final (object)
class(ps_table_t), intent(inout) :: object
type(ps_entry_t), pointer :: current
do while (associated (object%first))
current => object%first
object%first => current%next
deallocate (current)
end do
nullify (object%last)
end subroutine ps_table_final
@ %def ps_table_final
@ Write the table. A base writer for the body and specific writers
for the headers.
<<Auto components: ps table: TBP>>=
procedure :: base_write => ps_table_base_write
procedure (ps_table_write), deferred :: write
<<Auto components: interfaces>>=
interface
subroutine ps_table_write (object, unit)
import
class(ps_table_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine ps_table_write
end interface
<<Auto components: ds table: TBP>>=
procedure :: write => ds_table_write
<<Auto components: fs table: TBP>>=
procedure :: write => fs_table_write
<<Auto components: if table: TBP>>=
procedure :: write => if_table_write
@ The first [[n_in]] particles will be replaced by antiparticles in
the output, and we write an arrow if [[n_in]] is present.
<<Auto components: procedures>>=
subroutine ps_table_base_write (object, unit, n_in)
class(ps_table_t), intent(in) :: object
integer, intent(in), optional :: unit
integer, intent(in), optional :: n_in
integer, dimension(:), allocatable :: pdg
type(ps_entry_t), pointer :: entry
type(field_data_t), pointer :: prt
integer :: u, i, j, n0
u = given_output_unit (unit)
entry => object%first
do while (associated (entry))
write (u, "(2x)", advance = "no")
if (present (n_in)) then
do i = 1, n_in
write (u, "(1x)", advance = "no")
pdg = entry%get (i)
do j = 1, size (pdg)
prt => object%model%get_field_ptr (pdg(j))
if (j > 1) write (u, "(':')", advance = "no")
write (u, "(A)", advance = "no") &
char (prt%get_name (pdg(j) >= 0))
end do
end do
write (u, "(1x,A)", advance = "no") "=>"
n0 = n_in + 1
else
n0 = 1
end if
do i = n0, entry%get_size ()
write (u, "(1x)", advance = "no")
pdg = entry%get (i)
do j = 1, size (pdg)
prt => object%model%get_field_ptr (pdg(j))
if (j > 1) write (u, "(':')", advance = "no")
write (u, "(A)", advance = "no") &
char (prt%get_name (pdg(j) < 0))
end do
end do
if (object%loops) then
write (u, "(2x,'[',I0,',',I0,']')") entry%n_loop, entry%n_rad
else
write (u, "(A)")
end if
entry => entry%next
end do
end subroutine ps_table_base_write
subroutine ds_table_write (object, unit)
class(ds_table_t), intent(in) :: object
integer, intent(in), optional :: unit
type(field_data_t), pointer :: prt
integer :: u
u = given_output_unit (unit)
prt => object%model%get_field_ptr (object%pdg_in)
write (u, "(1x,A,1x,A)") "Decays for particle:", &
char (prt%get_name (object%pdg_in < 0))
call object%base_write (u)
end subroutine ds_table_write
subroutine fs_table_write (object, unit)
class(fs_table_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Table of final states:"
call object%base_write (u)
end subroutine fs_table_write
subroutine if_table_write (object, unit)
class(if_table_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Table of in/out states:"
select case (object%proc_type)
case (PROC_DECAY)
call object%base_write (u, n_in = 1)
case (PROC_SCATTER)
call object%base_write (u, n_in = 2)
end select
end subroutine if_table_write
@ %def ps_table_write ds_table_write fs_table_write
@ Obtain a particle string for a given index in the pdg list
<<Auto components: ps table: TBP>>=
procedure :: get_particle_string => ps_table_get_particle_string
<<Auto components: procedures>>=
subroutine ps_table_get_particle_string (object, index, prt_in, prt_out)
class(ps_table_t), intent(in) :: object
integer, intent(in) :: index
type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out
integer :: n_in
type(field_data_t), pointer :: prt
type(ps_entry_t), pointer :: entry
integer, dimension(:), allocatable :: pdg
integer :: n0
integer :: i, j
entry => object%first
i = 1
do while (i < index)
if (associated (entry%next)) then
entry => entry%next
i = i + 1
else
call msg_fatal ("ps_table: entry with requested index does not exist!")
end if
end do
if (object%proc_type > 0) then
select case (object%proc_type)
case (PROC_DECAY)
n_in = 1
case (PROC_SCATTER)
n_in = 2
end select
else
call msg_fatal ("Neither decay nor scattering process")
end if
n0 = n_in + 1
allocate (prt_in (n_in), prt_out (entry%get_size () - n_in))
do i = 1, n_in
prt_in(i) = ""
pdg = entry%get(i)
do j = 1, size (pdg)
prt => object%model%get_field_ptr (pdg(j))
prt_in(i) = prt_in(i) // prt%get_name (pdg(j) >= 0)
if (j /= size (pdg)) prt_in(i) = prt_in(i) // ":"
end do
end do
do i = n0, entry%get_size ()
prt_out(i-n_in) = ""
pdg = entry%get(i)
do j = 1, size (pdg)
prt => object%model%get_field_ptr (pdg(j))
prt_out(i-n_in) = prt_out(i-n_in) // prt%get_name (pdg(j) < 0)
if (j /= size (pdg)) prt_out(i-n_in) = prt_out(i-n_in) // ":"
end do
end do
end subroutine ps_table_get_particle_string
@ %def ps_table_get_particle_string
@ Initialize with a predefined set of final states, or in/out state lists.
<<Auto components: ps table: TBP>>=
generic :: init => ps_table_init
procedure, private :: ps_table_init
<<Auto components: if table: TBP>>=
generic :: init => if_table_init
procedure, private :: if_table_init
<<Auto components: procedures>>=
subroutine ps_table_init (table, model, pl, constraints, n_in, do_not_check_regular)
class(ps_table_t), intent(out) :: table
class(model_data_t), intent(in), target :: model
type(pdg_list_t), dimension(:), intent(in) :: pl
type(split_constraints_t), intent(in) :: constraints
integer, intent(in), optional :: n_in
logical, intent(in), optional :: do_not_check_regular
logical :: passed
integer :: i
table%model => model
if (present (n_in)) then
select case (n_in)
case (1)
table%proc_type = PROC_DECAY
case (2)
table%proc_type = PROC_SCATTER
case default
table%proc_type = PROC_UNDEFINED
end select
else
table%proc_type = PROC_UNDEFINED
end if
do i = 1, size (pl)
call table%record (pl(i), 0, 0, constraints, &
do_not_check_regular, passed)
if (.not. passed) then
call msg_fatal ("ps_table: Registering process components failed")
end if
end do
end subroutine ps_table_init
subroutine if_table_init (table, model, pl_in, pl_out, constraints)
class(if_table_t), intent(out) :: table
class(model_data_t), intent(in), target :: model
type(pdg_list_t), dimension(:), intent(in) :: pl_in, pl_out
type(split_constraints_t), intent(in) :: constraints
integer :: i, j, k, p, n_in, n_out
type(pdg_array_t), dimension(:), allocatable :: pa_in
type(pdg_list_t), dimension(:), allocatable :: pl
allocate (pl (size (pl_in) * size (pl_out)))
k = 0
do i = 1, size (pl_in)
n_in = pl_in(i)%get_size ()
allocate (pa_in (n_in))
do p = 1, n_in
pa_in(p) = pl_in(i)%get (p)
end do
do j = 1, size (pl_out)
n_out = pl_out(j)%get_size ()
k = k + 1
call pl(k)%init (n_in + n_out)
do p = 1, n_in
call pl(k)%set (p, invert_pdg_array (pa_in(p), model))
end do
do p = 1, n_out
call pl(k)%set (n_in + p, pl_out(j)%get (p))
end do
end do
deallocate (pa_in)
end do
n_in = size (pl_in(1)%a)
call table%init (model, pl, constraints, n_in, do_not_check_regular = .true.)
end subroutine if_table_init
@ %def ps_table_init if_table_init
@ Enable loops for the table. This affects both splitting and output.
<<Auto components: ps table: TBP>>=
procedure :: enable_loops => ps_table_enable_loops
<<Auto components: procedures>>=
subroutine ps_table_enable_loops (table)
class(ps_table_t), intent(inout) :: table
table%loops = .true.
end subroutine ps_table_enable_loops
@ %def ps_table_enable_loops
@
\subsection{Top-level methods}
Create a table for a single-particle decay. Construct all possible final
states from a single particle with PDG code [[pdg_in]]. The construction is
limited by the given [[constraints]].
<<Auto components: ds table: TBP>>=
procedure :: make => ds_table_make
<<Auto components: procedures>>=
subroutine ds_table_make (table, model, pdg_in, constraints)
class(ds_table_t), intent(out) :: table
class(model_data_t), intent(in), target :: model
integer, intent(in) :: pdg_in
type(split_constraints_t), intent(in) :: constraints
type(pdg_list_t) :: pl_in
type(pdg_list_t), dimension(0) :: pl
call table%init (model, pl, constraints)
table%pdg_in = pdg_in
call pl_in%init (1)
call pl_in%set (1, [pdg_in])
call table%split (pl_in, 0, constraints)
end subroutine ds_table_make
@ %def ds_table_make
@ Split all entries in a growing table, starting from a table that may already
contain states. Add and record split states on the fly.
<<Auto components: fs table: TBP>>=
procedure :: radiate => fs_table_radiate
<<Auto components: procedures>>=
subroutine fs_table_radiate (table, constraints, do_not_check_regular)
class(fs_table_t), intent(inout) :: table
type(split_constraints_t) :: constraints
logical, intent(in), optional :: do_not_check_regular
type(ps_entry_t), pointer :: current
current => table%first
do while (associated (current))
call table%split (current, 0, constraints, record = .true., &
do_not_check_regular = do_not_check_regular)
current => current%next
end do
end subroutine fs_table_radiate
@ %def fs_table_radiate
@
\subsection{Splitting algorithm}
Recursive splitting. First of all, we record the current [[pdg_list]] in
the table, subject to [[constraints]], if requested. We also record copies of
the list marked as loop corrections.
When we record a particle list, we sort it first.
If there is room for splitting, We take a PDG array list and the index of an
element, and split this element in all possible ways. The split entry is
inserted into the list, which we split further.
The recursion terminates whenever the split array would have a length
greater than $n_\text{max}$.
<<Auto components: ps table: TBP>>=
procedure :: split => ps_table_split
<<Auto components: procedures>>=
recursive subroutine ps_table_split (table, pl, n_rad, constraints, &
record, do_not_check_regular)
class(ps_table_t), intent(inout) :: table
class(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_rad
type(split_constraints_t), intent(in) :: constraints
logical, intent(in), optional :: record, do_not_check_regular
integer :: n_loop, i
logical :: passed, save_pdg_index
type(vertex_iterator_t) :: vit
integer, dimension(:), allocatable :: pdg1
integer, dimension(:), allocatable :: pdg2
if (present (record)) then
if (record) then
n_loop = 0
INCR_LOOPS: do
call table%record_sorted (pl, n_loop, n_rad, constraints, &
do_not_check_regular, passed)
if (.not. passed) exit INCR_LOOPS
if (.not. table%loops) exit INCR_LOOPS
n_loop = n_loop + 1
end do INCR_LOOPS
end if
end if
select type (table)
type is (if_table_t)
save_pdg_index = .true.
class default
save_pdg_index = .false.
end select
do i = 1, pl%get_size ()
call constraints%check_before_split (table, pl, i, passed)
if (passed) then
pdg1 = pl%get (i)
call vit%init (table%model, pdg1, save_pdg_index)
SCAN_VERTICES: do
call vit%get_next_match (pdg2)
if (allocated (pdg2)) then
call table%insert (pl, n_rad, i, pdg2, constraints, &
do_not_check_regular = do_not_check_regular)
else
exit SCAN_VERTICES
end if
end do SCAN_VERTICES
end if
end do
end subroutine ps_table_split
@ %def ps_table_split
@ The worker part: insert the list of particles found by vertex matching in
place of entry [[i]] in the PDG list. Then split/record further.
The [[n_in]] parameter tells the replacement routine to insert the new
particles after entry [[n_in]]. Otherwise, they follow index [[i]].
<<Auto components: ps table: TBP>>=
procedure :: insert => ps_table_insert
<<Auto components: procedures>>=
recursive subroutine ps_table_insert &
(table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular)
class(ps_table_t), intent(inout) :: table
class(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_rad, i
integer, dimension(:), intent(in) :: pdg
type(split_constraints_t), intent(in) :: constraints
integer, intent(in), optional :: n_in
logical, intent(in), optional :: do_not_check_regular
type(pdg_list_t) :: pl_insert
logical :: passed
integer :: k, s
s = size (pdg)
call pl_insert%init (s)
do k = 1, s
call pl_insert%set (k, pdg(k))
end do
call constraints%check_before_insert (table, pl%get (i), pl_insert, passed)
if (passed) then
if (.not. is_colored_isr ()) return
call table%split (pl%replace (i, pl_insert, n_in), n_rad + s - 1, &
constraints, record = .true., do_not_check_regular = .true.)
end if
contains
logical function is_colored_isr () result (ok)
type(pdg_list_t) :: pl_replaced
ok = .true.
if (present (n_in)) then
if (i <= n_in) then
ok = pl_insert%contains_colored_particles ()
if (.not. ok) then
pl_replaced = pl%replace (i, pl_insert, n_in)
associate (size_replaced => pl_replaced%get_pdg_sizes (), &
size => pl%get_pdg_sizes ())
ok = all (size_replaced(:n_in) == size(:n_in))
end associate
end if
end if
end if
end function is_colored_isr
end subroutine ps_table_insert
@ %def ps_table_insert
@ Special case:
If we are splitting an initial particle, there is slightly more to
do. We loop over the particles from the vertex match and replace the
initial particle by each of them in turn. The remaining particles
must be appended after the second initial particle, so they will end
up in the out state. This is done by providing the [[n_in]] argument
to the base method as an optional argument.
Note that we must call the base-method procedure explicitly, so the
[[table]] argument keeps its dynamic type as [[if_table]] inside this
procedure.
<<Auto components: if table: TBP>>=
procedure :: insert => if_table_insert
<<Auto components: procedures>>=
recursive subroutine if_table_insert &
(table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular)
class(if_table_t), intent(inout) :: table
class(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_rad, i
integer, dimension(:), intent(in) :: pdg
type(split_constraints_t), intent(in) :: constraints
integer, intent(in), optional :: n_in
logical, intent(in), optional :: do_not_check_regular
integer, dimension(:), allocatable :: pdg_work
integer :: p
if (i > 2) then
call ps_table_insert (table, pl, n_rad, i, pdg, constraints, &
do_not_check_regular = do_not_check_regular)
else
allocate (pdg_work (size (pdg)))
do p = 1, size (pdg)
pdg_work(1) = pdg(p)
pdg_work(2:p) = pdg(1:p-1)
pdg_work(p+1:) = pdg(p+1:)
select case (table%proc_type)
case (PROC_DECAY)
call ps_table_insert (table, &
pl, n_rad, i, pdg_work, constraints, n_in = 1, &
do_not_check_regular = do_not_check_regular)
case (PROC_SCATTER)
call ps_table_insert (table, &
pl, n_rad, i, pdg_work, constraints, n_in = 2, &
do_not_check_regular = do_not_check_regular)
end select
end do
end if
end subroutine if_table_insert
@ %def if_table_insert
@ Sort before recording. In the case of the [[if_table]], we do not
sort the first [[n_in]] particle entries. Instead, we check whether they are
allowed in the [[pl_beam]] PDG list, if that is provided.
<<Auto components: ps table: TBP>>=
procedure :: record_sorted => ps_table_record_sorted
<<Auto components: if table: TBP>>=
procedure :: record_sorted => if_table_record_sorted
<<Auto components: procedures>>=
subroutine ps_table_record_sorted &
(table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed)
class(ps_table_t), intent(inout) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop, n_rad
type(split_constraints_t), intent(in) :: constraints
logical, intent(in), optional :: do_not_check_regular
logical, intent(out) :: passed
call table%record (pl%sort_abs (), n_loop, n_rad, constraints, &
do_not_check_regular, passed)
end subroutine ps_table_record_sorted
subroutine if_table_record_sorted &
(table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed)
class(if_table_t), intent(inout) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop, n_rad
type(split_constraints_t), intent(in) :: constraints
logical, intent(in), optional :: do_not_check_regular
logical, intent(out) :: passed
call table%record (pl%sort_abs (2), n_loop, n_rad, constraints, &
do_not_check_regular, passed)
end subroutine if_table_record_sorted
@ %def ps_table_record_sorted if_table_record_sorted
@ Record an entry: insert into the list. Check the ordering and
insert it at the correct place, unless it is already there.
We record an array only if its mass sum is less than the total
available energy. This restriction is removed by setting
[[constrained]] to false.
<<Auto components: ps table: TBP>>=
procedure :: record => ps_table_record
<<Auto components: procedures>>=
subroutine ps_table_record (table, pl, n_loop, n_rad, constraints, &
do_not_check_regular, passed)
class(ps_table_t), intent(inout) :: table
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n_loop, n_rad
type(split_constraints_t), intent(in) :: constraints
logical, intent(in), optional :: do_not_check_regular
logical, intent(out) :: passed
type(ps_entry_t), pointer :: current
logical :: needs_check
passed = .false.
needs_check = .true.
if (present (do_not_check_regular)) needs_check = .not. do_not_check_regular
if (needs_check .and. .not. pl%is_regular ()) then
call msg_warning ("Record ps_table entry: Irregular pdg-list encountered!")
return
end if
call constraints%check_before_record (table, pl, n_loop, passed)
if (.not. passed) then
return
end if
current => table%first
do while (associated (current))
if (pl == current) then
if (n_loop == current%n_loop) return
else if (pl < current) then
call insert
return
end if
current => current%next
end do
call insert
contains
subroutine insert ()
type(ps_entry_t), pointer :: entry
allocate (entry)
entry%pdg_list_t = pl
entry%n_loop = n_loop
entry%n_rad = n_rad
if (associated (current)) then
if (associated (current%previous)) then
current%previous%next => entry
entry%previous => current%previous
else
table%first => entry
end if
entry%next => current
current%previous => entry
else
if (associated (table%last)) then
table%last%next => entry
entry%previous => table%last
else
table%first => entry
end if
table%last => entry
end if
end subroutine insert
end subroutine ps_table_record
@ %def ps_table_record
@
\subsection{Tools}
Compute the mass sum for a PDG list object, counting the entries with indices
between (including) [[n1]] and [[n2]]. Rely on the requirement that
if an entry is a PDG array, this array must be degenerate in mass.
<<Auto components: procedures>>=
function mass_sum (pl, n1, n2, model) result (m)
type(pdg_list_t), intent(in) :: pl
integer, intent(in) :: n1, n2
class(model_data_t), intent(in), target :: model
integer, dimension(:), allocatable :: pdg
real(default) :: m
type(field_data_t), pointer :: prt
integer :: i
m = 0
do i = n1, n2
pdg = pl%get (i)
prt => model%get_field_ptr (pdg(1))
m = m + prt%get_mass ()
end do
end function mass_sum
@ %def mass_sum
@ Invert a PDG array, replacing particles by antiparticles. This
depends on the model.
<<Auto components: procedures>>=
function invert_pdg_array (pa, model) result (pa_inv)
type(pdg_array_t), intent(in) :: pa
class(model_data_t), intent(in), target :: model
type(pdg_array_t) :: pa_inv
type(field_data_t), pointer :: prt
integer :: i, pdg
pa_inv = pa
do i = 1, pa_inv%get_length ()
pdg = pa_inv%get (i)
prt => model%get_field_ptr (pdg)
if (prt%has_antiparticle ()) call pa_inv%set (i, -pdg)
end do
end function invert_pdg_array
@ %def invert_pdg_array
@
\subsection{Access results}
Return the number of generated decays.
<<Auto components: ps table: TBP>>=
procedure :: get_length => ps_table_get_length
<<Auto components: procedures>>=
function ps_table_get_length (ps_table) result (n)
class(ps_table_t), intent(in) :: ps_table
integer :: n
type(ps_entry_t), pointer :: entry
n = 0
entry => ps_table%first
do while (associated (entry))
n = n + 1
entry => entry%next
end do
end function ps_table_get_length
@ %def ps_table_get_length
@
<<Auto components: ps table: TBP>>=
procedure :: get_emitters => ps_table_get_emitters
<<Auto components: procedures>>=
subroutine ps_table_get_emitters (table, constraints, emitters)
class(ps_table_t), intent(in) :: table
type(split_constraints_t), intent(in) :: constraints
integer, dimension(:), allocatable, intent(out) :: emitters
class(pdg_list_t), pointer :: pl
integer :: i
logical :: passed
type(vertex_iterator_t) :: vit
integer, dimension(:), allocatable :: pdg1, pdg2
integer :: n_emitters
integer, dimension(:), allocatable :: emitters_tmp
integer, parameter :: buf0 = 6
n_emitters = 0
pl => table%first
allocate (emitters_tmp (buf0))
do i = 1, pl%get_size ()
call constraints%check_before_split (table, pl, i, passed)
if (passed) then
pdg1 = pl%get(i)
call vit%init (table%model, pdg1, .false.)
do
call vit%get_next_match(pdg2)
if (allocated (pdg2)) then
if (n_emitters + 1 > size (emitters_tmp)) &
call extend_integer_array (emitters_tmp, 10)
emitters_tmp (n_emitters + 1) = pdg1(1)
n_emitters = n_emitters + 1
else
exit
end if
end do
end if
end do
allocate (emitters (n_emitters))
emitters = emitters_tmp (1:n_emitters)
deallocate (emitters_tmp)
end subroutine ps_table_get_emitters
@ %def ps_table_get_emitters
@ Return an allocated array of decay products (PDG codes). If
requested, return also the loop and radiation order count.
<<Auto components: ps table: TBP>>=
procedure :: get_pdg_out => ps_table_get_pdg_out
<<Auto components: procedures>>=
subroutine ps_table_get_pdg_out (ps_table, i, pa_out, n_loop, n_rad)
class(ps_table_t), intent(in) :: ps_table
integer, intent(in) :: i
type(pdg_array_t), dimension(:), allocatable, intent(out) :: pa_out
integer, intent(out), optional :: n_loop, n_rad
type(ps_entry_t), pointer :: entry
integer :: n, j
n = 0
entry => ps_table%first
FIND_ENTRY: do while (associated (entry))
n = n + 1
if (n == i) then
allocate (pa_out (entry%get_size ()))
do j = 1, entry%get_size ()
pa_out(j) = entry%get (j)
if (present (n_loop)) n_loop = entry%n_loop
if (present (n_rad)) n_rad = entry%n_rad
end do
exit FIND_ENTRY
end if
entry => entry%next
end do FIND_ENTRY
end subroutine ps_table_get_pdg_out
@ %def ps_table_get_pdg_out
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[auto_components_ut.f90]]>>=
<<File header>>
module auto_components_ut
use unit_tests
use auto_components_uti
<<Standard module head>>
<<Auto components: public test>>
contains
<<Auto components: test driver>>
end module auto_components_ut
@ %def auto_components_ut
@
<<[[auto_components_uti.f90]]>>=
<<File header>>
module auto_components_uti
<<Use kinds>>
<<Use strings>>
use pdg_arrays
use model_data
use model_testbed, only: prepare_model, cleanup_model
use auto_components
<<Standard module head>>
<<Auto components: test declarations>>
contains
<<Auto components: tests>>
end module auto_components_uti
@ %def auto_components_ut
@ API: driver for the unit tests below.
<<Auto components: public test>>=
public :: auto_components_test
<<Auto components: test driver>>=
subroutine auto_components_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Auto components: execute tests>>
end subroutine auto_components_test
@ %def auto_components_tests
@
\subsubsection{Generate Decay Table}
Determine all kinematically allowed decay channels for a Higgs boson,
using default parameter values.
<<Auto components: execute tests>>=
call test (auto_components_1, "auto_components_1", &
"generate decay table", &
u, results)
<<Auto components: test declarations>>=
public :: auto_components_1
<<Auto components: tests>>=
subroutine auto_components_1 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: model
type(field_data_t), pointer :: prt
type(ds_table_t) :: ds_table
type(split_constraints_t) :: constraints
write (u, "(A)") "* Test output: auto_components_1"
write (u, "(A)") "* Purpose: determine Higgs decay table"
write (u, *)
write (u, "(A)") "* Read Standard Model"
model => null ()
call prepare_model (model, var_str ("SM"))
prt => model%get_field_ptr (25)
write (u, *)
write (u, "(A)") "* Higgs decays n = 2"
write (u, *)
call constraints%init (2)
call constraints%set (1, constrain_n_tot (2))
call constraints%set (2, constrain_mass_sum (prt%get_mass ()))
call ds_table%make (model, 25, constraints)
call ds_table%write (u)
call ds_table%final ()
write (u, *)
write (u, "(A)") "* Higgs decays n = 3 (w/o radiative)"
write (u, *)
call constraints%init (3)
call constraints%set (1, constrain_n_tot (3))
call constraints%set (2, constrain_mass_sum (prt%get_mass ()))
call constraints%set (3, constrain_radiation ())
call ds_table%make (model, 25, constraints)
call ds_table%write (u)
call ds_table%final ()
write (u, *)
write (u, "(A)") "* Higgs decays n = 3 (w/ radiative)"
write (u, *)
call constraints%init (2)
call constraints%set (1, constrain_n_tot (3))
call constraints%set (2, constrain_mass_sum (prt%get_mass ()))
call ds_table%make (model, 25, constraints)
call ds_table%write (u)
call ds_table%final ()
write (u, *)
write (u, "(A)") "* Cleanup"
call cleanup_model (model)
deallocate (model)
write (u, *)
write (u, "(A)") "* Test output end: auto_components_1"
end subroutine auto_components_1
@ %def auto_components_1
@
\subsubsection{Generate radiation}
Given a final state, add radiation (NLO and NNLO). We provide a list
of particles that is allowed to occur in the generated final states.
<<Auto components: execute tests>>=
call test (auto_components_2, "auto_components_2", &
"generate NLO corrections, final state", &
u, results)
<<Auto components: test declarations>>=
public :: auto_components_2
<<Auto components: tests>>=
subroutine auto_components_2 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: model
type(pdg_list_t), dimension(:), allocatable :: pl, pl_zzh
type(pdg_list_t) :: pl_match
type(fs_table_t) :: fs_table
type(split_constraints_t) :: constraints
real(default) :: sqrts
integer :: i
write (u, "(A)") "* Test output: auto_components_2"
write (u, "(A)") "* Purpose: generate radiation (NLO)"
write (u, *)
write (u, "(A)") "* Read Standard Model"
model => null ()
call prepare_model (model, var_str ("SM"))
write (u, *)
write (u, "(A)") "* LO final state"
write (u, *)
allocate (pl (2))
call pl(1)%init (2)
call pl(1)%set (1, 1)
call pl(1)%set (2, -1)
call pl(2)%init (2)
call pl(2)%set (1, 21)
call pl(2)%set (2, 21)
do i = 1, 2
call pl(i)%write (u); write (u, *)
end do
write (u, *)
write (u, "(A)") "* Initialize FS table"
write (u, *)
call constraints%init (1)
call constraints%set (1, constrain_n_tot (3))
call fs_table%init (model, pl, constraints)
call fs_table%write (u)
write (u, *)
write (u, "(A)") "* Generate NLO corrections, unconstrained"
write (u, *)
call fs_table%radiate (constraints)
call fs_table%write (u)
call fs_table%final ()
write (u, *)
write (u, "(A)") "* Generate NLO corrections, &
&complete but mass-constrained"
write (u, *)
sqrts = 50
call constraints%init (2)
call constraints%set (1, constrain_n_tot (3))
call constraints%set (2, constrain_mass_sum (sqrts))
call fs_table%init (model, pl, constraints)
call fs_table%radiate (constraints)
call fs_table%write (u)
call fs_table%final ()
write (u, *)
write (u, "(A)") "* Generate NLO corrections, restricted"
write (u, *)
call pl_match%init ([1, -1, 21])
call constraints%init (2)
call constraints%set (1, constrain_n_tot (3))
call constraints%set (2, constrain_insert (pl_match))
call fs_table%init (model, pl, constraints)
call fs_table%radiate (constraints)
call fs_table%write (u)
call fs_table%final ()
write (u, *)
write (u, "(A)") "* Generate NNLO corrections, restricted, with one loop"
write (u, *)
call pl_match%init ([1, -1, 21])
call constraints%init (3)
call constraints%set (1, constrain_n_tot (4))
call constraints%set (2, constrain_n_loop (1))
call constraints%set (3, constrain_insert (pl_match))
call fs_table%init (model, pl, constraints)
call fs_table%enable_loops ()
call fs_table%radiate (constraints)
call fs_table%write (u)
call fs_table%final ()
write (u, *)
write (u, "(A)") "* Generate NNLO corrections, restricted, with loops"
write (u, *)
call constraints%init (2)
call constraints%set (1, constrain_n_tot (4))
call constraints%set (2, constrain_insert (pl_match))
call fs_table%init (model, pl, constraints)
call fs_table%enable_loops ()
call fs_table%radiate (constraints)
call fs_table%write (u)
call fs_table%final ()
write (u, *)
write (u, "(A)") "* Generate NNLO corrections, restricted, to Z Z H, &
&no loops"
write (u, *)
allocate (pl_zzh (1))
call pl_zzh(1)%init (3)
call pl_zzh(1)%set (1, 23)
call pl_zzh(1)%set (2, 23)
call pl_zzh(1)%set (3, 25)
call constraints%init (3)
call constraints%set (1, constrain_n_tot (5))
call constraints%set (2, constrain_mass_sum (500._default))
call constraints%set (3, constrain_require (pl_zzh(1)))
call fs_table%init (model, pl_zzh, constraints)
call fs_table%radiate (constraints)
call fs_table%write (u)
call fs_table%final ()
call cleanup_model (model)
deallocate (model)
write (u, *)
write (u, "(A)") "* Test output end: auto_components_2"
end subroutine auto_components_2
@ %def auto_components_2
@
\subsubsection{Generate radiation from initial and final state}
Given a process, add radiation (NLO and NNLO). We provide a list
of particles that is allowed to occur in the generated final states.
<<Auto components: execute tests>>=
call test (auto_components_3, "auto_components_3", &
"generate NLO corrections, in and out", &
u, results)
<<Auto components: test declarations>>=
public :: auto_components_3
<<Auto components: tests>>=
subroutine auto_components_3 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: model
type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out
type(pdg_list_t) :: pl_match, pl_beam
type(if_table_t) :: if_table
type(split_constraints_t) :: constraints
real(default) :: sqrts
integer :: i
write (u, "(A)") "* Test output: auto_components_3"
write (u, "(A)") "* Purpose: generate radiation (NLO)"
write (u, *)
write (u, "(A)") "* Read Standard Model"
model => null ()
call prepare_model (model, var_str ("SM"))
write (u, *)
write (u, "(A)") "* LO initial state"
write (u, *)
allocate (pl_in (2))
call pl_in(1)%init (2)
call pl_in(1)%set (1, 1)
call pl_in(1)%set (2, -1)
call pl_in(2)%init (2)
call pl_in(2)%set (1, -1)
call pl_in(2)%set (2, 1)
do i = 1, 2
call pl_in(i)%write (u); write (u, *)
end do
write (u, *)
write (u, "(A)") "* LO final state"
write (u, *)
allocate (pl_out (1))
call pl_out(1)%init (1)
call pl_out(1)%set (1, 23)
call pl_out(1)%write (u); write (u, *)
write (u, *)
write (u, "(A)") "* Initialize FS table"
write (u, *)
call constraints%init (1)
call constraints%set (1, constrain_n_tot (4))
call if_table%init (model, pl_in, pl_out, constraints)
call if_table%write (u)
write (u, *)
write (u, "(A)") "* Generate NLO corrections, unconstrained"
write (u, *)
call if_table%radiate (constraints)
call if_table%write (u)
call if_table%final ()
write (u, *)
write (u, "(A)") "* Generate NLO corrections, &
&complete but mass-constrained"
write (u, *)
sqrts = 100
call constraints%init (2)
call constraints%set (1, constrain_n_tot (4))
call constraints%set (2, constrain_mass_sum (sqrts))
call if_table%init (model, pl_in, pl_out, constraints)
call if_table%radiate (constraints)
call if_table%write (u)
call if_table%final ()
write (u, *)
write (u, "(A)") "* Generate NLO corrections, &
&mass-constrained, restricted beams"
write (u, *)
call pl_beam%init (3)
call pl_beam%set (1, 1)
call pl_beam%set (2, -1)
call pl_beam%set (3, 21)
call constraints%init (3)
call constraints%set (1, constrain_n_tot (4))
call constraints%set (2, constrain_in_state (pl_beam))
call constraints%set (3, constrain_mass_sum (sqrts))
call if_table%init (model, pl_in, pl_out, constraints)
call if_table%radiate (constraints)
call if_table%write (u)
call if_table%final ()
write (u, *)
write (u, "(A)") "* Generate NLO corrections, restricted"
write (u, *)
call pl_match%init ([1, -1, 21])
call constraints%init (4)
call constraints%set (1, constrain_n_tot (4))
call constraints%set (2, constrain_in_state (pl_beam))
call constraints%set (3, constrain_mass_sum (sqrts))
call constraints%set (4, constrain_insert (pl_match))
call if_table%init (model, pl_in, pl_out, constraints)
call if_table%radiate (constraints)
call if_table%write (u)
call if_table%final ()
write (u, *)
write (u, "(A)") "* Generate NNLO corrections, restricted, Z preserved, &
&with loops"
write (u, *)
call constraints%init (5)
call constraints%set (1, constrain_n_tot (5))
call constraints%set (2, constrain_in_state (pl_beam))
call constraints%set (3, constrain_mass_sum (sqrts))
call constraints%set (4, constrain_insert (pl_match))
call constraints%set (5, constrain_require (pl_out(1)))
call if_table%init (model, pl_in, pl_out, constraints)
call if_table%enable_loops ()
call if_table%radiate (constraints)
call if_table%write (u)
call if_table%final ()
call cleanup_model (model)
deallocate (model)
write (u, *)
write (u, "(A)") "* Test output end: auto_components_3"
end subroutine auto_components_3
@ %def auto_components_3
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Creating the real flavor structure}
<<[[radiation_generator.f90]]>>=
<<File header>>
module radiation_generator
<<Use kinds>>
<<Use strings>>
use diagnostics
use io_units
use physics_defs, only: PHOTON, GLUON
use pdg_arrays
use flavors
use model_data
use auto_components
use string_utils, only: split_string, string_contains_word
implicit none
private
<<radiation generator: public>>
<<radiation generator: types>>
contains
<<radiation generator: procedures>>
end module radiation_generator
@ %def radiation_generator
@
<<radiation generator: types>>=
type :: pdg_sorter_t
integer :: pdg
logical :: checked = .false.
integer :: associated_born = 0
end type pdg_sorter_t
@ %def pdg_sorter
@
<<radiation generator: types>>=
type :: pdg_states_t
type(pdg_array_t), dimension(:), allocatable :: pdg
type(pdg_states_t), pointer :: next
integer :: n_particles
contains
<<radiation generator: pdg states: TBP>>
end type pdg_states_t
@ %def pdg_states_t
<<radiation generator: pdg states: TBP>>=
procedure :: init => pdg_states_init
<<radiation generator: procedures>>=
subroutine pdg_states_init (states)
class(pdg_states_t), intent(inout) :: states
nullify (states%next)
end subroutine pdg_states_init
@ %def pdg_states_init
@
<<radiation generator: pdg states: TBP>>=
procedure :: add => pdg_states_add
<<radiation generator: procedures>>=
subroutine pdg_states_add (states, pdg)
class(pdg_states_t), intent(inout), target :: states
type(pdg_array_t), dimension(:), intent(in) :: pdg
type(pdg_states_t), pointer :: current_state
select type (states)
type is (pdg_states_t)
current_state => states
do
if (associated (current_state%next)) then
current_state => current_state%next
else
allocate (current_state%next)
nullify(current_state%next%next)
current_state%pdg = pdg
exit
end if
end do
end select
end subroutine pdg_states_add
@ %def pdg_states_add
@
<<radiation generator: pdg states: TBP>>=
procedure :: get_n_states => pdg_states_get_n_states
<<radiation generator: procedures>>=
function pdg_states_get_n_states (states) result (n)
class(pdg_states_t), intent(in), target :: states
integer :: n
type(pdg_states_t), pointer :: current_state
n = 0
select type(states)
type is (pdg_states_t)
current_state => states
do
if (associated (current_state%next)) then
n = n+1
current_state => current_state%next
else
exit
end if
end do
end select
end function pdg_states_get_n_states
@ %def pdg_states_get_n_states
@
<<radiation generator: types>>=
type :: prt_queue_t
type(string_t), dimension(:), allocatable :: prt_string
type(prt_queue_t), pointer :: next => null ()
type(prt_queue_t), pointer :: previous => null ()
type(prt_queue_t), pointer :: front => null ()
type(prt_queue_t), pointer :: current_prt => null ()
type(prt_queue_t), pointer :: back => null ()
integer :: n_lists = 0
contains
<<radiation generator: prt queue: TBP>>
end type prt_queue_t
@ %def prt_queue_t
@
<<radiation generator: prt queue: TBP>>=
procedure :: null => prt_queue_null
<<radiation generator: procedures>>=
subroutine prt_queue_null (queue)
class(prt_queue_t), intent(out) :: queue
queue%next => null ()
queue%previous => null ()
queue%front => null ()
queue%current_prt => null ()
queue%back => null ()
queue%n_lists = 0
if (allocated (queue%prt_string)) deallocate (queue%prt_string)
end subroutine prt_queue_null
@ %def prt_queue_null
@
<<radiation generator: prt queue: TBP>>=
procedure :: append => prt_queue_append
<<radiation generator: procedures>>=
subroutine prt_queue_append (queue, prt_string)
class(prt_queue_t), intent(inout) :: queue
type(string_t), intent(in), dimension(:) :: prt_string
type(prt_queue_t), pointer :: new_element => null ()
type(prt_queue_t), pointer :: current_back => null ()
allocate (new_element)
allocate (new_element%prt_string(size (prt_string)))
new_element%prt_string = prt_string
if (associated (queue%back)) then
current_back => queue%back
current_back%next => new_element
new_element%previous => current_back
queue%back => new_element
else
!!! Initial entry
queue%front => new_element
queue%back => queue%front
queue%current_prt => queue%front
end if
queue%n_lists = queue%n_lists + 1
end subroutine prt_queue_append
@ %def prt_queue_append
@
<<radiation generator: prt queue: TBP>>=
procedure :: get => prt_queue_get
<<radiation generator: procedures>>=
subroutine prt_queue_get (queue, prt_string)
class(prt_queue_t), intent(inout) :: queue
type(string_t), dimension(:), allocatable, intent(out) :: prt_string
if (associated (queue%current_prt)) then
prt_string = queue%current_prt%prt_string
if (associated (queue%current_prt%next)) &
queue%current_prt => queue%current_prt%next
else
prt_string = " "
end if
end subroutine prt_queue_get
@ %def prt_queue_get
@ As above.
<<radiation generator: prt queue: TBP>>=
procedure :: get_last => prt_queue_get_last
<<radiation generator: procedures>>=
subroutine prt_queue_get_last (queue, prt_string)
class(prt_queue_t), intent(in) :: queue
type(string_t), dimension(:), allocatable, intent(out) :: prt_string
if (associated (queue%back)) then
allocate (prt_string(size (queue%back%prt_string)))
prt_string = queue%back%prt_string
else
prt_string = " "
end if
end subroutine prt_queue_get_last
@ %def prt_queue_get_last
@
<<radiation generator: prt queue: TBP>>=
procedure :: reset => prt_queue_reset
<<radiation generator: procedures>>=
subroutine prt_queue_reset (queue)
class(prt_queue_t), intent(inout) :: queue
queue%current_prt => queue%front
end subroutine prt_queue_reset
@ %def prt_queue_reset
@
<<radiation generator: prt queue: TBP>>=
procedure :: check_for_same_prt_strings => prt_queue_check_for_same_prt_strings
<<radiation generator: procedures>>=
function prt_queue_check_for_same_prt_strings (queue) result (val)
class(prt_queue_t), intent(inout) :: queue
logical :: val
type(string_t), dimension(:), allocatable :: prt_string
integer, dimension(:,:), allocatable :: i_particle
integer :: n_d, n_dbar, n_u, n_ubar, n_s, n_sbar, n_gl, n_e, n_ep, n_mu, n_mup, n_A
integer :: i, j
call queue%reset ()
allocate (i_particle (queue%n_lists, 12))
do i = 1, queue%n_lists
call queue%get (prt_string)
n_d = count_particle (prt_string, 1)
n_dbar = count_particle (prt_string, -1)
n_u = count_particle (prt_string, 2)
n_ubar = count_particle (prt_string, -2)
n_s = count_particle (prt_string, 3)
n_sbar = count_particle (prt_string, -3)
n_gl = count_particle (prt_string, 21)
n_e = count_particle (prt_string, 11)
n_ep = count_particle (prt_string, -11)
n_mu = count_particle (prt_string, 13)
n_mup = count_particle (prt_string, -13)
n_A = count_particle (prt_string, 22)
i_particle (i, 1) = n_d
i_particle (i, 2) = n_dbar
i_particle (i, 3) = n_u
i_particle (i, 4) = n_ubar
i_particle (i, 5) = n_s
i_particle (i, 6) = n_sbar
i_particle (i, 7) = n_gl
i_particle (i, 8) = n_e
i_particle (i, 9) = n_ep
i_particle (i, 10) = n_mu
i_particle (i, 11) = n_mup
i_particle (i, 12) = n_A
end do
val = .false.
do i = 1, queue%n_lists
do j = 1, queue%n_lists
if (i == j) cycle
val = val .or. all (i_particle (i,:) == i_particle(j,:))
end do
end do
contains
function count_particle (prt_string, pdg) result (n)
type(string_t), dimension(:), intent(in) :: prt_string
integer, intent(in) :: pdg
integer :: n
integer :: i
type(string_t) :: prt_ref
n = 0
select case (pdg)
case (1)
prt_ref = "d"
case (-1)
prt_ref = "dbar"
case (2)
prt_ref = "u"
case (-2)
prt_ref = "ubar"
case (3)
prt_ref = "s"
case (-3)
prt_ref = "sbar"
case (21)
prt_ref = "gl"
case (11)
prt_ref = "e-"
case (-11)
prt_ref = "e+"
case (13)
prt_ref = "mu-"
case (-13)
prt_ref = "mu+"
case (22)
prt_ref = "A"
end select
do i = 1, size (prt_string)
if (prt_string(i) == prt_ref) n = n+1
end do
end function count_particle
end function prt_queue_check_for_same_prt_strings
@ %def prt_queue_check_for_same_prt_strings
@
<<radiation generator: prt queue: TBP>>=
procedure :: contains => prt_queue_contains
<<radiation generator: procedures>>=
function prt_queue_contains (queue, prt_string) result (val)
class(prt_queue_t), intent(in) :: queue
type(string_t), intent(in), dimension(:) :: prt_string
logical :: val
type(prt_queue_t), pointer :: current => null()
if (associated (queue%front)) then
current => queue%front
else
call msg_fatal ("Trying to access empty particle queue")
end if
val = .false.
do
if (size (current%prt_string) == size (prt_string)) then
if (all (current%prt_string == prt_string)) then
val = .true.
exit
end if
end if
if (associated (current%next)) then
current => current%next
else
exit
end if
end do
end function prt_queue_contains
@ %def prt_string_list_contains
@
<<radiation generator: prt queue: TBP>>=
procedure :: write => prt_queue_write
<<radiation generator: procedures>>=
subroutine prt_queue_write (queue, unit)
class(prt_queue_t), intent(in) :: queue
integer, optional :: unit
type(prt_queue_t), pointer :: current => null ()
integer :: i, j, u
u = given_output_unit (unit)
if (associated (queue%front)) then
current => queue%front
else
write (u, "(A)") "[Particle queue is empty]"
return
end if
j = 1
do
write (u, "(I2,A,1X)", advance = 'no') j , ":"
do i = 1, size (current%prt_string)
write (u, "(A,1X)", advance = 'no') char (current%prt_string(i))
end do
write (u, "(A)")
if (associated (current%next)) then
current => current%next
j = j+1
else
exit
end if
end do
end subroutine prt_queue_write
@ %def prt_queue_write
@
<<radiation generator: procedures>>=
subroutine sort_prt (prt, model)
type(string_t), dimension(:), intent(inout) :: prt
class(model_data_t), intent(in), target :: model
type(pdg_array_t), dimension(:), allocatable :: pdg
type(flavor_t) :: flv
integer :: i
call create_pdg_array (prt, model, pdg)
call sort_pdg (pdg)
do i = 1, size (pdg)
call flv%init (pdg(i)%get(), model)
prt(i) = flv%get_name ()
end do
end subroutine sort_prt
subroutine sort_pdg (pdg)
type(pdg_array_t), dimension(:), intent(inout) :: pdg
integer, dimension(:), allocatable :: i_pdg
integer :: i
allocate (i_pdg (size (pdg)))
do i = 1, size (pdg)
i_pdg(i) = pdg(i)%get ()
end do
i_pdg = sort_abs (i_pdg)
do i = 1, size (pdg)
call pdg(i)%set (1, i_pdg(i))
end do
end subroutine sort_pdg
subroutine create_pdg_array (prt, model, pdg)
type (string_t), dimension(:), intent(in) :: prt
class (model_data_t), intent(in), target :: model
type(pdg_array_t), dimension(:), allocatable, intent(out) :: pdg
type(flavor_t) :: flv
integer :: i
allocate (pdg (size (prt)))
do i = 1, size (prt)
call flv%init (prt(i), model)
pdg(i) = flv%get_pdg ()
end do
end subroutine create_pdg_array
@ %def sort_prt sort_pdg create_pdg_array
@ This is used in unit tests:
<<radiation generator: test auxiliary>>=
subroutine write_pdg_array (pdg, u)
use pdg_arrays
type(pdg_array_t), dimension(:), intent(in) :: pdg
integer, intent(in) :: u
integer :: i
do i = 1, size (pdg)
call pdg(i)%write (u)
end do
write (u, "(A)")
end subroutine write_pdg_array
subroutine write_particle_string (prt, u)
<<Use strings>>
type(string_t), dimension(:), intent(in) :: prt
integer, intent(in) :: u
integer :: i
do i = 1, size (prt)
write (u, "(A,1X)", advance = "no") char (prt(i))
end do
write (u, "(A)")
end subroutine write_particle_string
@ %def write_pdg_array write_particle_string
<<radiation generator: types>>=
type :: reshuffle_list_t
integer, dimension(:), allocatable :: ii
type(reshuffle_list_t), pointer :: next => null ()
contains
<<radiation generator: reshuffle list: TBP>>
end type reshuffle_list_t
@ %def reshuffle_list_t
@
<<radiation generator: reshuffle list: TBP>>=
procedure :: write => reshuffle_list_write
<<radiation generator: procedures>>=
subroutine reshuffle_list_write (rlist)
class(reshuffle_list_t), intent(in) :: rlist
type(reshuffle_list_t), pointer :: current => null ()
integer :: i
print *, 'Content of reshuffling list: '
if (associated (rlist%next)) then
current => rlist%next
i = 1
do
print *, 'i: ', i, 'list: ', current%ii
i = i + 1
if (associated (current%next)) then
current => current%next
else
exit
end if
end do
else
print *, '[EMPTY]'
end if
end subroutine reshuffle_list_write
@ %def reshuffle_list_write
@
<<radiation generator: reshuffle list: TBP>>=
procedure :: append => reshuffle_list_append
<<radiation generator: procedures>>=
subroutine reshuffle_list_append (rlist, ii)
class(reshuffle_list_t), intent(inout) :: rlist
integer, dimension(:), allocatable, intent(in) :: ii
type(reshuffle_list_t), pointer :: current
if (associated (rlist%next)) then
current => rlist%next
do
if (associated (current%next)) then
current => current%next
else
allocate (current%next)
allocate (current%next%ii (size (ii)))
current%next%ii = ii
exit
end if
end do
else
allocate (rlist%next)
allocate (rlist%next%ii (size (ii)))
rlist%next%ii = ii
end if
end subroutine reshuffle_list_append
@ %def reshuffle_list_append
@
<<radiation generator: reshuffle list: TBP>>=
procedure :: is_empty => reshuffle_list_is_empty
<<radiation generator: procedures>>=
elemental function reshuffle_list_is_empty (rlist) result (is_empty)
logical :: is_empty
class(reshuffle_list_t), intent(in) :: rlist
is_empty = .not. associated (rlist%next)
end function reshuffle_list_is_empty
@ %def reshuffle_list_is_empty
@
<<radiation generator: reshuffle list: TBP>>=
procedure :: get => reshuffle_list_get
<<radiation generator: procedures>>=
function reshuffle_list_get (rlist, index) result (ii)
integer, dimension(:), allocatable :: ii
class(reshuffle_list_t), intent(inout) :: rlist
integer, intent(in) :: index
type(reshuffle_list_t), pointer :: current => null ()
integer :: i
current => rlist%next
do i = 1, index - 1
if (associated (current%next)) then
current => current%next
else
call msg_fatal ("Index exceeds size of reshuffling list")
end if
end do
allocate (ii (size (current%ii)))
ii = current%ii
end function reshuffle_list_get
@ %def reshuffle_list_get
@ We need to reset the [[reshuffle_list]] in order to deal with
subsequent usages of the [[radiation_generator]]. Below is obviously
the lazy and dirty solution. Otherwise, we would have to equip this
auxiliary type with additional information about [[last]] and [[previous]]
pointers. Considering that at most $n_{\rm{legs}}$ integers are saved
in the lists, and that the subroutine is only called during the
initialization phase (more precisely: at the moment only in the
[[radiation_generator]] unit tests), I think this quick fix is justified.
<<radiation generator: reshuffle list: TBP>>=
procedure :: reset => reshuffle_list_reset
<<radiation generator: procedures>>=
subroutine reshuffle_list_reset (rlist)
class(reshuffle_list_t), intent(inout) :: rlist
rlist%next => null ()
end subroutine reshuffle_list_reset
@ %def reshuffle_list_reset
@
<<radiation generator: public>>=
public :: radiation_generator_t
<<radiation generator: types>>=
type :: radiation_generator_t
logical :: qcd_enabled = .false.
logical :: qed_enabled = .false.
logical :: is_gluon = .false.
logical :: fs_gluon = .false.
logical :: is_photon = .false.
logical :: fs_photon = .false.
logical :: only_final_state = .true.
type(pdg_list_t) :: pl_in, pl_out
type(pdg_list_t) :: pl_excluded_gauge_splittings
type(split_constraints_t) :: constraints
integer :: n_tot
integer :: n_in, n_out
integer :: n_loops
integer :: n_light_quarks
real(default) :: mass_sum
type(prt_queue_t) :: prt_queue
type(pdg_states_t) :: pdg_raw
type(pdg_array_t), dimension(:), allocatable :: pdg_in_born, pdg_out_born
type(if_table_t) :: if_table
type(reshuffle_list_t) :: reshuffle_list
contains
<<radiation generator: radiation generator: TBP>>
end type radiation_generator_t
@
@ %def radiation_generator_t
<<radiation generator: radiation generator: TBP>>=
generic :: init => init_pdg_list, init_pdg_array
procedure :: init_pdg_list => radiation_generator_init_pdg_list
procedure :: init_pdg_array => radiation_generator_init_pdg_array
<<radiation generator: procedures>>=
subroutine radiation_generator_init_pdg_list &
(generator, pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed)
class(radiation_generator_t), intent(inout) :: generator
type(pdg_list_t), intent(in) :: pl_in, pl_out
type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings
logical, intent(in), optional :: qcd, qed
if (present (qcd)) generator%qcd_enabled = qcd
if (present (qed)) generator%qed_enabled = qed
generator%pl_in = pl_in
generator%pl_out = pl_out
generator%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings
generator%is_gluon = pl_in%search_for_particle (GLUON)
generator%fs_gluon = pl_out%search_for_particle (GLUON)
generator%is_photon = pl_in%search_for_particle (PHOTON)
generator%fs_photon = pl_out%search_for_particle (PHOTON)
generator%mass_sum = 0._default
call generator%pdg_raw%init ()
end subroutine radiation_generator_init_pdg_list
subroutine radiation_generator_init_pdg_array &
(generator, pdg_in, pdg_out, pdg_excluded_gauge_splittings, qcd, qed)
class(radiation_generator_t), intent(inout) :: generator
type(pdg_array_t), intent(in), dimension(:) :: pdg_in, pdg_out
type(pdg_array_t), intent(in), dimension(:) :: pdg_excluded_gauge_splittings
logical, intent(in), optional :: qcd, qed
type(pdg_list_t) :: pl_in, pl_out
type(pdg_list_t) :: pl_excluded_gauge_splittings
integer :: i
call pl_in%init(size (pdg_in))
call pl_out%init(size (pdg_out))
do i = 1, size (pdg_in)
call pl_in%set (i, pdg_in(i))
end do
do i = 1, size (pdg_out)
call pl_out%set (i, pdg_out(i))
end do
call pl_excluded_gauge_splittings%init(size (pdg_excluded_gauge_splittings))
do i = 1, size (pdg_excluded_gauge_splittings)
call pl_excluded_gauge_splittings%set &
(i, pdg_excluded_gauge_splittings(i))
end do
call generator%init (pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed)
end subroutine radiation_generator_init_pdg_array
@ %def radiation_generator_init_pdg_list radiation_generator_init_pdg_array
@
<<radiation generator: radiation generator: TBP>>=
procedure :: set_initial_state_emissions => &
radiation_generator_set_initial_state_emissions
<<radiation generator: procedures>>=
subroutine radiation_generator_set_initial_state_emissions (generator)
class(radiation_generator_t), intent(inout) :: generator
generator%only_final_state = .false.
end subroutine radiation_generator_set_initial_state_emissions
@ %def radiation_generator_set_initial_state_emissions
@
<<radiation generator: radiation generator: TBP>>=
procedure :: setup_if_table => radiation_generator_setup_if_table
<<radiation generator: procedures>>=
subroutine radiation_generator_setup_if_table (generator, model)
class(radiation_generator_t), intent(inout) :: generator
class(model_data_t), intent(in), target :: model
type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out
allocate (pl_in(1), pl_out(1))
pl_in(1) = generator%pl_in
pl_out(1) = generator%pl_out
call generator%if_table%init &
(model, pl_in, pl_out, generator%constraints)
end subroutine radiation_generator_setup_if_table
@ %def radiation_generator_setup_if_table
@
<<radiation generator: radiation generator: TBP>>=
generic :: reset_particle_content => reset_particle_content_pdg_array, &
reset_particle_content_pdg_list
procedure :: reset_particle_content_pdg_list => &
radiation_generator_reset_particle_content_pdg_list
procedure :: reset_particle_content_pdg_array => &
radiation_generator_reset_particle_content_pdg_array
<<radiation generator: procedures>>=
subroutine radiation_generator_reset_particle_content_pdg_list (generator, pl)
class(radiation_generator_t), intent(inout) :: generator
type(pdg_list_t), intent(in) :: pl
generator%pl_out = pl
generator%fs_gluon = pl%search_for_particle (GLUON)
generator%fs_photon = pl%search_for_particle (PHOTON)
end subroutine radiation_generator_reset_particle_content_pdg_list
subroutine radiation_generator_reset_particle_content_pdg_array (generator, pdg)
class(radiation_generator_t), intent(inout) :: generator
type(pdg_array_t), intent(in), dimension(:) :: pdg
type(pdg_list_t) :: pl
integer :: i
call pl%init (size (pdg))
do i = 1, size (pdg)
call pl%set (i, pdg(i))
end do
call generator%reset_particle_content (pl)
end subroutine radiation_generator_reset_particle_content_pdg_array
@ %def radiation_generator_reset_particle_content
@
<<radiation generator: radiation generator: TBP>>=
procedure :: reset_reshuffle_list=> radiation_generator_reset_reshuffle_list
<<radiation generator: procedures>>=
subroutine radiation_generator_reset_reshuffle_list (generator)
class(radiation_generator_t), intent(inout) :: generator
call generator%reshuffle_list%reset ()
end subroutine radiation_generator_reset_reshuffle_list
@ %def radiation_generator_reset_reshuffle_list
@
<<radiation generator: radiation generator: TBP>>=
procedure :: set_n => radiation_generator_set_n
<<radiation generator: procedures>>=
subroutine radiation_generator_set_n (generator, n_in, n_out, n_loops)
class(radiation_generator_t), intent(inout) :: generator
integer, intent(in) :: n_in, n_out, n_loops
generator%n_tot = n_in + n_out + 1
generator%n_in = n_in
generator%n_out = n_out
generator%n_loops = n_loops
end subroutine radiation_generator_set_n
@ %def radiation_generator_set_n
@
<<radiation generator: radiation generator: TBP>>=
procedure :: set_constraints => radiation_generator_set_constraints
<<radiation generator: procedures>>=
subroutine radiation_generator_set_constraints &
(generator, set_n_loop, set_mass_sum, &
set_selected_particles, set_required_particles)
class(radiation_generator_t), intent(inout), target :: generator
logical, intent(in) :: set_n_loop
logical, intent(in) :: set_mass_sum
logical, intent(in) :: set_selected_particles
logical, intent(in) :: set_required_particles
logical :: set_no_photon_induced = .true.
integer :: i, j, n, n_constraints
type(pdg_list_t) :: pl_req, pl_insert
type(pdg_list_t) :: pl_antiparticles
type(pdg_array_t) :: pdg_gluon, pdg_photon
type(pdg_array_t) :: pdg_add, pdg_tmp
integer :: last_index
integer :: n_new_particles, n_skip
integer, dimension(:), allocatable :: i_skip
integer :: n_nlo_correction_types
n_nlo_correction_types = count ([generator%qcd_enabled, generator%qed_enabled])
if (generator%is_photon) set_no_photon_induced = .false.
allocate (i_skip (generator%n_tot))
i_skip = -1
n_constraints = 2 + count([set_n_loop, set_mass_sum, &
set_selected_particles, set_required_particles, set_no_photon_induced])
associate (constraints => generator%constraints)
n = 1
call constraints%init (n_constraints)
call constraints%set (n, constrain_n_tot (generator%n_tot))
n = 2
call constraints%set (n, constrain_couplings (generator%qcd_enabled, &
generator%qed_enabled, n_nlo_correction_types))
n = n + 1
if (set_no_photon_induced) then
call constraints%set (n, constrain_photon_induced_processes (generator%n_in))
n = n + 1
end if
if (set_n_loop) then
call constraints%set (n, constrain_n_loop(generator%n_loops))
n = n + 1
end if
if (set_mass_sum) then
call constraints%set (n, constrain_mass_sum(generator%mass_sum))
n = n + 1
end if
if (set_required_particles) then
if (generator%fs_gluon .or. generator%fs_photon) then
do i = 1, generator%n_out
pdg_tmp = generator%pl_out%get(i)
if (pdg_tmp%search_for_particle (GLUON) &
.or. pdg_tmp%search_for_particle (PHOTON)) then
i_skip(i) = i
end if
end do
n_skip = count (i_skip > 0)
call pl_req%init (generator%n_out-n_skip)
else
call pl_req%init (generator%n_out)
end if
j = 1
do i = 1, generator%n_out
if (any (i == i_skip)) cycle
call pl_req%set (j, generator%pl_out%get(i))
j = j + 1
end do
call constraints%set (n, constrain_require (pl_req))
n = n + 1
end if
if (set_selected_particles) then
if (generator%only_final_state ) then
call pl_insert%init (generator%n_out + n_nlo_correction_types)
do i = 1, generator%n_out
call pl_insert%set(i, generator%pl_out%get(i))
end do
last_index = generator%n_out + 1
else
call generator%pl_in%create_antiparticles (pl_antiparticles, n_new_particles)
call pl_insert%init (generator%n_tot + n_new_particles &
+ n_nlo_correction_types)
do i = 1, generator%n_in
call pl_insert%set(i, generator%pl_in%get(i))
end do
do i = 1, generator%n_out
j = i + generator%n_in
call pl_insert%set(j, generator%pl_out%get(i))
end do
do i = 1, n_new_particles
j = i + generator%n_in + generator%n_out
call pl_insert%set(j, pl_antiparticles%get(i))
end do
last_index = generator%n_tot + n_new_particles + 1
end if
pdg_gluon = GLUON; pdg_photon = PHOTON
if (generator%qcd_enabled) then
pdg_add = pdg_gluon
call pl_insert%set (last_index, pdg_add)
last_index = last_index + 1
end if
if (generator%qed_enabled) then
pdg_add = pdg_photon
call pl_insert%set (last_index, pdg_add)
end if
call constraints%set (n, constrain_splittings (pl_insert, &
generator%pl_excluded_gauge_splittings))
end if
end associate
end subroutine radiation_generator_set_constraints
@ %def radiation_generator_set_constraints
@
<<radiation generator: radiation generator: TBP>>=
procedure :: find_splittings => radiation_generator_find_splittings
<<radiation generator: procedures>>=
subroutine radiation_generator_find_splittings (generator)
class(radiation_generator_t), intent(inout) :: generator
integer :: i
type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out, pdg_tmp
integer, dimension(:), allocatable :: reshuffle_list
call generator%pl_in%create_pdg_array (pdg_in)
call generator%pl_out%create_pdg_array (pdg_out)
associate (if_table => generator%if_table)
call if_table%radiate (generator%constraints, do_not_check_regular = .true.)
do i = 1, if_table%get_length ()
call if_table%get_pdg_out (i, pdg_tmp)
if (size (pdg_tmp) == generator%n_tot) then
call pdg_reshuffle (pdg_out, pdg_tmp, reshuffle_list)
call generator%reshuffle_list%append (reshuffle_list)
end if
end do
end associate
contains
subroutine pdg_reshuffle (pdg_born, pdg_real, list)
type(pdg_array_t), intent(in), dimension(:) :: pdg_born, pdg_real
integer, intent(out), dimension(:), allocatable :: list
type(pdg_sorter_t), dimension(:), allocatable :: sort_born
type(pdg_sorter_t), dimension(:), allocatable :: sort_real
integer :: i_min, n_in, n_born, n_real
integer :: ib, ir
n_in = generator%n_in
n_born = size (pdg_born)
n_real = size (pdg_real)
allocate (list (n_real - n_in))
allocate (sort_born (n_born))
allocate (sort_real (n_real - n_in))
sort_born%pdg = pdg_born%get ()
sort_real%pdg = pdg_real(n_in + 1 : n_real)%get()
do ib = 1, n_born
if (any (sort_born(ib)%pdg == sort_real%pdg)) &
call associate_born_indices (sort_born(ib), sort_real, ib, n_real)
end do
i_min = maxval (sort_real%associated_born) + 1
do ir = 1, n_real - n_in
if (sort_real(ir)%associated_born == 0) then
sort_real(ir)%associated_born = i_min
i_min = i_min + 1
end if
end do
list = sort_real%associated_born
end subroutine pdg_reshuffle
subroutine associate_born_indices (sort_born, sort_real, ib, n_real)
type(pdg_sorter_t), intent(in) :: sort_born
type(pdg_sorter_t), intent(inout), dimension(:) :: sort_real
integer, intent(in) :: ib, n_real
integer :: ir
do ir = 1, n_real - generator%n_in
if (sort_born%pdg == sort_real(ir)%pdg &
.and..not. sort_real(ir)%checked) then
sort_real(ir)%associated_born = ib
sort_real(ir)%checked = .true.
exit
end if
end do
end subroutine associate_born_indices
end subroutine radiation_generator_find_splittings
@ %def radiation_generator_find_splittings
@
<<radiation generator: radiation generator: TBP>>=
procedure :: generate_real_particle_strings &
=> radiation_generator_generate_real_particle_strings
<<radiation generator: procedures>>=
subroutine radiation_generator_generate_real_particle_strings &
(generator, prt_tot_in, prt_tot_out)
type :: prt_array_t
type(string_t), dimension(:), allocatable :: prt
end type
class(radiation_generator_t), intent(inout) :: generator
type(string_t), intent(out), dimension(:), allocatable :: prt_tot_in, prt_tot_out
type(prt_array_t), dimension(:), allocatable :: prt_in, prt_out
type(prt_array_t), dimension(:), allocatable :: prt_out0, prt_in0
type(pdg_array_t), dimension(:), allocatable :: pdg_tmp, pdg_out, pdg_in
type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out
type(prt_array_t) :: prt_out0_tmp, prt_in0_tmp
integer :: i, j
integer, dimension(:), allocatable :: reshuffle_list_local
type(reshuffle_list_t) :: reshuffle_list
integer :: flv
type(string_t), dimension(:), allocatable :: buf
integer :: i_buf
flv = 0
allocate (prt_in0(0), prt_out0(0))
associate (if_table => generator%if_table)
do i = 1, if_table%get_length ()
call if_table%get_pdg_out (i, pdg_tmp)
if (size (pdg_tmp) == generator%n_tot) then
call if_table%get_particle_string (i, &
prt_in0_tmp%prt, prt_out0_tmp%prt)
prt_in0 = [prt_in0, prt_in0_tmp]
prt_out0 = [prt_out0, prt_out0_tmp]
flv = flv + 1
end if
end do
end associate
allocate (prt_in(size (prt_in0)), prt_out(size (prt_out0)))
do i = 1, flv
allocate (prt_in(i)%prt (generator%n_in))
allocate (prt_out(i)%prt (generator%n_tot - generator%n_in))
end do
allocate (prt_tot_in (generator%n_in))
allocate (prt_tot_out (generator%n_tot - generator%n_in))
allocate (buf (generator%n_tot))
buf = ""
do j = 1, flv
do i = 1, generator%n_in
prt_in(j)%prt(i) = prt_in0(j)%prt(i)
call fill_buffer (buf(i), prt_in0(j)%prt(i))
end do
end do
prt_tot_in = buf(1 : generator%n_in)
do j = 1, flv
allocate (reshuffle_list_local (size (generator%reshuffle_list%get(j))))
reshuffle_list_local = generator%reshuffle_list%get(j)
do i = 1, size (reshuffle_list_local)
prt_out(j)%prt(reshuffle_list_local(i)) = prt_out0(j)%prt(i)
i_buf = reshuffle_list_local(i) + generator%n_in
call fill_buffer (buf(i_buf), &
prt_out(j)%prt(reshuffle_list_local(i)))
end do
!!! Need to deallocate here because in the next iteration the reshuffling
!!! list can have a different size
deallocate (reshuffle_list_local)
end do
prt_tot_out = buf(generator%n_in + 1 : generator%n_tot)
if (debug2_active (D_CORE)) then
print *, 'Generated initial state: '
do i = 1, size (prt_tot_in)
print *, char (prt_tot_in(i))
end do
print *, 'Generated final state: '
do i = 1, size (prt_tot_out)
print *, char (prt_tot_out(i))
end do
end if
contains
subroutine fill_buffer (buffer, particle)
type(string_t), intent(inout) :: buffer
type(string_t), intent(in) :: particle
logical :: particle_present
if (len (buffer) > 0) then
particle_present = check_for_substring (char(buffer), particle)
if (.not. particle_present) buffer = buffer // ":" // particle
else
buffer = buffer // particle
end if
end subroutine fill_buffer
function check_for_substring (buffer, substring) result (exist)
character(len=*), intent(in) :: buffer
type(string_t), intent(in) :: substring
character(len=50) :: buffer_internal
logical :: exist
integer :: i_first, i_last
exist = .false.
i_first = 1; i_last = 1
do
if (buffer(i_last:i_last) == ":") then
buffer_internal = buffer (i_first : i_last - 1)
if (buffer_internal == char (substring)) then
exist = .true.
exit
end if
i_first = i_last + 1; i_last = i_first + 1
if (i_last > len(buffer)) exit
else if (i_last == len(buffer)) then
buffer_internal = buffer (i_first : i_last)
exist = buffer_internal == char (substring)
exit
else
i_last = i_last + 1
if (i_last > len(buffer)) exit
end if
end do
end function check_for_substring
end subroutine radiation_generator_generate_real_particle_strings
@ %def radiation_generator_generate_real_particle_strings
@
<<radiation generator: radiation generator: TBP>>=
procedure :: contains_emissions => radiation_generator_contains_emissions
<<radiation generator: procedures>>=
function radiation_generator_contains_emissions (generator) result (has_em)
logical :: has_em
class(radiation_generator_t), intent(in) :: generator
has_em = .not. generator%reshuffle_list%is_empty ()
end function radiation_generator_contains_emissions
@ %def radiation_generator_contains_emissions
@
<<radiation generator: radiation generator: TBP>>=
procedure :: generate => radiation_generator_generate
<<radiation generator: procedures>>=
subroutine radiation_generator_generate (generator, prt_in, prt_out)
class(radiation_generator_t), intent(inout) :: generator
type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out
call generator%find_splittings ()
call generator%generate_real_particle_strings (prt_in, prt_out)
end subroutine radiation_generator_generate
@ %def radiation_generator_generate
@
<<radiation generator: radiation generator: TBP>>=
procedure :: generate_multiple => radiation_generator_generate_multiple
<<radiation generator: procedures>>=
subroutine radiation_generator_generate_multiple (generator, max_multiplicity, model)
class(radiation_generator_t), intent(inout) :: generator
integer, intent(in) :: max_multiplicity
class(model_data_t), intent(in), target :: model
if (max_multiplicity <= generator%n_out) &
call msg_fatal ("GKS states: Multiplicity is not large enough!")
call generator%first_emission (model)
call generator%reset_reshuffle_list ()
if (max_multiplicity - generator%n_out > 1) &
call generator%append_emissions (max_multiplicity, model)
end subroutine radiation_generator_generate_multiple
@ %def radiation_generator_generate_multiple
@
<<radiation generator: radiation generator: TBP>>=
procedure :: first_emission => radiation_generator_first_emission
<<radiation generator: procedures>>=
subroutine radiation_generator_first_emission (generator, model)
class(radiation_generator_t), intent(inout) :: generator
class(model_data_t), intent(in), target :: model
type(string_t), dimension(:), allocatable :: prt_in, prt_out
call generator%setup_if_table (model)
call generator%generate (prt_in, prt_out)
call generator%prt_queue%null ()
call generator%prt_queue%append (prt_out)
end subroutine radiation_generator_first_emission
@ %def radiation_generator_first_emission
@
<<radiation generator: radiation generator: TBP>>=
procedure :: append_emissions => radiation_generator_append_emissions
<<radiation generator: procedures>>=
subroutine radiation_generator_append_emissions (generator, max_multiplicity, model)
class(radiation_generator_t), intent(inout) :: generator
integer, intent(in) :: max_multiplicity
class(model_data_t), intent(in), target :: model
type(string_t), dimension(:), allocatable :: prt_fetched
type(string_t), dimension(:), allocatable :: prt_in
type(string_t), dimension(:), allocatable :: prt_out
type(pdg_array_t), dimension(:), allocatable :: pdg_new_out
integer :: current_multiplicity, i, j, n_longest_length
type :: prt_table_t
type(string_t), dimension(:), allocatable :: prt
end type prt_table_t
type(prt_table_t), dimension(:), allocatable :: prt_table_out
do
call generator%prt_queue%get (prt_fetched)
current_multiplicity = size (prt_fetched)
if (current_multiplicity == max_multiplicity) exit
call create_pdg_array (prt_fetched, model, &
pdg_new_out)
call generator%reset_particle_content (pdg_new_out)
call generator%set_n (2, current_multiplicity, 0)
call generator%set_constraints (.false., .false., .true., .true.)
call generator%setup_if_table (model)
call generator%generate (prt_in, prt_out)
n_longest_length = get_length_of_longest_tuple (prt_out)
call separate_particles (prt_out, prt_table_out)
do i = 1, n_longest_length
if (.not. any (prt_table_out(i)%prt == " ")) then
call sort_prt (prt_table_out(i)%prt, model)
if (.not. generator%prt_queue%contains (prt_table_out(i)%prt)) then
call generator%prt_queue%append (prt_table_out(i)%prt)
end if
end if
end do
call generator%reset_reshuffle_list ()
end do
contains
subroutine separate_particles (prt, prt_table)
type(string_t), intent(in), dimension(:) :: prt
type(string_t), dimension(:), allocatable :: prt_tmp
type(prt_table_t), intent(out), dimension(:), allocatable :: prt_table
integer :: i, j
logical, dimension(:), allocatable :: tuples_occured
allocate (prt_table (n_longest_length))
do i = 1, n_longest_length
allocate (prt_table(i)%prt (size (prt)))
end do
allocate (tuples_occured (size (prt)))
do j = 1, size (prt)
call split_string (prt(j), var_str (":"), prt_tmp)
do i = 1, n_longest_length
if (i <= size (prt_tmp)) then
prt_table(i)%prt(j) = prt_tmp(i)
else
prt_table(i)%prt(j) = " "
end if
end do
if (n_longest_length > 1) &
tuples_occured(j) = prt_table(1)%prt(j) /= " " &
.and. prt_table(2)%prt(j) /= " "
end do
if (any (tuples_occured)) then
do j = 1, size (tuples_occured)
if (.not. tuples_occured(j)) then
do i = 2, n_longest_length
prt_table(i)%prt(j) = prt_table(1)%prt(j)
end do
end if
end do
end if
end subroutine separate_particles
function get_length_of_longest_tuple (prt) result (longest_length)
type(string_t), intent(in), dimension(:) :: prt
integer :: longest_length, i
type(prt_table_t), dimension(:), allocatable :: prt_table
allocate (prt_table (size (prt)))
longest_length = 0
do i = 1, size (prt)
call split_string (prt(i), var_str (":"), prt_table(i)%prt)
if (size (prt_table(i)%prt) > longest_length) &
longest_length = size (prt_table(i)%prt)
end do
end function get_length_of_longest_tuple
end subroutine radiation_generator_append_emissions
@ %def radiation_generator_append_emissions
@
<<radiation generator: radiation generator: TBP>>=
procedure :: reset_queue => radiation_generator_reset_queue
<<radiation generator: procedures>>=
subroutine radiation_generator_reset_queue (generator)
class(radiation_generator_t), intent(inout) :: generator
call generator%prt_queue%reset ()
end subroutine radiation_generator_reset_queue
@ %def radiation_generator_reset_queue
@
<<radiation generator: radiation generator: TBP>>=
procedure :: get_n_gks_states => radiation_generator_get_n_gks_states
<<radiation generator: procedures>>=
function radiation_generator_get_n_gks_states (generator) result (n)
class(radiation_generator_t), intent(in) :: generator
integer :: n
n = generator%prt_queue%n_lists
end function radiation_generator_get_n_gks_states
@ %def radiation_generator_get_n_fks_states
@
<<radiation generator: radiation generator: TBP>>=
procedure :: get_next_state => radiation_generator_get_next_state
<<radiation generator: procedures>>=
function radiation_generator_get_next_state (generator) result (prt_string)
class(radiation_generator_t), intent(inout) :: generator
type(string_t), dimension(:), allocatable :: prt_string
call generator%prt_queue%get (prt_string)
end function radiation_generator_get_next_state
@ %def radiation_generator_get_next_state
@
<<radiation generator: radiation generator: TBP>>=
procedure :: get_emitter_indices => radiation_generator_get_emitter_indices
<<radiation generator: procedures>>=
subroutine radiation_generator_get_emitter_indices (generator, indices)
class(radiation_generator_t), intent(in) :: generator
integer, dimension(:), allocatable, intent(out) :: indices
type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
integer, dimension(:), allocatable :: flv_in, flv_out
integer, dimension(:), allocatable :: emitters
integer :: i, j
integer :: n_in, n_out
call generator%pl_in%create_pdg_array (pdg_in)
call generator%pl_out%create_pdg_array (pdg_out)
n_in = size (pdg_in); n_out = size (pdg_out)
allocate (flv_in (n_in), flv_out (n_out))
forall (i=1:n_in) flv_in(i) = pdg_in(i)%get()
forall (i=1:n_out) flv_out(i) = pdg_out(i)%get()
call generator%if_table%get_emitters (generator%constraints, emitters)
allocate (indices (size (emitters)))
j = 1
do i = 1, n_in + n_out
if (i <= n_in) then
if (any (flv_in(i) == emitters)) then
indices (j) = i
j = j + 1
end if
else
if (any (flv_out(i-n_in) == emitters)) then
indices (j) = i
j = j + 1
end if
end if
end do
end subroutine radiation_generator_get_emitter_indices
@ %def radiation_generator_get_emitter_indices
@
<<radiation generator: radiation generator: TBP>>=
procedure :: get_raw_states => radiation_generator_get_raw_states
<<radiation generator: procedures>>=
function radiation_generator_get_raw_states (generator) result (raw_states)
class(radiation_generator_t), intent(in), target :: generator
integer, dimension(:,:), allocatable :: raw_states
type(pdg_states_t), pointer :: state
integer :: n_states, n_particles
integer :: i_state
integer :: j
state => generator%pdg_raw
n_states = generator%pdg_raw%get_n_states ()
n_particles = size (generator%pdg_raw%pdg)
allocate (raw_states (n_particles, n_states))
do i_state = 1, n_states
do j = 1, n_particles
raw_states (j, i_state) = state%pdg(j)%get ()
end do
state => state%next
end do
end function radiation_generator_get_raw_states
@ %def radiation_generator_get_raw_states
@
<<radiation generator: radiation generator: TBP>>=
procedure :: save_born_raw => radiation_generator_save_born_raw
<<radiation generator: procedures>>=
subroutine radiation_generator_save_born_raw (generator, pdg_in, pdg_out)
class(radiation_generator_t), intent(inout) :: generator
type(pdg_array_t), dimension(:), allocatable, intent(in) :: pdg_in, pdg_out
generator%pdg_in_born = pdg_in
generator%pdg_out_born = pdg_out
end subroutine radiation_generator_save_born_raw
@ %def radiation_generator_save_born_raw
@
<<radiation generator: radiation generator: TBP>>=
procedure :: get_born_raw => radiation_generator_get_born_raw
<<radiation generator: procedures>>=
function radiation_generator_get_born_raw (generator) result (flv_born)
class(radiation_generator_t), intent(in) :: generator
integer, dimension(:,:), allocatable :: flv_born
integer :: i_part, n_particles
n_particles = size (generator%pdg_in_born) + size (generator%pdg_out_born)
allocate (flv_born (n_particles, 1))
flv_born(1,1) = generator%pdg_in_born(1)%get ()
flv_born(2,1) = generator%pdg_in_born(2)%get ()
do i_part = 3, n_particles
flv_born(i_part, 1) = generator%pdg_out_born(i_part-2)%get ()
end do
end function radiation_generator_get_born_raw
@ %def radiation_generator_get_born_raw
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[radiation_generator_ut.f90]]>>=
<<File header>>
module radiation_generator_ut
use unit_tests
use radiation_generator_uti
<<Standard module head>>
<<radiation generator: public test>>
contains
<<radiation generator: test driver>>
end module radiation_generator_ut
@ %def radiation_generator_ut
@
<<[[radiation_generator_uti.f90]]>>=
<<File header>>
module radiation_generator_uti
<<Use strings>>
use format_utils, only: write_separator
use os_interface
use pdg_arrays
use models
use kinds, only: default
use radiation_generator
<<Standard module head>>
<<radiation generator: test declarations>>
contains
<<radiation generator: tests>>
<<radiation generator: test auxiliary>>
end module radiation_generator_uti
@ %def radiation_generator_ut
@ API: driver for the unit tests below.
<<radiation generator: public test>>=
public :: radiation_generator_test
<<radiation generator: test driver>>=
subroutine radiation_generator_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
call test(radiation_generator_1, "radiation_generator_1", &
"Test the generator of N+1-particle flavor structures in QCD", &
u, results)
call test(radiation_generator_2, "radiation_generator_2", &
"Test multiple splittings in QCD", &
u, results)
call test(radiation_generator_3, "radiation_generator_3", &
"Test the generator of N+1-particle flavor structures in QED", &
u, results)
call test(radiation_generator_4, "radiation_generator_4", &
"Test multiple splittings in QED", &
u, results)
end subroutine radiation_generator_test
@ %def radiation_generator_test
@
<<radiation generator: test declarations>>=
public :: radiation_generator_1
<<radiation generator: tests>>=
subroutine radiation_generator_1 (u)
integer, intent(in) :: u
type(radiation_generator_t) :: generator
type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model => null ()
write (u, "(A)") "* Test output: radiation_generator_1"
write (u, "(A)") "* Purpose: Create N+1-particle flavor structures &
&from predefined N-particle flavor structures"
write (u, "(A)") "* One additional strong coupling, no additional electroweak coupling"
write (u, "(A)")
write (u, "(A)") "* Loading radiation model: SM.mdl"
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model &
(var_str ("SM"), var_str ("SM.mdl"), &
os_data, model)
write (u, "(A)") "* Success"
allocate (pdg_in (2))
pdg_in(1) = 11; pdg_in(2) = -11
write (u, "(A)") "* Start checking processes"
call write_separator (u)
write (u, "(A)") "* Process 1: Top pair-production with additional gluon"
allocate (pdg_out(3))
pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = 21
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 2: Top pair-production with additional jet"
allocate (pdg_out(3))
pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = [-1,1,-2,2,-3,3,-4,4,-5,5,21]
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 3: Quark-antiquark production"
allocate (pdg_out(2))
pdg_out(1) = 2; pdg_out(2) = -2
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 4: Quark-antiquark production with additional gluon"
allocate (pdg_out(3))
pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 21
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 5: Z + jets"
allocate (pdg_out(3))
pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 6: Top Decay"
allocate (pdg_out(4))
pdg_out(1) = 24; pdg_out(2) = -24
pdg_out(3) = 5; pdg_out(4) = -5
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 7: Production of four quarks"
allocate (pdg_out(4))
pdg_out(1) = 2; pdg_out(2) = -2;
pdg_out(3) = 2; pdg_out(4) = -2
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out); deallocate (pdg_in)
write (u, "(A)") "* Process 8: Drell-Yan lepto-production"
allocate (pdg_in (2)); allocate (pdg_out (2))
pdg_in(1) = 2; pdg_in(2) = -2
pdg_out(1) = 11; pdg_out(2) = -11
call test_process (generator, pdg_in, pdg_out, u, .true.)
deallocate (pdg_out); deallocate (pdg_in)
write (u, "(A)") "* Process 9: WZ production at hadron-colliders"
allocate (pdg_in (2)); allocate (pdg_out (2))
pdg_in(1) = 1; pdg_in(2) = -2
pdg_out(1) = -24; pdg_out(2) = 23
call test_process (generator, pdg_in, pdg_out, u, .true.)
deallocate (pdg_out); deallocate (pdg_in)
contains
subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state)
type(radiation_generator_t), intent(inout) :: generator
type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out
integer, intent(in) :: u
logical, intent(in), optional :: include_initial_state
type(string_t), dimension(:), allocatable :: prt_strings_in
type(string_t), dimension(:), allocatable :: prt_strings_out
type(pdg_array_t), dimension(10) :: pdg_excluded
logical :: yorn
yorn = .false.
pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]
if (present (include_initial_state)) yorn = include_initial_state
write (u, "(A)") "* Leading order: "
write (u, "(A)", advance = 'no') '* Incoming: '
call write_pdg_array (pdg_in, u)
write (u, "(A)", advance = 'no') '* Outgoing: '
call write_pdg_array (pdg_out, u)
call generator%init (pdg_in, pdg_out, &
pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.)
call generator%set_n (2, size(pdg_out), 0)
if (yorn) call generator%set_initial_state_emissions ()
call generator%set_constraints (.false., .false., .true., .true.)
call generator%setup_if_table (model)
call generator%generate (prt_strings_in, prt_strings_out)
write (u, "(A)") "* Additional radiation: "
write (u, "(A)") "* Incoming: "
call write_particle_string (prt_strings_in, u)
write (u, "(A)") "* Outgoing: "
call write_particle_string (prt_strings_out, u)
call write_separator(u)
call generator%reset_reshuffle_list ()
end subroutine test_process
end subroutine radiation_generator_1
@ %def radiation_generator_1
@
<<radiation generator: test declarations>>=
public :: radiation_generator_2
<<radiation generator: tests>>=
subroutine radiation_generator_2 (u)
integer, intent(in) :: u
type(radiation_generator_t) :: generator
type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
type(pdg_array_t), dimension(:), allocatable :: pdg_excluded
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model => null ()
integer, parameter :: max_multiplicity = 10
type(string_t), dimension(:), allocatable :: prt_last
write (u, "(A)") "* Test output: radiation_generator_2"
write (u, "(A)") "* Purpose: Test the repeated application of &
&a radiation generator splitting in QCD"
write (u, "(A)") "* Only Final state emissions! "
write (u, "(A)")
write (u, "(A)") "* Loading radiation model: SM.mdl"
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model &
(var_str ("SM"), var_str ("SM.mdl"), &
os_data, model)
write (u, "(A)") "* Success"
allocate (pdg_in (2))
pdg_in(1) = 11; pdg_in(2) = -11
allocate (pdg_out(2))
pdg_out(1) = 2; pdg_out(2) = -2
allocate (pdg_excluded (10))
pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]
write (u, "(A)") "* Leading order"
write (u, "(A)", advance = 'no') "* Incoming: "
call write_pdg_array (pdg_in, u)
write (u, "(A)", advance = 'no') "* Outgoing: "
call write_pdg_array (pdg_out, u)
call generator%init (pdg_in, pdg_out, &
pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.)
call generator%set_n (2, 2, 0)
call generator%set_constraints (.false., .false., .true., .true.)
call write_separator (u)
write (u, "(A)") "Generate higher-multiplicity states"
write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity
call generator%generate_multiple (max_multiplicity, model)
call generator%prt_queue%write (u)
call write_separator (u)
write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists
write (u, "(A)") "Check that no particle state occurs twice or more"
if (.not. generator%prt_queue%check_for_same_prt_strings()) then
write (u, "(A)") "SUCCESS"
else
write (u, "(A)") "FAIL"
end if
call write_separator (u)
write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:"
call generator%prt_queue%get_last (prt_last)
if (size (prt_last) == max_multiplicity) then
write (u, "(A)") "SUCCESS"
else
write (u, "(A)") "FAIL"
end if
end subroutine radiation_generator_2
@ %def radiation_generator_2
@
<<radiation generator: test declarations>>=
public :: radiation_generator_3
<<radiation generator: tests>>=
subroutine radiation_generator_3 (u)
integer, intent(in) :: u
type(radiation_generator_t) :: generator
type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model => null ()
write (u, "(A)") "* Test output: radiation_generator_3"
write (u, "(A)") "* Purpose: Create N+1-particle flavor structures &
&from predefined N-particle flavor structures"
write (u, "(A)") "* One additional electroweak coupling, no additional strong coupling"
write (u, "(A)")
write (u, "(A)") "* Loading radiation model: SM.mdl"
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model &
(var_str ("SM"), var_str ("SM.mdl"), &
os_data, model)
write (u, "(A)") "* Success"
allocate (pdg_in (2))
pdg_in(1) = 11; pdg_in(2) = -11
write (u, "(A)") "* Start checking processes"
call write_separator (u)
write (u, "(A)") "* Process 1: Tau pair-production with additional photon"
allocate (pdg_out(3))
pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = 22
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 2: Tau pair-production with additional leptons or photon"
allocate (pdg_out(3))
pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = [-13, 13, 22]
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 3: Electron-positron production"
allocate (pdg_out(2))
pdg_out(1) = 11; pdg_out(2) = -11
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 4: Quark-antiquark production with additional photon"
allocate (pdg_out(3))
pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 22
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 5: Z + jets "
allocate (pdg_out(3))
pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 6: W + jets"
allocate (pdg_out(3))
pdg_out(1) = 1; pdg_out(2) = -2; pdg_out(3) = -24
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 7: Top Decay"
allocate (pdg_out(4))
pdg_out(1) = 24; pdg_out(2) = -24
pdg_out(3) = 5; pdg_out(4) = -5
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 8: Production of four quarks"
allocate (pdg_out(4))
pdg_out(1) = 2; pdg_out(2) = -2;
pdg_out(3) = 2; pdg_out(4) = -2
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out)
write (u, "(A)") "* Process 9: Neutrino pair-production"
allocate (pdg_out(2))
pdg_out(1) = 12; pdg_out(2) = -12
call test_process (generator, pdg_in, pdg_out, u, .true.)
deallocate (pdg_out); deallocate (pdg_in)
write (u, "(A)") "* Process 10: Drell-Yan lepto-production"
allocate (pdg_in (2)); allocate (pdg_out (2))
pdg_in(1) = 2; pdg_in(2) = -2
pdg_out(1) = 11; pdg_out(2) = -11
call test_process (generator, pdg_in, pdg_out, u, .true.)
deallocate (pdg_out); deallocate (pdg_in)
write (u, "(A)") "* Process 11: WZ production at hadron-colliders"
allocate (pdg_in (2)); allocate (pdg_out (2))
pdg_in(1) = 1; pdg_in(2) = -2
pdg_out(1) = -24; pdg_out(2) = 23
call test_process (generator, pdg_in, pdg_out, u, .true.)
deallocate (pdg_out); deallocate (pdg_in)
write (u, "(A)") "* Process 12: Positron-neutrino production"
allocate (pdg_in (2)); allocate (pdg_out (2))
pdg_in(1) = -1; pdg_in(2) = 2
pdg_out(1) = -11; pdg_out(2) = 12
call test_process (generator, pdg_in, pdg_out, u)
deallocate (pdg_out); deallocate (pdg_in)
contains
subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state)
type(radiation_generator_t), intent(inout) :: generator
type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out
integer, intent(in) :: u
logical, intent(in), optional :: include_initial_state
type(string_t), dimension(:), allocatable :: prt_strings_in
type(string_t), dimension(:), allocatable :: prt_strings_out
type(pdg_array_t), dimension(10) :: pdg_excluded
logical :: yorn
yorn = .false.
pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15]
if (present (include_initial_state)) yorn = include_initial_state
write (u, "(A)") "* Leading order: "
write (u, "(A)", advance = 'no') '* Incoming: '
call write_pdg_array (pdg_in, u)
write (u, "(A)", advance = 'no') '* Outgoing: '
call write_pdg_array (pdg_out, u)
call generator%init (pdg_in, pdg_out, &
pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.)
call generator%set_n (2, size(pdg_out), 0)
if (yorn) call generator%set_initial_state_emissions ()
call generator%set_constraints (.false., .false., .true., .true.)
call generator%setup_if_table (model)
call generator%generate (prt_strings_in, prt_strings_out)
write (u, "(A)") "* Additional radiation: "
write (u, "(A)") "* Incoming: "
call write_particle_string (prt_strings_in, u)
write (u, "(A)") "* Outgoing: "
call write_particle_string (prt_strings_out, u)
call write_separator(u)
call generator%reset_reshuffle_list ()
end subroutine test_process
end subroutine radiation_generator_3
@ %def radiation_generator_3
@
<<radiation generator: test declarations>>=
public :: radiation_generator_4
<<radiation generator: tests>>=
subroutine radiation_generator_4 (u)
integer, intent(in) :: u
type(radiation_generator_t) :: generator
type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out
type(pdg_array_t), dimension(:), allocatable :: pdg_excluded
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model => null ()
integer, parameter :: max_multiplicity = 10
type(string_t), dimension(:), allocatable :: prt_last
write (u, "(A)") "* Test output: radiation_generator_4"
write (u, "(A)") "* Purpose: Test the repeated application of &
&a radiation generator splitting in QED"
write (u, "(A)") "* Only Final state emissions! "
write (u, "(A)")
write (u, "(A)") "* Loading radiation model: SM.mdl"
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model &
(var_str ("SM"), var_str ("SM.mdl"), &
os_data, model)
write (u, "(A)") "* Success"
allocate (pdg_in (2))
pdg_in(1) = 2; pdg_in(2) = -2
allocate (pdg_out(2))
pdg_out(1) = 11; pdg_out(2) = -11
allocate ( pdg_excluded (14))
pdg_excluded = [1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, -6, 15, -15]
write (u, "(A)") "* Leading order"
write (u, "(A)", advance = 'no') "* Incoming: "
call write_pdg_array (pdg_in, u)
write (u, "(A)", advance = 'no') "* Outgoing: "
call write_pdg_array (pdg_out, u)
call generator%init (pdg_in, pdg_out, &
pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.)
call generator%set_n (2, 2, 0)
call generator%set_constraints (.false., .false., .true., .true.)
call write_separator (u)
write (u, "(A)") "Generate higher-multiplicity states"
write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity
call generator%generate_multiple (max_multiplicity, model)
call generator%prt_queue%write (u)
call write_separator (u)
write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists
write (u, "(A)") "Check that no particle state occurs twice or more"
if (.not. generator%prt_queue%check_for_same_prt_strings()) then
write (u, "(A)") "SUCCESS"
else
write (u, "(A)") "FAIL"
end if
call write_separator (u)
write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:"
call generator%prt_queue%get_last (prt_last)
if (size (prt_last) == max_multiplicity) then
write (u, "(A)") "SUCCESS"
else
write (u, "(A)") "FAIL"
end if
end subroutine radiation_generator_4
@ %def radiation_generator_4
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Sindarin Expression Implementation}
This module defines expressions of all kinds, represented in
a tree structure, for repeated evaluation. This provides an
implementation of the [[expr_base]] abstract type.
We have two flavors of expressions: one with particles and one without
particles. The latter version is used for defining cut/selection
criteria and for online analysis.
<<[[eval_trees.f90]]>>=
<<File header>>
module eval_trees
use, intrinsic :: iso_c_binding !NODEP!
<<Use kinds>>
<<Use strings>>
use io_units
use constants, only: DEGREE, IMAGO, PI
use format_defs, only: FMT_19
use numeric_utils, only: nearly_equal
use diagnostics
use lorentz
use md5
use formats
use sorting
use ifiles
use lexers
use syntax_rules
use parser
use analysis
use jets
use pdg_arrays
use subevents
use var_base
use expr_base
use variables
use observables
<<Standard module head>>
<<Eval trees: public>>
<<Eval trees: types>>
<<Eval trees: interfaces>>
<<Eval trees: variables>>
contains
<<Eval trees: procedures>>
end module eval_trees
@ %def eval_trees
@
\subsection{Tree nodes}
The evaluation tree consists of branch nodes (unary and binary) and of
leaf nodes, originating from a common root. The node object should be
polymorphic. For the time being, polymorphism is emulated here. This
means that we have to maintain all possibilities that the node may
hold, including associated procedures as pointers.
The following parameter values characterize the node. Unary and
binary operators have sub-nodes. The other are leaf nodes. Possible
leafs are literal constants or named-parameter references.
<<Eval trees: types>>=
integer, parameter :: EN_UNKNOWN = 0, EN_UNARY = 1, EN_BINARY = 2
integer, parameter :: EN_CONSTANT = 3, EN_VARIABLE = 4
integer, parameter :: EN_CONDITIONAL = 5, EN_BLOCK = 6
integer, parameter :: EN_RECORD_CMD = 7
integer, parameter :: EN_OBS1_INT = 11, EN_OBS2_INT = 12
integer, parameter :: EN_OBS1_REAL = 21, EN_OBS2_REAL = 22
integer, parameter :: EN_PRT_FUN_UNARY = 101, EN_PRT_FUN_BINARY = 102
integer, parameter :: EN_EVAL_FUN_UNARY = 111, EN_EVAL_FUN_BINARY = 112
integer, parameter :: EN_LOG_FUN_UNARY = 121, EN_LOG_FUN_BINARY = 122
integer, parameter :: EN_INT_FUN_UNARY = 131, EN_INT_FUN_BINARY = 132
integer, parameter :: EN_REAL_FUN_UNARY = 141, EN_REAL_FUN_BINARY = 142
integer, parameter :: EN_FORMAT_STR = 161
@ %def EN_UNKNOWN EN_UNARY EN_BINARY EN_CONSTANT EN_VARIABLE EN_CONDITIONAL
@ %def EN_RECORD_CMD
@ %def EN_OBS1_INT EN_OBS2_INT EN_OBS1_REAL EN_OBS2_REAL
@ %def EN_PRT_FUN_UNARY EN_PRT_FUN_BINARY
@ %def EN_EVAL_FUN_UNARY EN_EVAL_FUN_BINARY
@ %def EN_LOG_FUN_UNARY EN_LOG_FUN_BINARY
@ %def EN_INT_FUN_UNARY EN_INT_FUN_BINARY
@ %def EN_REAL_FUN_UNARY EN_REAL_FUN_BINARY
@ %def EN_FORMAT_STR
@ This is exported only for use within unit tests.
<<Eval trees: public>>=
public :: eval_node_t
<<Eval trees: types>>=
type :: eval_node_t
private
type(string_t) :: tag
integer :: type = EN_UNKNOWN
integer :: result_type = V_NONE
type(var_list_t), pointer :: var_list => null ()
type(string_t) :: var_name
logical, pointer :: value_is_known => null ()
logical, pointer :: lval => null ()
integer, pointer :: ival => null ()
real(default), pointer :: rval => null ()
complex(default), pointer :: cval => null ()
type(subevt_t), pointer :: pval => null ()
type(pdg_array_t), pointer :: aval => null ()
type(string_t), pointer :: sval => null ()
type(eval_node_t), pointer :: arg0 => null ()
type(eval_node_t), pointer :: arg1 => null ()
type(eval_node_t), pointer :: arg2 => null ()
type(eval_node_t), pointer :: arg3 => null ()
type(eval_node_t), pointer :: arg4 => null ()
procedure(obs_unary_int), nopass, pointer :: obs1_int => null ()
procedure(obs_unary_real), nopass, pointer :: obs1_real => null ()
procedure(obs_binary_int), nopass, pointer :: obs2_int => null ()
procedure(obs_binary_real), nopass, pointer :: obs2_real => null ()
integer, pointer :: prt_type => null ()
integer, pointer :: index => null ()
real(default), pointer :: tolerance => null ()
integer, pointer :: jet_algorithm => null ()
real(default), pointer :: jet_r => null ()
real(default), pointer :: jet_p => null ()
real(default), pointer :: jet_ycut => null ()
real(default), pointer :: jet_dcut => null ()
real(default), pointer :: photon_iso_eps => null ()
real(default), pointer :: photon_iso_n => null ()
real(default), pointer :: photon_iso_r0 => null ()
real(default), pointer :: photon_rec_r0 => null ()
type(prt_t), pointer :: prt1 => null ()
type(prt_t), pointer :: prt2 => null ()
procedure(unary_log), nopass, pointer :: op1_log => null ()
procedure(unary_int), nopass, pointer :: op1_int => null ()
procedure(unary_real), nopass, pointer :: op1_real => null ()
procedure(unary_cmplx), nopass, pointer :: op1_cmplx => null ()
procedure(unary_pdg), nopass, pointer :: op1_pdg => null ()
procedure(unary_sev), nopass, pointer :: op1_sev => null ()
procedure(unary_str), nopass, pointer :: op1_str => null ()
procedure(unary_cut), nopass, pointer :: op1_cut => null ()
procedure(unary_evi), nopass, pointer :: op1_evi => null ()
procedure(unary_evr), nopass, pointer :: op1_evr => null ()
procedure(binary_log), nopass, pointer :: op2_log => null ()
procedure(binary_int), nopass, pointer :: op2_int => null ()
procedure(binary_real), nopass, pointer :: op2_real => null ()
procedure(binary_cmplx), nopass, pointer :: op2_cmplx => null ()
procedure(binary_pdg), nopass, pointer :: op2_pdg => null ()
procedure(binary_sev), nopass, pointer :: op2_sev => null ()
procedure(binary_str), nopass, pointer :: op2_str => null ()
procedure(binary_cut), nopass, pointer :: op2_cut => null ()
procedure(binary_evi), nopass, pointer :: op2_evi => null ()
procedure(binary_evr), nopass, pointer :: op2_evr => null ()
contains
<<Eval trees: eval node: TBP>>
end type eval_node_t
@ %def eval_node_t
@ Finalize a node recursively. Allocated constants are deleted,
pointers are ignored.
<<Eval trees: eval node: TBP>>=
procedure :: final_rec => eval_node_final_rec
<<Eval trees: procedures>>=
recursive subroutine eval_node_final_rec (node)
class(eval_node_t), intent(inout) :: node
select case (node%type)
case (EN_UNARY)
call eval_node_final_rec (node%arg1)
case (EN_BINARY)
call eval_node_final_rec (node%arg1)
call eval_node_final_rec (node%arg2)
case (EN_CONDITIONAL)
call eval_node_final_rec (node%arg0)
call eval_node_final_rec (node%arg1)
call eval_node_final_rec (node%arg2)
case (EN_BLOCK)
call eval_node_final_rec (node%arg0)
call eval_node_final_rec (node%arg1)
case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, &
EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY)
if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
call eval_node_final_rec (node%arg1)
deallocate (node%index)
deallocate (node%prt1)
case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, &
EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY)
if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
call eval_node_final_rec (node%arg1)
call eval_node_final_rec (node%arg2)
deallocate (node%index)
deallocate (node%prt1)
deallocate (node%prt2)
case (EN_FORMAT_STR)
if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
if (associated (node%arg1)) call eval_node_final_rec (node%arg1)
deallocate (node%ival)
case (EN_RECORD_CMD)
if (associated (node%arg0)) call eval_node_final_rec (node%arg0)
if (associated (node%arg1)) call eval_node_final_rec (node%arg1)
if (associated (node%arg2)) call eval_node_final_rec (node%arg2)
if (associated (node%arg3)) call eval_node_final_rec (node%arg3)
if (associated (node%arg4)) call eval_node_final_rec (node%arg4)
end select
select case (node%type)
case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, EN_CONSTANT, EN_BLOCK, &
EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, &
EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, &
EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, &
EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, &
EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY, &
EN_FORMAT_STR, EN_RECORD_CMD)
select case (node%result_type)
case (V_LOG); deallocate (node%lval)
case (V_INT); deallocate (node%ival)
case (V_REAL); deallocate (node%rval)
case (V_CMPLX); deallocate (node%cval)
case (V_SEV); deallocate (node%pval)
case (V_PDG); deallocate (node%aval)
case (V_STR); deallocate (node%sval)
end select
deallocate (node%value_is_known)
end select
end subroutine eval_node_final_rec
@ %def eval_node_final_rec
@
\subsubsection{Leaf nodes}
Initialize a leaf node with a literal constant.
<<Eval trees: procedures>>=
subroutine eval_node_init_log (node, lval)
type(eval_node_t), intent(out) :: node
logical, intent(in) :: lval
node%type = EN_CONSTANT
node%result_type = V_LOG
allocate (node%lval, node%value_is_known)
node%lval = lval
node%value_is_known = .true.
end subroutine eval_node_init_log
subroutine eval_node_init_int (node, ival)
type(eval_node_t), intent(out) :: node
integer, intent(in) :: ival
node%type = EN_CONSTANT
node%result_type = V_INT
allocate (node%ival, node%value_is_known)
node%ival = ival
node%value_is_known = .true.
end subroutine eval_node_init_int
subroutine eval_node_init_real (node, rval)
type(eval_node_t), intent(out) :: node
real(default), intent(in) :: rval
node%type = EN_CONSTANT
node%result_type = V_REAL
allocate (node%rval, node%value_is_known)
node%rval = rval
node%value_is_known = .true.
end subroutine eval_node_init_real
subroutine eval_node_init_cmplx (node, cval)
type(eval_node_t), intent(out) :: node
complex(default), intent(in) :: cval
node%type = EN_CONSTANT
node%result_type = V_CMPLX
allocate (node%cval, node%value_is_known)
node%cval = cval
node%value_is_known = .true.
end subroutine eval_node_init_cmplx
subroutine eval_node_init_subevt (node, pval)
type(eval_node_t), intent(out) :: node
type(subevt_t), intent(in) :: pval
node%type = EN_CONSTANT
node%result_type = V_SEV
allocate (node%pval, node%value_is_known)
node%pval = pval
node%value_is_known = .true.
end subroutine eval_node_init_subevt
subroutine eval_node_init_pdg_array (node, aval)
type(eval_node_t), intent(out) :: node
type(pdg_array_t), intent(in) :: aval
node%type = EN_CONSTANT
node%result_type = V_PDG
allocate (node%aval, node%value_is_known)
node%aval = aval
node%value_is_known = .true.
end subroutine eval_node_init_pdg_array
subroutine eval_node_init_string (node, sval)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: sval
node%type = EN_CONSTANT
node%result_type = V_STR
allocate (node%sval, node%value_is_known)
node%sval = sval
node%value_is_known = .true.
end subroutine eval_node_init_string
@ %def eval_node_init_log eval_node_init_int eval_node_init_real
@ %def eval_node_init_cmplx eval_node_init_prt eval_node_init_subevt
@ %def eval_node_init_pdg_array eval_node_init_string
@ Initialize a leaf node with a pointer to a named parameter
<<Eval trees: procedures>>=
subroutine eval_node_init_log_ptr (node, name, lval, is_known)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
logical, intent(in), target :: lval
logical, intent(in), target :: is_known
node%type = EN_VARIABLE
node%tag = name
node%result_type = V_LOG
node%lval => lval
node%value_is_known => is_known
end subroutine eval_node_init_log_ptr
subroutine eval_node_init_int_ptr (node, name, ival, is_known)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
integer, intent(in), target :: ival
logical, intent(in), target :: is_known
node%type = EN_VARIABLE
node%tag = name
node%result_type = V_INT
node%ival => ival
node%value_is_known => is_known
end subroutine eval_node_init_int_ptr
subroutine eval_node_init_real_ptr (node, name, rval, is_known)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
real(default), intent(in), target :: rval
logical, intent(in), target :: is_known
node%type = EN_VARIABLE
node%tag = name
node%result_type = V_REAL
node%rval => rval
node%value_is_known => is_known
end subroutine eval_node_init_real_ptr
subroutine eval_node_init_cmplx_ptr (node, name, cval, is_known)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
complex(default), intent(in), target :: cval
logical, intent(in), target :: is_known
node%type = EN_VARIABLE
node%tag = name
node%result_type = V_CMPLX
node%cval => cval
node%value_is_known => is_known
end subroutine eval_node_init_cmplx_ptr
subroutine eval_node_init_subevt_ptr (node, name, pval, is_known)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
type(subevt_t), intent(in), target :: pval
logical, intent(in), target :: is_known
node%type = EN_VARIABLE
node%tag = name
node%result_type = V_SEV
node%pval => pval
node%value_is_known => is_known
end subroutine eval_node_init_subevt_ptr
subroutine eval_node_init_pdg_array_ptr (node, name, aval, is_known)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
type(pdg_array_t), intent(in), target :: aval
logical, intent(in), target :: is_known
node%type = EN_VARIABLE
node%tag = name
node%result_type = V_PDG
node%aval => aval
node%value_is_known => is_known
end subroutine eval_node_init_pdg_array_ptr
subroutine eval_node_init_string_ptr (node, name, sval, is_known)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
type(string_t), intent(in), target :: sval
logical, intent(in), target :: is_known
node%type = EN_VARIABLE
node%tag = name
node%result_type = V_STR
node%sval => sval
node%value_is_known => is_known
end subroutine eval_node_init_string_ptr
@ %def eval_node_init_log_ptr eval_node_init_int_ptr
@ %def eval_node_init_real_ptr eval_node_init_cmplx_ptr
@ %def eval_node_init_subevt_ptr eval_node_init_string_ptr
@ The procedure-pointer cases:
<<Eval trees: procedures>>=
subroutine eval_node_init_obs1_int_ptr (node, name, obs1_iptr, p1)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
procedure(obs_unary_int), intent(in), pointer :: obs1_iptr
type(prt_t), intent(in), target :: p1
node%type = EN_OBS1_INT
node%tag = name
node%result_type = V_INT
node%obs1_int => obs1_iptr
node%prt1 => p1
allocate (node%ival, node%value_is_known)
node%value_is_known = .false.
end subroutine eval_node_init_obs1_int_ptr
subroutine eval_node_init_obs2_int_ptr (node, name, obs2_iptr, p1, p2)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
procedure(obs_binary_int), intent(in), pointer :: obs2_iptr
type(prt_t), intent(in), target :: p1, p2
node%type = EN_OBS2_INT
node%tag = name
node%result_type = V_INT
node%obs2_int => obs2_iptr
node%prt1 => p1
node%prt2 => p2
allocate (node%ival, node%value_is_known)
node%value_is_known = .false.
end subroutine eval_node_init_obs2_int_ptr
subroutine eval_node_init_obs1_real_ptr (node, name, obs1_rptr, p1)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
procedure(obs_unary_real), intent(in), pointer :: obs1_rptr
type(prt_t), intent(in), target :: p1
node%type = EN_OBS1_REAL
node%tag = name
node%result_type = V_REAL
node%obs1_real => obs1_rptr
node%prt1 => p1
allocate (node%rval, node%value_is_known)
node%value_is_known = .false.
end subroutine eval_node_init_obs1_real_ptr
subroutine eval_node_init_obs2_real_ptr (node, name, obs2_rptr, p1, p2)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: name
procedure(obs_binary_real), intent(in), pointer :: obs2_rptr
type(prt_t), intent(in), target :: p1, p2
node%type = EN_OBS2_REAL
node%tag = name
node%result_type = V_REAL
node%obs2_real => obs2_rptr
node%prt1 => p1
node%prt2 => p2
allocate (node%rval, node%value_is_known)
node%value_is_known = .false.
end subroutine eval_node_init_obs2_real_ptr
@ %def eval_node_init_obs1_int_ptr
@ %def eval_node_init_obs2_int_ptr
@ %def eval_node_init_obs1_real_ptr
@ %def eval_node_init_obs2_real_ptr
@
\subsubsection{Branch nodes}
Initialize a branch node, sub-nodes are given.
<<Eval trees: procedures>>=
subroutine eval_node_init_branch (node, tag, result_type, arg1, arg2)
type(eval_node_t), intent(out) :: node
type(string_t), intent(in) :: tag
integer, intent(in) :: result_type
type(eval_node_t), intent(in), target :: arg1
type(eval_node_t), intent(in), target, optional :: arg2
if (present (arg2)) then
node%type = EN_BINARY
else
node%type = EN_UNARY
end if
node%tag = tag
node%result_type = result_type
call eval_node_allocate_value (node)
node%arg1 => arg1
if (present (arg2)) node%arg2 => arg2
end subroutine eval_node_init_branch
@ %def eval_node_init_branch
@ Allocate the node value according to the result type.
<<Eval trees: procedures>>=
subroutine eval_node_allocate_value (node)
type(eval_node_t), intent(inout) :: node
select case (node%result_type)
case (V_LOG); allocate (node%lval)
case (V_INT); allocate (node%ival)
case (V_REAL); allocate (node%rval)
case (V_CMPLX); allocate (node%cval)
case (V_PDG); allocate (node%aval)
case (V_SEV); allocate (node%pval)
call subevt_init (node%pval)
case (V_STR); allocate (node%sval)
end select
allocate (node%value_is_known)
node%value_is_known = .false.
end subroutine eval_node_allocate_value
@ %def eval_node_allocate_value
@ Initialize a block node which contains, in addition to the
expression to be evaluated, a variable definition. The result type is
not yet assigned, because we can compile the enclosed expression only
after the var list is set up.
Note that the node always allocates a new variable list and appends it to the
current one. Thus, if the variable redefines an existing one, it only shadows
it but does not reset it. Any side-effects are therefore absent and need not
be undone outside the block.
If the flag [[new]] is set, a variable is (re)declared. This must not be done
for intrinsic variables. Vice versa, if the variable is not existent, the
[[new]] flag is required.
<<Eval trees: procedures>>=
subroutine eval_node_init_block (node, name, type, var_def, var_list)
type(eval_node_t), intent(out), target :: node
type(string_t), intent(in) :: name
integer, intent(in) :: type
type(eval_node_t), intent(in), target :: var_def
type(var_list_t), intent(in), target :: var_list
node%type = EN_BLOCK
node%tag = "var_def"
node%var_name = name
node%arg1 => var_def
allocate (node%var_list)
call node%var_list%link (var_list)
if (var_def%type == EN_CONSTANT) then
select case (type)
case (V_LOG)
call var_list_append_log (node%var_list, name, var_def%lval)
case (V_INT)
call var_list_append_int (node%var_list, name, var_def%ival)
case (V_REAL)
call var_list_append_real (node%var_list, name, var_def%rval)
case (V_CMPLX)
call var_list_append_cmplx (node%var_list, name, var_def%cval)
case (V_PDG)
call var_list_append_pdg_array &
(node%var_list, name, var_def%aval)
case (V_SEV)
call var_list_append_subevt &
(node%var_list, name, var_def%pval)
case (V_STR)
call var_list_append_string (node%var_list, name, var_def%sval)
end select
else
select case (type)
case (V_LOG); call var_list_append_log_ptr &
(node%var_list, name, var_def%lval, var_def%value_is_known)
case (V_INT); call var_list_append_int_ptr &
(node%var_list, name, var_def%ival, var_def%value_is_known)
case (V_REAL); call var_list_append_real_ptr &
(node%var_list, name, var_def%rval, var_def%value_is_known)
case (V_CMPLX); call var_list_append_cmplx_ptr &
(node%var_list, name, var_def%cval, var_def%value_is_known)
case (V_PDG); call var_list_append_pdg_array_ptr &
(node%var_list, name, var_def%aval, var_def%value_is_known)
case (V_SEV); call var_list_append_subevt_ptr &
(node%var_list, name, var_def%pval, var_def%value_is_known)
case (V_STR); call var_list_append_string_ptr &
(node%var_list, name, var_def%sval, var_def%value_is_known)
end select
end if
end subroutine eval_node_init_block
@ %def eval_node_init_block
@ Complete block initialization by assigning the expression to
evaluate to [[arg0]].
<<Eval trees: procedures>>=
subroutine eval_node_set_expr (node, arg, result_type)
type(eval_node_t), intent(inout) :: node
type(eval_node_t), intent(in), target :: arg
integer, intent(in), optional :: result_type
if (present (result_type)) then
node%result_type = result_type
else
node%result_type = arg%result_type
end if
call eval_node_allocate_value (node)
node%arg0 => arg
end subroutine eval_node_set_expr
@ %def eval_node_set_block_expr
@ Initialize a conditional. There are three branches: the condition
(evaluates to logical) and the two alternatives (evaluate both to the
same arbitrary type).
<<Eval trees: procedures>>=
subroutine eval_node_init_conditional (node, result_type, cond, arg1, arg2)
type(eval_node_t), intent(out) :: node
integer, intent(in) :: result_type
type(eval_node_t), intent(in), target :: cond, arg1, arg2
node%type = EN_CONDITIONAL
node%tag = "cond"
node%result_type = result_type
call eval_node_allocate_value (node)
node%arg0 => cond
node%arg1 => arg1
node%arg2 => arg2
end subroutine eval_node_init_conditional
@ %def eval_node_init_conditional
@ Initialize a recording command (which evaluates to a logical
constant). The first branch is the ID of the analysis object to be
filled, the optional branches 1 to 4 are the values to be recorded.
If the event-weight pointer is null, we record values with unit weight.
Otherwise, we use the value pointed to as event weight.
There can be up to four arguments which represent $x$, $y$, $\Delta y$,
$\Delta x$. Therefore, this is the only node type that may fill four
sub-nodes.
<<Eval trees: procedures>>=
subroutine eval_node_init_record_cmd &
(node, event_weight, id, arg1, arg2, arg3, arg4)
type(eval_node_t), intent(out) :: node
real(default), pointer :: event_weight
type(eval_node_t), intent(in), target :: id
type(eval_node_t), intent(in), optional, target :: arg1, arg2, arg3, arg4
call eval_node_init_log (node, .true.)
node%type = EN_RECORD_CMD
node%rval => event_weight
node%tag = "record_cmd"
node%arg0 => id
if (present (arg1)) then
node%arg1 => arg1
if (present (arg2)) then
node%arg2 => arg2
if (present (arg3)) then
node%arg3 => arg3
if (present (arg4)) then
node%arg4 => arg4
end if
end if
end if
end if
end subroutine eval_node_init_record_cmd
@ %def eval_node_init_record_cmd
@ Initialize a node for operations on subevents. The particle
lists (one or two) are inserted as [[arg1]] and [[arg2]]. We
allocated particle pointers as temporaries for iterating over particle
lists. The procedure pointer which holds the function to evaluate for
the subevents (e.g., combine, select) is also initialized.
<<Eval trees: procedures>>=
subroutine eval_node_init_prt_fun_unary (node, arg1, name, proc)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1
type(string_t), intent(in) :: name
procedure(unary_sev) :: proc
node%type = EN_PRT_FUN_UNARY
node%tag = name
node%result_type = V_SEV
call eval_node_allocate_value (node)
node%arg1 => arg1
allocate (node%index, source = 0)
allocate (node%prt1)
node%op1_sev => proc
end subroutine eval_node_init_prt_fun_unary
subroutine eval_node_init_prt_fun_binary (node, arg1, arg2, name, proc)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1, arg2
type(string_t), intent(in) :: name
procedure(binary_sev) :: proc
node%type = EN_PRT_FUN_BINARY
node%tag = name
node%result_type = V_SEV
call eval_node_allocate_value (node)
node%arg1 => arg1
node%arg2 => arg2
allocate (node%index, source = 0)
allocate (node%prt1)
allocate (node%prt2)
node%op2_sev => proc
end subroutine eval_node_init_prt_fun_binary
@ %def eval_node_init_prt_fun_unary eval_node_init_prt_fun_binary
@ Similar, but for particle-list functions that evaluate to a real
value.
<<Eval trees: procedures>>=
subroutine eval_node_init_eval_fun_unary (node, arg1, name)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1
type(string_t), intent(in) :: name
node%type = EN_EVAL_FUN_UNARY
node%tag = name
node%result_type = V_REAL
call eval_node_allocate_value (node)
node%arg1 => arg1
allocate (node%index, source = 0)
allocate (node%prt1)
end subroutine eval_node_init_eval_fun_unary
subroutine eval_node_init_eval_fun_binary (node, arg1, arg2, name)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1, arg2
type(string_t), intent(in) :: name
node%type = EN_EVAL_FUN_BINARY
node%tag = name
node%result_type = V_REAL
call eval_node_allocate_value (node)
node%arg1 => arg1
node%arg2 => arg2
allocate (node%index, source = 0)
allocate (node%prt1)
allocate (node%prt2)
end subroutine eval_node_init_eval_fun_binary
@ %def eval_node_init_eval_fun_unary eval_node_init_eval_fun_binary
@ These are for particle-list functions that evaluate to a logical
value.
<<Eval trees: procedures>>=
subroutine eval_node_init_log_fun_unary (node, arg1, name, proc)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1
type(string_t), intent(in) :: name
procedure(unary_cut) :: proc
node%type = EN_LOG_FUN_UNARY
node%tag = name
node%result_type = V_LOG
call eval_node_allocate_value (node)
node%arg1 => arg1
allocate (node%index, source = 0)
allocate (node%prt1)
node%op1_cut => proc
end subroutine eval_node_init_log_fun_unary
subroutine eval_node_init_log_fun_binary (node, arg1, arg2, name, proc)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1, arg2
type(string_t), intent(in) :: name
procedure(binary_cut) :: proc
node%type = EN_LOG_FUN_BINARY
node%tag = name
node%result_type = V_LOG
call eval_node_allocate_value (node)
node%arg1 => arg1
node%arg2 => arg2
allocate (node%index, source = 0)
allocate (node%prt1)
allocate (node%prt2)
node%op2_cut => proc
end subroutine eval_node_init_log_fun_binary
@ %def eval_node_init_log_fun_unary eval_node_init_log_fun_binary
@ These are for particle-list functions that evaluate to an integer
value.
<<Eval trees: procedures>>=
subroutine eval_node_init_int_fun_unary (node, arg1, name, proc)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1
type(string_t), intent(in) :: name
procedure(unary_evi) :: proc
node%type = EN_INT_FUN_UNARY
node%tag = name
node%result_type = V_INT
call eval_node_allocate_value (node)
node%arg1 => arg1
allocate (node%index, source = 0)
allocate (node%prt1)
node%op1_evi => proc
end subroutine eval_node_init_int_fun_unary
subroutine eval_node_init_int_fun_binary (node, arg1, arg2, name, proc)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1, arg2
type(string_t), intent(in) :: name
procedure(binary_evi) :: proc
node%type = EN_INT_FUN_BINARY
node%tag = name
node%result_type = V_INT
call eval_node_allocate_value (node)
node%arg1 => arg1
node%arg2 => arg2
allocate (node%index, source = 0)
allocate (node%prt1)
allocate (node%prt2)
node%op2_evi => proc
end subroutine eval_node_init_int_fun_binary
@ %def eval_node_init_int_fun_unary eval_node_init_int_fun_binary
@ These are for particle-list functions that evaluate to a real
value.
<<Eval trees: procedures>>=
subroutine eval_node_init_real_fun_unary (node, arg1, name, proc)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1
type(string_t), intent(in) :: name
procedure(unary_evr) :: proc
node%type = EN_REAL_FUN_UNARY
node%tag = name
node%result_type = V_INT
call eval_node_allocate_value (node)
node%arg1 => arg1
allocate (node%index, source = 0)
allocate (node%prt1)
node%op1_evr => proc
end subroutine eval_node_init_real_fun_unary
subroutine eval_node_init_real_fun_binary (node, arg1, arg2, name, proc)
type(eval_node_t), intent(out) :: node
type(eval_node_t), intent(in), target :: arg1, arg2
type(string_t), intent(in) :: name
procedure(binary_evr) :: proc
node%type = EN_REAL_FUN_BINARY
node%tag = name
node%result_type = V_INT
call eval_node_allocate_value (node)
node%arg1 => arg1
node%arg2 => arg2
allocate (node%index, source = 0)
allocate (node%prt1)
allocate (node%prt2)
node%op2_evr => proc
end subroutine eval_node_init_real_fun_binary
@ %def eval_node_init_real_fun_unary eval_node_init_real_fun_binary
@ Initialize a node for a string formatting function (sprintf).
<<Eval trees: procedures>>=
subroutine eval_node_init_format_string (node, fmt, arg, name, n_args)
type(eval_node_t), intent(out) :: node
type(eval_node_t), pointer :: fmt, arg
type(string_t), intent(in) :: name
integer, intent(in) :: n_args
node%type = EN_FORMAT_STR
node%tag = name
node%result_type = V_STR
call eval_node_allocate_value (node)
node%arg0 => fmt
node%arg1 => arg
allocate (node%ival)
node%ival = n_args
end subroutine eval_node_init_format_string
@ %def eval_node_init_format_string
@ If particle functions depend upon a condition (or an expression is
evaluated), the observables that can be evaluated for the given
particles have to be thrown on the local variable stack. This is done
here. Each observable is initialized with the particle pointers which
have been allocated for the node.
The integer variable that is referred to by the [[Index]]
pseudo-observable is always known when it is referred to.
<<Eval trees: procedures>>=
subroutine eval_node_set_observables (node, var_list)
type(eval_node_t), intent(inout) :: node
type(var_list_t), intent(in), target :: var_list
logical, save, target :: known = .true.
allocate (node%var_list)
call node%var_list%link (var_list)
allocate (node%index, source = 0)
call var_list_append_int_ptr &
(node%var_list, var_str ("Index"), node%index, known, intrinsic=.true.)
if (.not. associated (node%prt2)) then
call var_list_set_observables_unary &
(node%var_list, node%prt1)
else
call var_list_set_observables_binary &
(node%var_list, node%prt1, node%prt2)
end if
end subroutine eval_node_set_observables
@ %def eval_node_set_observables
@
\subsubsection{Output}
<<Eval trees: eval node: TBP>>=
procedure :: write => eval_node_write
<<Eval trees: procedures>>=
subroutine eval_node_write (node, unit, indent)
class(eval_node_t), intent(in) :: node
integer, intent(in), optional :: unit
integer, intent(in), optional :: indent
integer :: u, ind
u = given_output_unit (unit); if (u < 0) return
ind = 0; if (present (indent)) ind = indent
write (u, "(A)", advance="no") repeat ("| ", ind) // "o "
select case (node%type)
case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, &
EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, &
EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, &
EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, &
EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, &
EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY)
write (u, "(A)", advance="no") "[" // char (node%tag) // "] ="
case (EN_CONSTANT)
write (u, "(A)", advance="no") "[const] ="
case (EN_VARIABLE)
write (u, "(A)", advance="no") char (node%tag) // " =>"
case (EN_OBS1_INT, EN_OBS2_INT, EN_OBS1_REAL, EN_OBS2_REAL)
write (u, "(A)", advance="no") char (node%tag) // " ="
case (EN_BLOCK)
write (u, "(A)", advance="no") "[" // char (node%tag) // "]" // &
char (node%var_name) // " [expr] = "
case default
write (u, "(A)", advance="no") "[???] ="
end select
select case (node%result_type)
case (V_LOG)
if (node%value_is_known) then
if (node%lval) then
write (u, "(1x,A)") "true"
else
write (u, "(1x,A)") "false"
end if
else
write (u, "(1x,A)") "[unknown logical]"
end if
case (V_INT)
if (node%value_is_known) then
write (u, "(1x,I0)") node%ival
else
write (u, "(1x,A)") "[unknown integer]"
end if
case (V_REAL)
if (node%value_is_known) then
write (u, "(1x," // FMT_19 // ")") node%rval
else
write (u, "(1x,A)") "[unknown real]"
end if
case (V_CMPLX)
if (node%value_is_known) then
write (u, "(1x,'('," // FMT_19 // ",','," // &
FMT_19 // ",')')") node%cval
else
write (u, "(1x,A)") "[unknown complex]"
end if
case (V_SEV)
if (char (node%tag) == "@evt") then
write (u, "(1x,A)") "[event subevent]"
else if (node%value_is_known) then
call subevt_write &
(node%pval, unit, prefix = repeat ("| ", ind + 1))
else
write (u, "(1x,A)") "[unknown subevent]"
end if
case (V_PDG)
write (u, "(1x)", advance="no")
call pdg_array_write (node%aval, u); write (u, *)
case (V_STR)
if (node%value_is_known) then
write (u, "(A)") '"' // char (node%sval) // '"'
else
write (u, "(1x,A)") "[unknown string]"
end if
case default
write (u, "(1x,A)") "[empty]"
end select
select case (node%type)
case (EN_OBS1_INT, EN_OBS1_REAL)
write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 ="
call prt_write (node%prt1, unit)
case (EN_OBS2_INT, EN_OBS2_REAL)
write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 ="
call prt_write (node%prt1, unit)
write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt2 ="
call prt_write (node%prt2, unit)
end select
end subroutine eval_node_write
recursive subroutine eval_node_write_rec (node, unit, indent)
type(eval_node_t), intent(in) :: node
integer, intent(in), optional :: unit
integer, intent(in), optional :: indent
integer :: u, ind
u = given_output_unit (unit); if (u < 0) return
ind = 0; if (present (indent)) ind = indent
call eval_node_write (node, unit, indent)
select case (node%type)
case (EN_UNARY)
if (associated (node%arg0)) &
call eval_node_write_rec (node%arg0, unit, ind+1)
call eval_node_write_rec (node%arg1, unit, ind+1)
case (EN_BINARY)
if (associated (node%arg0)) &
call eval_node_write_rec (node%arg0, unit, ind+1)
call eval_node_write_rec (node%arg1, unit, ind+1)
call eval_node_write_rec (node%arg2, unit, ind+1)
case (EN_BLOCK)
call eval_node_write_rec (node%arg1, unit, ind+1)
call eval_node_write_rec (node%arg0, unit, ind+1)
case (EN_CONDITIONAL)
call eval_node_write_rec (node%arg0, unit, ind+1)
call eval_node_write_rec (node%arg1, unit, ind+1)
call eval_node_write_rec (node%arg2, unit, ind+1)
case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, &
EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY)
if (associated (node%arg0)) &
call eval_node_write_rec (node%arg0, unit, ind+1)
call eval_node_write_rec (node%arg1, unit, ind+1)
case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, &
EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY)
if (associated (node%arg0)) &
call eval_node_write_rec (node%arg0, unit, ind+1)
call eval_node_write_rec (node%arg1, unit, ind+1)
call eval_node_write_rec (node%arg2, unit, ind+1)
case (EN_RECORD_CMD)
if (associated (node%arg1)) then
call eval_node_write_rec (node%arg1, unit, ind+1)
if (associated (node%arg2)) then
call eval_node_write_rec (node%arg2, unit, ind+1)
if (associated (node%arg3)) then
call eval_node_write_rec (node%arg3, unit, ind+1)
if (associated (node%arg4)) then
call eval_node_write_rec (node%arg4, unit, ind+1)
end if
end if
end if
end if
end select
end subroutine eval_node_write_rec
@ %def eval_node_write eval_node_write_rec
@
\subsection{Operation types}
For the operations associated to evaluation tree nodes, we define
abstract interfaces for all cases.
Particles/subevents are transferred by-reference, to avoid
unnecessary copying. Therefore, subroutines instead of functions.
<<Eval trees: interfaces>>=
abstract interface
logical function unary_log (arg)
import eval_node_t
type(eval_node_t), intent(in) :: arg
end function unary_log
end interface
abstract interface
integer function unary_int (arg)
import eval_node_t
type(eval_node_t), intent(in) :: arg
end function unary_int
end interface
abstract interface
real(default) function unary_real (arg)
import default
import eval_node_t
type(eval_node_t), intent(in) :: arg
end function unary_real
end interface
abstract interface
complex(default) function unary_cmplx (arg)
import default
import eval_node_t
type(eval_node_t), intent(in) :: arg
end function unary_cmplx
end interface
abstract interface
subroutine unary_pdg (pdg_array, arg)
import pdg_array_t
import eval_node_t
type(pdg_array_t), intent(out) :: pdg_array
type(eval_node_t), intent(in) :: arg
end subroutine unary_pdg
end interface
abstract interface
subroutine unary_sev (subevt, arg, arg0)
import subevt_t
import eval_node_t
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: arg
type(eval_node_t), intent(inout), optional :: arg0
end subroutine unary_sev
end interface
abstract interface
subroutine unary_str (string, arg)
import string_t
import eval_node_t
type(string_t), intent(out) :: string
type(eval_node_t), intent(in) :: arg
end subroutine unary_str
end interface
abstract interface
logical function unary_cut (arg1, arg0)
import eval_node_t
type(eval_node_t), intent(in) :: arg1
type(eval_node_t), intent(inout) :: arg0
end function unary_cut
end interface
abstract interface
subroutine unary_evi (ival, arg1, arg0)
import eval_node_t
integer, intent(out) :: ival
type(eval_node_t), intent(in) :: arg1
type(eval_node_t), intent(inout), optional :: arg0
end subroutine unary_evi
end interface
abstract interface
subroutine unary_evr (rval, arg1, arg0)
import eval_node_t, default
real(default), intent(out) :: rval
type(eval_node_t), intent(in) :: arg1
type(eval_node_t), intent(inout), optional :: arg0
end subroutine unary_evr
end interface
abstract interface
logical function binary_log (arg1, arg2)
import eval_node_t
type(eval_node_t), intent(in) :: arg1, arg2
end function binary_log
end interface
abstract interface
integer function binary_int (arg1, arg2)
import eval_node_t
type(eval_node_t), intent(in) :: arg1, arg2
end function binary_int
end interface
abstract interface
real(default) function binary_real (arg1, arg2)
import default
import eval_node_t
type(eval_node_t), intent(in) :: arg1, arg2
end function binary_real
end interface
abstract interface
complex(default) function binary_cmplx (arg1, arg2)
import default
import eval_node_t
type(eval_node_t), intent(in) :: arg1, arg2
end function binary_cmplx
end interface
abstract interface
subroutine binary_pdg (pdg_array, arg1, arg2)
import pdg_array_t
import eval_node_t
type(pdg_array_t), intent(out) :: pdg_array
type(eval_node_t), intent(in) :: arg1, arg2
end subroutine binary_pdg
end interface
abstract interface
subroutine binary_sev (subevt, arg1, arg2, arg0)
import subevt_t
import eval_node_t
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: arg1, arg2
type(eval_node_t), intent(inout), optional :: arg0
end subroutine binary_sev
end interface
abstract interface
subroutine binary_str (string, arg1, arg2)
import string_t
import eval_node_t
type(string_t), intent(out) :: string
type(eval_node_t), intent(in) :: arg1, arg2
end subroutine binary_str
end interface
abstract interface
logical function binary_cut (arg1, arg2, arg0)
import eval_node_t
type(eval_node_t), intent(in) :: arg1, arg2
type(eval_node_t), intent(inout) :: arg0
end function binary_cut
end interface
abstract interface
subroutine binary_evi (ival, arg1, arg2, arg0)
import eval_node_t
integer, intent(out) :: ival
type(eval_node_t), intent(in) :: arg1, arg2
type(eval_node_t), intent(inout), optional :: arg0
end subroutine binary_evi
end interface
abstract interface
subroutine binary_evr (rval, arg1, arg2, arg0)
import eval_node_t, default
real(default), intent(out) :: rval
type(eval_node_t), intent(in) :: arg1, arg2
type(eval_node_t), intent(inout), optional :: arg0
end subroutine binary_evr
end interface
@ The following subroutines set the procedure pointer:
<<Eval trees: procedures>>=
subroutine eval_node_set_op1_log (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_log) :: op
en%op1_log => op
end subroutine eval_node_set_op1_log
subroutine eval_node_set_op1_int (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_int) :: op
en%op1_int => op
end subroutine eval_node_set_op1_int
subroutine eval_node_set_op1_real (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_real) :: op
en%op1_real => op
end subroutine eval_node_set_op1_real
subroutine eval_node_set_op1_cmplx (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_cmplx) :: op
en%op1_cmplx => op
end subroutine eval_node_set_op1_cmplx
subroutine eval_node_set_op1_pdg (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_pdg) :: op
en%op1_pdg => op
end subroutine eval_node_set_op1_pdg
subroutine eval_node_set_op1_sev (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_sev) :: op
en%op1_sev => op
end subroutine eval_node_set_op1_sev
subroutine eval_node_set_op1_str (en, op)
type(eval_node_t), intent(inout) :: en
procedure(unary_str) :: op
en%op1_str => op
end subroutine eval_node_set_op1_str
subroutine eval_node_set_op2_log (en, op)
type(eval_node_t), intent(inout) :: en
procedure(binary_log) :: op
en%op2_log => op
end subroutine eval_node_set_op2_log
subroutine eval_node_set_op2_int (en, op)
type(eval_node_t), intent(inout) :: en
procedure(binary_int) :: op
en%op2_int => op
end subroutine eval_node_set_op2_int
subroutine eval_node_set_op2_real (en, op)
type(eval_node_t), intent(inout) :: en
procedure(binary_real) :: op
en%op2_real => op
end subroutine eval_node_set_op2_real
subroutine eval_node_set_op2_cmplx (en, op)
type(eval_node_t), intent(inout) :: en
procedure(binary_cmplx) :: op
en%op2_cmplx => op
end subroutine eval_node_set_op2_cmplx
subroutine eval_node_set_op2_pdg (en, op)
type(eval_node_t), intent(inout) :: en
procedure(binary_pdg) :: op
en%op2_pdg => op
end subroutine eval_node_set_op2_pdg
subroutine eval_node_set_op2_sev (en, op)
type(eval_node_t), intent(inout) :: en
procedure(binary_sev) :: op
en%op2_sev => op
end subroutine eval_node_set_op2_sev
subroutine eval_node_set_op2_str (en, op)
type(eval_node_t), intent(inout) :: en
procedure(binary_str) :: op
en%op2_str => op
end subroutine eval_node_set_op2_str
@ %def eval_node_set_operator
@
\subsection{Specific operators}
Our expression syntax contains all Fortran functions that make sense.
These functions have to be provided in a form that they can be used in
procedures pointers, and have the abstract interfaces above.
For some intrinsic functions, we could use specific versions provided
by Fortran directly. However, this has two drawbacks: (i) We should
work with the values instead of the eval-nodes as argument, which
complicates the interface; (ii) more importantly, the [[default]] real
type need not be equivalent to double precision. This would, at
least, introduce system dependencies. Finally, for operators there
are no specific versions.
Therefore, we write wrappers for all possible functions, at the
expense of some overhead.
\subsubsection{Binary numerical functions}
<<Eval trees: procedures>>=
integer function add_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival + en2%ival
end function add_ii
real(default) function add_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival + en2%rval
end function add_ir
complex(default) function add_ic (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival + en2%cval
end function add_ic
real(default) function add_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval + en2%ival
end function add_ri
complex(default) function add_ci (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval + en2%ival
end function add_ci
complex(default) function add_cr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval + en2%rval
end function add_cr
complex(default) function add_rc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval + en2%cval
end function add_rc
real(default) function add_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval + en2%rval
end function add_rr
complex(default) function add_cc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval + en2%cval
end function add_cc
integer function sub_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival - en2%ival
end function sub_ii
real(default) function sub_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival - en2%rval
end function sub_ir
real(default) function sub_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval - en2%ival
end function sub_ri
complex(default) function sub_ic (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival - en2%cval
end function sub_ic
complex(default) function sub_ci (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval - en2%ival
end function sub_ci
complex(default) function sub_cr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval - en2%rval
end function sub_cr
complex(default) function sub_rc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval - en2%cval
end function sub_rc
real(default) function sub_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval - en2%rval
end function sub_rr
complex(default) function sub_cc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval - en2%cval
end function sub_cc
integer function mul_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival * en2%ival
end function mul_ii
real(default) function mul_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival * en2%rval
end function mul_ir
real(default) function mul_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval * en2%ival
end function mul_ri
complex(default) function mul_ic (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival * en2%cval
end function mul_ic
complex(default) function mul_ci (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval * en2%ival
end function mul_ci
complex(default) function mul_rc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval * en2%cval
end function mul_rc
complex(default) function mul_cr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval * en2%rval
end function mul_cr
real(default) function mul_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval * en2%rval
end function mul_rr
complex(default) function mul_cc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval * en2%cval
end function mul_cc
integer function div_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (en2%ival == 0) then
if (en1%ival >= 0) then
call msg_warning ("division by zero: " // int2char (en1%ival) // &
" / 0 ; result set to 0")
else
call msg_warning ("division by zero: (" // int2char (en1%ival) // &
") / 0 ; result set to 0")
end if
y = 0
return
end if
y = en1%ival / en2%ival
end function div_ii
real(default) function div_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival / en2%rval
end function div_ir
real(default) function div_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval / en2%ival
end function div_ri
complex(default) function div_ic (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival / en2%cval
end function div_ic
complex(default) function div_ci (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval / en2%ival
end function div_ci
complex(default) function div_rc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval / en2%cval
end function div_rc
complex(default) function div_cr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval / en2%rval
end function div_cr
real(default) function div_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval / en2%rval
end function div_rr
complex(default) function div_cc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval / en2%cval
end function div_cc
integer function pow_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
integer :: a, b
real(default) :: rres
a = en1%ival
b = en2%ival
if ((a == 0) .and. (b < 0)) then
call msg_warning ("division by zero: " // int2char (a) // &
" ^ (" // int2char (b) // ") ; result set to 0")
y = 0
return
end if
rres = real(a, default) ** b
y = rres
if (real(y, default) /= rres) then
if (b < 0) then
call msg_warning ("result of all-integer operation " // &
int2char (a) // " ^ (" // int2char (b) // &
") has been trucated to "// int2char (y), &
[ var_str ("Chances are that you want to use " // &
"reals instead of integers at this point.") ])
else
call msg_warning ("integer overflow in " // int2char (a) // &
" ^ " // int2char (b) // " ; result is " // int2char (y), &
[ var_str ("Using reals instead of integers might help.")])
end if
end if
end function pow_ii
real(default) function pow_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval ** en2%ival
end function pow_ri
complex(default) function pow_ci (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval ** en2%ival
end function pow_ci
real(default) function pow_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival ** en2%rval
end function pow_ir
real(default) function pow_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval ** en2%rval
end function pow_rr
complex(default) function pow_cr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval ** en2%rval
end function pow_cr
complex(default) function pow_ic (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival ** en2%cval
end function pow_ic
complex(default) function pow_rc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval ** en2%cval
end function pow_rc
complex(default) function pow_cc (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%cval ** en2%cval
end function pow_cc
integer function max_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = max (en1%ival, en2%ival)
end function max_ii
real(default) function max_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = max (real (en1%ival, default), en2%rval)
end function max_ir
real(default) function max_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = max (en1%rval, real (en2%ival, default))
end function max_ri
real(default) function max_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = max (en1%rval, en2%rval)
end function max_rr
integer function min_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = min (en1%ival, en2%ival)
end function min_ii
real(default) function min_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = min (real (en1%ival, default), en2%rval)
end function min_ir
real(default) function min_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = min (en1%rval, real (en2%ival, default))
end function min_ri
real(default) function min_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = min (en1%rval, en2%rval)
end function min_rr
integer function mod_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = mod (en1%ival, en2%ival)
end function mod_ii
real(default) function mod_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = mod (real (en1%ival, default), en2%rval)
end function mod_ir
real(default) function mod_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = mod (en1%rval, real (en2%ival, default))
end function mod_ri
real(default) function mod_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = mod (en1%rval, en2%rval)
end function mod_rr
integer function modulo_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = modulo (en1%ival, en2%ival)
end function modulo_ii
real(default) function modulo_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = modulo (real (en1%ival, default), en2%rval)
end function modulo_ir
real(default) function modulo_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = modulo (en1%rval, real (en2%ival, default))
end function modulo_ri
real(default) function modulo_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = modulo (en1%rval, en2%rval)
end function modulo_rr
@
\subsubsection{Unary numeric functions}
<<Eval trees: procedures>>=
real(default) function real_i (en) result (y)
type(eval_node_t), intent(in) :: en
y = en%ival
end function real_i
real(default) function real_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = en%cval
end function real_c
integer function int_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = en%rval
end function int_r
complex(default) function cmplx_i (en) result (y)
type(eval_node_t), intent(in) :: en
y = en%ival
end function cmplx_i
integer function int_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = en%cval
end function int_c
complex(default) function cmplx_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = en%rval
end function cmplx_r
integer function nint_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = nint (en%rval)
end function nint_r
integer function floor_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = floor (en%rval)
end function floor_r
integer function ceiling_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = ceiling (en%rval)
end function ceiling_r
integer function neg_i (en) result (y)
type(eval_node_t), intent(in) :: en
y = - en%ival
end function neg_i
real(default) function neg_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = - en%rval
end function neg_r
complex(default) function neg_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = - en%cval
end function neg_c
integer function abs_i (en) result (y)
type(eval_node_t), intent(in) :: en
y = abs (en%ival)
end function abs_i
real(default) function abs_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = abs (en%rval)
end function abs_r
real(default) function abs_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = abs (en%cval)
end function abs_c
integer function conjg_i (en) result (y)
type(eval_node_t), intent(in) :: en
y = en%ival
end function conjg_i
real(default) function conjg_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = en%rval
end function conjg_r
complex(default) function conjg_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = conjg (en%cval)
end function conjg_c
integer function sgn_i (en) result (y)
type(eval_node_t), intent(in) :: en
y = sign (1, en%ival)
end function sgn_i
real(default) function sgn_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = sign (1._default, en%rval)
end function sgn_r
real(default) function sqrt_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = sqrt (en%rval)
end function sqrt_r
real(default) function exp_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = exp (en%rval)
end function exp_r
real(default) function log_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = log (en%rval)
end function log_r
real(default) function log10_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = log10 (en%rval)
end function log10_r
complex(default) function sqrt_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = sqrt (en%cval)
end function sqrt_c
complex(default) function exp_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = exp (en%cval)
end function exp_c
complex(default) function log_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = log (en%cval)
end function log_c
real(default) function sin_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = sin (en%rval)
end function sin_r
real(default) function cos_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = cos (en%rval)
end function cos_r
real(default) function tan_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = tan (en%rval)
end function tan_r
real(default) function asin_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = asin (en%rval)
end function asin_r
real(default) function acos_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = acos (en%rval)
end function acos_r
real(default) function atan_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = atan (en%rval)
end function atan_r
complex(default) function sin_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = sin (en%cval)
end function sin_c
complex(default) function cos_c (en) result (y)
type(eval_node_t), intent(in) :: en
y = cos (en%cval)
end function cos_c
real(default) function sinh_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = sinh (en%rval)
end function sinh_r
real(default) function cosh_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = cosh (en%rval)
end function cosh_r
real(default) function tanh_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = tanh (en%rval)
end function tanh_r
real(default) function asinh_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = asinh (en%rval)
end function asinh_r
real(default) function acosh_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = acosh (en%rval)
end function acosh_r
real(default) function atanh_r (en) result (y)
type(eval_node_t), intent(in) :: en
y = atanh (en%rval)
end function atanh_r
@
\subsubsection{Binary logical functions}
Logical expressions:
<<Eval trees: procedures>>=
logical function ignore_first_ll (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en2%lval
end function ignore_first_ll
logical function or_ll (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%lval .or. en2%lval
end function or_ll
logical function and_ll (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%lval .and. en2%lval
end function and_ll
@ Comparisons:
<<Eval trees: procedures>>=
logical function comp_lt_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival < en2%ival
end function comp_lt_ii
logical function comp_lt_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival < en2%rval
end function comp_lt_ir
logical function comp_lt_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval < en2%ival
end function comp_lt_ri
logical function comp_lt_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval < en2%rval
end function comp_lt_rr
logical function comp_gt_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival > en2%ival
end function comp_gt_ii
logical function comp_gt_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival > en2%rval
end function comp_gt_ir
logical function comp_gt_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval > en2%ival
end function comp_gt_ri
logical function comp_gt_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval > en2%rval
end function comp_gt_rr
logical function comp_le_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival <= en2%ival
end function comp_le_ii
logical function comp_le_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival <= en2%rval
end function comp_le_ir
logical function comp_le_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval <= en2%ival
end function comp_le_ri
logical function comp_le_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval <= en2%rval
end function comp_le_rr
logical function comp_ge_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival >= en2%ival
end function comp_ge_ii
logical function comp_ge_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival >= en2%rval
end function comp_ge_ir
logical function comp_ge_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval >= en2%ival
end function comp_ge_ri
logical function comp_ge_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval >= en2%rval
end function comp_ge_rr
logical function comp_eq_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival == en2%ival
end function comp_eq_ii
logical function comp_eq_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival == en2%rval
end function comp_eq_ir
logical function comp_eq_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval == en2%ival
end function comp_eq_ri
logical function comp_eq_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval == en2%rval
end function comp_eq_rr
logical function comp_eq_ss (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%sval == en2%sval
end function comp_eq_ss
logical function comp_ne_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival /= en2%ival
end function comp_ne_ii
logical function comp_ne_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%ival /= en2%rval
end function comp_ne_ir
logical function comp_ne_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval /= en2%ival
end function comp_ne_ri
logical function comp_ne_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%rval /= en2%rval
end function comp_ne_rr
logical function comp_ne_ss (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
y = en1%sval /= en2%sval
end function comp_ne_ss
@ Comparisons with tolerance:
<<Eval trees: procedures>>=
logical function comp_se_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = abs (en1%ival - en2%ival) <= en1%tolerance
else
y = en1%ival == en2%ival
end if
end function comp_se_ii
logical function comp_se_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = abs (en1%rval - en2%ival) <= en1%tolerance
else
y = en1%rval == en2%ival
end if
end function comp_se_ri
logical function comp_se_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = abs (en1%ival - en2%rval) <= en1%tolerance
else
y = en1%ival == en2%rval
end if
end function comp_se_ir
logical function comp_se_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = abs (en1%rval - en2%rval) <= en1%tolerance
else
y = en1%rval == en2%rval
end if
end function comp_se_rr
logical function comp_ns_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = abs (en1%ival - en2%ival) > en1%tolerance
else
y = en1%ival /= en2%ival
end if
end function comp_ns_ii
logical function comp_ns_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = abs (en1%rval - en2%ival) > en1%tolerance
else
y = en1%rval /= en2%ival
end if
end function comp_ns_ri
logical function comp_ns_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = abs (en1%ival - en2%rval) > en1%tolerance
else
y = en1%ival /= en2%rval
end if
end function comp_ns_ir
logical function comp_ns_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = abs (en1%rval - en2%rval) > en1%tolerance
else
y = en1%rval /= en2%rval
end if
end function comp_ns_rr
logical function comp_ls_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%ival <= en2%ival + en1%tolerance
else
y = en1%ival <= en2%ival
end if
end function comp_ls_ii
logical function comp_ls_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%rval <= en2%ival + en1%tolerance
else
y = en1%rval <= en2%ival
end if
end function comp_ls_ri
logical function comp_ls_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%ival <= en2%rval + en1%tolerance
else
y = en1%ival <= en2%rval
end if
end function comp_ls_ir
logical function comp_ls_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%rval <= en2%rval + en1%tolerance
else
y = en1%rval <= en2%rval
end if
end function comp_ls_rr
logical function comp_ll_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%ival < en2%ival - en1%tolerance
else
y = en1%ival < en2%ival
end if
end function comp_ll_ii
logical function comp_ll_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%rval < en2%ival - en1%tolerance
else
y = en1%rval < en2%ival
end if
end function comp_ll_ri
logical function comp_ll_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%ival < en2%rval - en1%tolerance
else
y = en1%ival < en2%rval
end if
end function comp_ll_ir
logical function comp_ll_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%rval < en2%rval - en1%tolerance
else
y = en1%rval < en2%rval
end if
end function comp_ll_rr
logical function comp_gs_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%ival >= en2%ival - en1%tolerance
else
y = en1%ival >= en2%ival
end if
end function comp_gs_ii
logical function comp_gs_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%rval >= en2%ival - en1%tolerance
else
y = en1%rval >= en2%ival
end if
end function comp_gs_ri
logical function comp_gs_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%ival >= en2%rval - en1%tolerance
else
y = en1%ival >= en2%rval
end if
end function comp_gs_ir
logical function comp_gs_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%rval >= en2%rval - en1%tolerance
else
y = en1%rval >= en2%rval
end if
end function comp_gs_rr
logical function comp_gg_ii (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%ival > en2%ival + en1%tolerance
else
y = en1%ival > en2%ival
end if
end function comp_gg_ii
logical function comp_gg_ri (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%rval > en2%ival + en1%tolerance
else
y = en1%rval > en2%ival
end if
end function comp_gg_ri
logical function comp_gg_ir (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%ival > en2%rval + en1%tolerance
else
y = en1%ival > en2%rval
end if
end function comp_gg_ir
logical function comp_gg_rr (en1, en2) result (y)
type(eval_node_t), intent(in) :: en1, en2
if (associated (en1%tolerance)) then
y = en1%rval > en2%rval + en1%tolerance
else
y = en1%rval > en2%rval
end if
end function comp_gg_rr
@
\subsubsection{Unary logical functions}
<<Eval trees: procedures>>=
logical function not_l (en) result (y)
type(eval_node_t), intent(in) :: en
y = .not. en%lval
end function not_l
@
\subsubsection{Unary PDG-array functions}
Make a PDG-array object from an integer.
<<Eval trees: procedures>>=
subroutine pdg_i (pdg_array, en)
type(pdg_array_t), intent(out) :: pdg_array
type(eval_node_t), intent(in) :: en
pdg_array = en%ival
end subroutine pdg_i
@
\subsubsection{Binary PDG-array functions}
Concatenate two PDG-array objects.
<<Eval trees: procedures>>=
subroutine concat_cc (pdg_array, en1, en2)
type(pdg_array_t), intent(out) :: pdg_array
type(eval_node_t), intent(in) :: en1, en2
pdg_array = en1%aval // en2%aval
end subroutine concat_cc
@
\subsubsection{Unary particle-list functions}
Combine all particles of the first argument. If [[en0]] is present,
create a mask which is true only for those particles that pass the
test.
<<Eval trees: procedures>>=
subroutine collect_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: n, i
n = subevt_get_length (en1%pval)
allocate (mask1 (n))
if (present (en0)) then
do i = 1, n
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
mask1(i) = en0%lval
end do
else
mask1 = .true.
end if
call subevt_collect (subevt, en1%pval, mask1)
end subroutine collect_p
@ %def collect_p
@ Cluster the particles of the first argument. If [[en0]] is present,
create a mask which is true only for those particles that pass the
test.
<<Eval trees: procedures>>=
subroutine cluster_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: n, i
!!! Should not be initialized for every event
type(jet_definition_t) :: jet_def
logical :: keep_jets, exclusive
call jet_def%init (en1%jet_algorithm, en1%jet_r, en1%jet_p, en1%jet_ycut)
n = subevt_get_length (en1%pval)
allocate (mask1 (n))
if (present (en0)) then
do i = 1, n
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
mask1(i) = en0%lval
end do
else
mask1 = .true.
end if
if (associated (en1%var_list)) then
keep_jets = en1%var_list%get_lval (var_str("?keep_flavors_when_clustering"))
else
keep_jets = .false.
end if
exclusive = .false.
select case (en1%jet_algorithm)
case (ee_kt_algorithm)
exclusive = .true.
case (ee_genkt_algorithm)
if (en1%jet_r > Pi) exclusive = .true.
end select
call subevt_cluster (subevt, en1%pval, en1%jet_dcut, mask1, &
jet_def, keep_jets, exclusive)
call jet_def%final ()
end subroutine cluster_p
@ %def cluster_p
@ Select all particles of the first argument. If [[en0]] is present,
create a mask which is true only for those particles that pass the
test.
<<Eval trees: procedures>>=
subroutine select_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: n, i
n = subevt_get_length (en1%pval)
allocate (mask1 (n))
if (present (en0)) then
do i = 1, subevt_get_length (en1%pval)
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
mask1(i) = en0%lval
end do
else
mask1 = .true.
end if
call subevt_select (subevt, en1%pval, mask1)
end subroutine select_p
@ %def select_p
[[select_b_jet_p]], [[select_non_b_jet_p]], [[select_c_jet_p]], and
[[select_light_jet_p]] are special selection function acting on a
subevent of combined particles (jets) and result in a list of $b$
jets, non-$b$ jets (i.e. $c$ and light jets), $c$ jets, and light
jets, respectively.
<<Eval trees: procedures>>=
subroutine select_b_jet_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: n, i
n = subevt_get_length (en1%pval)
allocate (mask1 (n))
do i = 1, subevt_get_length (en1%pval)
mask1(i) = prt_is_b_jet (subevt_get_prt (en1%pval, i))
if (present (en0)) then
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
mask1(i) = en0%lval .and. mask1(i)
end if
end do
call subevt_select (subevt, en1%pval, mask1)
end subroutine select_b_jet_p
@ %def select_b_jet_p
<<Eval trees: procedures>>=
subroutine select_non_b_jet_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: n, i
n = subevt_get_length (en1%pval)
allocate (mask1 (n))
do i = 1, subevt_get_length (en1%pval)
mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i))
if (present (en0)) then
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
mask1(i) = en0%lval .and. mask1(i)
end if
end do
call subevt_select (subevt, en1%pval, mask1)
end subroutine select_non_b_jet_p
@ %def select_non_b_jet_p
<<Eval trees: procedures>>=
subroutine select_c_jet_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: n, i
n = subevt_get_length (en1%pval)
allocate (mask1 (n))
do i = 1, subevt_get_length (en1%pval)
mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) &
.and. prt_is_c_jet (subevt_get_prt (en1%pval, i))
if (present (en0)) then
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
mask1(i) = en0%lval .and. mask1(i)
end if
end do
call subevt_select (subevt, en1%pval, mask1)
end subroutine select_c_jet_p
@ %def select_c_jet_p
<<Eval trees: procedures>>=
subroutine select_light_jet_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: n, i
n = subevt_get_length (en1%pval)
allocate (mask1 (n))
do i = 1, subevt_get_length (en1%pval)
mask1(i) = .not. prt_is_b_jet (subevt_get_prt (en1%pval, i)) &
.and. .not. prt_is_c_jet (subevt_get_prt (en1%pval, i))
if (present (en0)) then
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
mask1(i) = en0%lval .and. mask1(i)
end if
end do
call subevt_select (subevt, en1%pval, mask1)
end subroutine select_light_jet_p
@ %def select_light_jet_p
@ Extract the particle with index given by [[en0]] from the argument
list. Negative indices count from the end. If [[en0]] is absent,
extract the first particle. The result is a list with a single entry,
or no entries if the original list was empty or if the index is out of
range.
This function has no counterpart with two arguments.
<<Eval trees: procedures>>=
subroutine extract_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
integer :: index
if (present (en0)) then
call eval_node_evaluate (en0)
select case (en0%result_type)
case (V_INT); index = en0%ival
case default
call eval_node_write (en0)
call msg_fatal (" Index parameter of 'extract' must be integer.")
end select
else
index = 1
end if
call subevt_extract (subevt, en1%pval, index)
end subroutine extract_p
@ %def extract_p
@ Sort the subevent according to the result of evaluating
[[en0]]. If [[en0]] is absent, sort by default method (PDG code,
particles before antiparticles).
<<Eval trees: procedures>>=
subroutine sort_p (subevt, en1, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
integer, dimension(:), allocatable :: ival
real(default), dimension(:), allocatable :: rval
integer :: i, n
n = subevt_get_length (en1%pval)
if (present (en0)) then
select case (en0%result_type)
case (V_INT); allocate (ival (n))
case (V_REAL); allocate (rval (n))
end select
do i = 1, n
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
select case (en0%result_type)
case (V_INT); ival(i) = en0%ival
case (V_REAL); rval(i) = en0%rval
end select
end do
select case (en0%result_type)
case (V_INT); call subevt_sort (subevt, en1%pval, ival)
case (V_REAL); call subevt_sort (subevt, en1%pval, rval)
end select
else
call subevt_sort (subevt, en1%pval)
end if
end subroutine sort_p
@ %def sort_p
@ The following functions return a logical value. [[all]] evaluates
to true if the condition [[en0]] is true for all elements of the
subevent. [[any]] and [[no]] are analogous.
<<Eval trees: procedures>>=
function all_p (en1, en0) result (lval)
logical :: lval
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout) :: en0
integer :: i, n
n = subevt_get_length (en1%pval)
lval = .true.
do i = 1, n
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
lval = en0%lval
if (.not. lval) exit
end do
end function all_p
function any_p (en1, en0) result (lval)
logical :: lval
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout) :: en0
integer :: i, n
n = subevt_get_length (en1%pval)
lval = .false.
do i = 1, n
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
lval = en0%lval
if (lval) exit
end do
end function any_p
function no_p (en1, en0) result (lval)
logical :: lval
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout) :: en0
integer :: i, n
n = subevt_get_length (en1%pval)
lval = .true.
do i = 1, n
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
lval = .not. en0%lval
if (lval) exit
end do
end function no_p
@ %def all_p any_p no_p
@ The following function returns an integer value, namely the number
of particles for which the condition is true. If there is no
condition, it returns simply the length of the subevent.
<<Eval trees: procedures>>=
subroutine count_a (ival, en1, en0)
integer, intent(out) :: ival
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(inout), optional :: en0
integer :: i, n, count
n = subevt_get_length (en1%pval)
if (present (en0)) then
count = 0
do i = 1, n
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
call eval_node_evaluate (en0)
if (en0%lval) count = count + 1
end do
ival = count
else
ival = n
end if
end subroutine count_a
@ %def count_a
@
\subsubsection{Binary particle-list functions}
This joins two subevents, stored in the evaluation nodes [[en1]]
and [[en2]]. If [[en0]] is also present, it amounts to a logical test
returning true or false for every pair of particles. A particle of
the second list gets a mask entry only if it passes the test for all
particles of the first list.
<<Eval trees: procedures>>=
subroutine join_pp (subevt, en1, en2, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask2
integer :: i, j, n1, n2
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
allocate (mask2 (n2))
mask2 = .true.
if (present (en0)) then
do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
call eval_node_evaluate (en0)
mask2(j) = mask2(j) .and. en0%lval
end do
end do
end if
call subevt_join (subevt, en1%pval, en2%pval, mask2)
end subroutine join_pp
@ %def join_pp
@ Combine two subevents, i.e., make a list of composite particles
built from all possible particle pairs from the two lists. If [[en0]]
is present, create a mask which is true only for those pairs that pass
the test.
<<Eval trees: procedures>>=
subroutine combine_pp (subevt, en1, en2, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:,:), allocatable :: mask12
integer :: i, j, n1, n2
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
if (present (en0)) then
allocate (mask12 (n1, n2))
do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
call eval_node_evaluate (en0)
mask12(i,j) = en0%lval
end do
end do
call subevt_combine (subevt, en1%pval, en2%pval, mask12)
else
call subevt_combine (subevt, en1%pval, en2%pval)
end if
end subroutine combine_pp
@ %def combine_pp
@ Combine all particles of the first argument. If [[en0]] is present,
create a mask which is true only for those particles that pass the
test w.r.t. all particles in the second argument. If [[en0]] is
absent, the second argument is ignored.
<<Eval trees: procedures>>=
subroutine collect_pp (subevt, en1, en2, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: i, j, n1, n2
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
allocate (mask1 (n1))
mask1 = .true.
if (present (en0)) then
do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
call eval_node_evaluate (en0)
mask1(i) = mask1(i) .and. en0%lval
end do
end do
end if
call subevt_collect (subevt, en1%pval, mask1)
end subroutine collect_pp
@ %def collect_pp
@ Select all particles of the first argument. If [[en0]] is present,
create a mask which is true only for those particles that pass the
test w.r.t. all particles in the second argument. If [[en0]] is
absent, the second argument is ignored, and the first argument is
transferred unchanged. (This case is not very useful, of course.)
<<Eval trees: procedures>>=
subroutine select_pp (subevt, en1, en2, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
integer :: i, j, n1, n2
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
allocate (mask1 (n1))
mask1 = .true.
if (present (en0)) then
do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
call eval_node_evaluate (en0)
mask1(i) = mask1(i) .and. en0%lval
end do
end do
end if
call subevt_select (subevt, en1%pval, mask1)
end subroutine select_pp
@ %def select_pp
@ Sort the first subevent according to the result of evaluating
[[en0]]. From the second subevent, only the first element is
taken as reference. If [[en0]] is absent, we sort by default method
(PDG code, particles before antiparticles).
<<Eval trees: procedures>>=
subroutine sort_pp (subevt, en1, en2, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout), optional :: en0
integer, dimension(:), allocatable :: ival
real(default), dimension(:), allocatable :: rval
integer :: i, n1
n1 = subevt_get_length (en1%pval)
if (present (en0)) then
select case (en0%result_type)
case (V_INT); allocate (ival (n1))
case (V_REAL); allocate (rval (n1))
end select
do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
en0%prt2 = subevt_get_prt (en2%pval, 1)
call eval_node_evaluate (en0)
select case (en0%result_type)
case (V_INT); ival(i) = en0%ival
case (V_REAL); rval(i) = en0%rval
end select
end do
select case (en0%result_type)
case (V_INT); call subevt_sort (subevt, en1%pval, ival)
case (V_REAL); call subevt_sort (subevt, en1%pval, rval)
end select
else
call subevt_sort (subevt, en1%pval)
end if
end subroutine sort_pp
@ %def sort_pp
@ The following functions return a logical value. [[all]] evaluates
to true if the condition [[en0]] is true for all valid element pairs
of both subevents. Invalid pairs (with common [[src]] entry) are
ignored.
[[any]] and [[no]] are analogous.
<<Eval trees: procedures>>=
function all_pp (en1, en2, en0) result (lval)
logical :: lval
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout) :: en0
integer :: i, j, n1, n2
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
lval = .true.
LOOP1: do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
if (are_disjoint (en0%prt1, en0%prt2)) then
call eval_node_evaluate (en0)
lval = en0%lval
if (.not. lval) exit LOOP1
end if
end do
end do LOOP1
end function all_pp
function any_pp (en1, en2, en0) result (lval)
logical :: lval
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout) :: en0
integer :: i, j, n1, n2
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
lval = .false.
LOOP1: do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
if (are_disjoint (en0%prt1, en0%prt2)) then
call eval_node_evaluate (en0)
lval = en0%lval
if (lval) exit LOOP1
end if
end do
end do LOOP1
end function any_pp
function no_pp (en1, en2, en0) result (lval)
logical :: lval
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout) :: en0
integer :: i, j, n1, n2
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
lval = .true.
LOOP1: do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
if (are_disjoint (en0%prt1, en0%prt2)) then
call eval_node_evaluate (en0)
lval = .not. en0%lval
if (lval) exit LOOP1
end if
end do
end do LOOP1
end function no_pp
@ %def all_pp any_pp no_pp
@ Recombine photons with the particles of the first argument. If [[en0]] is present,
create a mask which is true only for those particles that pass the test.
<<Eval trees: procedures>>=
subroutine photon_recombination_pp (subevt, en1, en2, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1
type(eval_node_t), intent(in) :: en2
type(eval_node_t), intent(inout), optional :: en0
logical, dimension(:), allocatable :: mask1
type(prt_t), dimension(:), allocatable :: prt_gam0
type(prt_t) :: prt
integer :: n1, i
real(default) :: reco_r0
logical :: keep_flv
reco_r0 = en1%photon_rec_r0
n1 = subevt_get_length (en1%pval)
- if (n1 > 1) then
- call msg_fatal ("Photon recombination is supported " // &
- "only for single photons.")
- end if
- allocate (prt_gam0 (n1), mask1 (n1))
- do i = 1, n1
- prt_gam0(i) = subevt_get_prt (en1%pval, i)
- end do
- if (present (en0)) then
+ if (n1 == 0) then
+ subevt = en2%pval
+ else
+ if (n1 > 1) then
+ call msg_fatal ("Photon recombination is supported " // &
+ "only for single photons.")
+ end if
+ allocate (prt_gam0 (n1), mask1 (n1))
do i = 1, n1
- en0%index = i
- en0%prt1 = prt_gam0(i)
- if (.not. prt_is_photon (en0%prt1)) &
- call msg_fatal ("Photon recombination can only " // &
- "be applied to photons.")
- call eval_node_evaluate (en0)
- mask1(i) = en0%lval
+ prt_gam0(i) = subevt_get_prt (en1%pval, i)
end do
- else
- mask1 = .true.
- end if
- do i = 1, subevt_get_length (en2%pval)
- if (.not. prt_is_recombinable (subevt_get_prt (en2%pval, i))) then
- call msg_fatal ("Only charged leptons and QCD partons " //&
- "can be recombined with photons")
+ if (present (en0)) then
+ do i = 1, n1
+ en0%index = i
+ en0%prt1 = prt_gam0(i)
+ if (.not. prt_is_photon (en0%prt1)) &
+ call msg_fatal ("Photon recombination can only " // &
+ "be applied to photons.")
+ call eval_node_evaluate (en0)
+ mask1(i) = en0%lval
+ end do
+ else
+ mask1 = .true.
end if
- end do
- if (associated (en1%var_list)) then
- keep_flv = en1%var_list%get_lval &
- (var_str("?keep_flavors_when_recombining"))
- else
- keep_flv = .false.
+ do i = 1, subevt_get_length (en2%pval)
+ if (.not. prt_is_recombinable (subevt_get_prt (en2%pval, i))) then
+ call msg_fatal ("Only charged leptons and QCD partons " //&
+ "can be recombined with photons")
+ end if
+ end do
+ if (associated (en1%var_list)) then
+ keep_flv = en1%var_list%get_lval &
+ (var_str("?keep_flavors_when_recombining"))
+ else
+ keep_flv = .false.
+ end if
+ call subevt_recombine &
+ (subevt, en2%pval, prt_gam0(1), mask1(1), reco_r0, keep_flv)
end if
- call subevt_recombine &
- (subevt,en2%pval, prt_gam0(1), mask1(1), reco_r0, keep_flv)
end subroutine photon_recombination_pp
@ %def photon_recombination_pp
The conditional restriction encoded in the [[eval_node_t]] [[en_0]] is
applied only to the photons from [[en1]], not to the objects being
isolated from in [[en2]].
<<Eval trees: procedures>>=
function photon_isolation_pp (en1, en2, en0) result (lval)
logical :: lval
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout) :: en0
type(prt_t) :: prt
type(prt_t), dimension(:), allocatable :: prt_gam0, prt_lep
type(vector4_t), dimension(:), allocatable :: &
p_gam0, p_lep0, p_lep, p_par
integer :: i, j, n1, n2, n_par, n_lep, n_gam, n_delta
real(default), dimension(:), allocatable :: delta_r, et_sum
integer, dimension(:), allocatable :: index
real(default) :: eps, iso_n, r0, pt_gam
logical, dimension(:,:), allocatable :: photon_mask
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
allocate (p_gam0 (n1), prt_gam0 (n1))
eps = en1%photon_iso_eps
iso_n = en1%photon_iso_n
r0 = en1%photon_iso_r0
lval = .true.
do i = 1, n1
en0%index = i
prt = subevt_get_prt (en1%pval, i)
prt_gam0(i) = prt
if (.not. prt_is_photon (prt_gam0(i))) &
call msg_fatal ("Photon isolation can only " // &
"be applied to photons.")
p_gam0(i) = prt_get_momentum (prt_gam0(i))
en0%prt1 = prt
call eval_node_evaluate (en0)
lval = en0%lval
if (.not. lval) return
end do
if (n1 == 0) then
call msg_fatal ("Photon isolation applied on empty photon sample.")
end if
n_par = 0
n_lep = 0
n_gam = 0
do i = 1, n2
prt = subevt_get_prt (en2%pval, i)
if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then
n_par = n_par + 1
end if
if (prt_is_lepton (prt)) then
n_lep = n_lep + 1
end if
if (prt_is_photon (prt)) then
n_gam = n_gam + 1
end if
end do
if (n_lep > 0 .and. n_gam == 0) then
call msg_fatal ("Photon isolation from EM energy: photons " // &
"have to be included.")
end if
if (n_lep > 0 .and. n_gam /= n1) then
call msg_fatal ("Photon isolation: photon samples do not match.")
end if
allocate (p_par (n_par))
allocate (p_lep0 (n_gam+n_lep), prt_lep(n_gam+n_lep))
n_par = 0
n_lep = 0
do i = 1, n2
prt = subevt_get_prt (en2%pval, i)
if (prt_is_parton (prt) .or. prt_is_clustered (prt)) then
n_par = n_par + 1
p_par(n_par) = prt_get_momentum (prt)
end if
if (prt_is_lepton (prt) .or. prt_is_photon(prt)) then
n_lep = n_lep + 1
prt_lep(n_lep) = prt
p_lep0(n_lep) = prt_get_momentum (prt_lep(n_lep))
end if
end do
if (n_par > 0) then
allocate (delta_r (n_par), index (n_par))
HADRON_ISOLATION: do i = 1, n1
pt_gam = transverse_part (p_gam0(i))
delta_r(1:n_par) = sort (eta_phi_distance (p_gam0(i), p_par(1:n_par)))
index(1:n_par) = order (eta_phi_distance (p_gam0(i), p_par(1:n_par)))
n_delta = count (delta_r < r0)
allocate (et_sum(n_delta))
do j = 1, n_delta
et_sum(j) = sum (transverse_part (p_par (index (1:j))))
if (.not. et_sum(j) <= &
iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then
lval = .false.
return
end if
end do
deallocate (et_sum)
end do HADRON_ISOLATION
deallocate (delta_r)
deallocate (index)
end if
if (n_lep > 0) then
allocate (photon_mask(n1,n_lep))
do i = 1, n1
photon_mask(i,:) = .not. (prt_gam0(i) .match. prt_lep(:))
end do
allocate (delta_r (n_lep-1), index (n_lep-1), p_lep(n_lep-1))
EM_ISOLATION: do i = 1, n1
pt_gam = transverse_part (p_gam0(i))
p_lep = pack (p_lep0, photon_mask(i,:))
delta_r(1:n_lep-1) = sort (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1)))
index(1:n_lep-1) = order (eta_phi_distance (p_gam0(i), p_lep(1:n_lep-1)))
n_delta = count (delta_r < r0)
allocate (et_sum(n_delta))
do j = 1, n_delta
et_sum(j) = sum (transverse_part (p_lep (index(1:j))))
if (.not. et_sum(j) <= &
iso_chi_gamma (delta_r(j), r0, iso_n, eps, pt_gam)) then
lval = .false.
return
end if
end do
deallocate (et_sum)
end do EM_ISOLATION
deallocate (delta_r)
deallocate (index)
end if
contains
function iso_chi_gamma (dr, r0_gam, n_gam, eps_gam, pt_gam) result (iso)
real(default) :: iso
real(default), intent(in) :: dr, r0_gam, n_gam, eps_gam, pt_gam
iso = eps_gam * pt_gam
if (.not. nearly_equal (abs(n_gam), 0._default)) then
iso = iso * ((1._default - cos(dr)) / &
(1._default - cos(r0_gam)))**abs(n_gam)
end if
end function iso_chi_gamma
end function photon_isolation_pp
@ %def photon_isolation_pp
@ This function evaluates an observable for a pair of particles. From the two
particle lists, we take the first pair without [[src]] overlap. If there is
no valid pair, we revert the status of the value to unknown.
<<Eval trees: procedures>>=
subroutine eval_pp (en1, en2, en0, rval, is_known)
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout) :: en0
real(default), intent(out) :: rval
logical, intent(out) :: is_known
integer :: i, j, n1, n2
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
rval = 0
is_known = .false.
LOOP1: do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
if (are_disjoint (en0%prt1, en0%prt2)) then
call eval_node_evaluate (en0)
rval = en0%rval
is_known = .true.
exit LOOP1
end if
end do
end do LOOP1
end subroutine eval_pp
@ %def eval_ppp
@ The following function returns an integer value, namely the number
of valid particle-pairs from both lists for which the condition is
true. Invalid pairs (with common [[src]] entry) are ignored. If
there is no condition, it returns the number of valid particle pairs.
<<Eval trees: procedures>>=
subroutine count_pp (ival, en1, en2, en0)
integer, intent(out) :: ival
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout), optional :: en0
integer :: i, j, n1, n2, count
n1 = subevt_get_length (en1%pval)
n2 = subevt_get_length (en2%pval)
if (present (en0)) then
count = 0
do i = 1, n1
en0%index = i
en0%prt1 = subevt_get_prt (en1%pval, i)
do j = 1, n2
en0%prt2 = subevt_get_prt (en2%pval, j)
if (are_disjoint (en0%prt1, en0%prt2)) then
call eval_node_evaluate (en0)
if (en0%lval) count = count + 1
end if
end do
end do
else
count = 0
do i = 1, n1
do j = 1, n2
if (are_disjoint (subevt_get_prt (en1%pval, i), &
subevt_get_prt (en2%pval, j))) then
count = count + 1
end if
end do
end do
end if
ival = count
end subroutine count_pp
@ %def count_pp
@ This function makes up a subevent from the second argument
which consists only of particles which match the PDG code array (first
argument).
<<Eval trees: procedures>>=
subroutine select_pdg_ca (subevt, en1, en2, en0)
type(subevt_t), intent(inout) :: subevt
type(eval_node_t), intent(in) :: en1, en2
type(eval_node_t), intent(inout), optional :: en0
if (present (en0)) then
call subevt_select_pdg_code (subevt, en1%aval, en2%pval, en0%ival)
else
call subevt_select_pdg_code (subevt, en1%aval, en2%pval)
end if
end subroutine select_pdg_ca
@ %def select_pdg_ca
@
\subsubsection{Binary string functions}
Currently, the only string operation is concatenation.
<<Eval trees: procedures>>=
subroutine concat_ss (string, en1, en2)
type(string_t), intent(out) :: string
type(eval_node_t), intent(in) :: en1, en2
string = en1%sval // en2%sval
end subroutine concat_ss
@ %def concat_ss
@
\subsection{Compiling the parse tree}
The evaluation tree is built recursively by following a parse tree.
Evaluate an expression. The requested type is given as an optional
argument; default is numeric (integer or real).
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_genexpr &
(en, pn, var_list, result_type)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
integer, intent(in), optional :: result_type
if (debug_active (D_MODEL_F)) then
print *, "read genexpr"; call parse_node_write (pn)
end if
if (present (result_type)) then
select case (result_type)
case (V_INT, V_REAL, V_CMPLX)
call eval_node_compile_expr (en, pn, var_list)
case (V_LOG)
call eval_node_compile_lexpr (en, pn, var_list)
case (V_SEV)
call eval_node_compile_pexpr (en, pn, var_list)
case (V_PDG)
call eval_node_compile_cexpr (en, pn, var_list)
case (V_STR)
call eval_node_compile_sexpr (en, pn, var_list)
end select
else
call eval_node_compile_expr (en, pn, var_list)
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done genexpr"
end if
end subroutine eval_node_compile_genexpr
@ %def eval_node_compile_genexpr
@
\subsubsection{Numeric expressions}
This procedure compiles a numerical expression. This is a single term
or a sum or difference of terms. We have to account for all
combinations of integer and real arguments. If both are constant, we
immediately do the calculation and allocate a constant node.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_expr (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_term, pn_addition, pn_op, pn_arg
type(eval_node_t), pointer :: en1, en2
type(string_t) :: key
integer :: t1, t2, t
if (debug_active (D_MODEL_F)) then
print *, "read expr"; call parse_node_write (pn)
end if
pn_term => parse_node_get_sub_ptr (pn)
select case (char (parse_node_get_rule_key (pn_term)))
case ("term")
call eval_node_compile_term (en, pn_term, var_list)
pn_addition => parse_node_get_next_ptr (pn_term, tag="addition")
case ("addition")
en => null ()
pn_addition => pn_term
case default
call parse_node_mismatch ("term|addition", pn)
end select
do while (associated (pn_addition))
pn_op => parse_node_get_sub_ptr (pn_addition)
pn_arg => parse_node_get_next_ptr (pn_op, tag="term")
call eval_node_compile_term (en2, pn_arg, var_list)
t2 = en2%result_type
if (associated (en)) then
en1 => en
t1 = en1%result_type
else
allocate (en1)
select case (t2)
case (V_INT); call eval_node_init_int (en1, 0)
case (V_REAL); call eval_node_init_real (en1, 0._default)
case (V_CMPLX); call eval_node_init_cmplx (en1, cmplx &
(0._default, 0._default, kind=default))
end select
t1 = t2
end if
t = numeric_result_type (t1, t2)
allocate (en)
key = parse_node_get_key (pn_op)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
select case (char (key))
case ("+")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, add_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, add_ir (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, add_ic (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, add_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, add_rr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, add_rc (en1, en2))
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_init_cmplx (en, add_ci (en1, en2))
case (V_REAL); call eval_node_init_cmplx (en, add_cr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, add_cc (en1, en2))
end select
end select
case ("-")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, sub_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, sub_ir (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, sub_ic (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, sub_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, sub_rr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, sub_rc (en1, en2))
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_init_cmplx (en, sub_ci (en1, en2))
case (V_REAL); call eval_node_init_cmplx (en, sub_cr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, sub_cc (en1, en2))
end select
end select
end select
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch (en, key, t, en1, en2)
select case (char (key))
case ("+")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, add_ii)
case (V_REAL); call eval_node_set_op2_real (en, add_ir)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_ic)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, add_ri)
case (V_REAL); call eval_node_set_op2_real (en, add_rr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_rc)
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_set_op2_cmplx (en, add_ci)
case (V_REAL); call eval_node_set_op2_cmplx (en, add_cr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_cc)
end select
end select
case ("-")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, sub_ii)
case (V_REAL); call eval_node_set_op2_real (en, sub_ir)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_ic)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, sub_ri)
case (V_REAL); call eval_node_set_op2_real (en, sub_rr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_rc)
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_set_op2_cmplx (en, sub_ci)
case (V_REAL); call eval_node_set_op2_cmplx (en, sub_cr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_cc)
end select
end select
end select
end if
pn_addition => parse_node_get_next_ptr (pn_addition)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done expr"
end if
end subroutine eval_node_compile_expr
@ %def eval_node_compile_expr
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_term (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_factor, pn_multiplication, pn_op, pn_arg
type(eval_node_t), pointer :: en1, en2
type(string_t) :: key
integer :: t1, t2, t
if (debug_active (D_MODEL_F)) then
print *, "read term"; call parse_node_write (pn)
end if
pn_factor => parse_node_get_sub_ptr (pn, tag="factor")
call eval_node_compile_factor (en, pn_factor, var_list)
pn_multiplication => &
parse_node_get_next_ptr (pn_factor, tag="multiplication")
do while (associated (pn_multiplication))
pn_op => parse_node_get_sub_ptr (pn_multiplication)
pn_arg => parse_node_get_next_ptr (pn_op, tag="factor")
en1 => en
call eval_node_compile_factor (en2, pn_arg, var_list)
t1 = en1%result_type
t2 = en2%result_type
t = numeric_result_type (t1, t2)
allocate (en)
key = parse_node_get_key (pn_op)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
select case (char (key))
case ("*")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, mul_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, mul_ir (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, mul_ic (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, mul_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, mul_rr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, mul_rc (en1, en2))
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_init_cmplx (en, mul_ci (en1, en2))
case (V_REAL); call eval_node_init_cmplx (en, mul_cr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, mul_cc (en1, en2))
end select
end select
case ("/")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, div_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, div_ir (en1, en2))
case (V_CMPLX); call eval_node_init_real (en, div_ir (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, div_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, div_rr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, div_rc (en1, en2))
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_init_cmplx (en, div_ci (en1, en2))
case (V_REAL); call eval_node_init_cmplx (en, div_cr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, div_cc (en1, en2))
end select
end select
end select
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch (en, key, t, en1, en2)
select case (char (key))
case ("*")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, mul_ii)
case (V_REAL); call eval_node_set_op2_real (en, mul_ir)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_ic)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, mul_ri)
case (V_REAL); call eval_node_set_op2_real (en, mul_rr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_rc)
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_set_op2_cmplx (en, mul_ci)
case (V_REAL); call eval_node_set_op2_cmplx (en, mul_cr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_cc)
end select
end select
case ("/")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, div_ii)
case (V_REAL); call eval_node_set_op2_real (en, div_ir)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_ic)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, div_ri)
case (V_REAL); call eval_node_set_op2_real (en, div_rr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_rc)
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_set_op2_cmplx (en, div_ci)
case (V_REAL); call eval_node_set_op2_cmplx (en, div_cr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_cc)
end select
end select
end select
end if
pn_multiplication => parse_node_get_next_ptr (pn_multiplication)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done term"
end if
end subroutine eval_node_compile_term
@ %def eval_node_compile_term
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_factor (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_value, pn_exponentiation, pn_op, pn_arg
type(eval_node_t), pointer :: en1, en2
type(string_t) :: key
integer :: t1, t2, t
if (debug_active (D_MODEL_F)) then
print *, "read factor"; call parse_node_write (pn)
end if
pn_value => parse_node_get_sub_ptr (pn)
call eval_node_compile_signed_value (en, pn_value, var_list)
pn_exponentiation => &
parse_node_get_next_ptr (pn_value, tag="exponentiation")
if (associated (pn_exponentiation)) then
pn_op => parse_node_get_sub_ptr (pn_exponentiation)
pn_arg => parse_node_get_next_ptr (pn_op)
en1 => en
call eval_node_compile_signed_value (en2, pn_arg, var_list)
t1 = en1%result_type
t2 = en2%result_type
t = numeric_result_type (t1, t2)
allocate (en)
key = parse_node_get_key (pn_op)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, pow_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, pow_ir (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, pow_ic (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, pow_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, pow_rr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, pow_rc (en1, en2))
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_init_cmplx (en, pow_ci (en1, en2))
case (V_REAL); call eval_node_init_cmplx (en, pow_cr (en1, en2))
case (V_CMPLX); call eval_node_init_cmplx (en, pow_cc (en1, en2))
end select
end select
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch (en, key, t, en1, en2)
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, pow_ii)
case (V_REAL,V_CMPLX); call eval_type_error (pn, "exponentiation", t1)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, pow_ri)
case (V_REAL); call eval_node_set_op2_real (en, pow_rr)
case (V_CMPLX); call eval_type_error (pn, "exponentiation", t1)
end select
case (V_CMPLX)
select case (t2)
case (V_INT); call eval_node_set_op2_cmplx (en, pow_ci)
case (V_REAL); call eval_node_set_op2_cmplx (en, pow_cr)
case (V_CMPLX); call eval_node_set_op2_cmplx (en, pow_cc)
end select
end select
end if
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done factor"
end if
end subroutine eval_node_compile_factor
@ %def eval_node_compile_factor
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_signed_value (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_arg
type(eval_node_t), pointer :: en1
integer :: t
if (debug_active (D_MODEL_F)) then
print *, "read signed value"; call parse_node_write (pn)
end if
select case (char (parse_node_get_rule_key (pn)))
case ("signed_value")
pn_arg => parse_node_get_sub_ptr (pn, 2)
call eval_node_compile_value (en1, pn_arg, var_list)
t = en1%result_type
allocate (en)
if (en1%type == EN_CONSTANT) then
select case (t)
case (V_INT); call eval_node_init_int (en, neg_i (en1))
case (V_REAL); call eval_node_init_real (en, neg_r (en1))
case (V_CMPLX); call eval_node_init_cmplx (en, neg_c (en1))
end select
call eval_node_final_rec (en1)
deallocate (en1)
else
call eval_node_init_branch (en, var_str ("-"), t, en1)
select case (t)
case (V_INT); call eval_node_set_op1_int (en, neg_i)
case (V_REAL); call eval_node_set_op1_real (en, neg_r)
case (V_CMPLX); call eval_node_set_op1_cmplx (en, neg_c)
end select
end if
case default
call eval_node_compile_value (en, pn, var_list)
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done signed value"
end if
end subroutine eval_node_compile_signed_value
@ %def eval_node_compile_signed_value
@ Integer, real and complex values have an optional unit. The unit is
extracted and applied immediately. An integer with unit evaluates to
a real constant.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_value (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
if (debug_active (D_MODEL_F)) then
print *, "read value"; call parse_node_write (pn)
end if
select case (char (parse_node_get_rule_key (pn)))
case ("integer_value", "real_value", "complex_value")
call eval_node_compile_numeric_value (en, pn)
case ("pi")
call eval_node_compile_constant (en, pn)
case ("I")
call eval_node_compile_constant (en, pn)
case ("variable")
call eval_node_compile_variable (en, pn, var_list)
case ("result")
call eval_node_compile_result (en, pn, var_list)
case ("expr")
call eval_node_compile_expr (en, pn, var_list)
case ("block_expr")
call eval_node_compile_block_expr (en, pn, var_list)
case ("conditional_expr")
call eval_node_compile_conditional (en, pn, var_list)
case ("unary_function")
call eval_node_compile_unary_function (en, pn, var_list)
case ("binary_function")
call eval_node_compile_binary_function (en, pn, var_list)
case ("eval_fun")
call eval_node_compile_eval_function (en, pn, var_list)
case ("count_fun")
call eval_node_compile_numeric_function (en, pn, var_list)
case default
call parse_node_mismatch &
("integer|real|complex|constant|variable|" // &
"expr|block_expr|conditional_expr|" // &
"unary_function|binary_function|numeric_pexpr", pn)
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done value"
end if
end subroutine eval_node_compile_value
@ %def eval_node_compile_value
@ Real, complex and integer values are numeric literals with an
optional unit attached. In case of an integer, the unit actually
makes it a real value in disguise. The signed version of real values
is not possible in generic expressions; it is a special case for
numeric constants in model files (see below). We do not introduce
signed versions of complex values.
<<Eval trees: procedures>>=
subroutine eval_node_compile_numeric_value (en, pn)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in), target :: pn
type(parse_node_t), pointer :: pn_val, pn_unit
allocate (en)
pn_val => parse_node_get_sub_ptr (pn)
pn_unit => parse_node_get_next_ptr (pn_val)
select case (char (parse_node_get_rule_key (pn)))
case ("integer_value")
if (associated (pn_unit)) then
call eval_node_init_real (en, &
parse_node_get_integer (pn_val) * parse_node_get_unit (pn_unit))
else
call eval_node_init_int (en, parse_node_get_integer (pn_val))
end if
case ("real_value")
if (associated (pn_unit)) then
call eval_node_init_real (en, &
parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
else
call eval_node_init_real (en, parse_node_get_real (pn_val))
end if
case ("complex_value")
if (associated (pn_unit)) then
call eval_node_init_cmplx (en, &
parse_node_get_cmplx (pn_val) * parse_node_get_unit (pn_unit))
else
call eval_node_init_cmplx (en, parse_node_get_cmplx (pn_val))
end if
case ("neg_real_value")
pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2))
pn_unit => parse_node_get_next_ptr (pn_val)
if (associated (pn_unit)) then
call eval_node_init_real (en, &
- parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
else
call eval_node_init_real (en, - parse_node_get_real (pn_val))
end if
case ("pos_real_value")
pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2))
pn_unit => parse_node_get_next_ptr (pn_val)
if (associated (pn_unit)) then
call eval_node_init_real (en, &
parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit))
else
call eval_node_init_real (en, parse_node_get_real (pn_val))
end if
case default
call parse_node_mismatch &
("integer_value|real_value|complex_value|neg_real_value|pos_real_value", pn)
end select
end subroutine eval_node_compile_numeric_value
@ %def eval_node_compile_numeric_value
@ These are the units, predefined and hardcoded. The default energy
unit is GeV, the default angular unit is radians. We include units
for observables of dimension energy squared. Luminosities are
normalized in inverse femtobarns.
<<Eval trees: procedures>>=
function parse_node_get_unit (pn) result (factor)
real(default) :: factor
real(default) :: unit
type(parse_node_t), intent(in) :: pn
type(parse_node_t), pointer :: pn_unit, pn_unit_power
type(parse_node_t), pointer :: pn_frac, pn_num, pn_int, pn_div, pn_den
integer :: num, den
pn_unit => parse_node_get_sub_ptr (pn)
select case (char (parse_node_get_key (pn_unit)))
case ("TeV"); unit = 1.e3_default
case ("GeV"); unit = 1
case ("MeV"); unit = 1.e-3_default
case ("keV"); unit = 1.e-6_default
case ("eV"); unit = 1.e-9_default
case ("meV"); unit = 1.e-12_default
case ("nbarn"); unit = 1.e6_default
case ("pbarn"); unit = 1.e3_default
case ("fbarn"); unit = 1
case ("abarn"); unit = 1.e-3_default
case ("rad"); unit = 1
case ("mrad"); unit = 1.e-3_default
case ("degree"); unit = degree
case ("%"); unit = 1.e-2_default
case default
call msg_bug (" Unit '" // &
char (parse_node_get_key (pn)) // "' is undefined.")
end select
pn_unit_power => parse_node_get_next_ptr (pn_unit)
if (associated (pn_unit_power)) then
pn_frac => parse_node_get_sub_ptr (pn_unit_power, 2)
pn_num => parse_node_get_sub_ptr (pn_frac)
select case (char (parse_node_get_rule_key (pn_num)))
case ("neg_int")
pn_int => parse_node_get_sub_ptr (pn_num, 2)
num = - parse_node_get_integer (pn_int)
case ("pos_int")
pn_int => parse_node_get_sub_ptr (pn_num, 2)
num = parse_node_get_integer (pn_int)
case ("integer_literal")
num = parse_node_get_integer (pn_num)
case default
call parse_node_mismatch ("neg_int|pos_int|integer_literal", pn_num)
end select
pn_div => parse_node_get_next_ptr (pn_num)
if (associated (pn_div)) then
pn_den => parse_node_get_sub_ptr (pn_div, 2)
den = parse_node_get_integer (pn_den)
else
den = 1
end if
else
num = 1
den = 1
end if
factor = unit ** (real (num, default) / den)
end function parse_node_get_unit
@ %def parse_node_get_unit
@ There are only two predefined constants, but more can be added easily.
<<Eval trees: procedures>>=
subroutine eval_node_compile_constant (en, pn)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
if (debug_active (D_MODEL_F)) then
print *, "read constant"; call parse_node_write (pn)
end if
allocate (en)
select case (char (parse_node_get_key (pn)))
case ("pi"); call eval_node_init_real (en, pi)
case ("I"); call eval_node_init_cmplx (en, imago)
case default
call parse_node_mismatch ("pi or I", pn)
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done constant"
end if
end subroutine eval_node_compile_constant
@ %def eval_node_compile_constant
@ Compile a variable, with or without a specified type.
Take the list of variables, look for the name and make a node with a
pointer to the value. If no type is provided, the variable is
numeric, and the stored value determines whether it is real or integer.
We explicitly demand that the variable is defined, so we do not accidentally
point to variables that are declared only later in the script but have come
into existence in a previous compilation pass.
Variables may actually be anonymous, these are expressions in disguise. In
that case, the expression replaces the variable name in the parse tree, and we
allocate an ordinary expression node in the eval tree.
Variables of type [[V_PDG]] (pdg-code array) are not treated here.
They are handled by [[eval_node_compile_cvariable]].
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_variable (en, pn, var_list, var_type)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in), target :: pn
type(var_list_t), intent(in), target :: var_list
integer, intent(in), optional :: var_type
type(parse_node_t), pointer :: pn_name
type(string_t) :: var_name
logical, target, save :: no_lval
real(default), target, save :: no_rval
type(subevt_t), target, save :: no_pval
type(string_t), target, save :: no_sval
logical, target, save :: unknown = .false.
integer :: type
logical :: defined
logical, pointer :: known
logical, pointer :: lptr
integer, pointer :: iptr
real(default), pointer :: rptr
complex(default), pointer :: cptr
type(subevt_t), pointer :: pptr
type(string_t), pointer :: sptr
procedure(obs_unary_int), pointer :: obs1_iptr
procedure(obs_unary_real), pointer :: obs1_rptr
procedure(obs_binary_int), pointer :: obs2_iptr
procedure(obs_binary_real), pointer :: obs2_rptr
type(prt_t), pointer :: p1, p2
if (debug_active (D_MODEL_F)) then
print *, "read variable"; call parse_node_write (pn)
end if
if (present (var_type)) then
select case (var_type)
case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, &
V_OBS2_INT, V_CMPLX)
pn_name => pn
case default
pn_name => parse_node_get_sub_ptr (pn, 2)
end select
else
pn_name => pn
end if
select case (char (parse_node_get_rule_key (pn_name)))
case ("expr")
call eval_node_compile_expr (en, pn_name, var_list)
case ("lexpr")
call eval_node_compile_lexpr (en, pn_name, var_list)
case ("sexpr")
call eval_node_compile_sexpr (en, pn_name, var_list)
case ("pexpr")
call eval_node_compile_pexpr (en, pn_name, var_list)
case ("variable")
var_name = parse_node_get_string (pn_name)
if (present (var_type)) then
select case (var_type)
case (V_LOG); var_name = "?" // var_name
case (V_SEV); var_name = "@" // var_name
case (V_STR); var_name = "$" // var_name ! $ sign
end select
end if
call var_list%get_var_properties &
(var_name, req_type=var_type, type=type, is_defined=defined)
allocate (en)
if (defined) then
select case (type)
case (V_LOG)
call var_list%get_lptr (var_name, lptr, known)
call eval_node_init_log_ptr (en, var_name, lptr, known)
case (V_INT)
call var_list%get_iptr (var_name, iptr, known)
call eval_node_init_int_ptr (en, var_name, iptr, known)
case (V_REAL)
call var_list%get_rptr (var_name, rptr, known)
call eval_node_init_real_ptr (en, var_name, rptr, known)
case (V_CMPLX)
call var_list%get_cptr (var_name, cptr, known)
call eval_node_init_cmplx_ptr (en, var_name, cptr, known)
case (V_SEV)
call var_list%get_pptr (var_name, pptr, known)
call eval_node_init_subevt_ptr (en, var_name, pptr, known)
case (V_STR)
call var_list%get_sptr (var_name, sptr, known)
call eval_node_init_string_ptr (en, var_name, sptr, known)
case (V_OBS1_INT)
call var_list%get_obs1_iptr (var_name, obs1_iptr, p1)
call eval_node_init_obs1_int_ptr (en, var_name, obs1_iptr, p1)
case (V_OBS2_INT)
call var_list%get_obs2_iptr (var_name, obs2_iptr, p1, p2)
call eval_node_init_obs2_int_ptr (en, var_name, obs2_iptr, p1, p2)
case (V_OBS1_REAL)
call var_list%get_obs1_rptr (var_name, obs1_rptr, p1)
call eval_node_init_obs1_real_ptr (en, var_name, obs1_rptr, p1)
case (V_OBS2_REAL)
call var_list%get_obs2_rptr (var_name, obs2_rptr, p1, p2)
call eval_node_init_obs2_real_ptr (en, var_name, obs2_rptr, p1, p2)
case default
call parse_node_write (pn)
call msg_fatal ("Variable of this type " // &
"is not allowed in the present context")
if (present (var_type)) then
select case (var_type)
case (V_LOG)
call eval_node_init_log_ptr (en, var_name, no_lval, unknown)
case (V_SEV)
call eval_node_init_subevt_ptr &
(en, var_name, no_pval, unknown)
case (V_STR)
call eval_node_init_string_ptr &
(en, var_name, no_sval, unknown)
end select
else
call eval_node_init_real_ptr (en, var_name, no_rval, unknown)
end if
end select
else
call parse_node_write (pn)
call msg_error ("This variable is undefined at this point")
if (present (var_type)) then
select case (var_type)
case (V_LOG)
call eval_node_init_log_ptr (en, var_name, no_lval, unknown)
case (V_SEV)
call eval_node_init_subevt_ptr &
(en, var_name, no_pval, unknown)
case (V_STR)
call eval_node_init_string_ptr (en, var_name, no_sval, unknown)
end select
else
call eval_node_init_real_ptr (en, var_name, no_rval, unknown)
end if
end if
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done variable"
end if
end subroutine eval_node_compile_variable
@ %def eval_node_compile_variable
@ In a given context, a variable has to have a certain type.
<<Eval trees: procedures>>=
subroutine check_var_type (pn, ok, type_actual, type_requested)
type(parse_node_t), intent(in) :: pn
logical, intent(out) :: ok
integer, intent(in) :: type_actual
integer, intent(in), optional :: type_requested
if (present (type_requested)) then
select case (type_requested)
case (V_LOG)
select case (type_actual)
case (V_LOG)
case default
call parse_node_write (pn)
call msg_fatal ("Variable type is invalid (should be logical)")
ok = .false.
end select
case (V_SEV)
select case (type_actual)
case (V_SEV)
case default
call parse_node_write (pn)
call msg_fatal &
("Variable type is invalid (should be particle set)")
ok = .false.
end select
case (V_PDG)
select case (type_actual)
case (V_PDG)
case default
call parse_node_write (pn)
call msg_fatal &
("Variable type is invalid (should be PDG array)")
ok = .false.
end select
case (V_STR)
select case (type_actual)
case (V_STR)
case default
call parse_node_write (pn)
call msg_fatal &
("Variable type is invalid (should be string)")
ok = .false.
end select
case default
call parse_node_write (pn)
call msg_bug ("Variable type is unknown")
end select
else
select case (type_actual)
case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, &
V_OBS2_INT, V_CMPLX)
case default
call parse_node_write (pn)
call msg_fatal ("Variable type is invalid (should be numeric)")
ok = .false.
end select
end if
ok = .true.
end subroutine check_var_type
@ %def check_var_type
@ Retrieve the result of an integration. If the requested process has
been integrated, the results are available as special variables. (The
variables cannot be accessed in the usual way since they contain
brackets in their names.)
Since this compilation step may occur before the processes have been
loaded, we have to initialize the required variables before they are
used.
<<Eval trees: procedures>>=
subroutine eval_node_compile_result (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in), target :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_key, pn_prc_id
type(string_t) :: key, prc_id, var_name
integer, pointer :: iptr
real(default), pointer :: rptr
logical, pointer :: known
if (debug_active (D_MODEL_F)) then
print *, "read result"; call parse_node_write (pn)
end if
pn_key => parse_node_get_sub_ptr (pn)
pn_prc_id => parse_node_get_next_ptr (pn_key)
key = parse_node_get_key (pn_key)
prc_id = parse_node_get_string (pn_prc_id)
var_name = key // "(" // prc_id // ")"
if (var_list%contains (var_name)) then
allocate (en)
select case (char(key))
case ("num_id", "n_calls")
call var_list%get_iptr (var_name, iptr, known)
call eval_node_init_int_ptr (en, var_name, iptr, known)
case ("integral", "error")
call var_list%get_rptr (var_name, rptr, known)
call eval_node_init_real_ptr (en, var_name, rptr, known)
end select
else
call msg_fatal ("Result variable '" // char (var_name) &
// "' is undefined (call 'integrate' before use)")
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done result"
end if
end subroutine eval_node_compile_result
@ %def eval_node_compile_result
@ Functions with a single argument. For non-constant arguments, watch
for functions which convert their argument to a different type.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_unary_function (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_fname, pn_arg
type(eval_node_t), pointer :: en1
type(string_t) :: key
integer :: t
if (debug_active (D_MODEL_F)) then
print *, "read unary function"; call parse_node_write (pn)
end if
pn_fname => parse_node_get_sub_ptr (pn)
pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg1")
call eval_node_compile_expr &
(en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list)
t = en1%result_type
allocate (en)
key = parse_node_get_key (pn_fname)
if (en1%type == EN_CONSTANT) then
select case (char (key))
case ("complex")
select case (t)
case (V_INT); call eval_node_init_cmplx (en, cmplx_i (en1))
case (V_REAL); call eval_node_init_cmplx (en, cmplx_r (en1))
case (V_CMPLX); deallocate (en); en => en1; en1 => null ()
case default; call eval_type_error (pn, char (key), t)
end select
case ("real")
select case (t)
case (V_INT); call eval_node_init_real (en, real_i (en1))
case (V_REAL); deallocate (en); en => en1; en1 => null ()
case (V_CMPLX); call eval_node_init_real (en, real_c (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("int")
select case (t)
case (V_INT); deallocate (en); en => en1; en1 => null ()
case (V_REAL); call eval_node_init_int (en, int_r (en1))
case (V_CMPLX); call eval_node_init_int (en, int_c (en1))
end select
case ("nint")
select case (t)
case (V_INT); deallocate (en); en => en1; en1 => null ()
case (V_REAL); call eval_node_init_int (en, nint_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("floor")
select case (t)
case (V_INT); deallocate (en); en => en1; en1 => null ()
case (V_REAL); call eval_node_init_int (en, floor_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("ceiling")
select case (t)
case (V_INT); deallocate (en); en => en1; en1 => null ()
case (V_REAL); call eval_node_init_int (en, ceiling_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("abs")
select case (t)
case (V_INT); call eval_node_init_int (en, abs_i (en1))
case (V_REAL); call eval_node_init_real (en, abs_r (en1))
case (V_CMPLX); call eval_node_init_real (en, abs_c (en1))
end select
case ("conjg")
select case (t)
case (V_INT); call eval_node_init_int (en, conjg_i (en1))
case (V_REAL); call eval_node_init_real (en, conjg_r (en1))
case (V_CMPLX); call eval_node_init_cmplx (en, conjg_c (en1))
end select
case ("sgn")
select case (t)
case (V_INT); call eval_node_init_int (en, sgn_i (en1))
case (V_REAL); call eval_node_init_real (en, sgn_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("sqrt")
select case (t)
case (V_REAL); call eval_node_init_real (en, sqrt_r (en1))
case (V_CMPLX); call eval_node_init_cmplx (en, sqrt_c (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("exp")
select case (t)
case (V_REAL); call eval_node_init_real (en, exp_r (en1))
case (V_CMPLX); call eval_node_init_cmplx (en, exp_c (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("log")
select case (t)
case (V_REAL); call eval_node_init_real (en, log_r (en1))
case (V_CMPLX); call eval_node_init_cmplx (en, log_c (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("log10")
select case (t)
case (V_REAL); call eval_node_init_real (en, log10_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("sin")
select case (t)
case (V_REAL); call eval_node_init_real (en, sin_r (en1))
case (V_CMPLX); call eval_node_init_cmplx (en, sin_c (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("cos")
select case (t)
case (V_REAL); call eval_node_init_real (en, cos_r (en1))
case (V_CMPLX); call eval_node_init_cmplx (en, cos_c (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("tan")
select case (t)
case (V_REAL); call eval_node_init_real (en, tan_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("asin")
select case (t)
case (V_REAL); call eval_node_init_real (en, asin_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("acos")
select case (t)
case (V_REAL); call eval_node_init_real (en, acos_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("atan")
select case (t)
case (V_REAL); call eval_node_init_real (en, atan_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("sinh")
select case (t)
case (V_REAL); call eval_node_init_real (en, sinh_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("cosh")
select case (t)
case (V_REAL); call eval_node_init_real (en, cosh_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("tanh")
select case (t)
case (V_REAL); call eval_node_init_real (en, tanh_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("asinh")
select case (t)
case (V_REAL); call eval_node_init_real (en, asinh_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("acosh")
select case (t)
case (V_REAL); call eval_node_init_real (en, acosh_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case ("atanh")
select case (t)
case (V_REAL); call eval_node_init_real (en, atanh_r (en1))
case default; call eval_type_error (pn, char (key), t)
end select
case default
call parse_node_mismatch ("function name", pn_fname)
end select
if (associated (en1)) then
call eval_node_final_rec (en1)
deallocate (en1)
end if
else
select case (char (key))
case ("complex")
call eval_node_init_branch (en, key, V_CMPLX, en1)
case ("real")
call eval_node_init_branch (en, key, V_REAL, en1)
case ("int", "nint", "floor", "ceiling")
call eval_node_init_branch (en, key, V_INT, en1)
case default
call eval_node_init_branch (en, key, t, en1)
end select
select case (char (key))
case ("complex")
select case (t)
case (V_INT); call eval_node_set_op1_cmplx (en, cmplx_i)
case (V_REAL); call eval_node_set_op1_cmplx (en, cmplx_r)
case (V_CMPLX); deallocate (en); en => en1
case default; call eval_type_error (pn, char (key), t)
end select
case ("real")
select case (t)
case (V_INT); call eval_node_set_op1_real (en, real_i)
case (V_REAL); deallocate (en); en => en1
case (V_CMPLX); call eval_node_set_op1_real (en, real_c)
case default; call eval_type_error (pn, char (key), t)
end select
case ("int")
select case (t)
case (V_INT); deallocate (en); en => en1
case (V_REAL); call eval_node_set_op1_int (en, int_r)
case (V_CMPLX); call eval_node_set_op1_int (en, int_c)
end select
case ("nint")
select case (t)
case (V_INT); deallocate (en); en => en1
case (V_REAL); call eval_node_set_op1_int (en, nint_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("floor")
select case (t)
case (V_INT); deallocate (en); en => en1
case (V_REAL); call eval_node_set_op1_int (en, floor_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("ceiling")
select case (t)
case (V_INT); deallocate (en); en => en1
case (V_REAL); call eval_node_set_op1_int (en, ceiling_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("abs")
select case (t)
case (V_INT); call eval_node_set_op1_int (en, abs_i)
case (V_REAL); call eval_node_set_op1_real (en, abs_r)
case (V_CMPLX);
call eval_node_init_branch (en, key, V_REAL, en1)
call eval_node_set_op1_real (en, abs_c)
end select
case ("conjg")
select case (t)
case (V_INT); call eval_node_set_op1_int (en, conjg_i)
case (V_REAL); call eval_node_set_op1_real (en, conjg_r)
case (V_CMPLX); call eval_node_set_op1_cmplx (en, conjg_c)
end select
case ("sgn")
select case (t)
case (V_INT); call eval_node_set_op1_int (en, sgn_i)
case (V_REAL); call eval_node_set_op1_real (en, sgn_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("sqrt")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, sqrt_r)
case (V_CMPLX); call eval_node_set_op1_cmplx (en, sqrt_c)
case default; call eval_type_error (pn, char (key), t)
end select
case ("exp")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, exp_r)
case (V_CMPLX); call eval_node_set_op1_cmplx (en, exp_c)
case default; call eval_type_error (pn, char (key), t)
end select
case ("log")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, log_r)
case (V_CMPLX); call eval_node_set_op1_cmplx (en, log_c)
case default; call eval_type_error (pn, char (key), t)
end select
case ("log10")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, log10_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("sin")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, sin_r)
case (V_CMPLX); call eval_node_set_op1_cmplx (en, sin_c)
case default; call eval_type_error (pn, char (key), t)
end select
case ("cos")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, cos_r)
case (V_CMPLX); call eval_node_set_op1_cmplx (en, cos_c)
case default; call eval_type_error (pn, char (key), t)
end select
case ("tan")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, tan_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("asin")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, asin_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("acos")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, acos_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("atan")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, atan_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("sinh")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, sinh_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("cosh")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, cosh_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("tanh")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, tanh_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("asinh")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, asinh_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("acosh")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, acosh_r)
case default; call eval_type_error (pn, char (key), t)
end select
case ("atanh")
select case (t)
case (V_REAL); call eval_node_set_op1_real (en, atanh_r)
case default; call eval_type_error (pn, char (key), t)
end select
case default
call parse_node_mismatch ("function name", pn_fname)
end select
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done function"
end if
end subroutine eval_node_compile_unary_function
@ %def eval_node_compile_unary_function
@ Functions with two arguments.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_binary_function (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_fname, pn_arg, pn_arg1, pn_arg2
type(eval_node_t), pointer :: en1, en2
type(string_t) :: key
integer :: t1, t2
if (debug_active (D_MODEL_F)) then
print *, "read binary function"; call parse_node_write (pn)
end if
pn_fname => parse_node_get_sub_ptr (pn)
pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg2")
pn_arg1 => parse_node_get_sub_ptr (pn_arg, tag="expr")
pn_arg2 => parse_node_get_next_ptr (pn_arg1, tag="expr")
call eval_node_compile_expr (en1, pn_arg1, var_list)
call eval_node_compile_expr (en2, pn_arg2, var_list)
t1 = en1%result_type
t2 = en2%result_type
allocate (en)
key = parse_node_get_key (pn_fname)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
select case (char (key))
case ("max")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, max_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, max_ir (en1, en2))
case default; call eval_type_error (pn, char (key), t2)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, max_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, max_rr (en1, en2))
case default; call eval_type_error (pn, char (key), t2)
end select
case default; call eval_type_error (pn, char (key), t1)
end select
case ("min")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, min_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, min_ir (en1, en2))
case default; call eval_type_error (pn, char (key), t2)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, min_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, min_rr (en1, en2))
case default; call eval_type_error (pn, char (key), t2)
end select
case default; call eval_type_error (pn, char (key), t1)
end select
case ("mod")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, mod_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, mod_ir (en1, en2))
case default; call eval_type_error (pn, char (key), t2)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, mod_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, mod_rr (en1, en2))
case default; call eval_type_error (pn, char (key), t2)
end select
case default; call eval_type_error (pn, char (key), t1)
end select
case ("modulo")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_int (en, modulo_ii (en1, en2))
case (V_REAL); call eval_node_init_real (en, modulo_ir (en1, en2))
case default; call eval_type_error (pn, char (key), t2)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_real (en, modulo_ri (en1, en2))
case (V_REAL); call eval_node_init_real (en, modulo_rr (en1, en2))
case default; call eval_type_error (pn, char (key), t2)
end select
case default; call eval_type_error (pn, char (key), t2)
end select
case default
call parse_node_mismatch ("function name", pn_fname)
end select
call eval_node_final_rec (en1)
deallocate (en1)
else
call eval_node_init_branch (en, key, t1, en1, en2)
select case (char (key))
case ("max")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, max_ii)
case (V_REAL); call eval_node_set_op2_real (en, max_ir)
case default; call eval_type_error (pn, char (key), t2)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, max_ri)
case (V_REAL); call eval_node_set_op2_real (en, max_rr)
case default; call eval_type_error (pn, char (key), t2)
end select
case default; call eval_type_error (pn, char (key), t2)
end select
case ("min")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, min_ii)
case (V_REAL); call eval_node_set_op2_real (en, min_ir)
case default; call eval_type_error (pn, char (key), t2)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, min_ri)
case (V_REAL); call eval_node_set_op2_real (en, min_rr)
case default; call eval_type_error (pn, char (key), t2)
end select
case default; call eval_type_error (pn, char (key), t2)
end select
case ("mod")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, mod_ii)
case (V_REAL); call eval_node_set_op2_real (en, mod_ir)
case default; call eval_type_error (pn, char (key), t2)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, mod_ri)
case (V_REAL); call eval_node_set_op2_real (en, mod_rr)
case default; call eval_type_error (pn, char (key), t2)
end select
case default; call eval_type_error (pn, char (key), t2)
end select
case ("modulo")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_int (en, modulo_ii)
case (V_REAL); call eval_node_set_op2_real (en, modulo_ir)
case default; call eval_type_error (pn, char (key), t2)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_real (en, modulo_ri)
case (V_REAL); call eval_node_set_op2_real (en, modulo_rr)
case default; call eval_type_error (pn, char (key), t2)
end select
case default; call eval_type_error (pn, char (key), t2)
end select
case default
call parse_node_mismatch ("function name", pn_fname)
end select
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done function"
end if
end subroutine eval_node_compile_binary_function
@ %def eval_node_compile_binary_function
@
\subsubsection{Variable definition}
A block expression contains a variable definition (first argument) and
an expression where the definition can be used (second argument). The
[[result_type]] decides which type of expression is expected for the
second argument. For numeric variables, if there is a mismatch
between real and integer type, insert an extra node for type
conversion.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_block_expr &
(en, pn, var_list, result_type)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
integer, intent(in), optional :: result_type
type(parse_node_t), pointer :: pn_var_spec, pn_var_subspec
type(parse_node_t), pointer :: pn_var_type, pn_var_name, pn_var_expr
type(parse_node_t), pointer :: pn_expr
type(string_t) :: var_name
type(eval_node_t), pointer :: en1, en2
integer :: var_type
logical :: new
if (debug_active (D_MODEL_F)) then
print *, "read block expr"; call parse_node_write (pn)
end if
new = .false.
pn_var_spec => parse_node_get_sub_ptr (pn, 2)
select case (char (parse_node_get_rule_key (pn_var_spec)))
case ("var_num"); var_type = V_NONE
pn_var_name => parse_node_get_sub_ptr (pn_var_spec)
case ("var_int"); var_type = V_INT
new = .true.
pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
case ("var_real"); var_type = V_REAL
new = .true.
pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
case ("var_cmplx"); var_type = V_CMPLX
new = .true.
pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
case ("var_logical_new"); var_type = V_LOG
new = .true.
pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
case ("var_logical_spec"); var_type = V_LOG
pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
case ("var_plist_new"); var_type = V_SEV
new = .true.
pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
case ("var_plist_spec"); var_type = V_SEV
new = .true.
pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
case ("var_alias"); var_type = V_PDG
new = .true.
pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
case ("var_string_new"); var_type = V_STR
new = .true.
pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2)
pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2)
case ("var_string_spec"); var_type = V_STR
pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2)
case default
call parse_node_mismatch &
("logical|int|real|plist|alias", pn_var_type)
end select
pn_var_expr => parse_node_get_next_ptr (pn_var_name, 2)
pn_expr => parse_node_get_next_ptr (pn_var_spec, 2)
var_name = parse_node_get_string (pn_var_name)
select case (var_type)
case (V_LOG); var_name = "?" // var_name
case (V_SEV); var_name = "@" // var_name
case (V_STR); var_name = "$" // var_name ! $ sign
end select
call var_list_check_user_var (var_list, var_name, var_type, new)
call eval_node_compile_genexpr (en1, pn_var_expr, var_list, var_type)
call insert_conversion_node (en1, var_type)
allocate (en)
call eval_node_init_block (en, var_name, var_type, en1, var_list)
call eval_node_compile_genexpr (en2, pn_expr, en%var_list, result_type)
call eval_node_set_expr (en, en2)
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done block expr"
end if
end subroutine eval_node_compile_block_expr
@ %def eval_node_compile_block_expr
@ Insert a conversion node for integer/real/complex transformation if necessary.
What shall we do for the complex to integer/real conversion?
<<Eval trees: procedures>>=
subroutine insert_conversion_node (en, result_type)
type(eval_node_t), pointer :: en
integer, intent(in) :: result_type
type(eval_node_t), pointer :: en_conv
select case (en%result_type)
case (V_INT)
select case (result_type)
case (V_REAL)
allocate (en_conv)
call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en)
call eval_node_set_op1_real (en_conv, real_i)
en => en_conv
case (V_CMPLX)
allocate (en_conv)
call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en)
call eval_node_set_op1_cmplx (en_conv, cmplx_i)
en => en_conv
end select
case (V_REAL)
select case (result_type)
case (V_INT)
allocate (en_conv)
call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en)
call eval_node_set_op1_int (en_conv, int_r)
en => en_conv
case (V_CMPLX)
allocate (en_conv)
call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en)
call eval_node_set_op1_cmplx (en_conv, cmplx_r)
en => en_conv
end select
case (V_CMPLX)
select case (result_type)
case (V_INT)
allocate (en_conv)
call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en)
call eval_node_set_op1_int (en_conv, int_c)
en => en_conv
case (V_REAL)
allocate (en_conv)
call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en)
call eval_node_set_op1_real (en_conv, real_c)
en => en_conv
end select
case default
end select
end subroutine insert_conversion_node
@ %def insert_conversion_node
@
\subsubsection{Conditionals}
A conditional has the structure if lexpr then expr else expr. So we
first evaluate the logical expression, then depending on the result
the first or second expression. Note that the second expression is
mandatory.
The [[result_type]], if present, defines the requested type of the
[[then]] and [[else]] clauses. Default is numeric (int/real). If
there is a mismatch between real and integer result types, insert
conversion nodes.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_conditional &
(en, pn, var_list, result_type)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
integer, intent(in), optional :: result_type
type(parse_node_t), pointer :: pn_condition, pn_expr
type(parse_node_t), pointer :: pn_maybe_elsif, pn_elsif_branch
type(parse_node_t), pointer :: pn_maybe_else, pn_else_branch, pn_else_expr
type(eval_node_t), pointer :: en0, en1, en2
integer :: restype
if (debug_active (D_MODEL_F)) then
print *, "read conditional"; call parse_node_write (pn)
end if
pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr")
pn_expr => parse_node_get_next_ptr (pn_condition, 2)
call eval_node_compile_lexpr (en0, pn_condition, var_list)
call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type)
if (present (result_type)) then
restype = major_result_type (result_type, en1%result_type)
else
restype = en1%result_type
end if
pn_maybe_elsif => parse_node_get_next_ptr (pn_expr)
select case (char (parse_node_get_rule_key (pn_maybe_elsif)))
case ("maybe_elsif_expr", &
"maybe_elsif_lexpr", &
"maybe_elsif_pexpr", &
"maybe_elsif_cexpr", &
"maybe_elsif_sexpr")
pn_elsif_branch => parse_node_get_sub_ptr (pn_maybe_elsif)
pn_maybe_else => parse_node_get_next_ptr (pn_maybe_elsif)
select case (char (parse_node_get_rule_key (pn_maybe_else)))
case ("maybe_else_expr", &
"maybe_else_lexpr", &
"maybe_else_pexpr", &
"maybe_else_cexpr", &
"maybe_else_sexpr")
pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else)
pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2)
case default
pn_else_expr => null ()
end select
call eval_node_compile_elsif &
(en2, pn_elsif_branch, pn_else_expr, var_list, restype)
case ("maybe_else_expr", &
"maybe_else_lexpr", &
"maybe_else_pexpr", &
"maybe_else_cexpr", &
"maybe_else_sexpr")
pn_maybe_else => pn_maybe_elsif
pn_maybe_elsif => null ()
pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else)
pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2)
call eval_node_compile_genexpr &
(en2, pn_else_expr, var_list, restype)
case ("endif")
call eval_node_compile_default_else (en2, restype)
case default
call msg_bug ("Broken conditional: unexpected " &
// char (parse_node_get_rule_key (pn_maybe_elsif)))
end select
call eval_node_create_conditional (en, en0, en1, en2, restype)
call conditional_insert_conversion_nodes (en, restype)
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done conditional"
end if
end subroutine eval_node_compile_conditional
@ %def eval_node_compile_conditional
@ This recursively generates 'elsif' conditionals as a chain of sub-nodes of
the main conditional.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_elsif &
(en, pn, pn_else_expr, var_list, result_type)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in), target :: pn
type(parse_node_t), pointer :: pn_else_expr
type(var_list_t), intent(in), target :: var_list
integer, intent(inout) :: result_type
type(parse_node_t), pointer :: pn_next, pn_condition, pn_expr
type(eval_node_t), pointer :: en0, en1, en2
pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr")
pn_expr => parse_node_get_next_ptr (pn_condition, 2)
call eval_node_compile_lexpr (en0, pn_condition, var_list)
call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type)
result_type = major_result_type (result_type, en1%result_type)
pn_next => parse_node_get_next_ptr (pn)
if (associated (pn_next)) then
call eval_node_compile_elsif &
(en2, pn_next, pn_else_expr, var_list, result_type)
result_type = major_result_type (result_type, en2%result_type)
else if (associated (pn_else_expr)) then
call eval_node_compile_genexpr &
(en2, pn_else_expr, var_list, result_type)
result_type = major_result_type (result_type, en2%result_type)
else
call eval_node_compile_default_else (en2, result_type)
end if
call eval_node_create_conditional (en, en0, en1, en2, result_type)
end subroutine eval_node_compile_elsif
@ %def eval_node_compile_elsif
@ This makes a default 'else' branch in case it was omitted. The default value
just depends on the expected type.
<<Eval trees: procedures>>=
subroutine eval_node_compile_default_else (en, result_type)
type(eval_node_t), pointer :: en
integer, intent(in) :: result_type
type(subevt_t) :: pval_empty
type(pdg_array_t) :: aval_undefined
allocate (en)
select case (result_type)
case (V_LOG); call eval_node_init_log (en, .false.)
case (V_INT); call eval_node_init_int (en, 0)
case (V_REAL); call eval_node_init_real (en, 0._default)
case (V_CMPLX)
call eval_node_init_cmplx (en, (0._default, 0._default))
case (V_SEV)
call subevt_init (pval_empty)
call eval_node_init_subevt (en, pval_empty)
case (V_PDG)
call eval_node_init_pdg_array (en, aval_undefined)
case (V_STR)
call eval_node_init_string (en, var_str (""))
case default
call msg_bug ("Undefined type for 'else' branch in conditional")
end select
end subroutine eval_node_compile_default_else
@ %def eval_node_compile_default_else
@ If the logical expression is constant, we can simplify the conditional node
by replacing it with the selected branch. Otherwise, we initialize a true
branching.
<<Eval trees: procedures>>=
subroutine eval_node_create_conditional (en, en0, en1, en2, result_type)
type(eval_node_t), pointer :: en, en0, en1, en2
integer, intent(in) :: result_type
if (en0%type == EN_CONSTANT) then
if (en0%lval) then
en => en1
call eval_node_final_rec (en2)
deallocate (en2)
else
en => en2
call eval_node_final_rec (en1)
deallocate (en1)
end if
else
allocate (en)
call eval_node_init_conditional (en, result_type, en0, en1, en2)
end if
end subroutine eval_node_create_conditional
@ %def eval_node_create_conditional
@ Return the numerical result type which should be used for the combination of
the two result types.
<<Eval trees: procedures>>=
function major_result_type (t1, t2) result (t)
integer :: t
integer, intent(in) :: t1, t2
select case (t1)
case (V_INT)
select case (t2)
case (V_INT, V_REAL, V_CMPLX)
t = t2
case default
call type_mismatch ()
end select
case (V_REAL)
select case (t2)
case (V_INT)
t = t1
case (V_REAL, V_CMPLX)
t = t2
case default
call type_mismatch ()
end select
case (V_CMPLX)
select case (t2)
case (V_INT, V_REAL, V_CMPLX)
t = t1
case default
call type_mismatch ()
end select
case default
if (t1 == t2) then
t = t1
else
call type_mismatch ()
end if
end select
contains
subroutine type_mismatch ()
call msg_bug ("Type mismatch in branches of a conditional expression")
end subroutine type_mismatch
end function major_result_type
@ %def major_result_type
@ Recursively insert conversion nodes where necessary.
<<Eval trees: procedures>>=
recursive subroutine conditional_insert_conversion_nodes (en, result_type)
type(eval_node_t), intent(inout), target :: en
integer, intent(in) :: result_type
select case (result_type)
case (V_INT, V_REAL, V_CMPLX)
call insert_conversion_node (en%arg1, result_type)
if (en%arg2%type == EN_CONDITIONAL) then
call conditional_insert_conversion_nodes (en%arg2, result_type)
else
call insert_conversion_node (en%arg2, result_type)
end if
end select
end subroutine conditional_insert_conversion_nodes
@ %def conditional_insert_conversion_nodes
@
\subsubsection{Logical expressions}
A logical expression consists of one or more singlet logical expressions
concatenated by [[;]]. This is for allowing side-effects, only the last value
is used.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_lexpr (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_term, pn_sequel, pn_arg
type(eval_node_t), pointer :: en1, en2
if (debug_active (D_MODEL_F)) then
print *, "read lexpr"; call parse_node_write (pn)
end if
pn_term => parse_node_get_sub_ptr (pn, tag="lsinglet")
call eval_node_compile_lsinglet (en, pn_term, var_list)
pn_sequel => parse_node_get_next_ptr (pn_term, tag="lsequel")
do while (associated (pn_sequel))
pn_arg => parse_node_get_sub_ptr (pn_sequel, 2, tag="lsinglet")
en1 => en
call eval_node_compile_lsinglet (en2, pn_arg, var_list)
allocate (en)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
call eval_node_init_log (en, ignore_first_ll (en1, en2))
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch &
(en, var_str ("lsequel"), V_LOG, en1, en2)
call eval_node_set_op2_log (en, ignore_first_ll)
end if
pn_sequel => parse_node_get_next_ptr (pn_sequel)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done lexpr"
end if
end subroutine eval_node_compile_lexpr
@ %def eval_node_compile_lexpr
@ A logical singlet expression consists of one or more logical terms
concatenated by [[or]].
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_lsinglet (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_term, pn_alternative, pn_arg
type(eval_node_t), pointer :: en1, en2
if (debug_active (D_MODEL_F)) then
print *, "read lsinglet"; call parse_node_write (pn)
end if
pn_term => parse_node_get_sub_ptr (pn, tag="lterm")
call eval_node_compile_lterm (en, pn_term, var_list)
pn_alternative => parse_node_get_next_ptr (pn_term, tag="alternative")
do while (associated (pn_alternative))
pn_arg => parse_node_get_sub_ptr (pn_alternative, 2, tag="lterm")
en1 => en
call eval_node_compile_lterm (en2, pn_arg, var_list)
allocate (en)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
call eval_node_init_log (en, or_ll (en1, en2))
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch &
(en, var_str ("alternative"), V_LOG, en1, en2)
call eval_node_set_op2_log (en, or_ll)
end if
pn_alternative => parse_node_get_next_ptr (pn_alternative)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done lsinglet"
end if
end subroutine eval_node_compile_lsinglet
@ %def eval_node_compile_lsinglet
@ A logical term consists of one or more logical values
concatenated by [[and]].
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_lterm (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_term, pn_coincidence, pn_arg
type(eval_node_t), pointer :: en1, en2
if (debug_active (D_MODEL_F)) then
print *, "read lterm"; call parse_node_write (pn)
end if
pn_term => parse_node_get_sub_ptr (pn)
call eval_node_compile_lvalue (en, pn_term, var_list)
pn_coincidence => parse_node_get_next_ptr (pn_term, tag="coincidence")
do while (associated (pn_coincidence))
pn_arg => parse_node_get_sub_ptr (pn_coincidence, 2)
en1 => en
call eval_node_compile_lvalue (en2, pn_arg, var_list)
allocate (en)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
call eval_node_init_log (en, and_ll (en1, en2))
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch &
(en, var_str ("coincidence"), V_LOG, en1, en2)
call eval_node_set_op2_log (en, and_ll)
end if
pn_coincidence => parse_node_get_next_ptr (pn_coincidence)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done lterm"
end if
end subroutine eval_node_compile_lterm
@ %def eval_node_compile_lterm
@ Logical variables are disabled, because they are confused with the
l.h.s.\ of compared expressions.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_lvalue (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
if (debug_active (D_MODEL_F)) then
print *, "read lvalue"; call parse_node_write (pn)
end if
select case (char (parse_node_get_rule_key (pn)))
case ("true")
allocate (en)
call eval_node_init_log (en, .true.)
case ("false")
allocate (en)
call eval_node_init_log (en, .false.)
case ("negation")
call eval_node_compile_negation (en, pn, var_list)
case ("lvariable")
call eval_node_compile_variable (en, pn, var_list, V_LOG)
case ("lexpr")
call eval_node_compile_lexpr (en, pn, var_list)
case ("block_lexpr")
call eval_node_compile_block_expr (en, pn, var_list, V_LOG)
case ("conditional_lexpr")
call eval_node_compile_conditional (en, pn, var_list, V_LOG)
case ("compared_expr")
call eval_node_compile_compared_expr (en, pn, var_list, V_REAL)
case ("compared_sexpr")
call eval_node_compile_compared_expr (en, pn, var_list, V_STR)
case ("all_fun", "any_fun", "no_fun", "photon_isolation_fun")
call eval_node_compile_log_function (en, pn, var_list)
case ("record_cmd")
call eval_node_compile_record_cmd (en, pn, var_list)
case default
call parse_node_mismatch &
("true|false|negation|lvariable|" // &
"lexpr|block_lexpr|conditional_lexpr|" // &
"compared_expr|compared_sexpr|logical_pexpr", pn)
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done lvalue"
end if
end subroutine eval_node_compile_lvalue
@ %def eval_node_compile_lvalue
@ A negation consists of the keyword [[not]] and a logical value.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_negation (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_arg
type(eval_node_t), pointer :: en1
if (debug_active (D_MODEL_F)) then
print *, "read negation"; call parse_node_write (pn)
end if
pn_arg => parse_node_get_sub_ptr (pn, 2)
call eval_node_compile_lvalue (en1, pn_arg, var_list)
allocate (en)
if (en1%type == EN_CONSTANT) then
call eval_node_init_log (en, not_l (en1))
call eval_node_final_rec (en1)
deallocate (en1)
else
call eval_node_init_branch (en, var_str ("not"), V_LOG, en1)
call eval_node_set_op1_log (en, not_l)
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done negation"
end if
end subroutine eval_node_compile_negation
@ %def eval_node_compile_negation
@
\subsubsection{Comparisons}
Up to the loop, this is easy. There is always at least one
comparison. This is evaluated, and the result is the logical node
[[en]]. If it is constant, we keep its second sub-node as [[en2]].
(Thus, at the very end [[en2]] has to be deleted if [[en]] is (still)
constant.)
If there is another comparison, we first check if the first comparison
was constant. In that case, there are two possibilities: (i) it was
true. Then, its right-hand side is compared with the new right-hand
side, and the result replaces the previous one which is deleted. (ii)
it was false. In this case, the result of the whole comparison is
false, and we can exit the loop without evaluating anything else.
Now assume that the first comparison results in a valid branch, its
second sub-node kept as [[en2]]. We first need a copy of this, which
becomes the new left-hand side. If [[en2]] is constant, we make an
identical constant node [[en1]]. Otherwise, we make [[en1]] an
appropriate pointer node. Next, the first branch is saved as [[en0]]
and we evaluate the comparison between [[en1]] and the a right-hand
side. If this turns out to be constant, there are again two
possibilities: (i) true, then we revert to the previous result. (ii)
false, then the wh
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_compared_expr (en, pn, var_list, type)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
integer, intent(in) :: type
type(parse_node_t), pointer :: pn_comparison, pn_expr1
type(eval_node_t), pointer :: en0, en1, en2
if (debug_active (D_MODEL_F)) then
print *, "read comparison"; call parse_node_write (pn)
end if
select case (type)
case (V_INT, V_REAL)
pn_expr1 => parse_node_get_sub_ptr (pn, tag="expr")
call eval_node_compile_expr (en1, pn_expr1, var_list)
pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="comparison")
case (V_STR)
pn_expr1 => parse_node_get_sub_ptr (pn, tag="sexpr")
call eval_node_compile_sexpr (en1, pn_expr1, var_list)
pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="str_comparison")
end select
call eval_node_compile_comparison &
(en, en1, en2, pn_comparison, var_list, type)
pn_comparison => parse_node_get_next_ptr (pn_comparison)
SCAN_FURTHER: do while (associated (pn_comparison))
if (en%type == EN_CONSTANT) then
if (en%lval) then
en1 => en2
call eval_node_final_rec (en); deallocate (en)
call eval_node_compile_comparison &
(en, en1, en2, pn_comparison, var_list, type)
else
exit SCAN_FURTHER
end if
else
allocate (en1)
if (en2%type == EN_CONSTANT) then
select case (en2%result_type)
case (V_INT); call eval_node_init_int (en1, en2%ival)
case (V_REAL); call eval_node_init_real (en1, en2%rval)
case (V_STR); call eval_node_init_string (en1, en2%sval)
end select
else
select case (en2%result_type)
case (V_INT); call eval_node_init_int_ptr &
(en1, var_str ("(previous)"), en2%ival, en2%value_is_known)
case (V_REAL); call eval_node_init_real_ptr &
(en1, var_str ("(previous)"), en2%rval, en2%value_is_known)
case (V_STR); call eval_node_init_string_ptr &
(en1, var_str ("(previous)"), en2%sval, en2%value_is_known)
end select
end if
en0 => en
call eval_node_compile_comparison &
(en, en1, en2, pn_comparison, var_list, type)
if (en%type == EN_CONSTANT) then
if (en%lval) then
call eval_node_final_rec (en); deallocate (en)
en => en0
else
call eval_node_final_rec (en0); deallocate (en0)
exit SCAN_FURTHER
end if
else
en1 => en
allocate (en)
call eval_node_init_branch (en, var_str ("and"), V_LOG, en0, en1)
call eval_node_set_op2_log (en, and_ll)
end if
end if
pn_comparison => parse_node_get_next_ptr (pn_comparison)
end do SCAN_FURTHER
if (en%type == EN_CONSTANT .and. associated (en2)) then
call eval_node_final_rec (en2); deallocate (en2)
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done compared_expr"
end if
end subroutine eval_node_compile_compared_expr
@ %dev eval_node_compile_compared_expr
@ This takes two extra arguments: [[en1]], the left-hand-side of the
comparison, is already allocated and evaluated. [[en2]] (the
right-hand side) and [[en]] (the result) are allocated by the
routine. [[pn]] is the parse node which contains the operator and the
right-hand side as subnodes.
If the result of the comparison is constant, [[en1]] is deleted but
[[en2]] is kept, because it may be used in a subsequent comparison.
[[en]] then becomes a constant. If the result is variable, [[en]]
becomes a branch node which refers to [[en1]] and [[en2]].
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_comparison &
(en, en1, en2, pn, var_list, type)
type(eval_node_t), pointer :: en, en1, en2
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
integer, intent(in) :: type
type(parse_node_t), pointer :: pn_op, pn_arg
type(string_t) :: key
integer :: t1, t2
real(default), pointer :: tolerance_ptr
pn_op => parse_node_get_sub_ptr (pn)
key = parse_node_get_key (pn_op)
select case (type)
case (V_INT, V_REAL)
pn_arg => parse_node_get_next_ptr (pn_op, tag="expr")
call eval_node_compile_expr (en2, pn_arg, var_list)
case (V_STR)
pn_arg => parse_node_get_next_ptr (pn_op, tag="sexpr")
call eval_node_compile_sexpr (en2, pn_arg, var_list)
end select
t1 = en1%result_type
t2 = en2%result_type
allocate (en)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr)
en1%tolerance => tolerance_ptr
select case (char (key))
case ("<")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_lt_ii (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_ll_ir (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_ll_ri (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_ll_rr (en1, en2))
end select
end select
case (">")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_gt_ii (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_gg_ir (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_gg_ri (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_gg_rr (en1, en2))
end select
end select
case ("<=")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_le_ii (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_ls_ir (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_ls_ri (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_ls_rr (en1, en2))
end select
end select
case (">=")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_ge_ii (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_gs_ir (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_gs_ri (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_gs_rr (en1, en2))
end select
end select
case ("==")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_eq_ii (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_se_ir (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_se_ri (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_se_rr (en1, en2))
end select
case (V_STR)
select case (t2)
case (V_STR); call eval_node_init_log (en, comp_eq_ss (en1, en2))
end select
end select
case ("<>")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_ne_ii (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_ns_ir (en1, en2))
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_init_log (en, comp_ns_ri (en1, en2))
case (V_REAL); call eval_node_init_log (en, comp_ns_rr (en1, en2))
end select
case (V_STR)
select case (t2)
case (V_STR); call eval_node_init_log (en, comp_ne_ss (en1, en2))
end select
end select
end select
call eval_node_final_rec (en1)
deallocate (en1)
else
call eval_node_init_branch (en, key, V_LOG, en1, en2)
select case (char (key))
case ("<")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_lt_ii)
case (V_REAL); call eval_node_set_op2_log (en, comp_ll_ir)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_ll_ri)
case (V_REAL); call eval_node_set_op2_log (en, comp_ll_rr)
end select
end select
case (">")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_gt_ii)
case (V_REAL); call eval_node_set_op2_log (en, comp_gg_ir)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_gg_ri)
case (V_REAL); call eval_node_set_op2_log (en, comp_gg_rr)
end select
end select
case ("<=")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_le_ii)
case (V_REAL); call eval_node_set_op2_log (en, comp_ls_ir)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_ls_ri)
case (V_REAL); call eval_node_set_op2_log (en, comp_ls_rr)
end select
end select
case (">=")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_ge_ii)
case (V_REAL); call eval_node_set_op2_log (en, comp_gs_ir)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_gs_ri)
case (V_REAL); call eval_node_set_op2_log (en, comp_gs_rr)
end select
end select
case ("==")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_eq_ii)
case (V_REAL); call eval_node_set_op2_log (en, comp_se_ir)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_se_ri)
case (V_REAL); call eval_node_set_op2_log (en, comp_se_rr)
end select
case (V_STR)
select case (t2)
case (V_STR); call eval_node_set_op2_log (en, comp_eq_ss)
end select
end select
case ("<>")
select case (t1)
case (V_INT)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_ne_ii)
case (V_REAL); call eval_node_set_op2_log (en, comp_ns_ir)
end select
case (V_REAL)
select case (t2)
case (V_INT); call eval_node_set_op2_log (en, comp_ns_ri)
case (V_REAL); call eval_node_set_op2_log (en, comp_ns_rr)
end select
case (V_STR)
select case (t2)
case (V_STR); call eval_node_set_op2_log (en, comp_ne_ss)
end select
end select
end select
call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr)
en1%tolerance => tolerance_ptr
end if
end subroutine eval_node_compile_comparison
@ %def eval_node_compile_comparison
@
\subsubsection{Recording analysis data}
The [[record]] command is actually a logical expression which always
evaluates [[true]].
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_record_cmd (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_key, pn_tag, pn_arg
type(parse_node_t), pointer :: pn_arg1, pn_arg2, pn_arg3, pn_arg4
type(eval_node_t), pointer :: en0, en1, en2, en3, en4
real(default), pointer :: event_weight
if (debug_active (D_MODEL_F)) then
print *, "read record_cmd"; call parse_node_write (pn)
end if
pn_key => parse_node_get_sub_ptr (pn)
pn_tag => parse_node_get_next_ptr (pn_key)
pn_arg => parse_node_get_next_ptr (pn_tag)
select case (char (parse_node_get_key (pn_key)))
case ("record")
call var_list%get_rptr (var_str ("event_weight"), event_weight)
case ("record_unweighted")
event_weight => null ()
case ("record_excess")
call var_list%get_rptr (var_str ("event_excess"), event_weight)
end select
select case (char (parse_node_get_rule_key (pn_tag)))
case ("analysis_id")
allocate (en0)
call eval_node_init_string (en0, parse_node_get_string (pn_tag))
case default
call eval_node_compile_sexpr (en0, pn_tag, var_list)
end select
allocate (en)
if (associated (pn_arg)) then
pn_arg1 => parse_node_get_sub_ptr (pn_arg)
call eval_node_compile_expr (en1, pn_arg1, var_list)
if (en1%result_type == V_INT) &
call insert_conversion_node (en1, V_REAL)
pn_arg2 => parse_node_get_next_ptr (pn_arg1)
if (associated (pn_arg2)) then
call eval_node_compile_expr (en2, pn_arg2, var_list)
if (en2%result_type == V_INT) &
call insert_conversion_node (en2, V_REAL)
pn_arg3 => parse_node_get_next_ptr (pn_arg2)
if (associated (pn_arg3)) then
call eval_node_compile_expr (en3, pn_arg3, var_list)
if (en3%result_type == V_INT) &
call insert_conversion_node (en3, V_REAL)
pn_arg4 => parse_node_get_next_ptr (pn_arg3)
if (associated (pn_arg4)) then
call eval_node_compile_expr (en4, pn_arg4, var_list)
if (en4%result_type == V_INT) &
call insert_conversion_node (en4, V_REAL)
call eval_node_init_record_cmd &
(en, event_weight, en0, en1, en2, en3, en4)
else
call eval_node_init_record_cmd &
(en, event_weight, en0, en1, en2, en3)
end if
else
call eval_node_init_record_cmd (en, event_weight, en0, en1, en2)
end if
else
call eval_node_init_record_cmd (en, event_weight, en0, en1)
end if
else
call eval_node_init_record_cmd (en, event_weight, en0)
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done record_cmd"
end if
end subroutine eval_node_compile_record_cmd
@ %def eval_node_compile_record_cmd
@
\subsubsection{Particle-list expressions}
A particle expression is a subevent or a concatenation of
particle-list terms (using \verb|join|).
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_pexpr (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_pterm, pn_concatenation, pn_op, pn_arg
type(eval_node_t), pointer :: en1, en2
type(subevt_t) :: subevt
if (debug_active (D_MODEL_F)) then
print *, "read pexpr"; call parse_node_write (pn)
end if
pn_pterm => parse_node_get_sub_ptr (pn)
call eval_node_compile_pterm (en, pn_pterm, var_list)
pn_concatenation => &
parse_node_get_next_ptr (pn_pterm, tag="pconcatenation")
do while (associated (pn_concatenation))
pn_op => parse_node_get_sub_ptr (pn_concatenation)
pn_arg => parse_node_get_next_ptr (pn_op)
en1 => en
call eval_node_compile_pterm (en2, pn_arg, var_list)
allocate (en)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
call subevt_join (subevt, en1%pval, en2%pval)
call eval_node_init_subevt (en, subevt)
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch &
(en, var_str ("join"), V_SEV, en1, en2)
call eval_node_set_op2_sev (en, join_pp)
end if
pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done pexpr"
end if
end subroutine eval_node_compile_pexpr
@ %def eval_node_compile_pexpr
@ A particle term is a subevent or a combination of
particle-list values (using \verb|combine|).
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_pterm (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_pvalue, pn_combination, pn_op, pn_arg
type(eval_node_t), pointer :: en1, en2
type(subevt_t) :: subevt
if (debug_active (D_MODEL_F)) then
print *, "read pterm"; call parse_node_write (pn)
end if
pn_pvalue => parse_node_get_sub_ptr (pn)
call eval_node_compile_pvalue (en, pn_pvalue, var_list)
pn_combination => &
parse_node_get_next_ptr (pn_pvalue, tag="pcombination")
do while (associated (pn_combination))
pn_op => parse_node_get_sub_ptr (pn_combination)
pn_arg => parse_node_get_next_ptr (pn_op)
en1 => en
call eval_node_compile_pvalue (en2, pn_arg, var_list)
allocate (en)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
call subevt_combine (subevt, en1%pval, en2%pval)
call eval_node_init_subevt (en, subevt)
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch &
(en, var_str ("combine"), V_SEV, en1, en2)
call eval_node_set_op2_sev (en, combine_pp)
end if
pn_combination => parse_node_get_next_ptr (pn_combination)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done pterm"
end if
end subroutine eval_node_compile_pterm
@ %def eval_node_compile_pterm
@ A particle-list value is a PDG-code array, a particle identifier, a
variable, a (grouped) pexpr, a block pexpr, a conditional, or a
particle-list function.
The [[cexpr]] node is responsible for transforming a constant PDG-code
array into a subevent. It takes the code array as its first
argument, the event subevent as its second argument, and the
requested particle type (incoming/outgoing) as its zero-th argument.
The result is the list of particles in the event that match the code
array.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_pvalue (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_prefix_cexpr
type(eval_node_t), pointer :: en1, en2, en0
type(string_t) :: key
type(subevt_t), pointer :: evt_ptr
logical, pointer :: known
if (debug_active (D_MODEL_F)) then
print *, "read pvalue"; call parse_node_write (pn)
end if
select case (char (parse_node_get_rule_key (pn)))
case ("pexpr_src")
call eval_node_compile_prefix_cexpr (en1, pn, var_list)
allocate (en2)
if (var_list%contains (var_str ("@evt"))) then
call var_list%get_pptr (var_str ("@evt"), evt_ptr, known)
call eval_node_init_subevt_ptr (en2, var_str ("@evt"), evt_ptr, known)
allocate (en)
call eval_node_init_branch &
(en, var_str ("prt_selection"), V_SEV, en1, en2)
call eval_node_set_op2_sev (en, select_pdg_ca)
allocate (en0)
pn_prefix_cexpr => parse_node_get_sub_ptr (pn)
key = parse_node_get_rule_key (pn_prefix_cexpr)
select case (char (key))
case ("beam_prt")
call eval_node_init_int (en0, PRT_BEAM)
en%arg0 => en0
case ("incoming_prt")
call eval_node_init_int (en0, PRT_INCOMING)
en%arg0 => en0
case ("outgoing_prt")
call eval_node_init_int (en0, PRT_OUTGOING)
en%arg0 => en0
case ("unspecified_prt")
call eval_node_init_int (en0, PRT_OUTGOING)
en%arg0 => en0
end select
else
call parse_node_write (pn)
call msg_bug (" Missing event data while compiling pvalue")
end if
case ("pvariable")
call eval_node_compile_variable (en, pn, var_list, V_SEV)
case ("pexpr")
call eval_node_compile_pexpr (en, pn, var_list)
case ("block_pexpr")
call eval_node_compile_block_expr (en, pn, var_list, V_SEV)
case ("conditional_pexpr")
call eval_node_compile_conditional (en, pn, var_list, V_SEV)
case ("join_fun", "combine_fun", "collect_fun", "cluster_fun", &
"select_fun", "extract_fun", "sort_fun", "select_b_jet_fun", &
"select_non_bjet_fun", "select_c_jet_fun", &
"select_light_jet_fun", "photon_reco_fun")
call eval_node_compile_prt_function (en, pn, var_list)
case default
call parse_node_mismatch &
("prefix_cexpr|pvariable|" // &
"grouped_pexpr|block_pexpr|conditional_pexpr|" // &
"prt_function", pn)
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done pvalue"
end if
end subroutine eval_node_compile_pvalue
@ %def eval_node_compile_pvalue
@
\subsubsection{Particle functions}
This combines the treatment of 'join', 'combine', 'collect', 'cluster',
'select', and 'extract', as well as the functions for $b$, $c$ and
light jet selection and photon recombnation which all have the same
syntax. The one or two argument nodes are allocated. If there is a
condition, the condition node is also allocated as a logical
expression, for which the variable list is augmented by the
appropriate (unary/binary) observables.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_prt_function (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args
type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2
type(eval_node_t), pointer :: en0, en1, en2
type(string_t) :: key
if (debug_active (D_MODEL_F)) then
print *, "read prt_function"; call parse_node_write (pn)
end if
pn_clause => parse_node_get_sub_ptr (pn)
pn_key => parse_node_get_sub_ptr (pn_clause)
pn_cond => parse_node_get_next_ptr (pn_key)
if (associated (pn_cond)) &
pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
pn_args => parse_node_get_next_ptr (pn_clause)
pn_arg1 => parse_node_get_sub_ptr (pn_args)
pn_arg2 => parse_node_get_next_ptr (pn_arg1)
key = parse_node_get_key (pn_key)
call eval_node_compile_pexpr (en1, pn_arg1, var_list)
allocate (en)
if (.not. associated (pn_arg2)) then
select case (char (key))
case ("collect")
call eval_node_init_prt_fun_unary (en, en1, key, collect_p)
case ("cluster")
if (fastjet_available ()) then
call fastjet_init ()
else
call msg_fatal &
("'cluster' function requires FastJet, which is not enabled")
end if
en1%var_list => var_list
call eval_node_init_prt_fun_unary (en, en1, key, cluster_p)
call var_list%get_iptr (var_str ("jet_algorithm"), en1%jet_algorithm)
call var_list%get_rptr (var_str ("jet_r"), en1%jet_r)
call var_list%get_rptr (var_str ("jet_p"), en1%jet_p)
call var_list%get_rptr (var_str ("jet_ycut"), en1%jet_ycut)
call var_list%get_rptr (var_str ("jet_dcut"), en1%jet_dcut)
case ("select")
call eval_node_init_prt_fun_unary (en, en1, key, select_p)
case ("extract")
call eval_node_init_prt_fun_unary (en, en1, key, extract_p)
case ("sort")
call eval_node_init_prt_fun_unary (en, en1, key, sort_p)
case ("select_b_jet")
call eval_node_init_prt_fun_unary (en, en1, key, select_b_jet_p)
case ("select_non_b_jet")
call eval_node_init_prt_fun_unary (en, en1, key, select_non_b_jet_p)
case ("select_c_jet")
call eval_node_init_prt_fun_unary (en, en1, key, select_c_jet_p)
case ("select_light_jet")
call eval_node_init_prt_fun_unary (en, en1, key, select_light_jet_p)
case default
call msg_bug (" Unary particle function '" // char (key) // &
"' undefined")
end select
else
call eval_node_compile_pexpr (en2, pn_arg2, var_list)
select case (char (key))
case ("join")
call eval_node_init_prt_fun_binary (en, en1, en2, key, join_pp)
case ("combine")
call eval_node_init_prt_fun_binary (en, en1, en2, key, combine_pp)
case ("collect")
call eval_node_init_prt_fun_binary (en, en1, en2, key, collect_pp)
case ("select")
call eval_node_init_prt_fun_binary (en, en1, en2, key, select_pp)
case ("sort")
call eval_node_init_prt_fun_binary (en, en1, en2, key, sort_pp)
case ("photon_recombination")
en1%var_list => var_list
call eval_node_init_prt_fun_binary &
(en, en1, en2, key, photon_recombination_pp)
call var_list%get_rptr (var_str ("photon_rec_r0"), en1%photon_rec_r0)
case default
call msg_bug (" Binary particle function '" // char (key) // &
"' undefined")
end select
end if
if (associated (pn_cond)) then
call eval_node_set_observables (en, var_list)
select case (char (key))
case ("extract", "sort")
call eval_node_compile_expr (en0, pn_arg0, en%var_list)
case default
call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
end select
en%arg0 => en0
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done prt_function"
end if
end subroutine eval_node_compile_prt_function
@ %def eval_node_compile_prt_function
@ The [[eval]] expression is similar, but here the expression [[arg0]]
is mandatory, and the whole thing evaluates to a numeric value.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_eval_function (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_key, pn_arg0, pn_args, pn_arg1, pn_arg2
type(eval_node_t), pointer :: en0, en1, en2
type(string_t) :: key
if (debug_active (D_MODEL_F)) then
print *, "read eval_function"; call parse_node_write (pn)
end if
pn_key => parse_node_get_sub_ptr (pn)
pn_arg0 => parse_node_get_next_ptr (pn_key)
pn_args => parse_node_get_next_ptr (pn_arg0)
pn_arg1 => parse_node_get_sub_ptr (pn_args)
pn_arg2 => parse_node_get_next_ptr (pn_arg1)
key = parse_node_get_key (pn_key)
call eval_node_compile_pexpr (en1, pn_arg1, var_list)
allocate (en)
if (.not. associated (pn_arg2)) then
call eval_node_init_eval_fun_unary (en, en1, key)
else
call eval_node_compile_pexpr (en2, pn_arg2, var_list)
call eval_node_init_eval_fun_binary (en, en1, en2, key)
end if
call eval_node_set_observables (en, var_list)
call eval_node_compile_expr (en0, pn_arg0, en%var_list)
if (en0%result_type /= V_REAL) &
call msg_fatal (" 'eval' function does not result in real value")
call eval_node_set_expr (en, en0)
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done eval_function"
end if
end subroutine eval_node_compile_eval_function
@ %def eval_node_compile_eval_function
@ Logical functions of subevents. For [[photon_isolation]] there is a
conditional selection expression instead of a mandatory logical
expression, so in the case of the absence of the selection we have to
create a logical [[eval_node_t]] with value [[.true.]].
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_log_function (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_clause, pn_key, pn_str, pn_cond
type(parse_node_t), pointer :: pn_arg0, pn_args, pn_arg1, pn_arg2
type(eval_node_t), pointer :: en0, en1, en2
type(string_t) :: key
if (debug_active (D_MODEL_F)) then
print *, "read log_function"; call parse_node_write (pn)
end if
select case (char (parse_node_get_rule_key (pn)))
case ("all_fun", "any_fun", "no_fun")
pn_key => parse_node_get_sub_ptr (pn)
pn_arg0 => parse_node_get_next_ptr (pn_key)
pn_args => parse_node_get_next_ptr (pn_arg0)
case ("photon_isolation_fun")
pn_clause => parse_node_get_sub_ptr (pn)
pn_key => parse_node_get_sub_ptr (pn_clause)
pn_cond => parse_node_get_next_ptr (pn_key)
if (associated (pn_cond)) then
pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
else
pn_arg0 => null ()
end if
pn_args => parse_node_get_next_ptr (pn_clause)
case default
call parse_node_mismatch ("all_fun|any_fun|" // &
"no_fun|photon_isolation_fun", pn)
end select
pn_arg1 => parse_node_get_sub_ptr (pn_args)
pn_arg2 => parse_node_get_next_ptr (pn_arg1)
key = parse_node_get_key (pn_key)
call eval_node_compile_pexpr (en1, pn_arg1, var_list)
allocate (en)
if (.not. associated (pn_arg2)) then
select case (char (key))
case ("all")
call eval_node_init_log_fun_unary (en, en1, key, all_p)
case ("any")
call eval_node_init_log_fun_unary (en, en1, key, any_p)
case ("no")
call eval_node_init_log_fun_unary (en, en1, key, no_p)
case default
call msg_bug ("Unary logical particle function '" // char (key) // &
"' undefined")
end select
else
call eval_node_compile_pexpr (en2, pn_arg2, var_list)
select case (char (key))
case ("all")
call eval_node_init_log_fun_binary (en, en1, en2, key, all_pp)
case ("any")
call eval_node_init_log_fun_binary (en, en1, en2, key, any_pp)
case ("no")
call eval_node_init_log_fun_binary (en, en1, en2, key, no_pp)
case ("photon_isolation")
en1%var_list => var_list
call var_list%get_rptr (var_str ("photon_iso_eps"), en1%photon_iso_eps)
call var_list%get_rptr (var_str ("photon_iso_n"), en1%photon_iso_n)
call var_list%get_rptr (var_str ("photon_iso_r0"), en1%photon_iso_r0)
call eval_node_init_log_fun_binary (en, en1, en2, key, photon_isolation_pp)
case default
call msg_bug ("Binary logical particle function '" // char (key) // &
"' undefined")
end select
end if
if (associated (pn_arg0)) then
call eval_node_set_observables (en, var_list)
select case (char (key))
case ("all", "any", "no", "photon_isolation")
call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
case default
call msg_bug ("Compiling logical particle function: missing mode")
end select
call eval_node_set_expr (en, en0, V_LOG)
else
select case (char (key))
case ("photon_isolation")
allocate (en0)
call eval_node_init_log (en0, .true.)
call eval_node_set_expr (en, en0, V_LOG)
case default
call msg_bug ("Only photon isolation can be called unconditionally")
end select
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done log_function"
end if
end subroutine eval_node_compile_log_function
@ %def eval_node_compile_log_function
@ Numeric functions of subevents.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_numeric_function (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args
type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2
type(eval_node_t), pointer :: en0, en1, en2
type(string_t) :: key
if (debug_active (D_MODEL_F)) then
print *, "read numeric_function"; call parse_node_write (pn)
end if
select case (char (parse_node_get_rule_key (pn)))
case ("count_fun")
pn_clause => parse_node_get_sub_ptr (pn)
pn_key => parse_node_get_sub_ptr (pn_clause)
pn_cond => parse_node_get_next_ptr (pn_key)
if (associated (pn_cond)) then
pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2)
else
pn_arg0 => null ()
end if
pn_args => parse_node_get_next_ptr (pn_clause)
end select
pn_arg1 => parse_node_get_sub_ptr (pn_args)
pn_arg2 => parse_node_get_next_ptr (pn_arg1)
key = parse_node_get_key (pn_key)
call eval_node_compile_pexpr (en1, pn_arg1, var_list)
allocate (en)
if (.not. associated (pn_arg2)) then
select case (char (key))
case ("count")
call eval_node_init_int_fun_unary (en, en1, key, count_a)
case default
call msg_bug ("Unary subevent function '" // char (key) // &
"' undefined")
end select
else
call eval_node_compile_pexpr (en2, pn_arg2, var_list)
select case (char (key))
case ("count")
call eval_node_init_int_fun_binary (en, en1, en2, key, count_pp)
case default
call msg_bug ("Binary subevent function '" // char (key) // &
"' undefined")
end select
end if
if (associated (pn_arg0)) then
call eval_node_set_observables (en, var_list)
select case (char (key))
case ("count")
call eval_node_compile_lexpr (en0, pn_arg0, en%var_list)
call eval_node_set_expr (en, en0, V_INT)
end select
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done numeric_function"
end if
end subroutine eval_node_compile_numeric_function
@ %def eval_node_compile_numeric_function
@
\subsubsection{PDG-code arrays}
A PDG-code expression is (optionally) prefixed by [[beam]], [[incoming]], or
[[outgoing]], a block, or a conditional. In any case, it evaluates to
a constant.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_prefix_cexpr (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_avalue, pn_prt
type(string_t) :: key
if (debug_active (D_MODEL_F)) then
print *, "read prefix_cexpr"; call parse_node_write (pn)
end if
pn_avalue => parse_node_get_sub_ptr (pn)
key = parse_node_get_rule_key (pn_avalue)
select case (char (key))
case ("beam_prt")
pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
call eval_node_compile_cexpr (en, pn_prt, var_list)
case ("incoming_prt")
pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
call eval_node_compile_cexpr (en, pn_prt, var_list)
case ("outgoing_prt")
pn_prt => parse_node_get_sub_ptr (pn_avalue, 2)
call eval_node_compile_cexpr (en, pn_prt, var_list)
case ("unspecified_prt")
pn_prt => parse_node_get_sub_ptr (pn_avalue, 1)
call eval_node_compile_cexpr (en, pn_prt, var_list)
case default
call parse_node_mismatch &
("beam_prt|incoming_prt|outgoing_prt|unspecified_prt", &
pn_avalue)
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done prefix_cexpr"
end if
end subroutine eval_node_compile_prefix_cexpr
@ %def eval_node_compile_prefix_cexpr
@ A PDG array is a string of PDG code definitions (or aliases),
concatenated by ':'. The code definitions may be variables which are
not defined at compile time, so we have to allocate sub-nodes. This
analogous to [[eval_node_compile_term]].
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_cexpr (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_prt, pn_concatenation
type(eval_node_t), pointer :: en1, en2
type(pdg_array_t) :: aval
if (debug_active (D_MODEL_F)) then
print *, "read cexpr"; call parse_node_write (pn)
end if
pn_prt => parse_node_get_sub_ptr (pn)
call eval_node_compile_avalue (en, pn_prt, var_list)
pn_concatenation => parse_node_get_next_ptr (pn_prt)
do while (associated (pn_concatenation))
pn_prt => parse_node_get_sub_ptr (pn_concatenation, 2)
en1 => en
call eval_node_compile_avalue (en2, pn_prt, var_list)
allocate (en)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
call concat_cc (aval, en1, en2)
call eval_node_init_pdg_array (en, aval)
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch (en, var_str (":"), V_PDG, en1, en2)
call eval_node_set_op2_pdg (en, concat_cc)
end if
pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done cexpr"
end if
end subroutine eval_node_compile_cexpr
@ %def eval_node_compile_cexpr
@ Compile a PDG-code type value. It may be either an integer expression
or a variable of type PDG array, optionally quoted.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_avalue (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
if (debug_active (D_MODEL_F)) then
print *, "read avalue"; call parse_node_write (pn)
end if
select case (char (parse_node_get_rule_key (pn)))
case ("pdg_code")
call eval_node_compile_pdg_code (en, pn, var_list)
case ("cvariable", "variable", "prt_name")
call eval_node_compile_cvariable (en, pn, var_list)
case ("cexpr")
call eval_node_compile_cexpr (en, pn, var_list)
case ("block_cexpr")
call eval_node_compile_block_expr (en, pn, var_list, V_PDG)
case ("conditional_cexpr")
call eval_node_compile_conditional (en, pn, var_list, V_PDG)
case default
call parse_node_mismatch &
("grouped_cexpr|block_cexpr|conditional_cexpr|" // &
"pdg_code|cvariable|prt_name", pn)
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done avalue"
end if
end subroutine eval_node_compile_avalue
@ %def eval_node_compile_avalue
@ Compile a PDG-code expression, which is the key [[PDG]] with an
integer expression as argument. The procedure is analogous to
[[eval_node_compile_unary_function]].
<<Eval trees: procedures>>=
subroutine eval_node_compile_pdg_code (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in), target :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_arg
type(eval_node_t), pointer :: en1
type(string_t) :: key
type(pdg_array_t) :: aval
integer :: t
if (debug_active (D_MODEL_F)) then
print *, "read PDG code"; call parse_node_write (pn)
end if
pn_arg => parse_node_get_sub_ptr (pn, 2)
call eval_node_compile_expr &
(en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list)
t = en1%result_type
allocate (en)
key = "PDG"
if (en1%type == EN_CONSTANT) then
select case (t)
case (V_INT)
call pdg_i (aval, en1)
call eval_node_init_pdg_array (en, aval)
case default; call eval_type_error (pn, char (key), t)
end select
call eval_node_final_rec (en1)
deallocate (en1)
else
select case (t)
case (V_INT); call eval_node_set_op1_pdg (en, pdg_i)
case default; call eval_type_error (pn, char (key), t)
end select
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done function"
end if
end subroutine eval_node_compile_pdg_code
@ %def eval_node_compile_pdg_code
@ This is entirely analogous to [[eval_node_compile_variable]].
However, PDG-array variables occur in different contexts.
To avoid name clashes between PDG-array variables and ordinary
variables, we prepend a character ([[*]]). This is not visible to the
user.
<<Eval trees: procedures>>=
subroutine eval_node_compile_cvariable (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in), target :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_name
type(string_t) :: var_name
type(pdg_array_t), pointer :: aptr
type(pdg_array_t), target, save :: no_aval
logical, pointer :: known
logical, target, save :: unknown = .false.
if (debug_active (D_MODEL_F)) then
print *, "read cvariable"; call parse_node_write (pn)
end if
pn_name => pn
var_name = parse_node_get_string (pn_name)
allocate (en)
if (var_list%contains (var_name)) then
call var_list%get_aptr (var_name, aptr, known)
call eval_node_init_pdg_array_ptr (en, var_name, aptr, known)
else
call parse_node_write (pn)
call msg_error ("This PDG-array variable is undefined at this point")
call eval_node_init_pdg_array_ptr (en, var_name, no_aval, unknown)
end if
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done cvariable"
end if
end subroutine eval_node_compile_cvariable
@ %def eval_node_compile_cvariable
@
\subsubsection{String expressions}
A string expression is either a string value or a concatenation of
string values.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_sexpr (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_svalue, pn_concatenation, pn_op, pn_arg
type(eval_node_t), pointer :: en1, en2
type(string_t) :: string
if (debug_active (D_MODEL_F)) then
print *, "read sexpr"; call parse_node_write (pn)
end if
pn_svalue => parse_node_get_sub_ptr (pn)
call eval_node_compile_svalue (en, pn_svalue, var_list)
pn_concatenation => &
parse_node_get_next_ptr (pn_svalue, tag="str_concatenation")
do while (associated (pn_concatenation))
pn_op => parse_node_get_sub_ptr (pn_concatenation)
pn_arg => parse_node_get_next_ptr (pn_op)
en1 => en
call eval_node_compile_svalue (en2, pn_arg, var_list)
allocate (en)
if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then
call concat_ss (string, en1, en2)
call eval_node_init_string (en, string)
call eval_node_final_rec (en1)
call eval_node_final_rec (en2)
deallocate (en1, en2)
else
call eval_node_init_branch &
(en, var_str ("concat"), V_STR, en1, en2)
call eval_node_set_op2_str (en, concat_ss)
end if
pn_concatenation => parse_node_get_next_ptr (pn_concatenation)
end do
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done sexpr"
end if
end subroutine eval_node_compile_sexpr
@ %def eval_node_compile_sexpr
@ A string value is a string literal, a
variable, a (grouped) sexpr, a block sexpr, or a conditional.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_svalue (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
if (debug_active (D_MODEL_F)) then
print *, "read svalue"; call parse_node_write (pn)
end if
select case (char (parse_node_get_rule_key (pn)))
case ("svariable")
call eval_node_compile_variable (en, pn, var_list, V_STR)
case ("sexpr")
call eval_node_compile_sexpr (en, pn, var_list)
case ("block_sexpr")
call eval_node_compile_block_expr (en, pn, var_list, V_STR)
case ("conditional_sexpr")
call eval_node_compile_conditional (en, pn, var_list, V_STR)
case ("sprintf_fun")
call eval_node_compile_sprintf (en, pn, var_list)
case ("string_literal")
allocate (en)
call eval_node_init_string (en, parse_node_get_string (pn))
case default
call parse_node_mismatch &
("svariable|" // &
"grouped_sexpr|block_sexpr|conditional_sexpr|" // &
"string_function|string_literal", pn)
end select
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done svalue"
end if
end subroutine eval_node_compile_svalue
@ %def eval_node_compile_svalue
@ There is currently one string function, [[sprintf]]. For
[[sprintf]], the first argument (no brackets) is the format string, the
optional arguments in brackets are the expressions or variables to be
formatted.
<<Eval trees: procedures>>=
recursive subroutine eval_node_compile_sprintf (en, pn, var_list)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_clause, pn_key, pn_args
type(parse_node_t), pointer :: pn_arg0
type(eval_node_t), pointer :: en0, en1
integer :: n_args
type(string_t) :: key
if (debug_active (D_MODEL_F)) then
print *, "read sprintf_fun"; call parse_node_write (pn)
end if
pn_clause => parse_node_get_sub_ptr (pn)
pn_key => parse_node_get_sub_ptr (pn_clause)
pn_arg0 => parse_node_get_next_ptr (pn_key)
pn_args => parse_node_get_next_ptr (pn_clause)
call eval_node_compile_sexpr (en0, pn_arg0, var_list)
if (associated (pn_args)) then
call eval_node_compile_sprintf_args (en1, pn_args, var_list, n_args)
else
n_args = 0
en1 => null ()
end if
allocate (en)
key = parse_node_get_key (pn_key)
call eval_node_init_format_string (en, en0, en1, key, n_args)
if (debug_active (D_MODEL_F)) then
call eval_node_write (en)
print *, "done sprintf_fun"
end if
end subroutine eval_node_compile_sprintf
@ %def eval_node_compile_sprintf
<<Eval trees: procedures>>=
subroutine eval_node_compile_sprintf_args (en, pn, var_list, n_args)
type(eval_node_t), pointer :: en
type(parse_node_t), intent(in) :: pn
type(var_list_t), intent(in), target :: var_list
integer, intent(out) :: n_args
type(parse_node_t), pointer :: pn_arg
integer :: i
type(eval_node_t), pointer :: en1, en2
n_args = parse_node_get_n_sub (pn)
en => null ()
do i = n_args, 1, -1
pn_arg => parse_node_get_sub_ptr (pn, i)
select case (char (parse_node_get_rule_key (pn_arg)))
case ("lvariable")
call eval_node_compile_variable (en1, pn_arg, var_list, V_LOG)
case ("svariable")
call eval_node_compile_variable (en1, pn_arg, var_list, V_STR)
case ("expr")
call eval_node_compile_expr (en1, pn_arg, var_list)
case default
call parse_node_mismatch ("variable|svariable|lvariable|expr", pn_arg)
end select
if (associated (en)) then
en2 => en
allocate (en)
call eval_node_init_branch &
(en, var_str ("sprintf_arg"), V_NONE, en1, en2)
else
allocate (en)
call eval_node_init_branch &
(en, var_str ("sprintf_arg"), V_NONE, en1)
end if
end do
end subroutine eval_node_compile_sprintf_args
@ %def eval_node_compile_sprintf_args
@ Evaluation. We allocate the argument list and apply the Fortran wrapper for
the [[sprintf]] function.
<<Eval trees: procedures>>=
subroutine evaluate_sprintf (string, n_args, en_fmt, en_arg)
type(string_t), intent(out) :: string
integer, intent(in) :: n_args
type(eval_node_t), pointer :: en_fmt
type(eval_node_t), intent(in), optional, target :: en_arg
type(eval_node_t), pointer :: en_branch, en_var
type(sprintf_arg_t), dimension(:), allocatable :: arg
type(string_t) :: fmt
logical :: autoformat
integer :: i, j, sprintf_argc
autoformat = .not. associated (en_fmt)
if (autoformat) fmt = ""
if (present (en_arg)) then
sprintf_argc = 0
en_branch => en_arg
do i = 1, n_args
select case (en_branch%arg1%result_type)
case (V_CMPLX); sprintf_argc = sprintf_argc + 2
case default ; sprintf_argc = sprintf_argc + 1
end select
en_branch => en_branch%arg2
end do
allocate (arg (sprintf_argc))
j = 1
en_branch => en_arg
do i = 1, n_args
en_var => en_branch%arg1
select case (en_var%result_type)
case (V_LOG)
call sprintf_arg_init (arg(j), en_var%lval)
if (autoformat) fmt = fmt // "%s "
case (V_INT);
call sprintf_arg_init (arg(j), en_var%ival)
if (autoformat) fmt = fmt // "%i "
case (V_REAL);
call sprintf_arg_init (arg(j), en_var%rval)
if (autoformat) fmt = fmt // "%g "
case (V_STR)
call sprintf_arg_init (arg(j), en_var%sval)
if (autoformat) fmt = fmt // "%s "
case (V_CMPLX)
call sprintf_arg_init (arg(j), real (en_var%cval, default))
j = j + 1
call sprintf_arg_init (arg(j), aimag (en_var%cval))
if (autoformat) fmt = fmt // "(%g + %g * I) "
case default
call eval_node_write (en_var)
call msg_error ("sprintf is implemented " &
// "for logical, integer, real, and string values only")
end select
j = j + 1
en_branch => en_branch%arg2
end do
else
allocate (arg(0))
end if
if (autoformat) then
string = sprintf (trim (fmt), arg)
else
string = sprintf (en_fmt%sval, arg)
end if
end subroutine evaluate_sprintf
@ %def evaluate_sprintf
@
\subsection{Auxiliary functions for the compiler}
Issue an error that the current node could not be compiled because of
type mismatch:
<<Eval trees: procedures>>=
subroutine eval_type_error (pn, string, t)
type(parse_node_t), intent(in) :: pn
character(*), intent(in) :: string
integer, intent(in) :: t
type(string_t) :: type
select case (t)
case (V_NONE); type = "(none)"
case (V_LOG); type = "'logical'"
case (V_INT); type = "'integer'"
case (V_REAL); type = "'real'"
case (V_CMPLX); type = "'complex'"
case default; type = "(unknown)"
end select
call parse_node_write (pn)
call msg_fatal (" The " // string // &
" operation is not defined for the given argument type " // &
char (type))
end subroutine eval_type_error
@ %def eval_type_error
@
If two numerics are combined, the result is integer if both
arguments are integer, if one is integer and the other real or both
are real, than its argument is real, otherwise complex.
<<Eval trees: procedures>>=
function numeric_result_type (t1, t2) result (t)
integer, intent(in) :: t1, t2
integer :: t
if (t1 == V_INT .and. t2 == V_INT) then
t = V_INT
else if (t1 == V_INT .and. t2 == V_REAL) then
t = V_REAL
else if (t1 == V_REAL .and. t2 == V_INT) then
t = V_REAL
else if (t1 == V_REAL .and. t2 == V_REAL) then
t = V_REAL
else
t = V_CMPLX
end if
end function numeric_result_type
@ %def numeric_type
@
\subsection{Evaluation}
Evaluation is done recursively. For leaf nodes nothing is to be done.
Evaluating particle-list functions: First, we evaluate the particle
lists. If a condition is present, we assign the particle pointers of
the condition node to the allocated particle entries in the parent
node, keeping in mind that the observables in the variable stack used
for the evaluation of the condition also contain pointers to these
entries. Then, the assigned procedure is evaluated, which sets the
subevent in the parent node. If required, the procedure
evaluates the condition node once for each (pair of) particles to
determine the result.
<<Eval trees: procedures>>=
recursive subroutine eval_node_evaluate (en)
type(eval_node_t), intent(inout) :: en
logical :: exist
select case (en%type)
case (EN_UNARY)
if (associated (en%arg1)) then
call eval_node_evaluate (en%arg1)
en%value_is_known = en%arg1%value_is_known
else
en%value_is_known = .false.
end if
if (en%value_is_known) then
select case (en%result_type)
case (V_LOG); en%lval = en%op1_log (en%arg1)
case (V_INT); en%ival = en%op1_int (en%arg1)
case (V_REAL); en%rval = en%op1_real (en%arg1)
case (V_CMPLX); en%cval = en%op1_cmplx (en%arg1)
case (V_PDG);
call en%op1_pdg (en%aval, en%arg1)
case (V_SEV)
if (associated (en%arg0)) then
call en%op1_sev (en%pval, en%arg1, en%arg0)
else
call en%op1_sev (en%pval, en%arg1)
end if
case (V_STR)
call en%op1_str (en%sval, en%arg1)
end select
end if
case (EN_BINARY)
if (associated (en%arg1) .and. associated (en%arg2)) then
call eval_node_evaluate (en%arg1)
call eval_node_evaluate (en%arg2)
en%value_is_known = &
en%arg1%value_is_known .and. en%arg2%value_is_known
else
en%value_is_known = .false.
end if
if (en%value_is_known) then
select case (en%result_type)
case (V_LOG); en%lval = en%op2_log (en%arg1, en%arg2)
case (V_INT); en%ival = en%op2_int (en%arg1, en%arg2)
case (V_REAL); en%rval = en%op2_real (en%arg1, en%arg2)
case (V_CMPLX); en%cval = en%op2_cmplx (en%arg1, en%arg2)
case (V_PDG)
call en%op2_pdg (en%aval, en%arg1, en%arg2)
case (V_SEV)
if (associated (en%arg0)) then
call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0)
else
call en%op2_sev (en%pval, en%arg1, en%arg2)
end if
case (V_STR)
call en%op2_str (en%sval, en%arg1, en%arg2)
end select
end if
case (EN_BLOCK)
if (associated (en%arg1) .and. associated (en%arg0)) then
call eval_node_evaluate (en%arg1)
call eval_node_evaluate (en%arg0)
en%value_is_known = en%arg0%value_is_known
else
en%value_is_known = .false.
end if
if (en%value_is_known) then
select case (en%result_type)
case (V_LOG); en%lval = en%arg0%lval
case (V_INT); en%ival = en%arg0%ival
case (V_REAL); en%rval = en%arg0%rval
case (V_CMPLX); en%cval = en%arg0%cval
case (V_PDG); en%aval = en%arg0%aval
case (V_SEV); en%pval = en%arg0%pval
case (V_STR); en%sval = en%arg0%sval
end select
end if
case (EN_CONDITIONAL)
if (associated (en%arg0)) then
call eval_node_evaluate (en%arg0)
en%value_is_known = en%arg0%value_is_known
else
en%value_is_known = .false.
end if
if (en%arg0%value_is_known) then
if (en%arg0%lval) then
call eval_node_evaluate (en%arg1)
en%value_is_known = en%arg1%value_is_known
if (en%value_is_known) then
select case (en%result_type)
case (V_LOG); en%lval = en%arg1%lval
case (V_INT); en%ival = en%arg1%ival
case (V_REAL); en%rval = en%arg1%rval
case (V_CMPLX); en%cval = en%arg1%cval
case (V_PDG); en%aval = en%arg1%aval
case (V_SEV); en%pval = en%arg1%pval
case (V_STR); en%sval = en%arg1%sval
end select
end if
else
call eval_node_evaluate (en%arg2)
en%value_is_known = en%arg2%value_is_known
if (en%value_is_known) then
select case (en%result_type)
case (V_LOG); en%lval = en%arg2%lval
case (V_INT); en%ival = en%arg2%ival
case (V_REAL); en%rval = en%arg2%rval
case (V_CMPLX); en%cval = en%arg2%cval
case (V_PDG); en%aval = en%arg2%aval
case (V_SEV); en%pval = en%arg2%pval
case (V_STR); en%sval = en%arg2%sval
end select
end if
end if
end if
case (EN_RECORD_CMD)
exist = .true.
en%lval = .false.
call eval_node_evaluate (en%arg0)
if (en%arg0%value_is_known) then
if (associated (en%arg1)) then
call eval_node_evaluate (en%arg1)
if (en%arg1%value_is_known) then
if (associated (en%arg2)) then
call eval_node_evaluate (en%arg2)
if (en%arg2%value_is_known) then
if (associated (en%arg3)) then
call eval_node_evaluate (en%arg3)
if (en%arg3%value_is_known) then
if (associated (en%arg4)) then
call eval_node_evaluate (en%arg4)
if (en%arg4%value_is_known) then
if (associated (en%rval)) then
call analysis_record_data (en%arg0%sval, &
en%arg1%rval, en%arg2%rval, &
en%arg3%rval, en%arg4%rval, &
weight=en%rval, exist=exist, &
success=en%lval)
else
call analysis_record_data (en%arg0%sval, &
en%arg1%rval, en%arg2%rval, &
en%arg3%rval, en%arg4%rval, &
exist=exist, success=en%lval)
end if
end if
else
if (associated (en%rval)) then
call analysis_record_data (en%arg0%sval, &
en%arg1%rval, en%arg2%rval, &
en%arg3%rval, &
weight=en%rval, exist=exist, &
success=en%lval)
else
call analysis_record_data (en%arg0%sval, &
en%arg1%rval, en%arg2%rval, &
en%arg3%rval, &
exist=exist, success=en%lval)
end if
end if
end if
else
if (associated (en%rval)) then
call analysis_record_data (en%arg0%sval, &
en%arg1%rval, en%arg2%rval, &
weight=en%rval, exist=exist, &
success=en%lval)
else
call analysis_record_data (en%arg0%sval, &
en%arg1%rval, en%arg2%rval, &
exist=exist, success=en%lval)
end if
end if
end if
else
if (associated (en%rval)) then
call analysis_record_data (en%arg0%sval, &
en%arg1%rval, &
weight=en%rval, exist=exist, success=en%lval)
else
call analysis_record_data (en%arg0%sval, &
en%arg1%rval, &
exist=exist, success=en%lval)
end if
end if
end if
else
if (associated (en%rval)) then
call analysis_record_data (en%arg0%sval, 1._default, &
weight=en%rval, exist=exist, success=en%lval)
else
call analysis_record_data (en%arg0%sval, 1._default, &
exist=exist, success=en%lval)
end if
end if
if (.not. exist) then
call msg_error ("Analysis object '" // char (en%arg0%sval) &
// "' is undefined")
en%arg0%value_is_known = .false.
end if
end if
case (EN_OBS1_INT)
en%ival = en%obs1_int (en%prt1)
en%value_is_known = .true.
case (EN_OBS2_INT)
en%ival = en%obs2_int (en%prt1, en%prt2)
en%value_is_known = .true.
case (EN_OBS1_REAL)
en%rval = en%obs1_real (en%prt1)
en%value_is_known = .true.
case (EN_OBS2_REAL)
en%rval = en%obs2_real (en%prt1, en%prt2)
en%value_is_known = .true.
case (EN_PRT_FUN_UNARY)
call eval_node_evaluate (en%arg1)
en%value_is_known = en%arg1%value_is_known
if (en%value_is_known) then
if (associated (en%arg0)) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
call en%op1_sev (en%pval, en%arg1, en%arg0)
else
call en%op1_sev (en%pval, en%arg1)
end if
end if
case (EN_PRT_FUN_BINARY)
call eval_node_evaluate (en%arg1)
call eval_node_evaluate (en%arg2)
en%value_is_known = &
en%arg1%value_is_known .and. en%arg2%value_is_known
if (en%value_is_known) then
if (associated (en%arg0)) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
en%arg0%prt2 => en%prt2
call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0)
else
call en%op2_sev (en%pval, en%arg1, en%arg2)
end if
end if
case (EN_EVAL_FUN_UNARY)
call eval_node_evaluate (en%arg1)
en%value_is_known = subevt_is_nonempty (en%arg1%pval)
if (en%value_is_known) then
en%arg0%index => en%index
en%index = 1
en%arg0%prt1 => en%prt1
en%prt1 = subevt_get_prt (en%arg1%pval, 1)
call eval_node_evaluate (en%arg0)
en%rval = en%arg0%rval
end if
case (EN_EVAL_FUN_BINARY)
call eval_node_evaluate (en%arg1)
call eval_node_evaluate (en%arg2)
en%value_is_known = &
subevt_is_nonempty (en%arg1%pval) .and. &
subevt_is_nonempty (en%arg2%pval)
if (en%value_is_known) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
en%arg0%prt2 => en%prt2
en%index = 1
call eval_pp (en%arg1, en%arg2, en%arg0, en%rval, en%value_is_known)
end if
case (EN_LOG_FUN_UNARY)
call eval_node_evaluate (en%arg1)
en%value_is_known = .true.
if (en%value_is_known) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
en%lval = en%op1_cut (en%arg1, en%arg0)
end if
case (EN_LOG_FUN_BINARY)
call eval_node_evaluate (en%arg1)
call eval_node_evaluate (en%arg2)
en%value_is_known = .true.
if (en%value_is_known) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
en%arg0%prt2 => en%prt2
en%lval = en%op2_cut (en%arg1, en%arg2, en%arg0)
end if
case (EN_INT_FUN_UNARY)
call eval_node_evaluate (en%arg1)
en%value_is_known = en%arg1%value_is_known
if (en%value_is_known) then
if (associated (en%arg0)) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
call en%op1_evi (en%ival, en%arg1, en%arg0)
else
call en%op1_evi (en%ival, en%arg1)
end if
end if
case (EN_INT_FUN_BINARY)
call eval_node_evaluate (en%arg1)
call eval_node_evaluate (en%arg2)
en%value_is_known = &
en%arg1%value_is_known .and. &
en%arg2%value_is_known
if (en%value_is_known) then
if (associated (en%arg0)) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
en%arg0%prt2 => en%prt2
call en%op2_evi (en%ival, en%arg1, en%arg2, en%arg0)
else
call en%op2_evi (en%ival, en%arg1, en%arg2)
end if
end if
case (EN_REAL_FUN_UNARY)
call eval_node_evaluate (en%arg1)
en%value_is_known = en%arg1%value_is_known
if (en%value_is_known) then
if (associated (en%arg0)) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
call en%op1_evr (en%rval, en%arg1, en%arg0)
else
call en%op1_evr (en%rval, en%arg1)
end if
end if
case (EN_REAL_FUN_BINARY)
call eval_node_evaluate (en%arg1)
call eval_node_evaluate (en%arg2)
en%value_is_known = &
en%arg1%value_is_known .and. &
en%arg2%value_is_known
if (en%value_is_known) then
if (associated (en%arg0)) then
en%arg0%index => en%index
en%arg0%prt1 => en%prt1
en%arg0%prt2 => en%prt2
call en%op2_evr (en%rval, en%arg1, en%arg2, en%arg0)
else
call en%op2_evr (en%rval, en%arg1, en%arg2)
end if
end if
case (EN_FORMAT_STR)
if (associated (en%arg0)) then
call eval_node_evaluate (en%arg0)
en%value_is_known = en%arg0%value_is_known
else
en%value_is_known = .true.
end if
if (associated (en%arg1)) then
call eval_node_evaluate (en%arg1)
en%value_is_known = &
en%value_is_known .and. en%arg1%value_is_known
if (en%value_is_known) then
call evaluate_sprintf (en%sval, en%ival, en%arg0, en%arg1)
end if
else
if (en%value_is_known) then
call evaluate_sprintf (en%sval, en%ival, en%arg0)
end if
end if
end select
if (debug2_active (D_MODEL_F)) then
print *, "eval_node_evaluate"
call eval_node_write (en)
end if
end subroutine eval_node_evaluate
@ %def eval_node_evaluate
@
\subsubsection{Test method}
This is called from a unit test: initialize a particular observable.
<<Eval trees: eval node: TBP>>=
procedure :: test_obs => eval_node_test_obs
<<Eval trees: procedures>>=
subroutine eval_node_test_obs (node, var_list, var_name)
class(eval_node_t), intent(inout) :: node
type(var_list_t), intent(in) :: var_list
type(string_t), intent(in) :: var_name
procedure(obs_unary_int), pointer :: obs1_iptr
type(prt_t), pointer :: p1
call var_list%get_obs1_iptr (var_name, obs1_iptr, p1)
call eval_node_init_obs1_int_ptr (node, var_name, obs1_iptr, p1)
end subroutine eval_node_test_obs
@ %def eval_node_test_obs
@
\subsection{Evaluation syntax}
We have two different flavors of the syntax: with and without particles.
<<Eval trees: public>>=
public :: syntax_expr
public :: syntax_pexpr
<<Eval trees: variables>>=
type(syntax_t), target, save :: syntax_expr
type(syntax_t), target, save :: syntax_pexpr
@ %def syntax_expr syntax_pexpr
@ These are for testing only and may be removed:
<<Eval trees: public>>=
public :: syntax_expr_init
public :: syntax_pexpr_init
<<Eval trees: procedures>>=
subroutine syntax_expr_init ()
type(ifile_t) :: ifile
call define_expr_syntax (ifile, particles=.false., analysis=.false.)
call syntax_init (syntax_expr, ifile)
call ifile_final (ifile)
end subroutine syntax_expr_init
subroutine syntax_pexpr_init ()
type(ifile_t) :: ifile
call define_expr_syntax (ifile, particles=.true., analysis=.false.)
call syntax_init (syntax_pexpr, ifile)
call ifile_final (ifile)
end subroutine syntax_pexpr_init
@ %def syntax_expr_init syntax_pexpr_init
<<Eval trees: public>>=
public :: syntax_expr_final
public :: syntax_pexpr_final
<<Eval trees: procedures>>=
subroutine syntax_expr_final ()
call syntax_final (syntax_expr)
end subroutine syntax_expr_final
subroutine syntax_pexpr_final ()
call syntax_final (syntax_pexpr)
end subroutine syntax_pexpr_final
@ %def syntax_expr_final syntax_pexpr_final
<<Eval trees: public>>=
public :: syntax_pexpr_write
<<Eval trees: procedures>>=
subroutine syntax_pexpr_write (unit)
integer, intent(in), optional :: unit
call syntax_write (syntax_pexpr, unit)
end subroutine syntax_pexpr_write
@ %def syntax_pexpr_write
<<Eval trees: public>>=
public :: define_expr_syntax
@ Numeric expressions.
<<Eval trees: procedures>>=
subroutine define_expr_syntax (ifile, particles, analysis)
type(ifile_t), intent(inout) :: ifile
logical, intent(in) :: particles, analysis
type(string_t) :: numeric_pexpr
type(string_t) :: var_plist, var_alias
if (particles) then
numeric_pexpr = " | numeric_pexpr"
var_plist = " | var_plist"
var_alias = " | var_alias"
else
numeric_pexpr = ""
var_plist = ""
var_alias = ""
end if
call ifile_append (ifile, "SEQ expr = subexpr addition*")
call ifile_append (ifile, "ALT subexpr = addition | term")
call ifile_append (ifile, "SEQ addition = plus_or_minus term")
call ifile_append (ifile, "SEQ term = factor multiplication*")
call ifile_append (ifile, "SEQ multiplication = times_or_over factor")
call ifile_append (ifile, "SEQ factor = value exponentiation?")
call ifile_append (ifile, "SEQ exponentiation = to_the value")
call ifile_append (ifile, "ALT plus_or_minus = '+' | '-'")
call ifile_append (ifile, "ALT times_or_over = '*' | '/'")
call ifile_append (ifile, "ALT to_the = '^' | '**'")
call ifile_append (ifile, "KEY '+'")
call ifile_append (ifile, "KEY '-'")
call ifile_append (ifile, "KEY '*'")
call ifile_append (ifile, "KEY '/'")
call ifile_append (ifile, "KEY '^'")
call ifile_append (ifile, "KEY '**'")
call ifile_append (ifile, "ALT value = signed_value | unsigned_value")
call ifile_append (ifile, "SEQ signed_value = '-' unsigned_value")
call ifile_append (ifile, "ALT unsigned_value = " // &
"numeric_value | constant | variable | " // &
"result | " // &
"grouped_expr | block_expr | conditional_expr | " // &
"unary_function | binary_function" // &
numeric_pexpr)
call ifile_append (ifile, "ALT numeric_value = integer_value | " &
// "real_value | complex_value")
call ifile_append (ifile, "SEQ integer_value = integer_literal unit_expr?")
call ifile_append (ifile, "SEQ real_value = real_literal unit_expr?")
call ifile_append (ifile, "SEQ complex_value = complex_literal unit_expr?")
call ifile_append (ifile, "INT integer_literal")
call ifile_append (ifile, "REA real_literal")
call ifile_append (ifile, "COM complex_literal")
call ifile_append (ifile, "SEQ unit_expr = unit unit_power?")
call ifile_append (ifile, "ALT unit = " // &
"TeV | GeV | MeV | keV | eV | meV | " // &
"nbarn | pbarn | fbarn | abarn | " // &
"rad | mrad | degree | '%'")
call ifile_append (ifile, "KEY TeV")
call ifile_append (ifile, "KEY GeV")
call ifile_append (ifile, "KEY MeV")
call ifile_append (ifile, "KEY keV")
call ifile_append (ifile, "KEY eV")
call ifile_append (ifile, "KEY meV")
call ifile_append (ifile, "KEY nbarn")
call ifile_append (ifile, "KEY pbarn")
call ifile_append (ifile, "KEY fbarn")
call ifile_append (ifile, "KEY abarn")
call ifile_append (ifile, "KEY rad")
call ifile_append (ifile, "KEY mrad")
call ifile_append (ifile, "KEY degree")
call ifile_append (ifile, "KEY '%'")
call ifile_append (ifile, "SEQ unit_power = '^' frac_expr")
call ifile_append (ifile, "ALT frac_expr = frac | grouped_frac")
call ifile_append (ifile, "GRO grouped_frac = ( frac_expr )")
call ifile_append (ifile, "SEQ frac = signed_int div?")
call ifile_append (ifile, "ALT signed_int = " &
// "neg_int | pos_int | integer_literal")
call ifile_append (ifile, "SEQ neg_int = '-' integer_literal")
call ifile_append (ifile, "SEQ pos_int = '+' integer_literal")
call ifile_append (ifile, "SEQ div = '/' integer_literal")
call ifile_append (ifile, "ALT constant = pi | I")
call ifile_append (ifile, "KEY pi")
call ifile_append (ifile, "KEY I")
call ifile_append (ifile, "IDE variable")
call ifile_append (ifile, "SEQ result = result_key result_arg")
call ifile_append (ifile, "ALT result_key = " // &
"num_id | integral | error")
call ifile_append (ifile, "KEY num_id")
call ifile_append (ifile, "KEY integral")
call ifile_append (ifile, "KEY error")
call ifile_append (ifile, "GRO result_arg = ( process_id )")
call ifile_append (ifile, "IDE process_id")
call ifile_append (ifile, "SEQ unary_function = fun_unary function_arg1")
call ifile_append (ifile, "SEQ binary_function = fun_binary function_arg2")
call ifile_append (ifile, "ALT fun_unary = " // &
"complex | real | int | nint | floor | ceiling | abs | conjg | sgn | " // &
"sqrt | exp | log | log10 | " // &
"sin | cos | tan | asin | acos | atan | " // &
"sinh | cosh | tanh | asinh | acosh | atanh")
call ifile_append (ifile, "KEY complex")
call ifile_append (ifile, "KEY real")
call ifile_append (ifile, "KEY int")
call ifile_append (ifile, "KEY nint")
call ifile_append (ifile, "KEY floor")
call ifile_append (ifile, "KEY ceiling")
call ifile_append (ifile, "KEY abs")
call ifile_append (ifile, "KEY conjg")
call ifile_append (ifile, "KEY sgn")
call ifile_append (ifile, "KEY sqrt")
call ifile_append (ifile, "KEY exp")
call ifile_append (ifile, "KEY log")
call ifile_append (ifile, "KEY log10")
call ifile_append (ifile, "KEY sin")
call ifile_append (ifile, "KEY cos")
call ifile_append (ifile, "KEY tan")
call ifile_append (ifile, "KEY asin")
call ifile_append (ifile, "KEY acos")
call ifile_append (ifile, "KEY atan")
call ifile_append (ifile, "KEY sinh")
call ifile_append (ifile, "KEY cosh")
call ifile_append (ifile, "KEY tanh")
call ifile_append (ifile, "KEY asinh")
call ifile_append (ifile, "KEY acosh")
call ifile_append (ifile, "KEY atanh")
call ifile_append (ifile, "ALT fun_binary = max | min | mod | modulo")
call ifile_append (ifile, "KEY max")
call ifile_append (ifile, "KEY min")
call ifile_append (ifile, "KEY mod")
call ifile_append (ifile, "KEY modulo")
call ifile_append (ifile, "ARG function_arg1 = ( expr )")
call ifile_append (ifile, "ARG function_arg2 = ( expr, expr )")
call ifile_append (ifile, "GRO grouped_expr = ( expr )")
call ifile_append (ifile, "SEQ block_expr = let var_spec in expr")
call ifile_append (ifile, "KEY let")
call ifile_append (ifile, "ALT var_spec = " // &
"var_num | var_int | var_real | var_complex | " // &
"var_logical" // var_plist // var_alias // " | var_string")
call ifile_append (ifile, "SEQ var_num = var_name '=' expr")
call ifile_append (ifile, "SEQ var_int = int var_name '=' expr")
call ifile_append (ifile, "SEQ var_real = real var_name '=' expr")
call ifile_append (ifile, "SEQ var_complex = complex var_name '=' complex_expr")
call ifile_append (ifile, "ALT complex_expr = " // &
"cexpr_real | cexpr_complex")
call ifile_append (ifile, "ARG cexpr_complex = ( expr, expr )")
call ifile_append (ifile, "SEQ cexpr_real = expr")
call ifile_append (ifile, "IDE var_name")
call ifile_append (ifile, "KEY '='")
call ifile_append (ifile, "KEY in")
call ifile_append (ifile, "SEQ conditional_expr = " // &
"if lexpr then expr maybe_elsif_expr maybe_else_expr endif")
call ifile_append (ifile, "SEQ maybe_elsif_expr = elsif_expr*")
call ifile_append (ifile, "SEQ maybe_else_expr = else_expr?")
call ifile_append (ifile, "SEQ elsif_expr = elsif lexpr then expr")
call ifile_append (ifile, "SEQ else_expr = else expr")
call ifile_append (ifile, "KEY if")
call ifile_append (ifile, "KEY then")
call ifile_append (ifile, "KEY elsif")
call ifile_append (ifile, "KEY else")
call ifile_append (ifile, "KEY endif")
call define_lexpr_syntax (ifile, particles, analysis)
call define_sexpr_syntax (ifile)
if (particles) then
call define_pexpr_syntax (ifile)
call define_cexpr_syntax (ifile)
call define_var_plist_syntax (ifile)
call define_var_alias_syntax (ifile)
call define_numeric_pexpr_syntax (ifile)
call define_logical_pexpr_syntax (ifile)
end if
end subroutine define_expr_syntax
@ %def define_expr_syntax
@ Logical expressions.
<<Eval trees: procedures>>=
subroutine define_lexpr_syntax (ifile, particles, analysis)
type(ifile_t), intent(inout) :: ifile
logical, intent(in) :: particles, analysis
type(string_t) :: logical_pexpr, record_cmd
if (particles) then
logical_pexpr = " | logical_pexpr"
else
logical_pexpr = ""
end if
if (analysis) then
record_cmd = " | record_cmd"
else
record_cmd = ""
end if
call ifile_append (ifile, "SEQ lexpr = lsinglet lsequel*")
call ifile_append (ifile, "SEQ lsequel = ';' lsinglet")
call ifile_append (ifile, "SEQ lsinglet = lterm alternative*")
call ifile_append (ifile, "SEQ alternative = or lterm")
call ifile_append (ifile, "SEQ lterm = lvalue coincidence*")
call ifile_append (ifile, "SEQ coincidence = and lvalue")
call ifile_append (ifile, "KEY ';'")
call ifile_append (ifile, "KEY or")
call ifile_append (ifile, "KEY and")
call ifile_append (ifile, "ALT lvalue = " // &
"true | false | lvariable | negation | " // &
"grouped_lexpr | block_lexpr | conditional_lexpr | " // &
"compared_expr | compared_sexpr" // &
logical_pexpr // record_cmd)
call ifile_append (ifile, "KEY true")
call ifile_append (ifile, "KEY false")
call ifile_append (ifile, "SEQ lvariable = '?' alt_lvariable")
call ifile_append (ifile, "KEY '?'")
call ifile_append (ifile, "ALT alt_lvariable = variable | grouped_lexpr")
call ifile_append (ifile, "SEQ negation = not lvalue")
call ifile_append (ifile, "KEY not")
call ifile_append (ifile, "GRO grouped_lexpr = ( lexpr )")
call ifile_append (ifile, "SEQ block_lexpr = let var_spec in lexpr")
call ifile_append (ifile, "ALT var_logical = " // &
"var_logical_new | var_logical_spec")
call ifile_append (ifile, "SEQ var_logical_new = logical var_logical_spec")
call ifile_append (ifile, "KEY logical")
call ifile_append (ifile, "SEQ var_logical_spec = '?' var_name = lexpr")
call ifile_append (ifile, "SEQ conditional_lexpr = " // &
"if lexpr then lexpr maybe_elsif_lexpr maybe_else_lexpr endif")
call ifile_append (ifile, "SEQ maybe_elsif_lexpr = elsif_lexpr*")
call ifile_append (ifile, "SEQ maybe_else_lexpr = else_lexpr?")
call ifile_append (ifile, "SEQ elsif_lexpr = elsif lexpr then lexpr")
call ifile_append (ifile, "SEQ else_lexpr = else lexpr")
call ifile_append (ifile, "SEQ compared_expr = expr comparison+")
call ifile_append (ifile, "SEQ comparison = compare expr")
call ifile_append (ifile, "ALT compare = " // &
"'<' | '>' | '<=' | '>=' | '==' | '<>'")
call ifile_append (ifile, "KEY '<'")
call ifile_append (ifile, "KEY '>'")
call ifile_append (ifile, "KEY '<='")
call ifile_append (ifile, "KEY '>='")
call ifile_append (ifile, "KEY '=='")
call ifile_append (ifile, "KEY '<>'")
call ifile_append (ifile, "SEQ compared_sexpr = sexpr str_comparison+")
call ifile_append (ifile, "SEQ str_comparison = str_compare sexpr")
call ifile_append (ifile, "ALT str_compare = '==' | '<>'")
if (analysis) then
call ifile_append (ifile, "SEQ record_cmd = " // &
"record_key analysis_tag record_arg?")
call ifile_append (ifile, "ALT record_key = " // &
"record | record_unweighted | record_excess")
call ifile_append (ifile, "KEY record")
call ifile_append (ifile, "KEY record_unweighted")
call ifile_append (ifile, "KEY record_excess")
call ifile_append (ifile, "ALT analysis_tag = analysis_id | sexpr")
call ifile_append (ifile, "IDE analysis_id")
call ifile_append (ifile, "ARG record_arg = ( expr+ )")
end if
end subroutine define_lexpr_syntax
@ %def define_lexpr_syntax
@ String expressions.
<<Eval trees: procedures>>=
subroutine define_sexpr_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "SEQ sexpr = svalue str_concatenation*")
call ifile_append (ifile, "SEQ str_concatenation = '&' svalue")
call ifile_append (ifile, "KEY '&'")
call ifile_append (ifile, "ALT svalue = " // &
"grouped_sexpr | block_sexpr | conditional_sexpr | " // &
"svariable | string_function | string_literal")
call ifile_append (ifile, "GRO grouped_sexpr = ( sexpr )")
call ifile_append (ifile, "SEQ block_sexpr = let var_spec in sexpr")
call ifile_append (ifile, "SEQ conditional_sexpr = " // &
"if lexpr then sexpr maybe_elsif_sexpr maybe_else_sexpr endif")
call ifile_append (ifile, "SEQ maybe_elsif_sexpr = elsif_sexpr*")
call ifile_append (ifile, "SEQ maybe_else_sexpr = else_sexpr?")
call ifile_append (ifile, "SEQ elsif_sexpr = elsif lexpr then sexpr")
call ifile_append (ifile, "SEQ else_sexpr = else sexpr")
call ifile_append (ifile, "SEQ svariable = '$' alt_svariable")
call ifile_append (ifile, "KEY '$'")
call ifile_append (ifile, "ALT alt_svariable = variable | grouped_sexpr")
call ifile_append (ifile, "ALT var_string = " // &
"var_string_new | var_string_spec")
call ifile_append (ifile, "SEQ var_string_new = string var_string_spec")
call ifile_append (ifile, "KEY string")
call ifile_append (ifile, "SEQ var_string_spec = '$' var_name = sexpr") ! $
call ifile_append (ifile, "ALT string_function = sprintf_fun")
call ifile_append (ifile, "SEQ sprintf_fun = sprintf_clause sprintf_args?")
call ifile_append (ifile, "SEQ sprintf_clause = sprintf sexpr")
call ifile_append (ifile, "KEY sprintf")
call ifile_append (ifile, "ARG sprintf_args = ( sprintf_arg* )")
call ifile_append (ifile, "ALT sprintf_arg = " &
// "lvariable | svariable | expr")
call ifile_append (ifile, "QUO string_literal = '""'...'""'")
end subroutine define_sexpr_syntax
@ %def define_sexpr_syntax
@ Eval trees that evaluate to subevents.
<<Eval trees: procedures>>=
subroutine define_pexpr_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "SEQ pexpr = pterm pconcatenation*")
call ifile_append (ifile, "SEQ pconcatenation = '&' pterm")
! call ifile_append (ifile, "KEY '&'") !!! (Key exists already)
call ifile_append (ifile, "SEQ pterm = pvalue pcombination*")
call ifile_append (ifile, "SEQ pcombination = '+' pvalue")
! call ifile_append (ifile, "KEY '+'") !!! (Key exists already)
call ifile_append (ifile, "ALT pvalue = " // &
"pexpr_src | pvariable | " // &
"grouped_pexpr | block_pexpr | conditional_pexpr | " // &
"prt_function")
call ifile_append (ifile, "SEQ pexpr_src = prefix_cexpr")
call ifile_append (ifile, "ALT prefix_cexpr = " // &
"beam_prt | incoming_prt | outgoing_prt | unspecified_prt")
call ifile_append (ifile, "SEQ beam_prt = beam cexpr")
call ifile_append (ifile, "KEY beam")
call ifile_append (ifile, "SEQ incoming_prt = incoming cexpr")
call ifile_append (ifile, "KEY incoming")
call ifile_append (ifile, "SEQ outgoing_prt = outgoing cexpr")
call ifile_append (ifile, "KEY outgoing")
call ifile_append (ifile, "SEQ unspecified_prt = cexpr")
call ifile_append (ifile, "SEQ pvariable = '@' alt_pvariable")
call ifile_append (ifile, "KEY '@'")
call ifile_append (ifile, "ALT alt_pvariable = variable | grouped_pexpr")
call ifile_append (ifile, "GRO grouped_pexpr = '[' pexpr ']'")
call ifile_append (ifile, "SEQ block_pexpr = let var_spec in pexpr")
call ifile_append (ifile, "SEQ conditional_pexpr = " // &
"if lexpr then pexpr maybe_elsif_pexpr maybe_else_pexpr endif")
call ifile_append (ifile, "SEQ maybe_elsif_pexpr = elsif_pexpr*")
call ifile_append (ifile, "SEQ maybe_else_pexpr = else_pexpr?")
call ifile_append (ifile, "SEQ elsif_pexpr = elsif lexpr then pexpr")
call ifile_append (ifile, "SEQ else_pexpr = else pexpr")
call ifile_append (ifile, "ALT prt_function = " // &
"join_fun | combine_fun | collect_fun | cluster_fun | " // &
"photon_reco_fun | " // &
"select_fun | extract_fun | sort_fun | " // &
"select_b_jet_fun | select_non_b_jet_fun | " // &
"select_c_jet_fun | select_light_jet_fun")
call ifile_append (ifile, "SEQ join_fun = join_clause pargs2")
call ifile_append (ifile, "SEQ combine_fun = combine_clause pargs2")
call ifile_append (ifile, "SEQ collect_fun = collect_clause pargs1")
call ifile_append (ifile, "SEQ cluster_fun = cluster_clause pargs1")
call ifile_append (ifile, "SEQ photon_reco_fun = photon_reco_clause pargs1")
call ifile_append (ifile, "SEQ select_fun = select_clause pargs1")
call ifile_append (ifile, "SEQ extract_fun = extract_clause pargs1")
call ifile_append (ifile, "SEQ sort_fun = sort_clause pargs1")
call ifile_append (ifile, "SEQ select_b_jet_fun = " // &
"select_b_jet_clause pargs1")
call ifile_append (ifile, "SEQ select_non_b_jet_fun = " // &
"select_non_b_jet_clause pargs1")
call ifile_append (ifile, "SEQ select_c_jet_fun = " // &
"select_c_jet_clause pargs1")
call ifile_append (ifile, "SEQ select_light_jet_fun = " // &
"select_light_jet_clause pargs1")
call ifile_append (ifile, "SEQ join_clause = join condition?")
call ifile_append (ifile, "SEQ combine_clause = combine condition?")
call ifile_append (ifile, "SEQ collect_clause = collect condition?")
call ifile_append (ifile, "SEQ cluster_clause = cluster condition?")
call ifile_append (ifile, "SEQ photon_reco_clause = photon_recombination condition?")
call ifile_append (ifile, "SEQ select_clause = select condition?")
call ifile_append (ifile, "SEQ extract_clause = extract position?")
call ifile_append (ifile, "SEQ sort_clause = sort criterion?")
call ifile_append (ifile, "SEQ select_b_jet_clause = " // &
"select_b_jet condition?")
call ifile_append (ifile, "SEQ select_non_b_jet_clause = " // &
"select_non_b_jet condition?")
call ifile_append (ifile, "SEQ select_c_jet_clause = " // &
"select_c_jet condition?")
call ifile_append (ifile, "SEQ select_light_jet_clause = " // &
"select_light_jet condition?")
call ifile_append (ifile, "KEY join")
call ifile_append (ifile, "KEY combine")
call ifile_append (ifile, "KEY collect")
call ifile_append (ifile, "KEY cluster")
call ifile_append (ifile, "KEY photon_recombination")
call ifile_append (ifile, "KEY select")
call ifile_append (ifile, "SEQ condition = if lexpr")
call ifile_append (ifile, "KEY extract")
call ifile_append (ifile, "SEQ position = index expr")
call ifile_append (ifile, "KEY sort")
call ifile_append (ifile, "KEY select_b_jet")
call ifile_append (ifile, "KEY select_non_b_jet")
call ifile_append (ifile, "KEY select_c_jet")
call ifile_append (ifile, "KEY select_light_jet")
call ifile_append (ifile, "SEQ criterion = by expr")
call ifile_append (ifile, "KEY index")
call ifile_append (ifile, "KEY by")
call ifile_append (ifile, "ARG pargs2 = '[' pexpr, pexpr ']'")
call ifile_append (ifile, "ARG pargs1 = '[' pexpr, pexpr? ']'")
end subroutine define_pexpr_syntax
@ %def define_pexpr_syntax
@ Eval trees that evaluate to PDG-code arrays.
<<Eval trees: procedures>>=
subroutine define_cexpr_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "SEQ cexpr = avalue concatenation*")
call ifile_append (ifile, "SEQ concatenation = ':' avalue")
call ifile_append (ifile, "KEY ':'")
call ifile_append (ifile, "ALT avalue = " // &
"grouped_cexpr | block_cexpr | conditional_cexpr | " // &
"variable | pdg_code | prt_name")
call ifile_append (ifile, "GRO grouped_cexpr = ( cexpr )")
call ifile_append (ifile, "SEQ block_cexpr = let var_spec in cexpr")
call ifile_append (ifile, "SEQ conditional_cexpr = " // &
"if lexpr then cexpr maybe_elsif_cexpr maybe_else_cexpr endif")
call ifile_append (ifile, "SEQ maybe_elsif_cexpr = elsif_cexpr*")
call ifile_append (ifile, "SEQ maybe_else_cexpr = else_cexpr?")
call ifile_append (ifile, "SEQ elsif_cexpr = elsif lexpr then cexpr")
call ifile_append (ifile, "SEQ else_cexpr = else cexpr")
call ifile_append (ifile, "SEQ pdg_code = pdg pdg_arg")
call ifile_append (ifile, "KEY pdg")
call ifile_append (ifile, "ARG pdg_arg = ( expr )")
call ifile_append (ifile, "QUO prt_name = '""'...'""'")
end subroutine define_cexpr_syntax
@ %def define_cexpr_syntax
@ Extra variable types.
<<Eval trees: procedures>>=
subroutine define_var_plist_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "ALT var_plist = var_plist_new | var_plist_spec")
call ifile_append (ifile, "SEQ var_plist_new = subevt var_plist_spec")
call ifile_append (ifile, "KEY subevt")
call ifile_append (ifile, "SEQ var_plist_spec = '@' var_name '=' pexpr")
end subroutine define_var_plist_syntax
subroutine define_var_alias_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "SEQ var_alias = alias var_name '=' cexpr")
call ifile_append (ifile, "KEY alias")
end subroutine define_var_alias_syntax
@ %def define_var_plist_syntax define_var_alias_syntax
@ Particle-list expressions that evaluate to numeric values
<<Eval trees: procedures>>=
subroutine define_numeric_pexpr_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "ALT numeric_pexpr = " &
// "eval_fun | count_fun")
call ifile_append (ifile, "SEQ eval_fun = eval expr pargs1")
call ifile_append (ifile, "SEQ count_fun = count_clause pargs1")
call ifile_append (ifile, "SEQ count_clause = count condition?")
call ifile_append (ifile, "KEY eval")
call ifile_append (ifile, "KEY count")
end subroutine define_numeric_pexpr_syntax
@ %def define_numeric_pexpr_syntax
@ Particle-list functions that evaluate to logical values.
<<Eval trees: procedures>>=
subroutine define_logical_pexpr_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "ALT logical_pexpr = " // &
"all_fun | any_fun | no_fun | " // &
"photon_isolation_fun")
call ifile_append (ifile, "SEQ all_fun = all lexpr pargs1")
call ifile_append (ifile, "SEQ any_fun = any lexpr pargs1")
call ifile_append (ifile, "SEQ no_fun = no lexpr pargs1")
call ifile_append (ifile, "SEQ photon_isolation_fun = " // &
"photon_isolation_clause pargs2")
call ifile_append (ifile, "SEQ photon_isolation_clause = " // &
"photon_isolation condition?")
call ifile_append (ifile, "KEY all")
call ifile_append (ifile, "KEY any")
call ifile_append (ifile, "KEY no")
call ifile_append (ifile, "KEY photon_isolation")
end subroutine define_logical_pexpr_syntax
@ %def define_logical_pexpr_syntax
@ All characters that can occur in expressions (apart from alphanumeric).
<<Eval trees: procedures>>=
subroutine lexer_init_eval_tree (lexer, particles)
type(lexer_t), intent(out) :: lexer
logical, intent(in) :: particles
type(keyword_list_t), pointer :: keyword_list
if (particles) then
keyword_list => syntax_get_keyword_list_ptr (syntax_pexpr)
else
keyword_list => syntax_get_keyword_list_ptr (syntax_expr)
end if
call lexer_init (lexer, &
comment_chars = "#!", &
quote_chars = '"', &
quote_match = '"', &
single_chars = "()[],;:&%?$@", &
special_class = [ "+-*/^", "<>=~ " ] , &
keyword_list = keyword_list)
end subroutine lexer_init_eval_tree
@ %def lexer_init_eval_tree
@
\subsection{Set up appropriate parse trees}
Parse an input stream as a specific flavor of expression. The
appropriate expression syntax has to be available.
<<Eval trees: public>>=
public :: parse_tree_init_expr
public :: parse_tree_init_lexpr
public :: parse_tree_init_pexpr
public :: parse_tree_init_cexpr
public :: parse_tree_init_sexpr
<<Eval trees: procedures>>=
subroutine parse_tree_init_expr (parse_tree, stream, particles)
type(parse_tree_t), intent(out) :: parse_tree
type(stream_t), intent(inout), target :: stream
logical, intent(in) :: particles
type(lexer_t) :: lexer
call lexer_init_eval_tree (lexer, particles)
call lexer_assign_stream (lexer, stream)
if (particles) then
call parse_tree_init &
(parse_tree, syntax_pexpr, lexer, var_str ("expr"))
else
call parse_tree_init &
(parse_tree, syntax_expr, lexer, var_str ("expr"))
end if
call lexer_final (lexer)
end subroutine parse_tree_init_expr
subroutine parse_tree_init_lexpr (parse_tree, stream, particles)
type(parse_tree_t), intent(out) :: parse_tree
type(stream_t), intent(inout), target :: stream
logical, intent(in) :: particles
type(lexer_t) :: lexer
call lexer_init_eval_tree (lexer, particles)
call lexer_assign_stream (lexer, stream)
if (particles) then
call parse_tree_init &
(parse_tree, syntax_pexpr, lexer, var_str ("lexpr"))
else
call parse_tree_init &
(parse_tree, syntax_expr, lexer, var_str ("lexpr"))
end if
call lexer_final (lexer)
end subroutine parse_tree_init_lexpr
subroutine parse_tree_init_pexpr (parse_tree, stream)
type(parse_tree_t), intent(out) :: parse_tree
type(stream_t), intent(inout), target :: stream
type(lexer_t) :: lexer
call lexer_init_eval_tree (lexer, .true.)
call lexer_assign_stream (lexer, stream)
call parse_tree_init &
(parse_tree, syntax_pexpr, lexer, var_str ("pexpr"))
call lexer_final (lexer)
end subroutine parse_tree_init_pexpr
subroutine parse_tree_init_cexpr (parse_tree, stream)
type(parse_tree_t), intent(out) :: parse_tree
type(stream_t), intent(inout), target :: stream
type(lexer_t) :: lexer
call lexer_init_eval_tree (lexer, .true.)
call lexer_assign_stream (lexer, stream)
call parse_tree_init &
(parse_tree, syntax_pexpr, lexer, var_str ("cexpr"))
call lexer_final (lexer)
end subroutine parse_tree_init_cexpr
subroutine parse_tree_init_sexpr (parse_tree, stream, particles)
type(parse_tree_t), intent(out) :: parse_tree
type(stream_t), intent(inout), target :: stream
logical, intent(in) :: particles
type(lexer_t) :: lexer
call lexer_init_eval_tree (lexer, particles)
call lexer_assign_stream (lexer, stream)
if (particles) then
call parse_tree_init &
(parse_tree, syntax_pexpr, lexer, var_str ("sexpr"))
else
call parse_tree_init &
(parse_tree, syntax_expr, lexer, var_str ("sexpr"))
end if
call lexer_final (lexer)
end subroutine parse_tree_init_sexpr
@ %def parse_tree_init_expr
@ %def parse_tree_init_lexpr
@ %def parse_tree_init_pexpr
@ %def parse_tree_init_cexpr
@ %def parse_tree_init_sexpr
@
\subsection{The evaluation tree}
The evaluation tree contains the initial variable list and the root node.
<<Eval trees: public>>=
public :: eval_tree_t
<<Eval trees: types>>=
type, extends (expr_t) :: eval_tree_t
private
type(parse_node_t), pointer :: pn => null ()
type(var_list_t) :: var_list
type(eval_node_t), pointer :: root => null ()
contains
<<Eval trees: eval tree: TBP>>
end type eval_tree_t
@ %def eval_tree_t
@ Init from stream, using a temporary parse tree.
<<Eval trees: eval tree: TBP>>=
procedure :: init_stream => eval_tree_init_stream
<<Eval trees: procedures>>=
subroutine eval_tree_init_stream &
(eval_tree, stream, var_list, subevt, result_type)
class(eval_tree_t), intent(out), target :: eval_tree
type(stream_t), intent(inout), target :: stream
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), target, optional :: subevt
integer, intent(in), optional :: result_type
type(parse_tree_t) :: parse_tree
type(parse_node_t), pointer :: nd_root
integer :: type
type = V_REAL; if (present (result_type)) type = result_type
select case (type)
case (V_INT, V_REAL, V_CMPLX)
call parse_tree_init_expr (parse_tree, stream, present (subevt))
case (V_LOG)
call parse_tree_init_lexpr (parse_tree, stream, present (subevt))
case (V_SEV)
call parse_tree_init_pexpr (parse_tree, stream)
case (V_PDG)
call parse_tree_init_cexpr (parse_tree, stream)
case (V_STR)
call parse_tree_init_sexpr (parse_tree, stream, present (subevt))
end select
nd_root => parse_tree%get_root_ptr ()
if (associated (nd_root)) then
select case (type)
case (V_INT, V_REAL, V_CMPLX)
call eval_tree_init_expr (eval_tree, nd_root, var_list, subevt)
case (V_LOG)
call eval_tree_init_lexpr (eval_tree, nd_root, var_list, subevt)
case (V_SEV)
call eval_tree_init_pexpr (eval_tree, nd_root, var_list, subevt)
case (V_PDG)
call eval_tree_init_cexpr (eval_tree, nd_root, var_list, subevt)
case (V_STR)
call eval_tree_init_sexpr (eval_tree, nd_root, var_list, subevt)
end select
end if
call parse_tree_final (parse_tree)
end subroutine eval_tree_init_stream
@ %def eval_tree_init_stream
@ API (to be superseded by the methods below): Init from a given parse-tree
node. If we evaluate an expression that contains particle-list references,
the original subevent has to be supplied. The initial variable list is
optional.
<<Eval trees: eval tree: TBP>>=
procedure :: init_expr => eval_tree_init_expr
procedure :: init_lexpr => eval_tree_init_lexpr
procedure :: init_pexpr => eval_tree_init_pexpr
procedure :: init_cexpr => eval_tree_init_cexpr
procedure :: init_sexpr => eval_tree_init_sexpr
<<Eval trees: procedures>>=
subroutine eval_tree_init_expr &
(expr, parse_node, var_list, subevt)
class(eval_tree_t), intent(out), target :: expr
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
call eval_tree_link_var_list (expr, var_list)
if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
call eval_node_compile_expr &
(expr%root, parse_node, expr%var_list)
end subroutine eval_tree_init_expr
subroutine eval_tree_init_lexpr &
(expr, parse_node, var_list, subevt)
class(eval_tree_t), intent(out), target :: expr
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
call eval_tree_link_var_list (expr, var_list)
if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
call eval_node_compile_lexpr &
(expr%root, parse_node, expr%var_list)
end subroutine eval_tree_init_lexpr
subroutine eval_tree_init_pexpr &
(expr, parse_node, var_list, subevt)
class(eval_tree_t), intent(out), target :: expr
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
call eval_tree_link_var_list (expr, var_list)
if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
call eval_node_compile_pexpr &
(expr%root, parse_node, expr%var_list)
end subroutine eval_tree_init_pexpr
subroutine eval_tree_init_cexpr &
(expr, parse_node, var_list, subevt)
class(eval_tree_t), intent(out), target :: expr
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
call eval_tree_link_var_list (expr, var_list)
if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
call eval_node_compile_cexpr &
(expr%root, parse_node, expr%var_list)
end subroutine eval_tree_init_cexpr
subroutine eval_tree_init_sexpr &
(expr, parse_node, var_list, subevt)
class(eval_tree_t), intent(out), target :: expr
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
call eval_tree_link_var_list (expr, var_list)
if (present (subevt)) call eval_tree_set_subevt (expr, subevt)
call eval_node_compile_sexpr &
(expr%root, parse_node, expr%var_list)
end subroutine eval_tree_init_sexpr
@ %def eval_tree_init_expr
@ %def eval_tree_init_lexpr
@ %def eval_tree_init_pexpr
@ %def eval_tree_init_cexpr
@ %def eval_tree_init_sexpr
@ Alternative: set up the expression using the parse node that has already
been stored. We assume that the [[subevt]] or any other variable that
may be referred to has already been added to the local variable list.
<<Eval trees: eval tree: TBP>>=
procedure :: setup_expr => eval_tree_setup_expr
procedure :: setup_lexpr => eval_tree_setup_lexpr
procedure :: setup_pexpr => eval_tree_setup_pexpr
procedure :: setup_cexpr => eval_tree_setup_cexpr
procedure :: setup_sexpr => eval_tree_setup_sexpr
<<Eval trees: procedures>>=
subroutine eval_tree_setup_expr (expr, vars)
class(eval_tree_t), intent(inout), target :: expr
class(vars_t), intent(in), target :: vars
call eval_tree_link_var_list (expr, vars)
call eval_node_compile_expr (expr%root, expr%pn, expr%var_list)
end subroutine eval_tree_setup_expr
subroutine eval_tree_setup_lexpr (expr, vars)
class(eval_tree_t), intent(inout), target :: expr
class(vars_t), intent(in), target :: vars
call eval_tree_link_var_list (expr, vars)
call eval_node_compile_lexpr (expr%root, expr%pn, expr%var_list)
end subroutine eval_tree_setup_lexpr
subroutine eval_tree_setup_pexpr (expr, vars)
class(eval_tree_t), intent(inout), target :: expr
class(vars_t), intent(in), target :: vars
call eval_tree_link_var_list (expr, vars)
call eval_node_compile_pexpr (expr%root, expr%pn, expr%var_list)
end subroutine eval_tree_setup_pexpr
subroutine eval_tree_setup_cexpr (expr, vars)
class(eval_tree_t), intent(inout), target :: expr
class(vars_t), intent(in), target :: vars
call eval_tree_link_var_list (expr, vars)
call eval_node_compile_cexpr (expr%root, expr%pn, expr%var_list)
end subroutine eval_tree_setup_cexpr
subroutine eval_tree_setup_sexpr (expr, vars)
class(eval_tree_t), intent(inout), target :: expr
class(vars_t), intent(in), target :: vars
call eval_tree_link_var_list (expr, vars)
call eval_node_compile_sexpr (expr%root, expr%pn, expr%var_list)
end subroutine eval_tree_setup_sexpr
@ %def eval_tree_setup_expr
@ %def eval_tree_setup_lexpr
@ %def eval_tree_setup_pexpr
@ %def eval_tree_setup_cexpr
@ %def eval_tree_setup_sexpr
@ This extra API function handles numerical constant expressions only.
The only nontrivial part is the optional unit.
<<Eval trees: eval tree: TBP>>=
procedure :: init_numeric_value => eval_tree_init_numeric_value
<<Eval trees: procedures>>=
subroutine eval_tree_init_numeric_value (eval_tree, parse_node)
class(eval_tree_t), intent(out), target :: eval_tree
type(parse_node_t), intent(in), target :: parse_node
call eval_node_compile_numeric_value (eval_tree%root, parse_node)
end subroutine eval_tree_init_numeric_value
@ %def eval_tree_init_numeric_value
@ Initialize the variable list, linking it to a context variable list.
<<Eval trees: procedures>>=
subroutine eval_tree_link_var_list (eval_tree, vars)
type(eval_tree_t), intent(inout), target :: eval_tree
class(vars_t), intent(in), target :: vars
call eval_tree%var_list%link (vars)
end subroutine eval_tree_link_var_list
@ %def eval_tree_link_var_list
@ Include a subevent object in the initialization. We add a pointer
to this as variable [[@evt]] in the local variable list.
<<Eval trees: procedures>>=
subroutine eval_tree_set_subevt (eval_tree, subevt)
type(eval_tree_t), intent(inout), target :: eval_tree
type(subevt_t), intent(in), target :: subevt
logical, save, target :: known = .true.
call var_list_append_subevt_ptr &
(eval_tree%var_list, var_str ("@evt"), subevt, known, &
intrinsic=.true.)
end subroutine eval_tree_set_subevt
@ %def eval_tree_set_subevt
@ Finalizer.
<<Eval trees: eval tree: TBP>>=
procedure :: final => eval_tree_final
<<Eval trees: procedures>>=
subroutine eval_tree_final (expr)
class(eval_tree_t), intent(inout) :: expr
call expr%var_list%final ()
if (associated (expr%root)) then
call eval_node_final_rec (expr%root)
deallocate (expr%root)
end if
end subroutine eval_tree_final
@ %def eval_tree_final
@
<<Eval trees: eval tree: TBP>>=
procedure :: evaluate => eval_tree_evaluate
<<Eval trees: procedures>>=
subroutine eval_tree_evaluate (expr)
class(eval_tree_t), intent(inout) :: expr
if (associated (expr%root)) then
call eval_node_evaluate (expr%root)
end if
end subroutine eval_tree_evaluate
@ %def eval_tree_evaluate
@ Check if the eval tree is allocated.
<<Eval trees: procedures>>=
function eval_tree_is_defined (eval_tree) result (flag)
logical :: flag
type(eval_tree_t), intent(in) :: eval_tree
flag = associated (eval_tree%root)
end function eval_tree_is_defined
@ %def eval_tree_is_defined
@ Check if the eval tree result is constant.
<<Eval trees: procedures>>=
function eval_tree_is_constant (eval_tree) result (flag)
logical :: flag
type(eval_tree_t), intent(in) :: eval_tree
if (associated (eval_tree%root)) then
flag = eval_tree%root%type == EN_CONSTANT
else
flag = .false.
end if
end function eval_tree_is_constant
@ %def eval_tree_is_constant
@ Insert a conversion node at the root, if necessary (only for
real/int conversion)
<<Eval trees: procedures>>=
subroutine eval_tree_convert_result (eval_tree, result_type)
type(eval_tree_t), intent(inout) :: eval_tree
integer, intent(in) :: result_type
if (associated (eval_tree%root)) then
call insert_conversion_node (eval_tree%root, result_type)
end if
end subroutine eval_tree_convert_result
@ %def eval_tree_convert_result
@ Return the value of the top node, after evaluation. If the tree is
empty, return the type of [[V_NONE]]. When extracting the value, no
check for existence is done. For numeric values, the functions are
safe against real/integer mismatch.
<<Eval trees: eval tree: TBP>>=
procedure :: is_known => eval_tree_result_is_known
procedure :: get_log => eval_tree_get_log
procedure :: get_int => eval_tree_get_int
procedure :: get_real => eval_tree_get_real
procedure :: get_cmplx => eval_tree_get_cmplx
procedure :: get_pdg_array => eval_tree_get_pdg_array
procedure :: get_subevt => eval_tree_get_subevt
procedure :: get_string => eval_tree_get_string
<<Eval trees: procedures>>=
function eval_tree_get_result_type (expr) result (type)
integer :: type
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) then
type = expr%root%result_type
else
type = V_NONE
end if
end function eval_tree_get_result_type
function eval_tree_result_is_known (expr) result (flag)
logical :: flag
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) then
select case (expr%root%result_type)
case (V_LOG, V_INT, V_REAL)
flag = expr%root%value_is_known
case default
flag = .true.
end select
else
flag = .false.
end if
end function eval_tree_result_is_known
function eval_tree_result_is_known_ptr (expr) result (ptr)
logical, pointer :: ptr
class(eval_tree_t), intent(in) :: expr
logical, target, save :: known = .true.
if (associated (expr%root)) then
select case (expr%root%result_type)
case (V_LOG, V_INT, V_REAL)
ptr => expr%root%value_is_known
case default
ptr => known
end select
else
ptr => null ()
end if
end function eval_tree_result_is_known_ptr
function eval_tree_get_log (expr) result (lval)
logical :: lval
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) lval = expr%root%lval
end function eval_tree_get_log
function eval_tree_get_int (expr) result (ival)
integer :: ival
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) then
select case (expr%root%result_type)
case (V_INT); ival = expr%root%ival
case (V_REAL); ival = expr%root%rval
case (V_CMPLX); ival = expr%root%cval
end select
end if
end function eval_tree_get_int
function eval_tree_get_real (expr) result (rval)
real(default) :: rval
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) then
select case (expr%root%result_type)
case (V_REAL); rval = expr%root%rval
case (V_INT); rval = expr%root%ival
case (V_CMPLX); rval = expr%root%cval
end select
end if
end function eval_tree_get_real
function eval_tree_get_cmplx (expr) result (cval)
complex(default) :: cval
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) then
select case (expr%root%result_type)
case (V_CMPLX); cval = expr%root%cval
case (V_REAL); cval = expr%root%rval
case (V_INT); cval = expr%root%ival
end select
end if
end function eval_tree_get_cmplx
function eval_tree_get_pdg_array (expr) result (aval)
type(pdg_array_t) :: aval
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) then
aval = expr%root%aval
end if
end function eval_tree_get_pdg_array
function eval_tree_get_subevt (expr) result (pval)
type(subevt_t) :: pval
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) then
pval = expr%root%pval
end if
end function eval_tree_get_subevt
function eval_tree_get_string (expr) result (sval)
type(string_t) :: sval
class(eval_tree_t), intent(in) :: expr
if (associated (expr%root)) then
sval = expr%root%sval
end if
end function eval_tree_get_string
@ %def eval_tree_get_result_type
@ %def eval_tree_result_is_known
@ %def eval_tree_get_log eval_tree_get_int eval_tree_get_real
@ %def eval_tree_get_cmplx
@ %def eval_tree_get_pdg_expr
@ %def eval_tree_get_pdg_array
@ %def eval_tree_get_subevt
@ %def eval_tree_get_string
@ Return a pointer to the value of the top node.
<<Eval trees: procedures>>=
function eval_tree_get_log_ptr (eval_tree) result (lval)
logical, pointer :: lval
type(eval_tree_t), intent(in) :: eval_tree
if (associated (eval_tree%root)) then
lval => eval_tree%root%lval
else
lval => null ()
end if
end function eval_tree_get_log_ptr
function eval_tree_get_int_ptr (eval_tree) result (ival)
integer, pointer :: ival
type(eval_tree_t), intent(in) :: eval_tree
if (associated (eval_tree%root)) then
ival => eval_tree%root%ival
else
ival => null ()
end if
end function eval_tree_get_int_ptr
function eval_tree_get_real_ptr (eval_tree) result (rval)
real(default), pointer :: rval
type(eval_tree_t), intent(in) :: eval_tree
if (associated (eval_tree%root)) then
rval => eval_tree%root%rval
else
rval => null ()
end if
end function eval_tree_get_real_ptr
function eval_tree_get_cmplx_ptr (eval_tree) result (cval)
complex(default), pointer :: cval
type(eval_tree_t), intent(in) :: eval_tree
if (associated (eval_tree%root)) then
cval => eval_tree%root%cval
else
cval => null ()
end if
end function eval_tree_get_cmplx_ptr
function eval_tree_get_subevt_ptr (eval_tree) result (pval)
type(subevt_t), pointer :: pval
type(eval_tree_t), intent(in) :: eval_tree
if (associated (eval_tree%root)) then
pval => eval_tree%root%pval
else
pval => null ()
end if
end function eval_tree_get_subevt_ptr
function eval_tree_get_pdg_array_ptr (eval_tree) result (aval)
type(pdg_array_t), pointer :: aval
type(eval_tree_t), intent(in) :: eval_tree
if (associated (eval_tree%root)) then
aval => eval_tree%root%aval
else
aval => null ()
end if
end function eval_tree_get_pdg_array_ptr
function eval_tree_get_string_ptr (eval_tree) result (sval)
type(string_t), pointer :: sval
type(eval_tree_t), intent(in) :: eval_tree
if (associated (eval_tree%root)) then
sval => eval_tree%root%sval
else
sval => null ()
end if
end function eval_tree_get_string_ptr
@ %def eval_tree_get_log_ptr eval_tree_get_int_ptr eval_tree_get_real_ptr
@ %def eval_tree_get_cmplx_ptr
@ %def eval_tree_get_subevt_ptr eval_tree_get_pdg_array_ptr
@ %def eval_tree_get_string_ptr
<<Eval trees: eval tree: TBP>>=
procedure :: write => eval_tree_write
<<Eval trees: procedures>>=
subroutine eval_tree_write (expr, unit, write_vars)
class(eval_tree_t), intent(in) :: expr
integer, intent(in), optional :: unit
logical, intent(in), optional :: write_vars
integer :: u
logical :: vl
u = given_output_unit (unit); if (u < 0) return
vl = .false.; if (present (write_vars)) vl = write_vars
write (u, "(1x,A)") "Evaluation tree:"
if (associated (expr%root)) then
call eval_node_write_rec (expr%root, unit)
else
write (u, "(3x,A)") "[empty]"
end if
if (vl) call var_list_write (expr%var_list, unit)
end subroutine eval_tree_write
@ %def eval_tree_write
@ Use the written representation for generating an MD5 sum:
<<Eval trees: procedures>>=
function eval_tree_get_md5sum (eval_tree) result (md5sum_et)
character(32) :: md5sum_et
type(eval_tree_t), intent(in) :: eval_tree
integer :: u
u = free_unit ()
open (unit = u, status = "scratch", action = "readwrite")
call eval_tree_write (eval_tree, unit=u)
rewind (u)
md5sum_et = md5sum (u)
close (u)
end function eval_tree_get_md5sum
@ %def eval_tree_get_md5sum
@
\subsection{Direct evaluation}
These procedures create an eval tree and evaluate it on-the-fly, returning
only the final value. The evaluation must yield a well-defined value, unless
the [[is_known]] flag is present, which will be set accordingly.
<<Eval trees: public>>=
public :: eval_log
public :: eval_int
public :: eval_real
public :: eval_cmplx
public :: eval_subevt
public :: eval_pdg_array
public :: eval_string
<<Eval trees: procedures>>=
function eval_log &
(parse_node, var_list, subevt, is_known) result (lval)
logical :: lval
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
logical, intent(out), optional :: is_known
type(eval_tree_t), target :: eval_tree
call eval_tree_init_lexpr &
(eval_tree, parse_node, var_list, subevt)
call eval_tree_evaluate (eval_tree)
if (eval_tree_result_is_known (eval_tree)) then
if (present (is_known)) is_known = .true.
lval = eval_tree_get_log (eval_tree)
else if (present (is_known)) then
is_known = .false.
else
call eval_tree_unknown (eval_tree, parse_node)
lval = .false.
end if
call eval_tree_final (eval_tree)
end function eval_log
function eval_int &
(parse_node, var_list, subevt, is_known) result (ival)
integer :: ival
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
logical, intent(out), optional :: is_known
type(eval_tree_t), target :: eval_tree
call eval_tree_init_expr &
(eval_tree, parse_node, var_list, subevt)
call eval_tree_evaluate (eval_tree)
if (eval_tree_result_is_known (eval_tree)) then
if (present (is_known)) is_known = .true.
ival = eval_tree_get_int (eval_tree)
else if (present (is_known)) then
is_known = .false.
else
call eval_tree_unknown (eval_tree, parse_node)
ival = 0
end if
call eval_tree_final (eval_tree)
end function eval_int
function eval_real &
(parse_node, var_list, subevt, is_known) result (rval)
real(default) :: rval
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
logical, intent(out), optional :: is_known
type(eval_tree_t), target :: eval_tree
call eval_tree_init_expr &
(eval_tree, parse_node, var_list, subevt)
call eval_tree_evaluate (eval_tree)
if (eval_tree_result_is_known (eval_tree)) then
if (present (is_known)) is_known = .true.
rval = eval_tree_get_real (eval_tree)
else if (present (is_known)) then
is_known = .false.
else
call eval_tree_unknown (eval_tree, parse_node)
rval = 0
end if
call eval_tree_final (eval_tree)
end function eval_real
function eval_cmplx &
(parse_node, var_list, subevt, is_known) result (cval)
complex(default) :: cval
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
logical, intent(out), optional :: is_known
type(eval_tree_t), target :: eval_tree
call eval_tree_init_expr &
(eval_tree, parse_node, var_list, subevt)
call eval_tree_evaluate (eval_tree)
if (eval_tree_result_is_known (eval_tree)) then
if (present (is_known)) is_known = .true.
cval = eval_tree_get_cmplx (eval_tree)
else if (present (is_known)) then
is_known = .false.
else
call eval_tree_unknown (eval_tree, parse_node)
cval = 0
end if
call eval_tree_final (eval_tree)
end function eval_cmplx
function eval_subevt &
(parse_node, var_list, subevt, is_known) result (pval)
type(subevt_t) :: pval
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
logical, intent(out), optional :: is_known
type(eval_tree_t), target :: eval_tree
call eval_tree_init_pexpr &
(eval_tree, parse_node, var_list, subevt)
call eval_tree_evaluate (eval_tree)
if (eval_tree_result_is_known (eval_tree)) then
if (present (is_known)) is_known = .true.
pval = eval_tree_get_subevt (eval_tree)
else if (present (is_known)) then
is_known = .false.
else
call eval_tree_unknown (eval_tree, parse_node)
end if
call eval_tree_final (eval_tree)
end function eval_subevt
function eval_pdg_array &
(parse_node, var_list, subevt, is_known) result (aval)
type(pdg_array_t) :: aval
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
logical, intent(out), optional :: is_known
type(eval_tree_t), target :: eval_tree
call eval_tree_init_cexpr &
(eval_tree, parse_node, var_list, subevt)
call eval_tree_evaluate (eval_tree)
if (eval_tree_result_is_known (eval_tree)) then
if (present (is_known)) is_known = .true.
aval = eval_tree_get_pdg_array (eval_tree)
else if (present (is_known)) then
is_known = .false.
else
call eval_tree_unknown (eval_tree, parse_node)
end if
call eval_tree_final (eval_tree)
end function eval_pdg_array
function eval_string &
(parse_node, var_list, subevt, is_known) result (sval)
type(string_t) :: sval
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
logical, intent(out), optional :: is_known
type(eval_tree_t), target :: eval_tree
call eval_tree_init_sexpr &
(eval_tree, parse_node, var_list, subevt)
call eval_tree_evaluate (eval_tree)
if (eval_tree_result_is_known (eval_tree)) then
if (present (is_known)) is_known = .true.
sval = eval_tree_get_string (eval_tree)
else if (present (is_known)) then
is_known = .false.
else
call eval_tree_unknown (eval_tree, parse_node)
sval = ""
end if
call eval_tree_final (eval_tree)
end function eval_string
@ %def eval_log eval_int eval_real eval_cmplx
@ %def eval_subevt eval_pdg_array eval_string
@ %def eval_tree_unknown
@ Here is a variant that returns numeric values of all possible kinds, the
appropriate kind to be selected later:
<<Eval trees: public>>=
public :: eval_numeric
<<Eval trees: procedures>>=
subroutine eval_numeric &
(parse_node, var_list, subevt, ival, rval, cval, &
is_known, result_type)
type(parse_node_t), intent(in), target :: parse_node
type(var_list_t), intent(in), target :: var_list
type(subevt_t), intent(in), optional, target :: subevt
integer, intent(out), optional :: ival
real(default), intent(out), optional :: rval
complex(default), intent(out), optional :: cval
logical, intent(out), optional :: is_known
integer, intent(out), optional :: result_type
type(eval_tree_t), target :: eval_tree
call eval_tree_init_expr &
(eval_tree, parse_node, var_list, subevt)
call eval_tree_evaluate (eval_tree)
if (eval_tree_result_is_known (eval_tree)) then
if (present (ival)) ival = eval_tree_get_int (eval_tree)
if (present (rval)) rval = eval_tree_get_real (eval_tree)
if (present (cval)) cval = eval_tree_get_cmplx (eval_tree)
if (present (is_known)) is_known = .true.
else
call eval_tree_unknown (eval_tree, parse_node)
if (present (ival)) ival = 0
if (present (rval)) rval = 0
if (present (cval)) cval = 0
if (present (is_known)) is_known = .false.
end if
if (present (result_type)) &
result_type = eval_tree_get_result_type (eval_tree)
call eval_tree_final (eval_tree)
end subroutine eval_numeric
@ %def eval_numeric
@ Error message with debugging info:
<<Eval trees: procedures>>=
subroutine eval_tree_unknown (eval_tree, parse_node)
type(eval_tree_t), intent(in) :: eval_tree
type(parse_node_t), intent(in) :: parse_node
call parse_node_write_rec (parse_node)
call eval_tree_write (eval_tree)
call msg_error ("Evaluation yields an undefined result, inserting default")
end subroutine eval_tree_unknown
@ %def eval_tree_unknown
@
\subsection{Factory Type}
Since [[eval_tree_t]] is an implementation of [[expr_t]], we also need a
matching factory type and build method.
<<Eval trees: public>>=
public :: eval_tree_factory_t
<<Eval trees: types>>=
type, extends (expr_factory_t) :: eval_tree_factory_t
private
type(parse_node_t), pointer :: pn => null ()
contains
<<Eval trees: eval tree factory: TBP>>
end type eval_tree_factory_t
@ %def eval_tree_factory_t
@ Output: delegate to the output of the embedded parse node.
<<Eval trees: eval tree factory: TBP>>=
procedure :: write => eval_tree_factory_write
<<Eval trees: procedures>>=
subroutine eval_tree_factory_write (expr_factory, unit)
class(eval_tree_factory_t), intent(in) :: expr_factory
integer, intent(in), optional :: unit
if (associated (expr_factory%pn)) then
call parse_node_write_rec (expr_factory%pn, unit)
end if
end subroutine eval_tree_factory_write
@ %def eval_tree_factory_write
@ Initializer: take a parse node and hide it thus from the environment.
<<Eval trees: eval tree factory: TBP>>=
procedure :: init => eval_tree_factory_init
<<Eval trees: procedures>>=
subroutine eval_tree_factory_init (expr_factory, pn)
class(eval_tree_factory_t), intent(out) :: expr_factory
type(parse_node_t), intent(in), pointer :: pn
expr_factory%pn => pn
end subroutine eval_tree_factory_init
@ %def eval_tree_factory_init
@ Factory method: allocate expression with correct eval tree type. If the
stored parse node is not associate, don't allocate.
<<Eval trees: eval tree factory: TBP>>=
procedure :: build => eval_tree_factory_build
<<Eval trees: procedures>>=
subroutine eval_tree_factory_build (expr_factory, expr)
class(eval_tree_factory_t), intent(in) :: expr_factory
class(expr_t), intent(out), allocatable :: expr
if (associated (expr_factory%pn)) then
allocate (eval_tree_t :: expr)
select type (expr)
type is (eval_tree_t)
expr%pn => expr_factory%pn
end select
end if
end subroutine eval_tree_factory_build
@ %def eval_tree_factory_build
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eval_trees_ut.f90]]>>=
<<File header>>
module eval_trees_ut
use unit_tests
use eval_trees_uti
<<Standard module head>>
<<Eval trees: public test>>
contains
<<Eval trees: test driver>>
end module eval_trees_ut
@ %def eval_trees_ut
@
<<[[eval_trees_uti.f90]]>>=
<<File header>>
module eval_trees_uti
<<Use kinds>>
<<Use strings>>
use ifiles
use lexers
use lorentz
use syntax_rules, only: syntax_write
use pdg_arrays
use subevents
use variables
use observables
use eval_trees
<<Standard module head>>
<<Eval trees: test declarations>>
contains
<<Eval trees: tests>>
end module eval_trees_uti
@ %def eval_trees_ut
@ API: driver for the unit tests below.
<<Eval trees: public test>>=
public :: expressions_test
<<Eval trees: test driver>>=
subroutine expressions_test (u, results)
integer, intent(in) :: u
type (test_results_t), intent(inout) :: results
<<Eval trees: execute tests>>
end subroutine expressions_test
@ %def expressions_test
@ Testing the routines of the expressions module. First a simple unary
observable and the node evaluation.
<<Eval trees: execute tests>>=
call test (expressions_1, "expressions_1", &
"check simple observable", &
u, results)
<<Eval trees: test declarations>>=
public :: expressions_1
<<Eval trees: tests>>=
subroutine expressions_1 (u)
integer, intent(in) :: u
type(var_list_t), pointer :: var_list => null ()
type(eval_node_t), pointer :: node => null ()
type(prt_t), pointer :: prt => null ()
type(string_t) :: var_name
write (u, "(A)") "* Test output: Expressions"
write (u, "(A)") "* Purpose: test simple observable and node evaluation"
write (u, "(A)")
write (u, "(A)") "* Setting a unary observable:"
write (u, "(A)")
allocate (var_list)
allocate (prt)
call var_list_set_observables_unary (var_list, prt)
call var_list%write (u)
write (u, "(A)") "* Evaluating the observable node:"
write (u, "(A)")
var_name = "PDG"
allocate (node)
call node%test_obs (var_list, var_name)
call node%write (u)
write (u, "(A)") "* Cleanup"
write (u, "(A)")
call node%final_rec ()
deallocate (node)
!!! Workaround for NAGFOR 6.2
! call var_list%final ()
deallocate (var_list)
deallocate (prt)
write (u, "(A)")
write (u, "(A)") "* Test output end: expressions_1"
end subroutine expressions_1
@ %def expressions_1
@ Parse a complicated expression, transfer it to a parse tree and evaluate.
<<Eval trees: execute tests>>=
call test (expressions_2, "expressions_2", &
"check expression transfer to parse tree", &
u, results)
<<Eval trees: test declarations>>=
public :: expressions_2
<<Eval trees: tests>>=
subroutine expressions_2 (u)
integer, intent(in) :: u
type(ifile_t) :: ifile
type(stream_t) :: stream
type(eval_tree_t) :: eval_tree
type(string_t) :: expr_text
type(var_list_t), pointer :: var_list => null ()
write (u, "(A)") "* Test output: Expressions"
write (u, "(A)") "* Purpose: test parse routines"
write (u, "(A)")
call syntax_expr_init ()
call syntax_write (syntax_expr, u)
allocate (var_list)
call var_list_append_real (var_list, var_str ("tolerance"), 0._default)
call var_list_append_real (var_list, var_str ("x"), -5._default)
call var_list_append_int (var_list, var_str ("foo"), -27)
call var_list_append_real (var_list, var_str ("mb"), 4._default)
expr_text = &
"let real twopi = 2 * pi in" // &
" twopi * sqrt (25.d0 - mb^2)" // &
" / (let int mb_or_0 = max (mb, 0) in" // &
" 1 + (if -1 TeV <= x < mb_or_0 then abs(x) else x endif))"
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call var_list%write (u)
call eval_tree%init_stream (stream, var_list=var_list)
call eval_tree%evaluate ()
call eval_tree%write (u)
write (u, "(A)") "* Input string:"
write (u, "(A,A)") " ", char (expr_text)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call stream_final (stream)
call ifile_final (ifile)
call eval_tree%final ()
call var_list%final ()
deallocate (var_list)
call syntax_expr_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: expressions_2"
end subroutine expressions_2
@ %def expressions_2
@ Test a subevent expression.
<<Eval trees: execute tests>>=
call test (expressions_3, "expressions_3", &
"check subevent expressions", &
u, results)
<<Eval trees: test declarations>>=
public :: expressions_3
<<Eval trees: tests>>=
subroutine expressions_3 (u)
integer, intent(in) :: u
type(subevt_t) :: subevt
write (u, "(A)") "* Test output: Expressions"
write (u, "(A)") "* Purpose: test subevent expressions"
write (u, "(A)")
write (u, "(A)") "* Initialize subevent:"
write (u, "(A)")
call subevt_init (subevt)
call subevt_reset (subevt, 1)
call subevt_set_incoming (subevt, 1, &
22, vector4_moving (1.e3_default, 1.e3_default, 1), &
0._default, [2])
call subevt_write (subevt, u)
call subevt_reset (subevt, 4)
call subevt_reset (subevt, 3)
call subevt_set_incoming (subevt, 1, &
21, vector4_moving (1.e3_default, 1.e3_default, 3), &
0._default, [1])
call subevt_polarize (subevt, 1, -1)
call subevt_set_outgoing (subevt, 2, &
1, vector4_moving (0._default, 1.e3_default, 3), &
-1.e6_default, [7])
call subevt_set_composite (subevt, 3, &
vector4_moving (-1.e3_default, 0._default, 3), &
[2, 7])
call subevt_write (subevt, u)
write (u, "(A)")
write (u, "(A)") "* Test output end: expressions_3"
end subroutine expressions_3
@ %def expressions_3
@ Test expressions from a PDG array.
<<Eval trees: execute tests>>=
call test (expressions_4, "expressions_4", &
"check pdg array expressions", &
u, results)
<<Eval trees: test declarations>>=
public :: expressions_4
<<Eval trees: tests>>=
subroutine expressions_4 (u)
integer, intent(in) :: u
type(subevt_t), target :: subevt
type(string_t) :: expr_text
type(ifile_t) :: ifile
type(stream_t) :: stream
type(eval_tree_t) :: eval_tree
type(var_list_t), pointer :: var_list => null ()
type(pdg_array_t) :: aval
write (u, "(A)") "* Test output: Expressions"
write (u, "(A)") "* Purpose: test pdg array expressions"
write (u, "(A)")
write (u, "(A)") "* Initialization:"
write (u, "(A)")
call syntax_pexpr_init ()
call syntax_write (syntax_pexpr, u)
allocate (var_list)
call var_list_append_real (var_list, var_str ("tolerance"), 0._default)
aval = 0
call var_list_append_pdg_array (var_list, var_str ("particle"), aval)
aval = [11,-11]
call var_list_append_pdg_array (var_list, var_str ("lepton"), aval)
aval = 22
call var_list_append_pdg_array (var_list, var_str ("photon"), aval)
aval = 1
call var_list_append_pdg_array (var_list, var_str ("u"), aval)
call subevt_init (subevt)
call subevt_reset (subevt, 6)
call subevt_set_incoming (subevt, 1, &
1, vector4_moving (1._default, 1._default, 1), 0._default)
call subevt_set_incoming (subevt, 2, &
-1, vector4_moving (2._default, 2._default, 1), 0._default)
call subevt_set_outgoing (subevt, 3, &
22, vector4_moving (3._default, 3._default, 1), 0._default)
call subevt_set_outgoing (subevt, 4, &
22, vector4_moving (4._default, 4._default, 1), 0._default)
call subevt_set_outgoing (subevt, 5, &
11, vector4_moving (5._default, 5._default, 1), 0._default)
call subevt_set_outgoing (subevt, 6, &
-11, vector4_moving (6._default, 6._default, 1), 0._default)
write (u, "(A)")
write (u, "(A)") "* Expression:"
expr_text = &
"let alias quark = pdg(1):pdg(2):pdg(3) in" // &
" any E > 3 GeV " // &
" [sort by - Pt " // &
" [select if Index < 6 " // &
" [photon:pdg(-11):pdg(3):quark " // &
" & incoming particle]]]" // &
" and" // &
" eval Theta [extract index -1 [photon]] > 45 degree" // &
" and" // &
" count [incoming photon] * 3 > 0"
write (u, "(A,A)") " ", char (expr_text)
write (u, "(A)")
write (u, "(A)")
write (u, "(A)") "* Extract the evaluation tree:"
write (u, "(A)")
call ifile_append (ifile, expr_text)
call stream_init (stream, ifile)
call eval_tree%init_stream (stream, var_list, subevt, V_LOG)
call eval_tree%write (u)
call eval_tree%evaluate ()
write (u, "(A)")
write (u, "(A)") "* Evaluate the tree:"
write (u, "(A)")
call eval_tree%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
write (u, "(A)")
call stream_final (stream)
call ifile_final (ifile)
call eval_tree%final ()
call var_list%final ()
deallocate (var_list)
call syntax_pexpr_final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: expressions_4"
end subroutine expressions_4
@ %def expressions_4
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Physics Models}
A model object represents a physics model. It contains a table of particle
data, a list of parameters, and a vertex table. The list of parameters is a
variable list which includes the real parameters (which are pointers to the
particle data table) and PDG array variables for the particles themselves.
The vertex list is used for phase-space generation, not for calculating the
matrix element.
The actual numeric model data are in the base type [[model_data_t]],
as part of the [[qft]] section. We implement the [[model_t]] as an
extension of this, for convenient direct access to the base-type
methods via inheritance. (Alternatively, we could delegate these calls
explicitly.) The extension contains administrative additions, such as
the methods for recalculating derived data and keeping the parameter
set consistent. It thus acts as a proxy of the actual model-data
object towards the \whizard\ package. There are further proxy
objects, such as the [[parameter_t]] array which provides the
interface to the actual numeric parameters.
Model definitions are read from model files. Therefore, this module contains
a parser for model files. The parameter definitions (derived parameters) are
Sindarin expressions.
The models, as read from file, are stored in a model library which is a simple
list of model definitions. For setting up a process object we should make a
copy (an instance) of a model, which gets the current parameter values from
the global variable list.
\subsection{Module}
<<[[models.f90]]>>=
<<File header>>
module models
use, intrinsic :: iso_c_binding !NODEP!
<<Use kinds>>
use kinds, only: c_default_float
<<Use strings>>
use io_units
use diagnostics
use md5
use os_interface
use physics_defs, only: UNDEFINED
use model_data
use ifiles
use syntax_rules
use lexers
use parser
use pdg_arrays
use variables
use expr_base
use eval_trees
use ttv_formfactors, only: init_parameters
<<Standard module head>>
<<Models: public>>
<<Models: parameters>>
<<Models: types>>
<<Models: interfaces>>
<<Models: variables>>
contains
<<Models: procedures>>
end module models
@ %def models
@
\subsection{Physics Parameters}
A parameter has a name, a value. Derived parameters also have a
definition in terms of other parameters, which is stored as an
[[eval_tree]]. External parameters are set by an external program.
This parameter object should be considered as a proxy object. The
parameter name and value are stored in a corresponding
[[modelpar_data_t]] object which is located in a [[model_data_t]]
object. The latter is a component of the [[model_t]] handler.
Methods of [[parameter_t]] can be delegated to the [[par_data_t]]
component.
The [[block_name]] and [[block_index]] values, if nonempty, indicate
the possibility of reading this parameter from a SLHA-type input file.
(Within the [[parameter_t]] object, this info is just used for I/O,
the actual block register is located in the parent [[model_t]]
object.)
The [[pn]] component is a pointer to the parameter definition inside the
model parse tree. It allows us to recreate the [[eval_tree]] when making
copies (instances) of the parameter object.
<<Models: parameters>>=
integer, parameter :: PAR_NONE = 0, PAR_UNUSED = -1
integer, parameter :: PAR_INDEPENDENT = 1, PAR_DERIVED = 2
integer, parameter :: PAR_EXTERNAL = 3
@ %def PAR_NONE PAR_INDEPENDENT PAR_DERIVED PAR_EXTERNAL PAR_UNUSED
<<Models: types>>=
type :: parameter_t
private
integer :: type = PAR_NONE
class(modelpar_data_t), pointer :: data => null ()
type(string_t) :: block_name
integer, dimension(:), allocatable :: block_index
type(parse_node_t), pointer :: pn => null ()
class(expr_t), allocatable :: expr
contains
<<Models: parameter: TBP>>
end type parameter_t
@ %def parameter_t
@ Initialization depends on parameter type. Independent parameters
are initialized by a constant value or a constant numerical expression
(which may contain a unit). Derived parameters are initialized by an
arbitrary numerical expression, which makes use of the current
variable list. The expression is evaluated by the function
[[parameter_reset]].
This implementation supports only real parameters and real values.
<<Models: parameter: TBP>>=
procedure :: init_independent_value => parameter_init_independent_value
procedure :: init_independent => parameter_init_independent
procedure :: init_derived => parameter_init_derived
procedure :: init_external => parameter_init_external
procedure :: init_unused => parameter_init_unused
<<Models: procedures>>=
subroutine parameter_init_independent_value (par, par_data, name, value)
class(parameter_t), intent(out) :: par
class(modelpar_data_t), intent(in), target :: par_data
type(string_t), intent(in) :: name
real(default), intent(in) :: value
par%type = PAR_INDEPENDENT
par%data => par_data
call par%data%init (name, value)
end subroutine parameter_init_independent_value
subroutine parameter_init_independent (par, par_data, name, pn)
class(parameter_t), intent(out) :: par
class(modelpar_data_t), intent(in), target :: par_data
type(string_t), intent(in) :: name
type(parse_node_t), intent(in), target :: pn
par%type = PAR_INDEPENDENT
par%pn => pn
allocate (eval_tree_t :: par%expr)
select type (expr => par%expr)
type is (eval_tree_t)
call expr%init_numeric_value (pn)
end select
par%data => par_data
call par%data%init (name, par%expr%get_real ())
end subroutine parameter_init_independent
subroutine parameter_init_derived (par, par_data, name, pn, var_list)
class(parameter_t), intent(out) :: par
class(modelpar_data_t), intent(in), target :: par_data
type(string_t), intent(in) :: name
type(parse_node_t), intent(in), target :: pn
type(var_list_t), intent(in), target :: var_list
par%type = PAR_DERIVED
par%pn => pn
allocate (eval_tree_t :: par%expr)
select type (expr => par%expr)
type is (eval_tree_t)
call expr%init_expr (pn, var_list=var_list)
end select
par%data => par_data
! call par%expr%evaluate ()
call par%data%init (name, 0._default)
end subroutine parameter_init_derived
subroutine parameter_init_external (par, par_data, name)
class(parameter_t), intent(out) :: par
class(modelpar_data_t), intent(in), target :: par_data
type(string_t), intent(in) :: name
par%type = PAR_EXTERNAL
par%data => par_data
call par%data%init (name, 0._default)
end subroutine parameter_init_external
subroutine parameter_init_unused (par, par_data, name)
class(parameter_t), intent(out) :: par
class(modelpar_data_t), intent(in), target :: par_data
type(string_t), intent(in) :: name
par%type = PAR_UNUSED
par%data => par_data
call par%data%init (name, 0._default)
end subroutine parameter_init_unused
@ %def parameter_init_independent_value
@ %def parameter_init_independent
@ %def parameter_init_derived
@ %def parameter_init_external
@ %def parameter_init_unused
@ The finalizer is needed for the evaluation tree in the definition.
<<Models: parameter: TBP>>=
procedure :: final => parameter_final
<<Models: procedures>>=
subroutine parameter_final (par)
class(parameter_t), intent(inout) :: par
if (allocated (par%expr)) then
call par%expr%final ()
end if
end subroutine parameter_final
@ %def parameter_final
@ All derived parameters should be recalculated if some independent
parameters have changed:
<<Models: parameter: TBP>>=
procedure :: reset_derived => parameter_reset_derived
<<Models: procedures>>=
subroutine parameter_reset_derived (par)
class(parameter_t), intent(inout) :: par
select case (par%type)
case (PAR_DERIVED)
call par%expr%evaluate ()
par%data = par%expr%get_real ()
end select
end subroutine parameter_reset_derived
@ %def parameter_reset_derived parameter_reset_external
@ Output. [We should have a formula format for the eval tree,
suitable for input and output!]
<<Models: parameter: TBP>>=
procedure :: write => parameter_write
<<Models: procedures>>=
subroutine parameter_write (par, unit, write_defs)
class(parameter_t), intent(in) :: par
integer, intent(in), optional :: unit
logical, intent(in), optional :: write_defs
logical :: defs
integer :: u
u = given_output_unit (unit); if (u < 0) return
defs = .false.; if (present (write_defs)) defs = write_defs
select case (par%type)
case (PAR_INDEPENDENT)
write (u, "(3x,A)", advance="no") "parameter"
call par%data%write (u)
case (PAR_DERIVED)
write (u, "(3x,A)", advance="no") "derived"
call par%data%write (u)
case (PAR_EXTERNAL)
write (u, "(3x,A)", advance="no") "external"
call par%data%write (u)
case (PAR_UNUSED)
write (u, "(3x,A)", advance="no") "unused"
write (u, "(1x,A)", advance="no") char (par%data%get_name ())
end select
select case (par%type)
case (PAR_INDEPENDENT)
if (allocated (par%block_index)) then
write (u, "(1x,A,1x,A,*(1x,I0))") &
"slha_entry", char (par%block_name), par%block_index
else
write (u, "(A)")
end if
case (PAR_DERIVED)
if (defs) then
call par%expr%write (unit)
else
write (u, "(A)")
end if
case default
write (u, "(A)")
end select
end subroutine parameter_write
@ %def parameter_write
@ Screen output variant. Restrict output to the given parameter type.
<<Models: parameter: TBP>>=
procedure :: show => parameter_show
<<Models: procedures>>=
subroutine parameter_show (par, l, u, partype)
class(parameter_t), intent(in) :: par
integer, intent(in) :: l, u
integer, intent(in) :: partype
if (par%type == partype) then
call par%data%show (l, u)
end if
end subroutine parameter_show
@ %def parameter_show
@
\subsection{SLHA block register}
For the optional SLHA interface, the model record contains a register
of SLHA-type block names together with index values, which point to a
particular parameter. These are private types:
<<Models: types>>=
type :: slha_entry_t
integer, dimension(:), allocatable :: block_index
integer :: i_par = 0
end type slha_entry_t
@ %def slha_entry_t
<<Models: types>>=
type :: slha_block_t
type(string_t) :: name
integer :: n_entry = 0
type(slha_entry_t), dimension(:), allocatable :: entry
end type slha_block_t
@ %def slha_block_t
@
\subsection{Model Object}
A model object holds all information about parameters, particles,
and vertices. For models that require an external program for
parameter calculation, there is the pointer to a function that does
this calculation, given the set of independent and derived parameters.
As explained above, the type inherits from [[model_data_t]], which is
the actual storage for the model data.
When reading a model, we create a parse tree. Parameter definitions are
available via parse nodes. Since we may need those later when making model
instances, we keep the whole parse tree in the model definition (but not in
the instances).
<<Models: public>>=
public :: model_t
<<Models: types>>=
type, extends (model_data_t) :: model_t
private
character(32) :: md5sum = ""
logical :: ufo_model = .false.
type(string_t) :: ufo_path
type(string_t), dimension(:), allocatable :: schemes
type(string_t), allocatable :: selected_scheme
type(parameter_t), dimension(:), allocatable :: par
integer :: n_slha_block = 0
type(slha_block_t), dimension(:), allocatable :: slha_block
integer :: max_par_name_length = 0
integer :: max_field_name_length = 0
type(var_list_t) :: var_list
type(string_t) :: dlname
procedure(model_init_external_parameters), nopass, pointer :: &
init_external_parameters => null ()
type(dlaccess_t) :: dlaccess
type(parse_tree_t) :: parse_tree
contains
<<Models: model: TBP>>
end type model_t
@ %def model_t
@ This is the interface for a procedure that initializes the
calculation of external parameters, given the array of all
parameters.
<<Models: interfaces>>=
abstract interface
subroutine model_init_external_parameters (par) bind (C)
import
real(c_default_float), dimension(*), intent(inout) :: par
end subroutine model_init_external_parameters
end interface
@ %def model_init_external_parameters
@ Initialization: Specify the number of parameters, particles,
vertices and allocate memory. If an associated DL library is
specified, load this library.
The model may already carry scheme information, so we have to save and
restore the scheme number when actually initializing the [[model_data_t]]
base.
<<Models: model: TBP>>=
generic :: init => model_init
procedure, private :: model_init
<<Models: procedures>>=
subroutine model_init &
(model, name, libname, os_data, n_par, n_prt, n_vtx, ufo)
class(model_t), intent(inout) :: model
type(string_t), intent(in) :: name, libname
type(os_data_t), intent(in) :: os_data
integer, intent(in) :: n_par, n_prt, n_vtx
logical, intent(in), optional :: ufo
type(c_funptr) :: c_fptr
type(string_t) :: libpath
integer :: scheme_num
scheme_num = model%get_scheme_num ()
call model%basic_init (name, n_par, n_prt, n_vtx)
if (present (ufo)) model%ufo_model = ufo
call model%set_scheme_num (scheme_num)
if (libname /= "") then
if (.not. os_data%use_testfiles) then
libpath = os_data%whizard_models_libpath_local
model%dlname = os_get_dlname ( &
libpath // "/" // libname, os_data, ignore=.true.)
end if
if (model%dlname == "") then
libpath = os_data%whizard_models_libpath
model%dlname = os_get_dlname (libpath // "/" // libname, os_data)
end if
else
model%dlname = ""
end if
if (model%dlname /= "") then
if (.not. dlaccess_is_open (model%dlaccess)) then
if (logging) &
call msg_message ("Loading model auxiliary library '" &
// char (libpath) // "/" // char (model%dlname) // "'")
call dlaccess_init (model%dlaccess, os_data%whizard_models_libpath, &
model%dlname, os_data)
if (dlaccess_has_error (model%dlaccess)) then
call msg_message (char (dlaccess_get_error (model%dlaccess)))
call msg_fatal ("Loading model auxiliary library '" &
// char (model%dlname) // "' failed")
return
end if
c_fptr = dlaccess_get_c_funptr (model%dlaccess, &
var_str ("init_external_parameters"))
if (dlaccess_has_error (model%dlaccess)) then
call msg_message (char (dlaccess_get_error (model%dlaccess)))
call msg_fatal ("Loading function from auxiliary library '" &
// char (model%dlname) // "' failed")
return
end if
call c_f_procpointer (c_fptr, model% init_external_parameters)
end if
end if
end subroutine model_init
@ %def model_init
@ For a model instance, we do not attempt to load a DL library. This is the
core of the full initializer above.
<<Models: model: TBP>>=
procedure, private :: basic_init => model_basic_init
<<Models: procedures>>=
subroutine model_basic_init (model, name, n_par, n_prt, n_vtx)
class(model_t), intent(inout) :: model
type(string_t), intent(in) :: name
integer, intent(in) :: n_par, n_prt, n_vtx
allocate (model%par (n_par))
call model%model_data_t%init (name, n_par, 0, n_prt, n_vtx)
end subroutine model_basic_init
@ %def model_basic_init
@ Finalization: The variable list contains allocated pointers, also the parse
tree. We also close the DL access object, if any, that enables external
parameter calculation.
<<Models: model: TBP>>=
procedure :: final => model_final
<<Models: procedures>>=
subroutine model_final (model)
class(model_t), intent(inout) :: model
integer :: i
if (allocated (model%par)) then
do i = 1, size (model%par)
call model%par(i)%final ()
end do
end if
call model%var_list%final (follow_link=.false.)
if (model%dlname /= "") call dlaccess_final (model%dlaccess)
call parse_tree_final (model%parse_tree)
call model%model_data_t%final ()
end subroutine model_final
@ %def model_final
@ Output. By default, the output is in the form of an input file. If
[[verbose]] is true, for each derived parameter the definition (eval
tree) is displayed, and the vertex hash table is shown.
<<Models: model: TBP>>=
procedure :: write => model_write
<<Models: procedures>>=
subroutine model_write (model, unit, verbose, &
show_md5sum, show_variables, show_parameters, &
show_particles, show_vertices, show_scheme)
class(model_t), intent(in) :: model
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
logical, intent(in), optional :: show_md5sum
logical, intent(in), optional :: show_variables
logical, intent(in), optional :: show_parameters
logical, intent(in), optional :: show_particles
logical, intent(in), optional :: show_vertices
logical, intent(in), optional :: show_scheme
logical :: verb, show_md5, show_par, show_var
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
verb = .false.; if (present (verbose)) verb = verbose
show_md5 = .true.; if (present (show_md5sum)) &
show_md5 = show_md5sum
show_par = .true.; if (present (show_parameters)) &
show_par = show_parameters
show_var = verb; if (present (show_variables)) &
show_var = show_variables
write (u, "(A,A,A)") 'model "', char (model%get_name ()), '"'
if (show_md5 .and. model%md5sum /= "") &
write (u, "(1x,A,A,A)") "! md5sum = '", model%md5sum, "'"
if (model%is_ufo_model ()) then
write (u, "(1x,A)") "! model derived from UFO source"
else if (model%has_schemes ()) then
write (u, "(1x,A)", advance="no") "! schemes ="
do i = 1, size (model%schemes)
if (i > 1) write (u, "(',')", advance="no")
write (u, "(1x,A,A,A)", advance="no") &
"'", char (model%schemes(i)), "'"
end do
write (u, *)
if (allocated (model%selected_scheme)) then
write (u, "(1x,A,A,A,I0,A)") &
"! selected scheme = '", char (model%get_scheme ()), &
"' (", model%get_scheme_num (), ")"
end if
end if
if (show_par) then
write (u, "(A)")
do i = 1, size (model%par)
call model%par(i)%write (u, write_defs=verbose)
end do
end if
call model%model_data_t%write (unit, verbose, &
show_md5sum, show_variables, &
show_parameters=.false., &
show_particles=show_particles, &
show_vertices=show_vertices, &
show_scheme=show_scheme)
if (show_var) then
write (u, "(A)")
call var_list_write (model%var_list, unit, follow_link=.false.)
end if
end subroutine model_write
@ %def model_write
@ Screen output, condensed form.
<<Models: model: TBP>>=
procedure :: show => model_show
<<Models: procedures>>=
subroutine model_show (model, unit)
class(model_t), intent(in) :: model
integer, intent(in), optional :: unit
integer :: i, u, l
u = given_output_unit (unit)
write (u, "(A,1x,A)") "Model:", char (model%get_name ())
if (model%has_schemes ()) then
write (u, "(2x,A,A,A,I0,A)") "Scheme: '", &
char (model%get_scheme ()), "' (", model%get_scheme_num (), ")"
end if
l = model%max_field_name_length
call model%show_fields (l, u)
l = model%max_par_name_length
if (any (model%par%type == PAR_INDEPENDENT)) then
write (u, "(2x,A)") "Independent parameters:"
do i = 1, size (model%par)
call model%par(i)%show (l, u, PAR_INDEPENDENT)
end do
end if
if (any (model%par%type == PAR_DERIVED)) then
write (u, "(2x,A)") "Derived parameters:"
do i = 1, size (model%par)
call model%par(i)%show (l, u, PAR_DERIVED)
end do
end if
if (any (model%par%type == PAR_EXTERNAL)) then
write (u, "(2x,A)") "External parameters:"
do i = 1, size (model%par)
call model%par(i)%show (l, u, PAR_EXTERNAL)
end do
end if
if (any (model%par%type == PAR_UNUSED)) then
write (u, "(2x,A)") "Unused parameters:"
do i = 1, size (model%par)
call model%par(i)%show (l, u, PAR_UNUSED)
end do
end if
end subroutine model_show
@ %def model_show
@ Show all fields/particles.
<<Models: model: TBP>>=
procedure :: show_fields => model_show_fields
<<Models: procedures>>=
subroutine model_show_fields (model, l, unit)
class(model_t), intent(in), target :: model
integer, intent(in) :: l
integer, intent(in), optional :: unit
type(field_data_t), pointer :: field
integer :: u, i
u = given_output_unit (unit)
write (u, "(2x,A)") "Particles:"
do i = 1, model%get_n_field ()
field => model%get_field_ptr_by_index (i)
call field%show (l, u)
end do
end subroutine model_show_fields
@ %def model_data_show_fields
@ Show the list of stable, unstable, polarized, or unpolarized
particles, respectively.
<<Models: model: TBP>>=
procedure :: show_stable => model_show_stable
procedure :: show_unstable => model_show_unstable
procedure :: show_polarized => model_show_polarized
procedure :: show_unpolarized => model_show_unpolarized
<<Models: procedures>>=
subroutine model_show_stable (model, unit)
class(model_t), intent(in), target :: model
integer, intent(in), optional :: unit
type(field_data_t), pointer :: field
integer :: u, i
u = given_output_unit (unit)
write (u, "(A,1x)", advance="no") "Stable particles:"
do i = 1, model%get_n_field ()
field => model%get_field_ptr_by_index (i)
if (field%is_stable (.false.)) then
write (u, "(1x,A)", advance="no") char (field%get_name (.false.))
end if
if (field%has_antiparticle ()) then
if (field%is_stable (.true.)) then
write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
end if
end if
end do
write (u, *)
end subroutine model_show_stable
subroutine model_show_unstable (model, unit)
class(model_t), intent(in), target :: model
integer, intent(in), optional :: unit
type(field_data_t), pointer :: field
integer :: u, i
u = given_output_unit (unit)
write (u, "(A,1x)", advance="no") "Unstable particles:"
do i = 1, model%get_n_field ()
field => model%get_field_ptr_by_index (i)
if (.not. field%is_stable (.false.)) then
write (u, "(1x,A)", advance="no") char (field%get_name (.false.))
end if
if (field%has_antiparticle ()) then
if (.not. field%is_stable (.true.)) then
write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
end if
end if
end do
write (u, *)
end subroutine model_show_unstable
subroutine model_show_polarized (model, unit)
class(model_t), intent(in), target :: model
integer, intent(in), optional :: unit
type(field_data_t), pointer :: field
integer :: u, i
u = given_output_unit (unit)
write (u, "(A,1x)", advance="no") "Polarized particles:"
do i = 1, model%get_n_field ()
field => model%get_field_ptr_by_index (i)
if (field%is_polarized (.false.)) then
write (u, "(1x,A)", advance="no") char (field%get_name (.false.))
end if
if (field%has_antiparticle ()) then
if (field%is_polarized (.true.)) then
write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
end if
end if
end do
write (u, *)
end subroutine model_show_polarized
subroutine model_show_unpolarized (model, unit)
class(model_t), intent(in), target :: model
integer, intent(in), optional :: unit
type(field_data_t), pointer :: field
integer :: u, i
u = given_output_unit (unit)
write (u, "(A,1x)", advance="no") "Unpolarized particles:"
do i = 1, model%get_n_field ()
field => model%get_field_ptr_by_index (i)
if (.not. field%is_polarized (.false.)) then
write (u, "(1x,A)", advance="no") &
char (field%get_name (.false.))
end if
if (field%has_antiparticle ()) then
if (.not. field%is_polarized (.true.)) then
write (u, "(1x,A)", advance="no") char (field%get_name (.true.))
end if
end if
end do
write (u, *)
end subroutine model_show_unpolarized
@ %def model_show_stable
@ %def model_show_unstable
@ %def model_show_polarized
@ %def model_show_unpolarized
@ Retrieve the MD5 sum of a model (actually, of the model file).
<<Models: model: TBP>>=
procedure :: get_md5sum => model_get_md5sum
<<Models: procedures>>=
function model_get_md5sum (model) result (md5sum)
character(32) :: md5sum
class(model_t), intent(in) :: model
md5sum = model%md5sum
end function model_get_md5sum
@ %def model_get_md5sum
@ Parameters are defined by an expression which may be constant or
arbitrary.
<<Models: model: TBP>>=
procedure :: &
set_parameter_constant => model_set_parameter_constant
procedure, private :: &
set_parameter_parse_node => model_set_parameter_parse_node
procedure :: &
set_parameter_external => model_set_parameter_external
procedure :: &
set_parameter_unused => model_set_parameter_unused
<<Models: procedures>>=
subroutine model_set_parameter_constant (model, i, name, value)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name
real(default), intent(in) :: value
logical, save, target :: known = .true.
class(modelpar_data_t), pointer :: par_data
real(default), pointer :: value_ptr
par_data => model%get_par_real_ptr (i)
call model%par(i)%init_independent_value (par_data, name, value)
value_ptr => par_data%get_real_ptr ()
call var_list_append_real_ptr (model%var_list, &
name, value_ptr, &
is_known=known, intrinsic=.true.)
model%max_par_name_length = max (model%max_par_name_length, len (name))
end subroutine model_set_parameter_constant
subroutine model_set_parameter_parse_node (model, i, name, pn, constant)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name
type(parse_node_t), intent(in), target :: pn
logical, intent(in) :: constant
logical, save, target :: known = .true.
class(modelpar_data_t), pointer :: par_data
real(default), pointer :: value_ptr
par_data => model%get_par_real_ptr (i)
if (constant) then
call model%par(i)%init_independent (par_data, name, pn)
else
call model%par(i)%init_derived (par_data, name, pn, model%var_list)
end if
value_ptr => par_data%get_real_ptr ()
call var_list_append_real_ptr (model%var_list, &
name, value_ptr, &
is_known=known, locked=.not.constant, intrinsic=.true.)
model%max_par_name_length = max (model%max_par_name_length, len (name))
end subroutine model_set_parameter_parse_node
subroutine model_set_parameter_external (model, i, name)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name
logical, save, target :: known = .true.
class(modelpar_data_t), pointer :: par_data
real(default), pointer :: value_ptr
par_data => model%get_par_real_ptr (i)
call model%par(i)%init_external (par_data, name)
value_ptr => par_data%get_real_ptr ()
call var_list_append_real_ptr (model%var_list, &
name, value_ptr, &
is_known=known, locked=.true., intrinsic=.true.)
model%max_par_name_length = max (model%max_par_name_length, len (name))
end subroutine model_set_parameter_external
subroutine model_set_parameter_unused (model, i, name)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name
class(modelpar_data_t), pointer :: par_data
par_data => model%get_par_real_ptr (i)
call model%par(i)%init_unused (par_data, name)
call var_list_append_real (model%var_list, &
name, locked=.true., intrinsic=.true.)
model%max_par_name_length = max (model%max_par_name_length, len (name))
end subroutine model_set_parameter_unused
@ %def model_set_parameter
@ Make a copy of a parameter. We assume that the [[model_data_t]]
parameter arrays have already been copied, so names and values are
available in the current model, and can be used as targets. The eval
tree should not be copied, since it should refer to the new variable
list. The safe solution is to make use of the above initializers,
which also take care of the building a new variable list.
<<Models: model: TBP>>=
procedure, private :: copy_parameter => model_copy_parameter
<<Models: procedures>>=
subroutine model_copy_parameter (model, i, par)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(parameter_t), intent(in) :: par
type(string_t) :: name
real(default) :: value
name = par%data%get_name ()
select case (par%type)
case (PAR_INDEPENDENT)
if (associated (par%pn)) then
call model%set_parameter_parse_node (i, name, par%pn, &
constant = .true.)
else
value = par%data%get_real ()
call model%set_parameter_constant (i, name, value)
end if
if (allocated (par%block_index)) then
model%par(i)%block_name = par%block_name
model%par(i)%block_index = par%block_index
end if
case (PAR_DERIVED)
call model%set_parameter_parse_node (i, name, par%pn, &
constant = .false.)
case (PAR_EXTERNAL)
call model%set_parameter_external (i, name)
case (PAR_UNUSED)
call model%set_parameter_unused (i, name)
end select
end subroutine model_copy_parameter
@ %def model_copy_parameter
@ Recalculate all derived parameters.
<<Models: model: TBP>>=
procedure :: update_parameters => model_parameters_update
<<Models: procedures>>=
subroutine model_parameters_update (model)
class(model_t), intent(inout) :: model
integer :: i
real(default), dimension(:), allocatable :: par
do i = 1, size (model%par)
call model%par(i)%reset_derived ()
end do
if (associated (model%init_external_parameters)) then
allocate (par (model%get_n_real ()))
call model%real_parameters_to_c_array (par)
call model%init_external_parameters (par)
call model%real_parameters_from_c_array (par)
if (model%get_name() == var_str ("SM_tt_threshold")) &
call set_threshold_parameters ()
end if
contains
subroutine set_threshold_parameters ()
real(default) :: mpole, wtop
!!! !!! !!! Workaround for OS-X and BSD which do not load
!!! !!! !!! the global values created previously. Therefore
!!! !!! !!! a second initialization for the threshold model,
!!! !!! !!! where M1S is required to compute the top mass.
call init_parameters (mpole, wtop, &
par(20), par(21), par(22), &
par(19), par(39), par(4), par(1), &
par(2), par(10), par(24), par(25), &
par(23), par(26), par(27), par(29), &
par(30), par(31), par(32), par(33), &
par(36) > 0._default, par(28))
end subroutine set_threshold_parameters
end subroutine model_parameters_update
@ %def model_parameters_update
@ Initialize field data with PDG long name and PDG code.
<<Models: model: TBP>>=
procedure, private :: init_field => model_init_field
<<Models: procedures>>=
subroutine model_init_field (model, i, longname, pdg)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(string_t), intent(in) :: longname
integer, intent(in) :: pdg
type(field_data_t), pointer :: field
field => model%get_field_ptr_by_index (i)
call field%init (longname, pdg)
end subroutine model_init_field
@ %def model_init_field
@ Copy field data for index [[i]] from another particle which serves
as a template. The name should be the unique long name.
<<Models: model: TBP>>=
procedure, private :: copy_field => model_copy_field
<<Models: procedures>>=
subroutine model_copy_field (model, i, name_src)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(string_t), intent(in) :: name_src
type(field_data_t), pointer :: field_src, field
field_src => model%get_field_ptr (name_src)
field => model%get_field_ptr_by_index (i)
call field%copy_from (field_src)
end subroutine model_copy_field
@ %def model_copy_field
@
\subsection{Model Access via Variables}
Write the model variable list.
<<Models: model: TBP>>=
procedure :: write_var_list => model_write_var_list
<<Models: procedures>>=
subroutine model_write_var_list (model, unit, follow_link)
class(model_t), intent(in) :: model
integer, intent(in), optional :: unit
logical, intent(in), optional :: follow_link
call var_list_write (model%var_list, unit, follow_link)
end subroutine model_write_var_list
@ %def model_write_var_list
@ Link a variable list to the model variables.
<<Models: model: TBP>>=
procedure :: link_var_list => model_link_var_list
<<Models: procedures>>=
subroutine model_link_var_list (model, var_list)
class(model_t), intent(inout) :: model
type(var_list_t), intent(in), target :: var_list
call model%var_list%link (var_list)
end subroutine model_link_var_list
@ %def model_link_var_list
@
Check if the model contains a named variable.
<<Models: model: TBP>>=
procedure :: var_exists => model_var_exists
<<Models: procedures>>=
function model_var_exists (model, name) result (flag)
class(model_t), intent(in) :: model
type(string_t), intent(in) :: name
logical :: flag
flag = model%var_list%contains (name, follow_link=.false.)
end function model_var_exists
@ %def model_var_exists
@ Check if the model variable is a derived parameter, i.e., locked.
<<Models: model: TBP>>=
procedure :: var_is_locked => model_var_is_locked
<<Models: procedures>>=
function model_var_is_locked (model, name) result (flag)
class(model_t), intent(in) :: model
type(string_t), intent(in) :: name
logical :: flag
flag = model%var_list%is_locked (name, follow_link=.false.)
end function model_var_is_locked
@ %def model_var_is_locked
@ Set a model parameter via the named variable. We assume that the
variable exists and is writable, i.e., non-locked. We update the
model and variable list, so independent and derived parameters are
always synchronized.
<<Models: model: TBP>>=
procedure :: set_real => model_var_set_real
<<Models: procedures>>=
subroutine model_var_set_real (model, name, rval, verbose, pacified)
class(model_t), intent(inout) :: model
type(string_t), intent(in) :: name
real(default), intent(in) :: rval
logical, intent(in), optional :: verbose, pacified
call model%var_list%set_real (name, rval, &
is_known=.true., ignore=.false., &
verbose=verbose, model_name=model%get_name (), pacified=pacified)
call model%update_parameters ()
end subroutine model_var_set_real
@ %def model_var_set_real
@ Retrieve a model parameter value.
<<Models: model: TBP>>=
procedure :: get_rval => model_var_get_rval
<<Models: procedures>>=
function model_var_get_rval (model, name) result (rval)
class(model_t), intent(in) :: model
type(string_t), intent(in) :: name
real(default) :: rval
rval = model%var_list%get_rval (name, follow_link=.false.)
end function model_var_get_rval
@ %def model_var_get_rval
@
[To be deleted] Return a pointer to the variable list.
<<Models: model: TBP>>=
procedure :: get_var_list_ptr => model_get_var_list_ptr
<<Models: procedures>>=
function model_get_var_list_ptr (model) result (var_list)
type(var_list_t), pointer :: var_list
class(model_t), intent(in), target :: model
var_list => model%var_list
end function model_get_var_list_ptr
@ %def model_get_var_list_ptr
@
\subsection{UFO models}
A single flag identifies a model as a UFO model. There is no other
distinction, but the flag allows us to handle built-in and UFO models
with the same name in parallel.
<<Models: model: TBP>>=
procedure :: is_ufo_model => model_is_ufo_model
<<Models: procedures>>=
function model_is_ufo_model (model) result (flag)
class(model_t), intent(in) :: model
logical :: flag
flag = model%ufo_model
end function model_is_ufo_model
@ %def model_is_ufo_model
@ Return the UFO path used for fetching the UFO source.
<<Models: model: TBP>>=
procedure :: get_ufo_path => model_get_ufo_path
<<Models: procedures>>=
function model_get_ufo_path (model) result (path)
class(model_t), intent(in) :: model
type(string_t) :: path
if (model%ufo_model) then
path = model%ufo_path
else
path = ""
end if
end function model_get_ufo_path
@ %def model_get_ufo_path
@
Call OMega and generate a model file from an UFO source file. We
start with a file name; the model name is expected to be the base
name, stripping extensions.
The path search either takes [[ufo_path_requested]], or searches first
in the working directory, then in a hard-coded UFO model directory.
<<Models: procedures>>=
subroutine model_generate_ufo (filename, os_data, ufo_path, &
ufo_path_requested)
type(string_t), intent(in) :: filename
type(os_data_t), intent(in) :: os_data
type(string_t), intent(out) :: ufo_path
type(string_t), intent(in), optional :: ufo_path_requested
type(string_t) :: model_name, omega_path, ufo_dir, ufo_init
logical :: exist
call get_model_name (filename, model_name)
call msg_message ("Model: Generating model '" // char (model_name) &
// "' from UFO sources")
if (present (ufo_path_requested)) then
call msg_message ("Model: Searching for UFO sources in '" &
// char (ufo_path_requested) // "'")
ufo_path = ufo_path_requested
ufo_dir = ufo_path_requested // "/" // model_name
ufo_init = ufo_dir // "/" // "__init__.py"
inquire (file = char (ufo_init), exist = exist)
else
call msg_message ("Model: Searching for UFO sources in &
&working directory")
ufo_path = "."
ufo_dir = ufo_path // "/" // model_name
ufo_init = ufo_dir // "/" // "__init__.py"
inquire (file = char (ufo_init), exist = exist)
if (.not. exist) then
ufo_path = char (os_data%whizard_modelpath_ufo)
ufo_dir = ufo_path // "/" // model_name
ufo_init = ufo_dir // "/" // "__init__.py"
call msg_message ("Model: Searching for UFO sources in '" &
// char (os_data%whizard_modelpath_ufo) // "'")
inquire (file = char (ufo_init), exist = exist)
end if
end if
if (exist) then
call msg_message ("Model: Found UFO sources for model '" &
// char (model_name) // "'")
else
call msg_fatal ("Model: UFO sources for model '" &
// char (model_name) // "' not found")
end if
omega_path = os_data%whizard_omega_binpath // "/omega_UFO.opt"
call os_system_call (omega_path &
// " -model:UFO_dir " // ufo_dir &
// " -model:exec" &
// " -model:write_WHIZARD" &
// " > " // filename)
inquire (file = char (filename), exist = exist)
if (exist) then
call msg_message ("Model: Model file '" // char (filename) //&
"' generated")
else
call msg_fatal ("Model: Model file '" // char (filename) &
// "' could not be generated")
end if
contains
subroutine get_model_name (filename, model_name)
type(string_t), intent(in) :: filename
type(string_t), intent(out) :: model_name
type(string_t) :: string
string = filename
call split (string, model_name, ".")
end subroutine get_model_name
end subroutine model_generate_ufo
@ %def model_generate_ufo
@
\subsection{Scheme handling}
A model can specify a set of allowed schemes that steer the setup of
model variables. The model file can contain scheme-specific
declarations that are selected by a [[select scheme]] clause. Scheme
support is optional.
If enabled, the model object contains a list of allowed schemes, and
the model reader takes the active scheme as an argument. After the
model has been read, the scheme is fixed and can no longer be
modified.
The model supports schemes if the scheme array is allocated.
<<Models: model: TBP>>=
procedure :: has_schemes => model_has_schemes
<<Models: procedures>>=
function model_has_schemes (model) result (flag)
logical :: flag
class(model_t), intent(in) :: model
flag = allocated (model%schemes)
end function model_has_schemes
@ %def model_has_schemes
@
Enable schemes: fix the list of allowed schemes.
<<Models: model: TBP>>=
procedure :: enable_schemes => model_enable_schemes
<<Models: procedures>>=
subroutine model_enable_schemes (model, scheme)
class(model_t), intent(inout) :: model
type(string_t), dimension(:), intent(in) :: scheme
allocate (model%schemes (size (scheme)), source = scheme)
end subroutine model_enable_schemes
@ %def model_enable_schemes
@
Find the scheme. Check if the scheme is allowed. The numeric index of the
selected scheme is stored in the [[model_data_t]] base object.
If no argument is given,
select the first scheme. The numeric scheme ID will then be $1$, while a
model without schemes retains $0$.
<<Models: model: TBP>>=
procedure :: set_scheme => model_set_scheme
<<Models: procedures>>=
subroutine model_set_scheme (model, scheme)
class(model_t), intent(inout) :: model
type(string_t), intent(in), optional :: scheme
logical :: ok
integer :: i
if (model%has_schemes ()) then
if (present (scheme)) then
ok = .false.
CHECK_SCHEME: do i = 1, size (model%schemes)
if (scheme == model%schemes(i)) then
allocate (model%selected_scheme, source = scheme)
call model%set_scheme_num (i)
ok = .true.
exit CHECK_SCHEME
end if
end do CHECK_SCHEME
if (.not. ok) then
call msg_fatal &
("Model '" // char (model%get_name ()) &
// "': scheme '" // char (scheme) // "' not supported")
end if
else
allocate (model%selected_scheme, source = model%schemes(1))
call model%set_scheme_num (1)
end if
else
if (present (scheme)) then
call msg_error &
("Model '" // char (model%get_name ()) &
// "' does not support schemes")
end if
end if
end subroutine model_set_scheme
@ %def model_set_scheme
@
Get the scheme. Note that the base [[model_data_t]] provides a
[[get_scheme_num]] getter function.
<<Models: model: TBP>>=
procedure :: get_scheme => model_get_scheme
<<Models: procedures>>=
function model_get_scheme (model) result (scheme)
class(model_t), intent(in) :: model
type(string_t) :: scheme
if (allocated (model%selected_scheme)) then
scheme = model%selected_scheme
else
scheme = ""
end if
end function model_get_scheme
@ %def model_get_scheme
@
Check if a model has been set up with a specific name and (if
applicable) scheme. This helps in determining whether we need a new
model object.
A UFO model is considered to be distinct from a non-UFO model. We assume that
if [[ufo]] is asked for, there is no scheme argument. Furthermore,
if there is an [[ufo_path]] requested, it must coincide with the
[[ufo_path]] of the model. If not, the model [[ufo_path]] is not checked.
<<Models: model: TBP>>=
procedure :: matches => model_matches
<<Models: procedures>>=
function model_matches (model, name, scheme, ufo, ufo_path) result (flag)
logical :: flag
class(model_t), intent(in) :: model
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: scheme
logical, intent(in), optional :: ufo
type(string_t), intent(in), optional :: ufo_path
logical :: ufo_model
ufo_model = .false.; if (present (ufo)) ufo_model = ufo
if (name /= model%get_name ()) then
flag = .false.
else if (ufo_model .neqv. model%is_ufo_model ()) then
flag = .false.
else if (ufo_model) then
if (present (ufo_path)) then
flag = model%get_ufo_path () == ufo_path
else
flag = .true.
end if
else if (model%has_schemes ()) then
if (present (scheme)) then
flag = model%get_scheme () == scheme
else
flag = model%get_scheme_num () == 1
end if
else if (present (scheme)) then
flag = .false.
else
flag = .true.
end if
end function model_matches
@ %def model_matches
@
\subsection{SLHA-type interface}
Abusing the original strict SUSY Les Houches Accord (SLHA), we support
reading parameter data from some custom SLHA-type input file. To this
end, the [[model]] object stores a list of model-specific block names
together with information how to find a parameter in the model record,
given a block name and index vector.
Check if the model supports custom SLHA block info. This is the case
if [[n_slha_block]] is nonzero, i.e., after SLHA block names have been
parsed and registered.
<<Models: model: TBP>>=
procedure :: supports_custom_slha => model_supports_custom_slha
<<Models: procedures>>=
function model_supports_custom_slha (model) result (flag)
class(model_t), intent(in) :: model
logical :: flag
flag = model%n_slha_block > 0
end function model_supports_custom_slha
@ %def model_supports_custom_slha
@ Return the block names for all SLHA block references.
<<Models: model: TBP>>=
procedure :: get_custom_slha_blocks => model_get_custom_slha_blocks
<<Models: procedures>>=
subroutine model_get_custom_slha_blocks (model, block_name)
class(model_t), intent(in) :: model
type(string_t), dimension(:), allocatable :: block_name
integer :: i
allocate (block_name (model%n_slha_block))
do i = 1, size (block_name)
block_name(i) = model%slha_block(i)%name
end do
end subroutine model_get_custom_slha_blocks
@ %def model_get_custom_slha_blocks
@
This routine registers a SLHA block reference. We have the index of a
(new) parameter entry and a parse node from the model file which
specifies a block name and an index array.
<<Models: procedures>>=
subroutine model_record_slha_block_entry (model, i_par, node)
class(model_t), intent(inout) :: model
integer, intent(in) :: i_par
type(parse_node_t), intent(in), target :: node
type(parse_node_t), pointer :: node_block_name, node_index
type(string_t) :: block_name
integer :: n_index, i, i_block
integer, dimension(:), allocatable :: block_index
node_block_name => node%get_sub_ptr (2)
select case (char (node_block_name%get_rule_key ()))
case ("block_name")
block_name = node_block_name%get_string ()
case ("QNUMBERS")
block_name = "QNUMBERS"
case default
block_name = node_block_name%get_string ()
end select
n_index = node%get_n_sub () - 2
allocate (block_index (n_index))
node_index => node_block_name%get_next_ptr ()
do i = 1, n_index
block_index(i) = node_index%get_integer ()
node_index => node_index%get_next_ptr ()
end do
i_block = 0
FIND_BLOCK: do i = 1, model%n_slha_block
if (model%slha_block(i)%name == block_name) then
i_block = i
exit FIND_BLOCK
end if
end do FIND_BLOCK
if (i_block == 0) then
call model_add_slha_block (model, block_name)
i_block = model%n_slha_block
end if
associate (b => model%slha_block(i_block))
call add_slha_block_entry (b, block_index, i_par)
end associate
model%par(i_par)%block_name = block_name
model%par(i_par)%block_index = block_index
end subroutine model_record_slha_block_entry
@ %def model_record_slha_block_entry
@ Add a new entry to the SLHA block register, increasing the array
size if necessary
<<Models: procedures>>=
subroutine model_add_slha_block (model, block_name)
class(model_t), intent(inout) :: model
type(string_t), intent(in) :: block_name
if (.not. allocated (model%slha_block)) allocate (model%slha_block (1))
if (model%n_slha_block == size (model%slha_block)) call grow
model%n_slha_block = model%n_slha_block + 1
associate (b => model%slha_block(model%n_slha_block))
b%name = block_name
allocate (b%entry (1))
end associate
contains
subroutine grow
type(slha_block_t), dimension(:), allocatable :: b_tmp
call move_alloc (model%slha_block, b_tmp)
allocate (model%slha_block (2 * size (b_tmp)))
model%slha_block(:size (b_tmp)) = b_tmp(:)
end subroutine grow
end subroutine model_add_slha_block
@ %def model_add_slha_block
@ Add a new entry to a block-register record. The entry establishes a
pointer-target relation between an index array within the SLHA block and a
parameter-data record. We increase the entry array as needed.
<<Models: procedures>>=
subroutine add_slha_block_entry (b, block_index, i_par)
type(slha_block_t), intent(inout) :: b
integer, dimension(:), intent(in) :: block_index
integer, intent(in) :: i_par
if (b%n_entry == size (b%entry)) call grow
b%n_entry = b%n_entry + 1
associate (entry => b%entry(b%n_entry))
entry%block_index = block_index
entry%i_par = i_par
end associate
contains
subroutine grow
type(slha_entry_t), dimension(:), allocatable :: entry_tmp
call move_alloc (b%entry, entry_tmp)
allocate (b%entry (2 * size (entry_tmp)))
b%entry(:size (entry_tmp)) = entry_tmp(:)
end subroutine grow
end subroutine add_slha_block_entry
@ %def add_slha_block_entry
@
The lookup routine returns a pointer to the appropriate [[par_data]]
record, if [[block_name]] and [[block_index]] are valid. The latter
point to the [[slha_block_t]] register within the [[model_t]] object,
if it is allocated.
This should only be needed during I/O (i.e., while reading the SLHA
file), so a simple linear search for each parameter should not be a
performance problem.
<<Models: model: TBP>>=
procedure :: slha_lookup => model_slha_lookup
<<Models: procedures>>=
subroutine model_slha_lookup (model, block_name, block_index, par_data)
class(model_t), intent(in) :: model
type(string_t), intent(in) :: block_name
integer, dimension(:), intent(in) :: block_index
class(modelpar_data_t), pointer, intent(out) :: par_data
integer :: i, j
par_data => null ()
if (allocated (model%slha_block)) then
do i = 1, model%n_slha_block
associate (block => model%slha_block(i))
if (block%name == block_name) then
do j = 1, block%n_entry
associate (entry => block%entry(j))
if (size (entry%block_index) == size (block_index)) then
if (all (entry%block_index == block_index)) then
par_data => model%par(entry%i_par)%data
return
end if
end if
end associate
end do
end if
end associate
end do
end if
end subroutine model_slha_lookup
@ %def model_slha_lookup
@ Modify the value of a parameter, identified by block name and index array.
<<Models: model: TBP>>=
procedure :: slha_set_par => model_slha_set_par
<<Models: procedures>>=
subroutine model_slha_set_par (model, block_name, block_index, value)
class(model_t), intent(inout) :: model
type(string_t), intent(in) :: block_name
integer, dimension(:), intent(in) :: block_index
real(default), intent(in) :: value
class(modelpar_data_t), pointer :: par_data
call model%slha_lookup (block_name, block_index, par_data)
if (associated (par_data)) then
par_data = value
end if
end subroutine model_slha_set_par
@ %def model_slha_set_par
@
\subsection{Reading models from file}
This procedure defines the model-file syntax for the parser, returning
an internal file (ifile).
Note that arithmetic operators are defined as keywords in the
expression syntax, so we exclude them here.
<<Models: procedures>>=
subroutine define_model_file_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "SEQ model_def = model_name_def " // &
"scheme_header parameters external_pars particles vertices")
call ifile_append (ifile, "SEQ model_name_def = model model_name")
call ifile_append (ifile, "KEY model")
call ifile_append (ifile, "QUO model_name = '""'...'""'")
call ifile_append (ifile, "SEQ scheme_header = scheme_decl?")
call ifile_append (ifile, "SEQ scheme_decl = schemes '=' scheme_list")
call ifile_append (ifile, "KEY schemes")
call ifile_append (ifile, "LIS scheme_list = scheme_name+")
call ifile_append (ifile, "QUO scheme_name = '""'...'""'")
call ifile_append (ifile, "SEQ parameters = generic_par_def*")
call ifile_append (ifile, "ALT generic_par_def = &
¶meter_def | derived_def | unused_def | scheme_block")
call ifile_append (ifile, "SEQ parameter_def = parameter par_name " // &
"'=' any_real_value slha_annotation?")
call ifile_append (ifile, "ALT any_real_value = " &
// "neg_real_value | pos_real_value | real_value")
call ifile_append (ifile, "SEQ neg_real_value = '-' real_value")
call ifile_append (ifile, "SEQ pos_real_value = '+' real_value")
call ifile_append (ifile, "KEY parameter")
call ifile_append (ifile, "IDE par_name")
! call ifile_append (ifile, "KEY '='") !!! Key already exists
call ifile_append (ifile, "SEQ slha_annotation = " // &
"slha_entry slha_block_name slha_entry_index*")
call ifile_append (ifile, "KEY slha_entry")
call ifile_append (ifile, "IDE slha_block_name")
call ifile_append (ifile, "INT slha_entry_index")
call ifile_append (ifile, "SEQ derived_def = derived par_name " // &
"'=' expr")
call ifile_append (ifile, "KEY derived")
call ifile_append (ifile, "SEQ unused_def = unused par_name")
call ifile_append (ifile, "KEY unused")
call ifile_append (ifile, "SEQ external_pars = external_def*")
call ifile_append (ifile, "SEQ external_def = external par_name")
call ifile_append (ifile, "KEY external")
call ifile_append (ifile, "SEQ scheme_block = &
&scheme_block_beg scheme_block_body scheme_block_end")
call ifile_append (ifile, "SEQ scheme_block_beg = select scheme")
call ifile_append (ifile, "SEQ scheme_block_body = scheme_block_case*")
call ifile_append (ifile, "SEQ scheme_block_case = &
&scheme scheme_id parameters")
call ifile_append (ifile, "ALT scheme_id = scheme_list | other")
call ifile_append (ifile, "SEQ scheme_block_end = end select")
call ifile_append (ifile, "KEY select")
call ifile_append (ifile, "KEY scheme")
call ifile_append (ifile, "KEY other")
call ifile_append (ifile, "KEY end")
call ifile_append (ifile, "SEQ particles = particle_def*")
call ifile_append (ifile, "SEQ particle_def = particle name_def " // &
"prt_pdg prt_details")
call ifile_append (ifile, "KEY particle")
call ifile_append (ifile, "SEQ prt_pdg = signed_int")
call ifile_append (ifile, "ALT prt_details = prt_src | prt_properties")
call ifile_append (ifile, "SEQ prt_src = like name_def prt_properties")
call ifile_append (ifile, "KEY like")
call ifile_append (ifile, "SEQ prt_properties = prt_property*")
call ifile_append (ifile, "ALT prt_property = " // &
"parton | invisible | gauge | left | right | " // &
"prt_name | prt_anti | prt_tex_name | prt_tex_anti | " // &
"prt_spin | prt_isospin | prt_charge | " // &
"prt_color | prt_mass | prt_width")
call ifile_append (ifile, "KEY parton")
call ifile_append (ifile, "KEY invisible")
call ifile_append (ifile, "KEY gauge")
call ifile_append (ifile, "KEY left")
call ifile_append (ifile, "KEY right")
call ifile_append (ifile, "SEQ prt_name = name name_def+")
call ifile_append (ifile, "SEQ prt_anti = anti name_def+")
call ifile_append (ifile, "SEQ prt_tex_name = tex_name name_def")
call ifile_append (ifile, "SEQ prt_tex_anti = tex_anti name_def")
call ifile_append (ifile, "KEY name")
call ifile_append (ifile, "KEY anti")
call ifile_append (ifile, "KEY tex_name")
call ifile_append (ifile, "KEY tex_anti")
call ifile_append (ifile, "ALT name_def = name_string | name_id")
call ifile_append (ifile, "QUO name_string = '""'...'""'")
call ifile_append (ifile, "IDE name_id")
call ifile_append (ifile, "SEQ prt_spin = spin frac")
call ifile_append (ifile, "KEY spin")
call ifile_append (ifile, "SEQ prt_isospin = isospin frac")
call ifile_append (ifile, "KEY isospin")
call ifile_append (ifile, "SEQ prt_charge = charge frac")
call ifile_append (ifile, "KEY charge")
call ifile_append (ifile, "SEQ prt_color = color integer_literal")
call ifile_append (ifile, "KEY color")
call ifile_append (ifile, "SEQ prt_mass = mass par_name")
call ifile_append (ifile, "KEY mass")
call ifile_append (ifile, "SEQ prt_width = width par_name")
call ifile_append (ifile, "KEY width")
call ifile_append (ifile, "SEQ vertices = vertex_def*")
call ifile_append (ifile, "SEQ vertex_def = vertex name_def+")
call ifile_append (ifile, "KEY vertex")
call define_expr_syntax (ifile, particles=.false., analysis=.false.)
end subroutine define_model_file_syntax
@ %def define_model_file_syntax
@ The model-file syntax and lexer are fixed, therefore stored as
module variables:
<<Models: variables>>=
type(syntax_t), target, save :: syntax_model_file
@ %def syntax_model_file
<<Models: public>>=
public :: syntax_model_file_init
<<Models: procedures>>=
subroutine syntax_model_file_init ()
type(ifile_t) :: ifile
call define_model_file_syntax (ifile)
call syntax_init (syntax_model_file, ifile)
call ifile_final (ifile)
end subroutine syntax_model_file_init
@ %def syntax_model_file_init
<<Models: procedures>>=
subroutine lexer_init_model_file (lexer)
type(lexer_t), intent(out) :: lexer
call lexer_init (lexer, &
comment_chars = "#!", &
quote_chars = '"{', &
quote_match = '"}', &
single_chars = ":(),", &
special_class = [ "+-*/^", "<>= " ] , &
keyword_list = syntax_get_keyword_list_ptr (syntax_model_file))
end subroutine lexer_init_model_file
@ %def lexer_init_model_file
<<Models: public>>=
public :: syntax_model_file_final
<<Models: procedures>>=
subroutine syntax_model_file_final ()
call syntax_final (syntax_model_file)
end subroutine syntax_model_file_final
@ %def syntax_model_file_final
<<Models: public>>=
public :: syntax_model_file_write
<<Models: procedures>>=
subroutine syntax_model_file_write (unit)
integer, intent(in), optional :: unit
call syntax_write (syntax_model_file, unit)
end subroutine syntax_model_file_write
@ %def syntax_model_file_write
@
Read a model from file. Handle all syntax and respect the provided scheme.
The [[ufo]] flag just says that the model object should be tagged as
being derived from an UFO model. The UFO model path may be requested
by the caller. If not, we use a standard path search for UFO models.
There is no difference in the
contents of the file or the generated model object.
<<Models: model: TBP>>=
procedure :: read => model_read
<<Models: procedures>>=
subroutine model_read (model, filename, os_data, exist, &
scheme, ufo, ufo_path_requested, rebuild_mdl)
class(model_t), intent(out), target :: model
type(string_t), intent(in) :: filename
type(os_data_t), intent(in) :: os_data
logical, intent(out), optional :: exist
type(string_t), intent(in), optional :: scheme
logical, intent(in), optional :: ufo
type(string_t), intent(in), optional :: ufo_path_requested
logical, intent(in), optional :: rebuild_mdl
type(string_t) :: file
type(stream_t), target :: stream
type(lexer_t) :: lexer
integer :: unit
character(32) :: model_md5sum
type(parse_node_t), pointer :: nd_model_def, nd_model_name_def
type(parse_node_t), pointer :: nd_schemes, nd_scheme_decl
type(parse_node_t), pointer :: nd_parameters
type(parse_node_t), pointer :: nd_external_pars
type(parse_node_t), pointer :: nd_particles, nd_vertices
type(string_t) :: model_name, lib_name
integer :: n_parblock, n_par, i_par, n_ext, n_prt, n_vtx
type(parse_node_t), pointer :: nd_par_def
type(parse_node_t), pointer :: nd_ext_def
type(parse_node_t), pointer :: nd_prt
type(parse_node_t), pointer :: nd_vtx
logical :: ufo_model, model_exist, rebuild
ufo_model = .false.; if (present (ufo)) ufo_model = ufo
rebuild = .true.; if (present (rebuild_mdl)) rebuild = rebuild_mdl
file = filename
inquire (file=char(file), exist=model_exist)
if ((.not. model_exist) .and. (.not. os_data%use_testfiles)) then
file = os_data%whizard_modelpath_local // "/" // filename
inquire (file = char (file), exist = model_exist)
end if
if (.not. model_exist) then
file = os_data%whizard_modelpath // "/" // filename
inquire (file = char (file), exist = model_exist)
end if
if (ufo_model .and. rebuild) then
file = filename
call model_generate_ufo (filename, os_data, model%ufo_path, &
ufo_path_requested=ufo_path_requested)
inquire (file = char (file), exist = model_exist)
end if
if (.not. model_exist) then
call msg_fatal ("Model file '" // char (filename) // "' not found")
if (present (exist)) exist = .false.
return
end if
if (present (exist)) exist = .true.
if (logging) call msg_message ("Reading model file '" // char (file) // "'")
unit = free_unit ()
open (file=char(file), unit=unit, action="read", status="old")
model_md5sum = md5sum (unit)
close (unit)
call lexer_init_model_file (lexer)
call stream_init (stream, char (file))
call lexer_assign_stream (lexer, stream)
call parse_tree_init (model%parse_tree, syntax_model_file, lexer)
call stream_final (stream)
call lexer_final (lexer)
nd_model_def => model%parse_tree%get_root_ptr ()
nd_model_name_def => parse_node_get_sub_ptr (nd_model_def)
model_name = parse_node_get_string &
(parse_node_get_sub_ptr (nd_model_name_def, 2))
nd_schemes => nd_model_name_def%get_next_ptr ()
call find_block &
("scheme_header", nd_schemes, nd_scheme_decl, nd_next=nd_parameters)
call find_block &
("parameters", nd_parameters, nd_par_def, n_parblock, nd_external_pars)
call find_block &
("external_pars", nd_external_pars, nd_ext_def, n_ext, nd_particles)
call find_block &
("particles", nd_particles, nd_prt, n_prt, nd_vertices)
call find_block &
("vertices", nd_vertices, nd_vtx, n_vtx)
if (associated (nd_external_pars)) then
lib_name = "external." // model_name
else
lib_name = ""
end if
if (associated (nd_scheme_decl)) then
call handle_schemes (nd_scheme_decl, scheme)
end if
n_par = 0
call count_parameters (nd_par_def, n_parblock, n_par)
call model%init &
(model_name, lib_name, os_data, n_par + n_ext, n_prt, n_vtx, ufo)
model%md5sum = model_md5sum
if (associated (nd_par_def)) then
i_par = 0
call handle_parameters (nd_par_def, n_parblock, i_par)
end if
if (associated (nd_ext_def)) then
call handle_external (nd_ext_def, n_par, n_ext)
end if
call model%update_parameters ()
if (associated (nd_prt)) then
call handle_fields (nd_prt, n_prt)
end if
if (associated (nd_vtx)) then
call handle_vertices (nd_vtx, n_vtx)
end if
call model%freeze_vertices ()
call model%append_field_vars ()
contains
subroutine find_block (key, nd, nd_item, n_item, nd_next)
character(*), intent(in) :: key
type(parse_node_t), pointer, intent(inout) :: nd
type(parse_node_t), pointer, intent(out) :: nd_item
integer, intent(out), optional :: n_item
type(parse_node_t), pointer, intent(out), optional :: nd_next
if (associated (nd)) then
if (nd%get_rule_key () == key) then
nd_item => nd%get_sub_ptr ()
if (present (n_item)) n_item = nd%get_n_sub ()
if (present (nd_next)) nd_next => nd%get_next_ptr ()
else
nd_item => null ()
if (present (n_item)) n_item = 0
if (present (nd_next)) nd_next => nd
nd => null ()
end if
else
nd_item => null ()
if (present (n_item)) n_item = 0
if (present (nd_next)) nd_next => null ()
end if
end subroutine find_block
subroutine handle_schemes (nd_scheme_decl, scheme)
type(parse_node_t), pointer, intent(in) :: nd_scheme_decl
type(string_t), intent(in), optional :: scheme
type(parse_node_t), pointer :: nd_list, nd_entry
type(string_t), dimension(:), allocatable :: schemes
integer :: i, n_schemes
nd_list => nd_scheme_decl%get_sub_ptr (3)
nd_entry => nd_list%get_sub_ptr ()
n_schemes = nd_list%get_n_sub ()
allocate (schemes (n_schemes))
do i = 1, n_schemes
schemes(i) = nd_entry%get_string ()
nd_entry => nd_entry%get_next_ptr ()
end do
if (present (scheme)) then
do i = 1, n_schemes
if (schemes(i) == scheme) goto 10 ! block exit
end do
call msg_fatal ("Scheme '" // char (scheme) &
// "' is not supported by model '" // char (model_name) // "'")
end if
10 continue
call model%enable_schemes (schemes)
call model%set_scheme (scheme)
end subroutine handle_schemes
subroutine select_scheme (nd_scheme_block, n_parblock_sub, nd_par_def)
type(parse_node_t), pointer, intent(in) :: nd_scheme_block
integer, intent(out) :: n_parblock_sub
type(parse_node_t), pointer, intent(out) :: nd_par_def
type(parse_node_t), pointer :: nd_scheme_body
type(parse_node_t), pointer :: nd_scheme_case, nd_scheme_id, nd_scheme
type(string_t) :: scheme
integer :: n_cases, i
scheme = model%get_scheme ()
nd_scheme_body => nd_scheme_block%get_sub_ptr (2)
nd_parameters => null ()
select case (char (nd_scheme_body%get_rule_key ()))
case ("scheme_block_body")
n_cases = nd_scheme_body%get_n_sub ()
FIND_SCHEME: do i = 1, n_cases
nd_scheme_case => nd_scheme_body%get_sub_ptr (i)
nd_scheme_id => nd_scheme_case%get_sub_ptr (2)
select case (char (nd_scheme_id%get_rule_key ()))
case ("scheme_list")
nd_scheme => nd_scheme_id%get_sub_ptr ()
do while (associated (nd_scheme))
if (scheme == nd_scheme%get_string ()) then
nd_parameters => nd_scheme_id%get_next_ptr ()
exit FIND_SCHEME
end if
nd_scheme => nd_scheme%get_next_ptr ()
end do
case ("other")
nd_parameters => nd_scheme_id%get_next_ptr ()
exit FIND_SCHEME
case default
print *, "'", char (nd_scheme_id%get_rule_key ()), "'"
call msg_bug ("Model read: impossible scheme rule")
end select
end do FIND_SCHEME
end select
if (associated (nd_parameters)) then
select case (char (nd_parameters%get_rule_key ()))
case ("parameters")
n_parblock_sub = nd_parameters%get_n_sub ()
if (n_parblock_sub > 0) then
nd_par_def => nd_parameters%get_sub_ptr ()
else
nd_par_def => null ()
end if
case default
n_parblock_sub = 0
nd_par_def => null ()
end select
else
n_parblock_sub = 0
nd_par_def => null ()
end if
end subroutine select_scheme
recursive subroutine count_parameters (nd_par_def_in, n_parblock, n_par)
type(parse_node_t), pointer, intent(in) :: nd_par_def_in
integer, intent(in) :: n_parblock
integer, intent(inout) :: n_par
type(parse_node_t), pointer :: nd_par_def, nd_par_key
type(parse_node_t), pointer :: nd_par_def_sub
integer :: n_parblock_sub
integer :: i
nd_par_def => nd_par_def_in
do i = 1, n_parblock
nd_par_key => nd_par_def%get_sub_ptr ()
select case (char (nd_par_key%get_rule_key ()))
case ("parameter", "derived", "unused")
n_par = n_par + 1
case ("scheme_block_beg")
call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub)
if (n_parblock_sub > 0) then
call count_parameters (nd_par_def_sub, n_parblock_sub, n_par)
end if
case default
print *, "'", char (nd_par_key%get_rule_key ()), "'"
call msg_bug ("Model read: impossible parameter rule")
end select
nd_par_def => parse_node_get_next_ptr (nd_par_def)
end do
end subroutine count_parameters
recursive subroutine handle_parameters (nd_par_def_in, n_parblock, i_par)
type(parse_node_t), pointer, intent(in) :: nd_par_def_in
integer, intent(in) :: n_parblock
integer, intent(inout) :: i_par
type(parse_node_t), pointer :: nd_par_def, nd_par_key
type(parse_node_t), pointer :: nd_par_def_sub
integer :: n_parblock_sub
integer :: i
nd_par_def => nd_par_def_in
do i = 1, n_parblock
nd_par_key => nd_par_def%get_sub_ptr ()
select case (char (nd_par_key%get_rule_key ()))
case ("parameter")
i_par = i_par + 1
call model%read_parameter (i_par, nd_par_def)
case ("derived")
i_par = i_par + 1
call model%read_derived (i_par, nd_par_def)
case ("unused")
i_par = i_par + 1
call model%read_unused (i_par, nd_par_def)
case ("scheme_block_beg")
call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub)
if (n_parblock_sub > 0) then
call handle_parameters (nd_par_def_sub, n_parblock_sub, i_par)
end if
end select
nd_par_def => parse_node_get_next_ptr (nd_par_def)
end do
end subroutine handle_parameters
subroutine handle_external (nd_ext_def, n_par, n_ext)
type(parse_node_t), pointer, intent(inout) :: nd_ext_def
integer, intent(in) :: n_par, n_ext
integer :: i
do i = n_par + 1, n_par + n_ext
call model%read_external (i, nd_ext_def)
nd_ext_def => parse_node_get_next_ptr (nd_ext_def)
end do
! real(c_default_float), dimension(:), allocatable :: par
! if (associated (model%init_external_parameters)) then
! allocate (par (model%get_n_real ()))
! call model%real_parameters_to_c_array (par)
! call model%init_external_parameters (par)
! call model%real_parameters_from_c_array (par)
! end if
end subroutine handle_external
subroutine handle_fields (nd_prt, n_prt)
type(parse_node_t), pointer, intent(inout) :: nd_prt
integer, intent(in) :: n_prt
integer :: i
do i = 1, n_prt
call model%read_field (i, nd_prt)
nd_prt => parse_node_get_next_ptr (nd_prt)
end do
end subroutine handle_fields
subroutine handle_vertices (nd_vtx, n_vtx)
type(parse_node_t), pointer, intent(inout) :: nd_vtx
integer, intent(in) :: n_vtx
integer :: i
do i = 1, n_vtx
call model%read_vertex (i, nd_vtx)
nd_vtx => parse_node_get_next_ptr (nd_vtx)
end do
end subroutine handle_vertices
end subroutine model_read
@ %def model_read
@ Parameters are real values (literal) with an optional unit.
<<Models: model: TBP>>=
procedure, private :: read_parameter => model_read_parameter
<<Models: procedures>>=
subroutine model_read_parameter (model, i, node)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(parse_node_t), intent(in), target :: node
type(parse_node_t), pointer :: node_name, node_val, node_slha_entry
type(string_t) :: name
node_name => parse_node_get_sub_ptr (node, 2)
name = parse_node_get_string (node_name)
node_val => parse_node_get_next_ptr (node_name, 2)
call model%set_parameter_parse_node (i, name, node_val, constant=.true.)
node_slha_entry => parse_node_get_next_ptr (node_val)
if (associated (node_slha_entry)) then
call model_record_slha_block_entry (model, i, node_slha_entry)
end if
end subroutine model_read_parameter
@ %def model_read_parameter
@ Derived parameters have any numeric expression as their definition.
Don't evaluate the expression, yet.
<<Models: model: TBP>>=
procedure, private :: read_derived => model_read_derived
<<Models: procedures>>=
subroutine model_read_derived (model, i, node)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(parse_node_t), intent(in), target :: node
type(string_t) :: name
type(parse_node_t), pointer :: pn_expr
name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
pn_expr => parse_node_get_sub_ptr (node, 4)
call model%set_parameter_parse_node (i, name, pn_expr, constant=.false.)
end subroutine model_read_derived
@ %def model_read_derived
@ External parameters have no definition; they are handled by an
external library.
<<Models: model: TBP>>=
procedure, private :: read_external => model_read_external
<<Models: procedures>>=
subroutine model_read_external (model, i, node)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(parse_node_t), intent(in), target :: node
type(string_t) :: name
name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
call model%set_parameter_external (i, name)
end subroutine model_read_external
@ %def model_read_external
@ Ditto for unused parameters, they are there just for reserving the name.
<<Models: model: TBP>>=
procedure, private :: read_unused => model_read_unused
<<Models: procedures>>=
subroutine model_read_unused (model, i, node)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(parse_node_t), intent(in), target :: node
type(string_t) :: name
name = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
call model%set_parameter_unused (i, name)
end subroutine model_read_unused
@ %def model_read_unused
<<Models: model: TBP>>=
procedure, private :: read_field => model_read_field
<<Models: procedures>>=
subroutine model_read_field (model, i, node)
class(model_t), intent(inout), target :: model
integer, intent(in) :: i
type(parse_node_t), intent(in) :: node
type(parse_node_t), pointer :: nd_src, nd_props, nd_prop
type(string_t) :: longname
integer :: pdg
type(string_t) :: name_src
type(string_t), dimension(:), allocatable :: name
type(field_data_t), pointer :: field, field_src
longname = parse_node_get_string (parse_node_get_sub_ptr (node, 2))
pdg = read_frac (parse_node_get_sub_ptr (node, 3))
field => model%get_field_ptr_by_index (i)
call field%init (longname, pdg)
nd_src => parse_node_get_sub_ptr (node, 4)
if (associated (nd_src)) then
if (parse_node_get_rule_key (nd_src) == "prt_src") then
name_src = parse_node_get_string (parse_node_get_sub_ptr (nd_src, 2))
field_src => model%get_field_ptr (name_src, check=.true.)
call field%copy_from (field_src)
nd_props => parse_node_get_sub_ptr (nd_src, 3)
else
nd_props => nd_src
end if
nd_prop => parse_node_get_sub_ptr (nd_props)
do while (associated (nd_prop))
select case (char (parse_node_get_rule_key (nd_prop)))
case ("invisible")
call field%set (is_visible=.false.)
case ("parton")
call field%set (is_parton=.true.)
case ("gauge")
call field%set (is_gauge=.true.)
case ("left")
call field%set (is_left_handed=.true.)
case ("right")
call field%set (is_right_handed=.true.)
case ("prt_name")
call read_names (nd_prop, name)
call field%set (name=name)
case ("prt_anti")
call read_names (nd_prop, name)
call field%set (anti=name)
case ("prt_tex_name")
call field%set ( &
tex_name = parse_node_get_string &
(parse_node_get_sub_ptr (nd_prop, 2)))
case ("prt_tex_anti")
call field%set ( &
tex_anti = parse_node_get_string &
(parse_node_get_sub_ptr (nd_prop, 2)))
case ("prt_spin")
call field%set ( &
spin_type = read_frac &
(parse_node_get_sub_ptr (nd_prop, 2), 2))
case ("prt_isospin")
call field%set ( &
isospin_type = read_frac &
(parse_node_get_sub_ptr (nd_prop, 2), 2))
case ("prt_charge")
call field%set ( &
charge_type = read_frac &
(parse_node_get_sub_ptr (nd_prop, 2), 3))
case ("prt_color")
call field%set ( &
color_type = parse_node_get_integer &
(parse_node_get_sub_ptr (nd_prop, 2)))
case ("prt_mass")
call field%set ( &
mass_data = model%get_par_data_ptr &
(parse_node_get_string &
(parse_node_get_sub_ptr (nd_prop, 2))))
case ("prt_width")
call field%set ( &
width_data = model%get_par_data_ptr &
(parse_node_get_string &
(parse_node_get_sub_ptr (nd_prop, 2))))
case default
call msg_bug (" Unknown particle property '" &
// char (parse_node_get_rule_key (nd_prop)) // "'")
end select
if (allocated (name)) deallocate (name)
nd_prop => parse_node_get_next_ptr (nd_prop)
end do
end if
call field%freeze ()
end subroutine model_read_field
@ %def model_read_field
<<Models: model: TBP>>=
procedure, private :: read_vertex => model_read_vertex
<<Models: procedures>>=
subroutine model_read_vertex (model, i, node)
class(model_t), intent(inout) :: model
integer, intent(in) :: i
type(parse_node_t), intent(in) :: node
type(string_t), dimension(:), allocatable :: name
call read_names (node, name)
call model%set_vertex (i, name)
end subroutine model_read_vertex
@ %def model_read_vertex
<<Models: procedures>>=
subroutine read_names (node, name)
type(parse_node_t), intent(in) :: node
type(string_t), dimension(:), allocatable, intent(inout) :: name
type(parse_node_t), pointer :: nd_name
integer :: n_names, i
n_names = parse_node_get_n_sub (node) - 1
allocate (name (n_names))
nd_name => parse_node_get_sub_ptr (node, 2)
do i = 1, n_names
name(i) = parse_node_get_string (nd_name)
nd_name => parse_node_get_next_ptr (nd_name)
end do
end subroutine read_names
@ %def read_names
@ There is an optional argument for the base.
<<Models: procedures>>=
function read_frac (nd_frac, base) result (qn_type)
integer :: qn_type
type(parse_node_t), intent(in) :: nd_frac
integer, intent(in), optional :: base
type(parse_node_t), pointer :: nd_num, nd_den
integer :: num, den
nd_num => parse_node_get_sub_ptr (nd_frac)
nd_den => parse_node_get_next_ptr (nd_num)
select case (char (parse_node_get_rule_key (nd_num)))
case ("integer_literal")
num = parse_node_get_integer (nd_num)
case ("neg_int")
num = - parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2))
case ("pos_int")
num = parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2))
case default
call parse_tree_bug (nd_num, "int|neg_int|pos_int")
end select
if (associated (nd_den)) then
den = parse_node_get_integer (parse_node_get_sub_ptr (nd_den, 2))
else
den = 1
end if
if (present (base)) then
if (den == 1) then
qn_type = sign (1 + abs (num) * base, num)
else if (den == base) then
qn_type = sign (abs (num) + 1, num)
else
call parse_node_write_rec (nd_frac)
call msg_fatal (" Fractional quantum number: wrong denominator")
end if
else
if (den == 1) then
qn_type = num
else
call parse_node_write_rec (nd_frac)
call msg_fatal (" Wrong type: no fraction expected")
end if
end if
end function read_frac
@ %def read_frac
@ Append field (PDG-array) variables to the variable list, based on
the field content.
<<Models: model: TBP>>=
procedure, private :: append_field_vars => model_append_field_vars
<<Models: procedures>>=
subroutine model_append_field_vars (model)
class(model_t), intent(inout) :: model
type(pdg_array_t) :: aval
type(field_data_t), dimension(:), pointer :: field_array
type(field_data_t), pointer :: field
type(string_t) :: name
type(string_t), dimension(:), allocatable :: name_array
integer, dimension(:), allocatable :: pdg
logical, dimension(:), allocatable :: mask
integer :: i, j
field_array => model%get_field_array_ptr ()
aval = UNDEFINED
call var_list_append_pdg_array &
(model%var_list, var_str ("particle"), &
aval, locked = .true., intrinsic=.true.)
do i = 1, size (field_array)
aval = field_array(i)%get_pdg ()
name = field_array(i)%get_longname ()
call var_list_append_pdg_array &
(model%var_list, name, aval, locked=.true., intrinsic=.true.)
call field_array(i)%get_name_array (.false., name_array)
do j = 1, size (name_array)
call var_list_append_pdg_array &
(model%var_list, name_array(j), &
aval, locked=.true., intrinsic=.true.)
end do
model%max_field_name_length = &
max (model%max_field_name_length, len (name_array(1)))
aval = - field_array(i)%get_pdg ()
call field_array(i)%get_name_array (.true., name_array)
do j = 1, size (name_array)
call var_list_append_pdg_array &
(model%var_list, name_array(j), &
aval, locked=.true., intrinsic=.true.)
end do
if (size (name_array) > 0) then
model%max_field_name_length = &
max (model%max_field_name_length, len (name_array(1)))
end if
end do
call model%get_all_pdg (pdg)
allocate (mask (size (pdg)))
do i = 1, size (pdg)
field => model%get_field_ptr (pdg(i))
mask(i) = field%get_charge_type () /= 1
end do
aval = pack (pdg, mask)
call var_list_append_pdg_array &
(model%var_list, var_str ("charged"), &
aval, locked = .true., intrinsic=.true.)
do i = 1, size (pdg)
field => model%get_field_ptr (pdg(i))
mask(i) = field%get_charge_type () == 1
end do
aval = pack (pdg, mask)
call var_list_append_pdg_array &
(model%var_list, var_str ("neutral"), &
aval, locked = .true., intrinsic=.true.)
do i = 1, size (pdg)
field => model%get_field_ptr (pdg(i))
mask(i) = field%get_color_type () /= 1
end do
aval = pack (pdg, mask)
call var_list_append_pdg_array &
(model%var_list, var_str ("colored"), &
aval, locked = .true., intrinsic=.true.)
end subroutine model_append_field_vars
@ %def model_append_field_vars
@
\subsection{Test models}
<<Models: public>>=
public :: create_test_model
<<Models: procedures>>=
subroutine create_test_model (model_name, test_model)
type(string_t), intent(in) :: model_name
type(model_t), intent(out), pointer :: test_model
type(os_data_t) :: os_data
type(model_list_t) :: model_list
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model &
(model_name, model_name // var_str (".mdl"), os_data, test_model)
end subroutine create_test_model
@ %def create_test_model
@
\subsection{Model list}
List of currently active models
<<Models: types>>=
type, extends (model_t) :: model_entry_t
type(model_entry_t), pointer :: next => null ()
end type model_entry_t
@ %def model_entry_t
<<Models: public>>=
public :: model_list_t
<<Models: types>>=
type :: model_list_t
type(model_entry_t), pointer :: first => null ()
type(model_entry_t), pointer :: last => null ()
type(model_list_t), pointer :: context => null ()
contains
<<Models: model list: TBP>>
end type model_list_t
@ %def model_list_t
@ Write an account of the model list. We write linked lists first, starting
from the global context.
<<Models: model list: TBP>>=
procedure :: write => model_list_write
<<Models: procedures>>=
recursive subroutine model_list_write (object, unit, verbose, follow_link)
class(model_list_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: verbose
logical, intent(in), optional :: follow_link
type(model_entry_t), pointer :: current
logical :: rec
integer :: u
u = given_output_unit (unit); if (u < 0) return
rec = .true.; if (present (follow_link)) rec = follow_link
if (rec .and. associated (object%context)) then
call object%context%write (unit, verbose, follow_link)
end if
current => object%first
if (associated (current)) then
do while (associated (current))
call current%write (unit, verbose)
current => current%next
if (associated (current)) write (u, *)
end do
end if
end subroutine model_list_write
@ %def model_list_write
@ Link this list to another one.
<<Models: model list: TBP>>=
procedure :: link => model_list_link
<<Models: procedures>>=
subroutine model_list_link (model_list, context)
class(model_list_t), intent(inout) :: model_list
type(model_list_t), intent(in), target :: context
model_list%context => context
end subroutine model_list_link
@ %def model_list_link
@ (Private, used below:)
Append an existing model, for which we have allocated a pointer entry, to
the model list. The original pointer becomes disassociated, and the model
should now be considered as part of the list. We assume that this model is
not yet part of the list.
If we provide a [[model]] argument, this returns a pointer to the new entry.
<<Models: model list: TBP>>=
procedure, private :: import => model_list_import
<<Models: procedures>>=
subroutine model_list_import (model_list, current, model)
class(model_list_t), intent(inout) :: model_list
type(model_entry_t), pointer, intent(inout) :: current
type(model_t), optional, pointer, intent(out) :: model
if (associated (current)) then
if (associated (model_list%first)) then
model_list%last%next => current
else
model_list%first => current
end if
model_list%last => current
if (present (model)) model => current%model_t
current => null ()
end if
end subroutine model_list_import
@ %def model_list_import
@ Currently test only:
Add a new model with given [[name]] to the list, if it does not yet
exist. If successful, return a pointer to the new model.
<<Models: model list: TBP>>=
procedure :: add => model_list_add
<<Models: procedures>>=
subroutine model_list_add (model_list, &
name, os_data, n_par, n_prt, n_vtx, model)
class(model_list_t), intent(inout) :: model_list
type(string_t), intent(in) :: name
type(os_data_t), intent(in) :: os_data
integer, intent(in) :: n_par, n_prt, n_vtx
type(model_t), pointer :: model
type(model_entry_t), pointer :: current
if (model_list%model_exists (name, follow_link=.false.)) then
model => null ()
else
allocate (current)
call current%init (name, var_str (""), os_data, &
n_par, n_prt, n_vtx)
call model_list%import (current, model)
end if
end subroutine model_list_add
@ %def model_list_add
@ Read a new model from file and add to the list, if it does not yet
exist. Finalize the model by allocating the vertex table. Return a
pointer to the new model. If unsuccessful, return the original
pointer.
The model is always inserted in the last link of a chain of model lists. This
way, we avoid loading models twice from different contexts. When a model is
modified, we should first allocate a local copy.
<<Models: model list: TBP>>=
procedure :: read_model => model_list_read_model
<<Models: procedures>>=
subroutine model_list_read_model &
(model_list, name, filename, os_data, model, &
scheme, ufo, ufo_path, rebuild_mdl)
class(model_list_t), intent(inout), target :: model_list
type(string_t), intent(in) :: name, filename
type(os_data_t), intent(in) :: os_data
type(model_t), pointer, intent(inout) :: model
type(string_t), intent(in), optional :: scheme
logical, intent(in), optional :: ufo
type(string_t), intent(in), optional :: ufo_path
logical, intent(in), optional :: rebuild_mdl
class(model_list_t), pointer :: global_model_list
type(model_entry_t), pointer :: current
logical :: exist
if (.not. model_list%model_exists (name, &
scheme, ufo, ufo_path, follow_link=.true.)) then
allocate (current)
call current%read (filename, os_data, exist, &
scheme=scheme, ufo=ufo, ufo_path_requested=ufo_path, &
rebuild_mdl=rebuild_mdl)
if (.not. exist) return
if (current%get_name () /= name) then
call msg_fatal ("Model file '" // char (filename) // &
"' contains model '" // char (current%get_name ()) // &
"' instead of '" // char (name) // "'")
call current%final (); deallocate (current)
return
end if
global_model_list => model_list
do while (associated (global_model_list%context))
global_model_list => global_model_list%context
end do
call global_model_list%import (current, model)
else
model => model_list%get_model_ptr (name, scheme, ufo, ufo_path)
end if
end subroutine model_list_read_model
@ %def model_list_read_model
@ Append a copy of an existing model to a model list. Optionally, return
pointer to the new entry.
<<Models: model list: TBP>>=
procedure :: append_copy => model_list_append_copy
<<Models: procedures>>=
subroutine model_list_append_copy (model_list, orig, model)
class(model_list_t), intent(inout) :: model_list
type(model_t), intent(in), target :: orig
type(model_t), intent(out), pointer, optional :: model
type(model_entry_t), pointer :: copy
allocate (copy)
call copy%init_instance (orig)
call model_list%import (copy, model)
end subroutine model_list_append_copy
@ %def model_list_append_copy
@ Check if a model exists by examining the list. Check recursively unless
told otherwise.
<<Models: model list: TBP>>=
procedure :: model_exists => model_list_model_exists
<<Models: procedures>>=
recursive function model_list_model_exists &
(model_list, name, scheme, ufo, ufo_path, follow_link) result (exists)
class(model_list_t), intent(in) :: model_list
logical :: exists
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: scheme
logical, intent(in), optional :: ufo
type(string_t), intent(in), optional :: ufo_path
logical, intent(in), optional :: follow_link
type(model_entry_t), pointer :: current
logical :: rec
rec = .true.; if (present (follow_link)) rec = follow_link
current => model_list%first
do while (associated (current))
if (current%matches (name, scheme, ufo, ufo_path)) then
exists = .true.
return
end if
current => current%next
end do
if (rec .and. associated (model_list%context)) then
exists = model_list%context%model_exists (name, &
scheme, ufo, ufo_path, follow_link)
else
exists = .false.
end if
end function model_list_model_exists
@ %def model_list_model_exists
@ Return a pointer to a named model. Search recursively unless told otherwise.
<<Models: model list: TBP>>=
procedure :: get_model_ptr => model_list_get_model_ptr
<<Models: procedures>>=
recursive function model_list_get_model_ptr &
(model_list, name, scheme, ufo, ufo_path, follow_link) result (model)
class(model_list_t), intent(in) :: model_list
type(model_t), pointer :: model
type(string_t), intent(in) :: name
type(string_t), intent(in), optional :: scheme
logical, intent(in), optional :: ufo
type(string_t), intent(in), optional :: ufo_path
logical, intent(in), optional :: follow_link
type(model_entry_t), pointer :: current
logical :: rec
rec = .true.; if (present (follow_link)) rec = follow_link
current => model_list%first
do while (associated (current))
if (current%matches (name, scheme, ufo, ufo_path)) then
model => current%model_t
return
end if
current => current%next
end do
if (rec .and. associated (model_list%context)) then
model => model_list%context%get_model_ptr (name, &
scheme, ufo, ufo_path, follow_link)
else
model => null ()
end if
end function model_list_get_model_ptr
@ %def model_list_get_model_ptr
@ Delete the list of models. No recursion.
<<Models: model list: TBP>>=
procedure :: final => model_list_final
<<Models: procedures>>=
subroutine model_list_final (model_list)
class(model_list_t), intent(inout) :: model_list
type(model_entry_t), pointer :: current
model_list%last => null ()
do while (associated (model_list%first))
current => model_list%first
model_list%first => model_list%first%next
call current%final ()
deallocate (current)
end do
end subroutine model_list_final
@ %def model_list_final
@
\subsection{Model instances}
A model instance is a copy of a model object. The parameters are true
copies. The particle data and the variable list pointers should point to the
copy, so modifying the parameters has only a local effect. Hence, we build
them up explicitly. The vertex array is also rebuilt, it contains particle
pointers. Finally, the vertex hash table can be copied directly since it
contains no pointers.
The [[multiplicity]] entry depends on the association of the [[mass_data]]
entry and therefore has to be set at the end.
The instance must carry the [[target]] attribute.
Parameters: the [[copy_parameter]] method essentially copies the parameter
decorations (parse node, expression etc.). The current parameter values are
part of the [[model_data_t]] base type and are copied afterwards via its
[[copy_from]] method.
Note: the parameter set is initialized for real parameters only.
In order for the local model to be able to use the correct UFO model
setup, UFO model information has to be transferred.
<<Models: model: TBP>>=
procedure :: init_instance => model_copy
<<Models: procedures>>=
subroutine model_copy (model, orig)
class(model_t), intent(out), target :: model
type(model_t), intent(in) :: orig
integer :: n_par, n_prt, n_vtx
integer :: i
n_par = orig%get_n_real ()
n_prt = orig%get_n_field ()
n_vtx = orig%get_n_vtx ()
call model%basic_init (orig%get_name (), n_par, n_prt, n_vtx)
if (allocated (orig%schemes)) then
model%schemes = orig%schemes
if (allocated (orig%selected_scheme)) then
model%selected_scheme = orig%selected_scheme
call model%set_scheme_num (orig%get_scheme_num ())
end if
end if
if (allocated (orig%slha_block)) then
model%slha_block = orig%slha_block
end if
model%md5sum = orig%md5sum
model%ufo_model = orig%ufo_model
model%ufo_path = orig%ufo_path
if (allocated (orig%par)) then
do i = 1, n_par
call model%copy_parameter (i, orig%par(i))
end do
end if
model%init_external_parameters => orig%init_external_parameters
call model%model_data_t%copy_from (orig)
model%max_par_name_length = orig%max_par_name_length
call model%append_field_vars ()
end subroutine model_copy
@ %def model_copy
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[models_ut.f90]]>>=
<<File header>>
module models_ut
use unit_tests
use models_uti
<<Standard module head>>
<<Models: public test>>
contains
<<Models: test driver>>
end module models_ut
@ %def models_ut
@
<<[[models_uti.f90]]>>=
<<File header>>
module models_uti
<<Use kinds>>
<<Use strings>>
use file_utils, only: delete_file
use physics_defs, only: SCALAR, SPINOR
use os_interface
use model_data
use variables
use models
<<Standard module head>>
<<Models: test declarations>>
contains
<<Models: tests>>
end module models_uti
@ %def models_ut
@ API: driver for the unit tests below.
<<Models: public test>>=
public :: models_test
<<Models: test driver>>=
subroutine models_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Models: execute tests>>
end subroutine models_test
@ %def models_tests
@
\subsubsection{Construct a Model}
Here, we construct a toy model explicitly without referring to a file.
<<Models: execute tests>>=
call test (models_1, "models_1", &
"construct model", &
u, results)
<<Models: test declarations>>=
public :: models_1
<<Models: tests>>=
subroutine models_1 (u)
integer, intent(in) :: u
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model
type(string_t) :: model_name
type(string_t) :: x_longname
type(string_t), dimension(2) :: parname
type(string_t), dimension(2) :: x_name
type(string_t), dimension(1) :: x_anti
type(string_t) :: x_tex_name, x_tex_anti
type(string_t) :: y_longname
type(string_t), dimension(2) :: y_name
type(string_t) :: y_tex_name
type(field_data_t), pointer :: field
write (u, "(A)") "* Test output: models_1"
write (u, "(A)") "* Purpose: create a model"
write (u, *)
model_name = "Test model"
call model_list%add (model_name, os_data, 2, 2, 3, model)
parname(1) = "mx"
parname(2) = "coup"
call model%set_parameter_constant (1, parname(1), 10._default)
call model%set_parameter_constant (2, parname(2), 1.3_default)
x_longname = "X_LEPTON"
x_name(1) = "X"
x_name(2) = "x"
x_anti(1) = "Xbar"
x_tex_name = "X^+"
x_tex_anti = "X^-"
field => model%get_field_ptr_by_index (1)
call field%init (x_longname, 99)
call field%set ( &
.true., .false., .false., .false., .false., &
name=x_name, anti=x_anti, tex_name=x_tex_name, tex_anti=x_tex_anti, &
spin_type=SPINOR, isospin_type=-3, charge_type=2, &
mass_data=model%get_par_data_ptr (parname(1)))
y_longname = "Y_COLORON"
y_name(1) = "Y"
y_name(2) = "yc"
y_tex_name = "Y^0"
field => model%get_field_ptr_by_index (2)
call field%init (y_longname, 97)
call field%set ( &
.false., .false., .true., .false., .false., &
name=y_name, tex_name=y_tex_name, &
spin_type=SCALAR, isospin_type=2, charge_type=1, color_type=8)
call model%set_vertex (1, [99, 99, 99])
call model%set_vertex (2, [99, 99, 99, 99])
call model%set_vertex (3, [99, 97, 99])
call model_list%write (u)
call model_list%final ()
write (u, *)
write (u, "(A)") "* Test output end: models_1"
end subroutine models_1
@ %def models_1
@
\subsubsection{Read a Model}
Read a predefined model from file.
<<Models: execute tests>>=
call test (models_2, "models_2", &
"read model", &
u, results)
<<Models: test declarations>>=
public :: models_2
<<Models: tests>>=
subroutine models_2 (u)
integer, intent(in) :: u
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(var_list_t), pointer :: var_list
type(model_t), pointer :: model
write (u, "(A)") "* Test output: models_2"
write (u, "(A)") "* Purpose: read a model from file"
write (u, *)
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
os_data, model)
call model_list%write (u)
write (u, *)
write (u, "(A)") "* Variable list"
write (u, *)
var_list => model%get_var_list_ptr ()
call var_list%write (u)
write (u, *)
write (u, "(A)") "* Cleanup"
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_2"
end subroutine models_2
@ %def models_2
@
\subsubsection{Model Instance}
Read a predefined model from file and create an instance.
<<Models: execute tests>>=
call test (models_3, "models_3", &
"model instance", &
u, results)
<<Models: test declarations>>=
public :: models_3
<<Models: tests>>=
subroutine models_3 (u)
integer, intent(in) :: u
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model
type(var_list_t), pointer :: var_list
type(model_t), pointer :: instance
write (u, "(A)") "* Test output: models_3"
write (u, "(A)") "* Purpose: create a model instance"
write (u, *)
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
os_data, model)
allocate (instance)
call instance%init_instance (model)
call model%write (u)
write (u, *)
write (u, "(A)") "* Variable list"
write (u, *)
var_list => instance%get_var_list_ptr ()
call var_list%write (u)
write (u, *)
write (u, "(A)") "* Cleanup"
call instance%final ()
deallocate (instance)
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_3"
end subroutine models_3
@ %def models_test
@
\subsubsection{Unstable and Polarized Particles}
Read a predefined model from file and define decays and polarization.
<<Models: execute tests>>=
call test (models_4, "models_4", &
"handle decays and polarization", &
u, results)
<<Models: test declarations>>=
public :: models_4
<<Models: tests>>=
subroutine models_4 (u)
integer, intent(in) :: u
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model, model_instance
character(32) :: md5sum
write (u, "(A)") "* Test output: models_4"
write (u, "(A)") "* Purpose: set and unset decays and polarization"
write (u, *)
call syntax_model_file_init ()
call os_data%init ()
write (u, "(A)") "* Read model from file"
call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
os_data, model)
md5sum = model%get_parameters_md5sum ()
write (u, *)
write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'"
write (u, *)
write (u, "(A)") "* Set particle decays and polarization"
write (u, *)
call model%set_unstable (25, [var_str ("dec1"), var_str ("dec2")])
call model%set_polarized (6)
call model%set_unstable (-6, [var_str ("fdec")])
call model%write (u)
md5sum = model%get_parameters_md5sum ()
write (u, *)
write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'"
write (u, *)
write (u, "(A)") "* Create a model instance"
allocate (model_instance)
call model_instance%init_instance (model)
write (u, *)
write (u, "(A)") "* Revert particle decays and polarization"
write (u, *)
call model%set_stable (25)
call model%set_unpolarized (6)
call model%set_stable (-6)
call model%write (u)
md5sum = model%get_parameters_md5sum ()
write (u, *)
write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'"
write (u, *)
write (u, "(A)") "* Show the model instance"
write (u, *)
call model_instance%write (u)
md5sum = model_instance%get_parameters_md5sum ()
write (u, *)
write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'"
write (u, *)
write (u, "(A)") "* Cleanup"
call model_instance%final ()
deallocate (model_instance)
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_4"
end subroutine models_4
@ %def models_4
@
\subsubsection{Model Variables}
Read a predefined model from file and modify some parameters.
Note that the MD5 sum is not modified by this.
<<Models: execute tests>>=
call test (models_5, "models_5", &
"handle parameters", &
u, results)
<<Models: test declarations>>=
public :: models_5
<<Models: tests>>=
subroutine models_5 (u)
integer, intent(in) :: u
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(model_t), pointer :: model, model_instance
character(32) :: md5sum
write (u, "(A)") "* Test output: models_5"
write (u, "(A)") "* Purpose: access and modify model variables"
write (u, *)
call syntax_model_file_init ()
call os_data%init ()
write (u, "(A)") "* Read model from file"
call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), &
os_data, model)
write (u, *)
call model%write (u, &
show_md5sum = .true., &
show_variables = .true., &
show_parameters = .true., &
show_particles = .false., &
show_vertices = .false.)
write (u, *)
write (u, "(A)") "* Check parameter status"
write (u, *)
write (u, "(1x,A,L1)") "xy exists = ", model%var_exists (var_str ("xx"))
write (u, "(1x,A,L1)") "ff exists = ", model%var_exists (var_str ("ff"))
write (u, "(1x,A,L1)") "mf exists = ", model%var_exists (var_str ("mf"))
write (u, "(1x,A,L1)") "ff locked = ", model%var_is_locked (var_str ("ff"))
write (u, "(1x,A,L1)") "mf locked = ", model%var_is_locked (var_str ("mf"))
write (u, *)
write (u, "(1x,A,F6.2)") "ff = ", model%get_rval (var_str ("ff"))
write (u, "(1x,A,F6.2)") "mf = ", model%get_rval (var_str ("mf"))
write (u, *)
write (u, "(A)") "* Modify parameter"
write (u, *)
call model%set_real (var_str ("ff"), 1._default)
call model%write (u, &
show_md5sum = .true., &
show_variables = .true., &
show_parameters = .true., &
show_particles = .false., &
show_vertices = .false.)
write (u, *)
write (u, "(A)") "* Cleanup"
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_5"
end subroutine models_5
@ %def models_5
@
\subsubsection{Read model with disordered parameters}
Read a model from file where the ordering of independent and derived
parameters is non-canonical.
<<Models: execute tests>>=
call test (models_6, "models_6", &
"read model parameters", &
u, results)
<<Models: test declarations>>=
public :: models_6
<<Models: tests>>=
subroutine models_6 (u)
integer, intent(in) :: u
integer :: um
character(80) :: buffer
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(var_list_t), pointer :: var_list
type(model_t), pointer :: model
write (u, "(A)") "* Test output: models_6"
write (u, "(A)") "* Purpose: read a model from file &
&with non-canonical parameter ordering"
write (u, *)
open (newunit=um, file="Test6.mdl", status="replace", action="readwrite")
write (um, "(A)") 'model "Test6"'
write (um, "(A)") ' parameter a = 1.000000000000E+00'
write (um, "(A)") ' derived b = 2 * a'
write (um, "(A)") ' parameter c = 3.000000000000E+00'
write (um, "(A)") ' unused d'
rewind (um)
do
read (um, "(A)", end=1) buffer
write (u, "(A)") trim (buffer)
end do
1 continue
close (um)
call syntax_model_file_init ()
call os_data%init ()
call model_list%read_model (var_str ("Test6"), var_str ("Test6.mdl"), &
os_data, model)
write (u, *)
write (u, "(A)") "* Variable list"
write (u, *)
var_list => model%get_var_list_ptr ()
call var_list%write (u)
write (u, *)
write (u, "(A)") "* Cleanup"
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_6"
end subroutine models_6
@ %def models_6
@
\subsubsection{Read model with schemes}
Read a model from file which supports scheme selection in the
parameter list.
<<Models: execute tests>>=
call test (models_7, "models_7", &
"handle schemes", &
u, results)
<<Models: test declarations>>=
public :: models_7
<<Models: tests>>=
subroutine models_7 (u)
integer, intent(in) :: u
integer :: um
character(80) :: buffer
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(var_list_t), pointer :: var_list
type(model_t), pointer :: model
write (u, "(A)") "* Test output: models_7"
write (u, "(A)") "* Purpose: read a model from file &
&with scheme selection"
write (u, *)
open (newunit=um, file="Test7.mdl", status="replace", action="readwrite")
write (um, "(A)") 'model "Test7"'
write (um, "(A)") ' schemes = "foo", "bar", "gee"'
write (um, "(A)") ''
write (um, "(A)") ' select scheme'
write (um, "(A)") ' scheme "foo"'
write (um, "(A)") ' parameter a = 1'
write (um, "(A)") ' derived b = 2 * a'
write (um, "(A)") ' scheme other'
write (um, "(A)") ' parameter b = 4'
write (um, "(A)") ' derived a = b / 2'
write (um, "(A)") ' end select'
write (um, "(A)") ''
write (um, "(A)") ' parameter c = 3'
write (um, "(A)") ''
write (um, "(A)") ' select scheme'
write (um, "(A)") ' scheme "foo", "gee"'
write (um, "(A)") ' derived d = b + c'
write (um, "(A)") ' scheme other'
write (um, "(A)") ' unused d'
write (um, "(A)") ' end select'
rewind (um)
do
read (um, "(A)", end=1) buffer
write (u, "(A)") trim (buffer)
end do
1 continue
close (um)
call syntax_model_file_init ()
call os_data%init ()
write (u, *)
write (u, "(A)") "* Model output, default scheme (= foo)"
write (u, *)
call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
os_data, model)
call model%write (u, show_md5sum=.false.)
call show_var_list ()
call show_par_array ()
call model_list%final ()
write (u, *)
write (u, "(A)") "* Model output, scheme foo"
write (u, *)
call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
os_data, model, scheme = var_str ("foo"))
call model%write (u, show_md5sum=.false.)
call show_var_list ()
call show_par_array ()
call model_list%final ()
write (u, *)
write (u, "(A)") "* Model output, scheme bar"
write (u, *)
call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
os_data, model, scheme = var_str ("bar"))
call model%write (u, show_md5sum=.false.)
call show_var_list ()
call show_par_array ()
call model_list%final ()
write (u, *)
write (u, "(A)") "* Model output, scheme gee"
write (u, *)
call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), &
os_data, model, scheme = var_str ("gee"))
call model%write (u, show_md5sum=.false.)
call show_var_list ()
call show_par_array ()
write (u, *)
write (u, "(A)") "* Cleanup"
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_7"
contains
subroutine show_var_list ()
write (u, *)
write (u, "(A)") "* Variable list"
write (u, *)
var_list => model%get_var_list_ptr ()
call var_list%write (u)
end subroutine show_var_list
subroutine show_par_array ()
real(default), dimension(:), allocatable :: par
integer :: n
write (u, *)
write (u, "(A)") "* Parameter array"
write (u, *)
n = model%get_n_real ()
allocate (par (n))
call model%real_parameters_to_array (par)
write (u, 1) par
1 format (1X,F6.3)
end subroutine show_par_array
end subroutine models_7
@ %def models_7
@
\subsubsection{Read and handle UFO model}
Read a model from file which is considered as an UFO model. In fact,
it is a mock model file which just follows our naming convention for
UFO models. Compare this to an equivalent non-UFO model.
<<Models: execute tests>>=
call test (models_8, "models_8", &
"handle UFO-derived models", &
u, results)
<<Models: test declarations>>=
public :: models_8
<<Models: tests>>=
subroutine models_8 (u)
integer, intent(in) :: u
integer :: um
character(80) :: buffer
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(string_t) :: model_name
type(model_t), pointer :: model
write (u, "(A)") "* Test output: models_8"
write (u, "(A)") "* Purpose: distinguish models marked as UFO-derived"
write (u, *)
call os_data%init ()
call show_model_list_status ()
model_name = "models_8_M"
write (u, *)
write (u, "(A)") "* Write WHIZARD model"
write (u, *)
open (newunit=um, file=char (model_name // ".mdl"), &
status="replace", action="readwrite")
write (um, "(A)") 'model "models_8_M"'
write (um, "(A)") ' parameter a = 1'
rewind (um)
do
read (um, "(A)", end=1) buffer
write (u, "(A)") trim (buffer)
end do
1 continue
close (um)
write (u, *)
write (u, "(A)") "* Write UFO model"
write (u, *)
open (newunit=um, file=char (model_name // ".ufo.mdl"), &
status="replace", action="readwrite")
write (um, "(A)") 'model "models_8_M"'
write (um, "(A)") ' parameter a = 2'
rewind (um)
do
read (um, "(A)", end=2) buffer
write (u, "(A)") trim (buffer)
end do
2 continue
close (um)
call syntax_model_file_init ()
call os_data%init ()
write (u, *)
write (u, "(A)") "* Read WHIZARD model"
write (u, *)
call model_list%read_model (model_name, model_name // ".mdl", &
os_data, model)
call model%write (u, show_md5sum=.false.)
call show_model_list_status ()
write (u, *)
write (u, "(A)") "* Read UFO model"
write (u, *)
call model_list%read_model (model_name, model_name // ".ufo.mdl", &
os_data, model, ufo=.true., rebuild_mdl = .false.)
call model%write (u, show_md5sum=.false.)
call show_model_list_status ()
write (u, *)
write (u, "(A)") "* Reload WHIZARD model"
write (u, *)
call model_list%read_model (model_name, model_name // ".mdl", &
os_data, model)
call model%write (u, show_md5sum=.false.)
call show_model_list_status ()
write (u, *)
write (u, "(A)") "* Reload UFO model"
write (u, *)
call model_list%read_model (model_name, model_name // ".ufo.mdl", &
os_data, model, ufo=.true., rebuild_mdl = .false.)
call model%write (u, show_md5sum=.false.)
call show_model_list_status ()
write (u, *)
write (u, "(A)") "* Cleanup"
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_8"
contains
subroutine show_model_list_status ()
write (u, "(A)") "* Model list status"
write (u, *)
write (u, "(A,1x,L1)") "WHIZARD model exists =", &
model_list%model_exists (model_name)
write (u, "(A,1x,L1)") "UFO model exists =", &
model_list%model_exists (model_name, ufo=.true.)
end subroutine show_model_list_status
end subroutine models_8
@ %def models_8
@
\subsubsection{Generate UFO model file}
Generate the necessary [[.ufo.mdl]] file from source, calling OMega, and load the model.
Note: There must not be another unit test which works with the same
UFO model. The model file is deleted explicitly at the end of this test.
<<Models: execute tests>>=
call test (models_9, "models_9", &
"generate UFO-derived model file", &
u, results)
<<Models: test declarations>>=
public :: models_9
<<Models: tests>>=
subroutine models_9 (u)
integer, intent(in) :: u
integer :: um
character(80) :: buffer
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(string_t) :: model_name, model_file_name
type(model_t), pointer :: model
write (u, "(A)") "* Test output: models_9"
write (u, "(A)") "* Purpose: enable the UFO Standard Model (test version)"
write (u, *)
call os_data%init ()
call syntax_model_file_init ()
os_data%whizard_modelpath_ufo = "../models/UFO"
model_name = "SM"
model_file_name = model_name // ".models_9" // ".ufo.mdl"
write (u, "(A)") "* Generate and read UFO model"
write (u, *)
call delete_file (char (model_file_name))
call model_list%read_model (model_name, model_file_name, os_data, model, ufo=.true.)
call model%write (u, show_md5sum=.false.)
write (u, *)
write (u, "(A)") "* Cleanup"
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_9"
end subroutine models_9
@ %def models_9
@
\subsubsection{Read model with schemes}
Read a model from file which contains [[slha_entry]] qualifiers for parameters.
<<Models: execute tests>>=
call test (models_10, "models_10", &
"handle slha_entry option", &
u, results)
<<Models: test declarations>>=
public :: models_10
<<Models: tests>>=
subroutine models_10 (u)
integer, intent(in) :: u
integer :: um
character(80) :: buffer
type(os_data_t) :: os_data
type(model_list_t) :: model_list
type(var_list_t), pointer :: var_list
type(model_t), pointer :: model
type(string_t), dimension(:), allocatable :: slha_block_name
integer :: i
write (u, "(A)") "* Test output: models_10"
write (u, "(A)") "* Purpose: read a model from file &
&with slha_entry options"
write (u, *)
open (newunit=um, file="Test10.mdl", status="replace", action="readwrite")
write (um, "(A)") 'model "Test10"'
write (um, "(A)") ' parameter a = 1 slha_entry FOO 1'
write (um, "(A)") ' parameter b = 4 slha_entry BAR 2 1'
rewind (um)
do
read (um, "(A)", end=1) buffer
write (u, "(A)") trim (buffer)
end do
1 continue
close (um)
call syntax_model_file_init ()
call os_data%init ()
write (u, *)
write (u, "(A)") "* Model output, default scheme (= foo)"
write (u, *)
call model_list%read_model (var_str ("Test10"), var_str ("Test10.mdl"), &
os_data, model)
call model%write (u, show_md5sum=.false.)
write (u, *)
write (u, "(A)") "* Check that model contains slha_entry options"
write (u, *)
write (u, "(A,1x,L1)") &
"supports_custom_slha =", model%supports_custom_slha ()
write (u, *)
write (u, "(A)") "custom_slha_blocks ="
call model%get_custom_slha_blocks (slha_block_name)
do i = 1, size (slha_block_name)
write (u, "(1x,A)", advance="no") char (slha_block_name(i))
end do
write (u, *)
write (u, *)
write (u, "(A)") "* Parameter lookup"
write (u, *)
call show_slha ("FOO", [1])
call show_slha ("FOO", [2])
call show_slha ("BAR", [2, 1])
call show_slha ("GEE", [3])
write (u, *)
write (u, "(A)") "* Modify parameter via SLHA block interface"
write (u, *)
call model%slha_set_par (var_str ("FOO"), [1], 7._default)
call show_slha ("FOO", [1])
write (u, *)
write (u, "(A)") "* Show var list with modified parameter"
write (u, *)
call show_var_list ()
write (u, *)
write (u, "(A)") "* Cleanup"
call model_list%final ()
call syntax_model_file_final ()
write (u, *)
write (u, "(A)") "* Test output end: models_10"
contains
subroutine show_slha (block_name, block_index)
character(*), intent(in) :: block_name
integer, dimension(:), intent(in) :: block_index
class(modelpar_data_t), pointer :: par_data
write (u, "(A,*(1x,I0))", advance="no") block_name, block_index
write (u, "(' => ')", advance="no")
call model%slha_lookup (var_str (block_name), block_index, par_data)
if (associated (par_data)) then
call par_data%write (u)
write (u, *)
else
write (u, "('-')")
end if
end subroutine show_slha
subroutine show_var_list ()
var_list => model%get_var_list_ptr ()
call var_list%write (u)
end subroutine show_var_list
end subroutine models_10
@ %def models_10
@
\clearpage
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{The SUSY Les Houches Accord}
The SUSY Les Houches Accord defines a standard interfaces for storing
the physics data of SUSY models. Here, we provide the means
for reading, storing, and writing such data.
<<[[slha_interface.f90]]>>=
<<File header>>
module slha_interface
<<Use kinds>>
<<Use strings>>
use io_units
use constants
use string_utils, only: upper_case
use system_defs, only: VERSION_STRING
use system_defs, only: EOF
use diagnostics
use os_interface
use ifiles
use lexers
use syntax_rules
use parser
use variables
use models
<<Standard module head>>
<<SLHA: public>>
<<SLHA: parameters>>
<<SLHA: variables>>
save
contains
<<SLHA: procedures>>
<<SLHA: tests>>
end module slha_interface
@ %def slha_interface
@
\subsection{Preprocessor}
SLHA is a mixed-format standard. It should be read in assuming free
format (but line-oriented), but it has some fixed-format elements.
To overcome this difficulty, we implement a preprocessing step which
transforms the SLHA into a format that can be swallowed by our generic
free-format lexer and parser. Each line with a blank first character
is assumed to be a data line. We prepend a 'DATA' keyword to these lines.
Furthermore, to enforce line-orientation, each line is appended a '\$'
key which is recognized by the parser. To do this properly, we first
remove trailing comments, and skip lines consisting only of comments.
The preprocessor reads from a stream and puts out an [[ifile]].
Blocks that are not recognized are skipped. For some blocks, data
items are quoted, so they can be read as strings if necessary.
A name clash occurse if the block name is identical to a keyword.
This can happen for custom SLHA models and files. In that case, we
prepend an underscore, which will be silently suppressed where needed.
<<SLHA: parameters>>=
integer, parameter :: MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2
@ %def MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2
<<SLHA: procedures>>=
subroutine slha_preprocess (stream, custom_block_name, ifile)
type(stream_t), intent(inout), target :: stream
type(string_t), dimension(:), intent(in) :: custom_block_name
type(ifile_t), intent(out) :: ifile
type(string_t) :: buffer, line, item
integer :: iostat
integer :: mode
mode = MODE
SCAN_FILE: do
call stream_get_record (stream, buffer, iostat)
select case (iostat)
case (0)
call split (buffer, line, "#")
if (len_trim (line) == 0) cycle SCAN_FILE
select case (char (extract (line, 1, 1)))
case ("B", "b")
call check_block_handling (line, custom_block_name, mode)
call ifile_append (ifile, line // "$")
case ("D", "d")
mode = MODE_DATA
call ifile_append (ifile, line // "$")
case (" ")
select case (mode)
case (MODE_DATA)
call ifile_append (ifile, "DATA" // line // "$")
case (MODE_INFO)
line = adjustl (line)
call split (line, item, " ")
call ifile_append (ifile, "INFO" // " " // item // " " &
// '"' // trim (adjustl (line)) // '" $')
end select
case default
call msg_message (char (line))
call msg_fatal ("SLHA: Incomprehensible line")
end select
case (EOF)
exit SCAN_FILE
case default
call msg_fatal ("SLHA: I/O error occured while reading SLHA input")
end select
end do SCAN_FILE
end subroutine slha_preprocess
@ %def slha_preprocess
@ Return the mode that we should treat this block with. We add the
[[custom_block_name]] array to the set of supported blocks, which
otherwise includes only hard-coded block names. Those custom blocks
are data blocks.
Unknown blocks will be skipped altogether. The standard does not
specify their internal format at all, so we must not parse their
content.
If the name of a (custom) block clashes with a keyword of the SLHA
syntax, we append an underscore to the block name, modifying the
current line string. This should be silently suppressed when actually
parsing block names.
<<SLHA: procedures>>=
subroutine check_block_handling (line, custom_block_name, mode)
type(string_t), intent(inout) :: line
type(string_t), dimension(:), intent(in) :: custom_block_name
integer, intent(out) :: mode
type(string_t) :: buffer, key, block_name
integer :: i
buffer = trim (line)
call split (buffer, key, " ")
buffer = adjustl (buffer)
call split (buffer, block_name, " ")
buffer = adjustl (buffer)
block_name = trim (adjustl (upper_case (block_name)))
select case (char (block_name))
case ("MODSEL", "MINPAR", "SMINPUTS")
mode = MODE_DATA
case ("MASS")
mode = MODE_DATA
case ("NMIX", "UMIX", "VMIX", "STOPMIX", "SBOTMIX", "STAUMIX")
mode = MODE_DATA
case ("NMHMIX", "NMAMIX", "NMNMIX", "NMSSMRUN")
mode = MODE_DATA
case ("ALPHA", "HMIX")
mode = MODE_DATA
case ("AU", "AD", "AE")
mode = MODE_DATA
case ("SPINFO", "DCINFO")
mode = MODE_INFO
case default
mode = MODE_SKIP
CHECK_CUSTOM_NAMES: do i = 1, size (custom_block_name)
if (block_name == custom_block_name(i)) then
mode = MODE_DATA
call mangle_keywords (block_name)
line = key // " " // block_name // " " // trim (buffer)
exit CHECK_CUSTOM_NAMES
end if
end do CHECK_CUSTOM_NAMES
end select
end subroutine check_block_handling
@ %def check_block_handling
@ Append an underscore to specific block names:
<<SLHA: procedures>>=
subroutine mangle_keywords (name)
type(string_t), intent(inout) :: name
select case (char (name))
case ("BLOCK", "DATA", "INFO", "DECAY")
name = name // "_"
end select
end subroutine mangle_keywords
@ %def mangle_keywords
@ Remove the underscore again:
<<SLHA: procedures>>=
subroutine demangle_keywords (name)
type(string_t), intent(inout) :: name
select case (char (name))
case ("BLOCK_", "DATA_", "INFO_", "DECAY_")
name = extract (name, 1, len(name)-1)
end select
end subroutine demangle_keywords
@ %def demangle_keywords
@
\subsection{Lexer and syntax}
<<SLHA: variables>>=
type(syntax_t), target :: syntax_slha
@ %def syntax_slha
<<SLHA: public>>=
public :: syntax_slha_init
<<SLHA: procedures>>=
subroutine syntax_slha_init ()
type(ifile_t) :: ifile
call define_slha_syntax (ifile)
call syntax_init (syntax_slha, ifile)
call ifile_final (ifile)
end subroutine syntax_slha_init
@ %def syntax_slha_init
<<SLHA: public>>=
public :: syntax_slha_final
<<SLHA: procedures>>=
subroutine syntax_slha_final ()
call syntax_final (syntax_slha)
end subroutine syntax_slha_final
@ %def syntax_slha_final
<<SLHA: public>>=
public :: syntax_slha_write
<<SLHA: procedures>>=
subroutine syntax_slha_write (unit)
integer, intent(in), optional :: unit
call syntax_write (syntax_slha, unit)
end subroutine syntax_slha_write
@ %def syntax_slha_write
<<SLHA: procedures>>=
subroutine define_slha_syntax (ifile)
type(ifile_t), intent(inout) :: ifile
call ifile_append (ifile, "SEQ slha = chunk*")
call ifile_append (ifile, "ALT chunk = block_def | decay_def")
call ifile_append (ifile, "SEQ block_def = " &
// "BLOCK blockgen '$' block_line*")
call ifile_append (ifile, "ALT blockgen = block_spec | q_spec")
call ifile_append (ifile, "KEY BLOCK")
call ifile_append (ifile, "SEQ q_spec = QNUMBERS pdg_code")
call ifile_append (ifile, "KEY QNUMBERS")
call ifile_append (ifile, "SEQ block_spec = block_name qvalue?")
call ifile_append (ifile, "IDE block_name")
call ifile_append (ifile, "SEQ qvalue = qname '=' real")
call ifile_append (ifile, "IDE qname")
call ifile_append (ifile, "KEY '='")
call ifile_append (ifile, "REA real")
call ifile_append (ifile, "KEY '$'")
call ifile_append (ifile, "ALT block_line = block_data | block_info")
call ifile_append (ifile, "SEQ block_data = DATA data_line '$'")
call ifile_append (ifile, "KEY DATA")
call ifile_append (ifile, "SEQ data_line = data_item+")
call ifile_append (ifile, "ALT data_item = signed_number | number")
call ifile_append (ifile, "SEQ signed_number = sign number")
call ifile_append (ifile, "ALT sign = '+' | '-'")
call ifile_append (ifile, "ALT number = integer | real")
call ifile_append (ifile, "INT integer")
call ifile_append (ifile, "KEY '-'")
call ifile_append (ifile, "KEY '+'")
call ifile_append (ifile, "SEQ block_info = INFO info_line '$'")
call ifile_append (ifile, "KEY INFO")
call ifile_append (ifile, "SEQ info_line = integer string_literal")
call ifile_append (ifile, "QUO string_literal = '""'...'""'")
call ifile_append (ifile, "SEQ decay_def = " &
// "DECAY decay_spec '$' decay_data*")
call ifile_append (ifile, "KEY DECAY")
call ifile_append (ifile, "SEQ decay_spec = pdg_code data_item")
call ifile_append (ifile, "ALT pdg_code = signed_integer | integer")
call ifile_append (ifile, "SEQ signed_integer = sign integer")
call ifile_append (ifile, "SEQ decay_data = DATA decay_line '$'")
call ifile_append (ifile, "SEQ decay_line = data_item integer pdg_code+")
end subroutine define_slha_syntax
@ %def define_slha_syntax
@ The SLHA specification allows for string data items in certain
places. Currently, we do not interpret them, but the strings, which
are not quoted, must be parsed somehow. The hack for this problem is
to allow essentially all characters as special characters, so the
string can be read before it is discarded.
<<SLHA: public>>=
public :: lexer_init_slha
<<SLHA: procedures>>=
subroutine lexer_init_slha (lexer)
type(lexer_t), intent(out) :: lexer
call lexer_init (lexer, &
comment_chars = "#", &
quote_chars = '"', &
quote_match = '"', &
single_chars = "+-=$", &
special_class = [ "" ], &
keyword_list = syntax_get_keyword_list_ptr (syntax_slha), &
upper_case_keywords = .true.) ! $
end subroutine lexer_init_slha
@ %def lexer_init_slha
@
\subsection{Interpreter}
\subsubsection{Find blocks}
From the parse tree, find the node that represents a particular
block. If [[required]] is true, issue an error if not found.
Since [[block_name]] is always invoked with capital letters, we
have to capitalize [[pn_block_name]].
<<SLHA: procedures>>=
function slha_get_block_ptr &
(parse_tree, block_name, required) result (pn_block)
type(parse_node_t), pointer :: pn_block
type(parse_tree_t), intent(in) :: parse_tree
type(string_t), intent(in) :: block_name
type(string_t) :: block_def
logical, intent(in) :: required
type(parse_node_t), pointer :: pn_root, pn_block_spec, pn_block_name
pn_root => parse_tree%get_root_ptr ()
pn_block => parse_node_get_sub_ptr (pn_root)
do while (associated (pn_block))
select case (char (parse_node_get_rule_key (pn_block)))
case ("block_def")
pn_block_spec => parse_node_get_sub_ptr (pn_block, 2)
pn_block_name => parse_node_get_sub_ptr (pn_block_spec)
select case (char (pn_block_name%get_rule_key ()))
case ("block_name")
block_def = trim (adjustl (upper_case &
(pn_block_name%get_string ())))
case ("QNUMBERS")
block_def = "QNUMBERS"
end select
if (block_def == block_name) then
return
end if
end select
pn_block => parse_node_get_next_ptr (pn_block)
end do
if (required) then
call msg_fatal ("SLHA: block '" // char (block_name) // "' not found")
end if
end function slha_get_block_ptr
@ %def slha_get_blck_ptr
@ Scan the file for the first/next DECAY block.
<<SLHA: procedures>>=
function slha_get_first_decay_ptr (parse_tree) result (pn_decay)
type(parse_node_t), pointer :: pn_decay
type(parse_tree_t), intent(in) :: parse_tree
type(parse_node_t), pointer :: pn_root
pn_root => parse_tree%get_root_ptr ()
pn_decay => parse_node_get_sub_ptr (pn_root)
do while (associated (pn_decay))
select case (char (parse_node_get_rule_key (pn_decay)))
case ("decay_def")
return
end select
pn_decay => parse_node_get_next_ptr (pn_decay)
end do
end function slha_get_first_decay_ptr
function slha_get_next_decay_ptr (pn_block) result (pn_decay)
type(parse_node_t), pointer :: pn_decay
type(parse_node_t), intent(in), target :: pn_block
pn_decay => parse_node_get_next_ptr (pn_block)
do while (associated (pn_decay))
select case (char (parse_node_get_rule_key (pn_decay)))
case ("decay_def")
return
end select
pn_decay => parse_node_get_next_ptr (pn_decay)
end do
end function slha_get_next_decay_ptr
@ %def slha_get_next_decay_ptr
@
\subsubsection{Extract and transfer data from blocks}
Given the parse node of a block, find the parse node of a particular
switch or data line. Return this node and the node of the data item
following the integer code.
<<SLHA: procedures>>=
subroutine slha_find_index_ptr (pn_block, pn_data, pn_item, code)
type(parse_node_t), intent(in), target :: pn_block
type(parse_node_t), intent(out), pointer :: pn_data
type(parse_node_t), intent(out), pointer :: pn_item
integer, intent(in) :: code
pn_data => parse_node_get_sub_ptr (pn_block, 4)
call slha_next_index_ptr (pn_data, pn_item, code)
end subroutine slha_find_index_ptr
subroutine slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2)
type(parse_node_t), intent(in), target :: pn_block
type(parse_node_t), intent(out), pointer :: pn_data
type(parse_node_t), intent(out), pointer :: pn_item
integer, intent(in) :: code1, code2
pn_data => parse_node_get_sub_ptr (pn_block, 4)
call slha_next_index_pair_ptr (pn_data, pn_item, code1, code2)
end subroutine slha_find_index_pair_ptr
@ %def slha_find_index_ptr slha_find_index_pair_ptr
@ Starting from the pointer to a data line, find a data line with the
given integer code.
<<SLHA: procedures>>=
subroutine slha_next_index_ptr (pn_data, pn_item, code)
type(parse_node_t), intent(inout), pointer :: pn_data
integer, intent(in) :: code
type(parse_node_t), intent(out), pointer :: pn_item
type(parse_node_t), pointer :: pn_line, pn_code
do while (associated (pn_data))
pn_line => parse_node_get_sub_ptr (pn_data, 2)
pn_code => parse_node_get_sub_ptr (pn_line)
select case (char (parse_node_get_rule_key (pn_code)))
case ("integer")
if (parse_node_get_integer (pn_code) == code) then
pn_item => parse_node_get_next_ptr (pn_code)
return
end if
end select
pn_data => parse_node_get_next_ptr (pn_data)
end do
pn_item => null ()
end subroutine slha_next_index_ptr
@ %def slha_next_index_ptr
@ Starting from the pointer to a data line, find a data line with the
given integer code pair.
<<SLHA: procedures>>=
subroutine slha_next_index_pair_ptr (pn_data, pn_item, code1, code2)
type(parse_node_t), intent(inout), pointer :: pn_data
integer, intent(in) :: code1, code2
type(parse_node_t), intent(out), pointer :: pn_item
type(parse_node_t), pointer :: pn_line, pn_code1, pn_code2
do while (associated (pn_data))
pn_line => parse_node_get_sub_ptr (pn_data, 2)
pn_code1 => parse_node_get_sub_ptr (pn_line)
select case (char (parse_node_get_rule_key (pn_code1)))
case ("integer")
if (parse_node_get_integer (pn_code1) == code1) then
pn_code2 => parse_node_get_next_ptr (pn_code1)
if (associated (pn_code2)) then
select case (char (parse_node_get_rule_key (pn_code2)))
case ("integer")
if (parse_node_get_integer (pn_code2) == code2) then
pn_item => parse_node_get_next_ptr (pn_code2)
return
end if
end select
end if
end if
end select
pn_data => parse_node_get_next_ptr (pn_data)
end do
pn_item => null ()
end subroutine slha_next_index_pair_ptr
@ %def slha_next_index_pair_ptr
@
\subsubsection{Handle info data}
Return all strings with index [[i]]. The result is an allocated
string array. Since we do not know the number of matching entries in
advance, we build an intermediate list which is transferred to the
final array and deleted before exiting.
<<SLHA: procedures>>=
subroutine retrieve_strings_in_block (pn_block, code, str_array)
type(parse_node_t), intent(in), target :: pn_block
integer, intent(in) :: code
type(string_t), dimension(:), allocatable, intent(out) :: str_array
type(parse_node_t), pointer :: pn_data, pn_item
type :: str_entry_t
type(string_t) :: str
type(str_entry_t), pointer :: next => null ()
end type str_entry_t
type(str_entry_t), pointer :: first => null ()
type(str_entry_t), pointer :: current => null ()
integer :: n
n = 0
call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
if (associated (pn_item)) then
n = n + 1
allocate (first)
first%str = parse_node_get_string (pn_item)
current => first
do while (associated (pn_data))
pn_data => parse_node_get_next_ptr (pn_data)
call slha_next_index_ptr (pn_data, pn_item, code)
if (associated (pn_item)) then
n = n + 1
allocate (current%next)
current => current%next
current%str = parse_node_get_string (pn_item)
end if
end do
allocate (str_array (n))
n = 0
do while (associated (first))
n = n + 1
current => first
str_array(n) = current%str
first => first%next
deallocate (current)
end do
else
allocate (str_array (0))
end if
end subroutine retrieve_strings_in_block
@ %def retrieve_strings_in_block
@
\subsubsection{Transfer data from SLHA to variables}
Extract real parameter with index [[i]]. If it does not
exist, retrieve it from the variable list, using the given name.
<<SLHA: procedures>>=
function get_parameter_in_block (pn_block, code, name, var_list) result (var)
real(default) :: var
type(parse_node_t), intent(in), target :: pn_block
integer, intent(in) :: code
type(string_t), intent(in) :: name
type(var_list_t), intent(in), target :: var_list
type(parse_node_t), pointer :: pn_data, pn_item
call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
if (associated (pn_item)) then
var = get_real_parameter (pn_item)
else
var = var_list%get_rval (name)
end if
end function get_parameter_in_block
@ %def get_parameter_in_block
@ Extract a real data item with index [[i]]. If it
does exist, set it in the variable list, using the given name. If
the variable is not present in the variable list, ignore it.
<<SLHA: procedures>>=
subroutine set_data_item (pn_block, code, name, var_list)
type(parse_node_t), intent(in), target :: pn_block
integer, intent(in) :: code
type(string_t), intent(in) :: name
type(var_list_t), intent(inout), target :: var_list
type(parse_node_t), pointer :: pn_data, pn_item
call slha_find_index_ptr (pn_block, pn_data, pn_item, code)
if (associated (pn_item)) then
call var_list%set_real (name, get_real_parameter (pn_item), &
is_known=.true., ignore=.true.)
end if
end subroutine set_data_item
@ %def set_data_item
@ Extract a real matrix element with index [[i,j]]. If it
does exists, set it in the variable list, using the given name. If
the variable is not present in the variable list, ignore it.
<<SLHA: procedures>>=
subroutine set_matrix_element (pn_block, code1, code2, name, var_list)
type(parse_node_t), intent(in), target :: pn_block
integer, intent(in) :: code1, code2
type(string_t), intent(in) :: name
type(var_list_t), intent(inout), target :: var_list
type(parse_node_t), pointer :: pn_data, pn_item
call slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2)
if (associated (pn_item)) then
call var_list%set_real (name, get_real_parameter (pn_item), &
is_known=.true., ignore=.true.)
end if
end subroutine set_matrix_element
@ %def set_matrix_element
@
\subsubsection{Transfer data from variables to SLHA}
Get a real/integer parameter with index [[i]] from the variable list and write
it to the current output file. In the integer case, we account for
the fact that the variable is type real. If it does not exist, do nothing.
<<SLHA: procedures>>=
subroutine write_integer_data_item (u, code, name, var_list, comment)
integer, intent(in) :: u
integer, intent(in) :: code
type(string_t), intent(in) :: name
type(var_list_t), intent(in) :: var_list
character(*), intent(in) :: comment
integer :: item
if (var_list%contains (name)) then
item = nint (var_list%get_rval (name))
call write_integer_parameter (u, code, item, comment)
end if
end subroutine write_integer_data_item
subroutine write_real_data_item (u, code, name, var_list, comment)
integer, intent(in) :: u
integer, intent(in) :: code
type(string_t), intent(in) :: name
type(var_list_t), intent(in) :: var_list
character(*), intent(in) :: comment
real(default) :: item
if (var_list%contains (name)) then
item = var_list%get_rval (name)
call write_real_parameter (u, code, item, comment)
end if
end subroutine write_real_data_item
@ %def write_real_data_item
@ Get a real data item with two integer indices from the variable list
and write it to the current output file. If it does not exist, do
nothing.
<<SLHA: procedures>>=
subroutine write_matrix_element (u, code1, code2, name, var_list, comment)
integer, intent(in) :: u
integer, intent(in) :: code1, code2
type(string_t), intent(in) :: name
type(var_list_t), intent(in) :: var_list
character(*), intent(in) :: comment
real(default) :: item
if (var_list%contains (name)) then
item = var_list%get_rval (name)
call write_real_matrix_element (u, code1, code2, item, comment)
end if
end subroutine write_matrix_element
@ %def write_matrix_element
@
\subsection{Auxiliary function}
Write a block header.
<<SLHA: procedures>>=
subroutine write_block_header (u, name, comment)
integer, intent(in) :: u
character(*), intent(in) :: name, comment
write (u, "(A,1x,A,3x,'#',1x,A)") "BLOCK", name, comment
end subroutine write_block_header
@ %def write_block_header
@ Extract a real parameter that may be defined real or
integer, signed or unsigned.
<<SLHA: procedures>>=
function get_real_parameter (pn_item) result (var)
real(default) :: var
type(parse_node_t), intent(in), target :: pn_item
type(parse_node_t), pointer :: pn_sign, pn_var
integer :: sign
select case (char (parse_node_get_rule_key (pn_item)))
case ("signed_number")
pn_sign => parse_node_get_sub_ptr (pn_item)
pn_var => parse_node_get_next_ptr (pn_sign)
select case (char (parse_node_get_key (pn_sign)))
case ("+"); sign = +1
case ("-"); sign = -1
end select
case default
sign = +1
pn_var => pn_item
end select
select case (char (parse_node_get_rule_key (pn_var)))
case ("integer"); var = sign * parse_node_get_integer (pn_var)
case ("real"); var = sign * parse_node_get_real (pn_var)
end select
end function get_real_parameter
@ %def get_real_parameter
@ Auxiliary: Extract an integer parameter that may be defined signed
or unsigned. A real value is an error.
<<SLHA: procedures>>=
function get_integer_parameter (pn_item) result (var)
integer :: var
type(parse_node_t), intent(in), target :: pn_item
type(parse_node_t), pointer :: pn_sign, pn_var
integer :: sign
select case (char (parse_node_get_rule_key (pn_item)))
case ("signed_integer")
pn_sign => parse_node_get_sub_ptr (pn_item)
pn_var => parse_node_get_next_ptr (pn_sign)
select case (char (parse_node_get_key (pn_sign)))
case ("+"); sign = +1
case ("-"); sign = -1
end select
case ("integer")
sign = +1
pn_var => pn_item
case default
call parse_node_write (pn_var)
call msg_error ("SLHA: Integer parameter expected")
var = 0
return
end select
var = sign * parse_node_get_integer (pn_var)
end function get_integer_parameter
@ %def get_real_parameter
@ Write an integer parameter with a single index directly to file,
using the required output format.
<<SLHA: procedures>>=
subroutine write_integer_parameter (u, code, item, comment)
integer, intent(in) :: u
integer, intent(in) :: code
integer, intent(in) :: item
character(*), intent(in) :: comment
1 format (1x, I9, 3x, 3x, I9, 4x, 3x, '#', 1x, A)
write (u, 1) code, item, comment
end subroutine write_integer_parameter
@ %def write_integer_parameter
@ Write a real parameter with two indices directly to file,
using the required output format.
<<SLHA: procedures>>=
subroutine write_real_parameter (u, code, item, comment)
integer, intent(in) :: u
integer, intent(in) :: code
real(default), intent(in) :: item
character(*), intent(in) :: comment
1 format (1x, I9, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A)
write (u, 1) code, item, comment
end subroutine write_real_parameter
@ %def write_real_parameter
@ Write a real parameter with a single index directly to file,
using the required output format.
<<SLHA: procedures>>=
subroutine write_real_matrix_element (u, code1, code2, item, comment)
integer, intent(in) :: u
integer, intent(in) :: code1, code2
real(default), intent(in) :: item
character(*), intent(in) :: comment
1 format (1x, I2, 1x, I2, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A)
write (u, 1) code1, code2, item, comment
end subroutine write_real_matrix_element
@ %def write_real_matrix_element
@
\subsubsection{The concrete SLHA interpreter}
SLHA codes for particular physics models
<<SLHA: parameters>>=
integer, parameter :: MDL_MSSM = 0
integer, parameter :: MDL_NMSSM = 1
@ %def MDL_MSSM MDL_NMSSM
@ Take the parse tree and extract relevant data. Select the correct
model and store all data that is present in the appropriate variable
list. Finally, update the variable record.
We assume that if the model contains custom SLHA block names, we just
have to scan those to get complete information. Block names could
coincide with the SLHA standard block names, but we do not have to
assume this. This will be the situation for an UFO-generated file.
In particular, an UFO file should contain all expressions necessary
for computing dependent parameters, so we can forget about the strict
SLHA standard and its hard-coded conventions.
If there are no custom SLHA block names, we should assume that the
model is a standard SUSY model, and the parameters and hard-coded
blocks can be read as specified by the original SLHA standard. There
are hard-coded block names and parameter calculations.
Public for use in unit test.
<<SLHA: public>>=
public :: slha_interpret_parse_tree
<<SLHA: procedures>>=
subroutine slha_interpret_parse_tree &
(parse_tree, model, input, spectrum, decays)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
logical, intent(in) :: input, spectrum, decays
logical :: errors
integer :: mssm_type
if (model%supports_custom_slha ()) then
call slha_handle_custom_file (parse_tree, model)
else
call slha_handle_MODSEL (parse_tree, model, mssm_type)
if (input) then
call slha_handle_SMINPUTS (parse_tree, model)
call slha_handle_MINPAR (parse_tree, model, mssm_type)
end if
if (spectrum) then
call slha_handle_info_block (parse_tree, "SPINFO", errors)
if (errors) return
call slha_handle_MASS (parse_tree, model)
call slha_handle_matrix_block (parse_tree, "NMIX", "mn_", 4, 4, model)
call slha_handle_matrix_block (parse_tree, "NMNMIX", "mixn_", 5, 5, model)
call slha_handle_matrix_block (parse_tree, "UMIX", "mu_", 2, 2, model)
call slha_handle_matrix_block (parse_tree, "VMIX", "mv_", 2, 2, model)
call slha_handle_matrix_block (parse_tree, "STOPMIX", "mt_", 2, 2, model)
call slha_handle_matrix_block (parse_tree, "SBOTMIX", "mb_", 2, 2, model)
call slha_handle_matrix_block (parse_tree, "STAUMIX", "ml_", 2, 2, model)
call slha_handle_matrix_block (parse_tree, "NMHMIX", "mixh0_", 3, 3, model)
call slha_handle_matrix_block (parse_tree, "NMAMIX", "mixa0_", 2, 3, model)
call slha_handle_ALPHA (parse_tree, model)
call slha_handle_HMIX (parse_tree, model)
call slha_handle_NMSSMRUN (parse_tree, model)
call slha_handle_matrix_block (parse_tree, "AU", "Au_", 3, 3, model)
call slha_handle_matrix_block (parse_tree, "AD", "Ad_", 3, 3, model)
call slha_handle_matrix_block (parse_tree, "AE", "Ae_", 3, 3, model)
end if
end if
if (decays) then
call slha_handle_info_block (parse_tree, "DCINFO", errors)
if (errors) return
call slha_handle_decays (parse_tree, model)
end if
end subroutine slha_interpret_parse_tree
@ %def slha_interpret_parse_tree
@
\subsubsection{Info blocks}
Handle the informational blocks SPINFO and DCINFO. The first two
items are program name and version. Items with index 3 are warnings.
Items with index 4 are errors. We reproduce these as WHIZARD warnings
and errors.
<<SLHA: procedures>>=
subroutine slha_handle_info_block (parse_tree, block_name, errors)
type(parse_tree_t), intent(in) :: parse_tree
character(*), intent(in) :: block_name
logical, intent(out) :: errors
type(parse_node_t), pointer :: pn_block
type(string_t), dimension(:), allocatable :: msg
integer :: i
pn_block => slha_get_block_ptr &
(parse_tree, var_str (block_name), required=.true.)
if (.not. associated (pn_block)) then
call msg_error ("SLHA: Missing info block '" &
// trim (block_name) // "'; ignored.")
errors = .true.
return
end if
select case (block_name)
case ("SPINFO")
call msg_message ("SLHA: SUSY spectrum program info:")
case ("DCINFO")
call msg_message ("SLHA: SUSY decay program info:")
end select
call retrieve_strings_in_block (pn_block, 1, msg)
do i = 1, size (msg)
call msg_message ("SLHA: " // char (msg(i)))
end do
call retrieve_strings_in_block (pn_block, 2, msg)
do i = 1, size (msg)
call msg_message ("SLHA: " // char (msg(i)))
end do
call retrieve_strings_in_block (pn_block, 3, msg)
do i = 1, size (msg)
call msg_warning ("SLHA: " // char (msg(i)))
end do
call retrieve_strings_in_block (pn_block, 4, msg)
do i = 1, size (msg)
call msg_error ("SLHA: " // char (msg(i)))
end do
errors = size (msg) > 0
end subroutine slha_handle_info_block
@ %def slha_handle_info_block
@
\subsubsection{MODSEL}
Handle the overall model definition. Only certain models are
recognized. The soft-breaking model templates that determine the set
of input parameters.
This block used to be required, but for generic UFO model support we
should allow for its absence. In that case, [[mssm_type]] will be set
to a negative value. If the block is present, the model must be one
of the following, or parsing ends with an error.
<<SLHA: parameters>>=
integer, parameter :: MSSM_GENERIC = 0
integer, parameter :: MSSM_SUGRA = 1
integer, parameter :: MSSM_GMSB = 2
integer, parameter :: MSSM_AMSB = 3
@ %def MSSM_GENERIC MSSM_MSUGRA MSSM_GMSB MSSM_AMSB
<<SLHA: procedures>>=
subroutine slha_handle_MODSEL (parse_tree, model, mssm_type)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(in), target :: model
integer, intent(out) :: mssm_type
type(parse_node_t), pointer :: pn_block, pn_data, pn_item
type(string_t) :: model_name
pn_block => slha_get_block_ptr &
(parse_tree, var_str ("MODSEL"), required=.false.)
if (.not. associated (pn_block)) then
mssm_type = -1
return
end if
call slha_find_index_ptr (pn_block, pn_data, pn_item, 1)
if (associated (pn_item)) then
mssm_type = get_integer_parameter (pn_item)
else
mssm_type = MSSM_GENERIC
end if
call slha_find_index_ptr (pn_block, pn_data, pn_item, 3)
if (associated (pn_item)) then
select case (parse_node_get_integer (pn_item))
case (MDL_MSSM); model_name = "MSSM"
case (MDL_NMSSM); model_name = "NMSSM"
case default
call msg_fatal ("SLHA: unknown model code in MODSEL")
return
end select
else
model_name = "MSSM"
end if
call slha_find_index_ptr (pn_block, pn_data, pn_item, 4)
if (associated (pn_item)) then
call msg_fatal (" R-parity violation is currently not supported by WHIZARD.")
end if
call slha_find_index_ptr (pn_block, pn_data, pn_item, 5)
if (associated (pn_item)) then
call msg_fatal (" CP violation is currently not supported by WHIZARD.")
end if
select case (char (model_name))
case ("MSSM")
select case (char (model%get_name ()))
case ("MSSM","MSSM_CKM","MSSM_Grav","MSSM_Hgg")
model_name = model%get_name ()
case default
call msg_fatal ("Selected model '" &
// char (model%get_name ()) // "' does not match model '" &
// char (model_name) // "' in SLHA input file.")
return
end select
case ("NMSSM")
select case (char (model%get_name ()))
case ("NMSSM","NMSSM_CKM","NMSSM_Hgg")
model_name = model%get_name ()
case default
call msg_fatal ("Selected model '" &
// char (model%get_name ()) // "' does not match model '" &
// char (model_name) // "' in SLHA input file.")
return
end select
case default
call msg_bug ("SLHA model name '" &
// char (model_name) // "' not recognized.")
return
end select
call msg_message ("SLHA: Initializing model '" // char (model_name) // "'")
end subroutine slha_handle_MODSEL
@ %def slha_handle_MODSEL
@ Write a MODSEL block, based on the contents of the current model.
<<SLHA: procedures>>=
subroutine slha_write_MODSEL (u, model, mssm_type)
integer, intent(in) :: u
type(model_t), intent(in), target :: model
integer, intent(out) :: mssm_type
type(var_list_t), pointer :: var_list
integer :: model_id
type(string_t) :: mtype_string
var_list => model%get_var_list_ptr ()
if (var_list%contains (var_str ("mtype"))) then
mssm_type = nint (var_list%get_rval (var_str ("mtype")))
else
call msg_error ("SLHA: parameter 'mtype' (SUSY breaking scheme) " &
// "is unknown in current model, no SLHA output possible")
mssm_type = -1
return
end if
call write_block_header (u, "MODSEL", "SUSY model selection")
select case (mssm_type)
case (0); mtype_string = "Generic MSSM"
case (1); mtype_string = "SUGRA"
case (2); mtype_string = "GMSB"
case (3); mtype_string = "AMSB"
case default
mtype_string = "unknown"
end select
call write_integer_parameter (u, 1, mssm_type, &
"SUSY-breaking scheme: " // char (mtype_string))
select case (char (model%get_name ()))
case ("MSSM"); model_id = MDL_MSSM
case ("NMSSM"); model_id = MDL_NMSSM
case default
model_id = 0
end select
call write_integer_parameter (u, 3, model_id, &
"SUSY model type: " // char (model%get_name ()))
end subroutine slha_write_MODSEL
@ %def slha_write_MODSEL
@
\subsubsection{SMINPUTS}
Read SM parameters and update the variable list accordingly. If a
parameter is not defined in the block, we use the previous value from
the model variable list. For the basic parameters we have to do a
small recalculation, since SLHA uses the $G_F$-$\alpha$-$m_Z$ scheme,
while \whizard\ derives them from $G_F$, $m_W$, and $m_Z$.
<<SLHA: procedures>>=
subroutine slha_handle_SMINPUTS (parse_tree, model)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_block
real(default) :: alpha_em_i, GF, alphas, mZ
real(default) :: ee, vv, cw_sw, cw2, mW
real(default) :: mb, mtop, mtau
type(var_list_t), pointer :: var_list
var_list => model%get_var_list_ptr ()
pn_block => slha_get_block_ptr &
(parse_tree, var_str ("SMINPUTS"), required=.true.)
if (.not. (associated (pn_block))) return
alpha_em_i = &
get_parameter_in_block (pn_block, 1, var_str ("alpha_em_i"), var_list)
GF = get_parameter_in_block (pn_block, 2, var_str ("GF"), var_list)
alphas = &
get_parameter_in_block (pn_block, 3, var_str ("alphas"), var_list)
mZ = get_parameter_in_block (pn_block, 4, var_str ("mZ"), var_list)
mb = get_parameter_in_block (pn_block, 5, var_str ("mb"), var_list)
mtop = get_parameter_in_block (pn_block, 6, var_str ("mtop"), var_list)
mtau = get_parameter_in_block (pn_block, 7, var_str ("mtau"), var_list)
ee = sqrt (4 * pi / alpha_em_i)
vv = 1 / sqrt (sqrt (2._default) * GF)
cw_sw = ee * vv / (2 * mZ)
if (2*cw_sw <= 1) then
cw2 = (1 + sqrt (1 - 4 * cw_sw**2)) / 2
mW = mZ * sqrt (cw2)
call var_list%set_real (var_str ("GF"), GF, .true.)
call var_list%set_real (var_str ("mZ"), mZ, .true.)
call var_list%set_real (var_str ("mW"), mW, .true.)
call var_list%set_real (var_str ("mtau"), mtau, .true.)
call var_list%set_real (var_str ("mb"), mb, .true.)
call var_list%set_real (var_str ("mtop"), mtop, .true.)
call var_list%set_real (var_str ("alphas"), alphas, .true.)
else
call msg_fatal ("SLHA: Unphysical SM parameter values")
return
end if
end subroutine slha_handle_SMINPUTS
@ %def slha_handle_SMINPUTS
@ Write a SMINPUTS block.
<<SLHA: procedures>>=
subroutine slha_write_SMINPUTS (u, model)
integer, intent(in) :: u
type(model_t), intent(in), target :: model
type(var_list_t), pointer :: var_list
var_list => model%get_var_list_ptr ()
call write_block_header (u, "SMINPUTS", "SM input parameters")
call write_real_data_item (u, 1, var_str ("alpha_em_i"), var_list, &
"Inverse electromagnetic coupling alpha (Z pole)")
call write_real_data_item (u, 2, var_str ("GF"), var_list, &
"Fermi constant")
call write_real_data_item (u, 3, var_str ("alphas"), var_list, &
"Strong coupling alpha_s (Z pole)")
call write_real_data_item (u, 4, var_str ("mZ"), var_list, &
"Z mass")
call write_real_data_item (u, 5, var_str ("mb"), var_list, &
"b running mass (at mb)")
call write_real_data_item (u, 6, var_str ("mtop"), var_list, &
"top mass")
call write_real_data_item (u, 7, var_str ("mtau"), var_list, &
"tau mass")
end subroutine slha_write_SMINPUTS
@ %def slha_write_SMINPUTS
@
\subsubsection{MINPAR}
The block of SUSY input parameters. They are accessible to WHIZARD,
but they only get used when an external spectrum generator is
invoked. The precise set of parameters depends on the type of SUSY
breaking, which by itself is one of the parameters.
<<SLHA: procedures>>=
subroutine slha_handle_MINPAR (parse_tree, model, mssm_type)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
integer, intent(in) :: mssm_type
type(var_list_t), pointer :: var_list
type(parse_node_t), pointer :: pn_block
var_list => model%get_var_list_ptr ()
call var_list%set_real &
(var_str ("mtype"), real(mssm_type, default), is_known=.true.)
pn_block => slha_get_block_ptr &
(parse_tree, var_str ("MINPAR"), required=.true.)
select case (mssm_type)
case (MSSM_SUGRA)
call set_data_item (pn_block, 1, var_str ("m_zero"), var_list)
call set_data_item (pn_block, 2, var_str ("m_half"), var_list)
call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
call set_data_item (pn_block, 5, var_str ("A0"), var_list)
case (MSSM_GMSB)
call set_data_item (pn_block, 1, var_str ("Lambda"), var_list)
call set_data_item (pn_block, 2, var_str ("M_mes"), var_list)
call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
call set_data_item (pn_block, 5, var_str ("N_5"), var_list)
call set_data_item (pn_block, 6, var_str ("c_grav"), var_list)
case (MSSM_AMSB)
call set_data_item (pn_block, 1, var_str ("m_zero"), var_list)
call set_data_item (pn_block, 2, var_str ("m_grav"), var_list)
call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list)
case default
call set_data_item (pn_block, 3, var_str ("tanb"), var_list)
end select
end subroutine slha_handle_MINPAR
@ %def slha_handle_MINPAR
@ Write a MINPAR block as appropriate for the current model type.
<<SLHA: procedures>>=
subroutine slha_write_MINPAR (u, model, mssm_type)
integer, intent(in) :: u
type(model_t), intent(in), target :: model
integer, intent(in) :: mssm_type
type(var_list_t), pointer :: var_list
var_list => model%get_var_list_ptr ()
call write_block_header (u, "MINPAR", "Basic SUSY input parameters")
select case (mssm_type)
case (MSSM_SUGRA)
call write_real_data_item (u, 1, var_str ("m_zero"), var_list, &
"Common scalar mass")
call write_real_data_item (u, 2, var_str ("m_half"), var_list, &
"Common gaugino mass")
call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
"tan(beta)")
call write_integer_data_item (u, 4, &
var_str ("sgn_mu"), var_list, &
"Sign of mu")
call write_real_data_item (u, 5, var_str ("A0"), var_list, &
"Common trilinear coupling")
case (MSSM_GMSB)
call write_real_data_item (u, 1, var_str ("Lambda"), var_list, &
"Soft-breaking scale")
call write_real_data_item (u, 2, var_str ("M_mes"), var_list, &
"Messenger scale")
call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
"tan(beta)")
call write_integer_data_item (u, 4, &
var_str ("sgn_mu"), var_list, &
"Sign of mu")
call write_integer_data_item (u, 5, var_str ("N_5"), var_list, &
"Messenger index")
call write_real_data_item (u, 6, var_str ("c_grav"), var_list, &
"Gravitino mass factor")
case (MSSM_AMSB)
call write_real_data_item (u, 1, var_str ("m_zero"), var_list, &
"Common scalar mass")
call write_real_data_item (u, 2, var_str ("m_grav"), var_list, &
"Gravitino mass")
call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
"tan(beta)")
call write_integer_data_item (u, 4, &
var_str ("sgn_mu"), var_list, &
"Sign of mu")
case default
call write_real_data_item (u, 3, var_str ("tanb"), var_list, &
"tan(beta)")
end select
end subroutine slha_write_MINPAR
@ %def slha_write_MINPAR
@
\subsubsection{Mass spectrum}
Set masses. Since the particles are identified by PDG code, read
the line and try to set the appropriate particle mass in the current
model. At the end, update parameters, just in case the $W$ or $Z$
mass was included.
<<SLHA: procedures>>=
subroutine slha_handle_MASS (parse_tree, model)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_block, pn_data, pn_line, pn_code
type(parse_node_t), pointer :: pn_mass
integer :: pdg
real(default) :: mass
pn_block => slha_get_block_ptr &
(parse_tree, var_str ("MASS"), required=.true.)
if (.not. (associated (pn_block))) return
pn_data => parse_node_get_sub_ptr (pn_block, 4)
do while (associated (pn_data))
pn_line => parse_node_get_sub_ptr (pn_data, 2)
pn_code => parse_node_get_sub_ptr (pn_line)
if (associated (pn_code)) then
pdg = get_integer_parameter (pn_code)
pn_mass => parse_node_get_next_ptr (pn_code)
if (associated (pn_mass)) then
mass = get_real_parameter (pn_mass)
call model%set_field_mass (pdg, mass)
else
call msg_error ("SLHA: Block MASS: Missing mass value")
end if
else
call msg_error ("SLHA: Block MASS: Missing PDG code")
end if
pn_data => parse_node_get_next_ptr (pn_data)
end do
end subroutine slha_handle_MASS
@ %def slha_handle_MASS
@
\subsubsection{Widths}
Set widths. For each DECAY block, extract the header, read the PDG
code and width, and try to set the appropriate particle width in the
current model.
<<SLHA: procedures>>=
subroutine slha_handle_decays (parse_tree, model)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_decay, pn_decay_spec, pn_code, pn_width
integer :: pdg
real(default) :: width
pn_decay => slha_get_first_decay_ptr (parse_tree)
do while (associated (pn_decay))
pn_decay_spec => parse_node_get_sub_ptr (pn_decay, 2)
pn_code => parse_node_get_sub_ptr (pn_decay_spec)
pdg = get_integer_parameter (pn_code)
pn_width => parse_node_get_next_ptr (pn_code)
width = get_real_parameter (pn_width)
call model%set_field_width (pdg, width)
pn_decay => slha_get_next_decay_ptr (pn_decay)
end do
end subroutine slha_handle_decays
@ %def slha_handle_decays
@
\subsubsection{Mixing matrices}
Read mixing matrices. We can treat all matrices by a single
procedure if we just know the block name, variable prefix, and matrix
dimension. The matrix dimension must be less than 10.
For the pseudoscalar Higgses in NMSSM-type models we need off-diagonal
matrices, so we generalize the definition.
<<SLHA: procedures>>=
subroutine slha_handle_matrix_block &
(parse_tree, block_name, var_prefix, dim1, dim2, model)
type(parse_tree_t), intent(in) :: parse_tree
character(*), intent(in) :: block_name, var_prefix
integer, intent(in) :: dim1, dim2
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_block
type(var_list_t), pointer :: var_list
integer :: i, j
character(len=len(var_prefix)+2) :: var_name
var_list => model%get_var_list_ptr ()
pn_block => slha_get_block_ptr &
(parse_tree, var_str (block_name), required=.false.)
if (.not. (associated (pn_block))) return
do i = 1, dim1
do j = 1, dim2
write (var_name, "(A,I1,I1)") var_prefix, i, j
call set_matrix_element (pn_block, i, j, var_str (var_name), var_list)
end do
end do
end subroutine slha_handle_matrix_block
@ %def slha_handle_matrix_block
@
\subsubsection{Higgs data}
Read the block ALPHA which holds just the Higgs mixing angle.
<<SLHA: procedures>>=
subroutine slha_handle_ALPHA (parse_tree, model)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_block, pn_line, pn_data, pn_item
type(var_list_t), pointer :: var_list
real(default) :: al_h
var_list => model%get_var_list_ptr ()
pn_block => slha_get_block_ptr &
(parse_tree, var_str ("ALPHA"), required=.false.)
if (.not. (associated (pn_block))) return
pn_data => parse_node_get_sub_ptr (pn_block, 4)
pn_line => parse_node_get_sub_ptr (pn_data, 2)
pn_item => parse_node_get_sub_ptr (pn_line)
if (associated (pn_item)) then
al_h = get_real_parameter (pn_item)
call var_list%set_real (var_str ("al_h"), al_h, &
is_known=.true., ignore=.true.)
end if
end subroutine slha_handle_ALPHA
@ %def slha_handle_matrix_block
@ Read the block HMIX for the Higgs mixing parameters
<<SLHA: procedures>>=
subroutine slha_handle_HMIX (parse_tree, model)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_block
type(var_list_t), pointer :: var_list
var_list => model%get_var_list_ptr ()
pn_block => slha_get_block_ptr &
(parse_tree, var_str ("HMIX"), required=.false.)
if (.not. (associated (pn_block))) return
call set_data_item (pn_block, 1, var_str ("mu_h"), var_list)
call set_data_item (pn_block, 2, var_str ("tanb_h"), var_list)
end subroutine slha_handle_HMIX
@ %def slha_handle_HMIX
@ Read the block NMSSMRUN for the specific NMSSM parameters
<<SLHA: procedures>>=
subroutine slha_handle_NMSSMRUN (parse_tree, model)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_block
type(var_list_t), pointer :: var_list
var_list => model%get_var_list_ptr ()
pn_block => slha_get_block_ptr &
(parse_tree, var_str ("NMSSMRUN"), required=.false.)
if (.not. (associated (pn_block))) return
call set_data_item (pn_block, 1, var_str ("ls"), var_list)
call set_data_item (pn_block, 2, var_str ("ks"), var_list)
call set_data_item (pn_block, 3, var_str ("a_ls"), var_list)
call set_data_item (pn_block, 4, var_str ("a_ks"), var_list)
call set_data_item (pn_block, 5, var_str ("nmu"), var_list)
end subroutine slha_handle_NMSSMRUN
@ %def slha_handle_NMSSMRUN
@
\subsection{Parsing custom SLHA files}
With the introduction of UFO models, we support custom files in
generic SLHA format that reset model parameters. In contrast to
strict SLHA files, the order and naming of blocks is arbitrary.
We scan the complete file (i.e., preprocessed parse tree), parsing all
blocks that contain data lines. For each data line, we identify index
array and associated value. Then we set the model parameter
that is associated with that block name and index array, if it exists.
<<SLHA: procedures>>=
subroutine slha_handle_custom_file (parse_tree, model)
type(parse_tree_t), intent(in) :: parse_tree
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_root, pn_block
type(parse_node_t), pointer :: pn_block_spec, pn_block_name
type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item
type(string_t) :: block_name
integer, dimension(:), allocatable :: block_index
integer :: n_index, i
real(default) :: value
pn_root => parse_tree%get_root_ptr ()
pn_block => pn_root%get_sub_ptr ()
HANDLE_BLOCKS: do while (associated (pn_block))
select case (char (pn_block%get_rule_key ()))
case ("block_def")
call slha_handle_custom_block (pn_block, model)
end select
pn_block => pn_block%get_next_ptr ()
end do HANDLE_BLOCKS
end subroutine slha_handle_custom_file
@ %def slha_handle_custom_file
@
<<SLHA: procedures>>=
subroutine slha_handle_custom_block (pn_block, model)
type(parse_node_t), intent(in), target :: pn_block
type(model_t), intent(inout), target :: model
type(parse_node_t), pointer :: pn_block_spec, pn_block_name
type(parse_node_t), pointer :: pn_data, pn_line, pn_code, pn_item
type(string_t) :: block_name
integer, dimension(:), allocatable :: block_index
integer :: n_index, i
real(default) :: value
pn_block_spec => parse_node_get_sub_ptr (pn_block, 2)
pn_block_name => parse_node_get_sub_ptr (pn_block_spec)
select case (char (parse_node_get_rule_key (pn_block_name)))
case ("block_name")
block_name = trim (adjustl (upper_case (pn_block_name%get_string ())))
case ("QNUMBERS")
block_name = "QNUMBERS"
end select
call demangle_keywords (block_name)
pn_data => pn_block%get_sub_ptr (4)
HANDLE_LINES: do while (associated (pn_data))
select case (char (pn_data%get_rule_key ()))
case ("block_data")
pn_line => pn_data%get_sub_ptr (2)
n_index = pn_line%get_n_sub () - 1
allocate (block_index (n_index))
pn_code => pn_line%get_sub_ptr ()
READ_LINE: do i = 1, n_index
select case (char (pn_code%get_rule_key ()))
case ("integer"); block_index(i) = pn_code%get_integer ()
case default
pn_code => null ()
exit READ_LINE
end select
pn_code => pn_code%get_next_ptr ()
end do READ_LINE
if (associated (pn_code)) then
value = get_real_parameter (pn_code)
call model%slha_set_par (block_name, block_index, value)
end if
deallocate (block_index)
end select
pn_data => pn_data%get_next_ptr ()
end do HANDLE_LINES
end subroutine slha_handle_custom_block
@ %def slha_handle_custom_block
@
\subsection{Parser}
Read a SLHA file from stream, including preprocessing, and make up a
parse tree.
<<SLHA: procedures>>=
subroutine slha_parse_stream (stream, custom_block_name, parse_tree)
type(stream_t), intent(inout), target :: stream
type(string_t), dimension(:), intent(in) :: custom_block_name
type(parse_tree_t), intent(out) :: parse_tree
type(ifile_t) :: ifile
type(lexer_t) :: lexer
type(stream_t), target :: stream_tmp
call slha_preprocess (stream, custom_block_name, ifile)
call stream_init (stream_tmp, ifile)
call lexer_init_slha (lexer)
call lexer_assign_stream (lexer, stream_tmp)
call parse_tree_init (parse_tree, syntax_slha, lexer)
call lexer_final (lexer)
call stream_final (stream_tmp)
call ifile_final (ifile)
end subroutine slha_parse_stream
@ %def slha_parse_stream
@ Read a SLHA file chosen by name. Check first the current directory,
then the directory where SUSY input files should be located.
The [[default_mode]] applies to unknown blocks in the SLHA file: this
is either [[MODE_SKIP]] or [[MODE_DATA]], corresponding to genuine
SUSY and custom file content, respectively.
<<SLHA: public>>=
public :: slha_parse_file
<<SLHA: procedures>>=
subroutine slha_parse_file (file, custom_block_name, os_data, parse_tree)
type(string_t), intent(in) :: file
type(string_t), dimension(:), intent(in) :: custom_block_name
type(os_data_t), intent(in) :: os_data
type(parse_tree_t), intent(out) :: parse_tree
logical :: exist
type(string_t) :: filename
type(stream_t), target :: stream
call msg_message ("Reading SLHA input file '" // char (file) // "'")
filename = file
inquire (file=char(filename), exist=exist)
if (.not. exist) then
filename = os_data%whizard_susypath // "/" // file
inquire (file=char(filename), exist=exist)
if (.not. exist) then
call msg_fatal ("SLHA input file '" // char (file) // "' not found")
return
end if
end if
call stream_init (stream, char (filename))
call slha_parse_stream (stream, custom_block_name, parse_tree)
call stream_final (stream)
end subroutine slha_parse_file
@ %def slha_parse_file
@
\subsection{API}
Read the SLHA file, parse it, and interpret the parse tree. The model
parameters retrieved from the file will be inserted into the
appropriate model, which is loaded and modified in the background.
The pointer to this model is returned as the last argument.
<<SLHA: public>>=
public :: slha_read_file
<<SLHA: procedures>>=
subroutine slha_read_file &
(file, os_data, model, input, spectrum, decays)
type(string_t), intent(in) :: file
type(os_data_t), intent(in) :: os_data
type(model_t), intent(inout), target :: model
logical, intent(in) :: input, spectrum, decays
type(string_t), dimension(:), allocatable :: custom_block_name
type(parse_tree_t) :: parse_tree
call model%get_custom_slha_blocks (custom_block_name)
call slha_parse_file (file, custom_block_name, os_data, parse_tree)
if (associated (parse_tree%get_root_ptr ())) then
call slha_interpret_parse_tree &
(parse_tree, model, input, spectrum, decays)
call parse_tree_final (parse_tree)
call model%update_parameters ()
end if
end subroutine slha_read_file
@ %def slha_read_file
@ Write the SLHA contents, as far as possible, to external file.
<<SLHA: public>>=
public :: slha_write_file
<<SLHA: procedures>>=
subroutine slha_write_file (file, model, input, spectrum, decays)
type(string_t), intent(in) :: file
type(model_t), target, intent(in) :: model
logical, intent(in) :: input, spectrum, decays
integer :: mssm_type
integer :: u
u = free_unit ()
call msg_message ("Writing SLHA output file '" // char (file) // "'")
open (unit=u, file=char(file), action="write", status="replace")
write (u, "(A)") "# SUSY Les Houches Accord"
write (u, "(A)") "# Output generated by " // trim (VERSION_STRING)
call slha_write_MODSEL (u, model, mssm_type)
if (input) then
call slha_write_SMINPUTS (u, model)
call slha_write_MINPAR (u, model, mssm_type)
end if
if (spectrum) then
call msg_bug ("SLHA: spectrum output not supported yet")
end if
if (decays) then
call msg_bug ("SLHA: decays output not supported yet")
end if
close (u)
end subroutine slha_write_file
@ %def slha_write_file
@
\subsection{Dispatch}
<<SLHA: public>>=
public :: dispatch_slha
<<SLHA: procedures>>=
subroutine dispatch_slha (var_list, input, spectrum, decays)
type(var_list_t), intent(inout), target :: var_list
logical, intent(out) :: input, spectrum, decays
input = var_list%get_lval (var_str ("?slha_read_input"))
spectrum = var_list%get_lval (var_str ("?slha_read_spectrum"))
decays = var_list%get_lval (var_str ("?slha_read_decays"))
end subroutine dispatch_slha
@ %def dispatch_slha
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[slha_interface_ut.f90]]>>=
<<File header>>
module slha_interface_ut
use unit_tests
use slha_interface_uti
<<Standard module head>>
<<SLHA: public test>>
contains
<<SLHA: test driver>>
end module slha_interface_ut
@ %def slha_interface_ut
@
<<[[slha_interface_uti.f90]]>>=
<<File header>>
module slha_interface_uti
<<Use strings>>
use io_units
use os_interface
use parser
use model_data
use variables
use models
use slha_interface
<<Standard module head>>
<<SLHA: test declarations>>
contains
<<SLHA: tests>>
end module slha_interface_uti
@ %def slha_interface_ut
@ API: driver for the unit tests below.
<<SLHA: public test>>=
public :: slha_test
<<SLHA: test driver>>=
subroutine slha_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<SLHA: execute tests>>
end subroutine slha_test
@ %def slha_test
@ Checking the basics of the SLHA interface.
<<SLHA: execute tests>>=
call test (slha_1, "slha_1", &
"check SLHA interface", &
u, results)
<<SLHA: test declarations>>=
public :: slha_1
<<SLHA: tests>>=
subroutine slha_1 (u)
integer, intent(in) :: u
type(os_data_t), pointer :: os_data => null ()
type(parse_tree_t), pointer :: parse_tree => null ()
integer :: u_file, iostat
character(80) :: buffer
character(*), parameter :: file_slha = "slha_test.dat"
type(model_list_t) :: model_list
type(model_t), pointer :: model => null ()
type(string_t), dimension(0) :: empty_string_array
write (u, "(A)") "* Test output: SLHA Interface"
write (u, "(A)") "* Purpose: test SLHA file reading and writing"
write (u, "(A)")
write (u, "(A)") "* Initializing"
write (u, "(A)")
allocate (os_data)
allocate (parse_tree)
call os_data%init ()
call syntax_model_file_init ()
call model_list%read_model &
(var_str("MSSM"), var_str("MSSM.mdl"), os_data, model)
call syntax_slha_init ()
write (u, "(A)") "* Reading SLHA file sps1ap_decays.slha"
write (u, "(A)")
call slha_parse_file (var_str ("sps1ap_decays.slha"), &
empty_string_array, os_data, parse_tree)
write (u, "(A)") "* Writing the parse tree:"
write (u, "(A)")
call parse_tree_write (parse_tree, u)
write (u, "(A)") "* Interpreting the parse tree"
write (u, "(A)")
call slha_interpret_parse_tree (parse_tree, model, &
input=.true., spectrum=.true., decays=.true.)
call parse_tree_final (parse_tree)
write (u, "(A)") "* Writing out the list of variables (reals only):"
write (u, "(A)")
call var_list_write (model%get_var_list_ptr (), &
only_type = V_REAL, unit = u)
write (u, "(A)")
write (u, "(A)") "* Writing SLHA output to '" // file_slha // "'"
write (u, "(A)")
call slha_write_file (var_str (file_slha), model, input=.true., &
spectrum=.false., decays=.false.)
u_file = free_unit ()
open (u_file, file = file_slha, action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:37) == "# Output generated by WHIZARD version") then
buffer = "[...]"
end if
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
write (u, "(A)")
call parse_tree_final (parse_tree)
deallocate (parse_tree)
deallocate (os_data)
write (u, "(A)") "* Test output end: slha_1"
write (u, "(A)")
end subroutine slha_1
@ %def slha_1
@
\subsubsection{SLHA interface}
This rather trivial sets all input values for the SLHA interface
to [[false]].
<<SLHA: execute tests>>=
call test (slha_2, "slha_2", &
"SLHA interface", &
u, results)
<<SLHA: test declarations>>=
public :: slha_2
<<SLHA: tests>>=
subroutine slha_2 (u)
integer, intent(in) :: u
type(var_list_t) :: var_list
logical :: input, spectrum, decays
write (u, "(A)") "* Test output: slha_2"
write (u, "(A)") "* Purpose: SLHA interface settings"
write (u, "(A)")
write (u, "(A)") "* Default settings"
write (u, "(A)")
call var_list%init_defaults (0)
call dispatch_slha (var_list, &
input = input, spectrum = spectrum, decays = decays)
write (u, "(A,1x,L1)") " slha_read_input =", input
write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum
write (u, "(A,1x,L1)") " slha_read_decays =", decays
call var_list%final ()
call var_list%init_defaults (0)
write (u, "(A)")
write (u, "(A)") "* Set all entries to [false]"
write (u, "(A)")
call var_list%set_log (var_str ("?slha_read_input"), &
.false., is_known = .true.)
call var_list%set_log (var_str ("?slha_read_spectrum"), &
.false., is_known = .true.)
call var_list%set_log (var_str ("?slha_read_decays"), &
.false., is_known = .true.)
call dispatch_slha (var_list, &
input = input, spectrum = spectrum, decays = decays)
write (u, "(A,1x,L1)") " slha_read_input =", input
write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum
write (u, "(A,1x,L1)") " slha_read_decays =", decays
call var_list%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: slha_2"
end subroutine slha_2
@ %def slha_2