Page MenuHomeHEPForge
Files F7877976

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
Index: trunk/src/events/events.nw
===================================================================
--- trunk/src/events/events.nw (revision 8177)
+++ trunk/src/events/events.nw (revision 8178)
@@ -1,16360 +1,16364 @@
%% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD code as NOWEB source: event handling objects
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Generic Event Handling}
\includemodulegraph{events}
Event records allow the MC to communicate with the outside world. The
event record should exhibit the observable contents of a physical
event. We should be able to read and write events. The actual
implementation of the event need not be defined yet, for that purpose.
We have the following basic modules:
\begin{description}
\item[event\_base]
Abstract base type for event records. The base type contains a
reference to a [[particle_set_t]] object as the event core, and it
holds some data that we should always expect, such as the squared
matrix element and event weight.
\item[eio\_data]
Transparent container for the metadata of an event sample.
\item[eio\_base]
Abstract base type for event-record input and output. The
implementations of this base type represent specific event I/O
formats.
\end{description}
These are the implementation modules:
\begin{description}
\item[eio\_checkpoints]
Auxiliary output format. The only purpose is to provide screen
diagnostics during event output.
\item[eio\_callback]
Auxiliary output format. The only purpose is to execute a callback
procedure, so we have a hook for external access during event output.
\item[eio\_weights]
Print some event summary data, no details. The main use if for
testing purposes.
\item[eio\_dump]
Dump the contents of WHIZARD's [[particle_set]] internal record,
using the [[write]] method of that record as-is. The main use if for
testing purposes.
\item[hep\_common]
Implements traditional HEP common blocks that are (still) used by
some of the event I/O formats below.
\item[hepmc\_interface]
Access particle objects of the HepMC package. Functional only if this
package is linked.
\item[lcio\_interface]
Access objects of the LCIO package. Functional only if this
package is linked.
\item[hep\_events]
Interface between the event record and the common blocks.
\item[eio\_ascii]
Collection of event output formats that write ASCII files.
\item[eio\_lhef]
LHEF for input and output.
\item[eio\_stdhep]
Support for the StdHEP format (binary, machine-independent).
\item[eio\_hepmc]
Support for the HepMC format (C++).
\item[eio\_lcio]
Support for the LCIO format (C++).
\end{description}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Generic Event Handling}
We introduce events first in form of an abstract type, together with
some utilities. Abstract events can be used by other modules, in
particular event I/O, without introducing an explicit dependency on
the event implementation.
<<[[event_base.f90]]>>=
<<File header>>
module event_base
<<Use kinds>>
use kinds, only: i64
<<Use strings>>
use io_units
use string_utils, only: lower_case
use diagnostics
use model_data
use particles
<<Standard module head>>
<<Event base: public>>
<<Event base: parameters>>
<<Event base: types>>
<<Event base: interfaces>>
contains
<<Event base: procedures>>
end module event_base
@ %def event_base
@
\subsection{generic event type}
<<Event base: public>>=
public :: generic_event_t
<<Event base: types>>=
type, abstract :: generic_event_t
!private
logical :: particle_set_is_valid = .false.
type(particle_set_t), pointer :: particle_set => null ()
logical :: sqme_ref_known = .false.
real(default) :: sqme_ref = 0
logical :: sqme_prc_known = .false.
real(default) :: sqme_prc = 0
logical :: weight_ref_known = .false.
real(default) :: weight_ref = 0
logical :: weight_prc_known = .false.
real(default) :: weight_prc = 0
logical :: excess_prc_known = .false.
real(default) :: excess_prc = 0
integer :: n_alt = 0
logical :: sqme_alt_known = .false.
real(default), dimension(:), allocatable :: sqme_alt
logical :: weight_alt_known = .false.
real(default), dimension(:), allocatable :: weight_alt
contains
<<Event base: generic event: TBP>>
end type generic_event_t
@ %def generic_event_t
@
\subsection{Initialization}
This determines the number of alternate weights and sqme values.
<<Event base: generic event: TBP>>=
procedure :: base_init => generic_event_init
<<Event base: procedures>>=
subroutine generic_event_init (event, n_alt)
class(generic_event_t), intent(out) :: event
integer, intent(in) :: n_alt
event%n_alt = n_alt
allocate (event%sqme_alt (n_alt))
allocate (event%weight_alt (n_alt))
end subroutine generic_event_init
@ %def generic_event_init
@
\subsection{Access particle set}
The particle set is the core of the event. We allow access to it via
a pointer, and we maintain the information whether the particle set
is valid, i.e., has been filled with meaningful data.
<<Event base: generic event: TBP>>=
procedure :: has_valid_particle_set => generic_event_has_valid_particle_set
procedure :: accept_particle_set => generic_event_accept_particle_set
procedure :: discard_particle_set => generic_event_discard_particle_set
<<Event base: procedures>>=
function generic_event_has_valid_particle_set (event) result (flag)
class(generic_event_t), intent(in) :: event
logical :: flag
flag = event%particle_set_is_valid
end function generic_event_has_valid_particle_set
subroutine generic_event_accept_particle_set (event)
class(generic_event_t), intent(inout) :: event
event%particle_set_is_valid = .true.
end subroutine generic_event_accept_particle_set
subroutine generic_event_discard_particle_set (event)
class(generic_event_t), intent(inout) :: event
event%particle_set_is_valid = .false.
end subroutine generic_event_discard_particle_set
@ %def generic_event_has_valid_particle_set
@ %def generic_event_accept_particle_set
@ %def generic_event_discard_particle_set
@
These procedures deal with the particle set directly. Return the pointer:
<<Event base: generic event: TBP>>=
procedure :: get_particle_set_ptr => generic_event_get_particle_set_ptr
<<Event base: procedures>>=
function generic_event_get_particle_set_ptr (event) result (ptr)
class(generic_event_t), intent(in) :: event
type(particle_set_t), pointer :: ptr
ptr => event%particle_set
end function generic_event_get_particle_set_ptr
@ %def generic_event_get_particle_set_ptr
@
Let it point to some existing particle set:
<<Event base: generic event: TBP>>=
procedure :: link_particle_set => generic_event_link_particle_set
<<Event base: procedures>>=
subroutine generic_event_link_particle_set (event, particle_set)
class(generic_event_t), intent(inout) :: event
type(particle_set_t), intent(in), target :: particle_set
event%particle_set => particle_set
call event%accept_particle_set ()
end subroutine generic_event_link_particle_set
@ %def generic_event_link_particle_set
@
\subsection{Access sqme and weight}
There are several incarnations: the current value, a reference value,
alternate values.
<<Event base: generic event: TBP>>=
procedure :: sqme_prc_is_known => generic_event_sqme_prc_is_known
procedure :: sqme_ref_is_known => generic_event_sqme_ref_is_known
procedure :: sqme_alt_is_known => generic_event_sqme_alt_is_known
procedure :: weight_prc_is_known => generic_event_weight_prc_is_known
procedure :: weight_ref_is_known => generic_event_weight_ref_is_known
procedure :: weight_alt_is_known => generic_event_weight_alt_is_known
procedure :: excess_prc_is_known => generic_event_excess_prc_is_known
<<Event base: procedures>>=
function generic_event_sqme_prc_is_known (event) result (flag)
class(generic_event_t), intent(in) :: event
logical :: flag
flag = event%sqme_prc_known
end function generic_event_sqme_prc_is_known
function generic_event_sqme_ref_is_known (event) result (flag)
class(generic_event_t), intent(in) :: event
logical :: flag
flag = event%sqme_ref_known
end function generic_event_sqme_ref_is_known
function generic_event_sqme_alt_is_known (event) result (flag)
class(generic_event_t), intent(in) :: event
logical :: flag
flag = event%sqme_alt_known
end function generic_event_sqme_alt_is_known
function generic_event_weight_prc_is_known (event) result (flag)
class(generic_event_t), intent(in) :: event
logical :: flag
flag = event%weight_prc_known
end function generic_event_weight_prc_is_known
function generic_event_weight_ref_is_known (event) result (flag)
class(generic_event_t), intent(in) :: event
logical :: flag
flag = event%weight_ref_known
end function generic_event_weight_ref_is_known
function generic_event_weight_alt_is_known (event) result (flag)
class(generic_event_t), intent(in) :: event
logical :: flag
flag = event%weight_alt_known
end function generic_event_weight_alt_is_known
function generic_event_excess_prc_is_known (event) result (flag)
class(generic_event_t), intent(in) :: event
logical :: flag
flag = event%excess_prc_known
end function generic_event_excess_prc_is_known
@ %def generic_event_sqme_prc_is_known
@ %def generic_event_sqme_ref_is_known
@ %def generic_event_sqme_alt_is_known
@ %def generic_event_weight_prc_is_known
@ %def generic_event_weight_ref_is_known
@ %def generic_event_weight_alt_is_known
@ %def generic_event_excess_prc_is_known
@
<<Event base: generic event: TBP>>=
procedure :: get_n_alt => generic_event_get_n_alt
<<Event base: procedures>>=
function generic_event_get_n_alt (event) result (n)
class(generic_event_t), intent(in) :: event
integer :: n
n = event%n_alt
end function generic_event_get_n_alt
@ %def generic_event_get_n_alt
@
<<Event base: generic event: TBP>>=
procedure :: get_sqme_prc => generic_event_get_sqme_prc
procedure :: get_sqme_ref => generic_event_get_sqme_ref
generic :: get_sqme_alt => &
generic_event_get_sqme_alt_0, generic_event_get_sqme_alt_1
procedure :: generic_event_get_sqme_alt_0
procedure :: generic_event_get_sqme_alt_1
procedure :: get_weight_prc => generic_event_get_weight_prc
procedure :: get_weight_ref => generic_event_get_weight_ref
generic :: get_weight_alt => &
generic_event_get_weight_alt_0, generic_event_get_weight_alt_1
procedure :: generic_event_get_weight_alt_0
procedure :: generic_event_get_weight_alt_1
procedure :: get_excess_prc => generic_event_get_excess_prc
<<Event base: procedures>>=
function generic_event_get_sqme_prc (event) result (sqme)
class(generic_event_t), intent(in) :: event
real(default) :: sqme
if (event%sqme_prc_known) then
sqme = event%sqme_prc
else
sqme = 0
end if
end function generic_event_get_sqme_prc
function generic_event_get_sqme_ref (event) result (sqme)
class(generic_event_t), intent(in) :: event
real(default) :: sqme
if (event%sqme_ref_known) then
sqme = event%sqme_ref
else
sqme = 0
end if
end function generic_event_get_sqme_ref
function generic_event_get_sqme_alt_0 (event, i) result (sqme)
class(generic_event_t), intent(in) :: event
integer, intent(in) :: i
real(default) :: sqme
if (event%sqme_alt_known) then
sqme = event%sqme_alt(i)
else
sqme = 0
end if
end function generic_event_get_sqme_alt_0
function generic_event_get_sqme_alt_1 (event) result (sqme)
class(generic_event_t), intent(in) :: event
real(default), dimension(event%n_alt) :: sqme
sqme = event%sqme_alt
end function generic_event_get_sqme_alt_1
function generic_event_get_weight_prc (event) result (weight)
class(generic_event_t), intent(in) :: event
real(default) :: weight
if (event%weight_prc_known) then
weight = event%weight_prc
else
weight = 0
end if
end function generic_event_get_weight_prc
function generic_event_get_weight_ref (event) result (weight)
class(generic_event_t), intent(in) :: event
real(default) :: weight
if (event%weight_ref_known) then
weight = event%weight_ref
else
weight = 0
end if
end function generic_event_get_weight_ref
function generic_event_get_weight_alt_0 (event, i) result (weight)
class(generic_event_t), intent(in) :: event
integer, intent(in) :: i
real(default) :: weight
if (event%weight_alt_known) then
weight = event%weight_alt(i)
else
weight = 0
end if
end function generic_event_get_weight_alt_0
function generic_event_get_weight_alt_1 (event) result (weight)
class(generic_event_t), intent(in) :: event
real(default), dimension(event%n_alt) :: weight
weight = event%weight_alt
end function generic_event_get_weight_alt_1
function generic_event_get_excess_prc (event) result (excess)
class(generic_event_t), intent(in) :: event
real(default) :: excess
if (event%excess_prc_known) then
excess = event%excess_prc
else
excess = 0
end if
end function generic_event_get_excess_prc
@ %def generic_event_get_sqme_prc
@ %def generic_event_get_sqme_ref
@ %def generic_event_get_sqme_alt
@ %def generic_event_get_weight_prc
@ %def generic_event_get_weight_ref
@ %def generic_event_get_weight_alt
@ %def generic_event_get_excess_prc
@
<<Event base: generic event: TBP>>=
procedure :: set_sqme_prc => generic_event_set_sqme_prc
procedure :: set_sqme_ref => generic_event_set_sqme_ref
procedure :: set_sqme_alt => generic_event_set_sqme_alt
procedure :: set_weight_prc => generic_event_set_weight_prc
procedure :: set_weight_ref => generic_event_set_weight_ref
procedure :: set_weight_alt => generic_event_set_weight_alt
procedure :: set_excess_prc => generic_event_set_excess_prc
<<Event base: procedures>>=
subroutine generic_event_set_sqme_prc (event, sqme)
class(generic_event_t), intent(inout) :: event
real(default), intent(in) :: sqme
event%sqme_prc = sqme
event%sqme_prc_known = .true.
end subroutine generic_event_set_sqme_prc
subroutine generic_event_set_sqme_ref (event, sqme)
class(generic_event_t), intent(inout) :: event
real(default), intent(in) :: sqme
event%sqme_ref = sqme
event%sqme_ref_known = .true.
end subroutine generic_event_set_sqme_ref
subroutine generic_event_set_sqme_alt (event, sqme)
class(generic_event_t), intent(inout) :: event
real(default), dimension(:), intent(in) :: sqme
event%sqme_alt = sqme
event%sqme_alt_known = .true.
end subroutine generic_event_set_sqme_alt
subroutine generic_event_set_weight_prc (event, weight)
class(generic_event_t), intent(inout) :: event
real(default), intent(in) :: weight
event%weight_prc = weight
event%weight_prc_known = .true.
end subroutine generic_event_set_weight_prc
subroutine generic_event_set_weight_ref (event, weight)
class(generic_event_t), intent(inout) :: event
real(default), intent(in) :: weight
event%weight_ref = weight
event%weight_ref_known = .true.
end subroutine generic_event_set_weight_ref
subroutine generic_event_set_weight_alt (event, weight)
class(generic_event_t), intent(inout) :: event
real(default), dimension(:), intent(in) :: weight
event%weight_alt = weight
event%weight_alt_known = .true.
end subroutine generic_event_set_weight_alt
subroutine generic_event_set_excess_prc (event, excess)
class(generic_event_t), intent(inout) :: event
real(default), intent(in) :: excess
event%excess_prc = excess
event%excess_prc_known = .true.
end subroutine generic_event_set_excess_prc
@ %def generic_event_set_sqme_prc
@ %def generic_event_set_sqme_ref
@ %def generic_event_set_sqme_alt
@ %def generic_event_set_weight_prc
@ %def generic_event_set_weight_ref
@ %def generic_event_set_weight_alt
@ %def generic_event_set_excess_prc
@
Set the appropriate entry directly.
<<Event base: generic event: TBP>>=
procedure :: set => generic_event_set
<<Event base: procedures>>=
subroutine generic_event_set (event, &
weight_ref, weight_prc, weight_alt, &
excess_prc, &
sqme_ref, sqme_prc, sqme_alt)
class(generic_event_t), intent(inout) :: event
real(default), intent(in), optional :: weight_ref, weight_prc
real(default), intent(in), optional :: sqme_ref, sqme_prc
real(default), dimension(:), intent(in), optional :: sqme_alt, weight_alt
real(default), intent(in), optional :: excess_prc
if (present (sqme_prc)) then
call event%set_sqme_prc (sqme_prc)
end if
if (present (sqme_ref)) then
call event%set_sqme_ref (sqme_ref)
end if
if (present (sqme_alt)) then
call event%set_sqme_alt (sqme_alt)
end if
if (present (weight_prc)) then
call event%set_weight_prc (weight_prc)
end if
if (present (weight_ref)) then
call event%set_weight_ref (weight_ref)
end if
if (present (weight_alt)) then
call event%set_weight_alt (weight_alt)
end if
if (present (excess_prc)) then
call event%set_excess_prc (excess_prc)
end if
end subroutine generic_event_set
@ %def generic_event_set
@
\subsection{Pure Virtual Methods}
These procedures can only implemented in the concrete implementation.
Output (verbose, depending on parameters).
<<Event base: generic event: TBP>>=
procedure (generic_event_write), deferred :: write
<<Event base: interfaces>>=
abstract interface
subroutine generic_event_write (object, unit, &
show_process, show_transforms, &
show_decay, verbose, testflag)
import
class(generic_event_t), intent(in) :: object
integer, intent(in), optional :: unit
logical, intent(in), optional :: show_process
logical, intent(in), optional :: show_transforms
logical, intent(in), optional :: show_decay
logical, intent(in), optional :: verbose
logical, intent(in), optional :: testflag
end subroutine generic_event_write
end interface
@ %def generic_event_write
@
Generate an event, based on a selector index [[i_mci]], and optionally on an
extra set of random numbers [[r]]. For the main bunch of random numbers that
the generator needs, the event object should contain its own generator.
<<Event base: generic event: TBP>>=
procedure (generic_event_generate), deferred :: generate
<<Event base: interfaces>>=
abstract interface
subroutine generic_event_generate (event, i_mci, r, i_nlo)
import
class(generic_event_t), intent(inout) :: event
integer, intent(in) :: i_mci
real(default), dimension(:), intent(in), optional :: r
integer, intent(in), optional :: i_nlo
end subroutine generic_event_generate
end interface
@ %def event_generate
@
Alternative : inject a particle set that is supposed to represent the hard
process.
How this determines the event, is dependent on the event structure,
therefore this is a deferred method.
<<Event base: generic event: TBP>>=
procedure (generic_event_set_hard_particle_set), deferred :: &
set_hard_particle_set
<<Event base: interfaces>>=
abstract interface
subroutine generic_event_set_hard_particle_set (event, particle_set)
import
class(generic_event_t), intent(inout) :: event
type(particle_set_t), intent(in) :: particle_set
end subroutine generic_event_set_hard_particle_set
end interface
@ %def generic_event_set_hard_particle_set
@ Event index handlers.
<<Event base: generic event: TBP>>=
procedure (generic_event_set_index), deferred :: set_index
procedure (generic_event_handler), deferred :: reset_index
procedure (generic_event_increment_index), deferred :: increment_index
@
<<Event base: interfaces>>=
abstract interface
subroutine generic_event_set_index (event, index)
import
class(generic_event_t), intent(inout) :: event
integer, intent(in) :: index
end subroutine generic_event_set_index
end interface
abstract interface
subroutine generic_event_handler (event)
import
class(generic_event_t), intent(inout) :: event
end subroutine generic_event_handler
end interface
abstract interface
subroutine generic_event_increment_index (event, offset)
import
class(generic_event_t), intent(inout) :: event
integer, intent(in), optional :: offset
end subroutine generic_event_increment_index
end interface
@ %def generic_event_set_index
@ %def generic_event_increment_index
@ %def generic_event_handler
@ Evaluate any expressions associated with the event. No argument needed.
<<Event base: generic event: TBP>>=
procedure (generic_event_handler), deferred :: evaluate_expressions
@
Select internal parameters
<<Event base: generic event: TBP>>=
procedure (generic_event_select), deferred :: select
<<Event base: interfaces>>=
abstract interface
subroutine generic_event_select (event, i_mci, i_term, channel)
import
class(generic_event_t), intent(inout) :: event
integer, intent(in) :: i_mci, i_term, channel
end subroutine generic_event_select
end interface
@ %def generic_event_select
@ Return a pointer to the model for the currently active process.
<<Event base: generic event: TBP>>=
procedure (generic_event_get_model_ptr), deferred :: get_model_ptr
<<Event base: interfaces>>=
abstract interface
function generic_event_get_model_ptr (event) result (model)
import
class(generic_event_t), intent(in) :: event
class(model_data_t), pointer :: model
end function generic_event_get_model_ptr
end interface
@ %def generic_event_get_model_ptr
@ Return data used by external event formats.
<<Event base: generic event: TBP>>=
procedure (generic_event_has_index), deferred :: has_index
procedure (generic_event_get_index), deferred :: get_index
procedure (generic_event_get_fac_scale), deferred :: get_fac_scale
procedure (generic_event_get_alpha_s), deferred :: get_alpha_s
procedure (generic_event_get_sqrts), deferred :: get_sqrts
procedure (generic_event_get_polarization), deferred :: get_polarization
procedure (generic_event_get_beam_file), deferred :: get_beam_file
procedure (generic_event_get_process_name), deferred :: &
get_process_name
<<Event base: interfaces>>=
abstract interface
function generic_event_has_index (event) result (flag)
import
class(generic_event_t), intent(in) :: event
logical :: flag
end function generic_event_has_index
end interface
abstract interface
function generic_event_get_index (event) result (index)
import
class(generic_event_t), intent(in) :: event
integer :: index
end function generic_event_get_index
end interface
abstract interface
function generic_event_get_fac_scale (event) result (fac_scale)
import
class(generic_event_t), intent(in) :: event
real(default) :: fac_scale
end function generic_event_get_fac_scale
end interface
abstract interface
function generic_event_get_alpha_s (event) result (alpha_s)
import
class(generic_event_t), intent(in) :: event
real(default) :: alpha_s
end function generic_event_get_alpha_s
end interface
abstract interface
function generic_event_get_sqrts (event) result (sqrts)
import
class(generic_event_t), intent(in) :: event
real(default) :: sqrts
end function generic_event_get_sqrts
end interface
abstract interface
function generic_event_get_polarization (event) result (pol)
import
class(generic_event_t), intent(in) :: event
real(default), dimension(2) :: pol
end function generic_event_get_polarization
end interface
abstract interface
function generic_event_get_beam_file (event) result (file)
import
class(generic_event_t), intent(in) :: event
type(string_t) :: file
end function generic_event_get_beam_file
end interface
abstract interface
function generic_event_get_process_name (event) result (name)
import
class(generic_event_t), intent(in) :: event
type(string_t) :: name
end function generic_event_get_process_name
end interface
@ %def generic_event_get_index
@ %def generic_event_get_fac_scale
@ %def generic_event_get_alpha_s
@ %def generic_event_get_sqrts
@ %def generic_event_get_polarization
@ %def generic_event_get_beam_file
@ %def generic_event_get_process_name
@ Set data used by external event formats.
<<Event base: generic event: TBP>>=
procedure (generic_event_set_alpha_qcd_forced), deferred :: &
set_alpha_qcd_forced
procedure (generic_event_set_scale_forced), deferred :: &
set_scale_forced
<<Event base: interfaces>>=
abstract interface
subroutine generic_event_set_alpha_qcd_forced (event, alpha_qcd)
import
class(generic_event_t), intent(inout) :: event
real(default), intent(in) :: alpha_qcd
end subroutine generic_event_set_alpha_qcd_forced
end interface
abstract interface
subroutine generic_event_set_scale_forced (event, scale)
import
class(generic_event_t), intent(inout) :: event
real(default), intent(in) :: scale
end subroutine generic_event_set_scale_forced
end interface
@ %def generic_event_set_alpha_qcd_forced
@ %def generic_event_set_scale_forced
@
\subsection{Utilities}
Applying this, current event contents are marked as incomplete but
are not deleted. In particular, the initialization is kept.
<<Event base: generic event: TBP>>=
procedure :: reset_contents => generic_event_reset_contents
procedure :: base_reset_contents => generic_event_reset_contents
<<Event base: procedures>>=
subroutine generic_event_reset_contents (event)
class(generic_event_t), intent(inout) :: event
call event%discard_particle_set ()
event%sqme_ref_known = .false.
event%sqme_prc_known = .false.
event%sqme_alt_known = .false.
event%weight_ref_known = .false.
event%weight_prc_known = .false.
event%weight_alt_known = .false.
event%excess_prc_known = .false.
end subroutine generic_event_reset_contents
@ %def generic_event_reset_contents
@ Pacify particle set.
<<Event base: generic event: TBP>>=
procedure :: pacify_particle_set => generic_event_pacify_particle_set
<<Event base: procedures>>=
subroutine generic_event_pacify_particle_set (event)
class(generic_event_t), intent(inout) :: event
if (event%has_valid_particle_set ()) call pacify (event%particle_set)
end subroutine generic_event_pacify_particle_set
@ %def generic_event_pacify_particle_set
@
\subsection{Event normalization}
The parameters for event normalization. For unweighted events,
[[NORM_UNIT]] is intended as default, while for weighted events, it is
[[NORM_SIGMA]].
Note: the unit test for this is in [[eio_data_2]] below.
<<Event base: parameters>>=
integer, parameter, public :: NORM_UNDEFINED = 0
integer, parameter, public :: NORM_UNIT = 1
integer, parameter, public :: NORM_N_EVT = 2
integer, parameter, public :: NORM_SIGMA = 3
integer, parameter, public :: NORM_S_N = 4
@ %def NORM_UNDEFINED NORM_UNIT NORM_N_EVT NORM_SIGMA NORM_S_N
@ These functions translate between the user representation and the
internal one.
<<Event base: public>>=
public :: event_normalization_mode
public :: event_normalization_string
<<Event base: procedures>>=
function event_normalization_mode (string, unweighted) result (mode)
integer :: mode
type(string_t), intent(in) :: string
logical, intent(in) :: unweighted
select case (lower_case (char (string)))
case ("auto")
if (unweighted) then
mode = NORM_UNIT
else
mode = NORM_SIGMA
end if
case ("1")
mode = NORM_UNIT
case ("1/n")
mode = NORM_N_EVT
case ("sigma")
mode = NORM_SIGMA
case ("sigma/n")
mode = NORM_S_N
case default
call msg_fatal ("Event normalization: unknown value '" &
// char (string) // "'")
end select
end function event_normalization_mode
function event_normalization_string (norm_mode) result (string)
integer, intent(in) :: norm_mode
type(string_t) :: string
select case (norm_mode)
case (NORM_UNDEFINED); string = "[undefined]"
case (NORM_UNIT); string = "'1'"
case (NORM_N_EVT); string = "'1/n'"
case (NORM_SIGMA); string = "'sigma'"
case (NORM_S_N); string = "'sigma/n'"
case default; string = "???"
end select
end function event_normalization_string
@ %def event_normalization_mode
@ %def event_normalization_string
@ We place this here as a generic helper, so we can update event
weights whenever we need, not just in connection with an event sample
data object.
<<Event base: public>>=
public :: event_normalization_update
<<Event base: procedures>>=
subroutine event_normalization_update (weight, sigma, n, mode_new, mode_old)
real(default), intent(inout) :: weight
real(default), intent(in) :: sigma
integer, intent(in) :: n
integer, intent(in) :: mode_new, mode_old
if (mode_new /= mode_old) then
if (sigma > 0 .and. n > 0) then
weight = weight / factor (mode_old) * factor (mode_new)
else
call msg_fatal ("Event normalization update: null sample")
end if
end if
contains
function factor (mode)
real(default) :: factor
integer, intent(in) :: mode
select case (mode)
case (NORM_UNIT); factor = 1._default
case (NORM_N_EVT); factor = 1._default / n
case (NORM_SIGMA); factor = sigma
case (NORM_S_N); factor = sigma / n
case default
call msg_fatal ("Event normalization update: undefined mode")
end select
end function factor
end subroutine event_normalization_update
@ %def event_normalization_update
@
\subsection{Callback container}
This derived type contains a callback procedure that can
be executed during event I/O. The callback procedure is given the
event object (with class [[generic_event]]) and an event index.
This is a simple wrapper. The object is abstract, so the the actual
procedure is introduced by overriding the deferred one. We use the
PASS attribute, so we may supplement runtime data in the callback object
if desired.
<<Event base: public>>=
public :: event_callback_t
<<Event base: types>>=
type, abstract :: event_callback_t
private
contains
procedure(event_callback_write), deferred :: write
procedure(event_callback_proc), deferred :: proc
end type event_callback_t
@ %def event_callback_t
@ Identify the callback procedure in output
<<Event base: interfaces>>=
abstract interface
subroutine event_callback_write (event_callback, unit)
import
class(event_callback_t), intent(in) :: event_callback
integer, intent(in), optional :: unit
end subroutine event_callback_write
end interface
@ %def event_callback_write
@ This is the procedure interface.
<<Event base: interfaces>>=
abstract interface
subroutine event_callback_proc (event_callback, i, event)
import
class(event_callback_t), intent(in) :: event_callback
integer(i64), intent(in) :: i
class(generic_event_t), intent(in) :: event
end subroutine event_callback_proc
end interface
@ %def event_callback_proc
@ A dummy implementation for testing and fallback.
<<Event base: public>>=
public :: event_callback_nop_t
<<Event base: types>>=
type, extends (event_callback_t) :: event_callback_nop_t
private
contains
procedure :: write => event_callback_nop_write
procedure :: proc => event_callback_nop
end type event_callback_nop_t
@ %def event_callback_t
<<Event base: procedures>>=
subroutine event_callback_nop_write (event_callback, unit)
class(event_callback_nop_t), intent(in) :: event_callback
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "NOP"
end subroutine event_callback_nop_write
subroutine event_callback_nop (event_callback, i, event)
class(event_callback_nop_t), intent(in) :: event_callback
integer(i64), intent(in) :: i
class(generic_event_t), intent(in) :: event
end subroutine event_callback_nop
@ %def event_callback_nop_write
@ %def event_callback_nop
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Event Sample Data}
We define a simple and transparent container for (meta)data that are
associated with an event sample.
<<[[eio_data.f90]]>>=
<<File header>>
module eio_data
<<Use kinds>>
<<Use strings>>
use io_units
use numeric_utils
use diagnostics
use event_base
<<Standard module head>>
<<EIO data: public>>
<<EIO data: types>>
contains
<<EIO data: procedures>>
end module eio_data
@ %def eio_data
@
\subsection{Event Sample Data}
These are data that apply to an event sample as a whole. They are
given in an easily portable form (no fancy structure) and are used for
initializing event formats.
There are two MD5 sums here. [[md5sum_proc]] depends only on the
definition of the contributing processes. A sample with matching
checksum can be rescanned with modified model parameters, beam
structure etc, to recalculate observables. [[md5sum_config]] includes
all relevant data. Rescanning a sample with matching checksum will
produce identical observables. (A third checksum might be added which
depends on the event sample itself. This is not needed, so far.)
If alternate weights are part of the event sample ([[n_alt]] nonzero),
there is a configuration MD5 sum for each of them.
<<EIO data: public>>=
public :: event_sample_data_t
<<EIO data: types>>=
type :: event_sample_data_t
character(32) :: md5sum_prc = ""
character(32) :: md5sum_cfg = ""
logical :: unweighted = .true.
logical :: negative_weights = .false.
integer :: norm_mode = NORM_UNDEFINED
integer :: n_beam = 0
integer, dimension(2) :: pdg_beam = 0
real(default), dimension(2) :: energy_beam = 0
integer :: n_proc = 0
integer :: n_evt = 0
integer :: nlo_multiplier = 1
integer :: split_n_evt = 0
integer :: split_n_kbytes = 0
integer :: split_index = 0
real(default) :: total_cross_section = 0
integer, dimension(:), allocatable :: proc_num_id
integer :: n_alt = 0
character(32), dimension(:), allocatable :: md5sum_alt
real(default), dimension(:), allocatable :: cross_section
real(default), dimension(:), allocatable :: error
contains
<<EIO data: event sample data: TBP>>
end type event_sample_data_t
@ %def event_sample_data_t
@ Initialize: allocate for the number of processes
<<EIO data: event sample data: TBP>>=
procedure :: init => event_sample_data_init
<<EIO data: procedures>>=
subroutine event_sample_data_init (data, n_proc, n_alt)
class(event_sample_data_t), intent(out) :: data
integer, intent(in) :: n_proc
integer, intent(in), optional :: n_alt
data%n_proc = n_proc
allocate (data%proc_num_id (n_proc), source = 0)
allocate (data%cross_section (n_proc), source = 0._default)
allocate (data%error (n_proc), source = 0._default)
if (present (n_alt)) then
data%n_alt = n_alt
allocate (data%md5sum_alt (n_alt))
data%md5sum_alt = ""
end if
end subroutine event_sample_data_init
@ %def event_sample_data_init
@ Output.
<<EIO data: event sample data: TBP>>=
procedure :: write => event_sample_data_write
<<EIO data: procedures>>=
subroutine event_sample_data_write (data, unit)
class(event_sample_data_t), intent(in) :: data
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A)") "Event sample properties:"
write (u, "(3x,A,A,A)") "MD5 sum (proc) = '", data%md5sum_prc, "'"
write (u, "(3x,A,A,A)") "MD5 sum (config) = '", data%md5sum_cfg, "'"
write (u, "(3x,A,L1)") "unweighted = ", data%unweighted
write (u, "(3x,A,L1)") "negative weights = ", data%negative_weights
write (u, "(3x,A,A)") "normalization = ", &
char (event_normalization_string (data%norm_mode))
write (u, "(3x,A,I0)") "number of beams = ", data%n_beam
write (u, "(5x,A,2(1x,I19))") "PDG = ", &
data%pdg_beam(:data%n_beam)
write (u, "(5x,A,2(1x,ES19.12))") "Energy = ", &
data%energy_beam(:data%n_beam)
if (data%n_evt > 0) then
write (u, "(3x,A,I0)") "number of events = ", data%n_evt
end if
if (.not. vanishes (data%total_cross_section)) then
write (u, "(3x,A,ES19.12)") "total cross sec. = ", &
data%total_cross_section
end if
write (u, "(3x,A,I0)") "num of processes = ", data%n_proc
do i = 1, data%n_proc
write (u, "(3x,A,I0)") "Process #", data%proc_num_id (i)
select case (data%n_beam)
case (1)
write (u, "(5x,A,ES19.12)") "Width = ", data%cross_section(i)
case (2)
write (u, "(5x,A,ES19.12)") "CSec = ", data%cross_section(i)
end select
write (u, "(5x,A,ES19.12)") "Error = ", data%error(i)
end do
if (data%n_alt > 0) then
write (u, "(3x,A,I0)") "num of alt wgt = ", data%n_alt
do i = 1, data%n_alt
write (u, "(5x,A,A,A,1x,I0)") "MD5 sum (cfg) = '", &
data%md5sum_alt(i), "'", i
end do
end if
end subroutine event_sample_data_write
@ %def event_sample_data_write
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_data_ut.f90]]>>=
<<File header>>
module eio_data_ut
use unit_tests
use eio_data_uti
<<Standard module head>>
<<EIO data: public test>>
contains
<<EIO data: test driver>>
end module eio_data_ut
@ %def eio_data_ut
@
<<[[eio_data_uti.f90]]>>=
<<File header>>
module eio_data_uti
<<Use kinds>>
<<Use strings>>
use event_base
use eio_data
<<Standard module head>>
<<EIO data: test declarations>>
contains
<<EIO data: tests>>
end module eio_data_uti
@ %def eio_data_ut
@ API: driver for the unit tests below.
<<EIO data: public test>>=
public :: eio_data_test
<<EIO data: test driver>>=
subroutine eio_data_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO data: execute tests>>
end subroutine eio_data_test
@ %def eio_data_test
@
\subsubsection{Event Sample Data}
Print the contents of a sample data block.
<<EIO data: execute tests>>=
call test (eio_data_1, "eio_data_1", &
"event sample data", &
u, results)
<<EIO data: test declarations>>=
public :: eio_data_1
<<EIO data: tests>>=
subroutine eio_data_1 (u)
integer, intent(in) :: u
type(event_sample_data_t) :: data
write (u, "(A)") "* Test output: eio_data_1"
write (u, "(A)") "* Purpose: display event sample data"
write (u, "(A)")
write (u, "(A)") "* Decay process, one component"
write (u, "(A)")
call data%init (1, 1)
data%n_beam = 1
data%pdg_beam(1) = 25
data%energy_beam(1) = 125
data%norm_mode = NORM_UNIT
data%proc_num_id = [42]
data%cross_section = [1.23e-4_default]
data%error = 5e-6_default
data%md5sum_prc = "abcdefghijklmnopabcdefghijklmnop"
data%md5sum_cfg = "12345678901234561234567890123456"
data%md5sum_alt(1) = "uuuuuuuuuuuuuuuuuuuuuuuuuuuuuuuu"
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Scattering process, two components"
write (u, "(A)")
call data%init (2)
data%n_beam = 2
data%pdg_beam = [2212, -2212]
data%energy_beam = [8._default, 10._default]
data%norm_mode = NORM_SIGMA
data%proc_num_id = [12, 34]
data%cross_section = [100._default, 88._default]
data%error = [1._default, 0.1_default]
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_data_1"
end subroutine eio_data_1
@ %def eio_data_1
@
\subsubsection{Event Normalization}
Check the functions for translating modes and updating weights.
<<EIO data: execute tests>>=
call test (eio_data_2, "eio_data_2", &
"event normalization", &
u, results)
<<EIO data: test declarations>>=
public :: eio_data_2
<<EIO data: tests>>=
subroutine eio_data_2 (u)
integer, intent(in) :: u
type(string_t) :: s
logical :: unweighted
real(default) :: w, w0, sigma
integer :: n
write (u, "(A)") "* Test output: eio_data_2"
write (u, "(A)") "* Purpose: handle event normalization"
write (u, "(A)")
write (u, "(A)") "* Normalization strings"
write (u, "(A)")
s = "auto"
unweighted = .true.
write (u, "(1x,A,1x,L1,1x,A)") char (s), unweighted, &
char (event_normalization_string &
(event_normalization_mode (s, unweighted)))
s = "AUTO"
unweighted = .false.
write (u, "(1x,A,1x,L1,1x,A)") char (s), unweighted, &
char (event_normalization_string &
(event_normalization_mode (s, unweighted)))
unweighted = .true.
s = "1"
write (u, "(2(1x,A))") char (s), char (event_normalization_string &
(event_normalization_mode (s, unweighted)))
s = "1/n"
write (u, "(2(1x,A))") char (s), char (event_normalization_string &
(event_normalization_mode (s, unweighted)))
s = "Sigma"
write (u, "(2(1x,A))") char (s), char (event_normalization_string &
(event_normalization_mode (s, unweighted)))
s = "sigma/N"
write (u, "(2(1x,A))") char (s), char (event_normalization_string &
(event_normalization_mode (s, unweighted)))
write (u, "(A)")
write (u, "(A)") "* Normalization update"
write (u, "(A)")
sigma = 5
n = 2
w0 = 1
w = w0
call event_normalization_update (w, sigma, n, NORM_UNIT, NORM_UNIT)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_N_EVT, NORM_UNIT)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_SIGMA, NORM_UNIT)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_S_N, NORM_UNIT)
write (u, "(2(F6.3))") w0, w
write (u, *)
w0 = 0.5
w = w0
call event_normalization_update (w, sigma, n, NORM_UNIT, NORM_N_EVT)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_N_EVT, NORM_N_EVT)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_SIGMA, NORM_N_EVT)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_S_N, NORM_N_EVT)
write (u, "(2(F6.3))") w0, w
write (u, *)
w0 = 5.0
w = w0
call event_normalization_update (w, sigma, n, NORM_UNIT, NORM_SIGMA)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_N_EVT, NORM_SIGMA)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_SIGMA, NORM_SIGMA)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_S_N, NORM_SIGMA)
write (u, "(2(F6.3))") w0, w
write (u, *)
w0 = 2.5
w = w0
call event_normalization_update (w, sigma, n, NORM_UNIT, NORM_S_N)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_N_EVT, NORM_S_N)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_SIGMA, NORM_S_N)
write (u, "(2(F6.3))") w0, w
w = w0
call event_normalization_update (w, sigma, n, NORM_S_N, NORM_S_N)
write (u, "(2(F6.3))") w0, w
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_data_2"
end subroutine eio_data_2
@ %def eio_data_2
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Abstract I/O Handler}
This module defines an abstract object for event I/O and the
associated methods.
There are [[output]] and [[input]] methods which
write or read a single event from/to the I/O stream, respectively.
The I/O stream itself may be a file, a common block, or an externally
linked structure, depending on the concrete implementation.
A [[write]] method prints the current content of the
implementation-dependent event record in human-readable form.
The [[init_in]]/[[init_out]] and [[final]] prepare
and finalize the I/O stream, respectively. There is also a
[[switch_inout]] method which turns an input stream into an output
stream where events can be appended.
Optionally, output files can be split in chunks of well-defined size. The
[[split_out]] method takes care of this.
<<[[eio_base.f90]]>>=
<<File header>>
module eio_base
use kinds, only: i64
<<Use strings>>
use io_units
use diagnostics
use model_data
use event_base
use eio_data
<<Standard module head>>
<<EIO base: public>>
<<EIO base: types>>
<<EIO base: interfaces>>
contains
<<EIO base: procedures>>
end module eio_base
@ %def eio_base
@
\subsection{Type}
We can assume that most implementations will need the file extension as a
fixed string and, if they support file splitting, the current file index.
The fallback model is useful for implementations that are able to read
unknown files which may contain hadrons etc., not in the current
hard-interaction model.
<<EIO base: public>>=
public :: eio_t
<<EIO base: types>>=
type, abstract :: eio_t
type(string_t) :: sample
type(string_t) :: extension
type(string_t) :: filename
logical :: has_file = .false.
logical :: split = .false.
integer :: split_n_evt = 0
integer :: split_n_kbytes = 0
integer :: split_index = 0
integer :: split_count = 0
class(model_data_t), pointer :: fallback_model => null ()
contains
<<EIO base: eio: TBP>>
end type eio_t
@ %def eio_t
@ Write to screen. If possible, this should display the contents of the
current event, i.e., the last one that was written or read.
<<EIO base: eio: TBP>>=
procedure (eio_write), deferred :: write
<<EIO base: interfaces>>=
abstract interface
subroutine eio_write (object, unit)
import
class(eio_t), intent(in) :: object
integer, intent(in), optional :: unit
end subroutine eio_write
end interface
@ %def eio_write
@ Finalize. This should write/read footer data and close input/output
channels.
<<EIO base: eio: TBP>>=
procedure (eio_final), deferred :: final
<<EIO base: interfaces>>=
abstract interface
subroutine eio_final (object)
import
class(eio_t), intent(inout) :: object
end subroutine eio_final
end interface
@ %def eio_final
@ Determine splitting parameters from the event sample data.
<<EIO base: eio: TBP>>=
procedure :: set_splitting => eio_set_splitting
<<EIO base: procedures>>=
subroutine eio_set_splitting (eio, data)
class(eio_t), intent(inout) :: eio
type(event_sample_data_t), intent(in) :: data
eio%split = data%split_n_evt > 0 .or. data%split_n_kbytes > 0
if (eio%split) then
eio%split_n_evt = data%split_n_evt
eio%split_n_kbytes = data%split_n_kbytes
eio%split_index = data%split_index
eio%split_count = 0
end if
end subroutine eio_set_splitting
@ %def eio_set_splitting
@ Update the byte count and check if it has increased. We use integer
division to determine the number of [[n_kbytes]] blocks that are in
the event file.
<<EIO base: eio: TBP>>=
procedure :: update_split_count => eio_update_split_count
<<EIO base: procedures>>=
subroutine eio_update_split_count (eio, increased)
class(eio_t), intent(inout) :: eio
logical, intent(out) :: increased
integer :: split_count_old
if (eio%split_n_kbytes > 0) then
split_count_old = eio%split_count
eio%split_count = eio%file_size_kbytes () / eio%split_n_kbytes
increased = eio%split_count > split_count_old
end if
end subroutine eio_update_split_count
@ %def eio_update_split_count
@ Generate a filename, taking a possible split index into account.
<<EIO base: eio: TBP>>=
procedure :: set_filename => eio_set_filename
<<EIO base: procedures>>=
subroutine eio_set_filename (eio)
class(eio_t), intent(inout) :: eio
character(32) :: buffer
if (eio%split) then
write (buffer, "(I0,'.')") eio%split_index
eio%filename = eio%sample // "." // trim (buffer) // eio%extension
eio%has_file = .true.
else
eio%filename = eio%sample // "." // eio%extension
eio%has_file = .true.
end if
end subroutine eio_set_filename
@ %def eio_set_filename
@ Set the fallback model.
<<EIO base: eio: TBP>>=
procedure :: set_fallback_model => eio_set_fallback_model
<<EIO base: procedures>>=
subroutine eio_set_fallback_model (eio, model)
class(eio_t), intent(inout) :: eio
class(model_data_t), intent(in), target :: model
eio%fallback_model => model
end subroutine eio_set_fallback_model
@ %def eio_set_fallback_model
@ Initialize for output. We provide process names. This should
open an event file if appropriate and write header data. Some methods
may require event sample data.
<<EIO base: eio: TBP>>=
procedure (eio_init_out), deferred :: init_out
<<EIO base: interfaces>>=
abstract interface
subroutine eio_init_out (eio, sample, data, success, extension)
import
class(eio_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
type(string_t), intent(in), optional :: extension
end subroutine eio_init_out
end interface
@ %def eio_init_out
@ Initialize for input. We provide process names. This should open an event
file if appropriate and read header data. The [[md5sum]] can be used to check
the integrity of the configuration, it it provides a checksum to compare with.
In case the extension has changed the extension is also given as an argument.
The [[data]] argument is [[intent(inout)]]: we may read part of it and
keep other parts and/or check them against the data in the file.
<<EIO base: eio: TBP>>=
procedure (eio_init_in), deferred :: init_in
<<EIO base: interfaces>>=
abstract interface
subroutine eio_init_in (eio, sample, data, success, extension)
import
class(eio_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
type(string_t), intent(in), optional :: extension
end subroutine eio_init_in
end interface
@ %def eio_init_in
@ Re-initialize for output. This should change the status of any event file
from input to output and position it for appending new events.
<<EIO base: eio: TBP>>=
procedure (eio_switch_inout), deferred :: switch_inout
<<EIO base: interfaces>>=
abstract interface
subroutine eio_switch_inout (eio, success)
import
class(eio_t), intent(inout) :: eio
logical, intent(out), optional :: success
end subroutine eio_switch_inout
end interface
@ %def eio_switch_inout
@ This is similar: split the output, i.e., close the current file and open a
new one. The default implementation does nothing. For the feature to work,
an implementation must override this.
<<EIO base: eio: TBP>>=
procedure :: split_out => eio_split_out
<<EIO base: procedures>>=
subroutine eio_split_out (eio)
class(eio_t), intent(inout) :: eio
end subroutine eio_split_out
@ %def eio_split_out
@ Determine the file size in kilobytes. More exactly, determine the
size in units of 1024 storage units, as returned by the INQUIRE statement.
The implementation returns zero if there is no file. The
[[has_file]] flag is set by the [[set_filename]] method, so we can be
confident that the [[inquire]] call is meaningful. If this algorithm
doesn't apply for a particular format, we still can override the
procedure.
<<EIO base: eio: TBP>>=
procedure :: file_size_kbytes => eio_file_size_kbytes
<<EIO base: procedures>>=
function eio_file_size_kbytes (eio) result (kbytes)
class(eio_t), intent(in) :: eio
integer :: kbytes
integer(i64) :: bytes
if (eio%has_file) then
inquire (file = char (eio%filename), size = bytes)
if (bytes > 0) then
kbytes = bytes / 1024
else
kbytes = 0
end if
else
kbytes = 0
end if
end function eio_file_size_kbytes
@ %def eio_file_size_kbytes
@ Output an event. All data can be taken from the [[event]] record.
The index [[i_prc]] identifies the process among the processes that
are contained in the current sample. The [[reading]] flag, if present,
indicates that the event was read from file, not generated.
The [[passed]] flag tells us that this event has passed the selection
criteria. Depending on the event format, we may choose to skip events
that have not passed.
<<EIO base: eio: TBP>>=
procedure (eio_output), deferred :: output
<<EIO base: interfaces>>=
abstract interface
subroutine eio_output (eio, event, i_prc, reading, passed, pacify)
import
class(eio_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
end subroutine eio_output
end interface
@ %def eio_output
@ Input an event. This should fill all event data that cannot be inferred
from the associated process.
The input is broken down into two parts. First we read the [[i_prc]]
index. So we know which process to expect in the subsequent event.
If we have reached end of file, we also will know.
Then, we read the event itself.
The parameter [[iostat]] is supposed to be set as the Fortran standard
requires, negative for EOF and positive for error.
<<EIO base: eio: TBP>>=
procedure (eio_input_i_prc), deferred :: input_i_prc
procedure (eio_input_event), deferred :: input_event
<<EIO base: interfaces>>=
abstract interface
subroutine eio_input_i_prc (eio, i_prc, iostat)
import
class(eio_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
end subroutine eio_input_i_prc
end interface
abstract interface
subroutine eio_input_event (eio, event, iostat)
import
class(eio_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
end subroutine eio_input_event
end interface
@ %def eio_input
@
<<EIO base: eio: TBP>>=
procedure (eio_skip), deferred :: skip
<<EIO base: interfaces>>=
abstract interface
subroutine eio_skip (eio, iostat)
import
class(eio_t), intent(inout) :: eio
integer, intent(out) :: iostat
end subroutine eio_skip
end interface
@ %def eio_skip
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_base_ut.f90]]>>=
<<File header>>
module eio_base_ut
use unit_tests
use eio_base_uti
<<Standard module head>>
<<EIO base: public test>>
<<EIO base: public test auxiliary>>
contains
<<EIO base: test driver>>
end module eio_base_ut
@ %def eio_base_ut
@
<<[[eio_base_uti.f90]]>>=
<<File header>>
module eio_base_uti
<<Use kinds>>
<<Use strings>>
use io_units
use lorentz
use model_data
use particles
use event_base
use eio_data
use eio_base
<<Standard module head>>
<<EIO base: public test auxiliary>>
<<EIO base: test declarations>>
<<EIO base: test types>>
<<EIO base: test variables>>
contains
<<EIO base: tests>>
<<EIO base: test auxiliary>>
end module eio_base_uti
@ %def eio_base_ut
@ API: driver for the unit tests below.
<<EIO base: public test>>=
public :: eio_base_test
<<EIO base: test driver>>=
subroutine eio_base_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO base: execute tests>>
end subroutine eio_base_test
@ %def eio_base_test
@ The caller has to provide procedures that prepare and cleanup the test
environment. They depend on modules that are not available here.
<<EIO base: test types>>=
abstract interface
subroutine eio_prepare_event (event, unweighted, n_alt)
import
class(generic_event_t), intent(inout), pointer :: event
logical, intent(in), optional :: unweighted
integer, intent(in), optional :: n_alt
end subroutine eio_prepare_event
end interface
abstract interface
subroutine eio_cleanup_event (event)
import
class(generic_event_t), intent(inout), pointer :: event
end subroutine eio_cleanup_event
end interface
@ We store pointers to the test-environment handlers as module variables.
This allows us to call them from the test routines themselves, which don't
allow for extra arguments.
<<EIO base: public test auxiliary>>=
public :: eio_prepare_test, eio_cleanup_test
<<EIO base: test types>>=
procedure(eio_prepare_event), pointer :: eio_prepare_test => null ()
procedure(eio_cleanup_event), pointer :: eio_cleanup_test => null ()
@ %def eio_prepare_test eio_cleanup_test
@ Similarly, for the fallback (hadron) model that some eio tests require:
<<EIO base: test types>>=
abstract interface
subroutine eio_prepare_model (model)
import
class(model_data_t), intent(inout), pointer :: model
end subroutine eio_prepare_model
end interface
abstract interface
subroutine eio_cleanup_model (model)
import
class(model_data_t), intent(inout), pointer :: model
end subroutine eio_cleanup_model
end interface
<<EIO base: public test auxiliary>>=
public :: eio_prepare_fallback_model, eio_cleanup_fallback_model
<<EIO base: test variables>>=
procedure(eio_prepare_model), pointer :: eio_prepare_fallback_model => null ()
procedure(eio_cleanup_model), pointer :: eio_cleanup_fallback_model => null ()
@ %def eio_prepare_fallback_model eio_cleanup_fallback_model
@
\subsubsection{Test type for event I/O}
The contents simulate the contents of an external file. We have the
[[sample]] string as the file name and the array of momenta
[[event_p]] as the list of events. The
second index is the event index. The [[event_i]] component is the pointer
to the current event, [[event_n]] is the total number of stored events.
<<EIO base: test types>>=
type, extends (eio_t) :: eio_test_t
integer :: event_n = 0
integer :: event_i = 0
integer :: i_prc = 0
type(vector4_t), dimension(:,:), allocatable :: event_p
contains
<<EIO base: eio test: TBP>>
end type eio_test_t
@ %def eio_test_t
@ Write to screen. Pretend that this is an actual event format.
<<EIO base: eio test: TBP>>=
procedure :: write => eio_test_write
<<EIO base: test auxiliary>>=
subroutine eio_test_write (object, unit)
class(eio_test_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A)") "Test event stream"
if (object%event_i /= 0) then
write (u, "(1x,A,I0,A)") "Event #", object%event_i, ":"
do i = 1, size (object%event_p, 1)
call vector4_write (object%event_p(i, object%event_i), u)
end do
end if
end subroutine eio_test_write
@ %def eio_test_write
@ Finalizer. For the test case, we just reset the event count,
but keep the stored ``events''. For the real implementations, the events
would be stored on an external medium, so we would delete the object
contents.
<<EIO base: eio test: TBP>>=
procedure :: final => eio_test_final
<<EIO base: test auxiliary>>=
subroutine eio_test_final (object)
class(eio_test_t), intent(inout) :: object
object%event_i = 0
end subroutine eio_test_final
@ %def eio_test_final
@ Initialization: We store the process IDs and the energy from the beam-data
object. We also allocate the momenta (i.e., the simulated event record) for a
fixed maximum size of 10 events, 2 momenta each. There is only a single
process.
<<EIO base: eio test: TBP>>=
procedure :: init_out => eio_test_init_out
<<EIO base: test auxiliary>>=
subroutine eio_test_init_out (eio, sample, data, success, extension)
class(eio_test_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
type(string_t), intent(in), optional :: extension
eio%sample = sample
eio%event_n = 0
eio%event_i = 0
allocate (eio%event_p (2, 10))
if (present (success)) success = .true.
end subroutine eio_test_init_out
@ %def eio_test_init_out
@ Initialization for input. Nothing to do for the test type.
<<EIO base: eio test: TBP>>=
procedure :: init_in => eio_test_init_in
<<EIO base: test auxiliary>>=
subroutine eio_test_init_in (eio, sample, data, success, extension)
class(eio_test_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
type(string_t), intent(in), optional :: extension
if (present (success)) success = .true.
end subroutine eio_test_init_in
@ %def eio_test_init_in
@ Switch from output to input. Again, nothing to do for the test type.
<<EIO base: eio test: TBP>>=
procedure :: switch_inout => eio_test_switch_inout
<<EIO base: test auxiliary>>=
subroutine eio_test_switch_inout (eio, success)
class(eio_test_t), intent(inout) :: eio
logical, intent(out), optional :: success
if (present (success)) success = .true.
end subroutine eio_test_switch_inout
@ %def eio_test_switch_inout
@ Output. Increment the event counter and store the momenta of the current
event.
<<EIO base: eio test: TBP>>=
procedure :: output => eio_test_output
<<EIO base: test auxiliary>>=
subroutine eio_test_output (eio, event, i_prc, reading, passed, pacify)
class(eio_test_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
logical, intent(in), optional :: reading, passed, pacify
integer, intent(in) :: i_prc
type(particle_set_t), pointer :: pset
type(particle_t) :: prt
eio%event_n = eio%event_n + 1
eio%event_i = eio%event_n
eio%i_prc = i_prc
pset => event%get_particle_set_ptr ()
prt = pset%get_particle (3)
eio%event_p(1, eio%event_i) = prt%get_momentum ()
prt = pset%get_particle (4)
eio%event_p(2, eio%event_i) = prt%get_momentum ()
end subroutine eio_test_output
@ %def eio_test_output
@ Input. Increment the event counter and retrieve the momenta of the current
event. For the test case, we do not actually modify the current event.
<<EIO base: eio test: TBP>>=
procedure :: input_i_prc => eio_test_input_i_prc
procedure :: input_event => eio_test_input_event
<<EIO base: test auxiliary>>=
subroutine eio_test_input_i_prc (eio, i_prc, iostat)
class(eio_test_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
i_prc = eio%i_prc
iostat = 0
end subroutine eio_test_input_i_prc
subroutine eio_test_input_event (eio, event, iostat)
class(eio_test_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
eio%event_i = eio%event_i + 1
iostat = 0
end subroutine eio_test_input_event
@ %def eio_test_input_i_prc
@ %def eio_test_input_event
@
<<EIO base: eio test: TBP>>=
procedure :: skip => eio_test_skip
<<EIO base: test auxiliary>>=
subroutine eio_test_skip (eio, iostat)
class(eio_test_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_test_skip
@ %def eio_test_skip
@
\subsubsection{Test I/O methods}
<<EIO base: execute tests>>=
call test (eio_base_1, "eio_base_1", &
"read and write event contents", &
u, results)
<<EIO base: test declarations>>=
public :: eio_base_1
<<EIO base: tests>>=
subroutine eio_base_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
class(eio_t), allocatable :: eio
integer :: i_prc, iostat
type(string_t) :: sample
write (u, "(A)") "* Test output: eio_base_1"
write (u, "(A)") "* Purpose: generate and read/write an event"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_test1"
allocate (eio_test_t :: eio)
call eio%init_out (sample)
call event%generate (1, [0._default, 0._default])
call eio%output (event, 42)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* Re-read the event"
write (u, "(A)")
call eio%init_in (sample)
call eio%input_i_prc (i_prc, iostat)
call eio%input_event (event, iostat)
call eio%write (u)
write (u, "(A)")
write (u, "(1x,A,I0)") "i = ", i_prc
write (u, "(A)")
write (u, "(A)") "* Generate and append another event"
write (u, "(A)")
call eio%switch_inout ()
call event%generate (1, [0._default, 0._default])
call eio%output (event, 5)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* Re-read both events"
write (u, "(A)")
call eio%init_in (sample)
call eio%input_i_prc (i_prc, iostat)
call eio%input_event (event, iostat)
call eio%input_i_prc (i_prc, iostat)
call eio%input_event (event, iostat)
call eio%write (u)
write (u, "(A)")
write (u, "(1x,A,I0)") "i = ", i_prc
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
deallocate (eio)
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_base_1"
end subroutine eio_base_1
@ %def eio_base_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Direct Event Access}
As a convenient application of the base type, we construct an event
handler that allows us of setting and retrieving events just in the
same way as an file I/O format, but directly dealing with particle
data and momenta. This is an input and output format, but we do not
care about counting events.
<<[[eio_direct.f90]]>>=
<<File header>>
module eio_direct
<<Use kinds>>
<<Use strings>>
use io_units
use diagnostics
use cputime
use lorentz, only: vector4_t
use particles, only: particle_set_t
use model_data, only: model_data_t
use event_base
use eio_data
use eio_base
<<Standard module head>>
<<EIO direct: public>>
<<EIO direct: types>>
contains
<<EIO direct: procedures>>
end module eio_direct
@ %def eio_direct
@
\subsection{Type}
<<EIO direct: public>>=
public :: eio_direct_t
<<EIO direct: types>>=
type, extends (eio_t) :: eio_direct_t
private
logical :: i_evt_set = .false.
integer :: i_evt = 0
integer :: i_prc = 0
integer :: i_mci = 0
integer :: i_term = 0
integer :: channel = 0
logical :: passed_set = .false.
logical :: passed = .true.
type(particle_set_t) :: pset
contains
<<EIO direct: eio direct: TBP>>
end type eio_direct_t
@ %def eio_direct_t
@
\subsection{Common Methods}
Output.
<<EIO direct: eio direct: TBP>>=
procedure :: write => eio_direct_write
<<EIO direct: procedures>>=
subroutine eio_direct_write (object, unit)
class(eio_direct_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Event direct access:"
if (object%i_evt_set) then
write (u, "(3x,A,1x,I0)") "i_evt =", object%i_evt
else
write (u, "(3x,A)") "i_evt = [undefined]"
end if
write (u, "(3x,A,1x,I0)") "i_prc =", object%i_prc
write (u, "(3x,A,1x,I0)") "i_mci =", object%i_prc
write (u, "(3x,A,1x,I0)") "i_term =", object%i_prc
write (u, "(3x,A,1x,I0)") "channel =", object%i_prc
if (object%passed_set) then
write (u, "(3x,A,1x,L1)") "passed =", object%passed
else
write (u, "(3x,A)") "passed = [N/A]"
end if
call object%pset%write (u)
end subroutine eio_direct_write
@ %def eio_direct_write
@ Finalizer: trivial.
<<EIO direct: eio direct: TBP>>=
procedure :: final => eio_direct_final
<<EIO direct: procedures>>=
subroutine eio_direct_final (object)
class(eio_direct_t), intent(inout) :: object
call object%pset%final ()
end subroutine eio_direct_final
@ %def eio_direct_final
@ Initialize for input and/or output, both are identical
<<EIO direct: eio direct: TBP>>=
procedure :: init_out => eio_direct_init_out
<<EIO direct: procedures>>=
subroutine eio_direct_init_out (eio, sample, data, success, extension)
class(eio_direct_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
if (present (success)) success = .true.
end subroutine eio_direct_init_out
@ %def eio_direct_init_out
@
<<EIO direct: eio direct: TBP>>=
procedure :: init_in => eio_direct_init_in
<<EIO direct: procedures>>=
subroutine eio_direct_init_in (eio, sample, data, success, extension)
class(eio_direct_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
if (present (success)) success = .true.
end subroutine eio_direct_init_in
@ %def eio_direct_init_in
@ Switch from input to output: no-op
<<EIO direct: eio direct: TBP>>=
procedure :: switch_inout => eio_direct_switch_inout
<<EIO direct: procedures>>=
subroutine eio_direct_switch_inout (eio, success)
class(eio_direct_t), intent(inout) :: eio
logical, intent(out), optional :: success
if (present (success)) success = .true.
end subroutine eio_direct_switch_inout
@ %def eio_direct_switch_inout
@ Output: transfer event contents from the [[event]] object to the
[[eio]] object. Note that finalization of the particle set is not
(yet) automatic.
<<EIO direct: eio direct: TBP>>=
procedure :: output => eio_direct_output
<<EIO direct: procedures>>=
subroutine eio_direct_output (eio, event, i_prc, reading, passed, pacify)
class(eio_direct_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
type(particle_set_t), pointer :: pset_ptr
call eio%pset%final ()
if (event%has_index ()) then
call eio%set_event_index (event%get_index ())
else
call eio%reset_event_index ()
end if
if (present (passed)) then
eio%passed = passed
eio%passed_set = .true.
else
eio%passed_set = .false.
end if
pset_ptr => event%get_particle_set_ptr ()
if (associated (pset_ptr)) then
eio%i_prc = i_prc
eio%pset = pset_ptr
end if
end subroutine eio_direct_output
@ %def eio_direct_output
@ Input: transfer event contents from the [[eio]] object to the
[[event]] object. The [[i_prc]] parameter has been stored inside the
[[eio]] record before.
<<EIO direct: eio direct: TBP>>=
procedure :: input_i_prc => eio_direct_input_i_prc
procedure :: input_event => eio_direct_input_event
<<EIO direct: procedures>>=
subroutine eio_direct_input_i_prc (eio, i_prc, iostat)
class(eio_direct_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
i_prc = eio%i_prc
iostat = 0
end subroutine eio_direct_input_i_prc
subroutine eio_direct_input_event (eio, event, iostat)
class(eio_direct_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
call event%select (eio%i_mci, eio%i_term, eio%channel)
if (eio%has_event_index ()) then
call event%set_index (eio%get_event_index ())
else
call event%reset_index ()
end if
call event%set_hard_particle_set (eio%pset)
end subroutine eio_direct_input_event
@ %def eio_direct_input_i_prc
@ %def eio_direct_input_event
@ No-op.
<<EIO direct: eio direct: TBP>>=
procedure :: skip => eio_direct_skip
<<EIO direct: procedures>>=
subroutine eio_direct_skip (eio, iostat)
class(eio_direct_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_direct_skip
@ %def eio_direct_skip
@
\subsection{Retrieve individual contents}
<<EIO direct: eio direct: TBP>>=
procedure :: has_event_index => eio_direct_has_event_index
procedure :: get_event_index => eio_direct_get_event_index
procedure :: passed_known => eio_direct_passed_known
procedure :: has_passed => eio_direct_has_passed
procedure :: get_n_in => eio_direct_get_n_in
procedure :: get_n_out => eio_direct_get_n_out
procedure :: get_n_tot => eio_direct_get_n_tot
<<EIO direct: procedures>>=
function eio_direct_has_event_index (eio) result (flag)
class(eio_direct_t), intent(in) :: eio
logical :: flag
flag = eio%i_evt_set
end function eio_direct_has_event_index
function eio_direct_get_event_index (eio) result (index)
class(eio_direct_t), intent(in) :: eio
integer :: index
if (eio%has_event_index ()) then
index = eio%i_evt
else
index = 0
end if
end function eio_direct_get_event_index
function eio_direct_passed_known (eio) result (flag)
class(eio_direct_t), intent(in) :: eio
logical :: flag
flag = eio%passed_set
end function eio_direct_passed_known
function eio_direct_has_passed (eio) result (flag)
class(eio_direct_t), intent(in) :: eio
logical :: flag
if (eio%passed_known ()) then
flag = eio%passed
else
flag = .true.
end if
end function eio_direct_has_passed
function eio_direct_get_n_in (eio) result (n_in)
class(eio_direct_t), intent(in) :: eio
integer :: n_in
n_in = eio%pset%get_n_in ()
end function eio_direct_get_n_in
function eio_direct_get_n_out (eio) result (n_out)
class(eio_direct_t), intent(in) :: eio
integer :: n_out
n_out = eio%pset%get_n_out ()
end function eio_direct_get_n_out
function eio_direct_get_n_tot (eio) result (n_tot)
class(eio_direct_t), intent(in) :: eio
integer :: n_tot
n_tot = eio%pset%get_n_tot ()
end function eio_direct_get_n_tot
@ %def eio_direct_has_event_index
@ %def eio_direct_get_event_index
@ %def eio_direct_passed_known
@ %def eio_direct_has_passed
@ %def eio_direct_get_n_in
@ %def eio_direct_get_n_out
@ %def eio_direct_get_n_tot
@ All momenta as a single allocatable array.
<<EIO direct: eio direct: TBP>>=
procedure :: get_momentum_array => eio_direct_get_momentum_array
<<EIO direct: procedures>>=
subroutine eio_direct_get_momentum_array (eio, p)
class(eio_direct_t), intent(in) :: eio
type(vector4_t), dimension(:), allocatable, intent(out) :: p
integer :: n
n = eio%get_n_tot ()
allocate (p (n))
p(:) = eio%pset%get_momenta ()
end subroutine eio_direct_get_momentum_array
@ %def eio_direct_get_momentum_array
@
\subsection{Manual access}
Build the contained particle set from scratch.
<<EIO direct: eio direct: TBP>>=
procedure :: init_direct => eio_direct_init_direct
<<EIO direct: procedures>>=
subroutine eio_direct_init_direct &
(eio, n_beam, n_in, n_rem, n_vir, n_out, pdg, model)
class(eio_direct_t), intent(out) :: eio
integer, intent(in) :: n_beam
integer, intent(in) :: n_in
integer, intent(in) :: n_rem
integer, intent(in) :: n_vir
integer, intent(in) :: n_out
integer, dimension(:), intent(in) :: pdg
class(model_data_t), intent(in), target :: model
call eio%pset%init_direct (n_beam, n_in, n_rem, n_vir, n_out, pdg, model)
end subroutine eio_direct_init_direct
@ %def eio_direct_init_direct
@ Set/reset the event index, which is optional.
<<EIO direct: eio direct: TBP>>=
procedure :: set_event_index => eio_direct_set_event_index
procedure :: reset_event_index => eio_direct_reset_event_index
<<EIO direct: procedures>>=
subroutine eio_direct_set_event_index (eio, index)
class(eio_direct_t), intent(inout) :: eio
integer, intent(in) :: index
eio%i_evt = index
eio%i_evt_set = .true.
end subroutine eio_direct_set_event_index
subroutine eio_direct_reset_event_index (eio)
class(eio_direct_t), intent(inout) :: eio
eio%i_evt_set = .false.
end subroutine eio_direct_reset_event_index
@ %def eio_direct_set_event_index
@ %def eio_direct_reset_event_index
@ Set the selection indices. This is supposed to select the [[i_prc]],
[[i_mci]], [[i_term]], and [[channel]]
entries of the event where the momentum set has to be stored, respectively.
The selection indices determine the process, MCI set, calculation term, and
phase-space channel is to be used for recalculation. The index values must
not be zero, even if the do not apply.
<<EIO direct: eio direct: TBP>>=
procedure :: set_selection_indices => eio_direct_set_selection_indices
<<EIO direct: procedures>>=
subroutine eio_direct_set_selection_indices &
(eio, i_prc, i_mci, i_term, channel)
class(eio_direct_t), intent(inout) :: eio
integer, intent(in) :: i_prc
integer, intent(in) :: i_mci
integer, intent(in) :: i_term
integer, intent(in) :: channel
eio%i_prc = i_prc
eio%i_mci = i_mci
eio%i_term = i_term
eio%channel = channel
end subroutine eio_direct_set_selection_indices
@ %def eio_direct_set_i_prc
@ Set momentum (or momenta -- elemental).
<<EIO direct: eio direct: TBP>>=
generic :: set_momentum => set_momentum_single
generic :: set_momentum => set_momentum_all
procedure :: set_momentum_single => eio_direct_set_momentum_single
procedure :: set_momentum_all => eio_direct_set_momentum_all
<<EIO direct: procedures>>=
subroutine eio_direct_set_momentum_single (eio, i, p, p2, on_shell)
class(eio_direct_t), intent(inout) :: eio
integer, intent(in) :: i
type(vector4_t), intent(in) :: p
real(default), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
call eio%pset%set_momentum (i, p, p2, on_shell)
end subroutine eio_direct_set_momentum_single
subroutine eio_direct_set_momentum_all (eio, p, p2, on_shell)
class(eio_direct_t), intent(inout) :: eio
type(vector4_t), dimension(:), intent(in) :: p
real(default), dimension(:), intent(in), optional :: p2
logical, intent(in), optional :: on_shell
call eio%pset%set_momentum (p, p2, on_shell)
end subroutine eio_direct_set_momentum_all
@ %def eio_direct_set_momentum
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_direct_ut.f90]]>>=
<<File header>>
module eio_direct_ut
use unit_tests
use eio_direct_uti
<<Standard module head>>
<<EIO direct: public test>>
contains
<<EIO direct: test driver>>
end module eio_direct_ut
@ %def eio_direct_ut
@
<<[[eio_direct_uti.f90]]>>=
<<File header>>
module eio_direct_uti
<<Use kinds>>
<<Use strings>>
use lorentz, only: vector4_t
use model_data, only: model_data_t
use event_base
use eio_data
use eio_base
use eio_direct
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
<<Standard module head>>
<<EIO direct: test declarations>>
contains
<<EIO direct: tests>>
end module eio_direct_uti
@ %def eio_direct_ut
@ API: driver for the unit tests below.
<<EIO direct: public test>>=
public :: eio_direct_test
<<EIO direct: test driver>>=
subroutine eio_direct_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO direct: execute tests>>
end subroutine eio_direct_test
@ %def eio_direct_test
@
\subsubsection{Test I/O methods}
We test the implementation of all I/O methods.
<<EIO direct: execute tests>>=
call test (eio_direct_1, "eio_direct_1", &
"read and write event contents", &
u, results)
<<EIO direct: test declarations>>=
public :: eio_direct_1
<<EIO direct: tests>>=
subroutine eio_direct_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
class(eio_t), allocatable :: eio
type(event_sample_data_t) :: data
type(string_t) :: sample
type(vector4_t), dimension(:), allocatable :: p
class(model_data_t), pointer :: model
integer :: i, n_events, iostat, i_prc
write (u, "(A)") "* Test output: eio_direct_1"
write (u, "(A)") "* Purpose: generate and read/write an event"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
write (u, "(A)")
write (u, "(A)") "* Initial state"
write (u, "(A)")
allocate (eio_direct_t :: eio)
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Extract an empty event"
write (u, "(A)")
call eio%output (event, 1)
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Retrieve contents"
write (u, "(A)")
select type (eio)
class is (eio_direct_t)
if (eio%has_event_index ()) write (u, "(A,1x,I0)") "index =", eio%get_event_index ()
if (eio%passed_known ()) write (u, "(A,1x,L1)") "passed =", eio%has_passed ()
write (u, "(A,1x,I0)") "n_in =", eio%get_n_in ()
write (u, "(A,1x,I0)") "n_out =", eio%get_n_out ()
end select
write (u, "(A)")
write (u, "(A)") "* Generate and extract an event"
write (u, "(A)")
call event%generate (1, [0._default, 0._default])
call event%set_index (42)
model => event%get_model_ptr ()
sample = ""
call eio%init_out (sample)
call eio%output (event, 1, passed = .true.)
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Retrieve contents"
write (u, "(A)")
select type (eio)
class is (eio_direct_t)
if (eio%has_event_index ()) write (u, "(A,1x,I0)") "index =", eio%get_event_index ()
if (eio%passed_known ()) write (u, "(A,1x,L1)") "passed =", eio%has_passed ()
write (u, "(A,1x,I0)") "n_in =", eio%get_n_in ()
write (u, "(A,1x,I0)") "n_out =", eio%get_n_out ()
end select
select type (eio)
class is (eio_direct_t)
call eio%get_momentum_array (p)
if (allocated (p)) then
write (u, "(A)") "p[3] ="
call p(3)%write (u)
end if
end select
write (u, "(A)")
write (u, "(A)") "* Re-create an eio event record: initialization"
write (u, "(A)")
call eio%final ()
select type (eio)
class is (eio_direct_t)
call eio%init_direct ( &
n_beam = 0, n_in = 2, n_rem = 0, n_vir = 0, n_out = 2, &
pdg = [25, 25, 25, 25], model = model)
call eio%set_event_index (42)
call eio%set_selection_indices (1, 1, 1, 1)
call eio%write (u)
end select
write (u, "(A)")
write (u, "(A)") "* Re-create an eio event record: &
&set momenta, interchanged"
write (u, "(A)")
select type (eio)
class is (eio_direct_t)
call eio%set_momentum (p([1,2,4,3]), on_shell=.true.)
call eio%write (u)
end select
write (u, "(A)")
write (u, "(A)") "* 'read' i_prc"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
write (u, "(1x,A,1x,I0)") "i_prc =", i_prc
write (u, "(1x,A,1x,I0)") "iostat =", iostat
write (u, "(A)")
write (u, "(A)") "* 'read' (fill) event"
write (u, "(A)")
call eio%input_event (event, iostat)
write (u, "(1x,A,1x,I0)") "iostat =", iostat
write (u, "(A)")
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
deallocate (eio)
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_direct_1"
end subroutine eio_direct_1
@ %def eio_direct_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Event Generation Checkpoints}
This is an output-only format. Its only use is to write screen
messages every $n$ events, to inform the user about progress.
<<[[eio_checkpoints.f90]]>>=
<<File header>>
module eio_checkpoints
<<Use strings>>
use io_units
use diagnostics
use cputime
use event_base
use eio_data
use eio_base
<<Standard module head>>
<<EIO checkpoints: public>>
<<EIO checkpoints: parameters>>
<<EIO checkpoints: types>>
contains
<<EIO checkpoints: procedures>>
end module eio_checkpoints
@ %def eio_checkpoints
@
\subsection{Type}
<<EIO checkpoints: public>>=
public :: eio_checkpoints_t
<<EIO checkpoints: types>>=
type, extends (eio_t) :: eio_checkpoints_t
logical :: active = .false.
logical :: running = .false.
integer :: val = 0
integer :: n_events = 0
integer :: n_read = 0
integer :: i_evt = 0
logical :: blank = .false.
type(timer_t) :: timer
contains
<<EIO checkpoints: eio checkpoints: TBP>>
end type eio_checkpoints_t
@ %def eio_checkpoints_t
@
\subsection{Specific Methods}
Set parameters that are specifically used for checkpointing.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: set_parameters => eio_checkpoints_set_parameters
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_set_parameters (eio, checkpoint, blank)
class(eio_checkpoints_t), intent(inout) :: eio
integer, intent(in) :: checkpoint
logical, intent(in), optional :: blank
eio%val = checkpoint
if (present (blank)) eio%blank = blank
end subroutine eio_checkpoints_set_parameters
@ %def eio_checkpoints_set_parameters
@
\subsection{Common Methods}
Output. This is not the actual event format, but a readable account
of the current status.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: write => eio_checkpoints_write
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_write (object, unit)
class(eio_checkpoints_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
if (object%active) then
write (u, "(1x,A)") "Event-sample checkpoints: active"
write (u, "(3x,A,I0)") "interval = ", object%val
write (u, "(3x,A,I0)") "n_events = ", object%n_events
write (u, "(3x,A,I0)") "n_read = ", object%n_read
write (u, "(3x,A,I0)") "n_current = ", object%i_evt
write (u, "(3x,A,L1)") "blanking = ", object%blank
call object%timer%write (u)
else
write (u, "(1x,A)") "Event-sample checkpoints: off"
end if
end subroutine eio_checkpoints_write
@ %def eio_checkpoints_write
@ Finalizer: trivial.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: final => eio_checkpoints_final
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_final (object)
class(eio_checkpoints_t), intent(inout) :: object
object%active = .false.
end subroutine eio_checkpoints_final
@ %def eio_checkpoints_final
@ Activate checkpointing for event generation or writing.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: init_out => eio_checkpoints_init_out
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_init_out (eio, sample, data, success, extension)
class(eio_checkpoints_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
if (present (data)) then
if (eio%val > 0) then
eio%active = .true.
eio%i_evt = 0
eio%n_read = 0
eio%n_events = data%n_evt * data%nlo_multiplier
end if
end if
if (present (success)) success = .true.
end subroutine eio_checkpoints_init_out
@ %def eio_checkpoints_init_out
@ No checkpointing for event reading.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: init_in => eio_checkpoints_init_in
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_init_in (eio, sample, data, success, extension)
class(eio_checkpoints_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
call msg_bug ("Event checkpoints: event input not supported")
if (present (success)) success = .false.
end subroutine eio_checkpoints_init_in
@ %def eio_checkpoints_init_in
@ Switch from input to output: also not supported.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: switch_inout => eio_checkpoints_switch_inout
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_switch_inout (eio, success)
class(eio_checkpoints_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("Event checkpoints: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_checkpoints_switch_inout
@ %def eio_checkpoints_switch_inout
@ Checkpoints: display progress for the current event, if applicable.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: output => eio_checkpoints_output
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_output (eio, event, i_prc, reading, passed, pacify)
class(eio_checkpoints_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
logical :: rd
rd = .false.; if (present (reading)) rd = reading
if (eio%active) then
if (.not. eio%running) call eio%startup ()
if (eio%running) then
eio%i_evt = eio%i_evt + 1
if (rd) then
eio%n_read = eio%n_read + 1
else if (mod (eio%i_evt, eio%val) == 0) then
call eio%message (eio%blank)
end if
if (eio%i_evt == eio%n_events) call eio%shutdown ()
end if
end if
end subroutine eio_checkpoints_output
@ %def eio_checkpoints_output
@ When the first event is called, we have to initialize the screen output.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: startup => eio_checkpoints_startup
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_startup (eio)
class(eio_checkpoints_t), intent(inout) :: eio
if (eio%active .and. eio%i_evt < eio%n_events) then
call msg_message ("")
call msg_message (checkpoint_bar)
call msg_message (checkpoint_head)
call msg_message (checkpoint_bar)
write (msg_buffer, checkpoint_fmt) 0., 0, eio%n_events - eio%i_evt, "???"
call msg_message ()
eio%running = .true.
call eio%timer%start ()
end if
end subroutine eio_checkpoints_startup
@ %def eio_checkpoints_startup
@ This message is printed at every checkpoint.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: message => eio_checkpoints_message
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_message (eio, testflag)
class(eio_checkpoints_t), intent(inout) :: eio
logical, intent(in), optional :: testflag
real :: t
type(time_t) :: time_remaining
type(string_t) :: time_string
call eio%timer%stop ()
t = eio%timer
call eio%timer%restart ()
time_remaining = &
nint (t / (eio%i_evt - eio%n_read) * (eio%n_events - eio%i_evt))
time_string = time_remaining%to_string_ms (blank = testflag)
write (msg_buffer, checkpoint_fmt) &
100 * (eio%i_evt - eio%n_read) / real (eio%n_events - eio%n_read), &
eio%i_evt - eio%n_read, &
eio%n_events - eio%i_evt, &
char (time_string)
call msg_message ()
end subroutine eio_checkpoints_message
@ %def eio_checkpoints_message
@ When the last event is called, wrap up.
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: shutdown => eio_checkpoints_shutdown
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_shutdown (eio)
class(eio_checkpoints_t), intent(inout) :: eio
if (mod (eio%i_evt, eio%val) /= 0) then
write (msg_buffer, checkpoint_fmt) &
100., eio%i_evt - eio%n_read, 0, "0m:00s"
call msg_message ()
end if
call msg_message (checkpoint_bar)
call msg_message ("")
eio%running = .false.
end subroutine eio_checkpoints_shutdown
@ %def eio_checkpoints_shutdown
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: input_i_prc => eio_checkpoints_input_i_prc
procedure :: input_event => eio_checkpoints_input_event
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_input_i_prc (eio, i_prc, iostat)
class(eio_checkpoints_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
call msg_bug ("Event checkpoints: event input not supported")
i_prc = 0
iostat = 1
end subroutine eio_checkpoints_input_i_prc
subroutine eio_checkpoints_input_event (eio, event, iostat)
class(eio_checkpoints_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
call msg_bug ("Event checkpoints: event input not supported")
iostat = 1
end subroutine eio_checkpoints_input_event
@ %def eio_checkpoints_input_i_prc
@ %def eio_checkpoints_input_event
@
<<EIO checkpoints: eio checkpoints: TBP>>=
procedure :: skip => eio_checkpoints_skip
<<EIO checkpoints: procedures>>=
subroutine eio_checkpoints_skip (eio, iostat)
class(eio_checkpoints_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_checkpoints_skip
@ %def eio_checkpoints_skip
@
\subsection{Message header}
<<EIO checkpoints: parameters>>=
character(*), parameter :: &
checkpoint_head = "| % complete | events generated | events remaining &
&| time remaining"
character(*), parameter :: &
checkpoint_bar = "|==================================================&
&=================|"
character(*), parameter :: &
checkpoint_fmt = "(' ',F5.1,T16,I9,T35,I9,T58,A)"
@ %def checkpoint_head
@ %def checkpoint_bar
@ %def checkpoint_fmt
@ %def checkpointing_t
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_checkpoints_ut.f90]]>>=
<<File header>>
module eio_checkpoints_ut
use unit_tests
use eio_checkpoints_uti
<<Standard module head>>
<<EIO checkpoints: public test>>
contains
<<EIO checkpoints: test driver>>
end module eio_checkpoints_ut
@ %def eio_checkpoints_ut
@
<<[[eio_checkpoints_uti.f90]]>>=
<<File header>>
module eio_checkpoints_uti
<<Use kinds>>
<<Use strings>>
use event_base
use eio_data
use eio_base
use eio_checkpoints
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
<<Standard module head>>
<<EIO checkpoints: test declarations>>
contains
<<EIO checkpoints: tests>>
end module eio_checkpoints_uti
@ %def eio_checkpoints_ut
@ API: driver for the unit tests below.
<<EIO checkpoints: public test>>=
public :: eio_checkpoints_test
<<EIO checkpoints: test driver>>=
subroutine eio_checkpoints_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO checkpoints: execute tests>>
end subroutine eio_checkpoints_test
@ %def eio_checkpoints_test
@
\subsubsection{Test I/O methods}
We test the implementation of all I/O methods.
<<EIO checkpoints: execute tests>>=
call test (eio_checkpoints_1, "eio_checkpoints_1", &
"read and write event contents", &
u, results)
<<EIO checkpoints: test declarations>>=
public :: eio_checkpoints_1
<<EIO checkpoints: tests>>=
subroutine eio_checkpoints_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
class(eio_t), allocatable :: eio
type(event_sample_data_t) :: data
type(string_t) :: sample
integer :: i, n_events
write (u, "(A)") "* Test output: eio_checkpoints_1"
write (u, "(A)") "* Purpose: generate a number of events &
&with screen output"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event)
write (u, "(A)")
write (u, "(A)") "* Generate events"
write (u, "(A)")
sample = "eio_checkpoints_1"
allocate (eio_checkpoints_t :: eio)
n_events = 10
call data%init (1, 0)
data%n_evt = n_events
select type (eio)
type is (eio_checkpoints_t)
call eio%set_parameters (checkpoint = 4)
end select
call eio%init_out (sample, data)
do i = 1, n_events
call event%generate (1, [0._default, 0._default])
call eio%output (event, i_prc = 0)
end do
write (u, "(A)") "* Checkpointing status"
write (u, "(A)")
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_checkpoints_1"
end subroutine eio_checkpoints_1
@ %def eio_checkpoints_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Event Generation Callback}
This is an output-only format. Its only use is to write screen
messages every $n$ events, to inform the user about progress.
<<[[eio_callback.f90]]>>=
<<File header>>
module eio_callback
use kinds, only: i64
<<Use strings>>
use io_units
use diagnostics
use cputime
use event_base
use eio_data
use eio_base
<<Standard module head>>
<<EIO callback: public>>
<<EIO callback: types>>
contains
<<EIO callback: procedures>>
end module eio_callback
@ %def eio_callback
@
\subsection{Type}
<<EIO callback: public>>=
public :: eio_callback_t
<<EIO callback: types>>=
type, extends (eio_t) :: eio_callback_t
class(event_callback_t), allocatable :: callback
integer(i64) :: i_evt = 0
integer :: i_interval = 0
integer :: n_interval = 0
! type(timer_t) :: timer
contains
<<EIO callback: eio callback: TBP>>
end type eio_callback_t
@ %def eio_callback_t
@
\subsection{Specific Methods}
Set parameters that are specifically used for callback: the procedure
and the number of events to wait until the procedure is called (again).
<<EIO callback: eio callback: TBP>>=
procedure :: set_parameters => eio_callback_set_parameters
<<EIO callback: procedures>>=
subroutine eio_callback_set_parameters (eio, callback, count_interval)
class(eio_callback_t), intent(inout) :: eio
class(event_callback_t), intent(in) :: callback
integer, intent(in) :: count_interval
allocate (eio%callback, source = callback)
eio%n_interval = count_interval
end subroutine eio_callback_set_parameters
@ %def eio_callback_set_parameters
@
\subsection{Common Methods}
Output. This is not the actual event format, but a readable account
of the current status.
<<EIO callback: eio callback: TBP>>=
procedure :: write => eio_callback_write
<<EIO callback: procedures>>=
subroutine eio_callback_write (object, unit)
class(eio_callback_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Event-sample callback:"
write (u, "(3x,A,I0)") "interval = ", object%n_interval
write (u, "(3x,A,I0)") "evt count = ", object%i_evt
! call object%timer%write (u)
end subroutine eio_callback_write
@ %def eio_callback_write
@ Finalizer: trivial.
<<EIO callback: eio callback: TBP>>=
procedure :: final => eio_callback_final
<<EIO callback: procedures>>=
subroutine eio_callback_final (object)
class(eio_callback_t), intent(inout) :: object
end subroutine eio_callback_final
@ %def eio_callback_final
@ Activate checkpointing for event generation or writing.
<<EIO callback: eio callback: TBP>>=
procedure :: init_out => eio_callback_init_out
<<EIO callback: procedures>>=
subroutine eio_callback_init_out (eio, sample, data, success, extension)
class(eio_callback_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
eio%i_evt = 0
eiO%i_interval = 0
if (present (success)) success = .true.
end subroutine eio_callback_init_out
@ %def eio_callback_init_out
@ No callback for event reading.
<<EIO callback: eio callback: TBP>>=
procedure :: init_in => eio_callback_init_in
<<EIO callback: procedures>>=
subroutine eio_callback_init_in (eio, sample, data, success, extension)
class(eio_callback_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
call msg_bug ("Event callback: event input not supported")
if (present (success)) success = .false.
end subroutine eio_callback_init_in
@ %def eio_callback_init_in
@ Switch from input to output: also not supported.
<<EIO callback: eio callback: TBP>>=
procedure :: switch_inout => eio_callback_switch_inout
<<EIO callback: procedures>>=
subroutine eio_callback_switch_inout (eio, success)
class(eio_callback_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("Event callback: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_callback_switch_inout
@ %def eio_callback_switch_inout
@ The actual callback. First increment counters, then call the
procedure if the counter hits the interval.
<<EIO callback: eio callback: TBP>>=
procedure :: output => eio_callback_output
<<EIO callback: procedures>>=
subroutine eio_callback_output (eio, event, i_prc, reading, passed, pacify)
class(eio_callback_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
eio%i_evt = eio%i_evt + 1
if (eio%n_interval > 0) then
eio%i_interval = eio%i_interval + 1
if (eio%i_interval >= eio%n_interval) then
call eio%callback%proc (eio%i_evt, event)
eio%i_interval = 0
end if
end if
end subroutine eio_callback_output
@ %def eio_callback_output
@ No input.
<<EIO callback: eio callback: TBP>>=
procedure :: input_i_prc => eio_callback_input_i_prc
procedure :: input_event => eio_callback_input_event
<<EIO callback: procedures>>=
subroutine eio_callback_input_i_prc (eio, i_prc, iostat)
class(eio_callback_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
call msg_bug ("Event callback: event input not supported")
i_prc = 0
iostat = 1
end subroutine eio_callback_input_i_prc
subroutine eio_callback_input_event (eio, event, iostat)
class(eio_callback_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
call msg_bug ("Event callback: event input not supported")
iostat = 1
end subroutine eio_callback_input_event
@ %def eio_callback_input_i_prc
@ %def eio_callback_input_event
@
<<EIO callback: eio callback: TBP>>=
procedure :: skip => eio_callback_skip
<<EIO callback: procedures>>=
subroutine eio_callback_skip (eio, iostat)
class(eio_callback_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_callback_skip
@ %def eio_callback_skip
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Event Weight Output}
This is an output-only format. For each event, we print the indices
that identify process, process part (MCI group), and term. As
numerical information we print the squared matrix element (trace) and
the event weight.
<<[[eio_weights.f90]]>>=
<<File header>>
module eio_weights
<<Use kinds>>
<<Use strings>>
use io_units
use diagnostics
use event_base
use eio_data
use eio_base
<<Standard module head>>
<<EIO weights: public>>
<<EIO weights: types>>
contains
<<EIO weights: procedures>>
end module eio_weights
@ %def eio_weights
@
\subsection{Type}
<<EIO weights: public>>=
public :: eio_weights_t
<<EIO weights: types>>=
type, extends (eio_t) :: eio_weights_t
logical :: writing = .false.
integer :: unit = 0
logical :: pacify = .false.
contains
<<EIO weights: eio weights: TBP>>
end type eio_weights_t
@ %def eio_weights_t
@
\subsection{Specific Methods}
Set pacify flags.
<<EIO weights: eio weights: TBP>>=
procedure :: set_parameters => eio_weights_set_parameters
<<EIO weights: procedures>>=
subroutine eio_weights_set_parameters (eio, pacify)
class(eio_weights_t), intent(inout) :: eio
logical, intent(in), optional :: pacify
if (present (pacify)) eio%pacify = pacify
eio%extension = "weights.dat"
end subroutine eio_weights_set_parameters
@ %def eio_weights_set_parameters
@
\subsection{Common Methods}
@ Output. This is not the actual event format, but a readable account
of the current object status.
<<EIO weights: eio weights: TBP>>=
procedure :: write => eio_weights_write
<<EIO weights: procedures>>=
subroutine eio_weights_write (object, unit)
class(eio_weights_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Weight stream:"
if (object%writing) then
write (u, "(3x,A,A)") "Writing to file = ", char (object%filename)
write (u, "(3x,A,L1)") "Reduced I/O prec. = ", object%pacify
else
write (u, "(3x,A)") "[closed]"
end if
end subroutine eio_weights_write
@ %def eio_weights_write
@ Finalizer: close any open file.
<<EIO weights: eio weights: TBP>>=
procedure :: final => eio_weights_final
<<EIO weights: procedures>>=
subroutine eio_weights_final (object)
class(eio_weights_t), intent(inout) :: object
if (object%writing) then
write (msg_buffer, "(A,A,A)") "Events: closing weight stream file '", &
char (object%filename), "'"
call msg_message ()
close (object%unit)
object%writing = .false.
end if
end subroutine eio_weights_final
@ %def eio_weights_final
@ Initialize event writing.
<<EIO weights: eio weights: TBP>>=
procedure :: init_out => eio_weights_init_out
<<EIO weights: procedures>>=
subroutine eio_weights_init_out (eio, sample, data, success, extension)
class(eio_weights_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
if (present(extension)) then
eio%extension = extension
else
eio%extension = "weights.dat"
end if
eio%filename = sample // "." // eio%extension
eio%unit = free_unit ()
write (msg_buffer, "(A,A,A)") "Events: writing to weight stream file '", &
char (eio%filename), "'"
call msg_message ()
eio%writing = .true.
open (eio%unit, file = char (eio%filename), &
action = "write", status = "replace")
if (present (success)) success = .true.
end subroutine eio_weights_init_out
@ %def eio_weights_init_out
@ Initialize event reading.
<<EIO weights: eio weights: TBP>>=
procedure :: init_in => eio_weights_init_in
<<EIO weights: procedures>>=
subroutine eio_weights_init_in (eio, sample, data, success, extension)
class(eio_weights_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
call msg_bug ("Weight stream: event input not supported")
if (present (success)) success = .false.
end subroutine eio_weights_init_in
@ %def eio_weights_init_in
@ Switch from input to output: reopen the file for reading.
<<EIO weights: eio weights: TBP>>=
procedure :: switch_inout => eio_weights_switch_inout
<<EIO weights: procedures>>=
subroutine eio_weights_switch_inout (eio, success)
class(eio_weights_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("Weight stream: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_weights_switch_inout
@ %def eio_weights_switch_inout
@ Output an event. Write first the event indices, then weight and two
values of the squared matrix element: [[sqme_ref]] is the value stored
in the event record, and [[sqme_prc]] is the one stored in the process
instance. (They can differ: when recalculating, the former is read
from file and the latter is the result of the new calculation.)
For the alternative entries, the [[sqme]] value is always obtained by
a new calculation, and thus qualifies as [[sqme_prc]].
Don't write the file if the [[passed]] flag is set and false.
<<EIO weights: eio weights: TBP>>=
procedure :: output => eio_weights_output
<<EIO weights: procedures>>=
subroutine eio_weights_output (eio, event, i_prc, reading, passed, pacify)
class(eio_weights_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
integer :: n_alt, i
real(default) :: weight, sqme_ref, sqme_prc
logical :: evt_pacify, evt_passed
evt_pacify = eio%pacify; if (present (pacify)) evt_pacify = pacify
evt_passed = .true.; if (present (passed)) evt_passed = passed
if (eio%writing) then
if (evt_passed) then
weight = event%get_weight_prc ()
sqme_ref = event%get_sqme_ref ()
sqme_prc = event%get_sqme_prc ()
n_alt = event%get_n_alt ()
1 format (I0,3(1x,ES17.10),3(1x,I0))
2 format (I0,3(1x,ES15.8),3(1x,I0))
if (evt_pacify) then
write (eio%unit, 2) 0, weight, sqme_prc, sqme_ref, &
i_prc
else
write (eio%unit, 1) 0, weight, sqme_prc, sqme_ref, &
i_prc
end if
do i = 1, n_alt
weight = event%get_weight_alt(i)
sqme_prc = event%get_sqme_alt(i)
if (evt_pacify) then
write (eio%unit, 2) i, weight, sqme_prc
else
write (eio%unit, 1) i, weight, sqme_prc
end if
end do
end if
else
call eio%write ()
call msg_fatal ("Weight stream file is not open for writing")
end if
end subroutine eio_weights_output
@ %def eio_weights_output
@ Input an event.
<<EIO weights: eio weights: TBP>>=
procedure :: input_i_prc => eio_weights_input_i_prc
procedure :: input_event => eio_weights_input_event
<<EIO weights: procedures>>=
subroutine eio_weights_input_i_prc (eio, i_prc, iostat)
class(eio_weights_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
call msg_bug ("Weight stream: event input not supported")
i_prc = 0
iostat = 1
end subroutine eio_weights_input_i_prc
subroutine eio_weights_input_event (eio, event, iostat)
class(eio_weights_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
call msg_bug ("Weight stream: event input not supported")
iostat = 1
end subroutine eio_weights_input_event
@ %def eio_weights_input_i_prc
@ %def eio_weights_input_event
@
<<EIO weights: eio weights: TBP>>=
procedure :: skip => eio_weights_skip
<<EIO weights: procedures>>=
subroutine eio_weights_skip (eio, iostat)
class(eio_weights_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_weights_skip
@ %def eio_weights_skip
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_weights_ut.f90]]>>=
<<File header>>
module eio_weights_ut
use unit_tests
use eio_weights_uti
<<Standard module head>>
<<EIO weights: public test>>
contains
<<EIO weights: test driver>>
end module eio_weights_ut
@ %def eio_weights_ut
@
<<[[eio_weights_uti.f90]]>>=
<<File header>>
module eio_weights_uti
<<Use kinds>>
<<Use strings>>
use io_units
use event_base
use eio_data
use eio_base
use eio_weights
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
<<Standard module head>>
<<EIO weights: test declarations>>
contains
<<EIO weights: tests>>
end module eio_weights_uti
@ %def eio_weights_ut
@ API: driver for the unit tests below.
<<EIO weights: public test>>=
public :: eio_weights_test
<<EIO weights: test driver>>=
subroutine eio_weights_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO weights: execute tests>>
end subroutine eio_weights_test
@ %def eio_weights_test
@
\subsubsection{Simple event}
We test the implementation of all I/O methods.
<<EIO weights: execute tests>>=
call test (eio_weights_1, "eio_weights_1", &
"read and write event contents", &
u, results)
<<EIO weights: test declarations>>=
public :: eio_weights_1
<<EIO weights: tests>>=
subroutine eio_weights_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file
character(80) :: buffer
write (u, "(A)") "* Test output: eio_weights_1"
write (u, "(A)") "* Purpose: generate an event and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_weights_1"
allocate (eio_weights_t :: eio)
call eio%init_out (sample)
call event%generate (1, [0._default, 0._default])
call eio%output (event, i_prc = 42)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents: &
&(weight, sqme(evt), sqme(prc), i_prc)"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = "eio_weights_1.weights.dat", &
action = "read", status = "old")
read (u_file, "(A)") buffer
write (u, "(A)") trim (buffer)
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_weights_1"
end subroutine eio_weights_1
@ %def eio_weights_1
@
\subsubsection{Multiple weights}
Event with several weight entries set.
<<EIO weights: execute tests>>=
call test (eio_weights_2, "eio_weights_2", &
"multiple weights", &
u, results)
<<EIO weights: test declarations>>=
public :: eio_weights_2
<<EIO weights: tests>>=
subroutine eio_weights_2 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, i
character(80) :: buffer
write (u, "(A)") "* Test output: eio_weights_2"
write (u, "(A)") "* Purpose: generate an event and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false., n_alt = 2)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_weights_2"
allocate (eio_weights_t :: eio)
call eio%init_out (sample)
select type (eio)
type is (eio_weights_t)
call eio%set_parameters (pacify = .true.)
end select
call event%generate (1, [0._default, 0._default])
call event%set (sqme_alt = [2._default, 3._default])
call event%set (weight_alt = &
[2 * event%get_weight_prc (), 3 * event%get_weight_prc ()])
call eio%output (event, i_prc = 42)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents: &
&(weight, sqme(evt), sqme(prc), i_prc)"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = "eio_weights_2.weights.dat", &
action = "read", status = "old")
do i = 1, 3
read (u_file, "(A)") buffer
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_weights_2"
end subroutine eio_weights_2
@ %def eio_weights_2
@
\subsubsection{Multiple events}
Events with [[passed]] flag switched on/off.
<<EIO weights: execute tests>>=
call test (eio_weights_3, "eio_weights_3", &
"check passed-flag", &
u, results)
<<EIO weights: test declarations>>=
public :: eio_weights_3
<<EIO weights: tests>>=
subroutine eio_weights_3 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_weights_3"
write (u, "(A)") "* Purpose: generate three events and write to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
write (u, "(A)")
write (u, "(A)") "* Generate and write events"
write (u, "(A)")
sample = "eio_weights_3"
allocate (eio_weights_t :: eio)
select type (eio)
type is (eio_weights_t)
call eio%set_parameters (pacify = .true.)
end select
call eio%init_out (sample)
call event%generate (1, [0._default, 0._default])
call eio%output (event, i_prc = 1)
call event%generate (1, [0.1_default, 0._default])
call eio%output (event, i_prc = 1, passed = .false.)
call event%generate (1, [0.2_default, 0._default])
call eio%output (event, i_prc = 1, passed = .true.)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents: &
&(weight, sqme(evt), sqme(prc), i_prc), should be just two entries"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = "eio_weights_3.weights.dat", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat=iostat) buffer
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_weights_3"
end subroutine eio_weights_3
@ %def eio_weights_3
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Event Dump Output}
This is an output-only format. We simply dump the contents of the
[[particle_set]], using the [[write]] method of that type. The
event-format options are the options of that procedure.
<<[[eio_dump.f90]]>>=
<<File header>>
module eio_dump
use, intrinsic :: iso_fortran_env, only: output_unit
use kinds, only: i64
<<Use strings>>
use format_utils, only: write_separator
use format_utils, only: pac_fmt
use format_defs, only: FMT_16, FMT_19
use io_units
use diagnostics
use event_base
use eio_data
use eio_base
<<Standard module head>>
<<EIO dump: public>>
<<EIO dump: types>>
contains
<<EIO dump: procedures>>
end module eio_dump
@ %def eio_dump
@
\subsection{Type}
<<EIO dump: public>>=
public :: eio_dump_t
<<EIO dump: types>>=
type, extends (eio_t) :: eio_dump_t
integer(i64) :: count = 0
integer :: unit = 0
logical :: writing = .false.
logical :: screen = .false.
logical :: pacify = .false.
logical :: weights = .false.
logical :: compressed = .false.
logical :: summary = .false.
contains
<<EIO dump: eio dump: TBP>>
end type eio_dump_t
@ %def eio_dump_t
@
\subsection{Specific Methods}
Set control parameters. We may provide a [[unit]] for input or output; this
will be taken if the sample file name is empty. In that case, the unit is
assumed to be open and will be kept open; no messages will be issued.
<<EIO dump: eio dump: TBP>>=
procedure :: set_parameters => eio_dump_set_parameters
<<EIO dump: procedures>>=
subroutine eio_dump_set_parameters (eio, extension, &
pacify, weights, compressed, summary, screen, unit)
class(eio_dump_t), intent(inout) :: eio
type(string_t), intent(in), optional :: extension
logical, intent(in), optional :: pacify
logical, intent(in), optional :: weights
logical, intent(in), optional :: compressed
logical, intent(in), optional :: summary
logical, intent(in), optional :: screen
integer, intent(in), optional :: unit
if (present (pacify)) eio%pacify = pacify
if (present (weights)) eio%weights = weights
if (present (compressed)) eio%compressed = compressed
if (present (summary)) eio%summary = summary
if (present (screen)) eio%screen = screen
if (present (unit)) eio%unit = unit
eio%extension = "pset.dat"
if (present (extension)) eio%extension = extension
end subroutine eio_dump_set_parameters
@ %def eio_dump_set_parameters
@
\subsection{Common Methods}
@ Output. This is not the actual event format, but a readable account
of the current object status.
<<EIO dump: eio dump: TBP>>=
procedure :: write => eio_dump_write
<<EIO dump: procedures>>=
subroutine eio_dump_write (object, unit)
class(eio_dump_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
write (u, "(1x,A)") "Dump event stream:"
if (object%writing) then
write (u, "(3x,A,L1)") "Screen output = ", object%screen
write (u, "(3x,A,A,A)") "Writing to file = '", char (object%filename), "'"
write (u, "(3x,A,L1)") "Reduced I/O prec. = ", object%pacify
write (u, "(3x,A,L1)") "Show weights/sqme = ", object%weights
write (u, "(3x,A,L1)") "Compressed = ", object%compressed
write (u, "(3x,A,L1)") "Summary = ", object%summary
else
write (u, "(3x,A)") "[closed]"
end if
end subroutine eio_dump_write
@ %def eio_dump_write
@ Finalizer: close any open file.
<<EIO dump: eio dump: TBP>>=
procedure :: final => eio_dump_final
<<EIO dump: procedures>>=
subroutine eio_dump_final (object)
class(eio_dump_t), intent(inout) :: object
if (object%screen) then
write (msg_buffer, "(A,A,A)") "Events: display complete"
call msg_message ()
object%screen = .false.
end if
if (object%writing) then
if (object%filename /= "") then
write (msg_buffer, "(A,A,A)") "Events: closing event dump file '", &
char (object%filename), "'"
call msg_message ()
close (object%unit)
end if
object%writing = .false.
end if
end subroutine eio_dump_final
@ %def eio_dump_final
@ Initialize event writing.
<<EIO dump: eio dump: TBP>>=
procedure :: init_out => eio_dump_init_out
<<EIO dump: procedures>>=
subroutine eio_dump_init_out (eio, sample, data, success, extension)
class(eio_dump_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
if (present(extension)) then
eio%extension = extension
else
eio%extension = "pset.dat"
end if
if (sample == "" .and. eio%unit /= 0) then
eio%filename = ""
eio%writing = .true.
else if (sample /= "") then
eio%filename = sample // "." // eio%extension
eio%unit = free_unit ()
write (msg_buffer, "(A,A,A)") "Events: writing to event dump file '", &
char (eio%filename), "'"
call msg_message ()
eio%writing = .true.
open (eio%unit, file = char (eio%filename), &
action = "write", status = "replace")
end if
if (eio%screen) then
write (msg_buffer, "(A,A,A)") "Events: display on standard output"
call msg_message ()
end if
eio%count = 0
if (present (success)) success = .true.
end subroutine eio_dump_init_out
@ %def eio_dump_init_out
@ Initialize event reading.
<<EIO dump: eio dump: TBP>>=
procedure :: init_in => eio_dump_init_in
<<EIO dump: procedures>>=
subroutine eio_dump_init_in (eio, sample, data, success, extension)
class(eio_dump_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
call msg_bug ("Event dump: event input not supported")
if (present (success)) success = .false.
end subroutine eio_dump_init_in
@ %def eio_dump_init_in
@ Switch from input to output: reopen the file for reading.
<<EIO dump: eio dump: TBP>>=
procedure :: switch_inout => eio_dump_switch_inout
<<EIO dump: procedures>>=
subroutine eio_dump_switch_inout (eio, success)
class(eio_dump_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("Event dump: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_dump_switch_inout
@ %def eio_dump_switch_inout
@ Output an event. Delegate the output call to the [[write]] method
of the current particle set, if valid. Output both to file (if defined)
and to screen (if requested).
<<EIO dump: eio dump: TBP>>=
procedure :: output => eio_dump_output
<<EIO dump: procedures>>=
subroutine eio_dump_output (eio, event, i_prc, reading, passed, pacify)
class(eio_dump_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
character(len=7) :: fmt
eio%count = eio%count + 1
if (present (pacify)) then
call pac_fmt (fmt, FMT_19, FMT_16, pacify)
else
call pac_fmt (fmt, FMT_19, FMT_16, eio%pacify)
end if
if (eio%writing) call dump (eio%unit)
if (eio%screen) then
call dump (output_unit)
if (logfile_unit () > 0) call dump (logfile_unit ())
end if
contains
subroutine dump (u)
integer, intent(in) :: u
integer :: i
call write_separator (u, 2)
write (u, "(1x,A,I0)", advance="no") "Event"
if (event%has_index ()) then
write (u, "(1x,'#',I0)") event%get_index ()
else
write (u, *)
end if
call write_separator (u, 2)
write (u, "(1x,A,1x,I0)") "count =", eio%count
if (present (passed)) then
write (u, "(1x,A,1x,L1)") "passed =", passed
else
write (u, "(1x,A)") "passed = [N/A]"
end if
write (u, "(1x,A,1x,I0)") "prc id =", i_prc
if (eio%weights) then
call write_separator (u)
if (event%sqme_ref_known) then
write (u, "(1x,A," // fmt // ")") "sqme (ref) = ", &
event%sqme_ref
else
write (u, "(1x,A)") "sqme (ref) = [undefined]"
end if
if (event%sqme_prc_known) then
write (u, "(1x,A," // fmt // ")") "sqme (prc) = ", &
event%sqme_prc
else
write (u, "(1x,A)") "sqme (prc) = [undefined]"
end if
if (event%weight_ref_known) then
write (u, "(1x,A," // fmt // ")") "weight (ref) = ", &
event%weight_ref
else
write (u, "(1x,A)") "weight (ref) = [undefined]"
end if
if (event%weight_prc_known) then
write (u, "(1x,A," // fmt // ")") "weight (prc) = ", &
event%weight_prc
else
write (u, "(1x,A)") "weight (prc) = [undefined]"
end if
if (event%excess_prc_known) then
write (u, "(1x,A," // fmt // ")") "excess (prc) = ", &
event%excess_prc
else
write (u, "(1x,A)") "excess (prc) = [undefined]"
end if
do i = 1, event%n_alt
if (event%sqme_ref_known) then
write (u, "(1x,A,I0,A," // fmt // ")") "sqme (", i, ") = ",&
event%sqme_prc
else
write (u, "(1x,A,I0,A)") "sqme (", i, ") = [undefined]"
end if
if (event%weight_prc_known) then
write (u, "(1x,A,I0,A," // fmt // ")") "weight (", i, ") = ",&
event%weight_prc
else
write (u, "(1x,A,I0,A)") "weight (", i, ") = [undefined]"
end if
end do
end if
call write_separator (u)
if (event%particle_set_is_valid) then
call event%particle_set%write (unit = u, &
summary = eio%summary, compressed = eio%compressed, &
testflag = eio%pacify)
else
write (u, "(1x,A)") "Particle set: [invalid]"
end if
end subroutine dump
end subroutine eio_dump_output
@ %def eio_dump_output
@ Input an event.
<<EIO dump: eio dump: TBP>>=
procedure :: input_i_prc => eio_dump_input_i_prc
procedure :: input_event => eio_dump_input_event
<<EIO dump: procedures>>=
subroutine eio_dump_input_i_prc (eio, i_prc, iostat)
class(eio_dump_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
call msg_bug ("Dump stream: event input not supported")
i_prc = 0
iostat = 1
end subroutine eio_dump_input_i_prc
subroutine eio_dump_input_event (eio, event, iostat)
class(eio_dump_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
call msg_bug ("Dump stream: event input not supported")
iostat = 1
end subroutine eio_dump_input_event
@ %def eio_dump_input_i_prc
@ %def eio_dump_input_event
@
<<EIO dump: eio dump: TBP>>=
procedure :: skip => eio_dump_skip
<<EIO dump: procedures>>=
subroutine eio_dump_skip (eio, iostat)
class(eio_dump_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_dump_skip
@ %def eio_dump_skip
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_dump_ut.f90]]>>=
<<File header>>
module eio_dump_ut
use unit_tests
use eio_dump_uti
<<Standard module head>>
<<EIO dump: public test>>
contains
<<EIO dump: test driver>>
end module eio_dump_ut
@ %def eio_dump_ut
@
<<[[eio_dump_uti.f90]]>>=
<<File header>>
module eio_dump_uti
<<Use kinds>>
<<Use strings>>
use io_units
use event_base
use eio_data
use eio_base
use eio_dump
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
<<Standard module head>>
<<EIO dump: test declarations>>
contains
<<EIO dump: tests>>
end module eio_dump_uti
@ %def eio_dump_ut
@ API: driver for the unit tests below.
<<EIO dump: public test>>=
public :: eio_dump_test
<<EIO dump: test driver>>=
subroutine eio_dump_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO dump: execute tests>>
end subroutine eio_dump_test
@ %def eio_dump_test
@
\subsubsection{Test I/O methods}
We test the implementation of all I/O methods.
<<EIO dump: execute tests>>=
call test (eio_dump_1, "eio_dump_1", &
"write event contents", &
u, results)
<<EIO dump: test declarations>>=
public :: eio_dump_1
<<EIO dump: tests>>=
subroutine eio_dump_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
class(eio_t), allocatable :: eio
integer :: i_prc
integer :: u_file
write (u, "(A)") "* Test output: eio_dump_1"
write (u, "(A)") "* Purpose: generate events and write essentials to output"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
write (u, "(A)")
write (u, "(A)") "* Generate and write three events (two passed)"
write (u, "(A)")
allocate (eio_dump_t :: eio)
select type (eio)
type is (eio_dump_t)
call eio%set_parameters (unit = u, weights = .true., pacify = .true.)
end select
i_prc = 42
call eio%init_out (var_str (""))
call event%generate (1, [0._default, 0._default])
call eio%output (event, i_prc = i_prc)
call event%generate (1, [0.1_default, 0._default])
call event%set_index (99)
call eio%output (event, i_prc = i_prc, passed = .false.)
call event%generate (1, [0.2_default, 0._default])
call event%increment_index ()
call eio%output (event, i_prc = i_prc, passed = .true.)
write (u, "(A)")
write (u, "(A)") "* Contents of eio_dump object"
write (u, "(A)")
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
select type (eio)
type is (eio_dump_t)
eio%writing = .false.
end select
call eio%final ()
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_dump_1"
end subroutine eio_dump_1
@ %def eio_dump_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{ASCII File Formats}
Here, we implement several ASCII file formats. It is possible to
switch between them using flags.
<<[[eio_ascii.f90]]>>=
<<File header>>
module eio_ascii
<<Use strings>>
use io_units
use diagnostics
use event_base
use eio_data
use eio_base
use hep_common
use hep_events
<<Standard module head>>
<<EIO ascii: public>>
<<EIO ascii: types>>
contains
<<EIO ascii: procedures>>
end module eio_ascii
@ %def eio_ascii
@
\subsection{Type}
<<EIO ascii: public>>=
public :: eio_ascii_t
<<EIO ascii: types>>=
type, abstract, extends (eio_t) :: eio_ascii_t
logical :: writing = .false.
integer :: unit = 0
logical :: keep_beams = .false.
logical :: keep_remnants = .true.
logical :: ensure_order = .false.
contains
<<EIO ascii: eio ascii: TBP>>
end type eio_ascii_t
@ %def eio_ascii_t
@
<<EIO ascii: public>>=
public :: eio_ascii_ascii_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_ascii_t
end type eio_ascii_ascii_t
@ %def eio_ascii_ascii_t
@
<<EIO ascii: public>>=
public :: eio_ascii_athena_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_athena_t
end type eio_ascii_athena_t
@ %def eio_ascii_athena_t
@ The debug format has a few options that can be controlled by
Sindarin variables.
<<EIO ascii: public>>=
public :: eio_ascii_debug_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_debug_t
logical :: show_process = .true.
logical :: show_transforms = .true.
logical :: show_decay = .true.
logical :: verbose = .true.
end type eio_ascii_debug_t
@ %def eio_ascii_debug_t
@
<<EIO ascii: public>>=
public :: eio_ascii_hepevt_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_hepevt_t
end type eio_ascii_hepevt_t
@ %def eio_ascii_hepevt_t
@
<<EIO ascii: public>>=
public :: eio_ascii_hepevt_verb_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_hepevt_verb_t
end type eio_ascii_hepevt_verb_t
@ %def eio_ascii_hepevt_verb_t
@
<<EIO ascii: public>>=
public :: eio_ascii_lha_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_lha_t
end type eio_ascii_lha_t
@ %def eio_ascii_lha_t
@
<<EIO ascii: public>>=
public :: eio_ascii_lha_verb_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_lha_verb_t
end type eio_ascii_lha_verb_t
@ %def eio_ascii_lha_verb_t
@
<<EIO ascii: public>>=
public :: eio_ascii_long_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_long_t
end type eio_ascii_long_t
@ %def eio_ascii_long_t
@
<<EIO ascii: public>>=
public :: eio_ascii_mokka_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_mokka_t
end type eio_ascii_mokka_t
@ %def eio_ascii_mokka_t
@
<<EIO ascii: public>>=
public :: eio_ascii_short_t
<<EIO ascii: types>>=
type, extends (eio_ascii_t) :: eio_ascii_short_t
end type eio_ascii_short_t
@ %def eio_ascii_short_t
@
\subsection{Specific Methods}
Set parameters that are specifically used with ASCII file formats. In
particular, this is the file extension.
<<EIO ascii: eio ascii: TBP>>=
procedure :: set_parameters => eio_ascii_set_parameters
<<EIO ascii: procedures>>=
subroutine eio_ascii_set_parameters (eio, &
keep_beams, keep_remnants, ensure_order, extension, &
show_process, show_transforms, show_decay, verbose)
class(eio_ascii_t), intent(inout) :: eio
logical, intent(in), optional :: keep_beams
logical, intent(in), optional :: keep_remnants
logical, intent(in), optional :: ensure_order
type(string_t), intent(in), optional :: extension
logical, intent(in), optional :: show_process, show_transforms, show_decay
logical, intent(in), optional :: verbose
if (present (keep_beams)) eio%keep_beams = keep_beams
if (present (keep_remnants)) eio%keep_remnants = keep_remnants
if (present (ensure_order)) eio%ensure_order = ensure_order
if (present (extension)) then
eio%extension = extension
else
select type (eio)
type is (eio_ascii_ascii_t)
eio%extension = "evt"
type is (eio_ascii_athena_t)
eio%extension = "athena.evt"
type is (eio_ascii_debug_t)
eio%extension = "debug"
type is (eio_ascii_hepevt_t)
eio%extension = "hepevt"
type is (eio_ascii_hepevt_verb_t)
eio%extension = "hepevt.verb"
type is (eio_ascii_lha_t)
eio%extension = "lha"
type is (eio_ascii_lha_verb_t)
eio%extension = "lha.verb"
type is (eio_ascii_long_t)
eio%extension = "long.evt"
type is (eio_ascii_mokka_t)
eio%extension = "mokka.evt"
type is (eio_ascii_short_t)
eio%extension = "short.evt"
end select
end if
select type (eio)
type is (eio_ascii_debug_t)
if (present (show_process)) eio%show_process = show_process
if (present (show_transforms)) eio%show_transforms = show_transforms
if (present (show_decay)) eio%show_decay = show_decay
if (present (verbose)) eio%verbose = verbose
end select
end subroutine eio_ascii_set_parameters
@ %def eio_ascii_set_parameters
@
\subsection{Common Methods}
Output. This is not the actual event format, but a readable account
of the current object status.
<<EIO ascii: eio ascii: TBP>>=
procedure :: write => eio_ascii_write
<<EIO ascii: procedures>>=
subroutine eio_ascii_write (object, unit)
class(eio_ascii_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit)
select type (object)
type is (eio_ascii_ascii_t)
write (u, "(1x,A)") "ASCII event stream (default format):"
type is (eio_ascii_athena_t)
write (u, "(1x,A)") "ASCII event stream (ATHENA format):"
type is (eio_ascii_debug_t)
write (u, "(1x,A)") "ASCII event stream (Debugging format):"
type is (eio_ascii_hepevt_t)
write (u, "(1x,A)") "ASCII event stream (HEPEVT format):"
type is (eio_ascii_hepevt_verb_t)
write (u, "(1x,A)") "ASCII event stream (verbose HEPEVT format):"
type is (eio_ascii_lha_t)
write (u, "(1x,A)") "ASCII event stream (LHA format):"
type is (eio_ascii_lha_verb_t)
write (u, "(1x,A)") "ASCII event stream (verbose LHA format):"
type is (eio_ascii_long_t)
write (u, "(1x,A)") "ASCII event stream (long format):"
type is (eio_ascii_mokka_t)
write (u, "(1x,A)") "ASCII event stream (MOKKA format):"
type is (eio_ascii_short_t)
write (u, "(1x,A)") "ASCII event stream (short format):"
end select
if (object%writing) then
write (u, "(3x,A,A)") "Writing to file = ", char (object%filename)
else
write (u, "(3x,A)") "[closed]"
end if
write (u, "(3x,A,L1)") "Keep beams = ", object%keep_beams
write (u, "(3x,A,L1)") "Keep remnants = ", object%keep_remnants
select type (object)
type is (eio_ascii_debug_t)
write (u, "(3x,A,L1)") "Show process = ", object%show_process
write (u, "(3x,A,L1)") "Show transforms = ", object%show_transforms
write (u, "(3x,A,L1)") "Show decay tree = ", object%show_decay
write (u, "(3x,A,L1)") "Verbose output = ", object%verbose
end select
end subroutine eio_ascii_write
@ %def eio_ascii_write
@ Finalizer: close any open file.
<<EIO ascii: eio ascii: TBP>>=
procedure :: final => eio_ascii_final
<<EIO ascii: procedures>>=
subroutine eio_ascii_final (object)
class(eio_ascii_t), intent(inout) :: object
if (object%writing) then
write (msg_buffer, "(A,A,A)") "Events: closing ASCII file '", &
char (object%filename), "'"
call msg_message ()
close (object%unit)
object%writing = .false.
end if
end subroutine eio_ascii_final
@ %def eio_ascii_final
@ Initialize event writing.
Check weight normalization. This applies to all ASCII-type files that
use the HEPRUP common block. We can't allow normalization conventions
that are not covered by the HEPRUP definition.
<<EIO ascii: eio ascii: TBP>>=
procedure :: init_out => eio_ascii_init_out
<<EIO ascii: procedures>>=
subroutine eio_ascii_init_out (eio, sample, data, success, extension)
class(eio_ascii_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
integer :: i
if (.not. present (data)) &
call msg_bug ("ASCII initialization: missing data")
if (data%n_beam /= 2) &
call msg_fatal ("ASCII: defined for scattering processes only")
eio%sample = sample
call eio%check_normalization (data)
call eio%set_splitting (data)
call eio%set_filename ()
eio%unit = free_unit ()
write (msg_buffer, "(A,A,A)") "Events: writing to ASCII file '", &
char (eio%filename), "'"
call msg_message ()
eio%writing = .true.
open (eio%unit, file = char (eio%filename), &
action = "write", status = "replace")
select type (eio)
type is (eio_ascii_lha_t)
call heprup_init &
(data%pdg_beam, &
data%energy_beam, &
n_processes = data%n_proc, &
unweighted = data%unweighted, &
negative_weights = data%negative_weights)
do i = 1, data%n_proc
call heprup_set_process_parameters (i = i, &
process_id = data%proc_num_id(i), &
cross_section = data%cross_section(i), &
error = data%error(i))
end do
call heprup_write_ascii (eio%unit)
type is (eio_ascii_lha_verb_t)
call heprup_init &
(data%pdg_beam, &
data%energy_beam, &
n_processes = data%n_proc, &
unweighted = data%unweighted, &
negative_weights = data%negative_weights)
do i = 1, data%n_proc
call heprup_set_process_parameters (i = i, &
process_id = data%proc_num_id(i), &
cross_section = data%cross_section(i), &
error = data%error(i))
end do
call heprup_write_verbose (eio%unit)
end select
if (present (success)) success = .true.
end subroutine eio_ascii_init_out
@ %def eio_ascii_init_out
@ Some event properties do not go well with some output formats. In
particular, many formats require unweighted events.
<<EIO ascii: eio ascii: TBP>>=
procedure :: check_normalization => eio_ascii_check_normalization
<<EIO ascii: procedures>>=
subroutine eio_ascii_check_normalization (eio, data)
class(eio_ascii_t), intent(in) :: eio
type(event_sample_data_t), intent(in) :: data
if (data%unweighted) then
else
select type (eio)
type is (eio_ascii_athena_t); call msg_fatal &
("Event output (Athena format): events must be unweighted.")
type is (eio_ascii_hepevt_t); call msg_fatal &
("Event output (HEPEVT format): events must be unweighted.")
type is (eio_ascii_hepevt_verb_t); call msg_fatal &
("Event output (HEPEVT format): events must be unweighted.")
end select
select case (data%norm_mode)
case (NORM_SIGMA)
case default
select type (eio)
type is (eio_ascii_lha_t)
call msg_fatal &
("Event output (LHA): normalization for weighted events &
&must be 'sigma'")
type is (eio_ascii_lha_verb_t)
call msg_fatal &
("Event output (LHA): normalization for weighted events &
&must be 'sigma'")
end select
end select
end if
end subroutine eio_ascii_check_normalization
@ %def check_normalization
@ Initialize event reading.
<<EIO ascii: eio ascii: TBP>>=
procedure :: init_in => eio_ascii_init_in
<<EIO ascii: procedures>>=
subroutine eio_ascii_init_in (eio, sample, data, success, extension)
class(eio_ascii_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
call msg_bug ("ASCII: event input not supported")
if (present (success)) success = .false.
end subroutine eio_ascii_init_in
@ %def eio_ascii_init_in
@ Switch from input to output: reopen the file for reading.
<<EIO ascii: eio ascii: TBP>>=
procedure :: switch_inout => eio_ascii_switch_inout
<<EIO ascii: procedures>>=
subroutine eio_ascii_switch_inout (eio, success)
class(eio_ascii_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("ASCII: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_ascii_switch_inout
@ %def eio_ascii_switch_inout
@ Split event file: increment the counter, close the current file, open a new
one. If the file needs a header, repeat it for the new file. (We assume that
the common block contents are still intact.)
<<EIO ascii: eio ascii: TBP>>=
procedure :: split_out => eio_ascii_split_out
<<EIO ascii: procedures>>=
subroutine eio_ascii_split_out (eio)
class(eio_ascii_t), intent(inout) :: eio
if (eio%split) then
eio%split_index = eio%split_index + 1
call eio%set_filename ()
write (msg_buffer, "(A,A,A)") "Events: writing to ASCII file '", &
char (eio%filename), "'"
call msg_message ()
close (eio%unit)
open (eio%unit, file = char (eio%filename), &
action = "write", status = "replace")
select type (eio)
type is (eio_ascii_lha_t)
call heprup_write_ascii (eio%unit)
type is (eio_ascii_lha_verb_t)
call heprup_write_verbose (eio%unit)
end select
end if
end subroutine eio_ascii_split_out
@ %def eio_ascii_split_out
@ Output an event. Write first the event indices, then weight and
squared matrix element, then the particle set.
Events that did not pass the selection are skipped. The exceptions are
the [[ascii]] and [[debug]] formats. These are the formats that
contain the [[passed]] flag in their output, and should be most useful
for debugging purposes.
<<EIO ascii: eio ascii: TBP>>=
procedure :: output => eio_ascii_output
<<EIO ascii: procedures>>=
subroutine eio_ascii_output (eio, event, i_prc, reading, passed, pacify)
class(eio_ascii_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
if (present (passed)) then
if (.not. passed) then
select type (eio)
type is (eio_ascii_debug_t)
type is (eio_ascii_ascii_t)
class default
return
end select
end if
end if
if (eio%writing) then
select type (eio)
type is (eio_ascii_lha_t)
call hepeup_from_event (event, &
process_index = i_prc, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants)
call hepeup_write_lha (eio%unit)
type is (eio_ascii_lha_verb_t)
call hepeup_from_event (event, &
process_index = i_prc, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants)
call hepeup_write_verbose (eio%unit)
type is (eio_ascii_ascii_t)
call event%write (eio%unit, &
show_process = .false., &
show_transforms = .false., &
show_decay = .false., &
verbose = .false., testflag = pacify)
type is (eio_ascii_athena_t)
call hepevt_from_event (event, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants, &
ensure_order = eio%ensure_order)
call hepevt_write_athena (eio%unit)
type is (eio_ascii_debug_t)
call event%write (eio%unit, &
show_process = eio%show_process, &
show_transforms = eio%show_transforms, &
show_decay = eio%show_decay, &
verbose = eio%verbose, &
testflag = pacify)
type is (eio_ascii_hepevt_t)
call hepevt_from_event (event, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants, &
ensure_order = eio%ensure_order)
call hepevt_write_hepevt (eio%unit)
type is (eio_ascii_hepevt_verb_t)
call hepevt_from_event (event, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants, &
ensure_order = eio%ensure_order)
call hepevt_write_verbose (eio%unit)
type is (eio_ascii_long_t)
call hepevt_from_event (event, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants, &
ensure_order = eio%ensure_order)
call hepevt_write_ascii (eio%unit, .true.)
type is (eio_ascii_mokka_t)
call hepevt_from_event (event, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants, &
ensure_order = eio%ensure_order)
call hepevt_write_mokka (eio%unit)
type is (eio_ascii_short_t)
call hepevt_from_event (event, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants, &
ensure_order = eio%ensure_order)
call hepevt_write_ascii (eio%unit, .false.)
end select
else
call eio%write ()
call msg_fatal ("ASCII file is not open for writing")
end if
end subroutine eio_ascii_output
@ %def eio_ascii_output
@ Input an event.
<<EIO ascii: eio ascii: TBP>>=
procedure :: input_i_prc => eio_ascii_input_i_prc
procedure :: input_event => eio_ascii_input_event
<<EIO ascii: procedures>>=
subroutine eio_ascii_input_i_prc (eio, i_prc, iostat)
class(eio_ascii_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
call msg_bug ("ASCII: event input not supported")
i_prc = 0
iostat = 1
end subroutine eio_ascii_input_i_prc
subroutine eio_ascii_input_event (eio, event, iostat)
class(eio_ascii_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
call msg_bug ("ASCII: event input not supported")
iostat = 1
end subroutine eio_ascii_input_event
@ %def eio_ascii_input_i_prc
@ %def eio_ascii_input_event
@
<<EIO ascii: eio ascii: TBP>>=
procedure :: skip => eio_ascii_skip
<<EIO ascii: procedures>>=
subroutine eio_ascii_skip (eio, iostat)
class(eio_ascii_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_ascii_skip
@ %def eio_asciii_skip
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_ascii_ut.f90]]>>=
<<File header>>
module eio_ascii_ut
use unit_tests
use eio_ascii_uti
<<Standard module head>>
<<EIO ascii: public test>>
contains
<<EIO ascii: test driver>>
end module eio_ascii_ut
@ %def eio_ascii_ut
@
<<[[eio_ascii_uti.f90]]>>=
<<File header>>
module eio_ascii_uti
<<Use kinds>>
<<Use strings>>
use io_units
use model_data
use event_base
use eio_data
use eio_base
use eio_ascii
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
<<Standard module head>>
<<EIO ascii: test declarations>>
contains
<<EIO ascii: tests>>
end module eio_ascii_uti
@ %def eio_ascii_uti
@ API: driver for the unit tests below.
<<EIO ascii: public test>>=
public :: eio_ascii_test
<<EIO ascii: test driver>>=
subroutine eio_ascii_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO ascii: execute tests>>
end subroutine eio_ascii_test
@ %def eio_ascii_test
@
\subsubsection{Test I/O methods}
We test the implementation of all I/O methods, method [[ascii]]:
<<EIO ascii: execute tests>>=
call test (eio_ascii_1, "eio_ascii_1", &
"read and write event contents, format [ascii]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_1
<<EIO ascii: tests>>=
subroutine eio_ascii_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_1"
write (u, "(A)") "* Purpose: generate an event in ASCII ascii format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_1"
allocate (eio_ascii_ascii_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (42)
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".evt"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_ascii_t :: eio)
select type (eio)
type is (eio_ascii_ascii_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_1"
end subroutine eio_ascii_1
@ %def eio_ascii_1
@
We test the implementation of all I/O methods, method [[athena]]:
<<EIO ascii: execute tests>>=
call test (eio_ascii_2, "eio_ascii_2", &
"read and write event contents, format [athena]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_2
<<EIO ascii: tests>>=
subroutine eio_ascii_2 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_2"
write (u, "(A)") "* Purpose: generate an event in ASCII athena format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_2"
allocate (eio_ascii_athena_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (42)
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char(sample // ".athena.evt"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_athena_t :: eio)
select type (eio)
type is (eio_ascii_athena_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_2"
end subroutine eio_ascii_2
@ %def eio_ascii_2
@
We test the implementation of all I/O methods, method [[debug]]:
<<EIO ascii: execute tests>>=
call test (eio_ascii_3, "eio_ascii_3", &
"read and write event contents, format [debug]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_3
<<EIO ascii: tests>>=
subroutine eio_ascii_3 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_3"
write (u, "(A)") "* Purpose: generate an event in ASCII debug format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_3"
allocate (eio_ascii_debug_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%increment_index ()
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".debug"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_debug_t :: eio)
select type (eio)
type is (eio_ascii_debug_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_3"
end subroutine eio_ascii_3
@ %def eio_ascii_3
@
We test the implementation of all I/O methods, method [[hepevt]]:
<<EIO ascii: execute tests>>=
call test (eio_ascii_4, "eio_ascii_4", &
"read and write event contents, format [hepevt]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_4
<<EIO ascii: tests>>=
subroutine eio_ascii_4 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_4"
write (u, "(A)") "* Purpose: generate an event in ASCII hepevt format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_4"
allocate (eio_ascii_hepevt_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%increment_index ()
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".hepevt"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_hepevt_t :: eio)
select type (eio)
type is (eio_ascii_hepevt_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_4"
end subroutine eio_ascii_4
@ %def eio_ascii_4
@
We test the implementation of all I/O methods, method [[lha]] (old LHA):
<<EIO ascii: execute tests>>=
call test (eio_ascii_5, "eio_ascii_5", &
"read and write event contents, format [lha]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_5
<<EIO ascii: tests>>=
subroutine eio_ascii_5 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_5"
write (u, "(A)") "* Purpose: generate an event in ASCII LHA format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_5"
allocate (eio_ascii_lha_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%increment_index ()
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".lha"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_lha_t :: eio)
select type (eio)
type is (eio_ascii_lha_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_5"
end subroutine eio_ascii_5
@ %def eio_ascii_5
@
We test the implementation of all I/O methods, method [[long]]:
<<EIO ascii: execute tests>>=
call test (eio_ascii_6, "eio_ascii_6", &
"read and write event contents, format [long]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_6
<<EIO ascii: tests>>=
subroutine eio_ascii_6 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_6"
write (u, "(A)") "* Purpose: generate an event in ASCII long format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_6"
allocate (eio_ascii_long_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%increment_index ()
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".long.evt"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_long_t :: eio)
select type (eio)
type is (eio_ascii_long_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_6"
end subroutine eio_ascii_6
@ %def eio_ascii_6
@
We test the implementation of all I/O methods, method [[mokka]]:
<<EIO ascii: execute tests>>=
call test (eio_ascii_7, "eio_ascii_7", &
"read and write event contents, format [mokka]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_7
<<EIO ascii: tests>>=
subroutine eio_ascii_7 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_7"
write (u, "(A)") "* Purpose: generate an event in ASCII mokka format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_7"
allocate (eio_ascii_mokka_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%increment_index ()
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".mokka.evt"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_mokka_t :: eio)
select type (eio)
type is (eio_ascii_mokka_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_7"
end subroutine eio_ascii_7
@ %def eio_ascii_7
@
We test the implementation of all I/O methods, method [[short]]:
<<EIO ascii: execute tests>>=
call test (eio_ascii_8, "eio_ascii_8", &
"read and write event contents, format [short]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_8
<<EIO ascii: tests>>=
subroutine eio_ascii_8 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_8"
write (u, "(A)") "* Purpose: generate an event in ASCII short format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_8"
allocate (eio_ascii_short_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%increment_index ()
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".short.evt"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_short_t :: eio)
select type (eio)
type is (eio_ascii_short_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_8"
end subroutine eio_ascii_8
@ %def eio_ascii_8
@
We test the implementation of all I/O methods, method [[lha]] (old
LHA) in verbose version:
<<EIO ascii: execute tests>>=
call test (eio_ascii_9, "eio_ascii_9", &
"read and write event contents, format [lha_verb]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_9
<<EIO ascii: tests>>=
subroutine eio_ascii_9 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_9"
write (u, "(A)") "* Purpose: generate an event in ASCII LHA verbose format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_9"
allocate (eio_ascii_lha_verb_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%increment_index ()
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".lha.verb"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_lha_verb_t :: eio)
select type (eio)
type is (eio_ascii_lha_verb_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_9"
end subroutine eio_ascii_9
@ %def eio_ascii_9
@
We test the implementation of all I/O methods, method [[hepevt_verb]]:
<<EIO ascii: execute tests>>=
call test (eio_ascii_10, "eio_ascii_10", &
"read and write event contents, format [hepevt_verb]", &
u, results)
<<EIO ascii: test declarations>>=
public :: eio_ascii_10
<<EIO ascii: tests>>=
subroutine eio_ascii_10 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_ascii_10"
write (u, "(A)") "* Purpose: generate an event in ASCII hepevt verbose format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_ascii_10"
allocate (eio_ascii_hepevt_verb_t :: eio)
select type (eio)
class is (eio_ascii_t); call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%increment_index ()
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".hepevt.verb"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_ascii_hepevt_verb_t :: eio)
select type (eio)
type is (eio_ascii_hepevt_verb_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_ascii_10"
end subroutine eio_ascii_10
@ %def eio_ascii_10
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{HEP Common Blocks}
Long ago, to transfer data between programs one had to set up a common
block and link both programs as libraries to the main executable. The
HEP community standardizes several of those common blocks.
The modern way of data exchange uses data files with standard
formats. However, the LHEF standard data format derives from a common
block (actually, two).
\whizard\ used to support those common blocks, and LHEF was
implemented via writing/reading blocks. We still keep this
convention, but intend to eliminate common blocks (or any other static
storage) from the workflow in the future. This will gain flexibility
towards concurrent running of program images.
We encapsulate everything here in a module. The module holds the
variables which are part of the common block. To access the common
block variables, we just have to [[use]] this module. (They are
nevertheless in the common block, since external software may access
it in this way.)
Note: This code is taken essentially unchanged from \whizard\ 2.1 and
does not (yet) provide unit tests.
<<[[hep_common.f90]]>>=
<<File header>>
module hep_common
<<Use kinds>>
use kinds, only: double
use constants
<<Use strings>>
use io_units
use diagnostics
use numeric_utils
use physics_defs, only: HADRON_REMNANT
use physics_defs, only: HADRON_REMNANT_SINGLET
use physics_defs, only: HADRON_REMNANT_TRIPLET
use physics_defs, only: HADRON_REMNANT_OCTET
use xml
use lorentz
use flavors
use colors
use polarizations
use model_data
use particles
use subevents, only: PRT_BEAM, PRT_INCOMING, PRT_OUTGOING
use subevents, only: PRT_UNDEFINED
use subevents, only: PRT_VIRTUAL, PRT_RESONANT, PRT_BEAM_REMNANT
<<Standard module head>>
<<HEP common: public>>
<<HEP common: interfaces>>
<<HEP common: parameters>>
<<HEP common: variables>>
<<HEP common: common blocks>>
contains
<<HEP common: procedures>>
end module hep_common
@ %def hep_common
@
\subsection{Event characteristics}
The maximal number of particles in an event record.
<<HEP common: parameters>>=
integer, parameter, public :: MAXNUP = 500
@ %def MAXNUP
@ The number of particles in this event.
<<HEP common: variables>>=
integer, public :: NUP
@ %def NUP
@ The process ID for this event.
<<HEP common: variables>>=
integer, public :: IDPRUP
@ %def IDPRUP
@ The weight of this event ($\pm 1$ for unweighted events).
<<HEP common: variables>>=
double precision, public :: XWGTUP
@ %def XWGTUP
@ The factorization scale that is used for PDF calculation ($-1$ if
undefined).
<<HEP common: variables>>=
double precision, public :: SCALUP
@ %def SCALUP
@ The QED and QCD couplings $\alpha$ used for this event ($-1$ if
undefined).
<<HEP common: variables>>=
double precision, public :: AQEDUP
double precision, public :: AQCDUP
@ %def AQEDUP AQCDUP
@
\subsection{Particle characteristics}
The PDG code:
<<HEP common: variables>>=
integer, dimension(MAXNUP), public :: IDUP
@ %def IDUP
@ The status code. Incoming: $-1$, outgoing: $+1$. Intermediate
t-channel propagator: $-2$ (currently not used by WHIZARD).
Intermediate resonance whose mass should be preserved: $2$.
Intermediate resonance for documentation: $3$ (currently not used).
Beam particles: $-9$.
<<HEP common: variables>>=
integer, dimension(MAXNUP), public :: ISTUP
@ %def ISTUP
@ Index of first and last mother.
<<HEP common: variables>>=
integer, dimension(2,MAXNUP), public :: MOTHUP
@ %def MOTHUP
@ Color line index of the color and anticolor entry for the particle.
The standard recommends using large numbers; we start from MAXNUP+1.
<<HEP common: variables>>=
integer, dimension(2,MAXNUP), public :: ICOLUP
@ %def ICOLUP
@ Momentum, energy, and invariant mass: $(p_x,p_y,p_z,E,M)$. For
space-like particles, $M$ is the negative square root of the absolute
value of the invariant mass.
<<HEP common: variables>>=
double precision, dimension(5,MAXNUP), public :: PUP
@ %def PUP
@ Invariant lifetime (distance) from production to decay in mm.
<<HEP common: variables>>=
double precision, dimension(MAXNUP), public :: VTIMUP
@ %def VTIMUP
@ Cosine of the angle between the spin-vector and a particle and the
3-momentum of its mother, given in the lab frame. If
undefined/unpolarized: $9$.
<<HEP common: variables>>=
double precision, dimension(MAXNUP), public :: SPINUP
@ %def SPINUP
@
\subsection{The HEPRUP common block}
This common block is filled once per run.
\subsubsection{Run characteristics}
The maximal number of different processes.
<<HEP common: parameters>>=
integer, parameter, public :: MAXPUP = 100
@ %def MAXPUP
@ The beam PDG codes.
<<HEP common: variables>>=
integer, dimension(2), public :: IDBMUP
@ %def IDBMUP
@ The beam energies in GeV.
<<HEP common: variables>>=
double precision, dimension(2), public :: EBMUP
@ %def EBMUP
@ The PDF group and set for the two beams. (Undefined: use $-1$;
LHAPDF: use group = $0$).
<<HEP common: variables>>=
integer, dimension(2), public :: PDFGUP
integer, dimension(2), public :: PDFSUP
@ %def PDFGUP PDFSUP
@ The (re)weighting model. 1: events are weighted, the shower
generator (SHG) selects processes according to the maximum weight (in
pb) and unweights events. 2: events are weighted, the SHG selects
processes according to their cross section (in pb) and unweights
events. 3: events are unweighted and simply run through the SHG. 4:
events are weighted, and the SHG keeps the weight. Negative numbers:
negative weights are allowed (and are reweighted to $\pm 1$ by the
SHG, if allowed).
\whizard\ only supports modes 3 and 4, as the SHG is not given control
over process selection. This is consistent with writing events to
file, for offline showering.
<<HEP common: variables>>=
integer, public :: IDWTUP
@ %def IDWTUP
@ The number of different processes.
<<HEP common: variables>>=
integer, public :: NPRUP
@ %def NPRUP
@
\subsubsection{Process characteristics}
Cross section and error in pb. (Cross section is needed only for
$[[IDWTUP]] = 2$, so here both values are given for informational
purposes only.)
<<HEP common: variables>>=
double precision, dimension(MAXPUP), public :: XSECUP
double precision, dimension(MAXPUP), public :: XERRUP
@ %def XSECUP XERRUP
@ Maximum weight, i.e., the maximum value that [[XWGTUP]] can take.
Also unused for the supported weighting models. It is $\pm 1$ for
unweighted events.
<<HEP common: variables>>=
double precision, dimension(MAXPUP), public :: XMAXUP
@ %def XMAXUP
@ Internal ID of the selected process, matches [[IDPRUP]] below.
<<HEP common: variables>>=
integer, dimension(MAXPUP), public :: LPRUP
@ %def LPRUP
@
\subsubsection{The common block}
<<HEP common: common blocks>>=
common /HEPRUP/ &
IDBMUP, EBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP, &
XSECUP, XERRUP, XMAXUP, LPRUP
save /HEPRUP/
@ %def HEPRUP
@ Fill the run characteristics of the common block. The
initialization sets the beam properties, number of processes, and
weighting model.
<<HEP common: public>>=
public :: heprup_init
<<HEP common: procedures>>=
subroutine heprup_init &
(beam_pdg, beam_energy, n_processes, unweighted, negative_weights)
integer, dimension(2), intent(in) :: beam_pdg
real(default), dimension(2), intent(in) :: beam_energy
integer, intent(in) :: n_processes
logical, intent(in) :: unweighted
logical, intent(in) :: negative_weights
IDBMUP = beam_pdg
EBMUP = beam_energy
PDFGUP = -1
PDFSUP = -1
if (unweighted) then
IDWTUP = 3
else
IDWTUP = 4
end if
if (negative_weights) IDWTUP = - IDWTUP
NPRUP = n_processes
end subroutine heprup_init
@ %def heprup_init
The HEPRUP (event) common block is needed for the interface to the shower.
Filling of it is triggered by some output file formats. If these are not
present, the common block is filled with some dummy information. Be generous
with the number of processes in HEPRUP so that PYTHIA only rarely needs to be
reinitialized in case events with higher process ids are generated.
<<HEP common: public>>=
public :: assure_heprup
<<HEP common: procedures>>=
subroutine assure_heprup (pset)
type(particle_set_t), intent(in) :: pset
integer :: i, num_id
integer, parameter :: min_processes = 10
num_id = 1
if (LPRUP (num_id) /= 0) return
call heprup_init ( &
[pset%prt(1)%get_pdg (), pset%prt(2)%get_pdg ()] , &
[pset%prt(1)%p%p(0), pset%prt(2)%p%p(0)], &
num_id, .false., .false.)
do i = 1, (num_id / min_processes + 1) * min_processes
call heprup_set_process_parameters (i = i, process_id = &
i, cross_section = 1._default, error = 1._default)
end do
end subroutine assure_heprup
@ %def assure_heprup
@ Read in the LHE file opened in unit [[u]] and add the final
particles to the [[particle_set]], the outgoing particles of the existing
[[particle_set]] are compared to the particles that are read in. When
they are equal in flavor and momenta, they are erased and their
mother-daughter relations are transferred to the existing particles.
<<HEP common: public>>=
public :: combine_lhef_with_particle_set
<<HEP common: procedures>>=
subroutine combine_lhef_with_particle_set &
(particle_set, u, model_in, model_hadrons)
type(particle_set_t), intent(inout) :: particle_set
integer, intent(in) :: u
class(model_data_t), intent(in), target :: model_in
class(model_data_t), intent(in), target :: model_hadrons
type(flavor_t) :: flv
type(color_t) :: col
class(model_data_t), pointer :: model
type(particle_t), dimension(:), allocatable :: prt_tmp, prt
integer :: i, j
type(vector4_t) :: mom, d_mom
integer, PARAMETER :: MAXLEN=200
character(len=maxlen) :: string
integer :: ibeg, n_tot, n_entries
integer, dimension(:), allocatable :: relations, mothers, tbd
INTEGER :: NUP,IDPRUP,IDUP,ISTUP
real(kind=double) :: XWGTUP,SCALUP,AQEDUP,AQCDUP,VTIMUP,SPINUP
integer :: MOTHUP(1:2), ICOLUP(1:2)
real(kind=double) :: PUP(1:5)
real(kind=default) :: pup_dum(1:5)
character(len=5) :: buffer
character(len=6) :: strfmt
logical :: not_found
logical :: debug_lhef = .false.
STRFMT='(A000)'
WRITE (STRFMT(3:5),'(I3)') MAXLEN
if (debug_lhef) call particle_set%write ()
rewind (u)
do
read (u,*, END=501, ERR=502) STRING
IBEG = 0
do
if (signal_is_pending ()) return
IBEG = IBEG + 1
! Allow indentation.
IF (STRING (IBEG:IBEG) .EQ. ' ' .and. IBEG < MAXLEN-6) cycle
exit
end do
IF (string(IBEG:IBEG+6) /= '<event>' .and. &
string(IBEG:IBEG+6) /= '<event ') cycle
exit
end do
!!! Read first line of event info -> number of entries
read (u, *, END=503, ERR=504) NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP
n_tot = particle_set%get_n_tot ()
allocate (prt_tmp (1:n_tot+NUP))
allocate (relations (1:NUP), mothers (1:NUP), tbd(1:NUP))
do i = 1, n_tot
if (signal_is_pending ()) return
prt_tmp (i) = particle_set%get_particle (i)
end do
!!! transfer particles from lhef to particle_set
!!!...Read NUP subsequent lines with information on each particle.
n_entries = 1
mothers = 0
relations = 0
PARTICLE_LOOP: do I = 1, NUP
read (u,*, END=200, ERR=505) IDUP, ISTUP, MOTHUP(1), MOTHUP(2), &
ICOLUP(1), ICOLUP(2), (PUP (J),J=1,5), VTIMUP, SPINUP
if (model_in%test_field (IDUP)) then
model => model_in
else if (model_hadrons%test_field (IDUP)) then
model => model_hadrons
else
write (buffer, "(I5)") IDUP
call msg_error ("Parton " // buffer // &
" found neither in given model file nor in SM_hadrons")
return
end if
if (debug_lhef) then
print *, "IDUP, ISTUP, MOTHUP, PUP = ", IDUP, ISTUP, MOTHUP(1), &
MOTHUP(2), PUP
end if
call flv%init (IDUP, model)
if (IABS(IDUP) == 2212 .or. IABS(IDUP) == 2112) then
! PYTHIA sometimes sets color indices for protons and neutrons (?)
ICOLUP (1) = 0
ICOLUP (2) = 0
end if
call col%init_col_acl (ICOLUP (1), ICOLUP (2))
!!! Settings for unpolarized particles
! particle_set%prt (oldsize+i)%hel = ??
! particle_set%prt (oldsize+i)%pol = ??
if (MOTHUP(1) /= 0) then
mothers(i) = MOTHUP(1)
end if
pup_dum = PUP
if (pup_dum(4) < 1E-10_default) cycle
mom = vector4_moving (pup_dum (4), &
vector3_moving ([pup_dum (1), pup_dum (2), pup_dum (3)]))
not_found = .true.
SCAN_PARTICLES: do j = 1, n_tot
d_mom = prt_tmp(j)%get_momentum ()
if (all (nearly_equal &
(mom%p, d_mom%p, abs_smallness = 1.E-4_default)) .and. &
(prt_tmp(j)%get_pdg () == IDUP)) then
if (.not. prt_tmp(j)%get_status () == PRT_BEAM .or. &
.not. prt_tmp(j)%get_status () == PRT_BEAM_REMNANT) &
relations(i) = j
not_found = .false.
end if
end do SCAN_PARTICLES
if (not_found) then
if (debug_lhef) &
print *, "Not found: adding particle"
call prt_tmp(n_tot+n_entries)%set_flavor (flv)
call prt_tmp(n_tot+n_entries)%set_color (col)
call prt_tmp(n_tot+n_entries)%set_momentum (mom)
if (MOTHUP(1) /= 0) then
if (relations(MOTHUP(1)) /= 0) then
call prt_tmp(n_tot+n_entries)%set_parents &
([relations(MOTHUP(1))])
call prt_tmp(relations(MOTHUP(1)))%add_child (n_tot+n_entries)
if (prt_tmp(relations(MOTHUP(1)))%get_status () &
== PRT_OUTGOING) &
call prt_tmp(relations(MOTHUP(1)))%reset_status &
(PRT_VIRTUAL)
end if
end if
call prt_tmp(n_tot+n_entries)%set_status (PRT_OUTGOING)
if (debug_lhef) call prt_tmp(n_tot+n_entries)%write ()
n_entries = n_entries + 1
end if
end do PARTICLE_LOOP
do i = 1, n_tot
if (prt_tmp(i)%get_status () == PRT_OUTGOING .and. &
prt_tmp(i)%get_n_children () /= 0) then
call prt_tmp(i)%reset_status (PRT_VIRTUAL)
end if
end do
allocate (prt (1:n_tot+n_entries-1))
prt = prt_tmp (1:n_tot+n_entries-1)
! transfer to particle_set
call particle_set%replace (prt)
deallocate (prt, prt_tmp)
if (debug_lhef) then
call particle_set%write ()
print *, "combine_lhef_with_particle_set"
! stop
end if
200 continue
return
501 write(*,*) "READING LHEF failed 501"
return
502 write(*,*) "READING LHEF failed 502"
return
503 write(*,*) "READING LHEF failed 503"
return
504 write(*,*) "READING LHEF failed 504"
return
505 write(*,*) "READING LHEF failed 505"
return
end subroutine combine_lhef_with_particle_set
@ %def combine_lhef_with_particle_set
@
<<HEP common: public>>=
public :: w2p_write_lhef_event
<<HEP common: procedures>>=
subroutine w2p_write_lhef_event (unit)
integer, intent(in) :: unit
type(xml_tag_t), allocatable :: tag_lhef, tag_head, tag_init, &
tag_event, tag_gen_n, tag_gen_v
call msg_debug (D_EVENTS, "w2p_write_lhef_event")
allocate (tag_lhef, tag_head, tag_init, tag_event, &
tag_gen_n, tag_gen_v)
call tag_lhef%init (var_str ("LesHouchesEvents"), &
[xml_attribute (var_str ("version"), var_str ("1.0"))], .true.)
call tag_head%init (var_str ("header"), .true.)
call tag_init%init (var_str ("init"), .true.)
call tag_event%init (var_str ("event"), .true.)
call tag_gen_n%init (var_str ("generator_name"), .true.)
call tag_gen_v%init (var_str ("generator_version"), .true.)
call tag_lhef%write (unit); write (unit, *)
call tag_head%write (unit); write (unit, *)
write (unit, "(2x)", advance = "no")
call tag_gen_n%write (var_str ("WHIZARD"), unit)
write (unit, *)
write (unit, "(2x)", advance = "no")
call tag_gen_v%write (var_str ("<<Version>>"), unit)
write (unit, *)
call tag_head%close (unit); write (unit, *)
call tag_init%write (unit); write (unit, *)
call heprup_write_lhef (unit)
call tag_init%close (unit); write (unit, *)
call tag_event%write (unit); write (unit, *)
call hepeup_write_lhef (unit)
call tag_event%close (unit); write (unit, *)
call tag_lhef%close (unit); write (unit, *)
deallocate (tag_lhef, tag_head, tag_init, tag_event, &
tag_gen_n, tag_gen_v)
end subroutine w2p_write_lhef_event
@ %def w2p_write_lhef_event
@ Extract parameters from the common block. We leave it to the caller
to specify which parameters it actually needs.
[[PDFGUP]] and [[PDFSUP]] are not extracted. [[IDWTUP=1,2]] are not
supported by \whizard, but correspond to weighted events.
<<HEP common: public>>=
public :: heprup_get_run_parameters
<<HEP common: procedures>>=
subroutine heprup_get_run_parameters &
(beam_pdg, beam_energy, n_processes, unweighted, negative_weights)
integer, dimension(2), intent(out), optional :: beam_pdg
real(default), dimension(2), intent(out), optional :: beam_energy
integer, intent(out), optional :: n_processes
logical, intent(out), optional :: unweighted
logical, intent(out), optional :: negative_weights
if (present (beam_pdg)) beam_pdg = IDBMUP
if (present (beam_energy)) beam_energy = EBMUP
if (present (n_processes)) n_processes = NPRUP
if (present (unweighted)) then
select case (abs (IDWTUP))
case (3)
unweighted = .true.
case (4)
unweighted = .false.
case (1,2) !!! not supported by WHIZARD
unweighted = .false.
case default
call msg_fatal ("HEPRUP: unsupported IDWTUP value")
end select
end if
if (present (negative_weights)) then
negative_weights = IDWTUP < 0
end if
end subroutine heprup_get_run_parameters
@ %def heprup_get_run_parameters
@ Specify PDF set info. Since we support only LHAPDF, the group entry
is zero.
<<HEP common: public>>=
public :: heprup_set_lhapdf_id
<<HEP common: procedures>>=
subroutine heprup_set_lhapdf_id (i_beam, pdf_id)
integer, intent(in) :: i_beam, pdf_id
PDFGUP(i_beam) = 0
PDFSUP(i_beam) = pdf_id
end subroutine heprup_set_lhapdf_id
@ %def heprup_set_lhapdf_id
@ Fill the characteristics for a particular process. Only the process
ID is mandatory. Note that \whizard\ computes cross sections in fb,
so we have to rescale to pb. The maximum weight is meaningless for
unweighted events.
<<HEP common: public>>=
public :: heprup_set_process_parameters
<<HEP common: procedures>>=
subroutine heprup_set_process_parameters &
(i, process_id, cross_section, error, max_weight)
integer, intent(in) :: i, process_id
real(default), intent(in), optional :: cross_section, error, max_weight
real(default), parameter :: pb_per_fb = 1.e-3_default
LPRUP(i) = process_id
if (present (cross_section)) then
XSECUP(i) = cross_section * pb_per_fb
else
XSECUP(i) = 0
end if
if (present (error)) then
XERRUP(i) = error * pb_per_fb
else
XERRUP(i) = 0
end if
select case (IDWTUP)
case (3); XMAXUP(i) = 1
case (4)
if (present (max_weight)) then
XMAXUP(i) = max_weight * pb_per_fb
else
XMAXUP(i) = 0
end if
end select
end subroutine heprup_set_process_parameters
@ %def heprup_set_process_parameters
@ Extract the process parameters, as far as needed.
<<HEP common: public>>=
public :: heprup_get_process_parameters
<<HEP common: procedures>>=
subroutine heprup_get_process_parameters &
(i, process_id, cross_section, error, max_weight)
integer, intent(in) :: i
integer, intent(out), optional :: process_id
real(default), intent(out), optional :: cross_section, error, max_weight
real(default), parameter :: pb_per_fb = 1.e-3_default
if (present (process_id)) process_id = LPRUP(i)
if (present (cross_section)) then
cross_section = XSECUP(i) / pb_per_fb
end if
if (present (error)) then
error = XERRUP(i) / pb_per_fb
end if
if (present (max_weight)) then
select case (IDWTUP)
case (3)
max_weight = 1
case (4)
max_weight = XMAXUP(i) / pb_per_fb
case (1,2) !!! not supported by WHIZARD
max_weight = 0
case default
call msg_fatal ("HEPRUP: unsupported IDWTUP value")
end select
end if
end subroutine heprup_get_process_parameters
@ %def heprup_get_process_parameters
@
\subsection{Run parameter output (verbose)}
This is a verbose output of the HEPRUP block.
<<HEP common: public>>=
public :: heprup_write_verbose
<<HEP common: procedures>>=
subroutine heprup_write_verbose (unit)
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)") "HEPRUP Common Block"
write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "IDBMUP", IDBMUP, &
"PDG code of beams"
write (u, "(3x,A6,' = ',G12.5,1x,G12.5,8x,A)") "EBMUP ", EBMUP, &
"Energy of beams in GeV"
write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "PDFGUP", PDFGUP, &
"PDF author group [-1 = undefined]"
write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "PDFSUP", PDFSUP, &
"PDF set ID [-1 = undefined]"
write (u, "(3x,A6,' = ',I9,3x,1x,9x,3x,8x,A)") "IDWTUP", IDWTUP, &
"LHA code for event weight mode"
write (u, "(3x,A6,' = ',I9,3x,1x,9x,3x,8x,A)") "NPRUP ", NPRUP, &
"Number of user subprocesses"
do i = 1, NPRUP
write (u, "(1x,A,I0)") "Subprocess #", i
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "XSECUP", XSECUP(i), &
"Cross section in pb"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "XERRUP", XERRUP(i), &
"Cross section error in pb"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "XMAXUP", XMAXUP(i), &
"Maximum event weight (cf. IDWTUP)"
write (u, "(3x,A6,' = ',I9,3x,1x,12x,8x,A)") "LPRUP ", LPRUP(i), &
"Subprocess ID"
end do
end subroutine heprup_write_verbose
@ %def heprup_write_verbose
@
\subsection{Run parameter output (other formats)}
This routine writes the initialization block according to the LHEF
standard. It uses the current contents of the HEPRUP block.
<<HEP common: public>>=
public :: heprup_write_lhef
<<HEP common: procedures>>=
subroutine heprup_write_lhef (unit)
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(2(1x,I0),2(1x,ES17.10),6(1x,I0))") &
IDBMUP, EBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP
do i = 1, NPRUP
write (u, "(3(1x,ES17.10),1x,I0)") &
XSECUP(i), XERRUP(i), XMAXUP(i), LPRUP(i)
end do
end subroutine heprup_write_lhef
@ %def heprup_write_lhef
@
This routine is a complete dummy at the moment. It uses the current
contents of the HEPRUP block. At the end, it should depend on certain
input flags for the different ASCII event formats.
<<HEP common: public>>=
public :: heprup_write_ascii
<<HEP common: procedures>>=
subroutine heprup_write_ascii (unit)
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(2(1x,I0),2(1x,ES17.10),6(1x,I0))") &
IDBMUP, EBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP
do i = 1, NPRUP
write (u, "(3(1x,ES17.10),1x,I0)") &
XSECUP(i), XERRUP(i), XMAXUP(i), LPRUP(i)
end do
end subroutine heprup_write_ascii
@ %def heprup_write_ascii
@
\subsubsection{Run parameter input (LHEF)}
In a LHEF file, the parameters are written in correct order on
separate lines, but we should not count on the precise format.
List-directed input should just work.
<<HEP common: public>>=
public :: heprup_read_lhef
<<HEP common: procedures>>=
subroutine heprup_read_lhef (u)
integer, intent(in) :: u
integer :: i
read (u, *) &
IDBMUP, EBMUP, PDFGUP, PDFSUP, IDWTUP, NPRUP
do i = 1, NPRUP
read (u, *) &
XSECUP(i), XERRUP(i), XMAXUP(i), LPRUP(i)
end do
end subroutine heprup_read_lhef
@ %def heprup_read_lhef
@
\subsection{The HEPEUP common block}
<<HEP common: common blocks>>=
common /HEPEUP/ &
NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP, &
IDUP, ISTUP, MOTHUP, ICOLUP, PUP, VTIMUP, SPINUP
save /HEPEUP/
@ %def HEPEUP
@
\subsubsection{Initialization}
Fill the event characteristics of the common block. The
initialization sets only the number of particles and initializes the
rest with default values. The other routine sets the optional
parameters.
<<HEP common: public>>=
public :: hepeup_init
public :: hepeup_set_event_parameters
<<HEP common: procedures>>=
subroutine hepeup_init (n_tot)
integer, intent(in) :: n_tot
NUP = n_tot
IDPRUP = 0
XWGTUP = 1
SCALUP = -1
AQEDUP = -1
AQCDUP = -1
end subroutine hepeup_init
subroutine hepeup_set_event_parameters &
(proc_id, weight, scale, alpha_qed, alpha_qcd)
integer, intent(in), optional :: proc_id
real(default), intent(in), optional :: weight, scale, alpha_qed, alpha_qcd
if (present (proc_id)) IDPRUP = proc_id
if (present (weight)) XWGTUP = weight
if (present (scale)) SCALUP = scale
if (present (alpha_qed)) AQEDUP = alpha_qed
if (present (alpha_qcd)) AQCDUP = alpha_qcd
end subroutine hepeup_set_event_parameters
@ %def hepeup_init hepeup_set_event_parameters
@ Extract event information. The caller determines the parameters.
<<HEP common: public>>=
public :: hepeup_get_event_parameters
<<HEP common: procedures>>=
subroutine hepeup_get_event_parameters &
(proc_id, weight, scale, alpha_qed, alpha_qcd)
integer, intent(out), optional :: proc_id
real(default), intent(out), optional :: weight, scale, alpha_qed, alpha_qcd
if (present (proc_id)) proc_id = IDPRUP
if (present (weight)) weight = XWGTUP
if (present (scale)) scale = SCALUP
if (present (alpha_qed)) alpha_qed = AQEDUP
if (present (alpha_qcd)) alpha_qcd = AQCDUP
end subroutine hepeup_get_event_parameters
@ %def hepeup_get_event_parameters
@
\subsubsection{Particle data}
Below we need the particle status codes which are actually defined
in the [[subevents]] module.
Set the entry for a specific particle. All parameters are set with
the exception of lifetime and spin, where default values are stored.
<<HEP common: public>>=
public :: hepeup_set_particle
<<HEP common: procedures>>=
subroutine hepeup_set_particle (i, pdg, status, parent, col, p, m2)
integer, intent(in) :: i
integer, intent(in) :: pdg, status
integer, dimension(:), intent(in) :: parent
type(vector4_t), intent(in) :: p
integer, dimension(2), intent(in) :: col
real(default), intent(in) :: m2
if (i > MAXNUP) then
call msg_error (arr=[ &
var_str ("Too many particles in HEPEUP common block. " // &
"If this happened "), &
var_str ("during event output, your events will be " // &
"invalid; please consider "), &
var_str ("switching to a modern event format like HEPMC. " // &
"If you are not "), &
var_str ("using an old, HEPEUP based format and " // &
"nevertheless get this error,"), &
var_str ("please notify the WHIZARD developers,") ])
return
end if
IDUP(i) = pdg
select case (status)
case (PRT_BEAM); ISTUP(i) = -9
case (PRT_INCOMING); ISTUP(i) = -1
case (PRT_BEAM_REMNANT); ISTUP(i) = 3
case (PRT_OUTGOING); ISTUP(i) = 1
case (PRT_RESONANT); ISTUP(i) = 2
case (PRT_VIRTUAL); ISTUP(i) = 3
case default; ISTUP(i) = 0
end select
select case (size (parent))
case (0); MOTHUP(:,i) = 0
case (1); MOTHUP(1,i) = parent(1); MOTHUP(2,i) = 0
case default; MOTHUP(:,i) = [ parent(1), parent(size (parent)) ]
end select
if (col(1) > 0) then
ICOLUP(1,i) = 500 + col(1)
else
ICOLUP(1,i) = 0
end if
if (col(2) > 0) then
ICOLUP(2,i) = 500 + col(2)
else
ICOLUP(2,i) = 0
end if
PUP(1:3,i) = vector3_get_components (space_part (p))
PUP(4,i) = energy (p)
PUP(5,i) = sign (sqrt (abs (m2)), m2)
VTIMUP(i) = 0
SPINUP(i) = 9
end subroutine hepeup_set_particle
@ %def hepeup_set_particle
@ Set the lifetime, actually $c\tau$ measured im mm, where $\tau$ is
the invariant lifetime.
<<HEP common: public>>=
public :: hepeup_set_particle_lifetime
<<HEP common: procedures>>=
subroutine hepeup_set_particle_lifetime (i, lifetime)
integer, intent(in) :: i
real(default), intent(in) :: lifetime
VTIMUP(i) = lifetime
end subroutine hepeup_set_particle_lifetime
@ %def hepeup_set_particle_lifetime
@ Set the particle spin entry. We need the cosine of the angle of the
spin axis with respect to the three-momentum of the parent particle.
If the particle has a full polarization density matrix given, we need
the particle momentum and polarization as well as the mother-particle
momentum. The polarization is transformed into a spin vector (which
is sensible only for spin-1/2 or massless particles), which then is
transformed into the lab frame (by a rotation of the 3-axis to the
particle momentum axis). Finally, we compute the scalar product of
this vector with the mother-particle three-momentum.
This puts severe restrictions on the applicability of this definition,
and Lorentz invariance is lost. Unfortunately, the Les Houches Accord
requires this computation.
<<HEP common: public>>=
public :: hepeup_set_particle_spin
<<HEP common: interfaces>>=
interface hepeup_set_particle_spin
module procedure hepeup_set_particle_spin_pol
end interface
<<HEP common: procedures>>=
subroutine hepeup_set_particle_spin_pol (i, p, pol, p_mother)
integer, intent(in) :: i
type(vector4_t), intent(in) :: p
type(polarization_t), intent(in) :: pol
type(vector4_t), intent(in) :: p_mother
type(vector3_t) :: s3, p3
type(vector4_t) :: s4
s3 = vector3_moving (pol%get_axis ())
p3 = space_part (p)
s4 = rotation_to_2nd (3, p3) * vector4_moving (0._default, s3)
SPINUP(i) = enclosed_angle_ct (s4, p_mother)
end subroutine hepeup_set_particle_spin_pol
@ %def hepeup_set_particle_spin
@
Extract particle data. The caller decides which ones to retrieve.
Status codes: beam remnants share the status code with virtual particles.
However, for the purpose of WHIZARD we should identify them. We
use the PDG code for this.
<<HEP common: public>>=
public :: hepeup_get_particle
<<HEP common: procedures>>=
subroutine hepeup_get_particle (i, pdg, status, parent, col, p, m2)
integer, intent(in) :: i
integer, intent(out), optional :: pdg, status
integer, dimension(:), intent(out), optional :: parent
type(vector4_t), intent(out), optional :: p
integer, dimension(2), intent(out), optional :: col
real(default), dimension(5,MAXNUP) :: pup_def
real(default), intent(out), optional :: m2
if (present (pdg)) pdg = IDUP(i)
if (present (status)) then
select case (ISTUP(i))
case (-9); status = PRT_BEAM
case (-1); status = PRT_INCOMING
case (1); status = PRT_OUTGOING
case (2); status = PRT_RESONANT
case (3);
select case (abs (IDUP(i)))
case (HADRON_REMNANT, HADRON_REMNANT_SINGLET, &
HADRON_REMNANT_TRIPLET, HADRON_REMNANT_OCTET)
status = PRT_BEAM_REMNANT
case default
status = PRT_VIRTUAL
end select
case default
status = PRT_UNDEFINED
end select
end if
if (present (parent)) then
select case (size (parent))
case (0)
case (1); parent(1) = MOTHUP(1,i)
case (2); parent = MOTHUP(:,i)
end select
end if
if (present (col)) then
col = ICOLUP(:,i)
end if
if (present (p)) then
pup_def = PUP
p = vector4_moving (pup_def(4,i), vector3_moving (pup_def(1:3,i)))
end if
if (present (m2)) then
m2 = sign (PUP(5,i) ** 2, PUP(5,i))
end if
end subroutine hepeup_get_particle
@ %def hepeup_get_particle
@
\subsection{The HEPEVT and HEPEV4 common block}
For the LEP Monte Carlos, a standard common block has been proposed
in AKV89. We strongly recommend its use. (The description is an
abbreviated transcription of AKV89, Vol. 3, pp. 327-330).
[[NMXHEP]] is the maximum number of entries:
<<HEP common: variables>>=
integer, parameter :: NMXHEP = 4000
@ %def NMXHEP
@ [[NEVHEP]] is normally the event number, but may take special
values as follows:
0 the program does not keep track of event numbers.
-1 a special initialization record.
-2 a special final record.
<<HEP common: variables>>=
integer :: NEVHEP
@ %def NEVHEP
@ [[NHEP]] holds the number of entries for this event.
<<HEP common: variables>>=
integer, public :: NHEP
@ %def NHEP
@ The entry [[ISTHEP(N)]] gives the status code for the [[N]]th entry,
with the following semantics:
0 a null entry.
1 an existing entry, which has not decayed or fragmented.
2 a decayed or fragmented entry, which is retained for
event history information.
3 documentation line.
4- 10 reserved for future standards.
11-200 at the disposal of each model builder.
201- at the disposal of users.
<<HEP common: variables>>=
integer, dimension(NMXHEP), public :: ISTHEP
@ %def ISTHEP
@
The Particle Data Group has proposed standard particle codes,
which are to be stored in [[IDHEP(N)]].
<<HEP common: variables>>=
integer, dimension(NMXHEP), public :: IDHEP
@ %def IDHEP
@ [[JMOHEP(1,N)]] points to the mother of the [[N]]th entry, if any.
It is set to zero for initial entries.
[[JMOHEP(2,N)]] points to the second mother, if any.
<<HEP common: variables>>=
integer, dimension(2, NMXHEP), public :: JMOHEP
@ %def JMOHEP
@ [[JDAHEP(1,N)]] and [[JDAHEP(2,N)]] point to the first and last daughter
of the [[N]]th entry, if any. These are zero for entries which have not
yet decayed. The other daughters are stored in between these two.
<<HEP common: variables>>=
integer, dimension(2, NMXHEP), public :: JDAHEP
@ %def JDAHEP
@ In [[PHEP]] we store the momentum of the particle, more specifically
this means that [[PHEP(1,N)]], [[PHEP(2,N)]], and [[PHEP(3,N)]] contain the
momentum in the $x$, $y$, and $z$ direction (as defined by the machine
people), measured in GeV/c. [[PHEP(4,N)]] contains the energy in GeV
and [[PHEP(5,N)]] the mass in GeV$/c^2$. The latter may be negative for
spacelike partons.
<<HEP common: variables>>=
double precision, dimension(5, NMXHEP), public :: PHEP
@ %def PHEP
@ Finally [[VHEP]] is the place to store the position of the production
vertex. [[VHEP(1,N)]], [[VHEP(2,N)]], and [[VHEP(3,N)]] contain the $x$, $y$,
and $z$ coordinate (as defined by the machine people), measured in mm.
[[VHEP(4,N)]] contains the production time in mm/c.
<<HEP common: variables>>=
double precision, dimension(4, NMXHEP) :: VHEP
@ %def VHEP
@ As an amendment to the proposed standard common block HEPEVT, we
also have a polarisation common block HEPSPN, as described in
AKV89. [[SHEP(1,N)]], [[SHEP(2,N)]], and [[SHEP(3,N)]] give the $x$, $y$, and $z$
component of the spinvector $s$ of a fermion in the fermions restframe.
Furthermore, we add the polarization of the corresponding outgoing
particles:
<<HEP common: variables>>=
integer, dimension(NMXHEP) :: hepevt_pol
@ %def hepevt_pol
@
By this variable the identity of the current process is given, defined
via the LPRUP codes.
<<HEP common: variables>>=
integer, public :: idruplh
@ %def idruplh
This is the event weight, i.e. the cross section divided by the total
number of generated events for the output of the parton shower programs.
<<HEP common: variables>>=
double precision, public :: eventweightlh
@ %def eventweightlh
@ There are the values for the electromagnetic and the strong coupling
constants, $\alpha_{em}$ and $\alpha_s$.
<<HEP common: variables>>=
double precision, public :: alphaqedlh, alphaqcdlh
@ %def alphaqedlh, alphaqcdlh
@ This is the squared scale $Q$ of the event.
<<HEP common: variables>>=
double precision, dimension(10), public :: scalelh
@ %def scalelh
@ Finally, these variables contain the spin information and the
color/anticolor flow of the particles.
<<HEP common: variables>>=
double precision, dimension (3,NMXHEP), public :: spinlh
integer, dimension (2,NMXHEP), public :: icolorflowlh
@ %def spinlh icolorflowlh
By convention, [[SHEP(4,N)]] is always 1. All this is taken from StdHep
4.06 manual and written using Fortran90 conventions.
<<HEP common: common blocks>>=
common /HEPEVT/ &
NEVHEP, NHEP, ISTHEP, IDHEP, &
JMOHEP, JDAHEP, PHEP, VHEP
save /HEPEVT/
@ %def HEPEVT
@ Here we store HEPEVT parameters of the WHIZARD 1 realization which
are not part of the HEPEVT common block.
<<HEP common: variables>>=
integer :: hepevt_n_out, hepevt_n_remnants
@ %def hepevt_n_out, hepevt_n_remnants
@
<<HEP common: variables>>=
double precision :: hepevt_weight, hepevt_function_value
double precision :: hepevt_function_ratio
@ %def hepevt_weight hepevt_function_value
@ The HEPEV4 common block is an extension of the HEPEVT common block
to allow for partonic colored events, including especially the color
flow etc.
<<HEP common: common blocks>>=
common /HEPEV4/ &
eventweightlh, alphaqedlh, alphaqcdlh, scalelh, &
spinlh, icolorflowlh, idruplh
save /HEPEV4/
@ %def HEPEV4
@ Filling HEPEVT: If the event count is not provided, set [[NEVHEP]]
to zero. If the event count is [[-1]] or [[-2]], the record
corresponds to initialization and finalization, and the event is
irrelevant.
Note that the event count may be larger than $2^{31}$ (2 GEvents). In
that case, cut off the upper bits since [[NEVHEP]] is probably limited
to default integer.
For the HEPEV4 common block, it is unclear why the [[scalelh]] variable
is 10-dimensional. We choose to only set the first value of the array.
<<HEP common: public>>=
public :: hepevt_init
public :: hepevt_set_event_parameters
<<HEP common: procedures>>=
subroutine hepevt_init (n_tot, n_out)
integer, intent(in) :: n_tot, n_out
NHEP = n_tot
NEVHEP = 0
idruplh = 0
hepevt_n_out = n_out
hepevt_n_remnants = 0
hepevt_weight = 1
eventweightlh = 1
hepevt_function_value = 0
hepevt_function_ratio = 1
alphaqcdlh = -1
alphaqedlh = -1
scalelh = -1
end subroutine hepevt_init
subroutine hepevt_set_event_parameters &
(proc_id, weight, function_value, function_ratio, &
alpha_qcd, alpha_qed, scale, i_evt)
integer, intent(in), optional :: proc_id
integer, intent(in), optional :: i_evt
real(default), intent(in), optional :: weight, function_value, &
function_ratio, alpha_qcd, alpha_qed, scale
if (present (proc_id)) idruplh = proc_id
if (present (i_evt)) NEVHEP = i_evt
if (present (weight)) then
hepevt_weight = weight
eventweightlh = weight
end if
if (present (function_value)) hepevt_function_value = &
function_value
if (present (function_ratio)) hepevt_function_ratio = &
function_ratio
if (present (alpha_qcd)) alphaqcdlh = alpha_qcd
if (present (alpha_qed)) alphaqedlh = alpha_qed
if (present (scale)) scalelh(1) = scale
if (present (i_evt)) NEVHEP = i_evt
end subroutine hepevt_set_event_parameters
@ %def hepevt_init hepevt_set_event_parameters
@ Set the entry for a specific particle. All parameters are set with
the exception of lifetime and spin, where default values are stored.
<<HEP common: public>>=
public :: hepevt_set_particle
<<HEP common: procedures>>=
subroutine hepevt_set_particle &
(i, pdg, status, parent, child, p, m2, hel, vtx, &
col, pol_status, pol, fill_hepev4)
integer, intent(in) :: i
integer, intent(in) :: pdg, status
integer, dimension(:), intent(in) :: parent
integer, dimension(:), intent(in) :: child
logical, intent(in), optional :: fill_hepev4
type(vector4_t), intent(in) :: p
real(default), intent(in) :: m2
integer, dimension(2), intent(in) :: col
integer, intent(in) :: pol_status
integer, intent(in) :: hel
type(polarization_t), intent(in), optional :: pol
type(vector4_t), intent(in) :: vtx
logical :: hepev4
hepev4 = .false.; if (present (fill_hepev4)) hepev4 = fill_hepev4
IDHEP(i) = pdg
select case (status)
case (PRT_BEAM); ISTHEP(i) = 2
case (PRT_INCOMING); ISTHEP(i) = 2
case (PRT_OUTGOING); ISTHEP(i) = 1
case (PRT_VIRTUAL); ISTHEP(i) = 2
case (PRT_RESONANT); ISTHEP(i) = 2
case default; ISTHEP(i) = 0
end select
select case (size (parent))
case (0); JMOHEP(:,i) = 0
case (1); JMOHEP(1,i) = parent(1); JMOHEP(2,i) = 0
case default; JMOHEP(:,i) = [ parent(1), parent(size (parent)) ]
end select
select case (size (child))
case (0); JDAHEP(:,i) = 0
case (1); JDAHEP(:,i) = child(1)
case default; JDAHEP(:,i) = [ child(1), child(size (child)) ]
end select
PHEP(1:3,i) = vector3_get_components (space_part (p))
PHEP(4,i) = energy (p)
PHEP(5,i) = sign (sqrt (abs (m2)), m2)
VHEP(1:3,i) = vtx%p(1:3)
VHEP(4,i) = vtx%p(0)
hepevt_pol(i) = hel
if (hepev4) then
if (col(1) > 0) then
icolorflowlh(1,i) = 500 + col(1)
else
icolorflowlh(1,i) = 0
end if
if (col(2) > 0) then
icolorflowlh(2,i) = 500 + col(2)
else
icolorflowlh(2,i) = 0
end if
if (present (pol) .and. &
pol_status == PRT_GENERIC_POLARIZATION) then
if (pol%is_polarized ()) &
spinlh(:,i) = pol%get_axis ()
else
spinlh(:,i) = zero
spinlh(3,i) = hel
end if
end if
end subroutine hepevt_set_particle
@ %def hepevt_set_particle
@
\subsection{Event output}
This is a verbose output of the HEPEVT block.
<<HEP common: public>>=
public :: hepevt_write_verbose
<<HEP common: procedures>>=
subroutine hepevt_write_verbose (unit)
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)") "HEPEVT Common Block"
write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "NEVHEP", NEVHEP, &
"Event number"
write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "NHEP ", NHEP, &
"Number of particles in event"
do i = 1, NHEP
write (u, "(1x,A,I0)") "Particle #", i
write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)", advance="no") &
"ISTHEP", ISTHEP(i), "Status code: "
select case (ISTHEP(i))
case ( 0); write (u, "(A)") "null entry"
case ( 1); write (u, "(A)") "outgoing"
case ( 2); write (u, "(A)") "decayed"
case ( 3); write (u, "(A)") "documentation"
case (4:10); write (u, "(A)") "[unspecified]"
case (11:200); write (u, "(A)") "[model-specific]"
case (201:); write (u, "(A)") "[user-defined]"
case default; write (u, "(A)") "[undefined]"
end select
write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "IDHEP ", IDHEP(i), &
"PDG code of particle"
write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "JMOHEP", JMOHEP(:,i), &
"Index of first/second mother"
write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "JDAHEP", JDAHEP(:,i), &
"Index of first/last daughter"
write (u, "(3x,A6,' = ',ES12.5,1x,ES12.5,8x,A)") "PHEP12", &
PHEP(1:2,i), "Transversal momentum (x/y) in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PHEP3 ", PHEP(3,i), &
"Longitudinal momentum (z) in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PHEP4 ", PHEP(4,i), &
"Energy in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PHEP5 ", PHEP(5,i), &
"Invariant mass in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,ES12.5,8x,A)") "VHEP12", VHEP(1:2,i), &
"Transversal displacement (xy) in mm"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "VHEP3 ", VHEP(3,i), &
"Longitudinal displacement (z) in mm"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "VHEP4 ", VHEP(4,i), &
"Production time in mm"
end do
end subroutine hepevt_write_verbose
@ %def hepevt_write_verbose
@
This is a verbose output of the HEPEUP block.
<<HEP common: public>>=
public :: hepeup_write_verbose
<<HEP common: procedures>>=
subroutine hepeup_write_verbose (unit)
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(A)") "HEPEUP Common Block"
write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "NUP ", NUP, &
"Number of particles in event"
write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "IDPRUP", IDPRUP, &
"Subprocess ID"
write (u, "(3x,A6,' = ',ES12.5,1x,20x,A)") "XWGTUP", XWGTUP, &
"Event weight"
write (u, "(3x,A6,' = ',ES12.5,1x,20x,A)") "SCALUP", SCALUP, &
"Event energy scale in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,20x,A)") "AQEDUP", AQEDUP, &
"QED coupling [-1 = undefined]"
write (u, "(3x,A6,' = ',ES12.5,1x,20x,A)") "AQCDUP", AQCDUP, &
"QCD coupling [-1 = undefined]"
do i = 1, NUP
write (u, "(1x,A,I0)") "Particle #", i
write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)") "IDUP ", IDUP(i), &
"PDG code of particle"
write (u, "(3x,A6,' = ',I9,3x,1x,20x,A)", advance="no") &
"ISTUP ", ISTUP(i), "Status code: "
select case (ISTUP(i))
case (-1); write (u, "(A)") "incoming"
case ( 1); write (u, "(A)") "outgoing"
case (-2); write (u, "(A)") "spacelike"
case ( 2); write (u, "(A)") "resonance"
case ( 3); write (u, "(A)") "resonance (doc)"
case (-9); write (u, "(A)") "beam"
case default; write (u, "(A)") "[undefined]"
end select
write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "MOTHUP", MOTHUP(:,i), &
"Index of first/last mother"
write (u, "(3x,A6,' = ',I9,3x,1x,I9,3x,8x,A)") "ICOLUP", ICOLUP(:,i), &
"Color/anticolor flow index"
write (u, "(3x,A6,' = ',ES12.5,1x,ES12.5,8x,A)") "PUP1/2", PUP(1:2,i), &
"Transversal momentum (x/y) in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PUP3 ", PUP(3,i), &
"Longitudinal momentum (z) in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PUP4 ", PUP(4,i), &
"Energy in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "PUP5 ", PUP(5,i), &
"Invariant mass in GeV"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "VTIMUP", VTIMUP(i), &
"Invariant lifetime in mm"
write (u, "(3x,A6,' = ',ES12.5,1x,12x,8x,A)") "SPINUP", SPINUP(i), &
"cos(spin angle) [9 = undefined]"
end do
end subroutine hepeup_write_verbose
@ %def hepeup_write_verbose
@
\subsection{Event output in various formats}
This routine writes event output according to the LHEF standard. It
uses the current contents of the HEPEUP block.
<<HEP common: public>>=
public :: hepeup_write_lhef
public :: hepeup_write_lha
<<HEP common: procedures>>=
subroutine hepeup_write_lhef (unit)
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
call msg_debug (D_EVENTS, "hepeup_write_lhef")
call msg_debug2 (D_EVENTS, "ID IST MOTH ICOL P VTIM SPIN")
write (u, "(2(1x,I0),4(1x,ES17.10))") &
NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP
do i = 1, NUP
write (u, "(6(1x,I0),7(1x,ES17.10))") &
IDUP(i), ISTUP(i), MOTHUP(:,i), ICOLUP(:,i), &
PUP(:,i), VTIMUP(i), SPINUP(i)
if (debug2_active (D_EVENTS)) then
write (msg_buffer, "(6(1x,I0),7(1x,ES17.10))") &
IDUP(i), ISTUP(i), MOTHUP(:,i), ICOLUP(:,i), &
PUP(:,i), VTIMUP(i), SPINUP(i)
call msg_message ()
end if
end do
end subroutine hepeup_write_lhef
subroutine hepeup_write_lha (unit)
integer, intent(in), optional :: unit
integer :: u, i
integer, dimension(MAXNUP) :: spin_up
spin_up = int(SPINUP)
u = given_output_unit (unit); if (u < 0) return
write (u, "(2(1x,I5),1x,ES17.10,3(1x,ES13.6))") &
NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP
write (u, "(500(1x,I5))") IDUP(:NUP)
write (u, "(500(1x,I5))") MOTHUP(1,:NUP)
write (u, "(500(1x,I5))") MOTHUP(2,:NUP)
write (u, "(500(1x,I5))") ICOLUP(1,:NUP)
write (u, "(500(1x,I5))") ICOLUP(2,:NUP)
write (u, "(500(1x,I5))") ISTUP(:NUP)
write (u, "(500(1x,I5))") spin_up(:NUP)
do i = 1, NUP
write (u, "(1x,I5,4(1x,ES17.10))") i, PUP([ 4,1,2,3 ], i)
end do
end subroutine hepeup_write_lha
@ %def hepeup_write_lhef hepeup_write_lha
@ This routine writes event output according to the HEPEVT standard. It
uses the current contents of the HEPEVT block and some additional
parameters according to the standard in WHIZARD 1. For the long ASCII
format, the value of the sample function (i.e. the product of squared
matrix element, structure functions and phase space factor is printed out).
The option of reweighting matrix elements with respect to some
reference cross section is not implemented in WHIZARD 2 for this event
format, therefore the second entry in the long ASCII format (the
function ratio) is always one. The ATHENA format is an implementation
of the HEPEVT format that is readable by the ATLAS ATHENA software
framework. It is very similar to the WHIZARD 1 HEPEVT format, except
that it contains an event counter, a particle counter inside the
event, and has the HEPEVT [[ISTHEP]] status before the PDG code. The
MOKKA format is a special ASCII format that contains the information
to be parsed to the MOKKA LC fast simulation software.
<<HEP common: public>>=
public :: hepevt_write_hepevt
public :: hepevt_write_ascii
public :: hepevt_write_athena
public :: hepevt_write_mokka
<<HEP common: procedures>>=
subroutine hepevt_write_hepevt (unit)
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(3(1x,I0),(1x,ES17.10))") &
NHEP, hepevt_n_out, hepevt_n_remnants, hepevt_weight
do i = 1, NHEP
write (u, "(7(1x,I0))") &
ISTHEP(i), IDHEP(i), JMOHEP(:,i), JDAHEP(:,i), hepevt_pol(i)
write (u, "(5(1x,ES17.10))") PHEP(:,i)
write (u, "(5(1x,ES17.10))") VHEP(:,i), 0.d0
end do
end subroutine hepevt_write_hepevt
subroutine hepevt_write_ascii (unit, long)
integer, intent(in), optional :: unit
logical, intent(in) :: long
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(3(1x,I0),(1x,ES17.10))") &
NHEP, hepevt_n_out, hepevt_n_remnants, hepevt_weight
do i = 1, NHEP
if (ISTHEP(i) /= 1) cycle
write (u, "(2(1x,I0))") IDHEP(i), hepevt_pol(i)
write (u, "(5(1x,ES17.10))") PHEP(:,i)
end do
if (long) then
write (u, "(2(1x,ES17.10))") &
hepevt_function_value, hepevt_function_ratio
end if
end subroutine hepevt_write_ascii
subroutine hepevt_write_athena (unit)
integer, intent(in), optional :: unit
integer :: u, i, num_event
num_event = 0
u = given_output_unit (unit); if (u < 0) return
write (u, "(2(1x,I0))") NEVHEP, NHEP
do i = 1, NHEP
write (u, "(7(1x,I0))") &
i, ISTHEP(i), IDHEP(i), JMOHEP(:,i), JDAHEP(:,i)
write (u, "(5(1x,ES17.10))") PHEP(:,i)
write (u, "(5(1x,ES17.10))") VHEP(1:4,i)
end do
end subroutine hepevt_write_athena
subroutine hepevt_write_mokka (unit)
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit); if (u < 0) return
write (u, "(3(1x,I0),(1x,ES17.10))") &
NHEP, hepevt_n_out, hepevt_n_remnants, hepevt_weight
do i = 1, NHEP
write (u, "(4(1x,I0),4(1x,ES17.10))") &
ISTHEP(i), IDHEP(i), JDAHEP(1,i), JDAHEP(2,i), &
PHEP(1:3,i), PHEP(5,i)
end do
end subroutine hepevt_write_mokka
@ %def hepevt_write_hepevt hepevt_write_ascii
@ %def hepevt_write_athena
@
\subsection{Event input in various formats}
This routine writes event output according to the LHEF standard. It
uses the current contents of the HEPEUP block.
<<HEP common: public>>=
public :: hepeup_read_lhef
<<HEP common: procedures>>=
subroutine hepeup_read_lhef (u)
integer, intent(in) :: u
integer :: i
read (u, *) &
NUP, IDPRUP, XWGTUP, SCALUP, AQEDUP, AQCDUP
do i = 1, NUP
read (u, *) &
IDUP(i), ISTUP(i), MOTHUP(:,i), ICOLUP(:,i), &
PUP(:,i), VTIMUP(i), SPINUP(i)
end do
end subroutine hepeup_read_lhef
@ %def hepeup_read_lhef
@
\subsection{Data Transfer: particle sets}
The \whizard\ format for handling particle data in events is
[[particle_set_t]]. We have to interface this to the common blocks.
We first create a new particle set that contains only the particles
that are supported by the LHEF format. These are: beam, incoming,
resonant, outgoing. We drop particles with unknown, virtual or
beam-remnant status.
From this set we fill the common block. Event information such as
process ID and weight is not transferred here; this has to be done by
the caller. The spin information is set only if the particle has a
unique mother, and if its polarization is fully defined.
We use this routine also to hand over information to Pythia which lets
Tauola access SPINUP. Tauola expects in SPINUP the helicity and not the
LHA convention. We switch to this mode with [[tauola_convention]].
<<HEP common: public>>=
public :: hepeup_from_particle_set
<<HEP common: procedures>>=
subroutine hepeup_from_particle_set (pset_in, &
keep_beams, keep_remnants, tauola_convention)
type(particle_set_t), intent(in) :: pset_in
type(particle_set_t), target :: pset
logical, intent(in), optional :: keep_beams
logical, intent(in), optional :: keep_remnants
logical, intent(in), optional :: tauola_convention
integer :: i, n_parents, status, n_tot
integer, dimension(1) :: i_mother
logical :: kr, tc
kr = .true.; if (present (keep_remnants)) kr = keep_remnants
tc = .false.; if (present (tauola_convention)) tc = tauola_convention
call pset_in%filter_particles (pset, real_parents = .true. , &
keep_beams = keep_beams, keep_virtuals = .false.)
n_tot = pset%get_n_tot ()
call hepeup_init (n_tot)
do i = 1, n_tot
associate (prt => pset%prt(i))
status = prt%get_status ()
if (kr .and. status == PRT_BEAM_REMNANT &
.and. prt%get_n_children () == 0) &
status = PRT_OUTGOING
call hepeup_set_particle (i, &
prt%get_pdg (), &
status, &
prt%get_parents (), &
prt%get_color (), &
prt%get_momentum (), &
prt%get_p2 ())
n_parents = prt%get_n_parents ()
call hepeup_set_particle_lifetime (i, &
prt%get_lifetime ())
if (.not. tc) then
if (n_parents == 1) then
i_mother = prt%get_parents ()
select case (prt%get_polarization_status ())
case (PRT_GENERIC_POLARIZATION)
call hepeup_set_particle_spin (i, &
prt%get_momentum (), &
prt%get_polarization (), &
pset%prt(i_mother(1))%get_momentum ())
end select
end if
else
select case (prt%get_polarization_status ())
case (PRT_DEFINITE_HELICITY)
SPINUP(i) = prt%get_helicity()
end select
end if
end associate
end do
end subroutine hepeup_from_particle_set
@ %def hepeup_from_particle_set
@ Input. The particle set should be allocated properly, but we
replace the particle contents.
If there are no beam particles in the event, we try to reconstruct beam
particles and beam remnants. We assume for simplicity that the beam
particles, if any, are the first two particles. If they are absent, the first
two particles should be the incoming partons.
<<HEP common: public>>=
public :: hepeup_to_particle_set
<<HEP common: procedures>>=
subroutine hepeup_to_particle_set &
(particle_set, recover_beams, model, alt_model)
type(particle_set_t), intent(inout), target :: particle_set
logical, intent(in), optional :: recover_beams
class(model_data_t), intent(in), target :: model, alt_model
type(particle_t), dimension(:), allocatable :: prt
integer, dimension(2) :: parent
integer, dimension(:), allocatable :: child
integer :: i, j, k, pdg, status
type(flavor_t) :: flv
type(color_t) :: col
integer, dimension(2) :: c
type(vector4_t) :: p
real(default) :: p2
logical :: reconstruct
integer :: off
if (present (recover_beams)) then
reconstruct = recover_beams .and. .not. all (ISTUP(1:2) == PRT_BEAM)
else
reconstruct = .false.
end if
if (reconstruct) then
off = 4
else
off = 0
end if
allocate (prt (NUP + off), child (NUP + off))
do i = 1, NUP
k = i + off
call hepeup_get_particle (i, pdg, status, col = c, p = p, m2 = p2)
call flv%init (pdg, model, alt_model)
call prt(k)%set_flavor (flv)
call prt(k)%reset_status (status)
call col%init (c)
call prt(k)%set_color (col)
call prt(k)%set_momentum (p, p2)
where (MOTHUP(:,i) /= 0)
parent = MOTHUP(:,i) + off
elsewhere
parent = 0
end where
call prt(k)%set_parents (parent)
child = [(j, j = 1 + off, NUP + off)]
where (MOTHUP(1,:NUP) /= i .and. MOTHUP(2,:NUP) /= i) child = 0
call prt(k)%set_children (child)
end do
if (reconstruct) then
do k = 1, 2
call prt(k)%reset_status (PRT_BEAM)
call prt(k)%set_children ([k+2,k+4])
end do
do k = 3, 4
call prt(k)%reset_status (PRT_BEAM_REMNANT)
call prt(k)%set_parents ([k-2])
end do
do k = 5, 6
call prt(k)%set_parents ([k-4])
end do
end if
call particle_set%replace (prt)
end subroutine hepeup_to_particle_set
@ %def hepeup_to_particle_set
@
The HEPEVT common block is quite similar, but does contain less
information, e.g. no color flows (it was LEP time). The spin
information is set only if the particle has a unique mother, and if
its polarization is fully defined.
<<HEP common: public>>=
public :: hepevt_from_particle_set
<<HEP common: procedures>>=
subroutine hepevt_from_particle_set &
(particle_set, keep_beams, keep_remnants, ensure_order, fill_hepev4)
type(particle_set_t), intent(in) :: particle_set
type(particle_set_t), target :: pset_hepevt, pset_tmp
logical, intent(in), optional :: keep_beams
logical, intent(in), optional :: keep_remnants
logical, intent(in), optional :: ensure_order
logical, intent(in), optional :: fill_hepev4
integer :: i, status, n_tot
logical :: activate_remnants, ensure
activate_remnants = .true.
if (present (keep_remnants)) activate_remnants = keep_remnants
ensure = .false.
if (present (ensure_order)) ensure = ensure_order
call particle_set%filter_particles (pset_tmp, real_parents = .true., &
keep_virtuals = .false., keep_beams = keep_beams)
if (ensure) then
call pset_tmp%to_hepevt_form (pset_hepevt)
else
pset_hepevt = pset_tmp
end if
n_tot = pset_hepevt%get_n_tot ()
call hepevt_init (n_tot, pset_hepevt%get_n_out ())
do i = 1, n_tot
associate (prt => pset_hepevt%prt(i))
status = prt%get_status ()
if (activate_remnants &
.and. status == PRT_BEAM_REMNANT &
.and. prt%get_n_children () == 0) &
status = PRT_OUTGOING
select case (prt%get_polarization_status ())
case (PRT_GENERIC_POLARIZATION)
call hepevt_set_particle (i, &
prt%get_pdg (), status, &
prt%get_parents (), &
prt%get_children (), &
prt%get_momentum (), &
prt%get_p2 (), &
prt%get_helicity (), &
prt%get_vertex (), &
prt%get_color (), &
prt%get_polarization_status (), &
pol = prt%get_polarization (), &
fill_hepev4 = fill_hepev4)
case default
call hepevt_set_particle (i, &
prt%get_pdg (), status, &
prt%get_parents (), &
prt%get_children (), &
prt%get_momentum (), &
prt%get_p2 (), &
prt%get_helicity (), &
prt%get_vertex (), &
prt%get_color (), &
prt%get_polarization_status (), &
fill_hepev4 = fill_hepev4)
end select
end associate
end do
call pset_hepevt%final ()
end subroutine hepevt_from_particle_set
@ %def hepevt_from_particle_set
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{HepMC events}
This section provides the interface to the HepMC C++ library for handling
Monte-Carlo events.
Each C++ class of HepMC that we use is mirrored by a Fortran type,
which contains as its only component the C pointer to the C++ object.
Each C++ method of HepMC that we use has a C wrapper function. This
function takes a pointer to the host object as its first argument.
Further arguments are either C pointers, or in the case of simple
types (integer, real), interoperable C/Fortran objects.
The C wrapper functions have explicit interfaces in the Fortran
module. They are called by Fortran wrapper procedures. These are
treated as methods of the corresponding Fortran type.
<<[[hepmc_interface.f90]]>>=
<<File header>>
module hepmc_interface
use, intrinsic :: iso_c_binding !NODEP!
<<Use kinds>>
<<Use strings>>
use constants, only: PI
use lorentz
use flavors
use colors
use helicities
use polarizations
<<Standard module head>>
<<HepMC interface: public>>
<<HepMC interface: types>>
<<HepMC interface: parameters>>
<<HepMC interface: interfaces>>
contains
<<HepMC interface: procedures>>
end module hepmc_interface
@ %def hepmc_interface
@
\subsection{Interface check}
This function can be called in order to verify that we are using the
actual HepMC library, and not the dummy version.
<<HepMC interface: interfaces>>=
interface
logical(c_bool) function hepmc_available () bind(C)
import
end function hepmc_available
end interface
<<HepMC interface: public>>=
public :: hepmc_is_available
<<HepMC interface: procedures>>=
function hepmc_is_available () result (flag)
logical :: flag
flag = hepmc_available ()
end function hepmc_is_available
@ %def hepmc_is_available
@
\subsection{FourVector}
The C version of four-vectors is often transferred by value, and the
associated procedures are all inlined. The wrapper needs to transfer
by reference, so we create FourVector objects on the heap which have
to be deleted explicitly. The input is a [[vector4_t]] or
[[vector3_t]] object from the [[lorentz]] module.
<<HepMC interface: public>>=
public :: hepmc_four_vector_t
<<HepMC interface: types>>=
type :: hepmc_four_vector_t
private
type(c_ptr) :: obj
end type hepmc_four_vector_t
@ %def hepmc_four_vector_t
@ In the C constructor, the zero-component (fourth argument) is
optional; if missing, it is set to zero. The Fortran version has
initializer form and takes either a three-vector or a four-vector.
A further version extracts the four-vector from a HepMC particle
object.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function new_four_vector_xyz (x, y, z) bind(C)
import
real(c_double), value :: x, y, z
end function new_four_vector_xyz
end interface
interface
type(c_ptr) function new_four_vector_xyzt (x, y, z, t) bind(C)
import
real(c_double), value :: x, y, z, t
end function new_four_vector_xyzt
end interface
@ %def new_four_vector_xyz new_four_vector_xyzt
<<HepMC interface: public>>=
public :: hepmc_four_vector_init
<<HepMC interface: interfaces>>=
interface hepmc_four_vector_init
module procedure hepmc_four_vector_init_v4
module procedure hepmc_four_vector_init_v3
module procedure hepmc_four_vector_init_hepmc_prt
end interface
<<HepMC interface: procedures>>=
subroutine hepmc_four_vector_init_v4 (pp, p)
type(hepmc_four_vector_t), intent(out) :: pp
type(vector4_t), intent(in) :: p
real(default), dimension(0:3) :: pa
pa = vector4_get_components (p)
pp%obj = new_four_vector_xyzt &
(real (pa(1), c_double), &
real (pa(2), c_double), &
real (pa(3), c_double), &
real (pa(0), c_double))
end subroutine hepmc_four_vector_init_v4
subroutine hepmc_four_vector_init_v3 (pp, p)
type(hepmc_four_vector_t), intent(out) :: pp
type(vector3_t), intent(in) :: p
real(default), dimension(3) :: pa
pa = vector3_get_components (p)
pp%obj = new_four_vector_xyz &
(real (pa(1), c_double), &
real (pa(2), c_double), &
real (pa(3), c_double))
end subroutine hepmc_four_vector_init_v3
subroutine hepmc_four_vector_init_hepmc_prt (pp, prt)
type(hepmc_four_vector_t), intent(out) :: pp
type(hepmc_particle_t), intent(in) :: prt
pp%obj = gen_particle_momentum (prt%obj)
end subroutine hepmc_four_vector_init_hepmc_prt
@ %def hepmc_four_vector_init
@ Here, the destructor is explicitly needed.
<<HepMC interface: interfaces>>=
interface
subroutine four_vector_delete (p_obj) bind(C)
import
type(c_ptr), value :: p_obj
end subroutine four_vector_delete
end interface
@ %def four_vector_delete
<<HepMC interface: public>>=
public :: hepmc_four_vector_final
<<HepMC interface: procedures>>=
subroutine hepmc_four_vector_final (p)
type(hepmc_four_vector_t), intent(inout) :: p
call four_vector_delete (p%obj)
end subroutine hepmc_four_vector_final
@ %def hepmc_four_vector_final
@ Convert to a Lorentz vector.
<<HepMC interface: interfaces>>=
interface
function four_vector_px (p_obj) result (px) bind(C)
import
real(c_double) :: px
type(c_ptr), value :: p_obj
end function four_vector_px
end interface
interface
function four_vector_py (p_obj) result (py) bind(C)
import
real(c_double) :: py
type(c_ptr), value :: p_obj
end function four_vector_py
end interface
interface
function four_vector_pz (p_obj) result (pz) bind(C)
import
real(c_double) :: pz
type(c_ptr), value :: p_obj
end function four_vector_pz
end interface
interface
function four_vector_e (p_obj) result (e) bind(C)
import
real(c_double) :: e
type(c_ptr), value :: p_obj
end function four_vector_e
end interface
@ %def four_vector_px four_vector_py four_vector_pz four_vector_e
<<HepMC interface: public>>=
public :: hepmc_four_vector_to_vector4
<<HepMC interface: procedures>>=
subroutine hepmc_four_vector_to_vector4 (pp, p)
type(hepmc_four_vector_t), intent(in) :: pp
type(vector4_t), intent(out) :: p
real(default) :: E
real(default), dimension(3) :: p3
E = four_vector_e (pp%obj)
p3(1) = four_vector_px (pp%obj)
p3(2) = four_vector_py (pp%obj)
p3(3) = four_vector_pz (pp%obj)
p = vector4_moving (E, vector3_moving (p3))
end subroutine hepmc_four_vector_to_vector4
@ %def hepmc_four_vector_to_vector4
@
\subsection{Polarization}
Polarization objects are temporarily used for assigning particle
polarization. We add a flag [[polarized]]. If this is false, the
polarization is not set and should not be transferred to
[[hepmc_particle]] objects.
<<HepMC interface: public>>=
public :: hepmc_polarization_t
<<HepMC interface: types>>=
type :: hepmc_polarization_t
private
logical :: polarized = .false.
type(c_ptr) :: obj
end type hepmc_polarization_t
@ %def hepmc_polarization_t
@ Constructor. The C wrapper takes polar and azimuthal angle as
arguments. The Fortran version allows for either a complete
polarization density matrix, or for a definite (diagonal) helicity.
\emph{HepMC does not allow to specify the degree of polarization,
therefore we have to map it to either 0 or 1. We choose 0 for
polarization less than $0.5$ and 1 for polarization greater than
$0.5$. Even this simplification works only for spin-1/2 and for
massless particles; massive vector bosons cannot be treated this
way. In particular, zero helicity is always translated as
unpolarized.}
\emph{For massive vector bosons, we arbitrarily choose the convention
that the longitudinal (zero) helicity state is mapped to the theta
angle $\pi/2$. This works under the condition that helicity is
projected onto one of the basis states.}
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function new_polarization (theta, phi) bind(C)
import
real(c_double), value :: theta, phi
end function new_polarization
end interface
@ %def new_polarization
<<HepMC interface: public>>=
public :: hepmc_polarization_init
<<HepMC interface: interfaces>>=
interface hepmc_polarization_init
module procedure hepmc_polarization_init_pol
module procedure hepmc_polarization_init_hel
module procedure hepmc_polarization_init_int
end interface
<<HepMC interface: procedures>>=
subroutine hepmc_polarization_init_pol (hpol, pol)
type(hepmc_polarization_t), intent(out) :: hpol
type(polarization_t), intent(in) :: pol
real(default) :: r, theta, phi
if (pol%is_polarized ()) then
call pol%to_angles (r, theta, phi)
if (r >= 0.5) then
hpol%polarized = .true.
hpol%obj = new_polarization &
(real (theta, c_double), real (phi, c_double))
end if
end if
end subroutine hepmc_polarization_init_pol
subroutine hepmc_polarization_init_hel (hpol, hel)
type(hepmc_polarization_t), intent(out) :: hpol
type(helicity_t), intent(in) :: hel
integer, dimension(2) :: h
if (hel%is_defined ()) then
h = hel%to_pair ()
select case (h(1))
case (1:)
hpol%polarized = .true.
hpol%obj = new_polarization (0._c_double, 0._c_double)
case (:-1)
hpol%polarized = .true.
hpol%obj = new_polarization (real (pi, c_double), 0._c_double)
case (0)
hpol%polarized = .true.
hpol%obj = new_polarization (real (pi/2, c_double), 0._c_double)
end select
end if
end subroutine hepmc_polarization_init_hel
subroutine hepmc_polarization_init_int (hpol, hel)
type(hepmc_polarization_t), intent(out) :: hpol
integer, intent(in) :: hel
select case (hel)
case (1:)
hpol%polarized = .true.
hpol%obj = new_polarization (0._c_double, 0._c_double)
case (:-1)
hpol%polarized = .true.
hpol%obj = new_polarization (real (pi, c_double), 0._c_double)
case (0)
hpol%polarized = .true.
hpol%obj = new_polarization (real (pi/2, c_double), 0._c_double)
end select
end subroutine hepmc_polarization_init_int
@ %def hepmc_polarization_init
@ Destructor. The C object is deallocated only if the [[polarized]]
flag is set.
<<HepMC interface: interfaces>>=
interface
subroutine polarization_delete (pol_obj) bind(C)
import
type(c_ptr), value :: pol_obj
end subroutine polarization_delete
end interface
@ %def polarization_delete
<<HepMC interface: public>>=
public :: hepmc_polarization_final
<<HepMC interface: procedures>>=
subroutine hepmc_polarization_final (hpol)
type(hepmc_polarization_t), intent(inout) :: hpol
if (hpol%polarized) call polarization_delete (hpol%obj)
end subroutine hepmc_polarization_final
@ %def hepmc_polarization_final
@ Recover polarization from HepMC polarization object (with the
abovementioned deficiencies).
<<HepMC interface: interfaces>>=
interface
function polarization_theta (pol_obj) result (theta) bind(C)
import
real(c_double) :: theta
type(c_ptr), value :: pol_obj
end function polarization_theta
end interface
interface
function polarization_phi (pol_obj) result (phi) bind(C)
import
real(c_double) :: phi
type(c_ptr), value :: pol_obj
end function polarization_phi
end interface
@ %def polarization_theta polarization_phi
<<HepMC interface: public>>=
public :: hepmc_polarization_to_pol
<<HepMC interface: procedures>>=
subroutine hepmc_polarization_to_pol (hpol, flv, pol)
type(hepmc_polarization_t), intent(in) :: hpol
type(flavor_t), intent(in) :: flv
type(polarization_t), intent(out) :: pol
real(default) :: theta, phi
theta = polarization_theta (hpol%obj)
phi = polarization_phi (hpol%obj)
call pol%init_angles (flv, 1._default, theta, phi)
end subroutine hepmc_polarization_to_pol
@ %def hepmc_polarization_to_pol
@ Recover helicity. Here, $\phi$ is ignored and only the sign of
$\cos\theta$ is relevant, mapped to positive/negative helicity.
<<HepMC interface: public>>=
public :: hepmc_polarization_to_hel
<<HepMC interface: procedures>>=
subroutine hepmc_polarization_to_hel (hpol, flv, hel)
type(hepmc_polarization_t), intent(in) :: hpol
type(flavor_t), intent(in) :: flv
type(helicity_t), intent(out) :: hel
real(default) :: theta
integer :: hmax
theta = polarization_theta (hpol%obj)
hmax = flv%get_spin_type () / 2
call hel%init (sign (hmax, nint (cos (theta))))
end subroutine hepmc_polarization_to_hel
@ %def hepmc_polarization_to_hel
@
\subsection{GenParticle}
Particle objects have the obvious meaning.
<<HepMC interface: public>>=
public :: hepmc_particle_t
<<HepMC interface: types>>=
type :: hepmc_particle_t
private
type(c_ptr) :: obj
end type hepmc_particle_t
@ %def hepmc_particle_t
@ Constructor. The C version takes a FourVector object, which in the
Fortran wrapper is created on the fly from a [[vector4]] Lorentz
vector.
No destructor is needed as long as all particles are entered into
vertex containers.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function new_gen_particle (prt_obj, pdg_id, status) bind(C)
import
type(c_ptr), value :: prt_obj
integer(c_int), value :: pdg_id, status
end function new_gen_particle
end interface
@ %def new_gen_particle
<<HepMC interface: public>>=
public :: hepmc_particle_init
<<HepMC interface: procedures>>=
subroutine hepmc_particle_init (prt, p, pdg, status)
type(hepmc_particle_t), intent(out) :: prt
type(vector4_t), intent(in) :: p
integer, intent(in) :: pdg, status
type(hepmc_four_vector_t) :: pp
call hepmc_four_vector_init (pp, p)
prt%obj = new_gen_particle (pp%obj, int (pdg, c_int), int (status, c_int))
call hepmc_four_vector_final (pp)
end subroutine hepmc_particle_init
@ %def hepmc_particle_init
@ Set the particle color flow.
<<HepMC interface: interfaces>>=
interface
subroutine gen_particle_set_flow (prt_obj, code_index, code) bind(C)
import
type(c_ptr), value :: prt_obj
integer(c_int), value :: code_index, code
end subroutine gen_particle_set_flow
end interface
@ %def gen_particle_set_flow
@ Set the particle color. Either from a [[color_t]] object or
directly from a pair of integers.
<<HepMC interface: interfaces>>=
interface hepmc_particle_set_color
module procedure hepmc_particle_set_color_col
module procedure hepmc_particle_set_color_int
end interface hepmc_particle_set_color
<<HepMC interface: public>>=
public :: hepmc_particle_set_color
<<HepMC interface: procedures>>=
subroutine hepmc_particle_set_color_col (prt, col)
type(hepmc_particle_t), intent(inout) :: prt
type(color_t), intent(in) :: col
integer(c_int) :: c
c = col%get_col ()
if (c /= 0) call gen_particle_set_flow (prt%obj, 1_c_int, c)
c = col%get_acl ()
if (c /= 0) call gen_particle_set_flow (prt%obj, 2_c_int, c)
end subroutine hepmc_particle_set_color_col
subroutine hepmc_particle_set_color_int (prt, col)
type(hepmc_particle_t), intent(inout) :: prt
integer, dimension(2), intent(in) :: col
integer(c_int) :: c
c = col(1)
if (c /= 0) call gen_particle_set_flow (prt%obj, 1_c_int, c)
c = col(2)
if (c /= 0) call gen_particle_set_flow (prt%obj, 2_c_int, c)
end subroutine hepmc_particle_set_color_int
@ %def hepmc_particle_set_color
@ Set the particle polarization. For the restrictions on particle
polarization in HepMC, see above [[hepmc_polarization_init]].
<<HepMC interface: interfaces>>=
interface
subroutine gen_particle_set_polarization (prt_obj, pol_obj) bind(C)
import
type(c_ptr), value :: prt_obj, pol_obj
end subroutine gen_particle_set_polarization
end interface
@ %def gen_particle_set_polarization
<<HepMC interface: public>>=
public :: hepmc_particle_set_polarization
<<HepMC interface: interfaces>>=
interface hepmc_particle_set_polarization
module procedure hepmc_particle_set_polarization_pol
module procedure hepmc_particle_set_polarization_hel
module procedure hepmc_particle_set_polarization_int
end interface
<<HepMC interface: procedures>>=
subroutine hepmc_particle_set_polarization_pol (prt, pol)
type(hepmc_particle_t), intent(inout) :: prt
type(polarization_t), intent(in) :: pol
type(hepmc_polarization_t) :: hpol
call hepmc_polarization_init (hpol, pol)
if (hpol%polarized) call gen_particle_set_polarization (prt%obj, hpol%obj)
call hepmc_polarization_final (hpol)
end subroutine hepmc_particle_set_polarization_pol
subroutine hepmc_particle_set_polarization_hel (prt, hel)
type(hepmc_particle_t), intent(inout) :: prt
type(helicity_t), intent(in) :: hel
type(hepmc_polarization_t) :: hpol
call hepmc_polarization_init (hpol, hel)
if (hpol%polarized) call gen_particle_set_polarization (prt%obj, hpol%obj)
call hepmc_polarization_final (hpol)
end subroutine hepmc_particle_set_polarization_hel
subroutine hepmc_particle_set_polarization_int (prt, hel)
type(hepmc_particle_t), intent(inout) :: prt
integer, intent(in) :: hel
type(hepmc_polarization_t) :: hpol
call hepmc_polarization_init (hpol, hel)
if (hpol%polarized) call gen_particle_set_polarization (prt%obj, hpol%obj)
call hepmc_polarization_final (hpol)
end subroutine hepmc_particle_set_polarization_int
@ %def hepmc_particle_set_polarization
@ Return the HepMC barcode (unique integer ID) of the particle.
<<HepMC interface: interfaces>>=
interface
function gen_particle_barcode (prt_obj) result (barcode) bind(C)
import
integer(c_int) :: barcode
type(c_ptr), value :: prt_obj
end function gen_particle_barcode
end interface
@ %def gen_particle_barcode
<<HepMC interface: public>>=
public :: hepmc_particle_get_barcode
<<HepMC interface: procedures>>=
function hepmc_particle_get_barcode (prt) result (barcode)
integer :: barcode
type(hepmc_particle_t), intent(in) :: prt
barcode = gen_particle_barcode (prt%obj)
end function hepmc_particle_get_barcode
@ %def hepmc_particle_get_barcode
@ Return the four-vector component of the particle object as a [[vector4_t]] Lorentz vector.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function gen_particle_momentum (prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function gen_particle_momentum
end interface
@ %def gen_particle_momentum
<<HepMC interface: public>>=
public :: hepmc_particle_get_momentum
<<HepMC interface: procedures>>=
function hepmc_particle_get_momentum (prt) result (p)
type(vector4_t) :: p
type(hepmc_particle_t), intent(in) :: prt
type(hepmc_four_vector_t) :: pp
call hepmc_four_vector_init (pp, prt)
call hepmc_four_vector_to_vector4 (pp, p)
call hepmc_four_vector_final (pp)
end function hepmc_particle_get_momentum
@ %def hepmc_particle_get_momentum
@ Return the invariant mass squared of the particle object. HepMC
stores the signed invariant mass (no squaring).
<<HepMC interface: interfaces>>=
interface
function gen_particle_generated_mass (prt_obj) result (mass) bind(C)
import
real(c_double) :: mass
type(c_ptr), value :: prt_obj
end function gen_particle_generated_mass
end interface
@ %def gen_particle_generated_mass
<<HepMC interface: public>>=
public :: hepmc_particle_get_mass_squared
<<HepMC interface: procedures>>=
function hepmc_particle_get_mass_squared (prt) result (m2)
real(default) :: m2
type(hepmc_particle_t), intent(in) :: prt
real(default) :: m
m = gen_particle_generated_mass (prt%obj)
m2 = sign (m**2, m)
end function hepmc_particle_get_mass_squared
@ %def hepmc_particle_get_mass_squared
@ Return the PDG ID:
<<HepMC interface: interfaces>>=
interface
function gen_particle_pdg_id (prt_obj) result (pdg_id) bind(C)
import
integer(c_int) :: pdg_id
type(c_ptr), value :: prt_obj
end function gen_particle_pdg_id
end interface
@ %def gen_particle_pdg_id
<<HepMC interface: public>>=
public :: hepmc_particle_get_pdg
<<HepMC interface: procedures>>=
function hepmc_particle_get_pdg (prt) result (pdg)
integer :: pdg
type(hepmc_particle_t), intent(in) :: prt
pdg = gen_particle_pdg_id (prt%obj)
end function hepmc_particle_get_pdg
@ %def hepmc_particle_get_pdg
@ Return the status code:
<<HepMC interface: interfaces>>=
interface
function gen_particle_status (prt_obj) result (status) bind(C)
import
integer(c_int) :: status
type(c_ptr), value :: prt_obj
end function gen_particle_status
end interface
@ %def gen_particle_status
<<HepMC interface: public>>=
public :: hepmc_particle_get_status
<<HepMC interface: procedures>>=
function hepmc_particle_get_status (prt) result (status)
integer :: status
type(hepmc_particle_t), intent(in) :: prt
status = gen_particle_status (prt%obj)
end function hepmc_particle_get_status
@ %def hepmc_particle_get_status
<<HepMC interface: interfaces>>=
interface
function gen_particle_is_beam (prt_obj) result (is_beam) bind(C)
import
logical(c_bool) :: is_beam
type(c_ptr), value :: prt_obj
end function gen_particle_is_beam
end interface
@ %def gen_particle_is_beam
@ Determine whether a particle is a beam particle.
<<HepMC interface: public>>=
public :: hepmc_particle_is_beam
<<HepMC interface: procedures>>=
function hepmc_particle_is_beam (prt) result (is_beam)
logical :: is_beam
type(hepmc_particle_t), intent(in) :: prt
is_beam = gen_particle_is_beam (prt%obj)
end function hepmc_particle_is_beam
@ %def hepmc_particle_is_beam
@ Return the production/decay vertex (as a pointer, no finalization
necessary).
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function gen_particle_production_vertex (prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function gen_particle_production_vertex
end interface
interface
type(c_ptr) function gen_particle_end_vertex (prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function gen_particle_end_vertex
end interface
@ %def gen_particle_production_vertex gen_particle_end_vertex
<<HepMC interface: public>>=
public :: hepmc_particle_get_production_vertex
public :: hepmc_particle_get_decay_vertex
<<HepMC interface: procedures>>=
function hepmc_particle_get_production_vertex (prt) result (v)
type(hepmc_vertex_t) :: v
type(hepmc_particle_t), intent(in) :: prt
v%obj = gen_particle_production_vertex (prt%obj)
end function hepmc_particle_get_production_vertex
function hepmc_particle_get_decay_vertex (prt) result (v)
type(hepmc_vertex_t) :: v
type(hepmc_particle_t), intent(in) :: prt
v%obj = gen_particle_end_vertex (prt%obj)
end function hepmc_particle_get_decay_vertex
@ %def hepmc_particle_get_production_vertex hepmc_particle_get_decay_vertex
@ Return the number of parents/children.
<<HepMC interface: public>>=
public :: hepmc_particle_get_n_parents
public :: hepmc_particle_get_n_children
<<HepMC interface: procedures>>=
function hepmc_particle_get_n_parents (prt) result (n_parents)
integer :: n_parents
type(hepmc_particle_t), intent(in) :: prt
type(hepmc_vertex_t) :: v
v = hepmc_particle_get_production_vertex (prt)
if (hepmc_vertex_is_valid (v)) then
n_parents = hepmc_vertex_get_n_in (v)
else
n_parents = 0
end if
end function hepmc_particle_get_n_parents
function hepmc_particle_get_n_children (prt) result (n_children)
integer :: n_children
type(hepmc_particle_t), intent(in) :: prt
type(hepmc_vertex_t) :: v
v = hepmc_particle_get_decay_vertex (prt)
if (hepmc_vertex_is_valid (v)) then
n_children = hepmc_vertex_get_n_out (v)
else
n_children = 0
end if
end function hepmc_particle_get_n_children
@ %def hepmc_particle_get_n_parents
@ %def hepmc_particle_get_n_children
@ Convenience function: Return the array of parent particles for a
given HepMC particle. The contents are HepMC barcodes that still have
to be mapped to the particle indices.
<<HepMC interface: public>>=
public :: hepmc_particle_get_parent_barcodes
public :: hepmc_particle_get_child_barcodes
<<HepMC interface: procedures>>=
function hepmc_particle_get_parent_barcodes (prt) result (parent_barcode)
type(hepmc_particle_t), intent(in) :: prt
integer, dimension(:), allocatable :: parent_barcode
type(hepmc_vertex_t) :: v
type(hepmc_vertex_particle_in_iterator_t) :: it
integer :: i
v = hepmc_particle_get_production_vertex (prt)
if (hepmc_vertex_is_valid (v)) then
allocate (parent_barcode (hepmc_vertex_get_n_in (v)))
if (size (parent_barcode) /= 0) then
call hepmc_vertex_particle_in_iterator_init (it, v)
do i = 1, size (parent_barcode)
parent_barcode(i) = hepmc_particle_get_barcode &
(hepmc_vertex_particle_in_iterator_get (it))
call hepmc_vertex_particle_in_iterator_advance (it)
end do
call hepmc_vertex_particle_in_iterator_final (it)
end if
else
allocate (parent_barcode (0))
end if
end function hepmc_particle_get_parent_barcodes
function hepmc_particle_get_child_barcodes (prt) result (child_barcode)
type(hepmc_particle_t), intent(in) :: prt
integer, dimension(:), allocatable :: child_barcode
type(hepmc_vertex_t) :: v
type(hepmc_vertex_particle_out_iterator_t) :: it
integer :: i
v = hepmc_particle_get_decay_vertex (prt)
if (hepmc_vertex_is_valid (v)) then
allocate (child_barcode (hepmc_vertex_get_n_out (v)))
call hepmc_vertex_particle_out_iterator_init (it, v)
if (size (child_barcode) /= 0) then
do i = 1, size (child_barcode)
child_barcode(i) = hepmc_particle_get_barcode &
(hepmc_vertex_particle_out_iterator_get (it))
call hepmc_vertex_particle_out_iterator_advance (it)
end do
call hepmc_vertex_particle_out_iterator_final (it)
end if
else
allocate (child_barcode (0))
end if
end function hepmc_particle_get_child_barcodes
@ %def hepmc_particle_get_parent_barcodes hepmc_particle_get_child_barcodes
@ Return the polarization (assuming that the particle is completely
polarized). Note that the generated polarization object needs finalization.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function gen_particle_polarization (prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function gen_particle_polarization
end interface
@ %def gen_particle_polarization
<<HepMC interface: public>>=
public :: hepmc_particle_get_polarization
<<HepMC interface: procedures>>=
function hepmc_particle_get_polarization (prt) result (pol)
type(hepmc_polarization_t) :: pol
type(hepmc_particle_t), intent(in) :: prt
pol%obj = gen_particle_polarization (prt%obj)
end function hepmc_particle_get_polarization
@ %def hepmc_particle_get_polarization
@ Return the particle color as a two-dimensional array (color, anticolor).
<<HepMC interface: interfaces>>=
interface
function gen_particle_flow (prt_obj, code_index) result (code) bind(C)
import
integer(c_int) :: code
type(c_ptr), value :: prt_obj
integer(c_int), value :: code_index
end function gen_particle_flow
end interface
@ %def gen_particle_flow
<<HepMC interface: public>>=
public :: hepmc_particle_get_color
<<HepMC interface: procedures>>=
function hepmc_particle_get_color (prt) result (col)
integer, dimension(2) :: col
type(hepmc_particle_t), intent(in) :: prt
col(1) = gen_particle_flow (prt%obj, 1)
col(2) = - gen_particle_flow (prt%obj, 2)
end function hepmc_particle_get_color
@ %def hepmc_particle_get_color
@
<<HepMC interface: interfaces>>=
interface
function gen_vertex_pos_x (v_obj) result (x) bind(C)
import
type(c_ptr), value :: v_obj
real(c_double) :: x
end function gen_vertex_pos_x
end interface
interface
function gen_vertex_pos_y (v_obj) result (y) bind(C)
import
type(c_ptr), value :: v_obj
real(c_double) :: y
end function gen_vertex_pos_y
end interface
interface
function gen_vertex_pos_z (v_obj) result (z) bind(C)
import
type(c_ptr), value :: v_obj
real(c_double) :: z
end function gen_vertex_pos_z
end interface
interface
function gen_vertex_time (v_obj) result (t) bind(C)
import
type(c_ptr), value :: v_obj
real(c_double) :: t
end function gen_vertex_time
end interface
@
<<HepMC interface: public>>=
public :: hepmc_vertex_to_vertex
<<HepMC interface: procedures>>=
function hepmc_vertex_to_vertex (vtx) result (v)
type(hepmc_vertex_t), intent(in) :: vtx
type(vector4_t) :: v
real(default) :: t, vx, vy, vz
if (hepmc_vertex_is_valid (vtx)) then
t = gen_vertex_time (vtx%obj)
vx = gen_vertex_pos_x (vtx%obj)
vy = gen_vertex_pos_y (vtx%obj)
vz = gen_vertex_pos_z (vtx%obj)
v = vector4_moving (t, &
vector3_moving ([vx, vy, vz]))
end if
end function hepmc_vertex_to_vertex
@ %def hepmc_vertex_to_vertex
@
\subsection{GenVertex}
Vertices are made of particles (incoming and outgoing).
<<HepMC interface: public>>=
public :: hepmc_vertex_t
<<HepMC interface: types>>=
type :: hepmc_vertex_t
private
type(c_ptr) :: obj
end type hepmc_vertex_t
@ %def hepmc_vertex_t
@ Constructor. Two versions, one plain, one with the position in
space and time (measured in mm) as argument. The Fortran version has
initializer form, and the vertex position is an optional argument.
A destructor is unnecessary as long as all vertices are entered into
an event container.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function new_gen_vertex () bind(C)
import
end function new_gen_vertex
end interface
interface
type(c_ptr) function new_gen_vertex_pos (prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function new_gen_vertex_pos
end interface
@ %def new_gen_vertex new_gen_vertex_pos
<<HepMC interface: public>>=
public :: hepmc_vertex_init
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_init (v, x)
type(hepmc_vertex_t), intent(out) :: v
type(vector4_t), intent(in), optional :: x
type(hepmc_four_vector_t) :: pos
if (present (x)) then
call hepmc_four_vector_init (pos, x)
v%obj = new_gen_vertex_pos (pos%obj)
call hepmc_four_vector_final (pos)
else
v%obj = new_gen_vertex ()
end if
end subroutine hepmc_vertex_init
@ %def hepmc_vertex_init
@ Return true if the vertex pointer is non-null:
<<HepMC interface: interfaces>>=
interface
function gen_vertex_is_valid (v_obj) result (flag) bind(C)
import
logical(c_bool) :: flag
type(c_ptr), value :: v_obj
end function gen_vertex_is_valid
end interface
@ %def gen_vertex_is_valid
<<HepMC interface: public>>=
public :: hepmc_vertex_is_valid
<<HepMC interface: procedures>>=
function hepmc_vertex_is_valid (v) result (flag)
logical :: flag
type(hepmc_vertex_t), intent(in) :: v
flag = gen_vertex_is_valid (v%obj)
end function hepmc_vertex_is_valid
@ %def hepmc_vertex_is_valid
@ Add a particle to a vertex, incoming or outgoing.
<<HepMC interface: interfaces>>=
interface
subroutine gen_vertex_add_particle_in (v_obj, prt_obj) bind(C)
import
type(c_ptr), value :: v_obj, prt_obj
end subroutine gen_vertex_add_particle_in
end interface
interface
subroutine gen_vertex_add_particle_out (v_obj, prt_obj) bind(C)
import
type(c_ptr), value :: v_obj, prt_obj
end subroutine gen_vertex_add_particle_out
end interface
<<HepMC interface: public>>=
public :: hepmc_vertex_add_particle_in
public :: hepmc_vertex_add_particle_out
@ %def gen_vertex_add_particle_in gen_vertex_add_particle_out
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_add_particle_in (v, prt)
type(hepmc_vertex_t), intent(inout) :: v
type(hepmc_particle_t), intent(in) :: prt
call gen_vertex_add_particle_in (v%obj, prt%obj)
end subroutine hepmc_vertex_add_particle_in
subroutine hepmc_vertex_add_particle_out (v, prt)
type(hepmc_vertex_t), intent(inout) :: v
type(hepmc_particle_t), intent(in) :: prt
call gen_vertex_add_particle_out (v%obj, prt%obj)
end subroutine hepmc_vertex_add_particle_out
@ %def hepmc_vertex_add_particle_in hepmc_vertex_add_particle_out
@ Return the number of incoming/outgoing particles.
<<HepMC interface: interfaces>>=
interface
function gen_vertex_particles_in_size (v_obj) result (size) bind(C)
import
integer(c_int) :: size
type(c_ptr), value :: v_obj
end function gen_vertex_particles_in_size
end interface
interface
function gen_vertex_particles_out_size (v_obj) result (size) bind(C)
import
integer(c_int) :: size
type(c_ptr), value :: v_obj
end function gen_vertex_particles_out_size
end interface
@ %def gen_vertex_particles_in_size gen_vertex_particles_out_size
<<HepMC interface: public>>=
public :: hepmc_vertex_get_n_in
public :: hepmc_vertex_get_n_out
<<HepMC interface: procedures>>=
function hepmc_vertex_get_n_in (v) result (n_in)
integer :: n_in
type(hepmc_vertex_t), intent(in) :: v
n_in = gen_vertex_particles_in_size (v%obj)
end function hepmc_vertex_get_n_in
function hepmc_vertex_get_n_out (v) result (n_out)
integer :: n_out
type(hepmc_vertex_t), intent(in) :: v
n_out = gen_vertex_particles_out_size (v%obj)
end function hepmc_vertex_get_n_out
@ %def hepmc_vertex_n_in hepmc_vertex_n_out
@
\subsection{Vertex-particle-in iterator}
This iterator iterates over all incoming particles in an vertex. We store a
pointer to the vertex in addition to the iterator. This allows for
simple end checking.
The iterator is actually a constant iterator; it can only read.
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_in_iterator_t
<<HepMC interface: types>>=
type :: hepmc_vertex_particle_in_iterator_t
private
type(c_ptr) :: obj
type(c_ptr) :: v_obj
end type hepmc_vertex_particle_in_iterator_t
@ %def hepmc_vertex_particle_in_iterator_t
@ Constructor. The iterator is initialized at the first particle in
the vertex.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function &
new_vertex_particles_in_const_iterator (v_obj) bind(C)
import
type(c_ptr), value :: v_obj
end function new_vertex_particles_in_const_iterator
end interface
@ %def new_vertex_particles_in_const_iterator
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_in_iterator_init
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_particle_in_iterator_init (it, v)
type(hepmc_vertex_particle_in_iterator_t), intent(out) :: it
type(hepmc_vertex_t), intent(in) :: v
it%obj = new_vertex_particles_in_const_iterator (v%obj)
it%v_obj = v%obj
end subroutine hepmc_vertex_particle_in_iterator_init
@ %def hepmc_vertex_particle_in_iterator_init
@ Destructor. Necessary because the iterator is allocated on the
heap.
<<HepMC interface: interfaces>>=
interface
subroutine vertex_particles_in_const_iterator_delete (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end subroutine vertex_particles_in_const_iterator_delete
end interface
@ %def vertex_particles_in_const_iterator_delete
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_in_iterator_final
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_particle_in_iterator_final (it)
type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it
call vertex_particles_in_const_iterator_delete (it%obj)
end subroutine hepmc_vertex_particle_in_iterator_final
@ %def hepmc_vertex_particle_in_iterator_final
@ Increment
<<HepMC interface: interfaces>>=
interface
subroutine vertex_particles_in_const_iterator_advance (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end subroutine vertex_particles_in_const_iterator_advance
end interface
@ %def vertex_particles_in_const_iterator_advance
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_in_iterator_advance
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_particle_in_iterator_advance (it)
type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it
call vertex_particles_in_const_iterator_advance (it%obj)
end subroutine hepmc_vertex_particle_in_iterator_advance
@ %def hepmc_vertex_particle_in_iterator_advance
@ Reset to the beginning
<<HepMC interface: interfaces>>=
interface
subroutine vertex_particles_in_const_iterator_reset &
(it_obj, v_obj) bind(C)
import
type(c_ptr), value :: it_obj, v_obj
end subroutine vertex_particles_in_const_iterator_reset
end interface
@ %def vertex_particles_in_const_iterator_reset
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_in_iterator_reset
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_particle_in_iterator_reset (it)
type(hepmc_vertex_particle_in_iterator_t), intent(inout) :: it
call vertex_particles_in_const_iterator_reset (it%obj, it%v_obj)
end subroutine hepmc_vertex_particle_in_iterator_reset
@ %def hepmc_vertex_particle_in_iterator_reset
@ Test: return true as long as we are not past the end.
<<HepMC interface: interfaces>>=
interface
function vertex_particles_in_const_iterator_is_valid &
(it_obj, v_obj) result (flag) bind(C)
import
logical(c_bool) :: flag
type(c_ptr), value :: it_obj, v_obj
end function vertex_particles_in_const_iterator_is_valid
end interface
@ %def vertex_particles_in_const_iterator_is_valid
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_in_iterator_is_valid
<<HepMC interface: procedures>>=
function hepmc_vertex_particle_in_iterator_is_valid (it) result (flag)
logical :: flag
type(hepmc_vertex_particle_in_iterator_t), intent(in) :: it
flag = vertex_particles_in_const_iterator_is_valid (it%obj, it%v_obj)
end function hepmc_vertex_particle_in_iterator_is_valid
@ %def hepmc_vertex_particle_in_iterator_is_valid
@ Return the particle pointed to by the iterator. (The particle
object should not be finalized, since it contains merely a pointer to
the particle which is owned by the vertex.)
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function &
vertex_particles_in_const_iterator_get (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end function vertex_particles_in_const_iterator_get
end interface
@ %def vertex_particles_in_const_iterator_get
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_in_iterator_get
<<HepMC interface: procedures>>=
function hepmc_vertex_particle_in_iterator_get (it) result (prt)
type(hepmc_particle_t) :: prt
type(hepmc_vertex_particle_in_iterator_t), intent(in) :: it
prt%obj = vertex_particles_in_const_iterator_get (it%obj)
end function hepmc_vertex_particle_in_iterator_get
@ %def hepmc_vertex_particle_in_iterator_get
@
\subsection{Vertex-particle-out iterator}
This iterator iterates over all incoming particles in an vertex. We store a
pointer to the vertex in addition to the iterator. This allows for
simple end checking.
The iterator is actually a constant iterator; it can only read.
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_out_iterator_t
<<HepMC interface: types>>=
type :: hepmc_vertex_particle_out_iterator_t
private
type(c_ptr) :: obj
type(c_ptr) :: v_obj
end type hepmc_vertex_particle_out_iterator_t
@ %def hepmc_vertex_particle_out_iterator_t
@ Constructor. The iterator is initialized at the first particle in
the vertex.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function &
new_vertex_particles_out_const_iterator (v_obj) bind(C)
import
type(c_ptr), value :: v_obj
end function new_vertex_particles_out_const_iterator
end interface
@ %def new_vertex_particles_out_const_iterator
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_out_iterator_init
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_particle_out_iterator_init (it, v)
type(hepmc_vertex_particle_out_iterator_t), intent(out) :: it
type(hepmc_vertex_t), intent(in) :: v
it%obj = new_vertex_particles_out_const_iterator (v%obj)
it%v_obj = v%obj
end subroutine hepmc_vertex_particle_out_iterator_init
@ %def hepmc_vertex_particle_out_iterator_init
@ Destructor. Necessary because the iterator is allocated on the
heap.
<<HepMC interface: interfaces>>=
interface
subroutine vertex_particles_out_const_iterator_delete (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end subroutine vertex_particles_out_const_iterator_delete
end interface
@ %def vertex_particles_out_const_iterator_delete
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_out_iterator_final
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_particle_out_iterator_final (it)
type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it
call vertex_particles_out_const_iterator_delete (it%obj)
end subroutine hepmc_vertex_particle_out_iterator_final
@ %def hepmc_vertex_particle_out_iterator_final
@ Increment
<<HepMC interface: interfaces>>=
interface
subroutine vertex_particles_out_const_iterator_advance (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end subroutine vertex_particles_out_const_iterator_advance
end interface
@ %def vertex_particles_out_const_iterator_advance
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_out_iterator_advance
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_particle_out_iterator_advance (it)
type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it
call vertex_particles_out_const_iterator_advance (it%obj)
end subroutine hepmc_vertex_particle_out_iterator_advance
@ %def hepmc_vertex_particle_out_iterator_advance
@ Reset to the beginning
<<HepMC interface: interfaces>>=
interface
subroutine vertex_particles_out_const_iterator_reset &
(it_obj, v_obj) bind(C)
import
type(c_ptr), value :: it_obj, v_obj
end subroutine vertex_particles_out_const_iterator_reset
end interface
@ %def vertex_particles_out_const_iterator_reset
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_out_iterator_reset
<<HepMC interface: procedures>>=
subroutine hepmc_vertex_particle_out_iterator_reset (it)
type(hepmc_vertex_particle_out_iterator_t), intent(inout) :: it
call vertex_particles_out_const_iterator_reset (it%obj, it%v_obj)
end subroutine hepmc_vertex_particle_out_iterator_reset
@ %def hepmc_vertex_particle_out_iterator_reset
@ Test: return true as long as we are not past the end.
<<HepMC interface: interfaces>>=
interface
function vertex_particles_out_const_iterator_is_valid &
(it_obj, v_obj) result (flag) bind(C)
import
logical(c_bool) :: flag
type(c_ptr), value :: it_obj, v_obj
end function vertex_particles_out_const_iterator_is_valid
end interface
@ %def vertex_particles_out_const_iterator_is_valid
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_out_iterator_is_valid
<<HepMC interface: procedures>>=
function hepmc_vertex_particle_out_iterator_is_valid (it) result (flag)
logical :: flag
type(hepmc_vertex_particle_out_iterator_t), intent(in) :: it
flag = vertex_particles_out_const_iterator_is_valid (it%obj, it%v_obj)
end function hepmc_vertex_particle_out_iterator_is_valid
@ %def hepmc_vertex_particle_out_iterator_is_valid
@ Return the particle pointed to by the iterator. (The particle
object should not be finalized, since it contains merely a pointer to
the particle which is owned by the vertex.)
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function &
vertex_particles_out_const_iterator_get (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end function vertex_particles_out_const_iterator_get
end interface
@ %def vertex_particles_out_const_iterator_get
<<HepMC interface: public>>=
public :: hepmc_vertex_particle_out_iterator_get
<<HepMC interface: procedures>>=
function hepmc_vertex_particle_out_iterator_get (it) result (prt)
type(hepmc_particle_t) :: prt
type(hepmc_vertex_particle_out_iterator_t), intent(in) :: it
prt%obj = vertex_particles_out_const_iterator_get (it%obj)
end function hepmc_vertex_particle_out_iterator_get
@ %def hepmc_vertex_particle_out_iterator_get
@
\subsection{GenEvent}
The main object of HepMC is a GenEvent. The object is filled by
GenVertex objects, which in turn contain GenParticle objects.
<<HepMC interface: public>>=
public :: hepmc_event_t
<<HepMC interface: types>>=
type :: hepmc_event_t
private
type(c_ptr) :: obj
end type hepmc_event_t
@ %def hepmc_event_t
@ Constructor. Arguments are process ID (integer) and event ID
(integer).
The Fortran version has initializer form.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function new_gen_event (proc_id, event_id) bind(C)
import
integer(c_int), value :: proc_id, event_id
end function new_gen_event
end interface
@ %def new_gen_event
<<HepMC interface: public>>=
public :: hepmc_event_init
<<HepMC interface: procedures>>=
subroutine hepmc_event_init (evt, proc_id, event_id)
type(hepmc_event_t), intent(out) :: evt
integer, intent(in), optional :: proc_id, event_id
integer(c_int) :: pid, eid
pid = 0; if (present (proc_id)) pid = proc_id
eid = 0; if (present (event_id)) eid = event_id
evt%obj = new_gen_event (pid, eid)
end subroutine hepmc_event_init
@ %def hepmc_event_init
@ Destructor.
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_delete (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end subroutine gen_event_delete
end interface
@ %def gen_event_delete
<<HepMC interface: public>>=
public :: hepmc_event_final
<<HepMC interface: procedures>>=
subroutine hepmc_event_final (evt)
type(hepmc_event_t), intent(inout) :: evt
call gen_event_delete (evt%obj)
end subroutine hepmc_event_final
@ %def hepmc_event_final
@ Screen output. Printing to file is possible in principle (using a
C++ output channel), by allowing an argument. Printing to an open
Fortran unit is obviously not possible.
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_print (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end subroutine gen_event_print
end interface
@ %def gen_event_print
<<HepMC interface: public>>=
public :: hepmc_event_print
<<HepMC interface: procedures>>=
subroutine hepmc_event_print (evt)
type(hepmc_event_t), intent(in) :: evt
call gen_event_print (evt%obj)
end subroutine hepmc_event_print
@ %def hepmc_event_print
@ Get the event number.
<<HepMC interface: interfaces>>=
interface
integer(c_int) function gen_event_event_number (evt_obj) bind(C)
use iso_c_binding !NODEP!
type(c_ptr), value :: evt_obj
end function gen_event_event_number
end interface
@ %def gen_event_event_number
<<HepMC interface: public>>=
public :: hepmc_event_get_event_index
<<HepMC interface: procedures>>=
function hepmc_event_get_event_index (evt) result (i_proc)
integer :: i_proc
type(hepmc_event_t), intent(in) :: evt
i_proc = gen_event_event_number (evt%obj)
end function hepmc_event_get_event_index
@ %def hepmc_event_get_event_index
@ Set the numeric signal process ID
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_set_signal_process_id (evt_obj, proc_id) bind(C)
import
type(c_ptr), value :: evt_obj
integer(c_int), value :: proc_id
end subroutine gen_event_set_signal_process_id
end interface
@ %def gen_event_set_signal_process_id
<<HepMC interface: public>>=
public :: hepmc_event_set_process_id
<<HepMC interface: procedures>>=
subroutine hepmc_event_set_process_id (evt, proc)
type(hepmc_event_t), intent(in) :: evt
integer, intent(in) :: proc
integer(c_int) :: i_proc
i_proc = proc
call gen_event_set_signal_process_id (evt%obj, i_proc)
end subroutine hepmc_event_set_process_id
@ %def hepmc_event_set_process_id
@ Get the numeric signal process ID
<<HepMC interface: interfaces>>=
interface
integer(c_int) function gen_event_signal_process_id (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end function gen_event_signal_process_id
end interface
@ %def gen_event_signal_process_id
<<HepMC interface: public>>=
public :: hepmc_event_get_process_id
<<HepMC interface: procedures>>=
function hepmc_event_get_process_id (evt) result (i_proc)
integer :: i_proc
type(hepmc_event_t), intent(in) :: evt
i_proc = gen_event_signal_process_id (evt%obj)
end function hepmc_event_get_process_id
@ %def hepmc_event_get_process_id
@ Set the event energy scale
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_set_event_scale (evt_obj, scale) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: scale
end subroutine gen_event_set_event_scale
end interface
@ %def gen_event_set_event_scale
<<HepMC interface: public>>=
public :: hepmc_event_set_scale
<<HepMC interface: procedures>>=
subroutine hepmc_event_set_scale (evt, scale)
type(hepmc_event_t), intent(in) :: evt
real(default), intent(in) :: scale
real(c_double) :: cscale
cscale = scale
call gen_event_set_event_scale (evt%obj, cscale)
end subroutine hepmc_event_set_scale
@ %def hepmc_event_set_scale
@ Get the event energy scale
<<HepMC interface: interfaces>>=
interface
real(c_double) function gen_event_event_scale (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end function gen_event_event_scale
end interface
@ %def gen_event_event_scale
<<HepMC interface: public>>=
public :: hepmc_event_get_scale
<<HepMC interface: procedures>>=
function hepmc_event_get_scale (evt) result (scale)
real(default) :: scale
type(hepmc_event_t), intent(in) :: evt
scale = gen_event_event_scale (evt%obj)
end function hepmc_event_get_scale
@ %def hepmc_event_set_scale
@ Set the value of $\alpha_{\rm QCD}$.
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_set_alpha_qcd (evt_obj, a) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: a
end subroutine gen_event_set_alpha_qcd
end interface
@ %def gen_event_set_alpha_qcd
<<HepMC interface: public>>=
public :: hepmc_event_set_alpha_qcd
<<HepMC interface: procedures>>=
subroutine hepmc_event_set_alpha_qcd (evt, alpha)
type(hepmc_event_t), intent(in) :: evt
real(default), intent(in) :: alpha
real(c_double) :: a
a = alpha
call gen_event_set_alpha_qcd (evt%obj, a)
end subroutine hepmc_event_set_alpha_qcd
@ %def hepmc_event_set_alpha_qcd
@ Get the value of $\alpha_{\rm QCD}$.
<<HepMC interface: interfaces>>=
interface
real(c_double) function gen_event_alpha_qcd (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end function gen_event_alpha_qcd
end interface
@ %def gen_event_get_alpha_qcd
<<HepMC interface: public>>=
public :: hepmc_event_get_alpha_qcd
<<HepMC interface: procedures>>=
function hepmc_event_get_alpha_qcd (evt) result (alpha)
real(default) :: alpha
type(hepmc_event_t), intent(in) :: evt
alpha = gen_event_alpha_qcd (evt%obj)
end function hepmc_event_get_alpha_qcd
@ %def hepmc_event_get_alpha_qcd
@ Set the value of $\alpha_{\rm QED}$.
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_set_alpha_qed (evt_obj, a) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: a
end subroutine gen_event_set_alpha_qed
end interface
@ %def gen_event_set_alpha_qed
<<HepMC interface: public>>=
public :: hepmc_event_set_alpha_qed
<<HepMC interface: procedures>>=
subroutine hepmc_event_set_alpha_qed (evt, alpha)
type(hepmc_event_t), intent(in) :: evt
real(default), intent(in) :: alpha
real(c_double) :: a
a = alpha
call gen_event_set_alpha_qed (evt%obj, a)
end subroutine hepmc_event_set_alpha_qed
@ %def hepmc_event_set_alpha_qed
@ Get the value of $\alpha_{\rm QED}$.
<<HepMC interface: interfaces>>=
interface
real(c_double) function gen_event_alpha_qed (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end function gen_event_alpha_qed
end interface
@ %def gen_event_get_alpha_qed
<<HepMC interface: public>>=
public :: hepmc_event_get_alpha_qed
<<HepMC interface: procedures>>=
function hepmc_event_get_alpha_qed (evt) result (alpha)
real(default) :: alpha
type(hepmc_event_t), intent(in) :: evt
alpha = gen_event_alpha_qed (evt%obj)
end function hepmc_event_get_alpha_qed
@ %def hepmc_event_get_alpha_qed
@ Clear a weight value to the end of the weight container.
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_clear_weights (evt_obj) bind(C)
use iso_c_binding !NODEP!
type(c_ptr), value :: evt_obj
end subroutine gen_event_clear_weights
end interface
@ %def gen_event_set_alpha_qed
@ The HepMC weights are measured in pb.
<<HepMC interface: parameters>>=
real(default), parameter :: pb_per_fb = 1.e-3_default
@ %def pb_per_fb
@
<<HepMC interface: public>>=
public :: hepmc_event_clear_weights
<<HepMC interface: procedures>>=
subroutine hepmc_event_clear_weights (evt)
type(hepmc_event_t), intent(in) :: evt
call gen_event_clear_weights (evt%obj)
end subroutine hepmc_event_clear_weights
@ %def hepmc_event_clear_weights
@ Add a weight value to the end of the weight container.
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_add_weight (evt_obj, w) bind(C)
use iso_c_binding !NODEP!
type(c_ptr), value :: evt_obj
real(c_double), value :: w
end subroutine gen_event_add_weight
end interface
@ %def gen_event_add_weight
@
<<HepMC interface: public>>=
public :: hepmc_event_add_weight
<<HepMC interface: procedures>>=
subroutine hepmc_event_add_weight (evt, weight)
type(hepmc_event_t), intent(in) :: evt
real(default), intent(in) :: weight
real(c_double) :: w
w = weight * pb_per_fb
call gen_event_add_weight (evt%obj, w)
end subroutine hepmc_event_add_weight
@ %def hepmc_event_add_weight
@ Get the size of the weight container (the number of valid elements).
<<HepMC interface: interfaces>>=
interface
integer(c_int) function gen_event_weights_size (evt_obj) bind(C)
use iso_c_binding !NODEP!
type(c_ptr), value :: evt_obj
end function gen_event_weights_size
end interface
@ %def gen_event_get_weight
<<HepMC interface: public>>=
public :: hepmc_event_get_weights_size
<<HepMC interface: procedures>>=
function hepmc_event_get_weights_size (evt) result (n)
integer :: n
type(hepmc_event_t), intent(in) :: evt
n = gen_event_weights_size (evt%obj)
end function hepmc_event_get_weights_size
@ %def hepmc_event_get_weights_size
@ Get the value of the weight with index [[i]]. (Count from 1, while C counts
from zero.)
<<HepMC interface: interfaces>>=
interface
real(c_double) function gen_event_weight (evt_obj, i) bind(C)
use iso_c_binding !NODEP!
type(c_ptr), value :: evt_obj
integer(c_int), value :: i
end function gen_event_weight
end interface
@ %def gen_event_get_weight
<<HepMC interface: public>>=
public :: hepmc_event_get_weight
<<HepMC interface: procedures>>=
function hepmc_event_get_weight (evt, index) result (weight)
real(default) :: weight
type(hepmc_event_t), intent(in) :: evt
integer, intent(in) :: index
integer(c_int) :: i
i = index - 1
weight = gen_event_weight (evt%obj, i) / pb_per_fb
end function hepmc_event_get_weight
@ %def hepmc_event_get_weight
@ Add a vertex to the event container.
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_add_vertex (evt_obj, v_obj) bind(C)
import
type(c_ptr), value :: evt_obj
type(c_ptr), value :: v_obj
end subroutine gen_event_add_vertex
end interface
@ %def gen_event_add_vertex
<<HepMC interface: public>>=
public :: hepmc_event_add_vertex
<<HepMC interface: procedures>>=
subroutine hepmc_event_add_vertex (evt, v)
type(hepmc_event_t), intent(inout) :: evt
type(hepmc_vertex_t), intent(in) :: v
call gen_event_add_vertex (evt%obj, v%obj)
end subroutine hepmc_event_add_vertex
@ %def hepmc_event_add_vertex
@ Mark a particular vertex as the signal process (hard interaction).
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_set_signal_process_vertex (evt_obj, v_obj) bind(C)
import
type(c_ptr), value :: evt_obj
type(c_ptr), value :: v_obj
end subroutine gen_event_set_signal_process_vertex
end interface
@ %def gen_event_set_signal_process_vertex
<<HepMC interface: public>>=
public :: hepmc_event_set_signal_process_vertex
<<HepMC interface: procedures>>=
subroutine hepmc_event_set_signal_process_vertex (evt, v)
type(hepmc_event_t), intent(inout) :: evt
type(hepmc_vertex_t), intent(in) :: v
call gen_event_set_signal_process_vertex (evt%obj, v%obj)
end subroutine hepmc_event_set_signal_process_vertex
@ %def hepmc_event_set_signal_process_vertex
@ Return the the signal process (hard interaction).
<<HepMC interface: interfaces>>=
interface
function gen_event_get_signal_process_vertex (evt_obj) &
result (v_obj) bind(C)
import
type(c_ptr), value :: evt_obj
type(c_ptr) :: v_obj
end function gen_event_get_signal_process_vertex
end interface
@ %def gen_event_get_signal_process_vertex
<<HepMC interface: public>>=
public :: hepmc_event_get_signal_process_vertex
<<HepMC interface: procedures>>=
function hepmc_event_get_signal_process_vertex (evt) result (v)
type(hepmc_event_t), intent(in) :: evt
type(hepmc_vertex_t) :: v
v%obj = gen_event_get_signal_process_vertex (evt%obj)
end function hepmc_event_get_signal_process_vertex
@ %def hepmc_event_get_signal_process_vertex
@ Set the beam particles explicitly.
<<HepMC interface: public>>=
public :: hepmc_event_set_beam_particles
<<HepMC interface: procedures>>=
subroutine hepmc_event_set_beam_particles (evt, prt1, prt2)
type(hepmc_event_t), intent(inout) :: evt
type(hepmc_particle_t), intent(in) :: prt1, prt2
logical(c_bool) :: flag
flag = gen_event_set_beam_particles (evt%obj, prt1%obj, prt2%obj)
end subroutine hepmc_event_set_beam_particles
@ %def hepmc_event_set_beam_particles
@ The C function returns a boolean which we do not use.
<<HepMC interface: interfaces>>=
interface
logical(c_bool) function gen_event_set_beam_particles &
(evt_obj, prt1_obj, prt2_obj) bind(C)
import
type(c_ptr), value :: evt_obj, prt1_obj, prt2_obj
end function gen_event_set_beam_particles
end interface
@ %def gen_event_set_beam_particles
@ Set the cross section and error explicitly. Note that HepMC uses
pb, while WHIZARD uses fb.
<<HepMC interface: public>>=
public :: hepmc_event_set_cross_section
<<HepMC interface: procedures>>=
subroutine hepmc_event_set_cross_section (evt, xsec, xsec_err)
type(hepmc_event_t), intent(inout) :: evt
real(default), intent(in) :: xsec, xsec_err
call gen_event_set_cross_section &
(evt%obj, &
real (xsec * 1e-3_default, c_double), &
real (xsec_err * 1e-3_default, c_double))
end subroutine hepmc_event_set_cross_section
@ %def hepmc_event_set_cross_section
@ The C function returns a boolean which we do not use.
<<HepMC interface: interfaces>>=
interface
subroutine gen_event_set_cross_section (evt_obj, xs, xs_err) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: xs, xs_err
end subroutine gen_event_set_cross_section
end interface
@ %def gen_event_set_cross_section
@
\subsection{Event-particle iterator}
This iterator iterates over all particles in an event. We store a
pointer to the event in addition to the iterator. This allows for
simple end checking.
The iterator is actually a constant iterator; it can only read.
<<HepMC interface: public>>=
public :: hepmc_event_particle_iterator_t
<<HepMC interface: types>>=
type :: hepmc_event_particle_iterator_t
private
type(c_ptr) :: obj
type(c_ptr) :: evt_obj
end type hepmc_event_particle_iterator_t
@ %def hepmc_event_particle_iterator_t
@ Constructor. The iterator is initialized at the first particle in
the event.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function new_event_particle_const_iterator (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end function new_event_particle_const_iterator
end interface
@ %def new_event_particle_const_iterator
<<HepMC interface: public>>=
public :: hepmc_event_particle_iterator_init
<<HepMC interface: procedures>>=
subroutine hepmc_event_particle_iterator_init (it, evt)
type(hepmc_event_particle_iterator_t), intent(out) :: it
type(hepmc_event_t), intent(in) :: evt
it%obj = new_event_particle_const_iterator (evt%obj)
it%evt_obj = evt%obj
end subroutine hepmc_event_particle_iterator_init
@ %def hepmc_event_particle_iterator_init
@ Destructor. Necessary because the iterator is allocated on the
heap.
<<HepMC interface: interfaces>>=
interface
subroutine event_particle_const_iterator_delete (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end subroutine event_particle_const_iterator_delete
end interface
@ %def event_particle_const_iterator_delete
<<HepMC interface: public>>=
public :: hepmc_event_particle_iterator_final
<<HepMC interface: procedures>>=
subroutine hepmc_event_particle_iterator_final (it)
type(hepmc_event_particle_iterator_t), intent(inout) :: it
call event_particle_const_iterator_delete (it%obj)
end subroutine hepmc_event_particle_iterator_final
@ %def hepmc_event_particle_iterator_final
@ Increment
<<HepMC interface: interfaces>>=
interface
subroutine event_particle_const_iterator_advance (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end subroutine event_particle_const_iterator_advance
end interface
@ %def event_particle_const_iterator_advance
<<HepMC interface: public>>=
public :: hepmc_event_particle_iterator_advance
<<HepMC interface: procedures>>=
subroutine hepmc_event_particle_iterator_advance (it)
type(hepmc_event_particle_iterator_t), intent(inout) :: it
call event_particle_const_iterator_advance (it%obj)
end subroutine hepmc_event_particle_iterator_advance
@ %def hepmc_event_particle_iterator_advance
@ Reset to the beginning
<<HepMC interface: interfaces>>=
interface
subroutine event_particle_const_iterator_reset (it_obj, evt_obj) bind(C)
import
type(c_ptr), value :: it_obj, evt_obj
end subroutine event_particle_const_iterator_reset
end interface
@ %def event_particle_const_iterator_reset
<<HepMC interface: public>>=
public :: hepmc_event_particle_iterator_reset
<<HepMC interface: procedures>>=
subroutine hepmc_event_particle_iterator_reset (it)
type(hepmc_event_particle_iterator_t), intent(inout) :: it
call event_particle_const_iterator_reset (it%obj, it%evt_obj)
end subroutine hepmc_event_particle_iterator_reset
@ %def hepmc_event_particle_iterator_reset
@ Test: return true as long as we are not past the end.
<<HepMC interface: interfaces>>=
interface
function event_particle_const_iterator_is_valid &
(it_obj, evt_obj) result (flag) bind(C)
import
logical(c_bool) :: flag
type(c_ptr), value :: it_obj, evt_obj
end function event_particle_const_iterator_is_valid
end interface
@ %def event_particle_const_iterator_is_valid
<<HepMC interface: public>>=
public :: hepmc_event_particle_iterator_is_valid
<<HepMC interface: procedures>>=
function hepmc_event_particle_iterator_is_valid (it) result (flag)
logical :: flag
type(hepmc_event_particle_iterator_t), intent(in) :: it
flag = event_particle_const_iterator_is_valid (it%obj, it%evt_obj)
end function hepmc_event_particle_iterator_is_valid
@ %def hepmc_event_particle_iterator_is_valid
@ Return the particle pointed to by the iterator. (The particle
object should not be finalized, since it contains merely a pointer to
the particle which is owned by the vertex.)
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function event_particle_const_iterator_get (it_obj) bind(C)
import
type(c_ptr), value :: it_obj
end function event_particle_const_iterator_get
end interface
@ %def event_particle_const_iterator_get
<<HepMC interface: public>>=
public :: hepmc_event_particle_iterator_get
<<HepMC interface: procedures>>=
function hepmc_event_particle_iterator_get (it) result (prt)
type(hepmc_particle_t) :: prt
type(hepmc_event_particle_iterator_t), intent(in) :: it
prt%obj = event_particle_const_iterator_get (it%obj)
end function hepmc_event_particle_iterator_get
@ %def hepmc_event_particle_iterator_get
@
\subsection{I/O streams}
There is a specific I/O stream type for handling the output of
GenEvent objects (i.e., Monte Carlo event samples) to file. Opening
the file is done by the constructor, closing by the destructor.
<<HepMC interface: public>>=
public :: hepmc_iostream_t
<<HepMC interface: types>>=
type :: hepmc_iostream_t
private
type(c_ptr) :: obj
end type hepmc_iostream_t
@ %def hepmc_iostream_t
@ Constructor for an output stream associated to a file.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function new_io_gen_event_out (filename) bind(C)
import
character(c_char), dimension(*), intent(in) :: filename
end function new_io_gen_event_out
end interface
@ %def new_io_gen_event
<<HepMC interface: public>>=
public :: hepmc_iostream_open_out
<<HepMC interface: procedures>>=
subroutine hepmc_iostream_open_out (iostream, filename)
type(hepmc_iostream_t), intent(out) :: iostream
type(string_t), intent(in) :: filename
iostream%obj = new_io_gen_event_out (char (filename) // c_null_char)
end subroutine hepmc_iostream_open_out
@ %def hepmc_iostream_open_out
@ Constructor for an input stream associated to a file.
<<HepMC interface: interfaces>>=
interface
type(c_ptr) function new_io_gen_event_in (filename) bind(C)
import
character(c_char), dimension(*), intent(in) :: filename
end function new_io_gen_event_in
end interface
@ %def new_io_gen_event
<<HepMC interface: public>>=
public :: hepmc_iostream_open_in
<<HepMC interface: procedures>>=
subroutine hepmc_iostream_open_in (iostream, filename)
type(hepmc_iostream_t), intent(out) :: iostream
type(string_t), intent(in) :: filename
iostream%obj = new_io_gen_event_in (char (filename) // c_null_char)
end subroutine hepmc_iostream_open_in
@ %def hepmc_iostream_open_in
@ Destructor:
<<HepMC interface: interfaces>>=
interface
subroutine io_gen_event_delete (io_obj) bind(C)
import
type(c_ptr), value :: io_obj
end subroutine io_gen_event_delete
end interface
@ %def io_gen_event_delete
<<HepMC interface: public>>=
public :: hepmc_iostream_close
<<HepMC interface: procedures>>=
subroutine hepmc_iostream_close (iostream)
type(hepmc_iostream_t), intent(inout) :: iostream
call io_gen_event_delete (iostream%obj)
end subroutine hepmc_iostream_close
@ %def hepmc_iostream_close
@ Write a single event to the I/O stream.
<<HepMC interface: interfaces>>=
interface
subroutine io_gen_event_write_event (io_obj, evt_obj) bind(C)
import
type(c_ptr), value :: io_obj, evt_obj
end subroutine io_gen_event_write_event
end interface
@ %def io_gen_event_write_event
<<HepMC interface: public>>=
public :: hepmc_iostream_write_event
<<HepMC interface: procedures>>=
subroutine hepmc_iostream_write_event (iostream, evt)
type(hepmc_iostream_t), intent(inout) :: iostream
type(hepmc_event_t), intent(in) :: evt
call io_gen_event_write_event (iostream%obj, evt%obj)
end subroutine hepmc_iostream_write_event
@ %def hepmc_iostream_write_event
@ Read a single event from the I/O stream. Return true if successful.
<<HepMC interface: interfaces>>=
interface
logical(c_bool) function io_gen_event_read_event (io_obj, evt_obj) bind(C)
import
type(c_ptr), value :: io_obj, evt_obj
end function io_gen_event_read_event
end interface
@ %def io_gen_event_read_event
<<HepMC interface: public>>=
public :: hepmc_iostream_read_event
<<HepMC interface: procedures>>=
subroutine hepmc_iostream_read_event (iostream, evt, ok)
type(hepmc_iostream_t), intent(inout) :: iostream
type(hepmc_event_t), intent(inout) :: evt
logical, intent(out) :: ok
ok = io_gen_event_read_event (iostream%obj, evt%obj)
end subroutine hepmc_iostream_read_event
@ %def hepmc_iostream_read_event
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[hepmc_interface_ut.f90]]>>=
<<File header>>
module hepmc_interface_ut
use unit_tests
use hepmc_interface_uti
<<Standard module head>>
<<HepMC interface: public test>>
contains
<<HepMC interface: test driver>>
end module hepmc_interface_ut
@ %def hepmc_interface_ut
@
<<[[hepmc_interface_uti.f90]]>>=
<<File header>>
module hepmc_interface_uti
<<Use kinds>>
<<Use strings>>
use io_units
use lorentz
use flavors
use colors
use polarizations
use hepmc_interface
<<Standard module head>>
<<HepMC interface: test declarations>>
contains
<<HepMC interface: tests>>
end module hepmc_interface_uti
@ %def hepmc_interface_ut
@ API: driver for the unit tests below.
<<HepMC interface: public test>>=
public :: hepmc_interface_test
<<HepMC interface: test driver>>=
subroutine hepmc_interface_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<HepMC interface: execute tests>>
end subroutine hepmc_interface_test
@ %def hepmc_test
@
This test example is an abridged version from the build-from-scratch
example in the HepMC distribution. We create two vertices for $p\to
q$ PDF splitting, then a vertex for a $qq\to W^-g$ hard-interaction
process, and finally a vertex for $W^-\to qq$ decay. The setup is for
LHC kinematics.
Extending the original example, we set color flow for the incoming
quarks and polarization for the outgoing photon. For the latter, we
have to define a particle-data object for the photon, so a flavor
object can be correctly initialized.
<<HepMC interface: execute tests>>=
call test (hepmc_interface_1, "hepmc_interface_1", &
"check HepMC interface", &
u, results)
<<HepMC interface: test declarations>>=
public :: hepmc_interface_1
<<HepMC interface: tests>>=
subroutine hepmc_interface_1 (u)
use physics_defs, only: VECTOR
use model_data, only: field_data_t
integer, intent(in) :: u
integer :: u_file, iostat
type(hepmc_event_t) :: evt
type(hepmc_vertex_t) :: v1, v2, v3, v4
type(hepmc_particle_t) :: prt1, prt2, prt3, prt4, prt5, prt6, prt7, prt8
type(hepmc_iostream_t) :: iostream
type(flavor_t) :: flv
type(color_t) :: col
type(polarization_t) :: pol
type(field_data_t), target :: photon_data
character(80) :: buffer
write (u, "(A)") "* Test output: HepMC interface"
write (u, "(A)") "* Purpose: test HepMC interface"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
! Initialize a photon flavor object and some polarization
call photon_data%init (var_str ("PHOTON"), 22)
call photon_data%set (spin_type=VECTOR)
call photon_data%freeze ()
call flv%init (photon_data)
call pol%init_angles &
(flv, 0.6_default, 1._default, 0.5_default)
! Event initialization
call hepmc_event_init (evt, 20, 1)
write (u, "(A)") "* p -> q splitting"
write (u, "(A)")
! $p\to q$ splittings
call hepmc_vertex_init (v1)
call hepmc_event_add_vertex (evt, v1)
call hepmc_vertex_init (v2)
call hepmc_event_add_vertex (evt, v2)
call particle_init (prt1, &
0._default, 0._default, 7000._default, 7000._default, &
2212, 3)
call hepmc_vertex_add_particle_in (v1, prt1)
call particle_init (prt2, &
0._default, 0._default,-7000._default, 7000._default, &
2212, 3)
call hepmc_vertex_add_particle_in (v2, prt2)
call particle_init (prt3, &
.750_default, -1.569_default, 32.191_default, 32.238_default, &
1, 3)
call color_init_from_array (col, [501])
call hepmc_particle_set_color (prt3, col)
call hepmc_vertex_add_particle_out (v1, prt3)
call particle_init (prt4, &
-3.047_default, -19._default, -54.629_default, 57.920_default, &
-2, 3)
call color_init_from_array (col, [-501])
call hepmc_particle_set_color (prt4, col)
call hepmc_vertex_add_particle_out (v2, prt4)
write (u, "(A)") "* Hard interaction"
write (u, "(A)")
! Hard interaction
call hepmc_vertex_init (v3)
call hepmc_event_add_vertex (evt, v3)
call hepmc_vertex_add_particle_in (v3, prt3)
call hepmc_vertex_add_particle_in (v3, prt4)
call particle_init (prt6, &
-3.813_default, 0.113_default, -1.833_default, 4.233_default, &
22, 1)
call hepmc_particle_set_polarization (prt6, pol)
call hepmc_vertex_add_particle_out (v3, prt6)
call particle_init (prt5, &
1.517_default, -20.68_default, -20.605_default, 85.925_default, &
-24, 3)
call hepmc_vertex_add_particle_out (v3, prt5)
call hepmc_event_set_signal_process_vertex (evt, v3)
! $W^-$ decay
call vertex_init_pos (v4, &
0.12_default, -0.3_default, 0.05_default, 0.004_default)
call hepmc_event_add_vertex (evt, v4)
call hepmc_vertex_add_particle_in (v4, prt5)
call particle_init (prt7, &
-2.445_default, 28.816_default, 6.082_default, 29.552_default, &
1, 1)
call hepmc_vertex_add_particle_out (v4, prt7)
call particle_init (prt8, &
3.962_default, -49.498_default, -26.687_default, 56.373_default, &
-2, 1)
call hepmc_vertex_add_particle_out (v4, prt8)
! Event output
call hepmc_event_print (evt)
write (u, "(A)") "Writing to file 'hepmc_test.hepmc'"
write (u, "(A)")
call hepmc_iostream_open_out (iostream , var_str ("hepmc_test.hepmc"))
call hepmc_iostream_write_event (iostream, evt)
call hepmc_iostream_close (iostream)
write (u, "(A)") "Writing completed"
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = "hepmc_test.hepmc", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:14) == "HepMC::Version") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
write (u, "(A)")
! Wrapup
! call pol%final ()
call hepmc_event_final (evt)
write (u, "(A)")
write (u, "(A)") "* Test output end: hepmc_interface_1"
contains
subroutine vertex_init_pos (v, x, y, z, t)
type(hepmc_vertex_t), intent(out) :: v
real(default), intent(in) :: x, y, z, t
type(vector4_t) :: xx
xx = vector4_moving (t, vector3_moving ([x, y, z]))
call hepmc_vertex_init (v, xx)
end subroutine vertex_init_pos
subroutine particle_init (prt, px, py, pz, E, pdg, status)
type(hepmc_particle_t), intent(out) :: prt
real(default), intent(in) :: px, py, pz, E
integer, intent(in) :: pdg, status
type(vector4_t) :: p
p = vector4_moving (E, vector3_moving ([px, py, pz]))
call hepmc_particle_init (prt, p, pdg, status)
end subroutine particle_init
end subroutine hepmc_interface_1
@ %def hepmc_interface_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{LCIO events}
This section provides the interface to the LCIO C++ library for handling
Monte-Carlo events.
Each C++ class of LCIO that we use is mirrored by a Fortran type,
which contains as its only component the C pointer to the C++ object.
Each C++ method of LCIO that we use has a C wrapper function. This
function takes a pointer to the host object as its first argument.
Further arguments are either C pointers, or in the case of simple
types (integer, real), interoperable C/Fortran objects.
The C wrapper functions have explicit interfaces in the Fortran
module. They are called by Fortran wrapper procedures. These are
treated as methods of the corresponding Fortran type.
<<[[lcio_interface.f90]]>>=
<<File header>>
module lcio_interface
use, intrinsic :: iso_c_binding !NODEP!
<<Use kinds>>
<<Use strings>>
use constants, only: PI
use diagnostics
use lorentz
use flavors
use colors
use helicities
use polarizations
<<Standard module head>>
<<LCIO interface: public>>
<<LCIO interface: types>>
<<LCIO interface: interfaces>>
contains
<<LCIO interface: procedures>>
end module lcio_interface
@ %def lcio_interface
@
\subsection{Interface check}
This function can be called in order to verify that we are using the
actual LCIO library, and not the dummy version.
<<LCIO interface: interfaces>>=
interface
logical(c_bool) function lcio_available () bind(C)
import
end function lcio_available
end interface
<<LCIO interface: public>>=
public :: lcio_is_available
<<LCIO interface: procedures>>=
function lcio_is_available () result (flag)
logical :: flag
flag = lcio_available ()
end function lcio_is_available
@ %def lcio_is_available
@
\subsection{LCIO Run Header}
This is a type for the run header of the LCIO file.
<<LCIO interface: public>>=
public :: lcio_run_header_t
<<LCIO interface: types>>=
type :: lcio_run_header_t
private
type(c_ptr) :: obj
end type lcio_run_header_t
@ %def lcio_run_header_t
The Fortran version has initializer form.
<<LCIO interface: interfaces>>=
interface
type(c_ptr) function new_lcio_run_header (proc_id) bind(C)
import
integer(c_int), value :: proc_id
end function new_lcio_run_header
end interface
@ %def new_lcio_run_header
<<LCIO interface: interfaces>>=
interface
subroutine run_header_set_simstring &
(runhdr_obj, simstring) bind(C)
import
type(c_ptr), value :: runhdr_obj
character(c_char), dimension(*), intent(in) :: simstring
end subroutine run_header_set_simstring
end interface
@ %def run_header_set_simstring
<<LCIO interface: public>>=
public :: lcio_run_header_init
<<LCIO interface: procedures>>=
subroutine lcio_run_header_init (runhdr, proc_id, run_id)
type(lcio_run_header_t), intent(out) :: runhdr
integer, intent(in), optional :: proc_id, run_id
integer(c_int) :: rid
rid = 0; if (present (run_id)) rid = run_id
runhdr%obj = new_lcio_run_header (rid)
call run_header_set_simstring (runhdr%obj, &
"WHIZARD version:" // "<<Version>>")
end subroutine lcio_run_header_init
@ %def lcio_run_header_init
@
<<LCIO interface: interfaces>>=
interface
subroutine write_run_header (lcwrt_obj, runhdr_obj) bind(C)
import
type(c_ptr), value :: lcwrt_obj
type(c_ptr), value :: runhdr_obj
end subroutine write_run_header
end interface
@ %def write_run_header
<<LCIO interface: public>>=
public :: lcio_run_header_write
<<LCIO interface: procedures>>=
subroutine lcio_run_header_write (wrt, hdr)
type(lcio_writer_t), intent(inout) :: wrt
type(lcio_run_header_t), intent(inout) :: hdr
call write_run_header (wrt%obj, hdr%obj)
end subroutine lcio_run_header_write
@ %def lcio_run_header_write
@
\subsection{LCIO Event and LC Collection}
The main object of LCIO is a LCEventImpl. The object is filled by
MCParticle objects, which are set as LCCollection.
<<LCIO interface: public>>=
public :: lccollection_t
<<LCIO interface: types>>=
type :: lccollection_t
private
type(c_ptr) :: obj
end type lccollection_t
@ %def lccollection_t
@ Initializer.
<<LCIO interface: interfaces>>=
interface
type(c_ptr) function new_lccollection () bind(C)
import
end function new_lccollection
end interface
@ %def new_lccollection
<<LCIO interface: public>>=
public :: lcio_event_t
<<LCIO interface: types>>=
type :: lcio_event_t
private
type(c_ptr) :: obj
type(lccollection_t) :: lccoll
end type lcio_event_t
@ %def lcio_event_t
@ Constructor. Arguments are process ID (integer) and event ID
(integer).
The Fortran version has initializer form.
<<LCIO interface: interfaces>>=
interface
type(c_ptr) function new_lcio_event (proc_id, event_id, run_id) bind(C)
import
integer(c_int), value :: proc_id, event_id, run_id
end function new_lcio_event
end interface
@ %def new_lcio_event
@
<<LCIO interface: public>>=
public :: lcio_event_init
<<LCIO interface: procedures>>=
subroutine lcio_event_init (evt, proc_id, event_id, run_id)
type(lcio_event_t), intent(out) :: evt
integer, intent(in), optional :: proc_id, event_id, run_id
integer(c_int) :: pid, eid, rid
pid = 0; if (present (proc_id)) pid = proc_id
eid = 0; if (present (event_id)) eid = event_id
rid = 0; if (present (run_id)) rid = run_id
evt%obj = new_lcio_event (pid, eid, rid)
evt%lccoll%obj = new_lccollection ()
end subroutine lcio_event_init
@ %def lcio_event_init
@ Destructor.
<<LCIO interface: interfaces>>=
interface
subroutine lcio_event_delete (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end subroutine lcio_event_delete
end interface
@ %def lcio_event_delete
@ Show event on screen.
<<LCIO interface: interfaces>>=
interface
subroutine dump_lcio_event (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end subroutine dump_lcio_event
end interface
@ %def dump_lcio_event
<<LCIO interface: public>>=
public :: show_lcio_event
<<LCIO interface: procedures>>=
subroutine show_lcio_event (evt)
type(lcio_event_t), intent(in) :: evt
if (c_associated (evt%obj)) then
call dump_lcio_event (evt%obj)
else
call msg_error ("LCIO event is not allocated.")
end if
end subroutine show_lcio_event
@ %def show_lcio_event
@ Put a single event to file.
<<LCIO interface: interfaces>>=
interface
subroutine lcio_event_to_file (evt_obj, filename) bind(C)
import
type(c_ptr), value :: evt_obj
character(c_char), dimension(*), intent(in) :: filename
end subroutine lcio_event_to_file
end interface
@ %def lcio_event_to_file
<<LCIO interface: public>>=
public :: write_lcio_event
<<LCIO interface: procedures>>=
subroutine write_lcio_event (evt, filename)
type(lcio_event_t), intent(in) :: evt
type(string_t), intent(in) :: filename
call lcio_event_to_file (evt%obj, char (filename) // c_null_char)
end subroutine write_lcio_event
@ %def write_lcio_event
@
<<LCIO interface: public>>=
public :: lcio_event_final
<<LCIO interface: procedures>>=
subroutine lcio_event_final (evt)
type(lcio_event_t), intent(inout) :: evt
call lcio_event_delete (evt%obj)
end subroutine lcio_event_final
@ %def lcio_event_final
@
<<LCIO interface: interfaces>>=
interface
subroutine lcio_set_weight (evt_obj, weight) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: weight
end subroutine lcio_set_weight
end interface
interface
subroutine lcio_set_alpha_qcd (evt_obj, alphas) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: alphas
end subroutine lcio_set_alpha_qcd
end interface
interface
subroutine lcio_set_scale (evt_obj, scale) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: scale
end subroutine lcio_set_scale
end interface
interface
subroutine lcio_set_sqrts (evt_obj, sqrts) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: sqrts
end subroutine lcio_set_sqrts
end interface
interface
subroutine lcio_set_xsec (evt_obj, xsec, xsec_err) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: xsec, xsec_err
end subroutine lcio_set_xsec
end interface
interface
subroutine lcio_set_beam (evt_obj, pdg, beam) bind(C)
import
type(c_ptr), value :: evt_obj
integer(c_int), value :: pdg, beam
end subroutine lcio_set_beam
end interface
interface
subroutine lcio_set_pol (evt_obj, pol1, pol2) bind(C)
import
type(c_ptr), value :: evt_obj
real(c_double), value :: pol1, pol2
end subroutine lcio_set_pol
end interface
interface
subroutine lcio_set_beam_file (evt_obj, file) bind(C)
import
type(c_ptr), value :: evt_obj
character(len=1, kind=c_char), dimension(*), intent(in) :: file
end subroutine lcio_set_beam_file
end interface
interface
subroutine lcio_set_process_name (evt_obj, name) bind(C)
import
type(c_ptr), value :: evt_obj
character(len=1, kind=c_char), dimension(*), intent(in) :: name
end subroutine lcio_set_process_name
end interface
@ %def lcio_set_weight lcio_set_alpha_qcd lcio_set_scale lcio_set_sqrts
@ %def lcio_set_xsec lcio_set_beam lcio_set_pol
@ %def lcio_set_beam_file lcio_set_process_name
@
<<LCIO interface: public>>=
public :: lcio_event_set_weight
<<LCIO interface: procedures>>=
subroutine lcio_event_set_weight (evt, weight)
type(lcio_event_t), intent(inout) :: evt
real(default), intent(in) :: weight
call lcio_set_weight (evt%obj, real (weight, c_double))
end subroutine lcio_event_set_weight
@ %def lcio_event_set_weight
@
<<LCIO interface: public>>=
public :: lcio_event_set_alpha_qcd
<<LCIO interface: procedures>>=
subroutine lcio_event_set_alpha_qcd (evt, alphas)
type(lcio_event_t), intent(inout) :: evt
real(default), intent(in) :: alphas
call lcio_set_alpha_qcd (evt%obj, real (alphas, c_double))
end subroutine lcio_event_set_alpha_qcd
@ %def lcio_event_set_alpha_qcd
@
<<LCIO interface: public>>=
public :: lcio_event_set_scale
<<LCIO interface: procedures>>=
subroutine lcio_event_set_scale (evt, scale)
type(lcio_event_t), intent(inout) :: evt
real(default), intent(in) :: scale
call lcio_set_scale (evt%obj, real (scale, c_double))
end subroutine lcio_event_set_scale
@ %def lcio_event_set_scale
@
<<LCIO interface: public>>=
public :: lcio_event_set_sqrts
<<LCIO interface: procedures>>=
subroutine lcio_event_set_sqrts (evt, sqrts)
type(lcio_event_t), intent(inout) :: evt
real(default), intent(in) :: sqrts
call lcio_set_sqrts (evt%obj, real (sqrts, c_double))
end subroutine lcio_event_set_sqrts
@ %def lcio_event_set_sqrts
@
<<LCIO interface: public>>=
public :: lcio_event_set_xsec
<<LCIO interface: procedures>>=
subroutine lcio_event_set_xsec (evt, xsec, xsec_err)
type(lcio_event_t), intent(inout) :: evt
real(default), intent(in) :: xsec, xsec_err
call lcio_set_xsec (evt%obj, &
real (xsec, c_double), real (xsec_err, c_double))
end subroutine lcio_event_set_xsec
@ %def lcio_event_set_xsec
@
<<LCIO interface: public>>=
public :: lcio_event_set_beam
<<LCIO interface: procedures>>=
subroutine lcio_event_set_beam (evt, pdg, beam)
type(lcio_event_t), intent(inout) :: evt
integer, intent(in) :: pdg, beam
call lcio_set_beam (evt%obj, &
int (pdg, c_int), int (beam, c_int))
end subroutine lcio_event_set_beam
@ %def lcio_event_set_beam
@
<<LCIO interface: public>>=
public :: lcio_event_set_polarization
<<LCIO interface: procedures>>=
subroutine lcio_event_set_polarization (evt, pol)
type(lcio_event_t), intent(inout) :: evt
real(default), intent(in), dimension(2) :: pol
call lcio_set_pol (evt%obj, &
real (pol(1), c_double), real (pol(2), c_double))
end subroutine lcio_event_set_polarization
@ %def lcio_event_set_polarization
@
<<LCIO interface: public>>=
public :: lcio_event_set_beam_file
<<LCIO interface: procedures>>=
subroutine lcio_event_set_beam_file (evt, file)
type(lcio_event_t), intent(inout) :: evt
type(string_t), intent(in) :: file
call lcio_set_beam_file (evt%obj, &
char (file) // c_null_char)
end subroutine lcio_event_set_beam_file
@ %def lcio_event_set_beam_file
@
<<LCIO interface: public>>=
public :: lcio_event_set_process_name
<<LCIO interface: procedures>>=
subroutine lcio_event_set_process_name (evt, name)
type(lcio_event_t), intent(inout) :: evt
type(string_t), intent(in) :: name
call lcio_set_process_name (evt%obj, &
char (name) // c_null_char)
end subroutine lcio_event_set_process_name
@ %def lcio_event_set_process_name
@
<<LCIO interface: interfaces>>=
interface
subroutine lcio_event_add_collection &
(evt_obj, lccoll_obj) bind(C)
import
type(c_ptr), value :: evt_obj, lccoll_obj
end subroutine lcio_event_add_collection
end interface
@ %def lcio_event_add_collection
<<LCIO interface: public>>=
public :: lcio_event_add_coll
<<LCIO interface: procedures>>=
subroutine lcio_event_add_coll (evt)
type(lcio_event_t), intent(inout) :: evt
call lcio_event_add_collection (evt%obj, &
evt%lccoll%obj)
end subroutine lcio_event_add_coll
@ %def lcio_event_add_coll
@
\subsection{LCIO Particle}
Particle objects have the obvious meaning.
<<LCIO interface: public>>=
public :: lcio_particle_t
<<LCIO interface: types>>=
type :: lcio_particle_t
private
type(c_ptr) :: obj
end type lcio_particle_t
@ %def lcio_particle_t
@ Constructor.
<<LCIO interface: interfaces>>=
interface
type(c_ptr) function new_lcio_particle &
(px, py, pz, pdg_id, mass, charge, status) bind(C)
import
integer(c_int), value :: pdg_id, status
real(c_double), value :: px, py, pz, mass, charge
end function new_lcio_particle
end interface
@ %def new_lcio_particle
@
<<LCIO interface: interfaces>>=
interface
subroutine add_particle_to_collection &
(prt_obj, lccoll_obj) bind(C)
import
type(c_ptr), value :: prt_obj, lccoll_obj
end subroutine add_particle_to_collection
end interface
@ %def add_particle_to_collection
<<LCIO interface: public>>=
public :: lcio_particle_add_to_evt_coll
<<LCIO interface: procedures>>=
subroutine lcio_particle_add_to_evt_coll &
(lprt, evt)
type(lcio_particle_t), intent(in) :: lprt
type(lcio_event_t), intent(inout) :: evt
call add_particle_to_collection (lprt%obj, evt%lccoll%obj)
end subroutine lcio_particle_add_to_evt_coll
@ %def lcio_particle_to_collection
@
<<LCIO interface: public>>=
public :: lcio_particle_init
<<LCIO interface: procedures>>=
subroutine lcio_particle_init (prt, p, pdg, charge, status)
type(lcio_particle_t), intent(out) :: prt
type(vector4_t), intent(in) :: p
real(default), intent(in) :: charge
real(default) :: mass
real(default) :: px, py, pz
integer, intent(in) :: pdg, status
px = vector4_get_component (p, 1)
py = vector4_get_component (p, 2)
pz = vector4_get_component (p, 3)
mass = p**1
prt%obj = new_lcio_particle (real (px, c_double), real (py, c_double), &
real (pz, c_double), int (pdg, c_int), &
real (mass, c_double), real (charge, c_double), int (status, c_int))
end subroutine lcio_particle_init
@ %def lcio_particle_init
@ Set the particle color flow.
<<LCIO interface: interfaces>>=
interface
subroutine lcio_set_color_flow (prt_obj, col1, col2) bind(C)
import
type(c_ptr), value :: prt_obj
integer(c_int), value :: col1, col2
end subroutine lcio_set_color_flow
end interface
@ %def lcio_set_color_flow
@ Set the particle color. Either from a [[color_t]] object or
directly from a pair of integers.
<<LCIO interface: interfaces>>=
interface lcio_particle_set_color
module procedure lcio_particle_set_color_col
module procedure lcio_particle_set_color_int
end interface lcio_particle_set_color
<<LCIO interface: public>>=
public :: lcio_particle_set_color
<<LCIO interface: procedures>>=
subroutine lcio_particle_set_color_col (prt, col)
type(lcio_particle_t), intent(inout) :: prt
type(color_t), intent(in) :: col
integer(c_int), dimension(2) :: c
c(1) = col%get_col ()
c(2) = col%get_acl ()
if (c(1) /= 0 .or. c(2) /= 0) then
call lcio_set_color_flow (prt%obj, c(1), c(2))
end if
end subroutine lcio_particle_set_color_col
subroutine lcio_particle_set_color_int (prt, col)
type(lcio_particle_t), intent(inout) :: prt
integer, dimension(2), intent(in) :: col
integer(c_int), dimension(2) :: c
c = col
if (c(1) /= 0 .or. c(2) /= 0) then
call lcio_set_color_flow (prt%obj, c(1), c(2))
end if
end subroutine lcio_particle_set_color_int
@ %def lcio_particle_set_color
@ Return the particle color as a two-dimensional array (color, anticolor).
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_particle_flow (prt_obj, col_index) bind(C)
use iso_c_binding !NODEP!
type(c_ptr), value :: prt_obj
integer(c_int), value :: col_index
end function lcio_particle_flow
end interface
@ %def lcio_particle_flow
<<LCIO interface: public>>=
public :: lcio_particle_get_flow
<<LCIO interface: procedures>>=
function lcio_particle_get_flow (prt) result (col)
integer, dimension(2) :: col
type(lcio_particle_t), intent(in) :: prt
col(1) = lcio_particle_flow (prt%obj, 0_c_int)
col(2) = - lcio_particle_flow (prt%obj, 1_c_int)
end function lcio_particle_get_flow
@ %def lcio_particle_get_flow
@ Return the four-momentum of a LCIO particle.
<<LCIO interface: interfaces>>=
interface
real(c_double) function lcio_three_momentum (prt_obj, p_index) bind(C)
use iso_c_binding !NODEP!
type(c_ptr), value :: prt_obj
integer(c_int), value :: p_index
end function lcio_three_momentum
end interface
@ %def lcio_three_momentum
<<LCIO interface: interfaces>>=
interface
real(c_double) function lcio_energy (prt_obj) bind(C)
import
type(c_ptr), intent(in), value :: prt_obj
end function lcio_energy
end interface
@ %def lcio_energy
<<LCIO interface: public>>=
public :: lcio_particle_get_momentum
<<LCIO interface: procedures>>=
function lcio_particle_get_momentum (prt) result (p)
type(vector4_t) :: p
type(lcio_particle_t), intent(in) :: prt
real(default) :: E, px, py, pz
E = lcio_energy (prt%obj)
px = lcio_three_momentum (prt%obj, 0_c_int)
py = lcio_three_momentum (prt%obj, 1_c_int)
pz = lcio_three_momentum (prt%obj, 2_c_int)
p = vector4_moving ( E, vector3_moving ([ px, py, pz ]))
end function lcio_particle_get_momentum
@ %def lcio_particle_get_momentum
@ Return the invariant mass squared of the particle object. LCIO
stores the signed invariant mass (no squaring).
<<LCIO interface: interfaces>>=
interface
function lcio_mass (prt_obj) result (mass) bind(C)
import
real(c_double) :: mass
type(c_ptr), value :: prt_obj
end function lcio_mass
end interface
@ %def lcio_mass
<<LCIO interface: public>>=
public :: lcio_particle_get_mass_squared
<<LCIO interface: procedures>>=
function lcio_particle_get_mass_squared (prt) result (m2)
real(default) :: m2
type(lcio_particle_t), intent(in) :: prt
real(default) :: m
m = lcio_mass (prt%obj)
m2 = sign (m**2, m)
end function lcio_particle_get_mass_squared
@ %def lcio_particle_get_mass_squared
@ Return vertex and production time of a LCIO particle.
<<LCIO interface: interfaces>>=
interface
real(c_double) function lcio_vtx_x (prt) bind(C)
import
type(c_ptr), value :: prt
end function lcio_vtx_x
end interface
interface
real(c_double) function lcio_vtx_y (prt) bind(C)
import
type(c_ptr), value :: prt
end function lcio_vtx_y
end interface
interface
real(c_double) function lcio_vtx_z (prt) bind(C)
import
type(c_ptr), value :: prt
end function lcio_vtx_z
end interface
interface
real(c_double) function lcio_prt_time (prt) bind(C)
import
type(c_ptr), value :: prt
end function lcio_prt_time
end interface
@
@
<<LCIO interface: public>>=
public :: lcio_particle_get_vertex
public :: lcio_particle_get_time
<<LCIO interface: procedures>>=
function lcio_particle_get_vertex (prt) result (vtx)
type(vector3_t) :: vtx
type(lcio_particle_t), intent(in) :: prt
real(default) :: vx, vy, vz
vx = lcio_vtx_x (prt%obj)
vy = lcio_vtx_y (prt%obj)
vz = lcio_vtx_z (prt%obj)
vtx = vector3_moving ([vx, vy, vz])
end function lcio_particle_get_vertex
function lcio_particle_get_time (prt) result (time)
real(default) :: time
type(lcio_particle_t), intent(in) :: prt
time = lcio_prt_time (prt%obj)
end function lcio_particle_get_time
@ %def lcio_particle_get_vertex lcio_particle_get_time
@
\subsection{Polarization}
For polarization there is a three-component float entry foreseen in the LCIO
format. Completely generic density matrices can in principle be attached to
events as float vectors added to [[LCCollection]] of the [[LCEvent]]. This is
not yet implemented currently. Here, we restrict ourselves to the same
implementation as in HepMC format: we use two entries as the polarization
angles, while the first entry gives the degree of polarization (something
not specified in the HepMC format).
\emph{For massive vector bosons, we arbitrarily choose the convention
that the longitudinal (zero) helicity state is mapped to the theta
angle $\pi/2$. This works under the condition that helicity is
projected onto one of the basis states.}
<<LCIO interface: interfaces>>=
interface
subroutine lcio_particle_set_spin (prt_obj, s1, s2, s3) bind(C)
import
type(c_ptr), value :: prt_obj
real(c_double), value :: s1, s2, s3
end subroutine lcio_particle_set_spin
end interface
@ %def lcio_particle_set_spin
@
<<LCIO interface: public>>=
public :: lcio_polarization_init
<<LCIO interface: interfaces>>=
interface lcio_polarization_init
module procedure lcio_polarization_init_pol
module procedure lcio_polarization_init_hel
module procedure lcio_polarization_init_int
end interface
<<LCIO interface: procedures>>=
subroutine lcio_polarization_init_pol (prt, pol)
type(lcio_particle_t), intent(inout) :: prt
type(polarization_t), intent(in) :: pol
real(default) :: r, theta, phi
if (pol%is_polarized ()) then
call pol%to_angles (r, theta, phi)
call lcio_particle_set_spin (prt%obj, &
real(r, c_double), real (theta, c_double), real (phi, c_double))
end if
end subroutine lcio_polarization_init_pol
subroutine lcio_polarization_init_hel (prt, hel)
type(lcio_particle_t), intent(inout) :: prt
type(helicity_t), intent(in) :: hel
integer, dimension(2) :: h
if (hel%is_defined ()) then
h = hel%to_pair ()
select case (h(1))
case (1:)
call lcio_particle_set_spin (prt%obj, 1._c_double, &
0._c_double, 0._c_double)
case (:-1)
call lcio_particle_set_spin (prt%obj, 1._c_double, &
real (pi, c_double), 0._c_double)
case (0)
call lcio_particle_set_spin (prt%obj, 1._c_double, &
real (pi/2, c_double), 0._c_double)
end select
end if
end subroutine lcio_polarization_init_hel
subroutine lcio_polarization_init_int (prt, hel)
type(lcio_particle_t), intent(inout) :: prt
integer, intent(in) :: hel
call lcio_particle_set_spin (prt%obj, 0._c_double, &
0._c_double, real (hel, c_double))
end subroutine lcio_polarization_init_int
@ %def lcio_polarization_init
@ Recover polarization from LCIO particle (with the
abovementioned deficiencies).
<<LCIO interface: interfaces>>=
interface
function lcio_polarization_degree (prt_obj) result (degree) bind(C)
import
real(c_double) :: degree
type(c_ptr), value :: prt_obj
end function lcio_polarization_degree
end interface
interface
function lcio_polarization_theta (prt_obj) result (theta) bind(C)
import
real(c_double) :: theta
type(c_ptr), value :: prt_obj
end function lcio_polarization_theta
end interface
interface
function lcio_polarization_phi (prt_obj) result (phi) bind(C)
import
real(c_double) :: phi
type(c_ptr), value :: prt_obj
end function lcio_polarization_phi
end interface
@ %def lcio_polarization_degree lcio_polarization_theta lcio_polarization_phi
<<LCIO interface: public>>=
public :: lcio_particle_to_pol
<<LCIO interface: procedures>>=
subroutine lcio_particle_to_pol (prt, flv, pol)
type(lcio_particle_t), intent(in) :: prt
type(flavor_t), intent(in) :: flv
type(polarization_t), intent(out) :: pol
real(default) :: degree, theta, phi
degree = lcio_polarization_degree (prt%obj)
theta = lcio_polarization_theta (prt%obj)
phi = lcio_polarization_phi (prt%obj)
call pol%init_angles (flv, degree, theta, phi)
end subroutine lcio_particle_to_pol
@ %def lcio_polarization_to_pol
@ Recover helicity. Here, $\phi$ and [[degree]] is ignored and only the sign of
$\cos\theta$ is relevant, mapped to positive/negative helicity.
<<LCIO interface: public>>=
public :: lcio_particle_to_hel
<<LCIO interface: procedures>>=
subroutine lcio_particle_to_hel (prt, flv, hel)
type(lcio_particle_t), intent(in) :: prt
type(flavor_t), intent(in) :: flv
type(helicity_t), intent(out) :: hel
real(default) :: theta
integer :: hmax
theta = lcio_polarization_theta (prt%obj)
hmax = flv%get_spin_type () / 2
call hel%init (sign (hmax, nint (cos (theta))))
end subroutine lcio_particle_to_hel
@ %def lcio_particle_to_hel
@ Set the vertex of a particle.
<<LCIO interface: interfaces>>=
interface
subroutine lcio_particle_set_vertex (prt_obj, vx, vy, vz) bind(C)
import
type(c_ptr), value :: prt_obj
real(c_double), value :: vx, vy, vz
end subroutine lcio_particle_set_vertex
end interface
interface
subroutine lcio_particle_set_time (prt_obj, t) bind(C)
import
type(c_ptr), value :: prt_obj
real(c_double), value :: t
end subroutine lcio_particle_set_time
end interface
@ %def lcio_particle_set_vertex lcio_particle_set_time
@
<<LCIO interface: public>>=
public :: lcio_particle_set_vtx
<<LCIO interface: procedures>>=
subroutine lcio_particle_set_vtx (prt, vtx)
type(lcio_particle_t), intent(inout) :: prt
type(vector3_t), intent(in) :: vtx
call lcio_particle_set_vertex (prt%obj, real(vtx%p(1), c_double), &
real(vtx%p(2), c_double), real(vtx%p(3), c_double))
end subroutine lcio_particle_set_vtx
@ %def lcio_particle_set_vtx
@
<<LCIO interface: public>>=
public :: lcio_particle_set_t
<<LCIO interface: procedures>>=
subroutine lcio_particle_set_t (prt, t)
type(lcio_particle_t), intent(inout) :: prt
real(default), intent(in) :: t
call lcio_particle_set_time (prt%obj, real(t, c_double))
end subroutine lcio_particle_set_t
@ %def lcio_particle_set_t
@
<<LCIO interface: interfaces>>=
interface
subroutine lcio_particle_add_parent (prt_obj1, prt_obj2) bind(C)
import
type(c_ptr), value :: prt_obj1, prt_obj2
end subroutine lcio_particle_add_parent
end interface
@ %def lcio_particle_add_parent
<<LCIO interface: public>>=
public :: lcio_particle_set_parent
<<LCIO interface: procedures>>=
subroutine lcio_particle_set_parent (daughter, parent)
type(lcio_particle_t), intent(inout) :: daughter, parent
call lcio_particle_add_parent (daughter%obj, parent%obj)
end subroutine lcio_particle_set_parent
@ %def lcio_particle_set_parent
@
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_particle_get_generator_status &
(prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function lcio_particle_get_generator_status
end interface
@ %def lcio_particle_get_generator_status
<<LCIO interface: public>>=
public :: lcio_particle_get_status
<<LCIO interface: procedures>>=
function lcio_particle_get_status (lptr) result (status)
integer :: status
type(lcio_particle_t), intent(in) :: lptr
status = lcio_particle_get_generator_status (lptr%obj)
end function lcio_particle_get_status
@ %def lcio_particle_get_status
@ Getting the PDG code.
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_particle_get_pdg_code (prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function lcio_particle_get_pdg_code
end interface
@ %def lcio_particle_get_pdg_code
@
<<LCIO interface: public>>=
public :: lcio_particle_get_pdg
<<LCIO interface: procedures>>=
function lcio_particle_get_pdg (lptr) result (pdg)
integer :: pdg
type(lcio_particle_t), intent(in) :: lptr
pdg = lcio_particle_get_pdg_code (lptr%obj)
end function lcio_particle_get_pdg
@ %def lcio_particle_get_pdg
@ Obtaining the number of parents and daughters of an LCIO particle.
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_n_parents (prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function lcio_n_parents
end interface
@ %def lcio_n_parents
@
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_n_daughters (prt_obj) bind(C)
import
type(c_ptr), value :: prt_obj
end function lcio_n_daughters
end interface
@ %def lcio_n_daughters
@
<<LCIO interface: public>>=
public :: lcio_particle_get_n_parents
<<LCIO interface: procedures>>=
function lcio_particle_get_n_parents (lptr) result (n_parents)
integer :: n_parents
type(lcio_particle_t), intent(in) :: lptr
n_parents = lcio_n_parents (lptr%obj)
end function lcio_particle_get_n_parents
@ %def lcio_particle_get_n_parents
@
<<LCIO interface: public>>=
public :: lcio_particle_get_n_children
<<LCIO interface: procedures>>=
function lcio_particle_get_n_children (lptr) result (n_children)
integer :: n_children
type(lcio_particle_t), intent(in) :: lptr
n_children = lcio_n_daughters (lptr%obj)
end function lcio_particle_get_n_children
@ %def lcio_particle_get_n_children
@ This provides access from the LCIO event [[lcio_event_t]] to the array entries
of the parent and daughter arrays of the LCIO particles.
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_event_parent_k &
(evt_obj, num_part, k_parent) bind (C)
use iso_c_binding !NODEP!
type(c_ptr), value :: evt_obj
integer(c_int), value :: num_part, k_parent
end function lcio_event_parent_k
end interface
@ %def lcio_event_parent_k
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_event_daughter_k &
(evt_obj, num_part, k_daughter) bind (C)
use iso_c_binding !NODEP!
type(c_ptr), value :: evt_obj
integer(c_int), value :: num_part, k_daughter
end function lcio_event_daughter_k
end interface
@ %def lcio_event_daughter_k
@
<<LCIO interface: public>>=
public :: lcio_get_n_parents
<<LCIO interface: procedures>>=
function lcio_get_n_parents (evt, num_part, k_parent) result (index_parent)
type(lcio_event_t), intent(in) :: evt
integer, intent(in) :: num_part, k_parent
integer :: index_parent
index_parent = lcio_event_parent_k (evt%obj, int (num_part, c_int), &
int (k_parent, c_int))
end function lcio_get_n_parents
@ %def lcio_get_n_parents
@
<<LCIO interface: public>>=
public :: lcio_get_n_children
<<LCIO interface: procedures>>=
function lcio_get_n_children (evt, num_part, k_daughter) result (index_daughter)
type(lcio_event_t), intent(in) :: evt
integer, intent(in) :: num_part, k_daughter
integer :: index_daughter
index_daughter = lcio_event_daughter_k (evt%obj, int (num_part, c_int), &
int (k_daughter, c_int))
end function lcio_get_n_children
@ %def lcio_get_n_children
@
\subsection{LCIO Writer type}
There is a specific LCIO Writer type for handling the output of
LCEventImpl objects (i.e., Monte Carlo event samples) to file. Opening
the file is done by the constructor, closing by the destructor.
<<LCIO interface: public>>=
public :: lcio_writer_t
<<LCIO interface: types>>=
type :: lcio_writer_t
private
type(c_ptr) :: obj
end type lcio_writer_t
@ %def lcio_writer_t
@ Constructor for an output associated to a file.
<<LCIO interface: interfaces>>=
interface
type(c_ptr) function open_lcio_writer_new (filename, complevel) bind(C)
import
character(c_char), dimension(*), intent(in) :: filename
integer(c_int), intent(in) :: complevel
end function open_lcio_writer_new
end interface
@ %def open_lcio_writer_now
<<LCIO interface: public>>=
public :: lcio_writer_open_out
<<LCIO interface: procedures>>=
subroutine lcio_writer_open_out (lcio_writer, filename)
type(lcio_writer_t), intent(out) :: lcio_writer
type(string_t), intent(in) :: filename
lcio_writer%obj = open_lcio_writer_new (char (filename) // &
c_null_char, 9_c_int)
end subroutine lcio_writer_open_out
@ %def lcio_writer_open_out
@ Destructor:
<<LCIO interface: interfaces>>=
interface
subroutine lcio_writer_delete (io_obj) bind(C)
import
type(c_ptr), value :: io_obj
end subroutine lcio_writer_delete
end interface
@ %def lcio_writer_delete
<<LCIO interface: public>>=
public :: lcio_writer_close
<<LCIO interface: procedures>>=
subroutine lcio_writer_close (lciowriter)
type(lcio_writer_t), intent(inout) :: lciowriter
call lcio_writer_delete (lciowriter%obj)
end subroutine lcio_writer_close
@ %def lcio_writer_close
@ Write a single event to the LCIO writer.
<<LCIO interface: interfaces>>=
interface
subroutine lcio_write_event (io_obj, evt_obj) bind(C)
import
type(c_ptr), value :: io_obj, evt_obj
end subroutine lcio_write_event
end interface
@ %def lcio_write_event
<<LCIO interface: public>>=
public :: lcio_event_write
<<LCIO interface: procedures>>=
subroutine lcio_event_write (wrt, evt)
type(lcio_writer_t), intent(inout) :: wrt
type(lcio_event_t), intent(in) :: evt
call lcio_write_event (wrt%obj, evt%obj)
end subroutine lcio_event_write
@ %def lcio_event_write
@
\subsection{LCIO Reader type}
There is a specific LCIO Reader type for handling the input of
LCEventImpl objects (i.e., Monte Carlo event samples) from file. Opening
the file is done by the constructor, closing by the destructor.
<<LCIO interface: public>>=
public :: lcio_reader_t
<<LCIO interface: types>>=
type :: lcio_reader_t
private
type(c_ptr) :: obj
end type lcio_reader_t
@ %def lcio_reader_t
@ Constructor for an output associated to a file.
<<LCIO interface: interfaces>>=
interface
type(c_ptr) function open_lcio_reader (filename) bind(C)
import
character(c_char), dimension(*), intent(in) :: filename
end function open_lcio_reader
end interface
@ %def open_lcio_reader
<<LCIO interface: public>>=
public :: lcio_open_file
<<LCIO interface: procedures>>=
subroutine lcio_open_file (lcio_reader, filename)
type(lcio_reader_t), intent(out) :: lcio_reader
type(string_t), intent(in) :: filename
lcio_reader%obj = open_lcio_reader (char (filename) // c_null_char)
end subroutine lcio_open_file
@ %def lcio_open_file
@ Destructor:
<<LCIO interface: interfaces>>=
interface
subroutine lcio_reader_delete (io_obj) bind(C)
import
type(c_ptr), value :: io_obj
end subroutine lcio_reader_delete
end interface
@ %def lcio_reader_delete
<<LCIO interface: public>>=
public :: lcio_reader_close
<<LCIO interface: procedures>>=
subroutine lcio_reader_close (lcioreader)
type(lcio_reader_t), intent(inout) :: lcioreader
call lcio_reader_delete (lcioreader%obj)
end subroutine lcio_reader_close
@ %def lcio_reader_close
@
@ Read a single event from the event file. Return true if successful.
<<LCIO interface: interfaces>>=
interface
type(c_ptr) function read_lcio_event (io_obj) bind(C)
import
type(c_ptr), value :: io_obj
end function read_lcio_event
end interface
@ %def read_lcio_event
<<LCIO interface: public>>=
public :: lcio_read_event
<<LCIO interface: procedures>>=
subroutine lcio_read_event (lcrdr, evt, ok)
type(lcio_reader_t), intent(inout) :: lcrdr
type(lcio_event_t), intent(out) :: evt
logical, intent(out) :: ok
evt%obj = read_lcio_event (lcrdr%obj)
ok = c_associated (evt%obj)
end subroutine lcio_read_event
@ %def lcio_read_event
@ Get the event index.
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_event_get_event_number (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end function lcio_event_get_event_number
end interface
@ %def lcio_event_get_event_number
<<LCIO interface: public>>=
public :: lcio_event_get_event_index
<<LCIO interface: procedures>>=
function lcio_event_get_event_index (evt) result (i_evt)
integer :: i_evt
type(lcio_event_t), intent(in) :: evt
i_evt = lcio_event_get_event_number (evt%obj)
end function lcio_event_get_event_index
@ %def lcio_event_get_event_index
@ Extract the process ID. This is stored (at the moment abusively) in the
RUN ID as well as in an additional event parameter.
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_event_signal_process_id (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end function lcio_event_signal_process_id
end interface
@ %def lcio_event_signal_process_id
<<LCIO interface: public>>=
public :: lcio_event_get_process_id
<<LCIO interface: procedures>>=
function lcio_event_get_process_id (evt) result (i_proc)
integer :: i_proc
type(lcio_event_t), intent(in) :: evt
i_proc = lcio_event_signal_process_id (evt%obj)
end function lcio_event_get_process_id
@ %def lcio_event_get_process_id
@ Number of particles in an LCIO event.
<<LCIO interface: interfaces>>=
interface
integer(c_int) function lcio_event_get_n_particles (evt_obj) bind(C)
import
type(c_ptr), value :: evt_obj
end function lcio_event_get_n_particles
end interface
@ %def lcio_event_get_n_particles
<<LCIO interface:>>=
@
<<LCIO interface: public>>=
public :: lcio_event_get_n_tot
<<LCIO interface: procedures>>=
function lcio_event_get_n_tot (evt) result (n_tot)
integer :: n_tot
type(lcio_event_t), intent(in) :: evt
n_tot = lcio_event_get_n_particles (evt%obj)
end function lcio_event_get_n_tot
@ %def lcio_event_get_n_tot
@ Extracting $\alpha_s$ and the scale.
<<LCIO interface: interfaces>>=
interface
function lcio_event_get_alpha_qcd (evt_obj) result (as) bind(C)
import
real(c_double) :: as
type(c_ptr), value :: evt_obj
end function lcio_event_get_alpha_qcd
end interface
interface
function lcio_event_get_scale (evt_obj) result (scale) bind(C)
import
real(c_double) :: scale
type(c_ptr), value :: evt_obj
end function lcio_event_get_scale
end interface
@ %def lcio_event_get_alpha_qcd lcio_event_get_scale
@
<<LCIO interface: public>>=
public :: lcio_event_get_alphas
<<LCIO interface: procedures>>=
function lcio_event_get_alphas (evt) result (as)
type(lcio_event_t), intent(in) :: evt
real(default) :: as
as = lcio_event_get_alpha_qcd (evt%obj)
end function lcio_event_get_alphas
@ %def lcio_event_get_alphas
@
<<LCIO interface: public>>=
public :: lcio_event_get_scaleval
<<LCIO interface: procedures>>=
function lcio_event_get_scaleval (evt) result (scale)
type(lcio_event_t), intent(in) :: evt
real(default) :: scale
scale = lcio_event_get_scale (evt%obj)
end function lcio_event_get_scaleval
@ %def lcio_event_get_scaleval
@ Extracting particles by index from an LCIO event.
<<LCIO interface: interfaces>>=
interface
type(c_ptr) function lcio_event_particle_k (evt_obj, k) bind(C)
import
type(c_ptr), value :: evt_obj
integer(c_int), value :: k
end function lcio_event_particle_k
end interface
@ %def lcio_event_particle_k
@
<<LCIO interface: public>>=
public :: lcio_event_get_particle
<<LCIO interface: procedures>>=
function lcio_event_get_particle (evt, n) result (prt)
type(lcio_event_t), intent(in) :: evt
integer, intent(in) :: n
type(lcio_particle_t) :: prt
prt%obj = lcio_event_particle_k (evt%obj, int (n, c_int))
end function lcio_event_get_particle
@ %def lcio_event_get_particle
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[lcio_interface_ut.f90]]>>=
<<File header>>
module lcio_interface_ut
use unit_tests
use lcio_interface_uti
<<Standard module head>>
<<LCIO interface: public test>>
contains
<<LCIO interface: test driver>>
end module lcio_interface_ut
@ %def lcio_interface_ut
@
<<[[lcio_interface_uti.f90]]>>=
<<File header>>
module lcio_interface_uti
<<Use kinds>>
<<Use strings>>
use io_units
use lorentz
use flavors
use colors
use polarizations
use lcio_interface
<<Standard module head>>
<<LCIO interface: test declarations>>
contains
<<LCIO interface: tests>>
end module lcio_interface_uti
@ %def lcio_interface_ut
@ API: driver for the unit tests below.
<<LCIO interface: public test>>=
public :: lcio_interface_test
<<LCIO interface: test driver>>=
subroutine lcio_interface_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<LCIO interface: execute tests>>
end subroutine lcio_interface_test
@ %def lcio_interface_test
@
<<LCIO interface: execute tests>>=
call test (lcio_interface_1, "lcio_interface_1", &
"check LCIO interface", &
u, results)
<<LCIO interface: test declarations>>=
public :: lcio_interface_1
<<LCIO interface: tests>>=
subroutine lcio_interface_1 (u)
use physics_defs, only: VECTOR
use model_data, only: field_data_t
integer, intent(in) :: u
integer :: u_file, iostat
type(lcio_event_t) :: evt
type(lcio_particle_t) :: prt1, prt2, prt3, prt4, prt5, prt6, prt7, prt8
type(flavor_t) :: flv
type(color_t) :: col
type(polarization_t) :: pol
type(field_data_t), target :: photon_data
character(220) :: buffer
write (u, "(A)") "* Test output: LCIO interface"
write (u, "(A)") "* Purpose: test LCIO interface"
write (u, "(A)")
write (u, "(A)") "* Initialization"
write (u, "(A)")
! Initialize a photon flavor object and some polarization
call photon_data%init (var_str ("PHOTON"), 22)
call photon_data%set (spin_type=VECTOR)
call photon_data%freeze ()
call flv%init (photon_data)
call pol%init_angles &
(flv, 0.6_default, 1._default, 0.5_default)
! Event initialization
call lcio_event_init (evt, 20, 1, 42)
write (u, "(A)") "* p -> q splitting"
write (u, "(A)")
! $p\to q$ splittings
call particle_init (prt1, &
0._default, 0._default, 7000._default, 7000._default, &
2212, 1._default, 3)
call particle_init (prt2, &
0._default, 0._default,-7000._default, 7000._default, &
2212, 1._default, 3)
call particle_init (prt3, &
.750_default, -1.569_default, 32.191_default, 32.238_default, &
1, -1._default/3._default, 3)
call color_init_from_array (col, [501])
call lcio_particle_set_color (prt3, col)
call lcio_particle_set_parent (prt3, prt1)
call lcio_particle_set_parent (prt3, prt2)
call particle_init (prt4, &
-3.047_default, -19._default, -54.629_default, 57.920_default, &
-2, -2._default/3._default, 3)
call color_init_from_array (col, [-501])
call lcio_particle_set_color (prt4, col)
call lcio_particle_set_parent (prt4, prt1)
call lcio_particle_set_parent (prt4, prt2)
write (u, "(A)") "* Hard interaction"
write (u, "(A)")
! Hard interaction
call particle_init (prt6, &
-3.813_default, 0.113_default, -1.833_default, 4.233_default, &
22, 0._default, 1)
call lcio_polarization_init (prt6, pol)
call particle_init (prt5, &
1.517_default, -20.68_default, -20.605_default, 85.925_default, &
-24, -1._default, 3)
call lcio_particle_set_parent (prt5, prt3)
call lcio_particle_set_parent (prt5, prt4)
call lcio_particle_set_parent (prt6, prt3)
call lcio_particle_set_parent (prt6, prt4)
! $W^-$ decay
call particle_init (prt7, &
-2.445_default, 28.816_default, 6.082_default, 29.552_default, &
1, -1._default/3._default, 1)
call particle_init (prt8, &
3.962_default, -49.498_default, -26.687_default, 56.373_default, &
-2, -2._default/3._default, 1)
call lcio_particle_set_t (prt7, 0.12_default)
call lcio_particle_set_t (prt8, 0.12_default)
call lcio_particle_set_vtx &
(prt7, vector3_moving ([-0.3_default, 0.05_default, 0.004_default]))
call lcio_particle_set_vtx &
(prt8, vector3_moving ([-0.3_default, 0.05_default, 0.004_default]))
call lcio_particle_set_parent (prt7, prt5)
call lcio_particle_set_parent (prt8, prt5)
call lcio_particle_add_to_evt_coll (prt1, evt)
call lcio_particle_add_to_evt_coll (prt2, evt)
call lcio_particle_add_to_evt_coll (prt3, evt)
call lcio_particle_add_to_evt_coll (prt4, evt)
call lcio_particle_add_to_evt_coll (prt5, evt)
call lcio_particle_add_to_evt_coll (prt6, evt)
call lcio_particle_add_to_evt_coll (prt7, evt)
call lcio_particle_add_to_evt_coll (prt8, evt)
call lcio_event_add_coll (evt)
! Event output
write (u, "(A)") "Writing in ASCII form to file 'lcio_test.slcio'"
write (u, "(A)")
call write_lcio_event (evt, var_str ("lcio_test.slcio"))
write (u, "(A)") "Writing completed"
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = "lcio_test.slcio", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (trim (buffer) == "") cycle
if (buffer(1:12) == " - timestamp") buffer = "[...]"
if (buffer(1:6) == " date:") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
write (u, "(A)")
! Wrapup
! call pol%final ()
call lcio_event_final (evt)
write (u, "(A)")
write (u, "(A)") "* Test output end: lcio_interface_1"
contains
subroutine particle_init &
(prt, px, py, pz, E, pdg, charge, status)
type(lcio_particle_t), intent(out) :: prt
real(default), intent(in) :: px, py, pz, E, charge
integer, intent(in) :: pdg, status
type(vector4_t) :: p
p = vector4_moving (E, vector3_moving ([px, py, pz]))
call lcio_particle_init (prt, p, pdg, charge, status)
end subroutine particle_init
end subroutine lcio_interface_1
@ %def lcio_interface_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{HEP Common and Events}
This is a separate module that manages data exchange between the common blocks
and [[event_t]] objects. We separate this from the previous module in order
to avoid a circular module dependency. It also contains the functions
necessary for communication between [[hepmc_event_t]] and
[[event_t]] or [[lcio_event_t]] and [[event_t]] as well as
[[particle_set_t]] and [[particle_t]] objects.
<<[[hep_events.f90]]>>=
<<File header>>
module hep_events
<<Use kinds>>
<<Use strings>>
use diagnostics
use lorentz
use numeric_utils
use flavors
use colors
use helicities
use polarizations
use model_data
use subevents, only: PRT_BEAM, PRT_INCOMING, PRT_OUTGOING
use subevents, only: PRT_UNDEFINED
use subevents, only: PRT_VIRTUAL, PRT_RESONANT, PRT_BEAM_REMNANT
use particles
use hep_common
use hepmc_interface
use lcio_interface
use event_base
<<Standard module head>>
<<HEP events: public>>
contains
<<HEP events: procedures>>
end module hep_events
@ %def hep_events
@
\subsection{Data Transfer: events}
Fill the HEPEUP block, given a \whizard\ event object.
<<HEP events: public>>=
public :: hepeup_from_event
<<HEP events: procedures>>=
subroutine hepeup_from_event &
(event, keep_beams, keep_remnants, process_index)
class(generic_event_t), intent(in), target :: event
logical, intent(in), optional :: keep_beams
logical, intent(in), optional :: keep_remnants
integer, intent(in), optional :: process_index
type(particle_set_t), pointer :: particle_set
real(default) :: scale, alpha_qcd
if (event%has_valid_particle_set ()) then
particle_set => event%get_particle_set_ptr ()
call hepeup_from_particle_set (particle_set, keep_beams, keep_remnants)
if (present (process_index)) then
call hepeup_set_event_parameters (proc_id = process_index)
end if
scale = event%get_fac_scale ()
if (.not. vanishes (scale)) then
call hepeup_set_event_parameters (scale = scale)
end if
alpha_qcd = event%get_alpha_s ()
if (.not. vanishes (alpha_qcd)) then
call hepeup_set_event_parameters (alpha_qcd = alpha_qcd)
end if
if (event%weight_prc_is_known ()) then
call hepeup_set_event_parameters (weight = event%get_weight_prc ())
end if
else
call msg_bug ("HEPEUP: event incomplete")
end if
end subroutine hepeup_from_event
@ %def hepeup_from_event
@ Reverse.
Note: The current implementation sets the particle set of the hard
process and is therefore not useful if the event on file is dressed.
This should be reconsidered.
Note: setting of scale or alpha is not yet supported by the
[[event_t]] object. Ticket \#628.
<<HEP events: public>>=
public :: hepeup_to_event
<<HEP events: procedures>>=
subroutine hepeup_to_event &
(event, fallback_model, process_index, recover_beams, &
use_alpha_s, use_scale)
class(generic_event_t), intent(inout), target :: event
class(model_data_t), intent(in), target :: fallback_model
integer, intent(out), optional :: process_index
logical, intent(in), optional :: recover_beams
logical, intent(in), optional :: use_alpha_s
logical, intent(in), optional :: use_scale
class(model_data_t), pointer :: model
real(default) :: weight, scale, alpha_qcd
type(particle_set_t) :: particle_set
model => event%get_model_ptr ()
call hepeup_to_particle_set &
(particle_set, recover_beams, model, fallback_model)
call event%set_hard_particle_set (particle_set)
call particle_set%final ()
if (present (process_index)) then
call hepeup_get_event_parameters (proc_id = process_index)
end if
call hepeup_get_event_parameters (weight = weight, &
scale = scale, alpha_qcd = alpha_qcd)
call event%set_weight_ref (weight)
if (present (use_alpha_s)) then
if (use_alpha_s .and. alpha_qcd > 0) &
call event%set_alpha_qcd_forced (alpha_qcd)
end if
if (present (use_scale)) then
if (use_scale .and. scale > 0) &
call event%set_scale_forced (scale)
end if
end subroutine hepeup_to_event
@ %def hepeup_to_event
@ Fill the HEPEVT (event) common block.
The [[i_evt]] argument overrides the index stored in the [[event]] object.
<<HEP events: public>>=
public :: hepevt_from_event
<<HEP events: procedures>>=
subroutine hepevt_from_event &
(event, process_index, i_evt, keep_beams, keep_remnants, &
ensure_order, fill_hepev4)
class(generic_event_t), intent(in), target :: event
integer, intent(in), optional :: i_evt, process_index
logical, intent(in), optional :: keep_beams
logical, intent(in), optional :: keep_remnants
logical, intent(in), optional :: ensure_order
logical, intent(in), optional :: fill_hepev4
type(particle_set_t), pointer :: particle_set
real(default) :: alpha_qcd, scale
if (event%has_valid_particle_set ()) then
particle_set => event%get_particle_set_ptr ()
call hepevt_from_particle_set (particle_set, keep_beams, &
keep_remnants, ensure_order, fill_hepev4)
if (present (process_index)) then
call hepevt_set_event_parameters (proc_id = process_index)
end if
if (event%weight_prc_is_known ()) then
call hepevt_set_event_parameters (weight = event%get_weight_prc ())
end if
if (event%sqme_prc_is_known ()) then
call hepevt_set_event_parameters &
(function_value = event%get_sqme_prc ())
end if
scale = event%get_fac_scale ()
if (.not. vanishes (scale)) then
call hepevt_set_event_parameters (scale = scale)
end if
alpha_qcd = event%get_alpha_s ()
if (.not. vanishes (alpha_qcd)) then
call hepevt_set_event_parameters (alpha_qcd = alpha_qcd)
end if
if (present (i_evt)) then
call hepevt_set_event_parameters (i_evt = i_evt)
else if (event%has_index ()) then
call hepevt_set_event_parameters (i_evt = event%get_index ())
else
call hepevt_set_event_parameters (i_evt = 0)
end if
else
call msg_bug ("HEPEVT: event incomplete")
end if
end subroutine hepevt_from_event
@ %def hepevt_from_event
@
\subsubsection{HepMC format}
The master output function fills a HepMC GenEvent object that is
already initialized, but has no vertices in it.
We first set up the vertex lists and enter the vertices into the HepMC
event. Then, we assign first all incoming particles and then all
outgoing particles to their associated vertices. Particles which have
neither parent nor children entries (this should not happen) are
dropped.
Finally, we insert the beam particles. If there are none, use the incoming
particles instead.
@ Transform a particle into a [[hepmc_particle]] object, including
color and polarization. The HepMC status is equivalent to the HEPEVT
status, in particular: 0 = null entry, 1 = physical particle, 2 =
decayed/fragmented SM hadron, tau or muon, 3 = other unphysical particle
entry, 4 = incoming particles, 11 = intermediate resonance such as squarks.
The use of 11 for intermediate resonances is as done by HERWIG, see
http://herwig.hepforge.org/trac/wiki/FaQs.
<<HEP events: procedures>>=
subroutine particle_to_hepmc (prt, hprt)
type(particle_t), intent(in) :: prt
type(hepmc_particle_t), intent(out) :: hprt
integer :: hepmc_status
select case (prt%get_status ())
case (PRT_UNDEFINED)
hepmc_status = 0
case (PRT_OUTGOING)
hepmc_status = 1
case (PRT_BEAM)
hepmc_status = 4
case (PRT_RESONANT)
if (abs(prt%get_pdg()) == 13 .or. &
abs(prt%get_pdg()) == 15) then
hepmc_status = 2
else
hepmc_status = 11
end if
case default
hepmc_status = 3
end select
call hepmc_particle_init (hprt, &
prt%get_momentum (), prt%get_pdg (), &
hepmc_status)
call hepmc_particle_set_color (hprt, prt%get_color ())
select case (prt%get_polarization_status ())
case (PRT_DEFINITE_HELICITY)
call hepmc_particle_set_polarization (hprt, &
prt%get_helicity ())
case (PRT_GENERIC_POLARIZATION)
call hepmc_particle_set_polarization (hprt, &
prt%get_polarization ())
end select
end subroutine particle_to_hepmc
@ %def particle_to_hepmc
@
<<HEP events: public>>=
public :: hepmc_event_from_particle_set
<<HEP events: procedures>>=
subroutine hepmc_event_from_particle_set &
(evt, particle_set, cross_section, error)
type(hepmc_event_t), intent(inout) :: evt
type(particle_set_t), intent(in) :: particle_set
real(default), intent(in), optional :: cross_section, error
type(hepmc_vertex_t), dimension(:), allocatable :: v
type(hepmc_particle_t), dimension(:), allocatable :: hprt
type(hepmc_particle_t), dimension(2) :: hbeam
type(vector4_t), dimension(:), allocatable :: vtx
logical, dimension(:), allocatable :: is_beam
integer, dimension(:), allocatable :: v_from, v_to
integer :: n_vertices, n_tot, i
n_tot = particle_set%get_n_tot ()
allocate (v_from (n_tot), v_to (n_tot))
call particle_set%assign_vertices (v_from, v_to, n_vertices)
allocate (hprt (n_tot))
allocate (vtx (n_vertices))
vtx = vector4_null
do i = 1, n_tot
if (v_to(i) /= 0 .or. v_from(i) /= 0) then
call particle_to_hepmc (particle_set%prt(i), hprt(i))
if (v_to(i) /= 0) then
vtx(v_to(i)) = particle_set%prt(i)%get_vertex ()
end if
end if
end do
if (present (cross_section) .and. present(error)) &
call hepmc_event_set_cross_section (evt, cross_section, error)
allocate (v (n_vertices))
do i = 1, n_vertices
call hepmc_vertex_init (v(i), vtx(i))
call hepmc_event_add_vertex (evt, v(i))
end do
allocate (is_beam (n_tot))
is_beam = particle_set%prt(1:n_tot)%get_status () == PRT_BEAM
if (.not. any (is_beam)) then
is_beam = particle_set%prt(1:n_tot)%get_status () == PRT_INCOMING
end if
if (count (is_beam) == 2) then
hbeam = pack (hprt, is_beam)
call hepmc_event_set_beam_particles (evt, hbeam(1), hbeam(2))
end if
do i = 1, n_tot
if (v_to(i) /= 0) then
call hepmc_vertex_add_particle_in (v(v_to(i)), hprt(i))
end if
end do
do i = 1, n_tot
if (v_from(i) /= 0) then
call hepmc_vertex_add_particle_out (v(v_from(i)), hprt(i))
end if
end do
FIND_SIGNAL_PROCESS: do i = 1, n_tot
if (particle_set%prt(i)%get_status () == PRT_INCOMING) then
call hepmc_event_set_signal_process_vertex (evt, v(v_to(i)))
exit FIND_SIGNAL_PROCESS
end if
end do FIND_SIGNAL_PROCESS
end subroutine hepmc_event_from_particle_set
@ %def hepmc_event_from_particle_set
@ Initialize a particle from a HepMC particle object. The model is
necessary for making a fully qualified flavor component. We have the
additional flag [[polarized]] which tells whether the polarization
information should be interpreted or ignored, and the lookup array of
barcodes. Note that the lookup array is searched linearly, a possible
bottleneck for large particle arrays. If necessary, the barcode array
could be replaced by a hash table.
<<HEP events: procedures>>=
subroutine particle_from_hepmc_particle &
(prt, hprt, model, fallback_model, polarization, barcode)
type(particle_t), intent(out) :: prt
type(hepmc_particle_t), intent(in) :: hprt
type(model_data_t), intent(in), target :: model
type(model_data_t), intent(in), target :: fallback_model
type(hepmc_vertex_t) :: vtx
integer, intent(in) :: polarization
integer, dimension(:), intent(in) :: barcode
type(hepmc_polarization_t) :: hpol
type(flavor_t) :: flv
type(color_t) :: col
type(helicity_t) :: hel
type(polarization_t) :: pol
type(vector4_t) :: vertex
integer :: n_parents, n_children
integer, dimension(:), allocatable :: &
parent_barcode, child_barcode, parent, child
integer :: i
select case (hepmc_particle_get_status (hprt))
case (1); call prt%set_status (PRT_OUTGOING)
case (2); call prt%set_status (PRT_RESONANT)
case (3); call prt%set_status (PRT_VIRTUAL)
end select
if (hepmc_particle_is_beam (hprt)) call prt%set_status (PRT_BEAM)
call flv%init (hepmc_particle_get_pdg (hprt), model, fallback_model)
call col%init (hepmc_particle_get_color (hprt))
call prt%set_flavor (flv)
call prt%set_color (col)
call prt%set_polarization (polarization)
select case (polarization)
case (PRT_DEFINITE_HELICITY)
hpol = hepmc_particle_get_polarization (hprt)
call hepmc_polarization_to_hel (hpol, prt%get_flv (), hel)
call prt%set_helicity (hel)
call hepmc_polarization_final (hpol)
case (PRT_GENERIC_POLARIZATION)
hpol = hepmc_particle_get_polarization (hprt)
call hepmc_polarization_to_pol (hpol, prt%get_flv (), pol)
call prt%set_pol (pol)
call hepmc_polarization_final (hpol)
end select
call prt%set_momentum (hepmc_particle_get_momentum (hprt), &
hepmc_particle_get_mass_squared (hprt))
n_parents = hepmc_particle_get_n_parents (hprt)
n_children = hepmc_particle_get_n_children (hprt)
allocate (parent_barcode (n_parents), parent (n_parents))
allocate (child_barcode (n_children), child (n_children))
parent_barcode = hepmc_particle_get_parent_barcodes (hprt)
child_barcode = hepmc_particle_get_child_barcodes (hprt)
do i = 1, size (barcode)
where (parent_barcode == barcode(i)) parent = i
where (child_barcode == barcode(i)) child = i
end do
call prt%set_parents (parent)
call prt%set_children (child)
if (prt%get_status () == PRT_VIRTUAL .and. n_parents == 0) &
call prt%set_status (PRT_INCOMING)
vtx = hepmc_particle_get_decay_vertex (hprt)
if (hepmc_vertex_is_valid (vtx)) then
vertex = hepmc_vertex_to_vertex (vtx)
if (vertex /= vector4_null) call prt%set_vertex (vertex)
end if
end subroutine particle_from_hepmc_particle
@ %def particle_from_hepmc_particle
@ If a particle set is initialized from a HepMC event record, we have
to specify the treatment of polarization (unpolarized or density
matrix) which is common to all particles. Correlated polarization
information is not available.
There is some complication in reconstructing incoming particles and
beam remnants. First of all, they all will be tagged as virtual. We
then define an incoming particle as
<<HEP events: public>>=
public :: hepmc_event_to_particle_set
<<HEP events: procedures>>=
subroutine hepmc_event_to_particle_set &
(particle_set, evt, model, fallback_model, polarization)
type(particle_set_t), intent(inout), target :: particle_set
type(hepmc_event_t), intent(in) :: evt
class(model_data_t), intent(in), target :: model, fallback_model
integer, intent(in) :: polarization
type(hepmc_event_particle_iterator_t) :: it
type(hepmc_vertex_t) :: v
type(hepmc_vertex_particle_in_iterator_t) :: v_it
type(hepmc_particle_t) :: prt
integer, dimension(:), allocatable :: barcode
integer :: n_tot, i, bc
n_tot = 0
call hepmc_event_particle_iterator_init (it, evt)
do while (hepmc_event_particle_iterator_is_valid (it))
n_tot = n_tot + 1
call hepmc_event_particle_iterator_advance (it)
end do
allocate (barcode (n_tot))
call hepmc_event_particle_iterator_reset (it)
do i = 1, n_tot
barcode(i) = hepmc_particle_get_barcode &
(hepmc_event_particle_iterator_get (it))
call hepmc_event_particle_iterator_advance (it)
end do
allocate (particle_set%prt (n_tot))
call hepmc_event_particle_iterator_reset (it)
do i = 1, n_tot
prt = hepmc_event_particle_iterator_get (it)
call particle_from_hepmc_particle (particle_set%prt(i), &
prt, model, fallback_model, polarization, barcode)
call hepmc_event_particle_iterator_advance (it)
end do
call hepmc_event_particle_iterator_final (it)
v = hepmc_event_get_signal_process_vertex (evt)
if (hepmc_vertex_is_valid (v)) then
call hepmc_vertex_particle_in_iterator_init (v_it, v)
do while (hepmc_vertex_particle_in_iterator_is_valid (v_it))
prt = hepmc_vertex_particle_in_iterator_get (v_it)
bc = hepmc_particle_get_barcode &
(hepmc_vertex_particle_in_iterator_get (v_it))
do i = 1, size(barcode)
if (bc == barcode(i)) &
call particle_set%prt(i)%set_status (PRT_INCOMING)
end do
call hepmc_vertex_particle_in_iterator_advance (v_it)
end do
call hepmc_vertex_particle_in_iterator_final (v_it)
end if
do i = 1, n_tot
if (particle_set%prt(i)%get_status () == PRT_VIRTUAL &
.and. particle_set%prt(i)%get_n_children () == 0) &
call particle_set%prt(i)%set_status (PRT_OUTGOING)
end do
particle_set%n_tot = n_tot
particle_set%n_beam = &
count (particle_set%prt%get_status () == PRT_BEAM)
particle_set%n_in = &
count (particle_set%prt%get_status () == PRT_INCOMING)
particle_set%n_out = &
count (particle_set%prt%get_status () == PRT_OUTGOING)
particle_set%n_vir = &
particle_set%n_tot - particle_set%n_in - particle_set%n_out
end subroutine hepmc_event_to_particle_set
@ %def hepmc_event_to_particle_set
@ Fill a WHIZARD event from a HepMC event record. In HepMC the weights
are in a weight container. If the size of this container is larger than
one, it is ambiguous to assign the event a specific weight. For now we
only allow to read in unweighted events.
<<HEP events: public>>=
public :: hepmc_to_event
<<HEP events: procedures>>=
subroutine hepmc_to_event &
(event, hepmc_event, fallback_model, process_index, &
recover_beams, use_alpha_s, use_scale)
class(generic_event_t), intent(inout), target :: event
type(hepmc_event_t), intent(inout) :: hepmc_event
class(model_data_t), intent(in), target :: fallback_model
integer, intent(out), optional :: process_index
logical, intent(in), optional :: recover_beams
logical, intent(in), optional :: use_alpha_s
logical, intent(in), optional :: use_scale
class(model_data_t), pointer :: model
real(default) :: scale, alpha_qcd
type(particle_set_t) :: particle_set
model => event%get_model_ptr ()
call event%set_index (hepmc_event_get_event_index (hepmc_event))
call hepmc_event_to_particle_set (particle_set, &
hepmc_event, model, fallback_model, PRT_DEFINITE_HELICITY)
call event%set_hard_particle_set (particle_set)
call particle_set%final ()
call event%set_weight_ref (1._default)
alpha_qcd = hepmc_event_get_alpha_qcd (hepmc_event)
scale = hepmc_event_get_scale (hepmc_event)
if (present (use_alpha_s)) then
if (use_alpha_s .and. alpha_qcd > 0) &
call event%set_alpha_qcd_forced (alpha_qcd)
end if
if (present (use_scale)) then
if (use_scale .and. scale > 0) &
call event%set_scale_forced (scale)
end if
end subroutine hepmc_to_event
@ %def hepmc_to_event
@
\subsubsection{LCIO event format}
The master output function fills a LCIO event object that is
already initialized, but has no particles in it.
In contrast to HepMC in LCIO there are no vertices (except for tracker
and other detector specifications). So we assign first all incoming
particles and then all outgoing particles to LCIO particle types.
Particles which have neither parent nor children entries (this
should not happen) are dropped. Finally, we insert the beam particles.
If there are none, use the incoming particles instead.
Transform a particle into a [[lcio_particle]] object, including
color and polarization. The LCIO status is equivalent to the HepMC
status, in particular: 0 = null entry, 1 = physical particle, 2 =
decayed/fragmented SM hadron, tau or muon, 3 = other unphysical particle
entry, 4 = incoming particles, 11 = intermediate resonance such as squarks.
The use of 11 for intermediate resonances is as done by HERWIG, see
http://herwig.hepforge.org/trac/wiki/FaQs.
A beam-remnant particle (e.g., ISR photon) that has no children is
tagged as outgoing, otherwise unphysical.
<<HEP events: public>>=
public :: particle_to_lcio
<<HEP events: procedures>>=
subroutine particle_to_lcio (prt, lprt)
type(particle_t), intent(in) :: prt
type(lcio_particle_t), intent(out) :: lprt
integer :: lcio_status
type(vector4_t) :: vtx
select case (prt%get_status ())
case (PRT_UNDEFINED)
lcio_status = 0
case (PRT_OUTGOING)
lcio_status = 1
case (PRT_BEAM_REMNANT)
if (prt%get_n_children () == 0) then
lcio_status = 1
else
lcio_status = 3
end if
case (PRT_BEAM)
lcio_status = 4
case (PRT_RESONANT)
lcio_status = 2
case default
lcio_status = 3
end select
call lcio_particle_init (lprt, &
prt%get_momentum (), &
prt%get_pdg (), &
prt%flv%get_charge (), &
lcio_status)
call lcio_particle_set_color (lprt, prt%get_color ())
vtx = prt%get_vertex ()
call lcio_particle_set_vtx (lprt, space_part (vtx))
call lcio_particle_set_t (lprt, vtx%p(0))
select case (prt%get_polarization_status ())
case (PRT_DEFINITE_HELICITY)
call lcio_polarization_init (lprt, prt%get_helicity ())
case (PRT_GENERIC_POLARIZATION)
call lcio_polarization_init (lprt, prt%get_polarization ())
end select
end subroutine particle_to_lcio
@ %def particle_to_lcio
@
@ Initialize a particle from a LCIO particle object. The model is
necessary for making a fully qualified flavor component.
<<HEP events: public>>=
public :: particle_from_lcio_particle
<<HEP events: procedures>>=
subroutine particle_from_lcio_particle &
(prt, lprt, model, daughters, parents, polarization)
type(particle_t), intent(out) :: prt
type(lcio_particle_t), intent(in) :: lprt
type(model_data_t), intent(in), target :: model
integer, dimension(:), intent(in) :: daughters, parents
type(vector4_t) :: vtx4
type(flavor_t) :: flv
type(color_t) :: col
type(helicity_t) :: hel
type(polarization_t) :: pol
integer, intent(in) :: polarization
select case (lcio_particle_get_status (lprt))
case (1); call prt%set_status (PRT_OUTGOING)
case (2); call prt%set_status (PRT_RESONANT)
case (3); call prt%set_status (PRT_VIRTUAL)
end select
call flv%init (lcio_particle_get_pdg (lprt), model)
call col%init (lcio_particle_get_flow (lprt))
if (flv%is_beam_remnant ()) call prt%set_status (PRT_BEAM_REMNANT)
call prt%set_flavor (flv)
call prt%set_color (col)
call prt%set_polarization (polarization)
select case (polarization)
case (PRT_DEFINITE_HELICITY)
call lcio_particle_to_hel (lprt, prt%get_flv (), hel)
call prt%set_helicity (hel)
case (PRT_GENERIC_POLARIZATION)
call lcio_particle_to_pol (lprt, prt%get_flv (), pol)
call prt%set_pol (pol)
end select
call prt%set_momentum (lcio_particle_get_momentum (lprt), &
lcio_particle_get_mass_squared (lprt))
call prt%set_parents (parents)
call prt%set_children (daughters)
if (prt%get_status () == PRT_VIRTUAL .and. size(parents) == 0) &
call prt%set_status (PRT_INCOMING)
vtx4 = vector4_moving (lcio_particle_get_time (lprt), &
lcio_particle_get_vertex (lprt))
if (vtx4 /= vector4_null) call prt%set_vertex (vtx4)
end subroutine particle_from_lcio_particle
@ %def particle_from_lcio_particle
@
<<HEP events: public>>=
public :: lcio_event_from_particle_set
<<HEP events: procedures>>=
subroutine lcio_event_from_particle_set (evt, particle_set)
type(lcio_event_t), intent(inout) :: evt
type(particle_set_t), intent(in) :: particle_set
type(lcio_particle_t), dimension(:), allocatable :: lprt
+ type(particle_set_t), target :: pset_filtered
integer, dimension(:), allocatable :: parent
integer :: n_tot, i, j, n_beam, n_parents, type, beam_count
- n_tot = particle_set%n_tot
- n_beam = count (particle_set%prt%get_status () == PRT_BEAM)
+
+ call particle_set%filter_particles ( pset_filtered, real_parents = .true. , &
+ keep_beams = .true. , keep_virtuals = .false.)
+ n_tot = pset_filtered%n_tot
+ n_beam = count (pset_filtered%prt%get_status () == PRT_BEAM)
if (n_beam == 0) then
type = PRT_INCOMING
else
type = PRT_BEAM
end if
beam_count = 0
allocate (lprt (n_tot))
do i = 1, n_tot
- call particle_to_lcio (particle_set%prt(i), lprt(i))
- n_parents = particle_set%prt(i)%get_n_parents ()
+ call particle_to_lcio (pset_filtered%prt(i), lprt(i))
+ n_parents = pset_filtered%prt(i)%get_n_parents ()
if (n_parents /= 0) then
allocate (parent (n_parents))
- parent = particle_set%prt(i)%get_parents ()
+ parent = pset_filtered%prt(i)%get_parents ()
do j = 1, n_parents
- call lcio_particle_set_parent (lprt(i), lprt(parent(j)))
+ call lcio_particle_set_parent (lprt(i), lprt(parent(j)))
end do
deallocate (parent)
end if
- if (particle_set%prt(i)%get_status () == type) then
+ if (pset_filtered%prt(i)%get_status () == type) then
beam_count = beam_count + 1
call lcio_event_set_beam &
- (evt, particle_set%prt(i)%get_pdg (), beam_count)
+ (evt, pset_filtered%prt(i)%get_pdg (), beam_count)
end if
call lcio_particle_add_to_evt_coll (lprt(i), evt)
end do
call lcio_event_add_coll (evt)
end subroutine lcio_event_from_particle_set
@ %def lcio_event_from_particle_set
@ If a particle set is initialized from a LCIO event record, we have
to specify the treatment of polarization (unpolarized or density
matrix) which is common to all particles. Correlated polarization
information is not available.
<<HEP events: public>>=
public :: lcio_event_to_particle_set
<<HEP events: procedures>>=
subroutine lcio_event_to_particle_set &
(particle_set, evt, model, fallback_model, polarization)
type(particle_set_t), intent(inout), target :: particle_set
type(lcio_event_t), intent(in) :: evt
class(model_data_t), intent(in), target :: model, fallback_model
integer, intent(in) :: polarization
type(lcio_particle_t) :: prt
integer, dimension(:), allocatable :: parents, daughters
integer :: n_tot, i, j, n_parents, n_children
n_tot = lcio_event_get_n_tot (evt)
allocate (particle_set%prt (n_tot))
do i = 1, n_tot
prt = lcio_event_get_particle (evt, i-1)
n_parents = lcio_particle_get_n_parents (prt)
n_children = lcio_particle_get_n_children (prt)
allocate (daughters (n_children))
allocate (parents (n_parents))
if (n_children > 0) then
do j = 1, n_children
daughters(j) = lcio_get_n_children (evt,i,j)
end do
end if
if (n_parents > 0) then
do j = 1, n_parents
parents(j) = lcio_get_n_parents (evt,i,j)
end do
end if
call particle_from_lcio_particle (particle_set%prt(i), prt, model, &
daughters, parents, polarization)
deallocate (daughters, parents)
end do
do i = 1, n_tot
if (particle_set%prt(i)%get_status () == PRT_VIRTUAL) then
CHECK_BEAM: do j = 1, particle_set%prt(i)%get_n_parents ()
if (particle_set%prt(j)%get_status () == PRT_BEAM) &
call particle_set%prt(i)%set_status (PRT_INCOMING)
exit CHECK_BEAM
end do CHECK_BEAM
end if
end do
particle_set%n_tot = n_tot
particle_set%n_beam = &
count (particle_set%prt%get_status () == PRT_BEAM)
particle_set%n_in = &
count (particle_set%prt%get_status () == PRT_INCOMING)
particle_set%n_out = &
count (particle_set%prt%get_status () == PRT_OUTGOING)
particle_set%n_vir = &
particle_set%n_tot - particle_set%n_in - particle_set%n_out
end subroutine lcio_event_to_particle_set
@ %def lcio_event_to_particle_set
@
<<HEP events: public>>=
public :: lcio_to_event
<<HEP events: procedures>>=
subroutine lcio_to_event &
(event, lcio_event, fallback_model, process_index, recover_beams, &
use_alpha_s, use_scale)
class(generic_event_t), intent(inout), target :: event
type(lcio_event_t), intent(inout) :: lcio_event
class(model_data_t), intent(in), target :: fallback_model
integer, intent(out), optional :: process_index
logical, intent(in), optional :: recover_beams
logical, intent(in), optional :: use_alpha_s
logical, intent(in), optional :: use_scale
class(model_data_t), pointer :: model
real(default) :: scale, alpha_qcd
type(particle_set_t) :: particle_set
model => event%get_model_ptr ()
call lcio_event_to_particle_set (particle_set, &
lcio_event, model, fallback_model, PRT_DEFINITE_HELICITY)
call event%set_hard_particle_set (particle_set)
call particle_set%final ()
alpha_qcd = lcio_event_get_alphas (lcio_event)
scale = lcio_event_get_scaleval (lcio_event)
if (present (use_alpha_s)) then
if (use_alpha_s .and. alpha_qcd > 0) &
call event%set_alpha_qcd_forced (alpha_qcd)
end if
if (present (use_scale)) then
if (use_scale .and. scale > 0) &
call event%set_scale_forced (scale)
end if
end subroutine lcio_to_event
@ %def lcio_to_event
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[hep_events_ut.f90]]>>=
<<File header>>
module hep_events_ut
use unit_tests
use hepmc_interface, only: HEPMC_IS_AVAILABLE
use hep_events_uti
<<Standard module head>>
<<HEP events: public test>>
contains
<<HEP events: test driver>>
end module hep_events_ut
@ %def hep_events_ut
@
<<[[hep_events_uti.f90]]>>=
<<File header>>
module hep_events_uti
<<Use kinds>>
<<Use strings>>
use lorentz
use flavors
use colors
use helicities
use quantum_numbers
use state_matrices, only: FM_SELECT_HELICITY, FM_FACTOR_HELICITY
use interactions
use evaluators
use model_data
use particles
use subevents
use hepmc_interface
use hep_events
<<Standard module head>>
<<HEP events: test declarations>>
contains
<<HEP events: tests>>
end module hep_events_uti
@ %def hep_events_ut
@ API: driver for the unit tests below.
<<HEP events: public test>>=
public :: hep_events_test
<<HEP events: test driver>>=
subroutine hep_events_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<HEP events: execute tests>>
end subroutine hep_events_test
@ %def particles_test
@ If [[HepMC]] is available, check the routines via [[HepMC]].
Set up a chain of production and decay and factorize the result into
particles. The process is $d\bar d \to Z \to q\bar q$.
<<HEP events: execute tests>>=
if (hepmc_is_available ()) then
call test (hep_events_1, "hep_events_1", &
"check HepMC event routines", &
u, results)
end if
<<HEP events: test declarations>>=
public :: hep_events_1
<<HEP events: tests>>=
subroutine hep_events_1 (u)
use os_interface
integer, intent(in) :: u
type(model_data_t), target :: model
type(flavor_t), dimension(3) :: flv
type(color_t), dimension(3) :: col
type(helicity_t), dimension(3) :: hel
type(quantum_numbers_t), dimension(3) :: qn
type(vector4_t), dimension(3) :: p
type(interaction_t), target :: int1, int2
type(quantum_numbers_mask_t) :: qn_mask_conn
type(evaluator_t), target :: eval
type(interaction_t), pointer :: int
type(particle_set_t) :: particle_set1, particle_set2
type(hepmc_event_t) :: hepmc_event
type(hepmc_iostream_t) :: iostream
real(default) :: cross_section, error, weight
logical :: ok
write (u, "(A)") "* Test output: HEP events"
write (u, "(A)") "* Purpose: test HepMC event routines"
write (u, "(A)")
write (u, "(A)") "* Reading model file"
call model%init_sm_test ()
write (u, "(A)")
write (u, "(A)") "* Initializing production process"
call int1%basic_init (2, 0, 1, set_relations=.true.)
call flv%init ([1, -1, 23], model)
call col%init_col_acl ([0, 0, 0], [0, 0, 0])
call hel(3)%init ( 1, 1)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0.25_default, 0._default))
call hel(3)%init ( 1,-1)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0._default, 0.25_default))
call hel(3)%init (-1, 1)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0._default,-0.25_default))
call hel(3)%init (-1,-1)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0.25_default, 0._default))
call hel(3)%init ( 0, 0)
call qn%init (flv, col, hel)
call int1%add_state (qn, value=(0.5_default, 0._default))
call int1%freeze ()
p(1) = vector4_moving (45._default, 45._default, 3)
p(2) = vector4_moving (45._default,-45._default, 3)
p(3) = p(1) + p(2)
call int1%set_momenta (p)
write (u, "(A)")
write (u, "(A)") "* Setup decay process"
call int2%basic_init (1, 0, 2, set_relations=.true.)
call flv%init ([23, 1, -1], model)
call col%init_col_acl ([0, 501, 0], [0, 0, 501])
call hel%init ([1, 1, 1], [1, 1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(1._default, 0._default))
call hel%init ([1, 1, 1], [-1,-1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(0._default, 0.1_default))
call hel%init ([-1,-1,-1], [1, 1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(0._default,-0.1_default))
call hel%init ([-1,-1,-1], [-1,-1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(1._default, 0._default))
call hel%init ([0, 1,-1], [0, 1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(4._default, 0._default))
call hel%init ([0,-1, 1], [0, 1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(2._default, 0._default))
call hel%init ([0, 1,-1], [0,-1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(2._default, 0._default))
call hel%init ([0,-1, 1], [0,-1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(4._default, 0._default))
call flv%init ([23, 2, -2], model)
call hel%init ([0, 1,-1], [0, 1,-1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(0.5_default, 0._default))
call hel%init ([0,-1, 1], [0,-1, 1])
call qn%init (flv, col, hel)
call int2%add_state (qn, value=(0.5_default, 0._default))
call int2%freeze ()
p(2) = vector4_moving (45._default, 45._default, 2)
p(3) = vector4_moving (45._default,-45._default, 2)
call int2%set_momenta (p)
call int2%set_source_link (1, int1, 3)
call int1%basic_write (u)
call int2%basic_write (u)
write (u, "(A)")
write (u, "(A)") "* Concatenate production and decay"
call eval%init_product (int1, int2, qn_mask_conn, &
connections_are_resonant=.true.)
call eval%receive_momenta ()
call eval%evaluate ()
call eval%write (u)
write (u, "(A)")
write (u, "(A)") "* Factorize as subevent (complete, polarized)"
write (u, "(A)")
int => eval%interaction_t
call particle_set1%init &
(ok, int, int, FM_FACTOR_HELICITY, &
[0.2_default, 0.2_default], .false., .true.)
call particle_set1%write (u)
write (u, "(A)")
write (u, "(A)") "* Factorize as subevent (in/out only, selected helicity)"
write (u, "(A)")
int => eval%interaction_t
call particle_set2%init &
(ok, int, int, FM_SELECT_HELICITY, &
[0.9_default, 0.9_default], .false., .false.)
call particle_set2%write (u)
call particle_set2%final ()
write (u, "(A)")
write (u, "(A)") "* Factorize as subevent (complete, selected helicity)"
write (u, "(A)")
int => eval%interaction_t
call particle_set2%init &
(ok, int, int, FM_SELECT_HELICITY, &
[0.7_default, 0.7_default], .false., .true.)
call particle_set2%write (u)
write (u, "(A)")
write (u, "(A)") "* Transfer particle_set to HepMC, print, and output to"
write (u, "(A)") " hep_events.hepmc.dat"
write (u, "(A)")
cross_section = 42.0_default
error = 17.0_default
weight = 1.0_default
call hepmc_event_init (hepmc_event, 11, 127)
call hepmc_event_from_particle_set (hepmc_event, particle_set2, &
cross_section, error)
call hepmc_event_add_weight (hepmc_event, weight)
call hepmc_event_print (hepmc_event)
call hepmc_iostream_open_out &
(iostream , var_str ("hep_events.hepmc.dat"))
call hepmc_iostream_write_event (iostream, hepmc_event)
call hepmc_iostream_close (iostream)
write (u, "(A)")
write (u, "(A)") "* Recover from HepMC file"
write (u, "(A)")
call particle_set2%final ()
call hepmc_event_final (hepmc_event)
call hepmc_event_init (hepmc_event)
call hepmc_iostream_open_in &
(iostream , var_str ("hep_events.hepmc.dat"))
call hepmc_iostream_read_event (iostream, hepmc_event, ok)
call hepmc_iostream_close (iostream)
call hepmc_event_to_particle_set (particle_set2, &
hepmc_event, model, model, PRT_DEFINITE_HELICITY)
call particle_set2%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call particle_set1%final ()
call particle_set2%final ()
call eval%final ()
call int1%final ()
call int2%final ()
call hepmc_event_final (hepmc_event)
call model%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: hep_events_1"
end subroutine hep_events_1
@
@ %def hep_events_1
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{LHEF Input/Output}
The LHEF event record is standardized. It is an ASCII format. We try
our best at using it for both input and output.
<<[[eio_lhef.f90]]>>=
<<File header>>
module eio_lhef
<<Use kinds>>
<<Use strings>>
use io_units
use string_utils
use numeric_utils
use diagnostics
use os_interface
use xml
use event_base
use eio_data
use eio_base
use hep_common
use hep_events
<<Standard module head>>
<<EIO LHEF: public>>
<<EIO LHEF: types>>
contains
<<EIO LHEF: procedures>>
end module eio_lhef
@ %def eio_lhef
@
\subsection{Type}
With sufficient confidence that it will always be three characters, we
can store the version string with a default value.
<<EIO LHEF: public>>=
public :: eio_lhef_t
<<EIO LHEF: types>>=
type, extends (eio_t) :: eio_lhef_t
logical :: writing = .false.
logical :: reading = .false.
integer :: unit = 0
type(event_sample_data_t) :: data
type(cstream_t) :: cstream
character(3) :: version = "1.0"
logical :: keep_beams = .false.
logical :: keep_remnants = .true.
logical :: keep_virtuals = .false.
logical :: recover_beams = .true.
logical :: unweighted = .true.
logical :: write_sqme_ref = .false.
logical :: write_sqme_prc = .false.
logical :: write_sqme_alt = .false.
logical :: use_alphas_from_file = .false.
logical :: use_scale_from_file = .false.
integer :: n_alt = 0
integer, dimension(:), allocatable :: proc_num_id
integer :: i_weight_sqme = 0
type(xml_tag_t) :: tag_lhef, tag_head, tag_init, tag_event
type(xml_tag_t), allocatable :: tag_gen_n, tag_gen_v
type(xml_tag_t), allocatable :: tag_generator, tag_xsecinfo
type(xml_tag_t), allocatable :: tag_sqme_ref, tag_sqme_prc
type(xml_tag_t), dimension(:), allocatable :: tag_sqme_alt, tag_wgts_alt
type(xml_tag_t), allocatable :: tag_weight, tag_weightinfo, tag_weights
contains
<<EIO LHEF: eio lhef: TBP>>
end type eio_lhef_t
@ %def eio_lhef_t
@
\subsection{Specific Methods}
Set parameters that are specifically used with LHEF.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: set_parameters => eio_lhef_set_parameters
<<EIO LHEF: procedures>>=
subroutine eio_lhef_set_parameters (eio, &
keep_beams, keep_remnants, recover_beams, &
use_alphas_from_file, use_scale_from_file, &
version, extension, write_sqme_ref, write_sqme_prc, write_sqme_alt)
class(eio_lhef_t), intent(inout) :: eio
logical, intent(in), optional :: keep_beams
logical, intent(in), optional :: keep_remnants
logical, intent(in), optional :: recover_beams
logical, intent(in), optional :: use_alphas_from_file
logical, intent(in), optional :: use_scale_from_file
character(*), intent(in), optional :: version
type(string_t), intent(in), optional :: extension
logical, intent(in), optional :: write_sqme_ref
logical, intent(in), optional :: write_sqme_prc
logical, intent(in), optional :: write_sqme_alt
if (present (keep_beams)) eio%keep_beams = keep_beams
if (present (keep_remnants)) eio%keep_remnants = keep_remnants
if (present (recover_beams)) eio%recover_beams = recover_beams
if (present (use_alphas_from_file)) &
eio%use_alphas_from_file = use_alphas_from_file
if (present (use_scale_from_file)) &
eio%use_scale_from_file = use_scale_from_file
if (present (version)) then
select case (version)
case ("1.0", "2.0", "3.0")
eio%version = version
case default
call msg_error ("LHEF version " // version &
// " is not supported. Inserting 2.0")
eio%version = "2.0"
end select
end if
if (present (extension)) then
eio%extension = extension
else
eio%extension = "lhe"
end if
if (present (write_sqme_ref)) eio%write_sqme_ref = write_sqme_ref
if (present (write_sqme_prc)) eio%write_sqme_prc = write_sqme_prc
if (present (write_sqme_alt)) eio%write_sqme_alt = write_sqme_alt
end subroutine eio_lhef_set_parameters
@ %def eio_lhef_set_parameters
@
\subsection{Common Methods}
Output. This is not the actual event format, but a readable account
of the current object status.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: write => eio_lhef_write
<<EIO LHEF: procedures>>=
subroutine eio_lhef_write (object, unit)
class(eio_lhef_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A)") "LHEF event stream:"
if (object%writing) then
write (u, "(3x,A,A)") "Writing to file = ", char (object%filename)
else if (object%reading) then
write (u, "(3x,A,A)") "Reading from file = ", char (object%filename)
else
write (u, "(3x,A)") "[closed]"
end if
write (u, "(3x,A,L1)") "Keep beams = ", object%keep_beams
write (u, "(3x,A,L1)") "Keep remnants = ", object%keep_remnants
write (u, "(3x,A,L1)") "Recover beams = ", object%recover_beams
write (u, "(3x,A,L1)") "Alpha_s from file = ", &
object%use_alphas_from_file
write (u, "(3x,A,L1)") "Scale from file = ", &
object%use_scale_from_file
write (u, "(3x,A,A)") "Version = ", object%version
write (u, "(3x,A,A,A)") "File extension = '", &
char (object%extension), "'"
if (allocated (object%proc_num_id)) then
write (u, "(3x,A)") "Numerical process IDs:"
do i = 1, size (object%proc_num_id)
write (u, "(5x,I0,': ',I0)") i, object%proc_num_id(i)
end do
end if
end subroutine eio_lhef_write
@ %def eio_lhef_write
@ Finalizer: close any open file.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: final => eio_lhef_final
<<EIO LHEF: procedures>>=
subroutine eio_lhef_final (object)
class(eio_lhef_t), intent(inout) :: object
if (allocated (object%proc_num_id)) deallocate (object%proc_num_id)
if (object%writing) then
write (msg_buffer, "(A,A,A)") "Events: closing LHEF file '", &
char (object%filename), "'"
call msg_message ()
call object%write_footer ()
close (object%unit)
object%writing = .false.
else if (object%reading) then
write (msg_buffer, "(A,A,A)") "Events: closing LHEF file '", &
char (object%filename), "'"
call msg_message ()
call object%cstream%final ()
close (object%unit)
object%reading = .false.
end if
end subroutine eio_lhef_final
@ %def eio_lhef_final
@ Common initialization for input and output.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: common_init => eio_lhef_common_init
<<EIO LHEF: procedures>>=
subroutine eio_lhef_common_init (eio, sample, data, extension)
class(eio_lhef_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
if (.not. present (data)) &
call msg_bug ("LHEF initialization: missing data")
eio%data = data
if (data%n_beam /= 2) &
call msg_fatal ("LHEF: defined for scattering processes only")
eio%unweighted = data%unweighted
if (eio%unweighted) then
select case (data%norm_mode)
case (NORM_UNIT)
case default; call msg_fatal &
("LHEF: normalization for unweighted events must be '1'")
end select
else
select case (data%norm_mode)
case (NORM_SIGMA)
case default; call msg_fatal &
("LHEF: normalization for weighted events must be 'sigma'")
end select
end if
eio%n_alt = data%n_alt
eio%sample = sample
if (present (extension)) then
eio%extension = extension
end if
call eio%set_filename ()
eio%unit = free_unit ()
call eio%init_tags (data)
allocate (eio%proc_num_id (data%n_proc), source = data%proc_num_id)
end subroutine eio_lhef_common_init
@ %def eio_lhef_common_init
@ Initialize the tag objects. Some tags depend on the LHEF
version. In particular, the tags that in LHEF 2.0 identify
individual weights by name in each event block, in LHEF 3.0 are
replaced by info tags in the init block and a single \texttt{weights}
tag in the event block. The name attributes of those tags
are specific for \whizard.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: init_tags => eio_lhef_init_tags
<<EIO LHEF: procedures>>=
subroutine eio_lhef_init_tags (eio, data)
class(eio_lhef_t), intent(inout) :: eio
type(event_sample_data_t), intent(in) :: data
real(default), parameter :: pb_per_fb = 1.e-3_default
integer :: i
call eio%tag_lhef%init ( &
var_str ("LesHouchesEvents"), &
[xml_attribute (var_str ("version"), var_str (eio%version))], &
.true.)
call eio%tag_head%init ( &
var_str ("header"), &
.true.)
call eio%tag_init%init ( &
var_str ("init"), &
.true.)
call eio%tag_event%init (var_str ("event"), &
.true.)
select case (eio%version)
case ("1.0")
allocate (eio%tag_gen_n)
call eio%tag_gen_n%init ( &
var_str ("generator_name"), &
.true.)
allocate (eio%tag_gen_v)
call eio%tag_gen_v%init ( &
var_str ("generator_version"), &
.true.)
end select
select case (eio%version)
case ("2.0", "3.0")
allocate (eio%tag_generator)
call eio%tag_generator%init ( &
var_str ("generator"), &
[xml_attribute (var_str ("version"), var_str ("<<Version>>"))], &
.true.)
allocate (eio%tag_xsecinfo)
call eio%tag_xsecinfo%init ( &
var_str ("xsecinfo"), &
[xml_attribute (var_str ("neve"), str (data%n_evt)), &
xml_attribute (var_str ("totxsec"), &
str (data%total_cross_section * pb_per_fb))])
end select
select case (eio%version)
case ("2.0")
allocate (eio%tag_weight)
call eio%tag_weight%init (var_str ("weight"), &
[xml_attribute (var_str ("name"))])
if (eio%write_sqme_ref) then
allocate (eio%tag_sqme_ref)
call eio%tag_sqme_ref%init (var_str ("weight"), &
[xml_attribute (var_str ("name"), var_str ("sqme_ref"))], &
.true.)
end if
if (eio%write_sqme_prc) then
allocate (eio%tag_sqme_prc)
call eio%tag_sqme_prc%init (var_str ("weight"), &
[xml_attribute (var_str ("name"), var_str ("sqme_prc"))], &
.true.)
end if
if (eio%n_alt > 0) then
if (eio%write_sqme_alt) then
allocate (eio%tag_sqme_alt (1))
call eio%tag_sqme_alt(1)%init (var_str ("weight"), &
[xml_attribute (var_str ("name"), var_str ("sqme_alt"))], &
.true.)
end if
allocate (eio%tag_wgts_alt (1))
call eio%tag_wgts_alt(1)%init (var_str ("weight"), &
[xml_attribute (var_str ("name"), var_str ("wgts_alt"))], &
.true.)
end if
case ("3.0")
if (eio%write_sqme_ref) then
allocate (eio%tag_sqme_ref)
call eio%tag_sqme_ref%init (var_str ("weightinfo"), &
[xml_attribute (var_str ("name"), var_str ("sqme_ref"))])
end if
if (eio%write_sqme_prc) then
allocate (eio%tag_sqme_prc)
call eio%tag_sqme_prc%init (var_str ("weightinfo"), &
[xml_attribute (var_str ("name"), var_str ("sqme_prc"))])
end if
if (eio%n_alt > 0) then
if (eio%write_sqme_alt) then
allocate (eio%tag_sqme_alt (eio%n_alt))
do i = 1, eio%n_alt
call eio%tag_sqme_alt(i)%init (var_str ("weightinfo"), &
[xml_attribute (var_str ("name"), &
var_str ("sqme_alt") // str (i))])
end do
end if
allocate (eio%tag_wgts_alt (eio%n_alt))
do i = 1, eio%n_alt
call eio%tag_wgts_alt(i)%init (var_str ("weightinfo"), &
[xml_attribute (var_str ("name"), &
var_str ("wgts_alt") // str (i))])
end do
end if
allocate (eio%tag_weightinfo)
call eio%tag_weightinfo%init (var_str ("weightinfo"), &
[xml_attribute (var_str ("name"))])
allocate (eio%tag_weights)
call eio%tag_weights%init (var_str ("weights"), .true.)
end select
end subroutine eio_lhef_init_tags
@ %def eio_lhef_init_tags
@ Initialize event writing.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: init_out => eio_lhef_init_out
<<EIO LHEF: procedures>>=
subroutine eio_lhef_init_out (eio, sample, data, success, extension)
class(eio_lhef_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
integer :: u, i
call eio%set_splitting (data)
call eio%common_init (sample, data, extension)
write (msg_buffer, "(A,A,A)") "Events: writing to LHEF file '", &
char (eio%filename), "'"
call msg_message ()
eio%writing = .true.
u = eio%unit
open (u, file = char (eio%filename), &
action = "write", status = "replace")
call eio%write_header ()
call heprup_init &
(data%pdg_beam, &
data%energy_beam, &
n_processes = data%n_proc, &
unweighted = data%unweighted, &
negative_weights = data%negative_weights)
do i = 1, data%n_proc
call heprup_set_process_parameters (i = i, &
process_id = data%proc_num_id(i), &
cross_section = data%cross_section(i), &
error = data%error(i))
end do
call eio%tag_init%write (u); write (u, *)
call heprup_write_lhef (u)
select case (eio%version)
case ("2.0"); call eio%write_init_20 (data)
case ("3.0"); call eio%write_init_30 (data)
end select
call eio%tag_init%close (u); write (u, *)
if (present (success)) success = .true.
end subroutine eio_lhef_init_out
@ %def eio_lhef_init_out
@ Initialize event reading. First read the LHEF tag and version, then
read the header and skip over its contents, then read the init block.
(We require the opening and closing tags of the init block to be placed
on separate lines without extra stuff.)
For input, we do not (yet?) support split event files.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: init_in => eio_lhef_init_in
<<EIO LHEF: procedures>>=
subroutine eio_lhef_init_in (eio, sample, data, success, extension)
class(eio_lhef_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
logical :: exist, ok, closing
type(event_sample_data_t) :: data_file
type(string_t) :: string
integer :: u
eio%split = .false.
call eio%common_init (sample, data, extension)
write (msg_buffer, "(A,A,A)") "Events: reading from LHEF file '", &
char (eio%filename), "'"
call msg_message ()
inquire (file = char (eio%filename), exist = exist)
if (.not. exist) call msg_fatal ("Events: LHEF file not found.")
eio%reading = .true.
u = eio%unit
open (u, file = char (eio%filename), &
action = "read", status = "old")
call eio%cstream%init (u)
call eio%read_header ()
call eio%tag_init%read (eio%cstream, ok)
if (.not. ok) call err_init
select case (eio%version)
case ("1.0"); call eio%read_init_10 (data_file)
call eio%tag_init%read_content (eio%cstream, string, closing)
if (string /= "" .or. .not. closing) call err_init
case ("2.0"); call eio%read_init_20 (data_file)
case ("3.0"); call eio%read_init_30 (data_file)
end select
call eio%merge_data (data, data_file)
if (present (success)) success = .true.
contains
subroutine err_init
call msg_fatal ("LHEF: syntax error in init tag")
end subroutine err_init
end subroutine eio_lhef_init_in
@ %def eio_lhef_init_in
@ Merge event sample data: we can check the data in the file against
our assumptions and set or reset parameters.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: merge_data => eio_merge_data
<<EIO LHEF: procedures>>=
subroutine eio_merge_data (eio, data, data_file)
class(eio_lhef_t), intent(inout) :: eio
type(event_sample_data_t), intent(inout) :: data
type(event_sample_data_t), intent(in) :: data_file
real, parameter :: tolerance = 1000 * epsilon (1._default)
if (data%unweighted .neqv. data_file%unweighted) call err_weights
if (data%negative_weights .neqv. data_file%negative_weights) &
call err_weights
if (data%norm_mode /= data_file%norm_mode) call err_norm
if (data%n_beam /= data_file%n_beam) call err_beams
if (any (data%pdg_beam /= data_file%pdg_beam)) call err_beams
if (any (abs ((data%energy_beam - data_file%energy_beam)) &
> (data%energy_beam + data_file%energy_beam) * tolerance)) &
call err_beams
if (data%n_proc /= data_file%n_proc) call err_proc
if (any (data%proc_num_id /= data_file%proc_num_id)) call err_proc
where (data%cross_section == 0)
data%cross_section = data_file%cross_section
data%error = data_file%error
end where
data%total_cross_section = sum (data%cross_section)
if (data_file%n_evt > 0) then
if (data%n_evt > 0 .and. data_file%n_evt /= data%n_evt) call err_n_evt
data%n_evt = data_file%n_evt
end if
contains
subroutine err_weights
call msg_fatal ("LHEF: mismatch in event weight properties")
end subroutine err_weights
subroutine err_norm
call msg_fatal ("LHEF: mismatch in event normalization")
end subroutine err_norm
subroutine err_beams
call msg_fatal ("LHEF: mismatch in beam properties")
end subroutine err_beams
subroutine err_proc
call msg_fatal ("LHEF: mismatch in process definitions")
end subroutine err_proc
subroutine err_n_evt
call msg_error ("LHEF: mismatch in specified number of events (ignored)")
end subroutine err_n_evt
end subroutine eio_merge_data
@ %def eio_merge_data
@ Switch from input to output: reopen the file for reading.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: switch_inout => eio_lhef_switch_inout
<<EIO LHEF: procedures>>=
subroutine eio_lhef_switch_inout (eio, success)
class(eio_lhef_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("LHEF: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_lhef_switch_inout
@ %def eio_lhef_switch_inout
@ Split event file: increment the counter, close the current file, open a new
one. If the file needs a header, repeat it for the new file. (We assume that
the common block contents are still intact.)
<<EIO LHEF: eio lhef: TBP>>=
procedure :: split_out => eio_lhef_split_out
<<EIO LHEF: procedures>>=
subroutine eio_lhef_split_out (eio)
class(eio_lhef_t), intent(inout) :: eio
integer :: u
if (eio%split) then
eio%split_index = eio%split_index + 1
call eio%set_filename ()
write (msg_buffer, "(A,A,A)") "Events: writing to LHEF file '", &
char (eio%filename), "'"
call msg_message ()
call eio%write_footer ()
u = eio%unit
close (u)
open (u, file = char (eio%filename), &
action = "write", status = "replace")
call eio%write_header ()
call eio%tag_init%write (u); write (u, *)
call heprup_write_lhef (u)
select case (eio%version)
case ("2.0"); call eio%write_init_20 (eio%data)
case ("3.0"); call eio%write_init_30 (eio%data)
end select
call eio%tag_init%close (u); write (u, *)
end if
end subroutine eio_lhef_split_out
@ %def eio_lhef_split_out
@ Output an event. Write first the event indices, then weight and
squared matrix element, then the particle set.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: output => eio_lhef_output
<<EIO LHEF: procedures>>=
subroutine eio_lhef_output (eio, event, i_prc, reading, passed, pacify)
class(eio_lhef_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
integer :: u
u = given_output_unit (eio%unit); if (u < 0) return
if (present (passed)) then
if (.not. passed) return
end if
if (eio%writing) then
call hepeup_from_event (event, &
process_index = eio%proc_num_id (i_prc), &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants)
write (u, '(A)') "<event>"
call hepeup_write_lhef (eio%unit)
select case (eio%version)
case ("2.0"); call eio%write_event_20 (event)
case ("3.0"); call eio%write_event_30 (event)
end select
write (u, '(A)') "</event>"
else
call eio%write ()
call msg_fatal ("LHEF file is not open for writing")
end if
end subroutine eio_lhef_output
@ %def eio_lhef_output
@ Input an event. Upon input of [[i_prc]], we can just read in the
whole HEPEUP common block. These data are known to come first. The
[[i_prc]] value can be deduced from the IDPRUP value by a table
lookup.
Reading the common block bypasses the [[cstream]] which accesses the
input unit. This is consistent with the LHEF specification. After
the common-block data have been swallowed, we can resume reading from
stream.
We don't catch actual I/O errors. However, we return a negative value in
[[iostat]] if we reached the terminating [[</LesHouchesEvents>]] tag.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: input_i_prc => eio_lhef_input_i_prc
<<EIO LHEF: procedures>>=
subroutine eio_lhef_input_i_prc (eio, i_prc, iostat)
class(eio_lhef_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
integer :: i, proc_num_id
type(string_t) :: s
logical :: ok
iostat = 0
call eio%tag_lhef%read_content (eio%cstream, s, ok)
if (ok) then
if (s == "") then
iostat = -1
else
call err_close
end if
return
else
call eio%cstream%revert_record (s)
end if
call eio%tag_event%read (eio%cstream, ok)
if (.not. ok) then
call err_evt1
return
end if
call hepeup_read_lhef (eio%unit)
call hepeup_get_event_parameters (proc_id = proc_num_id)
i_prc = 0
FIND_I_PRC: do i = 1, size (eio%proc_num_id)
if (eio%proc_num_id(i) == proc_num_id) then
i_prc = i
exit FIND_I_PRC
end if
end do FIND_I_PRC
if (i_prc == 0) call err_index
contains
subroutine err_close
call msg_error ("LHEF: reading events: syntax error in closing tag")
iostat = 1
end subroutine
subroutine err_evt1
call msg_error ("LHEF: reading events: invalid event tag, &
&aborting read")
iostat = 2
end subroutine err_evt1
subroutine err_index
call msg_error ("LHEF: reading events: undefined process ID " &
// char (str (proc_num_id)) // ", aborting read")
iostat = 3
end subroutine err_index
end subroutine eio_lhef_input_i_prc
@ %def eio_lhef_input_i_prc
@ Since we have already read the event information from file, this
input routine can transfer the common-block contents to the event
record. Also, we read any further information in the event record.
Since LHEF doesn't give this information, we must assume that the MCI
group, term, and channel can all be safely set to 1. This works if
there is only one MCI group and term. The channel doesn't matter for
the matrix element.
The event index is incremented, as if the event was generated. The
LHEF format does not support event indices.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: input_event => eio_lhef_input_event
<<EIO LHEF: procedures>>=
subroutine eio_lhef_input_event (eio, event, iostat)
class(eio_lhef_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
type(string_t) :: s
logical :: closing
iostat = 0
call event%reset_contents ()
call event%select (1, 1, 1)
call hepeup_to_event (event, eio%fallback_model, &
recover_beams = eio%recover_beams, &
use_alpha_s = eio%use_alphas_from_file, &
use_scale = eio%use_scale_from_file)
select case (eio%version)
case ("1.0")
call eio%tag_event%read_content (eio%cstream, s, closing = closing)
if (s /= "" .or. .not. closing) call err_evt2
case ("2.0"); call eio%read_event_20 (event)
case ("3.0"); call eio%read_event_30 (event)
end select
call event%increment_index ()
contains
subroutine err_evt2
call msg_error ("LHEF: reading events: syntax error in event record, &
&aborting read")
iostat = 2
end subroutine err_evt2
end subroutine eio_lhef_input_event
@ %def eio_lhef_input_event
@
<<EIO LHEF: eio lhef: TBP>>=
procedure :: skip => eio_lhef_skip
<<EIO LHEF: procedures>>=
subroutine eio_lhef_skip (eio, iostat)
class(eio_lhef_t), intent(inout) :: eio
integer, intent(out) :: iostat
if (eio%reading) then
read (eio%unit, iostat = iostat)
else
call eio%write ()
call msg_fatal ("Raw event file is not open for reading")
end if
end subroutine eio_lhef_skip
@ %def eio_lhef_skip
@
\subsection{Les Houches Event File: header/footer}
These two routines write the header and footer for the Les Houches
Event File format (LHEF).
The current version writes no information except for the generator
name and version (v.1.0 only).
<<EIO LHEF: eio lhef: TBP>>=
procedure :: write_header => eio_lhef_write_header
procedure :: write_footer => eio_lhef_write_footer
<<EIO LHEF: procedures>>=
subroutine eio_lhef_write_header (eio)
class(eio_lhef_t), intent(in) :: eio
integer :: u
u = given_output_unit (eio%unit); if (u < 0) return
call eio%tag_lhef%write (u); write (u, *)
call eio%tag_head%write (u); write (u, *)
select case (eio%version)
case ("1.0")
write (u, "(2x)", advance = "no")
call eio%tag_gen_n%write (var_str ("WHIZARD"), u)
write (u, *)
write (u, "(2x)", advance = "no")
call eio%tag_gen_v%write (var_str ("<<Version>>"), u)
write (u, *)
end select
call eio%tag_head%close (u); write (u, *)
end subroutine eio_lhef_write_header
subroutine eio_lhef_write_footer (eio)
class(eio_lhef_t), intent(in) :: eio
integer :: u
u = given_output_unit (eio%unit); if (u < 0) return
call eio%tag_lhef%close (u)
end subroutine eio_lhef_write_footer
@ %def eio_lhef_write_header eio_lhef_write_footer
@ Reading the header just means finding the tags and ignoring any
contents. When done, we should stand just after the header tag.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: read_header => eio_lhef_read_header
<<EIO LHEF: procedures>>=
subroutine eio_lhef_read_header (eio)
class(eio_lhef_t), intent(inout) :: eio
logical :: success, closing
type(string_t) :: content
call eio%tag_lhef%read (eio%cstream, success)
if (.not. success .or. .not. eio%tag_lhef%has_content) call err_lhef
if (eio%tag_lhef%get_attribute (1) /= eio%version) call err_version
call eio%tag_head%read (eio%cstream, success)
if (.not. success) call err_header
if (eio%tag_head%has_content) then
SKIP_HEADER_CONTENT: do
call eio%tag_head%read_content (eio%cstream, content, closing)
if (closing) exit SKIP_HEADER_CONTENT
end do SKIP_HEADER_CONTENT
end if
contains
subroutine err_lhef
call msg_fatal ("LHEF: LesHouchesEvents tag absent or corrupted")
end subroutine err_lhef
subroutine err_header
call msg_fatal ("LHEF: header tag absent or corrupted")
end subroutine err_header
subroutine err_version
call msg_error ("LHEF: version mismatch: expected " &
// eio%version // ", found " &
// char (eio%tag_lhef%get_attribute (1)))
end subroutine err_version
end subroutine eio_lhef_read_header
@ %def eio_lhef_read_header
@
\subsection{Version-Specific Code: 1.0}
In version 1.0, the init tag contains just HEPRUP data. While a
[[cstream]] is connected to the input unit, we bypass it temporarily
for the purpose of reading the HEPRUP contents. This is consistent
with the LHEF standard.
This routine does not read the closing tag of the init block.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: read_init_10 => eio_lhef_read_init_10
<<EIO LHEF: procedures>>=
subroutine eio_lhef_read_init_10 (eio, data)
class(eio_lhef_t), intent(in) :: eio
type(event_sample_data_t), intent(out) :: data
integer :: n_proc, i
call heprup_read_lhef (eio%unit)
call heprup_get_run_parameters (n_processes = n_proc)
call data%init (n_proc)
data%n_beam = 2
call heprup_get_run_parameters ( &
unweighted = data%unweighted, &
negative_weights = data%negative_weights, &
beam_pdg = data%pdg_beam, &
beam_energy = data%energy_beam)
if (data%unweighted) then
data%norm_mode = NORM_UNIT
else
data%norm_mode = NORM_SIGMA
end if
do i = 1, n_proc
call heprup_get_process_parameters (i, &
process_id = data%proc_num_id(i), &
cross_section = data%cross_section(i), &
error = data%error(i))
end do
end subroutine eio_lhef_read_init_10
@ %def eio_lhef_read_init_10
@
\subsection{Version-Specific Code: 2.0}
This is the init information for the 2.0 format, after the HEPRUP
data. We have the following tags:
\begin{itemize}
\item \texttt{generator} Generator name and version.
\item \texttt{xsecinfo} Cross section and weights data. We have the
total cross section and number of events (assuming that the event
file is intact), but information on minimum and maximum weights is
not available before the file is complete. We just write the
mandatory tags. (Note that the default values of the other tags
describe a uniform unit weight, but we can determine most values
only after the sample is complete.)
\item \texttt{cutsinfo} This optional tag is too specific to represent the
possibilities of WHIZARD, so we skip it.
\item \texttt{procinfo} This optional tag is useful for giving
details of NLO calculations. Skipped.
\item \texttt{mergetype} Optional, also not applicable.
\end{itemize}
<<EIO LHEF: eio lhef: TBP>>=
procedure :: write_init_20 => eio_lhef_write_init_20
<<EIO LHEF: procedures>>=
subroutine eio_lhef_write_init_20 (eio, data)
class(eio_lhef_t), intent(in) :: eio
type(event_sample_data_t), intent(in) :: data
integer :: u
u = eio%unit
call eio%tag_generator%write (u)
write (u, "(A)", advance="no") "WHIZARD"
call eio%tag_generator%close (u); write (u, *)
call eio%tag_xsecinfo%write (u); write (u, *)
end subroutine eio_lhef_write_init_20
@ %def eio_lhef_write_init_20
@ When reading the init block, we first call the 1.0 routine that
fills HEPRUP. Then we consider the possible tags. Only the
\texttt{generator} and \texttt{xsecinfo} tags are of interest. We
skip everything else except for the closing tag.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: read_init_20 => eio_lhef_read_init_20
<<EIO LHEF: procedures>>=
subroutine eio_lhef_read_init_20 (eio, data)
class(eio_lhef_t), intent(inout) :: eio
type(event_sample_data_t), intent(out) :: data
real(default), parameter :: pb_per_fb = 1.e-3_default
type(string_t) :: content
logical :: found, closing
call eio_lhef_read_init_10 (eio, data)
SCAN_INIT_TAGS: do
call eio%tag_generator%read (eio%cstream, found)
if (found) then
if (.not. eio%tag_generator%has_content) call err_generator
call eio%tag_generator%read_content (eio%cstream, content, closing)
call msg_message ("LHEF: Event file has been generated by " &
// char (content) // " " &
// char (eio%tag_generator%get_attribute (1)))
cycle SCAN_INIT_TAGS
end if
call eio%tag_xsecinfo%read (eio%cstream, found)
if (found) then
if (eio%tag_xsecinfo%has_content) call err_xsecinfo
cycle SCAN_INIT_TAGS
end if
call eio%tag_init%read_content (eio%cstream, content, closing)
if (closing) then
if (content /= "") call err_init
exit SCAN_INIT_TAGS
end if
end do SCAN_INIT_TAGS
data%n_evt = &
read_ival (eio%tag_xsecinfo%get_attribute (1))
data%total_cross_section = &
read_rval (eio%tag_xsecinfo%get_attribute (2)) / pb_per_fb
contains
subroutine err_generator
call msg_fatal ("LHEF: invalid generator tag")
end subroutine err_generator
subroutine err_xsecinfo
call msg_fatal ("LHEF: invalid xsecinfo tag")
end subroutine err_xsecinfo
subroutine err_init
call msg_fatal ("LHEF: syntax error after init tag")
end subroutine err_init
end subroutine eio_lhef_read_init_20
@ %def eio_lhef_read_init_20
@ This is additional event-specific information for the 2.0 format,
after the HEPEUP data. We can specify weights, starting from the
master weight and adding alternative weights. The alternative weights
are collected in a common tag.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: write_event_20 => eio_lhef_write_event_20
<<EIO LHEF: procedures>>=
subroutine eio_lhef_write_event_20 (eio, event)
class(eio_lhef_t), intent(in) :: eio
class(generic_event_t), intent(in) :: event
type(string_t) :: s
integer :: i, u
u = eio%unit
if (eio%write_sqme_ref) then
s = str (event%get_sqme_ref ())
call eio%tag_sqme_ref%write (s, u); write (u, *)
end if
if (eio%write_sqme_prc) then
s = str (event%get_sqme_prc ())
call eio%tag_sqme_prc%write (s, u); write (u, *)
end if
if (eio%n_alt > 0) then
if (eio%write_sqme_alt) then
s = str (event%get_sqme_alt(1))
do i = 2, eio%n_alt
s = s // " " // str (event%get_sqme_alt(i)); write (u, *)
end do
call eio%tag_sqme_alt(1)%write (s, u)
end if
s = str (event%get_weight_alt(1))
do i = 2, eio%n_alt
s = s // " " // str (event%get_weight_alt(i)); write (u, *)
end do
call eio%tag_wgts_alt(1)%write (s, u)
end if
end subroutine eio_lhef_write_event_20
@ %def eio_lhef_write_event_20
@ Read extra event data. If there is a weight entry labeled [[sqme_prc]], we
take this as the squared matrix-element value (the new
\emph{reference} value [[sqme_ref]]). Other tags, including
tags written by the above writer, are skipped.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: read_event_20 => eio_lhef_read_event_20
<<EIO LHEF: procedures>>=
subroutine eio_lhef_read_event_20 (eio, event)
class(eio_lhef_t), intent(inout) :: eio
class(generic_event_t), intent(inout) :: event
type(string_t) :: content
logical :: found, closing
SCAN_EVENT_TAGS: do
call eio%tag_weight%read (eio%cstream, found)
if (found) then
if (.not. eio%tag_weight%has_content) call err_weight
call eio%tag_weight%read_content (eio%cstream, content, closing)
if (.not. closing) call err_weight
if (eio%tag_weight%get_attribute (1) == "sqme_prc") then
call event%set_sqme_ref (read_rval (content))
end if
cycle SCAN_EVENT_TAGS
end if
call eio%tag_event%read_content (eio%cstream, content, closing)
if (closing) then
if (content /= "") call err_event
exit SCAN_EVENT_TAGS
end if
end do SCAN_EVENT_TAGS
contains
subroutine err_weight
call msg_fatal ("LHEF: invalid weight tag in event record")
end subroutine err_weight
subroutine err_event
call msg_fatal ("LHEF: syntax error after event tag")
end subroutine err_event
end subroutine eio_lhef_read_event_20
@ %def eio_lhef_read_event_20
@
\subsection{Version-Specific Code: 3.0}
This is the init information for the 3.0 format, after the HEPRUP
data. We have the following tags:
\begin{itemize}
\item \texttt{generator} Generator name and version.
\item \texttt{xsecinfo} Cross section and weights data. We have the
total cross section and number of events (assuming that the event
file is intact), but information on minimum and maximum weights is
not available before the file is complete. We just write the
mandatory tags. (Note that the default values of the other tags
describe a uniform unit weight, but we can determine most values
only after the sample is complete.)
\item \texttt{cutsinfo} This optional tag is too specific to represent the
possibilities of WHIZARD, so we skip it.
\item \texttt{procinfo} This optional tag is useful for giving
details of NLO calculations. Skipped.
\item \texttt{weightinfo} Determine the meaning of optional weights, whose
values are given in the event record.
\end{itemize}
<<EIO LHEF: eio lhef: TBP>>=
procedure :: write_init_30 => eio_lhef_write_init_30
<<EIO LHEF: procedures>>=
subroutine eio_lhef_write_init_30 (eio, data)
class(eio_lhef_t), intent(in) :: eio
type(event_sample_data_t), intent(in) :: data
integer :: u, i
u = given_output_unit (eio%unit)
call eio%tag_generator%write (u)
write (u, "(A)", advance="no") "WHIZARD"
call eiO%tag_generator%close (u); write (u, *)
call eio%tag_xsecinfo%write (u); write (u, *)
if (eio%write_sqme_ref) then
call eio%tag_sqme_ref%write (u); write (u, *)
end if
if (eio%write_sqme_prc) then
call eio%tag_sqme_prc%write (u); write (u, *)
end if
if (eio%write_sqme_alt) then
do i = 1, eio%n_alt
call eio%tag_sqme_alt(i)%write (u); write (u, *)
end do
end if
do i = 1, eio%n_alt
call eio%tag_wgts_alt(i)%write (u); write (u, *)
end do
end subroutine eio_lhef_write_init_30
@ %def eio_lhef_write_init_30
@ When reading the init block, we first call the 1.0 routine that
fills HEPRUP. Then we consider the possible tags. Only the
\texttt{generator} and \texttt{xsecinfo} tags are of interest. We
skip everything else except for the closing tag.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: read_init_30 => eio_lhef_read_init_30
<<EIO LHEF: procedures>>=
subroutine eio_lhef_read_init_30 (eio, data)
class(eio_lhef_t), intent(inout) :: eio
type(event_sample_data_t), intent(out) :: data
real(default), parameter :: pb_per_fb = 1.e-3_default
type(string_t) :: content
logical :: found, closing
integer :: n_weightinfo
call eio_lhef_read_init_10 (eio, data)
n_weightinfo = 0
eio%i_weight_sqme = 0
SCAN_INIT_TAGS: do
call eio%tag_generator%read (eio%cstream, found)
if (found) then
if (.not. eio%tag_generator%has_content) call err_generator
call eio%tag_generator%read_content (eio%cstream, content, closing)
call msg_message ("LHEF: Event file has been generated by " &
// char (content) // " " &
// char (eio%tag_generator%get_attribute (1)))
cycle SCAN_INIT_TAGS
end if
call eio%tag_xsecinfo%read (eio%cstream, found)
if (found) then
if (eio%tag_xsecinfo%has_content) call err_xsecinfo
cycle SCAN_INIT_TAGS
end if
call eio%tag_weightinfo%read (eio%cstream, found)
if (found) then
if (eio%tag_weightinfo%has_content) call err_xsecinfo
n_weightinfo = n_weightinfo + 1
if (eio%tag_weightinfo%get_attribute (1) == "sqme_prc") then
eio%i_weight_sqme = n_weightinfo
end if
cycle SCAN_INIT_TAGS
end if
call eio%tag_init%read_content (eio%cstream, content, closing)
if (closing) then
if (content /= "") call err_init
exit SCAN_INIT_TAGS
end if
end do SCAN_INIT_TAGS
data%n_evt = &
read_ival (eio%tag_xsecinfo%get_attribute (1))
data%total_cross_section = &
read_rval (eio%tag_xsecinfo%get_attribute (2)) / pb_per_fb
contains
subroutine err_generator
call msg_fatal ("LHEF: invalid generator tag")
end subroutine err_generator
subroutine err_xsecinfo
call msg_fatal ("LHEF: invalid xsecinfo tag")
end subroutine err_xsecinfo
subroutine err_init
call msg_fatal ("LHEF: syntax error after init tag")
end subroutine err_init
end subroutine eio_lhef_read_init_30
@ %def eio_lhef_read_init_30
@ This is additional event-specific information for the 3.0 format,
after the HEPEUP data. We can specify weights, starting from the
master weight and adding alternative weights. The weight tags are
already allocated, so we just have to transfer the weight values to
strings, assemble them and write them to file. All weights are
collected in a single tag.
Note: If efficiency turns out to be an issue, we may revert to
traditional character buffer writing. However, we need to know the
maximum length.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: write_event_30 => eio_lhef_write_event_30
<<EIO LHEF: procedures>>=
subroutine eio_lhef_write_event_30 (eio, event)
class(eio_lhef_t), intent(in) :: eio
class(generic_event_t), intent(in) :: event
type(string_t) :: s
integer :: u, i
u = eio%unit
s = ""
if (eio%write_sqme_ref) then
s = s // str (event%get_sqme_ref ()) // " "
end if
if (eio%write_sqme_prc) then
s = s // str (event%get_sqme_prc ()) // " "
end if
if (eio%n_alt > 0) then
if (eio%write_sqme_alt) then
s = s // str (event%get_sqme_alt(1)) // " "
do i = 2, eio%n_alt
s = s // str (event%get_sqme_alt(i)) // " "
end do
end if
s = s // str (event%get_weight_alt(1)) // " "
do i = 2, eio%n_alt
s = s // str (event%get_weight_alt(i)) // " "
end do
end if
if (len_trim (s) > 0) then
call eio%tag_weights%write (trim (s), u); write (u, *)
end if
end subroutine eio_lhef_write_event_30
@ %def eio_lhef_write_event_30
@ Read extra event data. If there is a [[weights]] tag and if there
was a [[weightinfo]] entry labeled [[sqme_prc]], we extract the
corresponding entry from the weights string and store this as the
event's squared matrix-element value. Other tags, including
tags written by the above writer, are skipped.
<<EIO LHEF: eio lhef: TBP>>=
procedure :: read_event_30 => eio_lhef_read_event_30
<<EIO LHEF: procedures>>=
subroutine eio_lhef_read_event_30 (eio, event)
class(eio_lhef_t), intent(inout) :: eio
class(generic_event_t), intent(inout) :: event
type(string_t) :: content, string
logical :: found, closing
integer :: i
SCAN_EVENT_TAGS: do
call eio%tag_weights%read (eio%cstream, found)
if (found) then
if (.not. eio%tag_weights%has_content) call err_weights
call eio%tag_weights%read_content (eio%cstream, content, closing)
if (.not. closing) call err_weights
if (eio%i_weight_sqme > 0) then
SCAN_WEIGHTS: do i = 1, eio%i_weight_sqme
call split (content, string, " ")
content = adjustl (content)
if (i == eio%i_weight_sqme) then
call event%set_sqme_ref (read_rval (string))
exit SCAN_WEIGHTS
end if
end do SCAN_WEIGHTS
end if
cycle SCAN_EVENT_TAGS
end if
call eio%tag_event%read_content (eio%cstream, content, closing)
if (closing) then
if (content /= "") call err_event
exit SCAN_EVENT_TAGS
end if
end do SCAN_EVENT_TAGS
contains
subroutine err_weights
call msg_fatal ("LHEF: invalid weights tag in event record")
end subroutine err_weights
subroutine err_event
call msg_fatal ("LHEF: syntax error after event tag")
end subroutine err_event
end subroutine eio_lhef_read_event_30
@ %def eio_lhef_read_event_30
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_lhef_ut.f90]]>>=
<<File header>>
module eio_lhef_ut
use unit_tests
use eio_lhef_uti
<<Standard module head>>
<<EIO LHEF: public test>>
contains
<<EIO LHEF: test driver>>
end module eio_lhef_ut
@ %def eio_lhef_ut
@
<<[[eio_lhef_uti.f90]]>>=
<<File header>>
module eio_lhef_uti
<<Use kinds>>
<<Use strings>>
use io_units
use model_data
use event_base
use eio_data
use eio_base
use eio_lhef
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
use eio_base_ut, only: eio_prepare_fallback_model, eio_cleanup_fallback_model
<<Standard module head>>
<<EIO LHEF: test declarations>>
contains
<<EIO LHEF: tests>>
end module eio_lhef_uti
@ %def eio_lhef_ut
@ API: driver for the unit tests below.
<<EIO LHEF: public test>>=
public :: eio_lhef_test
<<EIO LHEF: test driver>>=
subroutine eio_lhef_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO LHEF: execute tests>>
end subroutine eio_lhef_test
@ %def eio_lhef_test
@
\subsubsection{Version 1.0 Output}
We test the implementation of all I/O methods. We start with output
according to version 1.0.
<<EIO LHEF: execute tests>>=
call test (eio_lhef_1, "eio_lhef_1", &
"write version 1.0", &
u, results)
<<EIO LHEF: test declarations>>=
public :: eio_lhef_1
<<EIO LHEF: tests>>=
subroutine eio_lhef_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_lhef_1"
write (u, "(A)") "* Purpose: generate an event and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_lhef_1"
allocate (eio_lhef_t :: eio)
select type (eio)
type is (eio_lhef_t)
call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // "." // eio%extension), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:21) == " <generator_version>") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_lhef_t :: eio)
select type (eio)
type is (eio_lhef_t)
call eio%set_parameters ()
end select
select type (eio)
type is (eio_lhef_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_lhef_1"
end subroutine eio_lhef_1
@ %def eio_lhef_1
@
\subsubsection{Version 2.0 Output}
Version 2.0 has added a lot of options to the LHEF format. We
implement some of them.
<<EIO LHEF: execute tests>>=
call test (eio_lhef_2, "eio_lhef_2", &
"write version 2.0", &
u, results)
<<EIO LHEF: test declarations>>=
public :: eio_lhef_2
<<EIO LHEF: tests>>=
subroutine eio_lhef_2 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_lhef_2"
write (u, "(A)") "* Purpose: generate an event and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%unweighted = .false.
data%norm_mode = NORM_SIGMA
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_lhef_2"
allocate (eio_lhef_t :: eio)
select type (eio)
type is (eio_lhef_t)
call eio%set_parameters (version = "2.0", write_sqme_prc = .true.)
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // "." // eio%extension), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:10) == "<generator") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_lhef_2"
end subroutine eio_lhef_2
@ %def eio_lhef_2
@
\subsubsection{Version 3.0 Output}
Version 3.0 is an update which removes some tags (which we didn't use anyway)
and suggests a new treatment of weights.
<<EIO LHEF: execute tests>>=
call test (eio_lhef_3, "eio_lhef_3", &
"write version 3.0", &
u, results)
<<EIO LHEF: test declarations>>=
public :: eio_lhef_3
<<EIO LHEF: tests>>=
subroutine eio_lhef_3 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(80) :: buffer
write (u, "(A)") "* Test output: eio_lhef_3"
write (u, "(A)") "* Purpose: generate an event and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%unweighted = .false.
data%norm_mode = NORM_SIGMA
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_lhef_3"
allocate (eio_lhef_t :: eio)
select type (eio)
type is (eio_lhef_t)
call eio%set_parameters (version = "3.0", write_sqme_prc = .true.)
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents:"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".lhe"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (buffer(1:10) == "<generator") buffer = "[...]"
if (iostat /= 0) exit
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_lhef_3"
end subroutine eio_lhef_3
@ %def eio_lhef_3
@
\subsubsection{Version 1.0 Input}
Check input of a version-1.0 conforming LHEF file.
<<EIO LHEF: execute tests>>=
call test (eio_lhef_4, "eio_lhef_4", &
"read version 1.0", &
u, results)
<<EIO LHEF: test declarations>>=
public :: eio_lhef_4
<<EIO LHEF: tests>>=
subroutine eio_lhef_4 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: fallback_model
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat, i_prc
write (u, "(A)") "* Test output: eio_lhef_4"
write (u, "(A)") "* Purpose: read a LHEF 1.0 file"
write (u, "(A)")
write (u, "(A)") "* Write a LHEF data file"
write (u, "(A)")
u_file = free_unit ()
sample = "eio_lhef_4"
open (u_file, file = char (sample // ".lhe"), &
status = "replace", action = "readwrite")
write (u_file, "(A)") '<LesHouchesEvents version="1.0">'
write (u_file, "(A)") '<header>'
write (u_file, "(A)") ' <arbitrary_tag opt="foo">content</arbitrary_tag>'
write (u_file, "(A)") ' Text'
write (u_file, "(A)") ' <another_tag />'
write (u_file, "(A)") '</header>'
write (u_file, "(A)") '<init>'
write (u_file, "(A)") ' 25 25 5.0000000000E+02 5.0000000000E+02 &
& -1 -1 -1 -1 3 1'
write (u_file, "(A)") ' 1.0000000000E-01 1.0000000000E-03 &
& 1.0000000000E+00 42'
write (u_file, "(A)") '</init>'
write (u_file, "(A)") '<event>'
write (u_file, "(A)") ' 4 42 3.0574068604E+08 1.0000000000E+03 &
& -1.0000000000E+00 -1.0000000000E+00'
write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 0.0000000000E+00 &
& 4.8412291828E+02 5.0000000000E+02 1.2500000000E+02 &
& 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 0.0000000000E+00 &
&-4.8412291828E+02 5.0000000000E+02 1.2500000000E+02 &
& 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 1 1 2 0 0 -1.4960220911E+02 -4.6042825611E+02 &
& 0.0000000000E+00 5.0000000000E+02 1.2500000000E+02 &
& 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 1 1 2 0 0 1.4960220911E+02 4.6042825611E+02 &
& 0.0000000000E+00 5.0000000000E+02 1.2500000000E+02 &
& 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") '</event>'
write (u_file, "(A)") '</LesHouchesEvents>'
close (u_file)
write (u, "(A)") "* Initialize test process"
write (u, "(A)")
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event, unweighted = .false.)
allocate (eio_lhef_t :: eio)
select type (eio)
type is (eio_lhef_t)
call eio%set_parameters (recover_beams = .false.)
end select
call eio%set_fallback_model (fallback_model)
call data%init (1)
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
call data%write (u)
write (u, *)
write (u, "(A)") "* Initialize and read header"
write (u, "(A)")
call eio%init_in (sample, data)
call eio%write (u)
write (u, *)
select type (eio)
type is (eio_lhef_t)
call eio%tag_lhef%write (u); write (u, *)
end select
write (u, *)
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Read event"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
select type (eio)
type is (eio_lhef_t)
write (u, "(A,I0,A,I0)") "Found process #", i_prc, &
" with ID = ", eio%proc_num_id(i_prc)
end select
call eio%input_event (event, iostat)
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Read closing"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
write (u, "(A,I0)") "iostat = ", iostat
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_lhef_4"
end subroutine eio_lhef_4
@ %def eio_lhef_4
@
\subsubsection{Version 2.0 Input}
Check input of a version-2.0 conforming LHEF file.
<<EIO LHEF: execute tests>>=
call test (eio_lhef_5, "eio_lhef_5", &
"read version 2.0", &
u, results)
<<EIO LHEF: test declarations>>=
public :: eio_lhef_5
<<EIO LHEF: tests>>=
subroutine eio_lhef_5 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: fallback_model
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat, i_prc
write (u, "(A)") "* Test output: eio_lhef_5"
write (u, "(A)") "* Purpose: read a LHEF 2.0 file"
write (u, "(A)")
write (u, "(A)") "* Write a LHEF data file"
write (u, "(A)")
u_file = free_unit ()
sample = "eio_lhef_5"
open (u_file, file = char (sample // ".lhe"), &
status = "replace", action = "readwrite")
write (u_file, "(A)") '<LesHouchesEvents version="2.0">'
write (u_file, "(A)") '<header>'
write (u_file, "(A)") '</header>'
write (u_file, "(A)") '<init>'
write (u_file, "(A)") ' 25 25 5.0000000000E+02 5.0000000000E+02 &
&-1 -1 -1 -1 4 1'
write (u_file, "(A)") ' 1.0000000000E-01 1.0000000000E-03 &
& 0.0000000000E+00 42'
write (u_file, "(A)") '<generator version="2.2.3">WHIZARD&
&</generator>'
write (u_file, "(A)") '<xsecinfo neve="1" totxsec="1.0000000000E-01" />'
write (u_file, "(A)") '</init>'
write (u_file, "(A)") '<event>'
write (u_file, "(A)") ' 4 42 3.0574068604E+08 1.0000000000E+03 &
&-1.0000000000E+00 -1.0000000000E+00'
write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 &
& 0.0000000000E+00 4.8412291828E+02 5.0000000000E+02 &
& 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 &
& 0.0000000000E+00 -4.8412291828E+02 5.0000000000E+02 &
& 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 1 1 2 0 0 -1.4960220911E+02 &
&-4.6042825611E+02 0.0000000000E+00 5.0000000000E+02 &
& 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 1 1 2 0 0 1.4960220911E+02 &
& 4.6042825611E+02 0.0000000000E+00 5.0000000000E+02 &
& 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") '<weight name="sqme_prc">1.0000000000E+00</weight>'
write (u_file, "(A)") '</event>'
write (u_file, "(A)") '</LesHouchesEvents>'
close (u_file)
write (u, "(A)") "* Initialize test process"
write (u, "(A)")
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event, unweighted = .false.)
allocate (eio_lhef_t :: eio)
select type (eio)
type is (eio_lhef_t)
call eio%set_parameters (version = "2.0", recover_beams = .false.)
end select
call eio%set_fallback_model (fallback_model)
call data%init (1)
data%unweighted = .false.
data%norm_mode = NORM_SIGMA
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
call data%write (u)
write (u, *)
write (u, "(A)") "* Initialize and read header"
write (u, "(A)")
call eio%init_in (sample, data)
call eio%write (u)
write (u, *)
select type (eio)
type is (eio_lhef_t)
call eio%tag_lhef%write (u); write (u, *)
end select
write (u, *)
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Read event"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
select type (eio)
type is (eio_lhef_t)
write (u, "(A,I0,A,I0)") "Found process #", i_prc, &
" with ID = ", eio%proc_num_id(i_prc)
end select
call eio%input_event (event, iostat)
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Read closing"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
write (u, "(A,I0)") "iostat = ", iostat
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_lhef_5"
end subroutine eio_lhef_5
@ %def eio_lhef_5
@
\subsubsection{Version 3.0 Input}
Check input of a version-3.0 conforming LHEF file.
<<EIO LHEF: execute tests>>=
call test (eio_lhef_6, "eio_lhef_6", &
"read version 3.0", &
u, results)
<<EIO LHEF: test declarations>>=
public :: eio_lhef_6
<<EIO LHEF: tests>>=
subroutine eio_lhef_6 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: fallback_model
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat, i_prc
write (u, "(A)") "* Test output: eio_lhef_6"
write (u, "(A)") "* Purpose: read a LHEF 3.0 file"
write (u, "(A)")
write (u, "(A)") "* Write a LHEF data file"
write (u, "(A)")
u_file = free_unit ()
sample = "eio_lhef_6"
open (u_file, file = char (sample // ".lhe"), &
status = "replace", action = "readwrite")
write (u_file, "(A)") '<LesHouchesEvents version="3.0">'
write (u_file, "(A)") '<header>'
write (u_file, "(A)") '</header>'
write (u_file, "(A)") '<init>'
write (u_file, "(A)") ' 25 25 5.0000000000E+02 5.0000000000E+02 &
&-1 -1 -1 -1 4 1'
write (u_file, "(A)") ' 1.0000000000E-01 1.0000000000E-03 &
& 0.0000000000E+00 42'
write (u_file, "(A)") '<generator version="2.2.3">WHIZARD&
&</generator>'
write (u_file, "(A)") '<xsecinfo neve="1" totxsec="1.0000000000E-01" />'
write (u_file, "(A)") '<weightinfo name="sqme_prc" />'
write (u_file, "(A)") '</init>'
write (u_file, "(A)") '<event>'
write (u_file, "(A)") ' 4 42 3.0574068604E+08 1.0000000000E+03 &
&-1.0000000000E+00 -1.0000000000E+00'
write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 &
& 0.0000000000E+00 4.8412291828E+02 5.0000000000E+02 &
& 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 -1 0 0 0 0 0.0000000000E+00 &
& 0.0000000000E+00 -4.8412291828E+02 5.0000000000E+02 &
& 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 1 1 2 0 0 -1.4960220911E+02 &
&-4.6042825611E+02 0.0000000000E+00 5.0000000000E+02 &
& 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") ' 25 1 1 2 0 0 1.4960220911E+02 &
& 4.6042825611E+02 0.0000000000E+00 5.0000000000E+02 &
& 1.2500000000E+02 0.0000000000E+00 9.0000000000E+00'
write (u_file, "(A)") '<weights>1.0000000000E+00</weights>'
write (u_file, "(A)") '</event>'
write (u_file, "(A)") '</LesHouchesEvents>'
close (u_file)
write (u, "(A)") "* Initialize test process"
write (u, "(A)")
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event, unweighted = .false.)
allocate (eio_lhef_t :: eio)
select type (eio)
type is (eio_lhef_t)
call eio%set_parameters (version = "3.0", recover_beams = .false.)
end select
call eio%set_fallback_model (fallback_model)
call data%init (1)
data%unweighted = .false.
data%norm_mode = NORM_SIGMA
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
call data%write (u)
write (u, *)
write (u, "(A)") "* Initialize and read header"
write (u, "(A)")
call eio%init_in (sample, data)
call eio%write (u)
write (u, *)
select type (eio)
type is (eio_lhef_t)
call eio%tag_lhef%write (u); write (u, *)
end select
write (u, *)
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Read event"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
select type (eio)
type is (eio_lhef_t)
write (u, "(A,I0,A,I0)") "Found process #", i_prc, &
" with ID = ", eio%proc_num_id(i_prc)
end select
call eio%input_event (event, iostat)
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Read closing"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
write (u, "(A,I0)") "iostat = ", iostat
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_lhef_6"
end subroutine eio_lhef_6
@ %def eio_lhef_6
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{STDHEP File Formats}
Here, we implement the two existing STDHEP file formats, one based on the
HEPRUP/HEPEUP common blocks, the other based on the HEPEVT common block.
The second one is actually the standard STDHEP format.
<<[[eio_stdhep.f90]]>>=
<<File header>>
module eio_stdhep
use kinds, only: i32, i64
<<Use strings>>
use io_units
use string_utils
use diagnostics
use event_base
use hep_common
use hep_events
use eio_data
use eio_base
<<Standard module head>>
<<EIO stdhep: public>>
<<EIO stdhep: types>>
<<EIO stdhep: variables>>
contains
<<EIO stdhep: procedures>>
end module eio_stdhep
@ %def eio_stdhep
@
\subsection{Type}
<<EIO stdhep: public>>=
public :: eio_stdhep_t
<<EIO stdhep: types>>=
type, abstract, extends (eio_t) :: eio_stdhep_t
logical :: writing = .false.
logical :: reading = .false.
integer :: unit = 0
logical :: keep_beams = .false.
logical :: keep_remnants = .true.
logical :: ensure_order = .false.
logical :: recover_beams = .false.
logical :: use_alphas_from_file = .false.
logical :: use_scale_from_file = .false.
integer, dimension(:), allocatable :: proc_num_id
integer(i64) :: n_events_expected = 0
contains
<<EIO stdhep: eio stdhep: TBP>>
end type eio_stdhep_t
@ %def eio_stdhep_t
@
<<EIO stdhep: public>>=
public :: eio_stdhep_hepevt_t
<<EIO stdhep: types>>=
type, extends (eio_stdhep_t) :: eio_stdhep_hepevt_t
end type eio_stdhep_hepevt_t
@ %def eio_stdhep_hepevt_t
@
<<EIO stdhep: public>>=
public :: eio_stdhep_hepeup_t
<<EIO stdhep: types>>=
type, extends (eio_stdhep_t) :: eio_stdhep_hepeup_t
end type eio_stdhep_hepeup_t
@ %def eio_stdhep_hepeup_t
@
<<EIO stdhep: public>>=
public :: eio_stdhep_hepev4_t
<<EIO stdhep: types>>=
type, extends (eio_stdhep_t) :: eio_stdhep_hepev4_t
end type eio_stdhep_hepev4_t
@ %def eio_stdhep_hepev4_t
@
\subsection{Specific Methods}
Set parameters that are specifically used with STDHEP file formats.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: set_parameters => eio_stdhep_set_parameters
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_set_parameters (eio, &
keep_beams, keep_remnants, ensure_order, recover_beams, &
use_alphas_from_file, use_scale_from_file, extension)
class(eio_stdhep_t), intent(inout) :: eio
logical, intent(in), optional :: keep_beams
logical, intent(in), optional :: keep_remnants
logical, intent(in), optional :: ensure_order
logical, intent(in), optional :: recover_beams
logical, intent(in), optional :: use_alphas_from_file
logical, intent(in), optional :: use_scale_from_file
type(string_t), intent(in), optional :: extension
if (present (keep_beams)) eio%keep_beams = keep_beams
if (present (keep_remnants)) eio%keep_remnants = keep_remnants
if (present (ensure_order)) eio%ensure_order = ensure_order
if (present (recover_beams)) eio%recover_beams = recover_beams
if (present (use_alphas_from_file)) &
eio%use_alphas_from_file = use_alphas_from_file
if (present (use_scale_from_file)) &
eio%use_scale_from_file = use_scale_from_file
if (present (extension)) then
eio%extension = extension
else
select type (eio)
type is (eio_stdhep_hepevt_t)
eio%extension = "hep"
type is (eio_stdhep_hepev4_t)
eio%extension = "ev4.hep"
type is (eio_stdhep_hepeup_t)
eio%extension = "up.hep"
end select
end if
end subroutine eio_stdhep_set_parameters
@ %def eio_ascii_stdhep_parameters
@
\subsection{Common Methods}
Output. This is not the actual event format, but a readable account
of the current object status.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: write => eio_stdhep_write
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_write (object, unit)
class(eio_stdhep_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A)") "STDHEP event stream:"
if (object%writing) then
write (u, "(3x,A,A)") "Writing to file = ", char (object%filename)
else if (object%reading) then
write (u, "(3x,A,A)") "Reading from file = ", char (object%filename)
else
write (u, "(3x,A)") "[closed]"
end if
write (u, "(3x,A,L1)") "Keep beams = ", object%keep_beams
write (u, "(3x,A,L1)") "Keep remnants = ", object%keep_remnants
write (u, "(3x,A,L1)") "Recover beams = ", object%recover_beams
write (u, "(3x,A,L1)") "Alpha_s from file = ", &
object%use_alphas_from_file
write (u, "(3x,A,L1)") "Scale from file = ", &
object%use_scale_from_file
if (allocated (object%proc_num_id)) then
write (u, "(3x,A)") "Numerical process IDs:"
do i = 1, size (object%proc_num_id)
write (u, "(5x,I0,': ',I0)") i, object%proc_num_id(i)
end do
end if
end subroutine eio_stdhep_write
@ %def eio_stdhep_write
@ Finalizer: close any open file.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: final => eio_stdhep_final
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_final (object)
class(eio_stdhep_t), intent(inout) :: object
if (allocated (object%proc_num_id)) deallocate (object%proc_num_id)
if (object%writing) then
write (msg_buffer, "(A,A,A)") "Events: closing STDHEP file '", &
char (object%filename), "'"
call msg_message ()
call stdhep_write (200)
call stdhep_end ()
object%writing = .false.
else if (object%reading) then
write (msg_buffer, "(A,A,A)") "Events: closing STDHEP file '", &
char (object%filename), "'"
call msg_message ()
object%reading = .false.
end if
end subroutine eio_stdhep_final
@ %def eio_stdhep_final
@ Common initialization for input and output.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: common_init => eio_stdhep_common_init
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_common_init (eio, sample, data, extension)
class(eio_stdhep_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
if (.not. present (data)) &
call msg_bug ("STDHEP initialization: missing data")
if (data%n_beam /= 2) &
call msg_fatal ("STDHEP: defined for scattering processes only")
if (present (extension)) then
eio%extension = extension
end if
eio%sample = sample
call eio%set_filename ()
eio%unit = free_unit ()
allocate (eio%proc_num_id (data%n_proc), source = data%proc_num_id)
end subroutine eio_stdhep_common_init
@ %def eio_stdhep_common_init
@ Split event file: increment the counter, close the current file, open a new
one. If the file needs a header, repeat it for the new file. (We assume that
the common block contents are still intact.)
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: split_out => eio_stdhep_split_out
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_split_out (eio)
class(eio_stdhep_t), intent(inout) :: eio
if (eio%split) then
eio%split_index = eio%split_index + 1
call eio%set_filename ()
write (msg_buffer, "(A,A,A)") "Events: writing to STDHEP file '", &
char (eio%filename), "'"
call msg_message ()
call stdhep_write (200)
call stdhep_end ()
select type (eio)
type is (eio_stdhep_hepeup_t)
call stdhep_init_out (char (eio%filename), &
"WHIZARD <<Version>>", eio%n_events_expected)
call stdhep_write (100)
call stdhep_write (STDHEP_HEPRUP)
type is (eio_stdhep_hepevt_t)
call stdhep_init_out (char (eio%filename), &
"WHIZARD <<Version>>", eio%n_events_expected)
call stdhep_write (100)
type is (eio_stdhep_hepev4_t)
call stdhep_init_out (char (eio%filename), &
"WHIZARD <<Version>>", eio%n_events_expected)
call stdhep_write (100)
end select
end if
end subroutine eio_stdhep_split_out
@ %def eio_stdhep_split_out
@ Initialize event writing.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: init_out => eio_stdhep_init_out
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_init_out (eio, sample, data, success, extension)
class(eio_stdhep_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
integer :: i
if (.not. present (data)) &
call msg_bug ("STDHEP initialization: missing data")
call eio%set_splitting (data)
call eio%common_init (sample, data, extension)
eio%n_events_expected = data%n_evt
write (msg_buffer, "(A,A,A)") "Events: writing to STDHEP file '", &
char (eio%filename), "'"
call msg_message ()
eio%writing = .true.
select type (eio)
type is (eio_stdhep_hepeup_t)
call heprup_init &
(data%pdg_beam, &
data%energy_beam, &
n_processes = data%n_proc, &
unweighted = data%unweighted, &
negative_weights = data%negative_weights)
do i = 1, data%n_proc
call heprup_set_process_parameters (i = i, &
process_id = data%proc_num_id(i), &
cross_section = data%cross_section(i), &
error = data%error(i))
end do
call stdhep_init_out (char (eio%filename), &
"WHIZARD <<Version>>", eio%n_events_expected)
call stdhep_write (100)
call stdhep_write (STDHEP_HEPRUP)
type is (eio_stdhep_hepevt_t)
call stdhep_init_out (char (eio%filename), &
"WHIZARD <<Version>>", eio%n_events_expected)
call stdhep_write (100)
type is (eio_stdhep_hepev4_t)
call stdhep_init_out (char (eio%filename), &
"WHIZARD <<Version>>", eio%n_events_expected)
call stdhep_write (100)
end select
if (present (success)) success = .true.
end subroutine eio_stdhep_init_out
@ %def eio_stdhep_init_out
@ Initialize event reading.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: init_in => eio_stdhep_init_in
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_init_in (eio, sample, data, success, extension)
class(eio_stdhep_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
integer :: ilbl, lok
logical :: exist
call eio%common_init (sample, data, extension)
write (msg_buffer, "(A,A,A)") "Events: reading from STDHEP file '", &
char (eio%filename), "'"
call msg_message ()
inquire (file = char (eio%filename), exist = exist)
if (.not. exist) call msg_fatal ("Events: STDHEP file not found.")
eio%reading = .true.
call stdhep_init_in (char (eio%filename), eio%n_events_expected)
call stdhep_read (ilbl, lok)
if (lok /= 0) then
call stdhep_end ()
write (msg_buffer, "(A)") "Events: STDHEP file appears to" // &
" be empty."
call msg_message ()
end if
if (ilbl == 100) then
write (msg_buffer, "(A)") "Events: reading in STDHEP events"
call msg_message ()
end if
if (present (success)) success = .false.
end subroutine eio_stdhep_init_in
@ %def eio_stdhep_init_in
@ Switch from input to output: reopen the file for reading.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: switch_inout => eio_stdhep_switch_inout
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_switch_inout (eio, success)
class(eio_stdhep_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("STDHEP: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_stdhep_switch_inout
@ %def eio_stdhep_switch_inout
@ Output an event. Write first the event indices, then weight and
squared matrix element, then the particle set.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: output => eio_stdhep_output
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_output (eio, event, i_prc, reading, passed, pacify)
class(eio_stdhep_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
if (present (passed)) then
if (.not. passed) return
end if
if (eio%writing) then
select type (eio)
type is (eio_stdhep_hepeup_t)
call hepeup_from_event (event, &
process_index = eio%proc_num_id (i_prc), &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants)
call stdhep_write (STDHEP_HEPEUP)
type is (eio_stdhep_hepevt_t)
call hepevt_from_event (event, &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants, &
ensure_order = eio%ensure_order)
call stdhep_write (STDHEP_HEPEVT)
type is (eio_stdhep_hepev4_t)
call hepevt_from_event (event, &
process_index = eio%proc_num_id (i_prc), &
keep_beams = eio%keep_beams, &
keep_remnants = eio%keep_remnants, &
ensure_order = eio%ensure_order, &
fill_hepev4 = .true.)
call stdhep_write (STDHEP_HEPEV4)
end select
else
call eio%write ()
call msg_fatal ("STDHEP file is not open for writing")
end if
end subroutine eio_stdhep_output
@ %def eio_stdhep_output
@ Input an event. We do not allow to read in STDHEP files written via
the HEPEVT common block as there is no control on the process ID.
This implies that the event index cannot be read; it is simply
incremented to count the current event sample.
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: input_i_prc => eio_stdhep_input_i_prc
procedure :: input_event => eio_stdhep_input_event
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_input_i_prc (eio, i_prc, iostat)
class(eio_stdhep_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
integer :: i, ilbl, proc_num_id
iostat = 0
select type (eio)
type is (eio_stdhep_hepevt_t)
if (size (eio%proc_num_id) > 1) then
call msg_fatal ("Events: only single processes allowed " // &
"with the STDHEP HEPEVT format.")
else
proc_num_id = eio%proc_num_id (1)
call stdhep_read (ilbl, lok)
end if
type is (eio_stdhep_hepev4_t)
call stdhep_read (ilbl, lok)
proc_num_id = idruplh
type is (eio_stdhep_hepeup_t)
call stdhep_read (ilbl, lok)
if (lok /= 0) call msg_error ("Events: STDHEP appears to be " // &
"empty or corrupted.")
if (ilbl == 12) then
call stdhep_read (ilbl, lok)
end if
if (ilbl == 11) then
proc_num_id = IDPRUP
end if
end select
FIND_I_PRC: do i = 1, size (eio%proc_num_id)
if (eio%proc_num_id(i) == proc_num_id) then
i_prc = i
exit FIND_I_PRC
end if
end do FIND_I_PRC
if (i_prc == 0) call err_index
contains
subroutine err_index
call msg_error ("STDHEP: reading events: undefined process ID " &
// char (str (proc_num_id)) // ", aborting read")
iostat = 1
end subroutine err_index
end subroutine eio_stdhep_input_i_prc
subroutine eio_stdhep_input_event (eio, event, iostat)
class(eio_stdhep_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
iostat = 0
call event%reset_contents ()
call event%select (1, 1, 1)
call hepeup_to_event (event, eio%fallback_model, &
recover_beams = eio%recover_beams, &
use_alpha_s = eio%use_alphas_from_file, &
use_scale = eio%use_scale_from_file)
call event%increment_index ()
end subroutine eio_stdhep_input_event
@ %def eio_stdhep_input_i_prc
@ %def eio_stdhep_input_event
<<EIO stdhep: eio stdhep: TBP>>=
procedure :: skip => eio_stdhep_skip
<<EIO stdhep: procedures>>=
subroutine eio_stdhep_skip (eio, iostat)
class(eio_stdhep_t), intent(inout) :: eio
integer, intent(out) :: iostat
if (eio%reading) then
read (eio%unit, iostat = iostat)
else
call eio%write ()
call msg_fatal ("Raw event file is not open for reading")
end if
end subroutine eio_stdhep_skip
@ %def eio_stdhep_skip
@ STDHEP speficic routines.
<<EIO stdhep: public>>=
public :: stdhep_init_out
public :: stdhep_init_in
public :: stdhep_write
public :: stdhep_end
<<EIO stdhep: procedures>>=
subroutine stdhep_init_out (file, title, nevt)
character(len=*), intent(in) :: file, title
integer(i64), intent(in) :: nevt
integer(i32) :: nevt32
nevt32 = min (nevt, int (huge (1_i32), i64))
call stdxwinit (file, title, nevt32, istr, lok)
end subroutine stdhep_init_out
subroutine stdhep_init_in (file, nevt)
character(len=*), intent(in) :: file
integer(i64), intent(out) :: nevt
integer(i32) :: nevt32
call stdxrinit (file, nevt32, istr, lok)
if (lok /= 0) call msg_fatal ("STDHEP: error in reading file '" // &
file // "'.")
nevt = int (nevt32, i64)
end subroutine stdhep_init_in
subroutine stdhep_write (ilbl)
integer, intent(in) :: ilbl
call stdxwrt (ilbl, istr, lok)
end subroutine stdhep_write
subroutine stdhep_read (ilbl, lok)
integer, intent(out) :: ilbl, lok
call stdxrd (ilbl, istr, lok)
if (lok /= 0) return
end subroutine stdhep_read
subroutine stdhep_end
call stdxend (istr)
end subroutine stdhep_end
@ %def stdhep_init stdhep_read stdhep_write stdhep_end
@
\subsection{Variables}
<<EIO stdhep: variables>>=
integer, save :: istr, lok
integer, parameter :: &
STDHEP_HEPEVT = 1, STDHEP_HEPEV4 = 4, &
STDHEP_HEPEUP = 11, STDHEP_HEPRUP = 12
@
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_stdhep_ut.f90]]>>=
<<File header>>
module eio_stdhep_ut
use unit_tests
use eio_stdhep_uti
<<Standard module head>>
<<EIO stdhep: public test>>
contains
<<EIO stdhep: test driver>>
end module eio_stdhep_ut
@ %def eio_stdhep_ut
@
<<[[eio_stdhep_uti.f90]]>>=
<<File header>>
module eio_stdhep_uti
<<Use kinds>>
<<Use strings>>
use io_units
use model_data
use event_base
use eio_data
use eio_base
use xdr_wo_stdhep
use eio_stdhep
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
use eio_base_ut, only: eio_prepare_fallback_model, eio_cleanup_fallback_model
<<Standard module head>>
<<EIO stdhep: test declarations>>
contains
<<EIO stdhep: tests>>
end module eio_stdhep_uti
@ %def eio_stdhep_ut
@ API: driver for the unit tests below.
<<EIO stdhep: public test>>=
public :: eio_stdhep_test
<<EIO stdhep: test driver>>=
subroutine eio_stdhep_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO stdhep: execute tests>>
end subroutine eio_stdhep_test
@ %def eio_stdhep_test
@
\subsubsection{Test I/O methods}
We test the implementation of the STDHEP HEPEVT I/O method:
<<EIO stdhep: execute tests>>=
call test (eio_stdhep_1, "eio_stdhep_1", &
"read and write event contents, format [stdhep]", &
u, results)
<<EIO stdhep: test declarations>>=
public :: eio_stdhep_1
<<EIO stdhep: tests>>=
subroutine eio_stdhep_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(215) :: buffer
write (u, "(A)") "* Test output: eio_stdhep_1"
write (u, "(A)") "* Purpose: generate an event in STDHEP HEPEVT format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_stdhep_1"
allocate (eio_stdhep_hepevt_t :: eio)
select type (eio)
type is (eio_stdhep_hepevt_t)
call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (61) ! not supported by reader, actually
call event%evaluate_expressions ()
call event%pacify_particle_set ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* Write STDHEP file contents to ASCII file"
write (u, "(A)")
call write_stdhep_event &
(sample // ".hep", var_str ("eio_stdhep_1.hep.out"), 1)
write (u, "(A)")
write (u, "(A)") "* Read in ASCII contents of STDHEP file"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = "eio_stdhep_1.hep.out", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
if (trim (buffer) == "") cycle
if (buffer(1:18) == " total blocks: ") &
buffer = " total blocks: [...]"
if (buffer(1:25) == " title: WHIZARD") &
buffer = " title: WHIZARD [version]"
if (buffer(1:17) == " date:") &
buffer = " date: [...]"
if (buffer(1:17) == " closing date:") &
buffer = " closing date: [...]"
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_stdhep_hepevt_t :: eio)
select type (eio)
type is (eio_stdhep_hepevt_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_stdhep_1"
end subroutine eio_stdhep_1
@ %def eio_stdhep_1
@
We test the implementation of the STDHEP HEPEUP I/O method:
<<EIO stdhep: execute tests>>=
call test (eio_stdhep_2, "eio_stdhep_2", &
"read and write event contents, format [stdhep]", &
u, results)
<<EIO stdhep: test declarations>>=
public :: eio_stdhep_2
<<EIO stdhep: tests>>=
subroutine eio_stdhep_2 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(model_data_t), pointer :: fallback_model
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(215) :: buffer
write (u, "(A)") "* Test output: eio_stdhep_2"
write (u, "(A)") "* Purpose: generate an event in STDHEP HEPEUP format"
write (u, "(A)") "* and write weight to file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event, unweighted = .false.)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_stdhep_2"
allocate (eio_stdhep_hepeup_t :: eio)
select type (eio)
type is (eio_stdhep_hepeup_t)
call eio%set_parameters ()
end select
call eio%set_fallback_model (fallback_model)
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (62) ! not supported by reader, actually
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* Write STDHEP file contents to ASCII file"
write (u, "(A)")
call write_stdhep_event &
(sample // ".up.hep", var_str ("eio_stdhep_2.hep.out"), 2)
write (u, "(A)")
write (u, "(A)") "* Read in ASCII contents of STDHEP file"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = "eio_stdhep_2.hep.out", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
if (trim (buffer) == "") cycle
if (buffer(1:18) == " total blocks: ") &
buffer = " total blocks: [...]"
if (buffer(1:25) == " title: WHIZARD") &
buffer = " title: WHIZARD [version]"
if (buffer(1:17) == " date:") &
buffer = " date: [...]"
if (buffer(1:17) == " closing date:") &
buffer = " closing date: [...]"
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_stdhep_hepeup_t :: eio)
select type (eio)
type is (eio_stdhep_hepeup_t)
call eio%set_parameters (keep_beams = .true.)
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_stdhep_2"
end subroutine eio_stdhep_2
@ %def eio_stdhep_2
@
Check input from a StdHep file, HEPEVT block.
<<EIO stdhep: execute tests>>=
call test (eio_stdhep_3, "eio_stdhep_3", &
"read StdHep file, HEPEVT block", &
u, results)
<<EIO stdhep: test declarations>>=
public :: eio_stdhep_3
<<EIO stdhep: tests>>=
subroutine eio_stdhep_3 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: fallback_model
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: iostat, i_prc
write (u, "(A)") "* Test output: eio_stdhep_3"
write (u, "(A)") "* Purpose: read a StdHep file, HEPEVT block"
write (u, "(A)")
write (u, "(A)") "* Write a StdHep data file, HEPEVT block"
write (u, "(A)")
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_stdhep_3"
allocate (eio_stdhep_hepevt_t :: eio)
select type (eio)
type is (eio_stdhep_hepevt_t)
call eio%set_parameters ()
end select
call eio%set_fallback_model (fallback_model)
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (63) ! not supported by reader, actually
call event%evaluate_expressions ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
deallocate (eio)
write (u, "(A)") "* Initialize test process"
write (u, "(A)")
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event, unweighted = .false.)
allocate (eio_stdhep_hepevt_t :: eio)
select type (eio)
type is (eio_stdhep_hepevt_t)
call eio%set_parameters (recover_beams = .false.)
end select
call eio%set_fallback_model (fallback_model)
call data%init (1)
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
call data%write (u)
write (u, *)
write (u, "(A)") "* Initialize"
write (u, "(A)")
call eio%init_in (sample, data)
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Read event"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
select type (eio)
type is (eio_stdhep_hepevt_t)
write (u, "(A,I0,A,I0)") "Found process #", i_prc, &
" with ID = ", eio%proc_num_id(i_prc)
end select
call eio%input_event (event, iostat)
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Read closing"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
write (u, "(A,I0)") "iostat = ", iostat
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_stdhep_3"
end subroutine eio_stdhep_3
@ %def eio_stdhep_3
@
Check input from a StdHep file, HEPEVT block.
<<EIO stdhep: execute tests>>=
call test (eio_stdhep_4, "eio_stdhep_4", &
"read StdHep file, HEPRUP/HEPEUP block", &
u, results)
<<EIO stdhep: test declarations>>=
public :: eio_stdhep_4
<<EIO stdhep: tests>>=
subroutine eio_stdhep_4 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: fallback_model
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: iostat, i_prc
write (u, "(A)") "* Test output: eio_stdhep_3"
write (u, "(A)") "* Purpose: read a StdHep file, HEPRUP/HEPEUP block"
write (u, "(A)")
write (u, "(A)") "* Write a StdHep data file, HEPRUP/HEPEUP block"
write (u, "(A)")
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event)
call data%init (1)
data%n_evt = 1
data%n_beam = 2
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event, HEPEUP/HEPRUP"
write (u, "(A)")
sample = "eio_stdhep_4"
allocate (eio_stdhep_hepeup_t :: eio)
select type (eio)
type is (eio_stdhep_hepeup_t)
call eio%set_parameters ()
end select
call eio%set_fallback_model (fallback_model)
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (64) ! not supported by reader, actually
call event%evaluate_expressions ()
call event%pacify_particle_set ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
deallocate (eio)
write (u, "(A)") "* Initialize test process"
write (u, "(A)")
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event, unweighted = .false.)
allocate (eio_stdhep_hepeup_t :: eio)
select type (eio)
type is (eio_stdhep_hepeup_t)
call eio%set_parameters (recover_beams = .false.)
end select
call eio%set_fallback_model (fallback_model)
call data%init (1)
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
call data%write (u)
write (u, *)
write (u, "(A)") "* Initialize"
write (u, "(A)")
call eio%init_in (sample, data)
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Read event"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
select type (eio)
type is (eio_stdhep_hepeup_t)
write (u, "(A,I0,A,I0)") "Found process #", i_prc, &
" with ID = ", eio%proc_num_id(i_prc)
end select
call eio%input_event (event, iostat)
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Read closing"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
write (u, "(A,I0)") "iostat = ", iostat
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_stdhep_4"
end subroutine eio_stdhep_4
@ %def eio_stdhep_4
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{HepMC Output}
The HepMC event record is standardized. It is an ASCII format. We try
our best at using it for both input and output.
<<[[eio_hepmc.f90]]>>=
<<File header>>
module eio_hepmc
<<Use strings>>
use io_units
use string_utils
use diagnostics
use particles
use model_data
use event_base
use hep_events
use eio_data
use eio_base
use hepmc_interface
<<Standard module head>>
<<EIO HepMC: public>>
<<EIO HepMC: types>>
contains
<<EIO HepMC: procedures>>
end module eio_hepmc
@ %def eio_hepmc
@
\subsection{Type}
A type [[hepmc_event]] is introduced as container to store HepMC event
data, particularly for splitting the reading into read out of the process
index and the proper event data.
Note: the [[keep_beams]] flag is not supported. Beams will always
be written. Tools like \texttt{Rivet} can use the cross section
information of a HepMC file for scaling plots. As there is no header in
HepMC and this is written for every event, we make it optional with
[[output_cross_section]].
<<EIO HepMC: public>>=
public :: eio_hepmc_t
<<EIO HepMC: types>>=
type, extends (eio_t) :: eio_hepmc_t
logical :: writing = .false.
logical :: reading = .false.
type(event_sample_data_t) :: data
! logical :: keep_beams = .false.
logical :: recover_beams = .false.
logical :: use_alphas_from_file = .false.
logical :: use_scale_from_file = .false.
logical :: output_cross_section = .false.
type(hepmc_iostream_t) :: iostream
type(hepmc_event_t) :: hepmc_event
integer, dimension(:), allocatable :: proc_num_id
contains
<<EIO HepMC: eio hepmc: TBP>>
end type eio_hepmc_t
@ %def eio_hepmc_t
@
\subsection{Specific Methods}
Set parameters that are specifically used with HepMC.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: set_parameters => eio_hepmc_set_parameters
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_set_parameters &
(eio, &
recover_beams, use_alphas_from_file, use_scale_from_file, &
extension, output_cross_section)
class(eio_hepmc_t), intent(inout) :: eio
logical, intent(in), optional :: recover_beams
logical, intent(in), optional :: use_alphas_from_file
logical, intent(in), optional :: use_scale_from_file
logical, intent(in), optional :: output_cross_section
type(string_t), intent(in), optional :: extension
if (present (recover_beams)) &
eio%recover_beams = recover_beams
if (present (use_alphas_from_file)) &
eio%use_alphas_from_file = use_alphas_from_file
if (present (use_scale_from_file)) &
eio%use_scale_from_file = use_scale_from_file
if (present (extension)) then
eio%extension = extension
else
eio%extension = "hepmc"
end if
if (present (output_cross_section)) &
eio%output_cross_section = output_cross_section
end subroutine eio_hepmc_set_parameters
@ %def eio_hepmc_set_parameters
@
\subsection{Common Methods}
Output. This is not the actual event format, but a readable account
of the current object status.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: write => eio_hepmc_write
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_write (object, unit)
class(eio_hepmc_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A)") "HepMC event stream:"
if (object%writing) then
write (u, "(3x,A,A)") "Writing to file = ", char (object%filename)
else if (object%reading) then
write (u, "(3x,A,A)") "Reading from file = ", char (object%filename)
else
write (u, "(3x,A)") "[closed]"
end if
write (u, "(3x,A,L1)") "Recover beams = ", object%recover_beams
write (u, "(3x,A,L1)") "Alpha_s from file = ", &
object%use_alphas_from_file
write (u, "(3x,A,L1)") "Scale from file = ", &
object%use_scale_from_file
write (u, "(3x,A,A,A)") "File extension = '", &
char (object%extension), "'"
if (allocated (object%proc_num_id)) then
write (u, "(3x,A)") "Numerical process IDs:"
do i = 1, size (object%proc_num_id)
write (u, "(5x,I0,': ',I0)") i, object%proc_num_id(i)
end do
end if
end subroutine eio_hepmc_write
@ %def eio_hepmc_write
@ Finalizer: close any open file.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: final => eio_hepmc_final
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_final (object)
class(eio_hepmc_t), intent(inout) :: object
if (allocated (object%proc_num_id)) deallocate (object%proc_num_id)
if (object%writing) then
write (msg_buffer, "(A,A,A)") "Events: closing HepMC file '", &
char (object%filename), "'"
call msg_message ()
call hepmc_iostream_close (object%iostream)
object%writing = .false.
else if (object%reading) then
write (msg_buffer, "(A,A,A)") "Events: closing HepMC file '", &
char (object%filename), "'"
call msg_message ()
call hepmc_iostream_close (object%iostream)
object%reading = .false.
end if
end subroutine eio_hepmc_final
@ %def eio_hepmc_final
@ Split event file: increment the counter, close the current file, open a new
one. If the file needs a header, repeat it for the new file.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: split_out => eio_hepmc_split_out
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_split_out (eio)
class(eio_hepmc_t), intent(inout) :: eio
if (eio%split) then
eio%split_index = eio%split_index + 1
call eio%set_filename ()
write (msg_buffer, "(A,A,A)") "Events: writing to HepMC file '", &
char (eio%filename), "'"
call msg_message ()
call hepmc_iostream_close (eio%iostream)
call hepmc_iostream_open_out (eio%iostream, eio%filename)
end if
end subroutine eio_hepmc_split_out
@ %def eio_hepmc_split_out
@ Common initialization for input and output.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: common_init => eio_hepmc_common_init
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_common_init (eio, sample, data, extension)
class(eio_hepmc_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
if (.not. present (data)) &
call msg_bug ("HepMC initialization: missing data")
eio%data = data
if (data%n_beam /= 2) &
call msg_fatal ("HepMC: defined for scattering processes only")
! We could relax this condition now with weighted hepmc events
if (data%unweighted) then
select case (data%norm_mode)
case (NORM_UNIT)
case default; call msg_fatal &
("HepMC: normalization for unweighted events must be '1'")
end select
end if
eio%sample = sample
if (present (extension)) then
eio%extension = extension
end if
call eio%set_filename ()
allocate (eio%proc_num_id (data%n_proc), source = data%proc_num_id)
end subroutine eio_hepmc_common_init
@ %def eio_hepmc_common_init
@ Initialize event writing.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: init_out => eio_hepmc_init_out
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_init_out (eio, sample, data, success, extension)
class(eio_hepmc_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
call eio%set_splitting (data)
call eio%common_init (sample, data, extension)
write (msg_buffer, "(A,A,A)") "Events: writing to HepMC file '", &
char (eio%filename), "'"
call msg_message ()
eio%writing = .true.
call hepmc_iostream_open_out (eio%iostream, eio%filename)
if (present (success)) success = .true.
end subroutine eio_hepmc_init_out
@ %def eio_hepmc_init_out
@ Initialize event reading. For input, we do not (yet) support split
event files.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: init_in => eio_hepmc_init_in
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_init_in (eio, sample, data, success, extension)
class(eio_hepmc_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
logical :: exist
eio%split = .false.
call eio%common_init (sample, data, extension)
write (msg_buffer, "(A,A,A)") "Events: reading from HepMC file '", &
char (eio%filename), "'"
call msg_message ()
inquire (file = char (eio%filename), exist = exist)
if (.not. exist) call msg_fatal ("Events: HepMC file not found.")
eio%reading = .true.
call hepmc_iostream_open_in (eio%iostream, eio%filename)
if (present (success)) success = .true.
end subroutine eio_hepmc_init_in
@ %def eio_hepmc_init_in
@ Switch from input to output: reopen the file for reading.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: switch_inout => eio_hepmc_switch_inout
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_switch_inout (eio, success)
class(eio_hepmc_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("HepMC: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_hepmc_switch_inout
@ %def eio_hepmc_switch_inout
@ Output an event to the allocated HepMC output stream.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: output => eio_hepmc_output
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_output (eio, event, i_prc, reading, passed, pacify)
class(eio_hepmc_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
type(particle_set_t), pointer :: pset_ptr
if (present (passed)) then
if (.not. passed) return
end if
if (eio%writing) then
pset_ptr => event%get_particle_set_ptr ()
call hepmc_event_init (eio%hepmc_event, &
proc_id = eio%proc_num_id(i_prc), &
event_id = event%get_index ())
if (eio%output_cross_section) then
call hepmc_event_from_particle_set (eio%hepmc_event, pset_ptr, &
eio%data%cross_section(i_prc), eio%data%error(i_prc))
else
call hepmc_event_from_particle_set (eio%hepmc_event, pset_ptr)
end if
call hepmc_event_set_scale (eio%hepmc_event, event%get_fac_scale ())
call hepmc_event_set_alpha_qcd (eio%hepmc_event, event%get_alpha_s ())
if (.not. eio%data%unweighted) &
call hepmc_event_add_weight (eio%hepmc_event, event%weight_prc)
call hepmc_iostream_write_event (eio%iostream, eio%hepmc_event)
call hepmc_event_final (eio%hepmc_event)
else
call eio%write ()
call msg_fatal ("HepMC file is not open for writing")
end if
end subroutine eio_hepmc_output
@ %def eio_hepmc_output
@ Input an event.
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: input_i_prc => eio_hepmc_input_i_prc
procedure :: input_event => eio_hepmc_input_event
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_input_i_prc (eio, i_prc, iostat)
class(eio_hepmc_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
logical :: ok
integer :: i, proc_num_id
iostat = 0
call hepmc_event_init (eio%hepmc_event)
call hepmc_iostream_read_event (eio%iostream, eio%hepmc_event, ok)
proc_num_id = hepmc_event_get_process_id (eio%hepmc_event)
if (.not. ok) then
iostat = -1
return
end if
i_prc = 0
FIND_I_PRC: do i = 1, size (eio%proc_num_id)
if (eio%proc_num_id(i) == proc_num_id) then
i_prc = i
exit FIND_I_PRC
end if
end do FIND_I_PRC
if (i_prc == 0) call err_index
contains
subroutine err_index
call msg_error ("HepMC: reading events: undefined process ID " &
// char (str (proc_num_id)) // ", aborting read")
iostat = 1
end subroutine err_index
end subroutine eio_hepmc_input_i_prc
subroutine eio_hepmc_input_event (eio, event, iostat)
class(eio_hepmc_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
iostat = 0
call event%reset_contents ()
call event%select (1, 1, 1)
call hepmc_to_event (event, eio%hepmc_event, &
eio%fallback_model, &
recover_beams = eio%recover_beams, &
use_alpha_s = eio%use_alphas_from_file, &
use_scale = eio%use_scale_from_file)
call hepmc_event_final (eio%hepmc_event)
end subroutine eio_hepmc_input_event
@ %def eio_hepmc_input_i_prc
@ %def eio_hepmc_input_event
@
<<EIO HepMC: eio hepmc: TBP>>=
procedure :: skip => eio_hepmc_skip
<<EIO HepMC: procedures>>=
subroutine eio_hepmc_skip (eio, iostat)
class(eio_hepmc_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_hepmc_skip
@ %def eio_hepmc_skip
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_hepmc_ut.f90]]>>=
<<File header>>
module eio_hepmc_ut
use unit_tests
use eio_hepmc_uti
<<Standard module head>>
<<EIO HepMC: public test>>
contains
<<EIO HepMC: test driver>>
end module eio_hepmc_ut
@ %def eio_hepmc_ut
@
<<[[eio_hepmc_uti.f90]]>>=
<<File header>>
module eio_hepmc_uti
<<Use kinds>>
<<Use strings>>
use io_units
use model_data
use event_base
use eio_data
use eio_base
use eio_hepmc
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
use eio_base_ut, only: eio_prepare_fallback_model, eio_cleanup_fallback_model
<<Standard module head>>
<<EIO HepMC: test declarations>>
contains
<<EIO HepMC: tests>>
end module eio_hepmc_uti
@ %def eio_hepmc_ut
@ API: driver for the unit tests below.
<<EIO HepMC: public test>>=
public :: eio_hepmc_test
<<EIO HepMC: test driver>>=
subroutine eio_hepmc_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO HepMC: execute tests>>
end subroutine eio_hepmc_test
@ %def eio_hepmc_test
@
\subsubsection{Test I/O methods}
We test the implementation of all I/O methods.
<<EIO HepMC: execute tests>>=
call test (eio_hepmc_1, "eio_hepmc_1", &
"write event contents", &
u, results)
<<EIO HepMC: test declarations>>=
public :: eio_hepmc_1
<<EIO HepMC: tests>>=
subroutine eio_hepmc_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat
character(116) :: buffer
write (u, "(A)") "* Test output: eio_hepmc_1"
write (u, "(A)") "* Purpose: write a HepMC file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event, unweighted=.false.)
call data%init (1)
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_hepmc_1"
allocate (eio_hepmc_t :: eio)
select type (eio)
type is (eio_hepmc_t)
call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (55)
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* File contents (blanking out last two digits):"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = char (sample // ".hepmc"), &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
if (trim (buffer) == "") cycle
if (buffer(1:14) == "HepMC::Version") cycle
if (buffer(1:10) == "P 10001 25") &
call buffer_blanker (buffer, 32, 55, 78)
if (buffer(1:10) == "P 10002 25") &
call buffer_blanker (buffer, 33, 56, 79)
if (buffer(1:10) == "P 10003 25") &
call buffer_blanker (buffer, 29, 53, 78, 101)
if (buffer(1:10) == "P 10004 25") &
call buffer_blanker (buffer, 28, 51, 76, 99)
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_hepmc_t :: eio)
select type (eio)
type is (eio_hepmc_t)
call eio%set_parameters ()
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_hepmc_1"
contains
subroutine buffer_blanker (buf, pos1, pos2, pos3, pos4)
character(len=*), intent(inout) :: buf
integer, intent(in) :: pos1, pos2, pos3
integer, intent(in), optional :: pos4
type(string_t) :: line
line = var_str (trim (buf))
line = replace (line, pos1, "XX")
line = replace (line, pos2, "XX")
line = replace (line, pos3, "XX")
if (present (pos4)) then
line = replace (line, pos4, "XX")
end if
line = replace (line, "4999999999999", "5000000000000")
buf = char (line)
end subroutine buffer_blanker
end subroutine eio_hepmc_1
@ %def eio_hepmc_1
@ Test also the reading of HepMC events.
<<EIO HepMC: execute tests>>=
call test (eio_hepmc_2, "eio_hepmc_2", &
"read event contents", &
u, results)
<<EIO HepMC: test declarations>>=
public :: eio_hepmc_2
<<EIO HepMC: tests>>=
subroutine eio_hepmc_2 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: fallback_model
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: u_file, iostat, i_prc
write (u, "(A)") "* Test output: eio_hepmc_2"
write (u, "(A)") "* Purpose: read a HepMC event"
write (u, "(A)")
write (u, "(A)") "* Write a HepMC data file"
write (u, "(A)")
u_file = free_unit ()
sample = "eio_hepmc_2"
open (u_file, file = char (sample // ".hepmc"), &
status = "replace", action = "readwrite")
write (u_file, "(A)") "HepMC::Version 2.06.09"
write (u_file, "(A)") "HepMC::IO_GenEvent-START_EVENT_LISTING"
write (u_file, "(A)") "E 66 -1 -1.0000000000000000e+00 &
&-1.0000000000000000e+00 &
&-1.0000000000000000e+00 42 0 1 10001 10002 0 0"
write (u_file, "(A)") "U GEV MM"
write (u_file, "(A)") "V -1 0 0 0 0 0 2 2 0"
write (u_file, "(A)") "P 10001 25 0 0 4.8412291827592713e+02 &
&5.0000000000000000e+02 &
&1.2499999999999989e+02 3 0 0 -1 0"
write (u_file, "(A)") "P 10002 25 0 0 -4.8412291827592713e+02 &
&5.0000000000000000e+02 &
&1.2499999999999989e+02 3 0 0 -1 0"
write (u_file, "(A)") "P 10003 25 -1.4960220911365536e+02 &
&-4.6042825611414656e+02 &
&0 5.0000000000000000e+02 1.2500000000000000e+02 1 0 0 0 0"
write (u_file, "(A)") "P 10004 25 1.4960220911365536e+02 &
&4.6042825611414656e+02 &
&0 5.0000000000000000e+02 1.2500000000000000e+02 1 0 0 0 0"
write (u_file, "(A)") "HepMC::IO_GenEvent-END_EVENT_LISTING"
close (u_file)
write (u, "(A)") "* Initialize test process"
write (u, "(A)")
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event, unweighted=.false.)
allocate (eio_hepmc_t :: eio)
select type (eio)
type is (eio_hepmc_t)
call eio%set_parameters (recover_beams = .false.)
end select
call eio%set_fallback_model (fallback_model)
call data%init (1)
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
call data%write (u)
write (u, "(A)")
write (u, "(A)") "* Initialize"
write (u, "(A)")
call eio%init_in (sample, data)
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Read event"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
select type (eio)
type is (eio_hepmc_t)
write (u, "(A,I0,A,I0)") "Found process #", i_prc, &
" with ID = ", eio%proc_num_id(i_prc)
end select
call eio%input_event (event, iostat)
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Read closing"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
write (u, "(A,I0)") "iostat = ", iostat
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_hepmc_2"
end subroutine eio_hepmc_2
@ %def eio_hepmc_2
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{LCIO Output}
The LCIO event record is standardized for the use with Linear $e^+e^-$
colliders. It is a binary event format. We try our best at using it
for both input and output.
<<[[eio_lcio.f90]]>>=
<<File header>>
module eio_lcio
<<Use strings>>
use io_units
use string_utils
use diagnostics
use particles
use event_base
use hep_events
use eio_data
use eio_base
use lcio_interface
<<Standard module head>>
<<EIO LCIO: public>>
<<EIO LCIO: types>>
contains
<<EIO LCIO: procedures>>
end module eio_lcio
@ %def eio_lcio
@
\subsection{Type}
A type [[lcio_event]] is introduced as container to store LCIO event
data, particularly for splitting the reading into read out of the process
index and the proper event data.
Note: the [[keep_beams]] flag is not supported.
<<EIO LCIO: public>>=
public :: eio_lcio_t
<<EIO LCIO: types>>=
type, extends (eio_t) :: eio_lcio_t
logical :: writing = .false.
logical :: reading = .false.
type(event_sample_data_t) :: data
logical :: recover_beams = .false.
logical :: use_alphas_from_file = .false.
logical :: use_scale_from_file = .false.
type(lcio_writer_t) :: lcio_writer
type(lcio_reader_t) :: lcio_reader
type(lcio_run_header_t) :: lcio_run_hdr
type(lcio_event_t) :: lcio_event
integer, dimension(:), allocatable :: proc_num_id
contains
<<EIO LCIO: eio lcio: TBP>>
end type eio_lcio_t
@ %def eio_lcio_t
@
\subsection{Specific Methods}
Set parameters that are specifically used with LCIO.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: set_parameters => eio_lcio_set_parameters
<<EIO LCIO: procedures>>=
subroutine eio_lcio_set_parameters &
(eio, recover_beams, use_alphas_from_file, use_scale_from_file, &
extension)
class(eio_lcio_t), intent(inout) :: eio
logical, intent(in), optional :: recover_beams
logical, intent(in), optional :: use_alphas_from_file
logical, intent(in), optional :: use_scale_from_file
type(string_t), intent(in), optional :: extension
if (present (recover_beams)) eio%recover_beams = recover_beams
if (present (use_alphas_from_file)) &
eio%use_alphas_from_file = use_alphas_from_file
if (present (use_scale_from_file)) &
eio%use_scale_from_file = use_scale_from_file
if (present (extension)) then
eio%extension = extension
else
eio%extension = "slcio"
end if
end subroutine eio_lcio_set_parameters
@ %def eio_lcio_set_parameters
@
\subsection{Common Methods}
Output. This is not the actual event format, but a readable account
of the current object status.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: write => eio_lcio_write
<<EIO LCIO: procedures>>=
subroutine eio_lcio_write (object, unit)
class(eio_lcio_t), intent(in) :: object
integer, intent(in), optional :: unit
integer :: u, i
u = given_output_unit (unit)
write (u, "(1x,A)") "LCIO event stream:"
if (object%writing) then
write (u, "(3x,A,A)") "Writing to file = ", char (object%filename)
else if (object%reading) then
write (u, "(3x,A,A)") "Reading from file = ", char (object%filename)
else
write (u, "(3x,A)") "[closed]"
end if
write (u, "(3x,A,L1)") "Recover beams = ", object%recover_beams
write (u, "(3x,A,L1)") "Alpha_s from file = ", &
object%use_alphas_from_file
write (u, "(3x,A,L1)") "Scale from file = ", &
object%use_scale_from_file
write (u, "(3x,A,A,A)") "File extension = '", &
char (object%extension), "'"
if (allocated (object%proc_num_id)) then
write (u, "(3x,A)") "Numerical process IDs:"
do i = 1, size (object%proc_num_id)
write (u, "(5x,I0,': ',I0)") i, object%proc_num_id(i)
end do
end if
end subroutine eio_lcio_write
@ %def eio_lcio_write
@ Finalizer: close any open file.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: final => eio_lcio_final
<<EIO LCIO: procedures>>=
subroutine eio_lcio_final (object)
class(eio_lcio_t), intent(inout) :: object
if (allocated (object%proc_num_id)) deallocate (object%proc_num_id)
if (object%writing) then
write (msg_buffer, "(A,A,A)") "Events: closing LCIO file '", &
char (object%filename), "'"
call msg_message ()
call lcio_writer_close (object%lcio_writer)
object%writing = .false.
else if (object%reading) then
write (msg_buffer, "(A,A,A)") "Events: closing LCIO file '", &
char (object%filename), "'"
call msg_message ()
call lcio_reader_close (object%lcio_reader)
object%reading = .false.
end if
end subroutine eio_lcio_final
@ %def eio_lcio_final
@ Split event file: increment the counter, close the current file, open a new
one. If the file needs a header, repeat it for the new file.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: split_out => eio_lcio_split_out
<<EIO LCIO: procedures>>=
subroutine eio_lcio_split_out (eio)
class(eio_lcio_t), intent(inout) :: eio
if (eio%split) then
eio%split_index = eio%split_index + 1
call eio%set_filename ()
write (msg_buffer, "(A,A,A)") "Events: writing to LCIO file '", &
char (eio%filename), "'"
call msg_message ()
call lcio_writer_close (eio%lcio_writer)
call lcio_writer_open_out (eio%lcio_writer, eio%filename)
end if
end subroutine eio_lcio_split_out
@ %def eio_lcio_split_out
@ Common initialization for input and output.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: common_init => eio_lcio_common_init
<<EIO LCIO: procedures>>=
subroutine eio_lcio_common_init (eio, sample, data, extension)
class(eio_lcio_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
if (.not. present (data)) &
call msg_bug ("LCIO initialization: missing data")
eio%data = data
if (data%n_beam /= 2) &
call msg_fatal ("LCIO: defined for scattering processes only")
if (data%unweighted) then
select case (data%norm_mode)
case (NORM_UNIT)
case default; call msg_fatal &
("LCIO: normalization for unweighted events must be '1'")
end select
else
call msg_fatal ("LCIO: events must be unweighted")
end if
eio%sample = sample
if (present (extension)) then
eio%extension = extension
end if
call eio%set_filename ()
allocate (eio%proc_num_id (data%n_proc), source = data%proc_num_id)
end subroutine eio_lcio_common_init
@ %def eio_lcio_common_init
@ Initialize event writing.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: init_out => eio_lcio_init_out
<<EIO LCIO: procedures>>=
subroutine eio_lcio_init_out (eio, sample, data, success, extension)
class(eio_lcio_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(in), optional :: data
logical, intent(out), optional :: success
call eio%set_splitting (data)
call eio%common_init (sample, data, extension)
write (msg_buffer, "(A,A,A)") "Events: writing to LCIO file '", &
char (eio%filename), "'"
call msg_message ()
eio%writing = .true.
call lcio_writer_open_out (eio%lcio_writer, eio%filename)
call lcio_run_header_init (eio%lcio_run_hdr)
call lcio_run_header_write (eio%lcio_writer, eio%lcio_run_hdr)
if (present (success)) success = .true.
end subroutine eio_lcio_init_out
@ %def eio_lcio_init_out
@ Initialize event reading. For input, we do not (yet) support split
event files.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: init_in => eio_lcio_init_in
<<EIO LCIO: procedures>>=
subroutine eio_lcio_init_in (eio, sample, data, success, extension)
class(eio_lcio_t), intent(inout) :: eio
type(string_t), intent(in) :: sample
type(string_t), intent(in), optional :: extension
type(event_sample_data_t), intent(inout), optional :: data
logical, intent(out), optional :: success
logical :: exist
eio%split = .false.
call eio%common_init (sample, data, extension)
write (msg_buffer, "(A,A,A)") "Events: reading from LCIO file '", &
char (eio%filename), "'"
call msg_message ()
inquire (file = char (eio%filename), exist = exist)
if (.not. exist) call msg_fatal ("Events: LCIO file not found.")
eio%reading = .true.
call lcio_open_file (eio%lcio_reader, eio%filename)
if (present (success)) success = .true.
end subroutine eio_lcio_init_in
@ %def eio_lcio_init_in
@ Switch from input to output: reopen the file for reading.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: switch_inout => eio_lcio_switch_inout
<<EIO LCIO: procedures>>=
subroutine eio_lcio_switch_inout (eio, success)
class(eio_lcio_t), intent(inout) :: eio
logical, intent(out), optional :: success
call msg_bug ("LCIO: in-out switch not supported")
if (present (success)) success = .false.
end subroutine eio_lcio_switch_inout
@ %def eio_lcio_switch_inout
@ Output an event to the allocated LCIO writer.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: output => eio_lcio_output
<<EIO LCIO: procedures>>=
subroutine eio_lcio_output (eio, event, i_prc, reading, passed, pacify)
class(eio_lcio_t), intent(inout) :: eio
class(generic_event_t), intent(in), target :: event
integer, intent(in) :: i_prc
logical, intent(in), optional :: reading, passed, pacify
type(particle_set_t), pointer :: pset_ptr
if (present (passed)) then
if (.not. passed) return
end if
if (eio%writing) then
pset_ptr => event%get_particle_set_ptr ()
call lcio_event_init (eio%lcio_event, &
proc_id = eio%proc_num_id (i_prc), &
event_id = event%get_index ())
call lcio_event_from_particle_set (eio%lcio_event, pset_ptr)
call lcio_event_set_weight (eio%lcio_event, event%weight_prc)
call lcio_event_set_sqrts (eio%lcio_event, event%get_sqrts ())
call lcio_event_set_scale (eio%lcio_event, event%get_fac_scale ())
call lcio_event_set_alpha_qcd (eio%lcio_event, event%get_alpha_s ())
call lcio_event_set_xsec (eio%lcio_event, eio%data%cross_section(i_prc), &
eio%data%error(i_prc))
call lcio_event_set_polarization (eio%lcio_event, &
event%get_polarization ())
call lcio_event_set_beam_file (eio%lcio_event, &
event%get_beam_file ())
call lcio_event_set_process_name (eio%lcio_event, &
event%get_process_name ())
call lcio_event_write (eio%lcio_writer, eio%lcio_event)
call lcio_event_final (eio%lcio_event)
else
call eio%write ()
call msg_fatal ("LCIO file is not open for writing")
end if
end subroutine eio_lcio_output
@ %def eio_lcio_output
@ Input an event.
<<EIO LCIO: eio lcio: TBP>>=
procedure :: input_i_prc => eio_lcio_input_i_prc
procedure :: input_event => eio_lcio_input_event
<<EIO LCIO: procedures>>=
subroutine eio_lcio_input_i_prc (eio, i_prc, iostat)
class(eio_lcio_t), intent(inout) :: eio
integer, intent(out) :: i_prc
integer, intent(out) :: iostat
logical :: ok
integer :: i, proc_num_id
iostat = 0
call lcio_read_event (eio%lcio_reader, eio%lcio_event, ok)
if (.not. ok) then
iostat = -1
return
end if
proc_num_id = lcio_event_get_process_id (eio%lcio_event)
i_prc = 0
FIND_I_PRC: do i = 1, size (eio%proc_num_id)
if (eio%proc_num_id(i) == proc_num_id) then
i_prc = i
exit FIND_I_PRC
end if
end do FIND_I_PRC
if (i_prc == 0) call err_index
contains
subroutine err_index
call msg_error ("LCIO: reading events: undefined process ID " &
// char (str (proc_num_id)) // ", aborting read")
iostat = 1
end subroutine err_index
end subroutine eio_lcio_input_i_prc
subroutine eio_lcio_input_event (eio, event, iostat)
class(eio_lcio_t), intent(inout) :: eio
class(generic_event_t), intent(inout), target :: event
integer, intent(out) :: iostat
iostat = 0
call event%reset_contents ()
call event%select (1, 1, 1)
call event%set_index (lcio_event_get_event_index (eio%lcio_event))
call lcio_to_event (event, eio%lcio_event, eio%fallback_model, &
recover_beams = eio%recover_beams, &
use_alpha_s = eio%use_alphas_from_file, &
use_scale = eio%use_scale_from_file)
call lcio_event_final (eio%lcio_event)
end subroutine eio_lcio_input_event
@ %def eio_lcio_input_i_prc
@ %def eio_lcio_input_event
@
<<EIO LCIO: eio lcio: TBP>>=
procedure :: skip => eio_lcio_skip
<<EIO LCIO: procedures>>=
subroutine eio_lcio_skip (eio, iostat)
class(eio_lcio_t), intent(inout) :: eio
integer, intent(out) :: iostat
iostat = 0
end subroutine eio_lcio_skip
@ %def eio_lcio_skip
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[eio_lcio_ut.f90]]>>=
<<File header>>
module eio_lcio_ut
use unit_tests
use eio_lcio_uti
<<Standard module head>>
<<EIO LCIO: public test>>
contains
<<EIO LCIO: test driver>>
end module eio_lcio_ut
@ %def eio_lcio_ut
@
<<[[eio_lcio_uti.f90]]>>=
<<File header>>
module eio_lcio_uti
<<Use kinds>>
<<Use strings>>
use io_units
use model_data
use particles
use event_base
use eio_data
use eio_base
use hep_events
use lcio_interface
use eio_lcio
use eio_base_ut, only: eio_prepare_test, eio_cleanup_test
use eio_base_ut, only: eio_prepare_fallback_model, eio_cleanup_fallback_model
<<Standard module head>>
<<EIO LCIO: test declarations>>
contains
<<EIO LCIO: tests>>
end module eio_lcio_uti
@ %def eio_lcio_ut
@ API: driver for the unit tests below.
<<EIO LCIO: public test>>=
public :: eio_lcio_test
<<EIO LCIO: test driver>>=
subroutine eio_lcio_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<EIO LCIO: execute tests>>
end subroutine eio_lcio_test
@ %def eio_lcio_test
@
\subsubsection{Test I/O methods}
We test the implementation of all I/O methods.
<<EIO LCIO: execute tests>>=
call test (eio_lcio_1, "eio_lcio_1", &
"write event contents", &
u, results)
<<EIO LCIO: test declarations>>=
public :: eio_lcio_1
<<EIO LCIO: tests>>=
subroutine eio_lcio_1 (u)
integer, intent(in) :: u
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(particle_set_t), pointer :: pset_ptr
type(string_t) :: sample
integer :: u_file, iostat
character(215) :: buffer
write (u, "(A)") "* Test output: eio_lcio_1"
write (u, "(A)") "* Purpose: write a LCIO file"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_test (event)
call data%init (1)
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_lcio_1"
allocate (eio_lcio_t :: eio)
select type (eio)
type is (eio_lcio_t)
call eio%set_parameters ()
end select
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (77)
call event%pacify_particle_set ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
write (u, "(A)")
write (u, "(A)") "* Reset data"
write (u, "(A)")
deallocate (eio)
allocate (eio_lcio_t :: eio)
select type (eio)
type is (eio_lcio_t)
call eio%set_parameters ()
end select
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Write LCIO file contents to ASCII file"
write (u, "(A)")
select type (eio)
type is (eio_lcio_t)
call lcio_event_init (eio%lcio_event, &
proc_id = 42, &
event_id = event%get_index ())
pset_ptr => event%get_particle_set_ptr ()
call lcio_event_from_particle_set &
(eio%lcio_event, pset_ptr)
call write_lcio_event (eio%lcio_event, var_str ("test_file.slcio"))
call lcio_event_final (eio%lcio_event)
end select
write (u, "(A)")
write (u, "(A)") "* Read in ASCII contents of LCIO file"
write (u, "(A)")
u_file = free_unit ()
open (u_file, file = "test_file.slcio", &
action = "read", status = "old")
do
read (u_file, "(A)", iostat = iostat) buffer
if (iostat /= 0) exit
if (trim (buffer) == "") cycle
if (buffer(1:12) == " - timestamp") cycle
if (buffer(1:6) == " date:") cycle
write (u, "(A)") trim (buffer)
end do
close (u_file)
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio_cleanup_test (event)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_lcio_1"
end subroutine eio_lcio_1
@ %def eio_lcio_1
@ Test also the reading of LCIO events.
<<EIO LCIO: execute tests>>=
call test (eio_lcio_2, "eio_lcio_2", &
"read event contents", &
u, results)
<<EIO LCIO: test declarations>>=
public :: eio_lcio_2
<<EIO LCIO: tests>>=
subroutine eio_lcio_2 (u)
integer, intent(in) :: u
class(model_data_t), pointer :: fallback_model
class(generic_event_t), pointer :: event
type(event_sample_data_t) :: data
class(eio_t), allocatable :: eio
type(string_t) :: sample
integer :: iostat, i_prc
write (u, "(A)") "* Test output: eio_lcio_2"
write (u, "(A)") "* Purpose: read a LCIO event"
write (u, "(A)")
write (u, "(A)") "* Initialize test process"
call eio_prepare_fallback_model (fallback_model)
call eio_prepare_test (event)
call data%init (1)
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
data%cross_section(1) = 100
data%error(1) = 1
data%total_cross_section = sum (data%cross_section)
write (u, "(A)")
write (u, "(A)") "* Generate and write an event"
write (u, "(A)")
sample = "eio_lcio_2"
allocate (eio_lcio_t :: eio)
select type (eio)
type is (eio_lcio_t)
call eio%set_parameters (recover_beams = .false.)
end select
call eio%set_fallback_model (fallback_model)
call eio%init_out (sample, data)
call event%generate (1, [0._default, 0._default])
call event%set_index (88)
call event%evaluate_expressions ()
call event%pacify_particle_set ()
call eio%output (event, i_prc = 1)
call eio%write (u)
call eio%final ()
deallocate (eio)
call event%reset_contents ()
call event%reset_index ()
write (u, "(A)")
write (u, "(A)") "* Initialize"
write (u, "(A)")
allocate (eio_lcio_t :: eio)
select type (eio)
type is (eio_lcio_t)
call eio%set_parameters (recover_beams = .false.)
end select
call eio%set_fallback_model (fallback_model)
call data%init (1)
data%n_beam = 2
data%unweighted = .true.
data%norm_mode = NORM_UNIT
data%pdg_beam = 25
data%energy_beam = 500
data%proc_num_id = [42]
call data%write (u)
write (u, *)
write (u, "(A)") "* Initialize"
write (u, "(A)")
call eio%init_in (sample, data)
call eio%write (u)
write (u, "(A)")
write (u, "(A)") "* Read event"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
select type (eio)
type is (eio_lcio_t)
write (u, "(A,I0,A,I0)") "Found process #", i_prc, &
" with ID = ", eio%proc_num_id(i_prc)
end select
call eio%input_event (event, iostat)
call event%write (u)
write (u, "(A)")
write (u, "(A)") "* Read closing"
write (u, "(A)")
call eio%input_i_prc (i_prc, iostat)
write (u, "(A,I0)") "iostat = ", iostat
write (u, "(A)")
write (u, "(A)") "* Cleanup"
call eio%final ()
call eio_cleanup_test (event)
call eio_cleanup_fallback_model (fallback_model)
write (u, "(A)")
write (u, "(A)") "* Test output end: eio_lcio_2"
end subroutine eio_lcio_2
@ %def eio_lcio_2
Index: trunk/src/shower/shower.nw
===================================================================
--- trunk/src/shower/shower.nw (revision 8177)
+++ trunk/src/shower/shower.nw (revision 8178)
@@ -1,8297 +1,8296 @@
% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*-
% WHIZARD shower code as NOWEB source
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Parton shower and interface to PYTHIA6}
\includemodulegraph{shower}
This is the code for the \whizard\ QCD parton shower for final state
radiation (FSR) and initial state radiation (ISR) as well as the interface
to the \pythia\ module for showering and hadronization.
\section{Basics of the shower}
<<[[shower_base.f90]]>>=
<<File header>>
module shower_base
<<Use kinds>>
<<Use strings>>
use io_units
use constants
use diagnostics
use format_utils, only: write_separator
use lorentz
use particles
use os_interface
use rng_base
use physics_defs
use sm_physics, only: running_as_lam
use particles
use variables
use model_data
use pdf
use tauola_interface
<<Standard module head>>
<<Shower base: public>>
<<Shower base: parameters>>
<<Shower base: types>>
<<Shower base: interfaces>>
contains
<<Shower base: procedures>>
end module shower_base
@ %def shower_base
@
\subsection{Shower implementations}
<<Shower base: public>>=
public :: PS_WHIZARD, PS_PYTHIA6, PS_PYTHIA8, PS_UNDEFINED
<<Shower base: parameters>>=
integer, parameter :: PS_UNDEFINED = 0
integer, parameter :: PS_WHIZARD = 1
integer, parameter :: PS_PYTHIA6 = 2
integer, parameter :: PS_PYTHIA8 = 3
@ %def PS_UNDEFINED PS_WHIZARD PS_PYTHIA6 PS_PYTHIA8
@ A dictionary
<<Shower base: public>>=
public :: shower_method_of_string
<<Shower base: procedures>>=
elemental function shower_method_of_string (string) result (i)
integer :: i
type(string_t), intent(in) :: string
select case (char(string))
case ("WHIZARD")
i = PS_WHIZARD
case ("PYTHIA6")
i = PS_PYTHIA6
case ("PYTHIA8")
i = PS_PYTHIA8
case default
i = PS_UNDEFINED
end select
end function shower_method_of_string
@ %def shower_method_of_string
@
<<Shower base: public>>=
public :: shower_method_to_string
<<Shower base: procedures>>=
elemental function shower_method_to_string (i) result (string)
type(string_t) :: string
integer, intent(in) :: i
select case (i)
case (PS_WHIZARD)
string = "WHIZARD"
case (PS_PYTHIA6)
string = "PYTHIA6"
case (PS_PYTHIA8)
string = "PYTHIA8"
case default
string = "UNDEFINED"
end select
end function shower_method_to_string
@ %def shower_method_to_string
@
\subsection{Shower settings}
These the general shower settings, the settings and parameters for the
matching are defined in the corresponding matching modules. The width
and the cutoff of the Gaussian primordial $k_t$ distribution,
[[PARP(91)]] and [[PARP(93)]], in GeV, are called
[[isr_primordial_kt_width]] and [[isr_primordial_kt_cutoff]] in \whizard.
The parameter [[MSTJ(45)]] gives the maximum number of flavors in
gluon decay to quarks, and is here called [[max_n_flavors]].
The two parameters [[isr_alphas_running] and [[fsr_alphas_running]]
decide whether to use constant or running
$alpha_s$ in the form of the function $D\_{alpha_s} (t)$ for the FSR
and ISR ([[MSTJ(44)]], [[MSTP(64)]]), respectively. The next
parameter, [[fixed_alpha_s]] is the parameter [[PARU(111)]], which
sets the value for constant $\alpha_s$, and the flag whether to use
$P_t$-ordered ISR is [[isr_pt_ordered]]. From the entry [[min_voirtuality]]
on, parameters have meanings both for the \pythia\ and
\whizard\ parton shower(s), where \pythia\ values are denoted at the
end of the line.
<<Shower base: public>>=
public :: shower_settings_t
<<Shower base: types>>=
type :: shower_settings_t
logical :: active = .false.
logical :: isr_active = .false.
logical :: fsr_active = .false.
logical :: muli_active = .false.
logical :: hadronization_active = .false.
logical :: tau_dec = .false.
logical :: verbose = .false.
integer :: method = PS_UNDEFINED
logical :: hadron_collision = .false.
logical :: mlm_matching = .false.
logical :: ckkw_matching = .false.
logical :: powheg_matching = .false.
type(string_t) :: pythia6_pygive
real(default) :: min_virtuality = 1._default ! PARJ(82)^2
real(default) :: fsr_lambda = 0.29_default ! PARP(72)
real(default) :: isr_lambda = 0.29_default ! PARP(61)
integer :: max_n_flavors = 5 ! MSTJ(45)
logical :: isr_alphas_running = .true. ! MSTP(64)
logical :: fsr_alphas_running = .true. ! MSTJ(44)
real(default) :: fixed_alpha_s = 0.2_default ! PARU(111)
logical :: alpha_s_fudged = .true.
logical :: isr_pt_ordered = .false.
logical :: isr_angular_ordered = .true. ! MSTP(62)
real(default) :: isr_primordial_kt_width = 1.5_default ! PARP(91)
real(default) :: isr_primordial_kt_cutoff = 5._default ! PARP(93)
real(default) :: isr_z_cutoff = 0.999_default ! 1-PARP(66)
real(default) :: isr_minenergy = 2._default ! PARP(65)
real(default) :: isr_tscalefactor = 1._default
logical :: isr_only_onshell_emitted_partons = .true. ! MSTP(63)
contains
<<Shower base: shower settings: TBP>>
end type shower_settings_t
@ %def shower_settings_t
@ Read in the shower settings (and flags whether matching and
hadronization are switched on).
<<Shower base: shower settings: TBP>>=
procedure :: init => shower_settings_init
<<Shower base: procedures>>=
subroutine shower_settings_init (settings, var_list)
class(shower_settings_t), intent(out) :: settings
type(var_list_t), intent(in) :: var_list
settings%fsr_active = &
var_list%get_lval (var_str ("?ps_fsr_active"))
settings%isr_active = &
var_list%get_lval (var_str ("?ps_isr_active"))
settings%tau_dec = &
var_list%get_lval (var_str ("?ps_taudec_active"))
settings%muli_active = &
var_list%get_lval (var_str ("?muli_active"))
settings%hadronization_active = &
var_list%get_lval (var_str ("?hadronization_active"))
settings%mlm_matching = &
var_list%get_lval (var_str ("?mlm_matching"))
settings%ckkw_matching = &
var_list%get_lval (var_str ("?ckkw_matching"))
settings%powheg_matching = &
var_list%get_lval (var_str ("?powheg_matching"))
settings%method = shower_method_of_string ( &
var_list%get_sval (var_str ("$shower_method")))
settings%active = settings%isr_active .or. &
settings%fsr_active .or. &
settings%powheg_matching .or. &
settings%muli_active .or. &
settings%hadronization_active
if (.not. settings%active) return
settings%verbose = &
var_list%get_lval (var_str ("?shower_verbose"))
settings%pythia6_pygive = &
var_list%get_sval (var_str ("$ps_PYTHIA_PYGIVE"))
settings%min_virtuality = &
(var_list%get_rval (var_str ("ps_mass_cutoff"))**2)
settings%fsr_lambda = &
var_list%get_rval (var_str ("ps_fsr_lambda"))
settings%isr_lambda = &
var_list%get_rval (var_str ("ps_isr_lambda"))
settings%max_n_flavors = &
var_list%get_ival (var_str ("ps_max_n_flavors"))
settings%isr_alphas_running = &
var_list%get_lval (var_str ("?ps_isr_alphas_running"))
settings%fsr_alphas_running = &
var_list%get_lval (var_str ("?ps_fsr_alphas_running"))
settings%fixed_alpha_s = &
var_list%get_rval (var_str ("ps_fixed_alphas"))
settings%isr_pt_ordered = &
var_list%get_lval (var_str ("?ps_isr_pt_ordered"))
settings%isr_angular_ordered = &
var_list%get_lval (var_str ("?ps_isr_angular_ordered"))
settings%isr_primordial_kt_width = &
var_list%get_rval (var_str ("ps_isr_primordial_kt_width"))
settings%isr_primordial_kt_cutoff = &
var_list%get_rval (var_str ("ps_isr_primordial_kt_cutoff"))
settings%isr_z_cutoff = &
var_list%get_rval (var_str ("ps_isr_z_cutoff"))
settings%isr_minenergy = &
var_list%get_rval (var_str ("ps_isr_minenergy"))
settings%isr_tscalefactor = &
var_list%get_rval (var_str ("ps_isr_tscalefactor"))
settings%isr_only_onshell_emitted_partons = &
var_list%get_lval (&
var_str ("?ps_isr_only_onshell_emitted_partons"))
end subroutine shower_settings_init
@ %def shower_settings_init
@
<<Shower base: shower settings: TBP>>=
procedure :: write => shower_settings_write
<<Shower base: procedures>>=
subroutine shower_settings_write (settings, unit)
class(shower_settings_t), intent(in) :: settings
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "Shower settings:"
call write_separator (u)
write (u, "(1x,A)") "Master switches:"
write (u, "(3x,A,1x,L1)") &
"ps_isr_active = ", settings%isr_active
write (u, "(3x,A,1x,L1)") &
"ps_fsr_active = ", settings%fsr_active
write (u, "(3x,A,1x,L1)") &
"ps_tau_dec = ", settings%tau_dec
write (u, "(3x,A,1x,L1)") &
"muli_active = ", settings%muli_active
write (u, "(3x,A,1x,L1)") &
"hadronization_active = ", settings%hadronization_active
write (u, "(1x,A)") "General settings:"
if (settings%isr_active .or. settings%fsr_active) then
write (u, "(3x,A)") &
"method = " // &
char (shower_method_to_string (settings%method))
write (u, "(3x,A,1x,L1)") &
"shower_verbose = ", settings%verbose
write (u, "(3x,A,ES19.12)") &
"ps_mass_cutoff = ", &
sqrt (abs (settings%min_virtuality))
write (u, "(3x,A,1x,I1)") &
"ps_max_n_flavors = ", settings%max_n_flavors
else
write (u, "(3x,A)") " [ISR and FSR off]"
end if
if (settings%isr_active) then
write (u, "(1x,A)") "ISR settings:"
write (u, "(3x,A,1x,L1)") &
"ps_isr_pt_ordered = ", settings%isr_pt_ordered
write (u, "(3x,A,ES19.12)") &
"ps_isr_lambda = ", settings%isr_lambda
write (u, "(3x,A,1x,L1)") &
"ps_isr_alphas_running = ", settings%isr_alphas_running
write (u, "(3x,A,ES19.12)") &
"ps_isr_primordial_kt_width = ", settings%isr_primordial_kt_width
write (u, "(3x,A,ES19.12)") &
"ps_isr_primordial_kt_cutoff = ", &
settings%isr_primordial_kt_cutoff
write (u, "(3x,A,ES19.12)") &
"ps_isr_z_cutoff = ", settings%isr_z_cutoff
write (u, "(3x,A,ES19.12)") &
"ps_isr_minenergy = ", settings%isr_minenergy
write (u, "(3x,A,ES19.12)") &
"ps_isr_tscalefactor = ", settings%isr_tscalefactor
else if (settings%fsr_active) then
write (u, "(3x,A)") " [ISR off]"
end if
if (settings%fsr_active) then
write (u, "(1x,A)") "FSR settings:"
write (u, "(3x,A,ES19.12)") &
"ps_fsr_lambda = ", settings%fsr_lambda
write (u, "(3x,A,1x,L1)") &
"ps_fsr_alphas_running = ", settings%fsr_alphas_running
else if (settings%isr_active) then
write (u, "(3x,A)") " [FSR off]"
end if
write (u, "(1x,A)") "Matching Settings:"
write (u, "(3x,A,1x,L1)") &
"mlm_matching = ", settings%mlm_matching
write (u, "(3x,A,1x,L1)") &
"ckkw_matching = ", settings%ckkw_matching
write (u, "(1x,A)") "PYTHIA6 specific settings:"
write (u, "(3x,A,A,A)") &
"ps_PYTHIA_PYGIVE = '", &
char(settings%pythia6_pygive), "'"
end subroutine shower_settings_write
@ %def shower_settings_write
@
\subsection{Abstract Shower Type}
Any parton shower implementation will use random numbers to generate
emissions.
<<Shower base: public>>=
public :: shower_base_t
<<Shower base: types>>=
type, abstract :: shower_base_t
class(rng_t), allocatable :: rng
type(string_t) :: name
type(pdf_data_t) :: pdf_data
type(shower_settings_t) :: settings
type(taudec_settings_t) :: taudec_settings
contains
<<Shower base: shower base: TBP>>
end type shower_base_t
@ %def shower_base_t
@
<<Shower base: shower base: TBP>>=
procedure :: write_msg => shower_base_write_msg
<<Shower base: procedures>>=
subroutine shower_base_write_msg (shower)
class(shower_base_t), intent(inout) :: shower
call msg_message ("Shower: Using " // char(shower%name) // " shower")
end subroutine shower_base_write_msg
@ %def shower_base_write_msg
@
<<Shower base: shower base: TBP>>=
procedure :: import_rng => shower_base_import_rng
<<Shower base: procedures>>=
pure subroutine shower_base_import_rng (shower, rng)
class(shower_base_t), intent(inout) :: shower
class(rng_t), intent(inout), allocatable :: rng
call move_alloc (from = rng, to = shower%rng)
end subroutine shower_base_import_rng
@ %def shower_base_import_rng
@ Shower implementations need to know the overall settings as well as
[[pdf_data_t]] if ISR needs to be simulated.
<<Shower base: shower base: TBP>>=
procedure (shower_base_init), deferred :: init
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_init (shower, settings, taudec_settings, pdf_data)
import
class(shower_base_t), intent(out) :: shower
type(shower_settings_t), intent(in) :: settings
type(taudec_settings_t), intent(in) :: taudec_settings
type(pdf_data_t), intent(in) :: pdf_data
end subroutine shower_base_init
end interface
@ %def shower_base_init
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_prepare_new_event), deferred :: prepare_new_event
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_prepare_new_event &
(shower)
import
class(shower_base_t), intent(inout) :: shower
end subroutine shower_base_prepare_new_event
end interface
@ %def shower_base_prepare_new_event
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_import_particle_set), deferred :: import_particle_set
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_import_particle_set &
(shower, particle_set, os_data, scale)
import
class(shower_base_t), target, intent(inout) :: shower
type(particle_set_t), intent(in) :: particle_set
type(os_data_t), intent(in) :: os_data
real(default), intent(in) :: scale
end subroutine shower_base_import_particle_set
end interface
@ %def shower_base_import_particle_set
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_generate_emissions), deferred :: generate_emissions
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_generate_emissions &
(shower, valid, number_of_emissions)
import
class(shower_base_t), intent(inout), target :: shower
logical, intent(out) :: valid
integer, optional, intent(in) :: number_of_emissions
end subroutine shower_base_generate_emissions
end interface
@ %def shower_base_generate_emissions
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_make_particle_set), deferred :: make_particle_set
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_make_particle_set &
(shower, particle_set, model, model_hadrons)
import
class(shower_base_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model
class(model_data_t), intent(in), target :: model_hadrons
end subroutine shower_base_make_particle_set
end interface
@ %def shower_base_make_particle_set
@
<<Shower base: shower base: TBP>>=
procedure (shower_base_get_final_colored_ME_momenta), deferred :: &
get_final_colored_ME_momenta
<<Shower base: interfaces>>=
abstract interface
subroutine shower_base_get_final_colored_ME_momenta &
(shower, momenta)
import
class(shower_base_t), intent(in) :: shower
type(vector4_t), dimension(:), allocatable, intent(out) :: momenta
end subroutine shower_base_get_final_colored_ME_momenta
end interface
@ %def shower_base_get_final_colored_ME_momenta
@
\subsection{Additional parameters}
These parameters are the cut-off scale $t_{\text{cut}}$, given in
GeV$^2$ ([[PARJ(82)]]), the cut-off scale for the $P_t^2$-ordered
shower in GeV$^2$, and the two shower parameters [[PARP(72)]] and
[[PARP(61)]], respectively.
<<Shower base: parameters>>=
real(default), public :: D_min_scale = 0.5_default
@ %def D_min_scale
Treating either $u$ and $d$, or all quarks except $t$ as massless:
<<Shower base: parameters>>=
logical, public :: treat_light_quarks_massless = .true.
logical, public :: treat_duscb_quarks_massless = .false.
@ %def treat_light_quarks_massless
@ %def treat_duscb_quarks_massless
Temporary parameters for the $P_t$-ordered shower:
<<Shower base: parameters>>=
real(default), public :: scalefactor1 = 0.02_default
real(default), public :: scalefactor2 = 0.02_default
@ %def scalefactor1 scalefactor2
@
<<Shower base: public>>=
public :: D_alpha_s_isr
public :: D_alpha_s_fsr
<<Shower base: procedures>>=
function D_alpha_s_isr (tin, settings) result (alpha_s)
real(default), intent(in) :: tin
type(shower_settings_t), intent(in) :: settings
real(default) :: min_virtuality, d_constalpha_s, d_lambda_isr
integer :: d_nf
real(default) :: t
real(default) :: alpha_s
min_virtuality = settings%min_virtuality
d_lambda_isr = settings%isr_lambda
d_constalpha_s = settings%fixed_alpha_s
d_nf = settings%max_n_flavors
if (settings%alpha_s_fudged) then
t = max (max (0.1_default * min_virtuality, &
1.1_default * d_lambda_isr**2), abs(tin))
else
t = abs(tin)
end if
if (settings%isr_alphas_running) then
alpha_s = running_as_lam (number_of_flavors(t, d_nf, min_virtuality), &
sqrt(t), d_lambda_isr, 0)
else
alpha_s = d_constalpha_s
end if
end function D_alpha_s_isr
function D_alpha_s_fsr (tin, settings) result (alpha_s)
real(default), intent(in) :: tin
type(shower_settings_t), intent(in) :: settings
real(default) :: min_virtuality, d_lambda_fsr, d_constalpha_s
integer :: d_nf
real(default) :: t
real(default) :: alpha_s
min_virtuality = settings%min_virtuality
d_lambda_fsr = settings%fsr_lambda
d_constalpha_s = settings%fixed_alpha_s
d_nf = settings%max_n_flavors
if (settings%alpha_s_fudged) then
t = max (max (0.1_default * min_virtuality, &
1.1_default * d_lambda_fsr**2), abs(tin))
else
t = abs(tin)
end if
if (settings%fsr_alphas_running) then
alpha_s = running_as_lam (number_of_flavors (t, d_nf, min_virtuality), &
sqrt(t), d_lambda_fsr, 0)
else
alpha_s = d_constalpha_s
end if
end function D_alpha_s_fsr
@ %def D_alpha_s_isr D_alpha_s_fsr
@ Mass and mass squared selection functions. All masses are in
GeV. Light quarks are assumed to be ordered, $m_1 < m_2 < m_3 \ldots$,
and they get current masses, not elementary ones. Mesons and baryons
other than proton and neutron are needed as beam-remnants. Particles
with PDG number zero are taken massless, as well as proper beam
remnants and any other particles.
<<Shower base: public>>=
public :: mass_type
public :: mass_squared_type
<<Shower base: procedures>>=
elemental function mass_type (type, m2_default) result (mass)
integer, intent(in) :: type
real(default), intent(in) :: m2_default
real(default) :: mass
mass = sqrt (mass_squared_type (type, m2_default))
end function mass_type
elemental function mass_squared_type (type, m2_default) result (mass2)
integer, intent(in) :: type
real(default), intent(in) :: m2_default
real(default) :: mass2
select case (abs (type))
!!! case (1,2)
!!! if (treat_light_quarks_massless .or. &
!!! treat_duscb_quarks_massless) then
!!! mass2 = zero
!!! else
!!! mass2 = 0.330_default**2
!!! end if
!!! case (3)
!!! if (treat_duscb_quarks_massless) then
!!! mass2 = zero
!!! else
!!! mass2 = 0.500_default**2
!!! end if
!!! case (4)
!!! if (treat_duscb_quarks_massless) then
!!! mass2 = zero
!!! else
!!! mass2 = 1.500_default**2
!!! end if
!!! case (5)
!!! if (treat_duscb_quarks_massless) then
!!! mass2 = zero
!!! else
!!! mass2 = 4.800_default**2
!!! end if
!!! case (GLUON)
!!! mass2 = zero
case (NEUTRON)
mass2 = 0.939565_default**2
case (PROTON)
mass2 = 0.93827_default**2
case (DPLUS)
mass2 = 1.86960_default**2
case (D0)
mass2 = 1.86483_default**2
case (B0)
mass2 = 5.27950_default**2
case (BPLUS)
mass2 = 5.27917_default**2
case (DELTAPLUSPLUS)
mass2 = 1.232_default**2
case (SIGMA0)
mass2 = 1.192642_default**2
case (SIGMAPLUS)
mass2 = 1.18937_default**2
case (SIGMACPLUS)
mass2 = 2.4529_default**2
case (SIGMACPLUSPLUS)
mass2 = 2.45402_default**2
case (SIGMAB0)
mass2 = 5.8152_default**2
case (SIGMABPLUS)
mass2 = 5.8078_default**2
case (BEAM_REMNANT)
mass2 = zero !!! don't know how to handle the beamremnant
case default
mass2 = m2_default
end select
end function mass_squared_type
@ %def mass_type mass_squared_type
@ The number of flavors active at a certain scale (virtuality) $t$.
<<Shower base: public>>=
public :: number_of_flavors
<<Shower base: procedures>>=
elemental function number_of_flavors (t, d_nf, min_virtuality) result (nr)
real(default), intent(in) :: t, min_virtuality
integer, intent(in) :: d_nf
real(default) :: nr
integer :: i
nr = 0
if (t < min_virtuality) return ! arbitrary cut off
! TODO: do i = 1, min (max (3, d_nf), 6)
do i = 1, min (3, d_nf)
!!! to do: take heavier quarks(-> cuts on allowed costheta in g->qq)
!!! into account
if ((four * mass_squared_type (i, zero) + min_virtuality) < t ) then
nr = i
else
exit
end if
end do
end function number_of_flavors
@ %def number_of_flavors
@
\subsection{Unit tests}
Test module, followed by the corresponding implementation module.
<<[[shower_base_ut.f90]]>>=
<<File header>>
module shower_base_ut
use unit_tests
use shower_base_uti
<<Standard module head>>
<<Shower base: public test>>
contains
<<Shower base: test driver>>
end module shower_base_ut
@ %def shower_base_ut
@
<<[[shower_base_uti.f90]]>>=
<<File header>>
module shower_base_uti
<<Use kinds>>
<<Use strings>>
use format_utils, only: write_separator
use variables
use shower_base
<<Standard module head>>
<<Shower base: test declarations>>
contains
<<Shower base: tests>>
end module shower_base_uti
@ %def shower_base_ut
@ API: driver for the unit tests below.
<<Shower base: public test>>=
public :: shower_base_test
<<Shower base: test driver>>=
subroutine shower_base_test (u, results)
integer, intent(in) :: u
type(test_results_t), intent(inout) :: results
<<Shower base: execute tests>>
end subroutine shower_base_test
@ %def shower_base_test
@
\subsubsection{Shower settings}
This test dispatches an [[shower_settings]] object, which is used
to steer the initial and final state showers.
<<Shower base: execute tests>>=
call test (shower_base_1, "shower_base_1", &
"Shower settings", &
u, results)
<<Shower base: test declarations>>=
public :: shower_base_1
<<Shower base: tests>>=
subroutine shower_base_1 (u)
integer, intent(in) :: u
type(var_list_t) :: var_list
type(shower_settings_t) :: shower_settings
write (u, "(A)") "* Test output: shower_base_1"
write (u, "(A)") "* Purpose: setting ISR/FSR shower"
write (u, "(A)")
write (u, "(A)") "* Default settings"
write (u, "(A)")
call var_list%init_defaults (0)
call var_list%set_log (var_str ("?alphas_is_fixed"), &
.true., is_known = .true.)
call shower_settings%init (var_list)
call write_separator (u)
call shower_settings%write (u)
call write_separator (u)
write (u, "(A)")
write (u, "(A)") "* Switch on ISR/FSR showers, hadronization"
write (u, "(A)") " and MLM matching"
write (u, "(A)")
call var_list%set_string (var_str ("$shower_method"), &
var_str ("PYTHIA6"), is_known = .true.)
call var_list%set_log (var_str ("?ps_fsr_active"), &
.true., is_known = .true.)
call var_list%set_log (var_str ("?ps_isr_active"), &
.true., is_known = .true.)
call var_list%set_log (var_str ("?hadronization_active"), &
.true., is_known = .true.)
call var_list%set_log (var_str ("?mlm_matching"), &
.true., is_known = .true.)
call var_list%set_int &
(var_str ("ps_max_n_flavors"), 4, is_known = .true.)
call var_list%set_real &
(var_str ("ps_isr_z_cutoff"), 0.1234_default, &
is_known=.true.)
call var_list%set_real (&
var_str ("mlm_etamax"), 3.456_default, is_known=.true.)
call var_list%set_string (&
var_str ("$ps_PYTHIA_PYGIVE"), var_str ("abcdefgh"), is_known=.true.)
call shower_settings%init (var_list)
call write_separator (u)
call shower_settings%write (u)
call write_separator (u)
call var_list%final ()
write (u, "(A)")
write (u, "(A)") "* Test output end: shower_base_1"
end subroutine shower_base_1
@ %def shower_base_1
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Parton module for the shower}
<<[[shower_partons.f90]]>>=
<<File header>>
module shower_partons
<<Use kinds with double>>
use io_units
use constants
use system_defs, only: TAB
use diagnostics
use physics_defs
use lorentz
use sm_physics
use particles
use flavors
use colors
use subevents
use model_data
use shower_base
use rng_base
<<Standard module head>>
<<Shower partons: public>>
<<Shower partons: types>>
contains
<<Shower partons: procedures>>
end module shower_partons
@ %def shower_partons
@
\subsection{The basic type defintions}
The type [[parton_t]] defines a parton for the shower. The [[x]] value
of the parton is only needed for spacelike showers. The pointer
[[initial]] is only needed for partons in initial showers, it points to
the hadron the parton is coming from. An auxiliary value for the
$P_t$-ordered ISR is [[aux_pt]]. Then, there are two auxiliary entries
for the clustering of CKKW pseudo weights and CKKW matching,
[[ckkwlabel]] and [[ckkwscale]]. In order to make shower settings
available to all operations on the shower partons, we endow the
[[parton_t]] type with a pointer to [[shower_settings_t]].
<<Shower partons: public>>=
public :: parton_t
<<Shower partons: types>>=
type :: parton_t
integer :: nr = 0
integer :: type = 0
type(shower_settings_t), pointer :: settings => null()
type(vector4_t) :: momentum = vector4_null
real(default) :: t = zero
real(default) :: mass2 = zero
real(default) :: scale = zero
real(default) :: z = zero
real(default) :: costheta = zero
real(default) :: x = zero
logical :: simulated = .false.
logical :: belongstoFSR = .true.
logical :: belongstointeraction = .false.
type(parton_t), pointer :: parent => null ()
type(parton_t), pointer :: child1 => null ()
type(parton_t), pointer :: child2 => null ()
type(parton_t), pointer :: initial => null ()
integer :: c1 = 0, c2 = 0
integer :: aux_pt = 0
integer :: ckkwlabel = 0
real(default) :: ckkwscale = zero
integer :: ckkwtype = -1
integer :: interactionnr = 0
contains
<<Shower partons: parton: TBP>>
end type parton_t
@ %def parton_t
@
<<Shower partons: public>>=
public :: parton_pointer_t
<<Shower partons: types>>=
type :: parton_pointer_t
type(parton_t), pointer :: p => null ()
end type parton_pointer_t
@ %def parton_pointer_t
@
\subsection{Routines}
<<Shower partons: parton: TBP>>=
procedure :: to_particle => parton_to_particle
<<Shower partons: procedures>>=
function parton_to_particle (parton, model, from_hard_int) result (particle)
type(particle_t) :: particle
class(parton_t), intent(in) :: parton
class(model_data_t), pointer, intent(in) :: model
logical, intent(in), optional :: from_hard_int
integer :: col, anti_col
call parton%to_color (col, anti_col, from_hard_int)
call particle%init (parton%to_status (from_hard_int), parton%type, &
model, col, anti_col, parton%momentum)
end function parton_to_particle
@ %def parton_to_particle
@
<<Shower partons: public>>=
public :: parton_of_particle
<<Shower partons: procedures>>=
! pure
function parton_of_particle (particle, nr) result (parton)
type(parton_t) :: parton
type(particle_t), intent(in) :: particle
integer, intent(in) :: nr
integer, dimension(2) :: col_array
parton%nr = nr
parton%momentum = particle%p
parton%t = particle%p2
parton%type = particle%flv%get_pdg ()
col_array = particle%get_color ()
parton%c1 = col_array (1)
parton%c2 = col_array (2)
parton%interactionnr = 1
parton%mass2 = particle%flv%get_mass () ** 2
end function parton_of_particle
@ %def parton_of_particle
@
<<Shower partons: parton: TBP>>=
procedure :: to_status => parton_to_status
<<Shower partons: procedures>>=
pure function parton_to_status (parton, from_hard_int) result (status)
integer :: status
class(parton_t), intent(in) :: parton
logical, intent(in), optional :: from_hard_int
logical :: fhi
fhi = .false.; if (present (from_hard_int)) fhi = from_hard_int
if (fhi .or. parton%is_colored ()) then
if (associated (parton%initial) .and. .not. parton%belongstoFSR) then
status = PRT_INCOMING
else
status = PRT_OUTGOING
end if
else
status = PRT_BEAM_REMNANT
end if
end function parton_to_status
@ %def parton_to_status
@
<<Shower partons: parton: TBP>>=
procedure :: to_color => parton_to_color
<<Shower partons: procedures>>=
pure subroutine parton_to_color (parton, c1, c2, from_hard_int)
class(parton_t), intent(in) :: parton
integer, intent(out) :: c1, c2
logical, intent(in), optional :: from_hard_int
logical :: fhi
fhi = .false.; if (present (from_hard_int)) fhi = from_hard_int
c1 = 0
c2 = 0
if (parton%is_colored ()) then
if (fhi) then
if (parton%c1 /= 0) c1 = parton%c1
if (parton%c2 /= 0) c2 = parton%c2
else
if (parton%c1 /= 0) c1 = 500 + parton%c1
if (parton%c2 /= 0) c2 = 500 + parton%c2
end if
end if
end subroutine parton_to_color
@ %def parton_to_color
<<Shower partons: public>>=
public :: parton_copy
<<Shower partons: procedures>>=
subroutine parton_copy (prt1, prt2)
type(parton_t), intent(in) :: prt1
type(parton_t), intent(out) :: prt2
if (associated (prt1%settings)) prt2%settings => prt1%settings
prt2%nr = prt1%nr
prt2%type = prt1%type
prt2%momentum = prt1%momentum
prt2%t = prt1%t
prt2%mass2 = prt1%mass2
prt2%scale = prt1%scale
prt2%z = prt1%z
prt2%costheta = prt1%costheta
prt2%x = prt1%x
prt2%simulated = prt1%simulated
prt2%belongstoFSR = prt1%belongstoFSR
prt2%belongstointeraction = prt1%belongstointeraction
prt2%interactionnr = prt1%interactionnr
if (associated (prt1%parent)) prt2%parent => prt1%parent
if (associated (prt1%child1)) prt2%child1 => prt1%child1
if (associated (prt1%child2)) prt2%child2 => prt1%child2
if (associated (prt1%initial)) prt2%initial => prt1%initial
prt2%c1 = prt1%c1
prt2%c2 = prt1%c2
prt2%aux_pt = prt1%aux_pt
end subroutine parton_copy
@ %def parton_copy
@ This returns the angle between the daughters assuming them to be
massless.
<<Shower partons: parton: TBP>>=
procedure :: get_costheta => parton_get_costheta
<<Shower partons: procedures>>=
elemental function parton_get_costheta (prt) result (costheta)
class(parton_t), intent(in) :: prt
real(default) :: costheta
real(default) :: denom
denom = two * prt%z * (one - prt%z) * prt%momentum%p(0)**2
if (denom > eps0) then
costheta = one - prt%t / denom
else
costheta = - one
end if
end function parton_get_costheta
@ %def parton_get_costheta
@ The same for massive daughters.
<<Shower partons: parton: TBP>>=
procedure :: get_costheta_mass => parton_get_costheta_mass
<<Shower partons: procedures>>=
elemental function parton_get_costheta_mass (prt) result (costheta)
class(parton_t), intent(in) :: prt
real(default) :: costheta, sqrt12
if (prt%is_branched ()) then
if (prt%child1%simulated .and. &
prt%child2%simulated) then
sqrt12 = sqrt (max (zero, (prt%z)**2 * prt%momentum%p(0)**2 &
- prt%child1%t)) * &
sqrt (max (zero, (one - prt%z)**2 * prt%momentum%p(0)**2 &
- prt%child2%t))
if (sqrt12 > eps0) then
costheta = (prt%t - prt%child1%t - prt%child2%t - &
two * prt%z * (one - prt%z) * prt%momentum%p(0)**2) / &
(- two * sqrt12)
return
end if
end if
end if
costheta = prt%get_costheta ()
end function parton_get_costheta_mass
@ %def parton_get_costheta_mass
@ This function returns the angle between the momentum vectors of the
parton and first daughter. This is only used for debugging.
<<Shower partons: parton: TBP>>=
procedure :: get_costheta_motherfirst => parton_get_costheta_motherfirst
<<Shower partons: procedures>>=
elemental function parton_get_costheta_motherfirst (prt) result (costheta)
class(parton_t), intent(in) :: prt
real(default) :: costheta
if (prt%is_branched ()) then
if ((prt%child1%simulated .or. &
prt%child1%is_final () .or. &
prt%child1%is_branched ()) .and. &
(prt%child2%simulated .or. &
prt%child2%is_final () .or. &
prt%child2%is_branched ())) then
costheta = enclosed_angle_ct (prt%momentum, prt%child1%momentum)
return
end if
end if
costheta = - two
end function parton_get_costheta_motherfirst
@ %def parton_get_costheta_motherfirst
@ Get the parton velocities.
<<Shower partons: parton: TBP>>=
procedure :: get_beta => parton_get_beta
@
<<Shower partons: procedures>>=
pure function get_beta (t,E) result (beta)
real(default), intent(in) :: t,E
real(default) :: beta
beta = sqrt (max (tiny_07, one - t /(E**2)))
end function get_beta
elemental function parton_get_beta (prt) result (beta)
class(parton_t), intent(in) :: prt
real(default) :: beta
beta = sqrt (max (tiny_07, one - prt%t / prt%momentum%p(0)**2))
end function parton_get_beta
@ %def get_beta parton_get_beta
@ Write routine.
<<Shower partons: parton: TBP>>=
procedure :: write => parton_write
<<Shower partons: procedures>>=
subroutine parton_write (prt, unit)
class(parton_t), intent(in) :: prt
integer, intent(in), optional :: unit
integer :: u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,7A)") "Shower parton <nr>", TAB, "<type>", TAB // TAB, &
"<parent>", TAB, "<mom(0:3)>"
write (u, "(2x,I5,3A)", advance = "no") prt%nr, TAB, TAB, TAB
if (prt%is_final ()) then
write (u, "(1x,I5,1x,A)", advance = "no") prt%type, TAB // TAB
else
write (u, "('[',I5,']',A)", advance = "no") prt%type, TAB // TAB
end if
if (associated (prt%parent)) then
write (u, "(I5,A)", advance = "no") prt%parent%nr, TAB // TAB
else
write (u, "(5x,2A)", advance = "no") TAB, TAB
end if
write (u, "(4(ES12.5,A))") prt%momentum%p(0), TAB, &
prt%momentum%p(1), TAB, &
prt%momentum%p(2), TAB, &
prt%momentum%p(3)
write (u, "(1x,9A)") "<p4square>", TAB // TAB, "<t>", TAB // TAB, &
"<scale>", TAB // TAB, "<c1>", TAB, "<c2>", TAB, "<mass2>"
write (u, "(1x,3(ES12.5,A))", advance = "no") &
prt%momentum ** 2, TAB // TAB, prt%t, TAB, prt%scale, TAB, prt%mass2
write (u, "(2(I4,A))") prt%c1, TAB, prt%c2, TAB
if (prt%is_branched ()) then
if (prt%belongstoFSR) then
write (u, "(1x,9A)") "costheta(prt)", TAB, &
"costheta_correct(prt)", TAB, &
"prt%costheta", TAB, "prt%z", TAB, &
"costheta_motherfirst(prt)"
write (u, "(1X,5(ES12.5,A))") &
prt%get_costheta (), TAB, &
prt%get_costheta_mass (), TAB // TAB, &
prt%costheta, TAB, prt%z, TAB, &
prt%get_costheta_motherfirst (), TAB
else
write (u, "(1x,9A)") "prt%z", TAB, "prt%x", TAB, &
"costheta_correct(prt)", TAB, &
"prt%costheta", TAB, &
"costheta_motherfirst(prt)"
write (u, "(1X,5(ES12.5,A))") &
prt%z, TAB, prt%x, TAB, &
prt%get_costheta_mass (), TAB, &
prt%costheta, TAB, &
prt%get_costheta_motherfirst (), TAB
end if
else
if (prt%belongstoFSR) then
write (u, "(1X,A)") "not branched."
else
write (u, "(1X,A,ES12.5)") "not branched. x = ", prt%x
end if
end if
write (u, "(A)", advance = "no") " Parton"
if (prt%belongstoFSR) then
write (u, "(A)", advance = "no") " is FSR,"
else
if (associated (prt%initial)) then
write (u, "(A,I1)", advance = "no") " from hadron,", prt%initial%nr
else
write (u, "(A)", advance = "no") ""
end if
end if
if (prt%is_final ()) then
write (u, "(A)", advance = "no") " is final,"
else
write (u, "(A)", advance = "no") ""
end if
if (prt%simulated) then
write (u, "(A)", advance = "no") " is simulated,"
else
write (u, "(A)", advance = "no") ""
end if
if (associated (prt%child1) .and. associated (prt%child2)) then
write (u, "(A,2(I5),A)", advance = "no") &
" has children: ", prt%child1%nr, prt%child2%nr, ","
else if (associated (prt%child1)) then
write (u, "(A,1(I5),A)", advance = "no") &
" has one child: ", prt%child1%nr, ", "
end if
if (prt%belongstointeraction) then
write (u, "(A,I2)") " belongs to interaction ", &
prt%interactionnr
else
write (u, "(A,I2)") " does not belong to interaction ", &
prt%interactionnr
end if
write (u,"(A)") TAB
end subroutine parton_write
@ %def parton_write
@
<<Shower partons: parton: TBP>>=
procedure :: is_final => parton_is_final
<<Shower partons: procedures>>=
elemental function parton_is_final (prt) result (is_final)
class(parton_t), intent(in) :: prt
logical :: is_final
is_final = .false.
if (prt%belongstoFSR) then
is_final = .not. associated (prt%child1) .and. &
(.not. prt%belongstointeraction .or. &
(prt%belongstointeraction .and. prt%simulated))
end if
end function parton_is_final
@ %def parton_is_final
@
<<Shower partons: parton: TBP>>=
procedure :: is_branched => parton_is_branched
<<Shower partons: procedures>>=
elemental function parton_is_branched (prt) result (is_branched)
class(parton_t), intent(in) :: prt
logical :: is_branched
is_branched = associated (prt%child1) .and. associated (prt%child2)
end function parton_is_branched
@ %def parton_is_branched
@
<<Shower partons: parton: TBP>>=
procedure :: set_simulated => parton_set_simulated
<<Shower partons: procedures>>=
pure subroutine parton_set_simulated (prt, sim)
class(parton_t), intent(inout) :: prt
logical, intent(in), optional :: sim
if (present (sim)) then
prt%simulated = sim
else
prt%simulated = .true.
end if
end subroutine parton_set_simulated
@ %def parton_set_simulated
@
<<Shower partons: public>>=
public :: parton_set_parent
<<Shower partons: procedures>>=
subroutine parton_set_parent (prt, parent)
type(parton_t), intent(inout) :: prt
type(parton_t), intent(in) , target :: parent
prt%parent => parent
end subroutine parton_set_parent
@ %def parton_set_parent
@
<<Shower partons: public>>=
public :: parton_get_parent
<<Shower partons: procedures>>=
function parton_get_parent (prt) result (parent)
type(parton_t), intent(in) :: prt
type(parton_t), pointer :: parent
parent => prt%parent
end function parton_get_parent
@ %def parton_get_parent
@
<<Shower partons: public>>=
public :: parton_set_initial
<<Shower partons: procedures>>=
subroutine parton_set_initial (prt, initial)
type(parton_t), intent(inout) :: prt
type(parton_t), intent(in) , target :: initial
prt%initial => initial
end subroutine parton_set_initial
@ %def parton_set_initial
@
<<Shower partons: public>>=
public :: parton_get_initial
<<Shower partons: procedures>>=
function parton_get_initial (prt) result (initial)
type(parton_t), intent(in) :: prt
type(parton_t), pointer :: initial
initial => prt%initial
end function parton_get_initial
@ %def parton_get_initial
@
<<Shower partons: public>>=
public :: parton_set_child
<<Shower partons: procedures>>=
subroutine parton_set_child (prt, child, i)
type(parton_t), intent(inout) :: prt
type(parton_t), intent(in), target :: child
integer, intent(in) :: i
if (i == 1) then
prt%child1 => child
else
prt%child2 => child
end if
end subroutine parton_set_child
@ %def parton_set_child
@
<<Shower partons: public>>=
public :: parton_get_child
<<Shower partons: procedures>>=
function parton_get_child (prt, i) result (child)
type(parton_t), pointer :: child
type(parton_t), intent(in) :: prt
integer, intent(in) :: i
child => null ()
if (i == 1) then
child => prt%child1
else
child => prt%child2
end if
end function parton_get_child
@ %def parton_get_child
@
<<Shower partons: parton: TBP>>=
procedure :: is_quark => parton_is_quark
<<Shower partons: procedures>>=
elemental function parton_is_quark (prt) result (is_quark)
class(parton_t), intent(in) ::prt
logical :: is_quark
is_quark = abs (prt%type) <= 6 .and. prt%type /= 0
end function parton_is_quark
@ %def parton_is_quark
@
<<Shower partons: parton: TBP>>=
procedure :: is_squark => parton_is_squark
<<Shower partons: procedures>>=
elemental function parton_is_squark (prt) result (is_squark)
class(parton_t), intent(in) ::prt
logical :: is_squark
is_squark = ((abs(prt%type) >= 1000001) .and. (abs(prt%type) <= 1000006)) &
.or. ((abs(prt%type) >= 2000001) .and. (abs(prt%type) <= 2000006))
end function parton_is_squark
@ %def parton_is_squark
@ 9 can be used for gluons in codes for glueballs
<<Shower partons: parton: TBP>>=
procedure :: is_gluon => parton_is_gluon
<<Shower partons: procedures>>=
elemental function parton_is_gluon (prt) result (is_gluon)
class(parton_t), intent(in) :: prt
logical :: is_gluon
is_gluon = prt%type == GLUON .or. prt%type == 9
end function parton_is_gluon
@ %def parton_is_gluon
@
<<Shower partons: parton: TBP>>=
procedure :: is_gluino => parton_is_gluino
<<Shower partons: procedures>>=
elemental function parton_is_gluino (prt) result (is_gluino)
class(parton_t), intent(in) :: prt
logical :: is_gluino
is_gluino = prt%type == 1000021
end function parton_is_gluino
@ %def parton_is_gluino
@
<<Shower partons: parton: TBP>>=
procedure :: is_proton => parton_is_proton
<<Shower partons: procedures>>=
elemental function parton_is_proton (prt) result (is_hadron)
class(parton_t), intent(in) :: prt
logical :: is_hadron
is_hadron = abs (prt%type) == PROTON
end function parton_is_proton
@ %def parton_is_proton
@ TODO: SUSY partons.
<<Shower partons: parton: TBP>>=
procedure :: is_colored => parton_is_colored
<<Shower partons: procedures>>=
pure function parton_is_colored (parton) result (is_colored)
logical :: is_colored
class(parton_t), intent(in) :: parton
is_colored = parton_is_quark (parton) .or. parton_is_gluon (parton)
end function parton_is_colored
@ %def parton_is_colored
@
<<Shower partons: parton: TBP>>=
procedure :: mass => parton_mass
<<Shower partons: procedures>>=
elemental function parton_mass (prt) result (mass)
class(parton_t), intent(in) :: prt
real(default) :: mass
mass = mass_type (prt%type, prt%mass2)
end function parton_mass
@ %def parton_mass
@
<<Shower partons: parton: TBP>>=
procedure :: mass_squared => parton_mass_squared
<<Shower partons: procedures>>=
elemental function parton_mass_squared (prt) result (mass_squared)
class(parton_t), intent(in) :: prt
real(default) :: mass_squared
mass_squared = mass_squared_type (prt%type, prt%mass2)
end function parton_mass_squared
@ %def parton_mass_squared
@
<<Shower partons: parton: TBP>>=
procedure :: momentum_to_pythia6 => parton_momentum_to_pythia6
<<Shower partons: procedures>>=
pure function parton_momentum_to_pythia6 (prt) result (p)
real(double), dimension(1:5) :: p
class(parton_t), intent(in) :: prt
real(default) :: mass
!!! gfortran 5.1 complains about 'ELEMENTAL procedure pointer
!!! component ‘mass’ is not allowed as an actual argument'
!!! p = prt%momentum%to_pythia6 (prt%mass ())
mass = prt%mass ()
p = prt%momentum%to_pythia6 (mass)
end function parton_momentum_to_pythia6
@ %def parton_momentum_to_pythia6
@
<<Shower partons: public>>=
public :: P_prt_to_child1
<<Shower partons: procedures>>=
function P_prt_to_child1 (prt) result (retvalue)
type(parton_t), intent(in) :: prt
real(default) :: retvalue
retvalue = zero
if (prt%is_gluon ()) then
if (prt%child1%is_quark ()) then
retvalue = P_gqq (prt%z)
else if (prt%child1%is_gluon ()) then
retvalue = P_ggg (prt%z) + P_ggg (one - prt%z)
end if
else if (prt%is_quark ()) then
if (prt%child1%is_quark ()) then
retvalue = P_qqg (prt%z)
else if (prt%child1%is_gluon ()) then
retvalue = P_qqg (one - prt%z)
end if
end if
end function P_prt_to_child1
@ %def P_prt_to_child1
@ This function returns whether the kinematics of the branching of
parton [[prt]] into its daughters are allowed or not.
<<Shower partons: public>>=
public :: thetabar
<<Shower partons: procedures>>=
function thetabar (prt, recoiler, isr_ang, E3out) result (retvalue)
type(parton_t), intent(inout) :: prt
type(parton_t), intent(in) :: recoiler
real(default), intent(out), optional :: E3out
logical, intent(in) :: isr_ang
logical :: retvalue
real(default) :: ctheta, cthetachild1
real(default) p1, p4, p3, E3, shat
shat = (prt%child1%momentum + recoiler%momentum)**2
E3 = 0.5_default * (shat / prt%z -recoiler%t + prt%child1%t - &
prt%child2%mass_squared ()) / sqrt(shat)
if (present (E3out)) then
E3out = E3
end if
!!! absolute values of momenta in a 3 -> 1 + 4 branching
p3 = sqrt (E3**2 - prt%t)
p1 = sqrt (prt%child1%momentum%p(0)**2 - prt%child1%t)
p4 = sqrt (max (zero, (E3 - prt%child1%momentum%p(0))**2 &
- prt%child2%t))
if (p3 > zero) then
retvalue = ((p1 + p4 >= p3) .and. (p3 >= abs(p1 - p4)) )
if (retvalue .and. isr_ang) then
!!! check angular ordering
if (associated (prt%child1)) then
if (associated (prt%child1%child2)) then
ctheta = (E3**2 - p1**2 - p4**2 + prt%t) / (two * p1 * p4)
cthetachild1 = (prt%child1%momentum%p(0)**2 - &
space_part (prt%child1%child1%momentum)**2 &
- space_part (prt%child1%child2%momentum)**2 + prt%child1%t) &
/ (two * space_part (prt%child1%child1%momentum)**1 * &
space_part (prt%child1%child2%momentum)**1)
retvalue = (ctheta > cthetachild1)
end if
end if
end if
else
retvalue = .false.
end if
end function thetabar
@ %def thetabar
@
<<Shower partons: public>>=
public :: parton_apply_costheta
<<Shower partons: procedures>>=
recursive subroutine parton_apply_costheta (prt, rng)
type(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
if (debug2_active (D_SHOWER)) then
print *, "D: parton_apply_costheta for parton " , prt%nr
print *, 'prt%momentum%p = ', prt%momentum%p
call msg_debug2 (D_SHOWER, "prt%type", prt%type)
end if
prt%z = 0.5_default * (one + prt%get_beta () * prt%costheta)
if (associated (prt%child1) .and. associated (prt%child2)) then
if (prt%child1%simulated .and. prt%child2%simulated) then
prt%z = 0.5_default * (one + (prt%child1%t - prt%child2%t) / &
prt%t + prt%get_beta () * prt%costheta * &
sqrt((prt%t - prt%child1%t - prt%child2%t)**2 - &
4 * prt%child1%t * prt%child2%t) / prt%t)
if (prt%type /= INTERNAL) then
prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
end if
call prt%generate_ps (rng)
call parton_apply_costheta (prt%child1, rng)
call parton_apply_costheta (prt%child2, rng)
end if
end if
end subroutine parton_apply_costheta
@ %def parton_apply_costheta
@
<<Shower partons: public>>=
public :: parton_apply_lorentztrafo
<<Shower partons: procedures>>=
subroutine parton_apply_lorentztrafo (prt, L)
type(parton_t), intent(inout) :: prt
type(lorentz_transformation_t), intent(in) :: L
prt%momentum = L * prt%momentum
end subroutine parton_apply_lorentztrafo
@ %def parton_apply_lorentztrafo
@
<<Shower partons: public>>=
public :: parton_apply_lorentztrafo_recursive
<<Shower partons: procedures>>=
recursive subroutine parton_apply_lorentztrafo_recursive (prt, L)
type(parton_t), intent(inout) :: prt
type(lorentz_transformation_t) ,intent(in) :: L
if (prt%type /= PROTON .and. prt%type /= BEAM_REMNANT) then
!!! don't boost hadrons and beam-remnants
call parton_apply_lorentztrafo (prt, L)
end if
if (associated (prt%child1) .and. associated (prt%child2)) then
if ((space_part_norm (prt%child1%momentum) < eps0) .and. &
(space_part_norm (prt%child2%momentum) < eps0) .and. &
(.not. prt%child1%belongstointeraction) .and. &
(.not. prt%child2%belongstointeraction)) then
!!! don't boost unevolved timelike partons
else
call parton_apply_lorentztrafo_recursive (prt%child1, L)
call parton_apply_lorentztrafo_recursive (prt%child2, L)
end if
else
if (associated (prt%child1)) then
call parton_apply_lorentztrafo_recursive (prt%child1, L)
end if
if (associated (prt%child2)) then
call parton_apply_lorentztrafo_recursive (prt%child2, L)
end if
end if
end subroutine parton_apply_lorentztrafo_recursive
@ %def parton_apply_lorentztrafo_recursive
@ This takes the three-momentum of a parton and generates
three-momenta of its children given their energy and virtuality
<<Shower partons: parton: TBP>>=
procedure :: generate_ps => parton_generate_ps
<<Shower partons: procedures>>=
subroutine parton_generate_ps (prt, rng)
class(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
real(default), dimension(1:3, 1:3) :: directions
integer i,j
real(default) :: scproduct, pabs, p1abs, p2abs, x, ptabs, phi
real(default), dimension(1:3) :: momentum
type(vector3_t) :: pchild1_direction
type(lorentz_transformation_t) :: L, rotation
if (debug2_active (D_SHOWER)) print *, "D: parton_generate_ps for parton " , prt%nr
if (debug_active (D_SHOWER)) then
if (.not. (associated (prt%child1) .and. associated (prt%child2))) then
call msg_fatal ("no children for generate_ps")
end if
end if
!!! test if parton is a virtual parton from the imagined parton shower history
if (prt%type == INTERNAL) then
L = inverse (boost (prt%momentum, sqrt(prt%t)))
!!! boost to restframe of mother
call parton_apply_lorentztrafo (prt, L)
call parton_apply_lorentztrafo (prt%child1, L)
call parton_apply_lorentztrafo (prt%child2, L)
!!! Store child1's momenta
pchild1_direction = direction (space_part (prt%child1%momentum))
!!! Redistribute energy
prt%child1%momentum%p(0) = (prt%momentum%p(0)**2 - &
prt%child2%t + prt%child1%t) / (two * prt%momentum%p(0))
prt%child2%momentum%p(0) = prt%momentum%p(0) - &
prt%child1%momentum%p(0)
! rescale momenta and set momenta to be along z-axis
prt%child1%momentum = vector4_moving (prt%child1%momentum%p(0), &
vector3_canonical(3) * &
sqrt(prt%child1%momentum%p(0)**2 - prt%child1%t))
prt%child2%momentum = vector4_moving (prt%child2%momentum%p(0), &
- vector3_canonical(3) * &
sqrt(prt%child2%momentum%p(0)**2 - prt%child2%t))
!!! rotate so that total momentum is along former total momentum
rotation = rotation_to_2nd (space_part (prt%child1%momentum), &
pchild1_direction)
call parton_apply_lorentztrafo (prt%child1, rotation)
call parton_apply_lorentztrafo (prt%child2, rotation)
L = inverse (L) !!! inverse of the boost to restframe of mother
call parton_apply_lorentztrafo (prt, L)
call parton_apply_lorentztrafo (prt%child1, L)
call parton_apply_lorentztrafo (prt%child2, L)
else
!!! directions(1,:) -> direction of the parent parton
if (space_part_norm (prt%momentum) < eps0) return
directions(1,1:3) = prt%momentum%p(1:3) / space_part_norm (prt%momentum)
!!! directions(2,:) and directions(3,:) -> two random directions
!!! perpendicular to the direction of the parent parton
do j = 2, 3
call rng%generate (directions(j,:))
end do
do i = 2, 3
scproduct = zero
do j = 1, i - 1
scproduct = directions(i,1) * directions(j,1) + &
directions(i,2) * directions(j,2) + &
directions(i,3) * directions(j,3)
directions(i,1) = directions(i,1) - directions(j,1) * scproduct
directions(i,2) = directions(i,2) - directions(j,2) * scproduct
directions(i,3) = directions(i,3) - directions(j,3) * scproduct
end do
scproduct = directions(i,1)**2 + directions(i,2)**2 + &
directions(i,3)**2
do j = 1, 3
directions(i,j) = directions(i,j) / sqrt(scproduct)
end do
end do
<<Enforce right-handed system for [[directions]]>>
pabs = space_part_norm (prt%momentum)
if ((prt%child1%momentum%p(0)**2 - prt%child1%t < 0) .or. &
(prt%child2%momentum%p(0)**2 - prt%child2%t < 0)) then
call msg_debug(D_SHOWER, "generate_ps error at E^2 < t")
return
end if
p1abs = sqrt (prt%child1%momentum%p(0)**2 - prt%child1%t)
p2abs = sqrt (prt%child2%momentum%p(0)**2 - prt%child2%t)
x = (pabs**2 + p1abs**2 - p2abs**2) / (two * pabs)
if (pabs > p1abs + p2abs .or. &
pabs < abs(p1abs - p2abs)) then
if (debug_active (D_SHOWER)) then
print *, "D: parton_generate_ps Dreiecksungleichung error &
&for parton ", prt%nr, " ", &
space_part_norm (prt%momentum), " ", p1abs, " ", p2abs
call prt%write ()
call prt%child1%write ()
call prt%child2%write ()
end if
return
end if
!!! Due to numerical problems transverse momentum could be imaginary ->
!!! set transverse momentum to zero
ptabs = sqrt (max (p1abs * p1abs - x * x, zero))
call rng%generate (phi)
phi = twopi * phi
do i = 1, 3
momentum(i) = x * directions(1,i) + ptabs * &
(cos(phi) * directions(2,i) + sin(phi) * directions(3,i))
end do
prt%child1%momentum%p(1:3) = momentum(1:3)
do i = 1, 3
momentum(i) = (space_part_norm (prt%momentum) - x) * directions(1,i) - &
ptabs * (cos(phi) * directions(2,i) + sin(phi) * directions(3,i))
end do
prt%child2%momentum%p(1:3) = momentum(1:3)
end if
end subroutine parton_generate_ps
@ %def parton_generate_ps
@
<<Enforce right-handed system for [[directions]]>>=
if ((directions(1,1) * (directions(2,2) * directions(3,3) - &
directions(2,3) * directions(3,2)) + &
directions(1,2) * (directions(2,3) * directions(3,1) - &
directions(2,1) * directions(3,3)) + &
directions(1,3) * (directions(2,1) * directions(3,2) - &
directions(2,2) * directions(3,1))) < 0) then
directions(3,:) = - directions(3,:)
end if
@
This routine is similar to [[parton_generate_ps]], but now for the
ISR. It takes the three-momentum of a parton's first child as fixed and
generates the two remaining three-momenta.
<<Shower partons: parton: TBP>>=
procedure :: generate_ps_ini => parton_generate_ps_ini
<<Shower partons: procedures>>=
subroutine parton_generate_ps_ini (prt, rng)
class(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
real(default), dimension(1:3, 1:3) :: directions
integer :: i,j
real(default) :: scproduct, pabs, p1abs, p2abs, x, ptabs, phi
real(default), dimension(1:3) :: momentum
if (debug_active (D_SHOWER)) print *, "D: parton_generate_ps_ini: for parton " , prt%nr
if (debug_active (D_SHOWER)) then
if (.not. (associated (prt%child1) .and. associated (prt%child2))) then
call msg_fatal ("no children for generate_ps")
end if
end if
if (.not. prt%is_proton()) then
!!! generate ps for normal partons
do i = 1, 3
directions(1,i) = prt%child1%momentum%p(i) / &
space_part_norm(prt%child1%momentum)
end do
do j = 2, 3
call rng%generate (directions(j,:))
end do
do i = 2, 3
scproduct = zero
do j = 1, i - 1
scproduct = directions(i,1) * directions(j,1) + &
directions(i,2) * directions(j,2) + &
directions(i,3) * directions(j,3)
directions(i,1) = directions(i,1) - directions(j,1) * scproduct
directions(i,2) = directions(i,2) - directions(j,2) * scproduct
directions(i,3) = directions(i,3) - directions(j,3) * scproduct
end do
scproduct = directions(i,1)**2 + directions(i,2)**2 + &
directions(i,3)**2
do j = 1, 3
directions(i,j) = directions(i,j) / sqrt(scproduct)
end do
end do
<<Enforce right-handed system for [[directions]]>>
pabs = space_part_norm (prt%child1%momentum)
p1abs = sqrt (prt%momentum%p(0)**2 - prt%t)
p2abs = sqrt (max(zero, prt%child2%momentum%p(0)**2 - &
prt%child2%t))
x = (pabs**2 + p1abs**2 - p2abs**2) / (two * pabs)
if (debug_active (D_SHOWER)) then
if (pabs > p1abs + p2abs .or. pabs < abs(p1abs - p2abs)) then
print *, "error at generate_ps, Dreiecksungleichung for parton ", &
prt%nr, " ", pabs," ",p1abs," ",p2abs
call prt%write ()
call prt%child1%write ()
call prt%child2%write ()
call msg_fatal ("parton_generate_ps_ini: Dreiecksungleichung")
end if
end if
if (debug_active (D_SHOWER)) print *, "D: parton_generate_ps_ini: x = ", x
ptabs = sqrt (p1abs * p1abs - x**2)
call rng%generate (phi)
phi = twopi * phi
do i = 1,3
momentum(i) = x * directions(1,i) + ptabs * (cos(phi) * &
directions(2,i) + sin(phi) * directions(3,i))
end do
prt%momentum%p(1:3) = momentum
do i = 1, 3
momentum(i) = (x - pabs) * directions(1,i) + ptabs * (cos(phi) * &
directions(2,i) + sin(phi) * directions(3,i))
end do
prt%child2%momentum%p(1:3) = momentum(1:3)
else
!!! for first partons just set beam remnants momentum
prt%child2%momentum = prt%momentum - prt%child1%momentum
end if
end subroutine parton_generate_ps_ini
@ %def parton_generate_ps_ini
@
\subsection{The analytic FSR}
<<Shower partons: parton: TBP>>=
procedure :: next_t_ana => parton_next_t_ana
<<Shower partons: procedures>>=
subroutine parton_next_t_ana (prt, rng)
class(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
integer :: gtoqq
real(default) :: integral, random
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "next_t_ana")
! check if branchings are possible at all
if (min (prt%t, prt%momentum%p(0)**2) < &
prt%mass_squared () + prt%settings%min_virtuality) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
return
end if
integral = zero
call rng%generate (random)
do
call parton_simulate_stept (prt, rng, integral, random, gtoqq, .false.)
if (prt%simulated) then
if (prt%is_gluon ()) then
!!! Abusing the x-variable to store the information to which
!!! quark flavor the gluon branches (if any)
prt%x = one * gtoqq + 0.1_default
!!! x = gtoqq + 0.1 -> int(x) will be the quark flavor or
!!! zero for g -> gg
end if
exit
end if
end do
end subroutine parton_next_t_ana
@ %def parton_next_t_ana
@ The shower is actually sensitive to how close we go to the one here.
<<Shower partons: procedures>>=
function cmax (prt, tt) result (cmaxx)
type(parton_t), intent(in) :: prt
real(default), intent(in), optional :: tt
real(default) :: t, cost, cmaxx, radicand
t = prt%t; if (present (tt)) t = tt
if (associated (prt%parent)) then
cost = prt%parent%get_costheta ()
radicand = max(zero, one - &
t / (prt%get_beta () * prt%momentum%p(0))**2 * &
(one + cost) / (one - cost))
call msg_debug2 (D_SHOWER, "cmax: sqrt (radicand)", sqrt (radicand))
cmaxx = min (0.99999_default, sqrt (radicand))
else
cmaxx = 0.99999_default
end if
end function cmax
@ %def cmax
@ Simulation routine. The variable [[lookatsister]] takes constraints
from the sister parton into account, if not given it is assumed
[[.true.]]. [[a]] and [[x]] are three-dimensional arrays for values
used for the integration.
<<Shower partons: public>>=
public :: parton_simulate_stept
<<Shower partons: procedures>>=
subroutine parton_simulate_stept &
(prt, rng, integral, random, gtoqq, lookatsister)
type(parton_t), intent(inout) :: prt
class(rng_t), intent(inout), allocatable :: rng
real(default), intent(inout) :: integral
real(default), intent(inout) :: random
integer, intent(out) :: gtoqq
logical, intent(in), optional :: lookatsister
type(parton_t), pointer :: sister
real(default) :: tstep, tmin, oldt
real(default) :: c, cstep
real(default), dimension(3) :: z, P
real(default) :: to_integral
real(default) :: a11,a12,a13,a21,a22,a23
real(default) :: cmax_t
real(default) :: temprand
real(default), dimension(3) :: a, x
! higher values -> faster but coarser
real(default), parameter :: tstepfactor = 0.02_default
real(default), parameter :: tstepmin = 0.5_default
real(default), parameter :: cstepfactor = 0.8_default
real(default), parameter :: cstepmin = 0.03_default
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "parton_simulate_stept")
gtoqq = 111 ! illegal value
call prt%set_simulated (.false.)
<<Set [[sister]] if [[lookatsister]] is true or not given>>
tmin = prt%settings%min_virtuality + prt%mass_squared ()
if (prt%is_quark ()) then
to_integral = three *pi * log(one / random)
else if (prt%is_gluon ()) then
to_integral = four *pi * log(one / random)
else
prt%t = prt%mass_squared ()
call prt%set_simulated ()
return
end if
if (associated (sister)) then
if (sqrt(prt%t) > sqrt(prt%parent%t) - &
sqrt(sister%mass_squared ())) then
prt%t = (sqrt (prt%parent%t) - sqrt (sister%mass_squared ()))**2
end if
end if
if (prt%t > prt%momentum%p(0)**2) then
prt%t = prt%momentum%p(0)**2
end if
if (prt%t <= tmin) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
return
end if
! simulate the branchings between prt%t and prt%t - tstep
tstep = max(tstepfactor * (prt%t - 0.9_default * tmin), tstepmin)
cmax_t = cmax(prt)
c = - cmax_t ! take highest t -> minimal constraint
cstep = max(cstepfactor * (one - abs(c)), cstepmin)
! get values at border of "previous" bin -> to be used in first bin
z(3) = 0.5_default + 0.5_default * get_beta (prt%t - &
0.5_default * tstep, prt%momentum%p(0)) * c
if (prt%is_gluon ()) then
P(3) = P_ggg (z(3)) + P_gqq (z(3)) * number_of_flavors &
(prt%t, prt%settings%max_n_flavors, prt%settings%min_virtuality)
else
P(3) = P_qqg (z(3))
end if
a(3) = D_alpha_s_fsr (z(3) * (one - z(3)) * prt%t, &
prt%settings) * P(3) / (prt%t - 0.5_default * tstep)
do while (c < cmax_t .and. (integral < to_integral))
if (signal_is_pending ()) return
cmax_t = cmax (prt)
cstep = max (cstepfactor * (one - abs(c)**2), cstepmin)
if (c + cstep > cmax_t) then
cstep = cmax_t - c
end if
if (cstep < 1E-9_default) then
!!! reject too small bins
exit
end if
z(1) = z(3)
z(2) = 0.5_default + 0.5_default * get_beta &
(prt%t - 0.5_default * tstep, prt%momentum%p(0)) * &
(c + 0.5_default * cstep)
z(3) = 0.5_default + 0.5_default * get_beta &
(prt%t - 0.5_default * tstep, prt%momentum%p(0)) * (c + cstep)
P(1) = P(3)
if (prt%is_gluon ()) then
P(2) = P_ggg(z(2)) + P_gqq(z(2)) * number_of_flavors &
(prt%t, prt%settings%max_n_flavors, prt%settings%min_virtuality)
P(3) = P_ggg(z(3)) + P_gqq(z(3)) * number_of_flavors &
(prt%t, prt%settings%max_n_flavors, prt%settings%min_virtuality)
else
P(2) = P_qqg(z(2))
P(3) = P_qqg(z(3))
end if
! get values at borders of the intgral and in the middle
a(1) = a(3)
a(2) = D_alpha_s_fsr (z(2) * (one - z(2)) * prt%t, &
prt%settings) * P(2) / &
(prt%t - 0.5_default * tstep)
a(3) = D_alpha_s_fsr (z(3) * (one - z(3)) * prt%t, &
prt%settings) * P(3) / &
(prt%t - 0.5_default * tstep)
!!! a little tricky:
!!! fit x(1) + x(2)/(1 + c) + x(3)/(1 - c) to these values
a11 = (one+c+0.5_default*cstep) * (one-c-0.5_default*cstep) - &
(one-c) * (one+c+0.5_default*cstep)
a12 = (one-c-0.5_default*cstep) - (one+c+0.5_default*cstep) * &
(one-c) / (one+c)
a13 = a(2) * (one+c+0.5_default*cstep) * (one-c-0.5_default*cstep) - &
a(1) * (one-c) * (one+c+0.5_default*cstep)
a21 = (one+c+cstep) * (one-c-cstep) - (one+c+cstep) * (one-c)
a22 = (one-c-cstep) - (one+c+cstep) * (one-c) / (one+c)
a23 = a(3) * (one+c+cstep) * (one-c-cstep) - &
a(1) * (one-c) * (one+c+cstep)
x(2) = (a23 - a21 * a13 / a11) / (a22 - a12 * a21 / a11)
x(1) = (a13 - a12 * x(2)) / a11
x(3) = a(1) * (one - c) - x(1) * (one - c) - x(2) * (one - c) / (one + c)
integral = integral + tstep * (x(1) * cstep + x(2) * &
log((one + c + cstep) / (one + c)) - x(3) * &
log((one - c - cstep) / (one - c)))
if (integral > to_integral) then
oldt = prt%t
call rng%generate (temprand)
prt%t = prt%t - temprand * tstep
call rng%generate (temprand)
prt%costheta = c + (0.5_default - temprand) * cstep
call prt%set_simulated ()
if (prt%t < prt%settings%min_virtuality + prt%mass_squared ()) then
prt%t = prt%mass_squared ()
end if
if (abs(prt%costheta) > cmax_t) then
! reject branching due to violation of costheta-limits
call rng%generate (random)
if (prt%is_quark ()) then
to_integral = three * pi * log(one / random)
else if (prt%is_gluon ()) then
to_integral = four * pi * log(one / random)
end if
integral = zero
prt%t = oldt
call prt%set_simulated (.false.)
end if
if (prt%is_gluon ()) then
! decide between g->gg and g->qqbar splitting
z(1) = 0.5_default + 0.5_default * prt%costheta
call rng%generate (temprand)
if (P_ggg(z(1)) > temprand * (P_ggg (z(1)) + P_gqq (z(1)) * &
number_of_flavors(prt%t, prt%settings%max_n_flavors, &
prt%settings%min_virtuality))) then
gtoqq = 0
else
call rng%generate (temprand)
gtoqq = 1 + int (temprand * number_of_flavors &
(prt%t, prt%settings%max_n_flavors, &
prt%settings%min_virtuality))
end if
end if
else
c = c + cstep
end if
cmax_t = cmax (prt)
end do
if (integral <= to_integral) then
prt%t = prt%t - tstep
if (prt%t < prt%settings%min_virtuality + prt%mass_squared ()) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
end if
end if
end subroutine parton_simulate_stept
@ %def parton_simulate_stept
@
<<Set [[sister]] if [[lookatsister]] is true or not given>>=
sister => null()
SET_SISTER: do
if (present (lookatsister)) then
if (.not. lookatsister) then
exit SET_SISTER
end if
end if
if (prt%nr == prt%parent%child1%nr) then
sister => prt%parent%child2
else
sister => prt%parent%child1
end if
exit SET_SISTER
end do SET_SISTER
@
@ From the whole ISR algorithm all functionality has been moved to
[[shower_core.f90]]. Only [[maxzz]] remains here, because more than
one module needs to access it.
<<Shower partons: public>>=
public :: maxzz
<<Shower partons: procedures>>=
function maxzz (shat, s, maxz_isr, minenergy_timelike) result (maxz)
real(default), intent(in) :: shat, s, minenergy_timelike, maxz_isr
real(default) :: maxz
maxz = min (maxz_isr, one - (two * minenergy_timelike * sqrt(shat)) / s)
end function maxzz
@ %def maxzz
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Main shower module}
<<[[shower_core.f90]]>>=
<<File header>>
module shower_core
<<Use kinds with double>>
<<Use strings>>
use io_units
use constants
use format_utils, only: write_separator
use numeric_utils
use diagnostics
use physics_defs
use os_interface
use lorentz
use sm_physics
use particles
use model_data
use flavors
use colors
use subevents
use pdf
use rng_base
use shower_base
use shower_partons
use muli, only: muli_t
use hep_common
use tauola_interface
<<Standard module head>>
<<Shower core: public>>
<<Shower core: parameters>>
<<Shower core: types>>
<<Shower core: interfaces>>
contains
<<Shower core: procedures>>
end module shower_core
@ %def shower_core
@
<<Shower core: public>>=
public :: shower_interaction_t
<<Shower core: types>>=
type :: shower_interaction_t
type(parton_pointer_t), dimension(:), allocatable :: partons
end type shower_interaction_t
type :: shower_interaction_pointer_t
type(shower_interaction_t), pointer :: i => null ()
end type shower_interaction_pointer_t
@ %def shower_interaction_t
@ %def shower_interaction_pointer_t
@ The WHIZARD internal shower. Flags distinguish between analytic and
$k_T$-ordered showers.
<<Shower core: public>>=
public :: shower_t
<<Shower core: types>>=
type, extends (shower_base_t) :: shower_t
type(shower_interaction_pointer_t), dimension(:), allocatable :: &
interactions
type(parton_pointer_t), dimension(:), allocatable :: partons
type(muli_t) :: mi
integer :: next_free_nr
integer :: next_color_nr
logical :: valid
contains
<<Shower core: shower: TBP>>
end type shower_t
@ %def shower_t
@
<<Shower core: shower: TBP>>=
procedure :: init => shower_init
<<Shower core: procedures>>=
subroutine shower_init (shower, settings, taudec_settings, pdf_data)
class(shower_t), intent(out) :: shower
type(shower_settings_t), intent(in) :: settings
type(taudec_settings_t), intent(in) :: taudec_settings
type(pdf_data_t), intent(in) :: pdf_data
call msg_debug (D_SHOWER, "shower_init")
shower%settings = settings
shower%taudec_settings = taudec_settings
call shower%pdf_data%init (pdf_data)
shower%name = "WHIZARD internal"
call shower%write_msg ()
end subroutine shower_init
@ %def shower_init
@
<<Shower core: shower: TBP>>=
procedure :: prepare_new_event => shower_prepare_new_event
<<Shower core: procedures>>=
subroutine shower_prepare_new_event (shower)
class(shower_t), intent(inout) :: shower
call shower%cleanup ()
shower%next_free_nr = 1
shower%next_color_nr = 1
if (debug_active (D_SHOWER)) then
if (allocated (shower%interactions)) then
call msg_bug ("Shower: creating new shower while old one " // &
"is still associated (interactions)")
end if
if (allocated (shower%partons)) then
call msg_bug ("Shower: creating new shower while old one " // &
"is still associated (partons)")
end if
end if
treat_light_quarks_massless = .true.
treat_duscb_quarks_massless = .false.
shower%valid = .true.
end subroutine shower_prepare_new_event
@ %def shower_prepare_new_event
@ It would be better to have the muli type outside of the shower.
<<Shower core: shower: TBP>>=
procedure :: activate_multiple_interactions => shower_activate_multiple_interactions
<<Shower core: procedures>>=
subroutine shower_activate_multiple_interactions (shower, os_data)
class(shower_t), intent(inout) :: shower
type(os_data_t), intent(in) :: os_data
if (shower%mi%is_initialized ()) then
call shower%mi%restart ()
else
call shower%mi%initialize (&
GeV2_scale_cutoff=shower%settings%min_virtuality, &
GeV2_s=shower_interaction_get_s &
(shower%interactions(1)%i), &
muli_dir=char(os_data%whizard_mulipath))
end if
call shower%mi%apply_initial_interaction ( &
GeV2_s=shower_interaction_get_s(shower%interactions(1)%i), &
x1=shower%interactions(1)%i%partons(1)%p%parent%x, &
x2=shower%interactions(1)%i%partons(2)%p%parent%x, &
pdg_f1=shower%interactions(1)%i%partons(1)%p%parent%type, &
pdg_f2=shower%interactions(1)%i%partons(2)%p%parent%type, &
n1=shower%interactions(1)%i%partons(1)%p%parent%nr, &
n2=shower%interactions(1)%i%partons(2)%p%parent%nr)
end subroutine shower_activate_multiple_interactions
@ %def shower_activate_multiple_interactions
@
@
<<Shower core: shower: TBP>>=
procedure :: import_particle_set => shower_import_particle_set
<<Shower core: procedures>>=
subroutine shower_import_particle_set (shower, particle_set, os_data, scale)
class(shower_t), target, intent(inout) :: shower
type(particle_set_t), intent(in) :: particle_set
type(os_data_t), intent(in) :: os_data
real(default), intent(in) :: scale
!integer, dimension(:), allocatable :: connections
type(parton_t), dimension(:), allocatable, target, save :: partons, hadrons
type(parton_pointer_t), dimension(:), allocatable :: &
parton_pointers
integer :: n_beam, n_in, n_out, n_tot
integer :: i, j, nr, max_color_nr
call msg_debug (D_SHOWER, 'shower_import_particle_set')
call count_and_allocate ()
call setup_hadrons_from_particle_set ()
call setup_partons_from_particle_set ()
call shower%update_max_color_nr (1 + max_color_nr)
call shower%add_interaction_2ton (parton_pointers)
if (shower%settings%muli_active) then
call shower%activate_multiple_interactions (os_data)
end if
call msg_debug2 (D_SHOWER, 'shower%write() after shower_import_particle_set')
if (debug2_active (D_SHOWER)) then
call shower%write ()
end if
contains
<<Shower core: shower import particle set: procedures>>
end subroutine shower_import_particle_set
@ %def shower_import_particle_set
<<Shower core: shower import particle set: procedures>>=
subroutine count_and_allocate ()
max_color_nr = 0
n_beam = particle_set%get_n_beam ()
n_in = particle_set%get_n_in ()
n_out = particle_set%get_n_out ()
n_tot = particle_set%get_n_tot ()
if (allocated (partons)) deallocate (partons)
allocate (partons (n_in + n_out))
allocate (parton_pointers (n_in+n_out))
end subroutine count_and_allocate
@
<<Shower core: shower import particle set: procedures>>=
subroutine setup_hadrons_from_particle_set ()
j = 0
!!! !!! !!! Workaround for Portland 16.1 compiler bug
!!! if (n_beam > 0 .and. all (particle_set%prt(1:2)%flv%get_pdg_abs () > TAU)) then
if (n_beam > 0 .and. particle_set%prt(1)%flv%get_pdg_abs () > TAU .and. &
particle_set%prt(2)%flv%get_pdg_abs () > TAU) then
call msg_debug (D_SHOWER, 'Copy hadrons from particle_set to hadrons')
if (.not. allocated (hadrons)) allocate (hadrons (1:2))
do i = 1, n_tot
if (particle_set%prt(i)%status == PRT_BEAM) then
j = j + 1
nr = shower%get_next_free_nr ()
hadrons(j) = parton_of_particle (particle_set%prt(i), nr)
hadrons(j)%settings => shower%settings
max_color_nr = max (max_color_nr, abs(hadrons(j)%c1), &
abs(hadrons(j)%c2))
end if
end do
end if
end subroutine setup_hadrons_from_particle_set
@
<<Shower core: shower import particle set: procedures>>=
subroutine setup_partons_from_particle_set ()
integer, dimension(1) :: parent
j = 0
call msg_debug (D_SHOWER, "Copy partons from particle_set to partons")
do i = 1, n_tot
if (particle_set%prt(i)%get_status () == PRT_INCOMING .or. &
particle_set%prt(i)%get_status () == PRT_OUTGOING) then
j = j + 1
nr = shower%get_next_free_nr ()
partons(j) = parton_of_particle (particle_set%prt(i), nr)
partons(j)%settings => shower%settings
parton_pointers(j)%p => partons(j)
max_color_nr = max (max_color_nr, abs (partons(j)%c1), &
abs (partons(j)%c2))
if (particle_set%prt(i)%get_status () == PRT_INCOMING .and. &
particle_set%prt(i)%get_n_parents () == 1 .and. &
allocated (hadrons)) then
parent = particle_set%prt(i)%get_parents ()
partons(j)%initial => hadrons (parent(1))
partons(j)%x = space_part_norm (partons(j)%momentum) / &
space_part_norm (partons(j)%initial%momentum)
end if
end if
end do
end subroutine setup_partons_from_particle_set
@
<<Shower core: shower: TBP>>=
procedure :: generate_emissions => shower_generate_emissions
<<Shower core: procedures>>=
subroutine shower_generate_emissions &
(shower, valid, number_of_emissions)
class(shower_t), intent(inout), target :: shower
logical, intent(out) :: valid
integer, optional, intent(in) :: number_of_emissions
type(parton_t), dimension(:), allocatable, target :: partons
type(parton_pointer_t), dimension(:), allocatable :: &
parton_pointers
real(default) :: mi_scale, ps_scale, shat, phi
type(parton_pointer_t) :: temppp
integer :: i, j, k
integer :: n_int, max_color_nr
integer, dimension(2,4) :: color_corr
call msg_debug (D_SHOWER, "shower_generate_emissions")
if (shower%settings%isr_active) then
call msg_debug (D_SHOWER, "Generate ISR with FSR")
i = 0
BRANCHINGS: do
i = i + 1
if (signal_is_pending ()) return
if (shower%settings%muli_active) then
call shower%mi%generate_gev2_pt2 &
(shower%get_ISR_scale (), mi_scale)
else
mi_scale = 0.0
end if
!!! Shower: debugging
!!! shower%generate_next_isr_branching returns a pointer to
!!! the parton with the next ISR-branching, this parton's
!!! scale is the scale of the next branching
! temppp=shower%generate_next_isr_branching_veto ()
temppp = shower%generate_next_isr_branching ()
if (.not. associated (temppp%p) .and. &
mi_scale < shower%settings%min_virtuality) then
exit BRANCHINGS
end if
!!! check if branching or interaction occurs next
if (associated (temppp%p)) then
ps_scale = abs(temppp%p%t)
else
ps_scale = 0._default
end if
if (mi_scale > ps_scale) then
!!! discard branching evolution lower than mi_scale
call shower%set_max_ISR_scale (mi_scale)
if (associated (temppp%p)) &
call temppp%p%set_simulated (.false.)
!!! execute new interaction
deallocate (partons)
deallocate (parton_pointers)
allocate (partons(1:4))
allocate (parton_pointers(1:4))
do j = 1, 4
partons(j)%nr = shower%get_next_free_nr ()
partons(j)%belongstointeraction = .true.
parton_pointers(j)%p => partons(j)
end do
call shower%mi%generate_partons (partons(1)%nr, partons(2)%nr, &
partons(1)%x, partons(2)%x, &
partons(1)%type, partons(2)%type, &
partons(3)%type, partons(4)%type)
!!! calculate momenta
shat = partons(1)%x *partons(2)%x * &
shower_interaction_get_s (shower%interactions(1)%i)
partons(1)%momentum = [0.5_default * sqrt(shat), &
zero, zero, 0.5_default*sqrt(shat)]
partons(2)%momentum = [0.5_default * sqrt(shat), &
zero, zero, -0.5_default*sqrt(shat)]
call parton_set_initial (partons(1), &
shower%interactions(1)%i%partons(1)%p%initial)
call parton_set_initial (partons(2), &
shower%interactions(1)%i%partons(2)%p%initial)
partons(1)%belongstoFSR = .false.
partons(2)%belongstoFSR = .false.
!!! calculate color connection
call shower%mi%get_color_correlations &
(shower%get_next_color_nr (), &
max_color_nr,color_corr)
call shower%update_max_color_nr (max_color_nr)
partons(1)%c1 = color_corr(1,1)
partons(1)%c2 = color_corr(2,1)
partons(2)%c1 = color_corr(1,2)
partons(2)%c2 = color_corr(2,2)
partons(3)%c1 = color_corr(1,3)
partons(3)%c2 = color_corr(2,3)
partons(4)%c1 = color_corr(1,4)
partons(4)%c2 = color_corr(2,4)
call shower%rng%generate (phi)
phi = 2 * pi * phi
partons(3)%momentum = [0.5_default*sqrt(shat), &
sqrt(mi_scale)*cos(phi), &
sqrt(mi_scale)*sin(phi), &
sqrt(0.25_default*shat - mi_scale)]
partons(4)%momentum = [ 0.5_default*sqrt(shat), &
-sqrt(mi_scale)*cos(phi), &
-sqrt(mi_scale)*sin(phi), &
-sqrt(0.25_default*shat - mi_scale)]
partons(3)%belongstoFSR = .true.
partons(4)%belongstoFSR = .true.
call shower%add_interaction_2ton (parton_pointers)
n_int = size (shower%interactions)
do k = 1, 2
call shower%mi%replace_parton &
(shower%interactions(n_int)%i%partons(k)%p%initial%nr, &
shower%interactions(n_int)%i%partons(k)%p%nr, &
shower%interactions(n_int)%i%partons(k)%p%parent%nr, &
shower%interactions(n_int)%i%partons(k)%p%type, &
shower%interactions(n_int)%i%partons(k)%p%x, &
mi_scale)
end do
else
!!! execute the next branching 'found' in the previous step
call shower%execute_next_isr_branching (temppp)
if (shower%settings%muli_active) then
call shower%mi%replace_parton (temppp%p%initial%nr, &
temppp%p%child1%nr, temppp%p%nr, &
temppp%p%type, temppp%p%x, ps_scale)
end if
end if
end do BRANCHINGS
call shower%generate_fsr_for_isr_partons ()
else
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "Generate FSR without ISR")
call shower%simulate_no_isr_shower ()
end if
!!! some bookkeeping, needed after the shower is done
call shower%boost_to_labframe ()
call shower%generate_primordial_kt ()
call shower%update_beamremnants ()
if (shower%settings%fsr_active) then
do i = 1, size (shower%interactions)
if (signal_is_pending ()) return
call shower%interaction_generate_fsr_2ton &
(shower%interactions(i)%i)
end do
else
call shower%simulate_no_fsr_shower ()
end if
call msg_debug (D_SHOWER, "Shower finished:")
if (debug_active (D_SHOWER)) call shower%write ()
valid = shower%valid
!!! clean-up muli: we should finalize the muli pdf sets
!!! when _all_ runs are done. Not after every event if possible
! call shower%mi%finalize()
end subroutine shower_generate_emissions
@ %def shower_generate_emissions
@
<<Shower core: shower: TBP>>=
procedure :: make_particle_set => shower_make_particle_set
<<Shower core: procedures>>=
subroutine shower_make_particle_set &
(shower, particle_set, model, model_hadrons)
class(shower_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model
class(model_data_t), intent(in), target :: model_hadrons
call shower%combine_with_particle_set (particle_set, model, &
model_hadrons)
if (shower%settings%hadronization_active) then
call shower%converttopythia ()
end if
end subroutine shower_make_particle_set
@ %def shower_make_particle_set
@ The parameters of the shower module:
<<Shower core: parameters>>=
real(default), save :: alphasxpdfmax = 12._default
@ %def alphasxpdfmax
@
@ In this routine, [[y]] and [[ymin]] are the jet measures, [[w]] and
[[wmax]] are weights, [[s]] is the kinematic energy squared of the
interaction. The flag [[isr_is_possible_and_allowed]] checks whether the initial
parton is set, lepton-hadron collisions are not implemented (yet).
% TODO: (bcn 2015-04-23) I dont understand the workaround
As a workaround: as WHIZARD can treat partons as massless, there might
be partons with $E < m$: if such a parton is found, quarks will be
treated massless.
<<Shower core: shower: TBP>>=
procedure :: add_interaction_2ton => shower_add_interaction_2ton
<<Shower core: procedures>>=
subroutine shower_add_interaction_2ton (shower, partons)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t), intent(in), dimension(:), allocatable :: partons
!type(ckkw_pseudo_shower_weights_t), intent(in) :: ckkw_pseudo_weights
integer :: n_partons, n_out
integer :: i, j, imin, jmin
real(default) :: y, ymin
!real(default) :: w, wmax
!real(default) :: random, sum
type(parton_pointer_t), dimension(:), allocatable :: new_partons
type(parton_t), pointer :: prt
integer :: n_int
type(shower_interaction_pointer_t), dimension(:), allocatable :: temp
type(vector4_t) :: prtmomentum, childmomentum
logical :: isr_is_possible_and_allowed
type(lorentz_transformation_t) :: L
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "Add interaction2toN")
n_partons = size (partons)
n_out = n_partons - 2
if (n_out < 2) then
call msg_bug &
("Shower core: trying to add a 2-> (something<2) interaction")
end if
isr_is_possible_and_allowed = (associated (partons(1)%p%initial) &
.and. associated (partons(2)%p%initial)) .and. &
shower%settings%isr_active
call msg_debug (D_SHOWER, "isr_is_possible_and_allowed", &
isr_is_possible_and_allowed)
if (associated (partons(1)%p%initial) .and. &
partons(1)%p%is_quark ()) then
if (partons(1)%p%momentum%p(0) < &
two * partons(1)%p%mass()) then
if (abs(partons(1)%p%type) < 2) then
treat_light_quarks_massless = .true.
else
treat_duscb_quarks_massless = .true.
end if
end if
end if
if (associated (partons(2)%p%initial) .and. &
partons(2)%p%is_quark ()) then
if (partons(2)%p%momentum%p(0) < &
two * partons(2)%p%mass()) then
if (abs(partons(2)%p%type) < 2) then
treat_light_quarks_massless = .true.
else
treat_duscb_quarks_massless = .true.
end if
end if
end if
<<Add a new interaction to [[shower%interactions]]>>
if (associated (shower%interactions(n_int)%i%partons(1)%p%initial)) &
call shower%interactions(n_int)%i%partons(1)%p%initial%set_simulated ()
if (associated (shower%interactions(n_int)%i%partons(2)%p%initial)) &
call shower%interactions(n_int)%i%partons(2)%p%initial%set_simulated ()
if (isr_is_possible_and_allowed) then
!!! boost to the CMFrame of the incoming partons
L = boost (-(shower%interactions(n_int)%i%partons(1)%p%momentum + &
shower%interactions(n_int)%i%partons(2)%p%momentum), &
(shower%interactions(n_int)%i%partons(1)%p%momentum + &
shower%interactions(n_int)%i%partons(2)%p%momentum)**1 )
do i = 1, n_partons
call parton_apply_lorentztrafo &
(shower%interactions(n_int)%i%partons(i)%p, L)
end do
end if
do i = 1, size (partons)
if (signal_is_pending ()) return
!!! partons are marked as belonging to the hard interaction
shower%interactions(n_int)%i%partons(i)%p%belongstointeraction &
= .true.
shower%interactions(n_int)%i%partons(i)%p%belongstoFSR = i > 2
shower%interactions(n_int)%i%partons(i)%p%interactionnr = n_int
!!! include a 2^(i - 1) number as a label for the ckkw clustering
shower%interactions(n_int)%i%partons(i)%p%ckkwlabel = 2**(i - 1)
end do
<<Add partons from [[shower%interactions]] to [[shower%partons]]>>
if (isr_is_possible_and_allowed) then
if (shower%settings%isr_pt_ordered) then
call shower_prepare_for_simulate_isr_pt &
(shower, shower%interactions(size (shower%interactions))%i)
else
call shower_prepare_for_simulate_isr_ana_test &
(shower, shower%interactions(n_int)%i%partons(1)%p, &
shower%interactions(n_int)%i%partons(2)%p)
end if
end if
!!! generate pseudo parton shower history and add all partons to
!!! shower%partons-array
!!! TODO initial -> initial + final branchings ??
allocate (new_partons(1:(n_partons - 2)))
do i = 1, size (new_partons)
nullify (new_partons(i)%p)
end do
do i = 1, size (new_partons)
new_partons(i)%p => shower%interactions(n_int)%i%partons(i + 2)%p
end do
imin = 0
jmin = 0
! TODO: (bcn 2015-04-24) make this a clustering step of the matching
! if (allocated (ckkw_pseudo_weights%weights)) then
! !<Perform clustering using the CKKW weights>>
! else
<<Perform clustering in the usual way>>
! end if
!!! set the FSR starting scale for all partons
do i = 1, size (new_partons)
!!! the imaginary mother is the only parton remaining in new_partons
if (.not. associated (new_partons(i)%p)) cycle
call set_starting_scale (new_partons(i)%p, &
get_starting_scale (new_partons(i)%p))
exit
end do
contains
<<Procedures of [[shower_add_interaction_2ton]]>>
end subroutine shower_add_interaction_2ton
@ %def shower_add_interaction_2ton
@
<<Add a new interaction to [[shower%interactions]]>>=
if (allocated (shower%interactions)) then
n_int = size (shower%interactions) + 1
else
n_int = 1
end if
allocate (temp (1:n_int))
do i = 1, n_int - 1
allocate (temp(i)%i)
temp(i)%i = shower%interactions(i)%i
end do
allocate (temp(n_int)%i)
allocate (temp(n_int)%i%partons(1:n_partons))
do i = 1, n_partons
allocate (temp(n_int)%i%partons(i)%p)
call parton_copy (partons(i)%p, temp(n_int)%i%partons(i)%p)
end do
if (allocated (shower%interactions)) deallocate(shower%interactions)
allocate (shower%interactions(1:n_int))
do i = 1, n_int
shower%interactions(i)%i => temp(i)%i
end do
deallocate (temp)
@
<<Add partons from [[shower%interactions]] to [[shower%partons]]>>=
if (allocated (shower%partons)) then
allocate (new_partons(1:size(shower%partons) + &
size(shower%interactions(n_int)%i%partons)))
do i = 1, size (shower%partons)
new_partons(i)%p => shower%partons(i)%p
end do
do i = 1, size (shower%interactions(n_int)%i%partons)
new_partons(size(shower%partons) + i)%p => &
shower%interactions(n_int)%i%partons(i)%p
end do
deallocate (shower%partons)
else
allocate (new_partons(1:size(shower%interactions(n_int)%i%partons)))
do i = 1, size (partons)
new_partons(i)%p => shower%interactions(n_int)%i%partons(i)%p
end do
end if
allocate (shower%partons(1:size (new_partons)))
do i = 1, size (new_partons)
shower%partons(i)%p => new_partons(i)%p
end do
deallocate (new_partons)
@
<<Perform clustering using the CKKW weights>>=
CKKW_CLUSTERING: do
!!! search for the combination with the highest weight
wmax = zero
CKKW_OUTER: do i = 1, size (new_partons)
CKKW_INNER: do j = i + 1, size (new_partons)
if (.not. associated (new_partons(i)%p)) cycle
if (.not. associated (new_partons(j)%p)) cycle
w = ckkw_pseudo_weights%weights(new_partons(i)%p%ckkwlabel + &
new_partons(j)%p%ckkwlabel)
if (w > wmax .or. vanishes(wmax)) then
wmax = w
imin = i
jmin = j
end if
end do CKKW_INNER
end do CKKW_OUTER
if (wmax > zero) then
call shower%add_parent (new_partons(imin)%p)
call parton_set_child (new_partons(imin)%p%parent, &
new_partons(jmin)%p, 2)
call parton_set_parent (new_partons(jmin)%p, &
new_partons(imin)%p%parent)
prt => new_partons(imin)%p%parent
prt%nr = shower_get_next_free_nr (shower)
prt%type = INTERNAL
prt%momentum = new_partons(imin)%p%momentum + &
new_partons(jmin)%p%momentum
prt%t = prt%momentum**2
!!! auxilliary values for the ckkw matching
!!! for now, randomly choose the type of the intermediate
prt%ckkwlabel = new_partons(imin)%p%ckkwlabel + &
new_partons(jmin)%p%ckkwlabel
sum = zero
call shower%rng%generate (random)
CKKW_TYPE: do i = 0, 4
if (sum + &
ckkw_pseudo_weights%weights_by_type(prt%ckkwlabel, i) > &
random * ckkw_pseudo_weights%weights(prt%ckkwlabel) ) then
prt%ckkwtype = i
exit ckkw_type
end if
sum = sum + &
ckkw_pseudo_weights%weights_by_type(prt%ckkwlabel, i)
end do CKKW_TYPE
!!! TODO -> calculate costheta and store it for
!!! later use in generate_ps
if (space_part_norm(prt%momentum) > tiny_10) then
prtmomentum = prt%momentum
childmomentum = prt%child1%momentum
prtmomentum = boost (- prt%get_beta() / &
sqrt (one - &
(prt%get_beta ())**2), space_part (prt%momentum) / &
space_part_norm(prt%momentum)) * prtmomentum
childmomentum = boost (- prt%get_beta () / &
sqrt(one - &
(prt%get_beta ())**2), space_part (prt%momentum) / &
space_part_norm(prt%momentum)) * childmomentum
prt%costheta = enclosed_angle_ct(prtmomentum, childmomentum)
else
prt%costheta = - one
end if
prt%belongstointeraction = .true.
prt%belongstoFSR = &
new_partons(imin)%p%belongstoFSR .and. &
new_partons(jmin)%p%belongstoFSR
nullify (new_partons(imin)%p)
nullify (new_partons(jmin)%p)
new_partons(imin)%p => prt
else
exit CKKW_CLUSTERING
end if
end do CKKW_CLUSTERING
@
<<Perform clustering in the usual way>>=
CLUSTERING: do
!!! search for the partons to be clustered together
ymin = zero
OUTER: do i = 1, size (new_partons)
INNER: do j = i + 1, size (new_partons)
!!! calculate the jet measure
if (.not.associated (new_partons(i)%p)) cycle INNER
if (.not.associated (new_partons(j)%p)) cycle INNER
!if (.not. shower_clustering_allowed &
!(shower, new_partons, i,j)) &
!cycle inner
!!! Durham jet-measure ! don't care about constants
y = min (new_partons(i)%p%momentum%p(0), &
new_partons(j)%p%momentum%p(0)) * &
(one - enclosed_angle_ct &
(new_partons(i)%p%momentum, &
new_partons(j)%p%momentum))
if (y < ymin .or. vanishes(ymin)) then
ymin = y
imin = i
jmin = j
end if
end do INNER
end do OUTER
if (ymin > zero) then
call shower%add_parent (new_partons(imin)%p)
call parton_set_child &
(new_partons(imin)%p%parent, new_partons(jmin)%p, 2)
call parton_set_parent &
(new_partons(jmin)%p, new_partons(imin)%p%parent)
prt => new_partons(imin)%p%parent
prt%nr = shower_get_next_free_nr (shower)
prt%type = INTERNAL
prt%momentum = new_partons(imin)%p%momentum + &
new_partons(jmin)%p%momentum
prt%t = prt%momentum**2
!!! TODO -> calculate costheta and store it for
!!! later use in generate_ps
if (space_part_norm(prt%momentum) > tiny_10) then
prtmomentum = prt%momentum
childmomentum = prt%child1%momentum
prtmomentum = boost (- prt%get_beta () / sqrt(one - &
(prt%get_beta ())**2), space_part(prt%momentum) / &
space_part_norm(prt%momentum)) * prtmomentum
childmomentum = boost (- prt%get_beta() / &
sqrt(one - &
(prt%get_beta ())**2), space_part(prt%momentum) / &
space_part_norm(prt%momentum)) * childmomentum
prt%costheta = enclosed_angle_ct (prtmomentum, childmomentum)
else
prt%costheta = - one
end if
prt%belongstointeraction = .true.
nullify (new_partons(imin)%p)
nullify (new_partons(jmin)%p)
new_partons(imin)%p => prt
else
exit CLUSTERING
end if
end do CLUSTERING
@
<<Procedures of [[shower_add_interaction_2ton]]>>=
recursive subroutine transfer_pointers (destiny, start, prt)
type(parton_pointer_t), dimension(:), allocatable :: destiny
integer, intent(inout) :: start
type(parton_t), pointer :: prt
destiny(start)%p => prt
start = start + 1
if (associated (prt%child1)) then
call transfer_pointers (destiny, start, prt%child1)
end if
if (associated (prt%child2)) then
call transfer_pointers (destiny, start, prt%child2)
end if
end subroutine transfer_pointers
@
<<Procedures of [[shower_add_interaction_2ton]]>>=
recursive function get_starting_scale (prt) result (scale)
type(parton_t), pointer :: prt
real(default) :: scale
scale = huge (scale)
if (associated (prt%child1) .and. associated (prt%child2)) then
scale = min(scale, prt%t)
end if
if (associated (prt%child1)) then
scale = min (scale, get_starting_scale (prt%child1))
end if
if (associated (prt%child2)) then
scale = min (scale, get_starting_scale (prt%child2))
end if
end function get_starting_scale
@
<<Procedures of [[shower_add_interaction_2ton]]>>=
recursive subroutine set_starting_scale (prt, scale)
type(parton_t), pointer :: prt
real(default) :: scale
if (prt%type /= INTERNAL) then
if (scale > prt%settings%min_virtuality + prt%mass_squared ()) then
prt%t = scale
else
prt%t = prt%mass_squared ()
call prt%set_simulated ()
end if
end if
if (associated (prt%child1)) then
call set_starting_scale (prt%child1, scale)
end if
if (associated (prt%child2)) then
call set_starting_scale (prt%child2, scale)
end if
end subroutine set_starting_scale
@
<<Shower core: shower: TBP>>=
procedure :: simulate_no_isr_shower => shower_simulate_no_isr_shower
<<Shower core: procedures>>=
subroutine shower_simulate_no_isr_shower (shower)
class(shower_t), intent(inout) :: shower
integer :: i, j
type(parton_t), pointer :: prt
call msg_debug (D_SHOWER, "shower_simulate_no_isr_shower")
do i = 1, size (shower%interactions)
do j = 1, 2
prt => shower%interactions(i)%i%partons(j)%p
if (associated (prt%initial)) then
!!! for virtuality ordered: remove unneeded partons
if (associated (prt%parent)) then
if (.not. prt%parent%is_proton ()) then
if (associated (prt%parent%parent)) then
if (.not. prt%parent%is_proton ()) then
call shower_remove_parton_from_partons &
(shower, prt%parent%parent)
end if
end if
call shower_remove_parton_from_partons &
(shower, prt%parent)
end if
end if
call parton_set_parent (prt, prt%initial)
call parton_set_child (prt%initial, prt, 1)
if (associated (prt%initial%child2)) then
call shower_remove_parton_from_partons &
(shower,prt%initial%child2)
deallocate (prt%initial%child2)
end if
call shower%add_child (prt%initial, 2)
end if
end do
end do
end subroutine shower_simulate_no_isr_shower
@ %def shower_simulate_no_isr_shower
@
<<Shower core: shower: TBP>>=
procedure :: simulate_no_fsr_shower => shower_simulate_no_fsr_shower
<<Shower core: procedures>>=
subroutine shower_simulate_no_fsr_shower (shower)
class(shower_t), intent(inout) :: shower
integer :: i, j
type(parton_t), pointer :: prt
do i = 1, size (shower%interactions)
do j = 3, size (shower%interactions(i)%i%partons)
prt => shower%interactions(i)%i%partons(j)%p
call prt%set_simulated ()
prt%scale = zero
prt%t = prt%mass_squared ()
end do
end do
end subroutine shower_simulate_no_fsr_shower
@ %def shower_simulate_no_fsr_shower
@
<<Shower core: procedures>>=
subroutine swap_pointers (prtp1, prtp2)
type(parton_pointer_t), intent(inout) :: prtp1, prtp2
type(parton_pointer_t) :: prtptemp
prtptemp%p => prtp1%p
prtp1%p => prtp2%p
prtp2%p => prtptemp%p
end subroutine swap_pointers
@ %def swap_pointers
@ This removes emitted timelike partons.
<<Shower core: procedures>>=
recursive subroutine shower_remove_parton_from_partons (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), pointer :: prt
integer :: i
if (.not. prt%belongstoFSR .and. associated (prt%child2)) then
call shower_remove_parton_from_partons_recursive (shower, prt%child2)
end if
do i = 1, size (shower%partons)
if (associated (shower%partons(i)%p, prt)) then
shower%partons(i)%p => null()
! TODO: (bcn 2015-05-05) memory leak here? no deallocation?
exit
end if
if (debug_active (D_SHOWER)) then
if (i == size (shower%partons)) then
call msg_bug ("shower_remove_parton_from_partons: parton&
&to be removed not found")
end if
end if
end do
end subroutine shower_remove_parton_from_partons
@ %def shower_remove_parton_from_partons
@ This removes the parton [[prt]] and all its children.
<<Shower core: procedures>>=
recursive subroutine shower_remove_parton_from_partons_recursive (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), pointer :: prt
if (associated (prt%child1)) then
call shower_remove_parton_from_partons_recursive (shower, prt%child1)
deallocate (prt%child1)
end if
if (associated (prt%child2)) then
call shower_remove_parton_from_partons_recursive (shower, prt%child2)
deallocate (prt%child2)
end if
call shower_remove_parton_from_partons (shower, prt)
end subroutine shower_remove_parton_from_partons_recursive
@ %def shower_remove_parton_from_partons_recursive
@
<<Shower core: shower: TBP>>=
procedure :: sort_partons => shower_sort_partons
<<Shower core: procedures>>=
subroutine shower_sort_partons (shower)
class(shower_t), intent(inout) :: shower
integer :: i, j, maxsort, size_partons
logical :: changed
call msg_debug2 (D_SHOWER, "shower_sort_partons")
if (.not. allocated (shower%partons)) return
size_partons = size (shower%partons)
maxsort = 0
do i = 1, size_partons
if (associated (shower%partons(i)%p)) maxsort = i
end do
if (signal_is_pending ()) return
size_partons = size (shower%partons)
if (size_partons <= 1) return
do i = 1, maxsort
if (.not. associated (shower%partons(i)%p)) cycle
if (.not. shower%settings%isr_pt_ordered) then
!!! set unsimulated ISR partons to be "typeless" to prevent
!!! influences from "wrong" masses
if (.not. shower%partons(i)%p%belongstoFSR .and. &
.not. shower%partons(i)%p%simulated .and. &
.not. shower%partons(i)%p%belongstointeraction) then
shower%partons(i)%p%type = 0
end if
end if
end do
if (signal_is_pending ()) return
!!! Just a Bubblesort
!!! Different algorithms needed for t-ordered and pt^2-ordered shower
!!! Pt-ordered:
if (shower%settings%isr_pt_ordered) then
OUTERDO_PT: do i = 1, maxsort - 1
changed = .false.
INNERDO_PT: do j = 1, maxsort - i
if (.not. associated (shower%partons(j + 1)%p)) cycle
if (.not. associated (shower%partons(j)%p)) then
!!! change if j + 1 ist assoaciated and j is not
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else if (shower%partons(j)%p%scale < &
shower%partons(j + 1)%p%scale) then
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else if (nearly_equal(shower%partons(j)%p%scale, &
shower%partons(j + 1)%p%scale)) then
if (shower%partons(j)%p%nr > shower%partons(j + 1)%p%nr) then
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
end if
end if
end do INNERDO_PT
if (.not. changed) exit OUTERDO_PT
end do outerdo_pt
!!! |t|-ordered
else
OUTERDO_T: do i = 1, maxsort - 1
changed = .false.
INNERDO_T: do j = 1, maxsort - i
if (.not. associated (shower%partons(j + 1)%p)) cycle
if (.not. associated (shower%partons(j)%p)) then
!!! change if j+1 is associated and j isn't
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else if (.not. shower%partons(j)%p%belongstointeraction .and. &
shower%partons(j + 1)%p%belongstointeraction) then
!!! move partons belonging to the interaction to the front
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else if (.not. shower%partons(j)%p%belongstointeraction .and. &
.not. shower%partons(j + 1)%p%belongstointeraction ) then
if (abs (shower%partons(j)%p%t) - &
shower%partons(j)%p%mass_squared () < &
abs(shower%partons(j + 1)%p%t) - &
shower%partons(j + 1)%p%mass_squared ()) then
call swap_pointers (shower%partons(j), shower%partons(j + 1))
changed = .true.
else
if (nearly_equal(abs (shower%partons(j)%p%t) - &
shower%partons(j)%p%mass_squared (), &
abs(shower%partons(j + 1)%p%t) - &
shower%partons(j + 1)%p%mass_squared ())) then
if (shower%partons(j)%p%nr > &
shower%partons(j + 1)%p%nr) then
call swap_pointers (shower%partons(j), &
shower%partons(j + 1))
changed = .true.
end if
end if
end if
end if
end do INNERDO_T
if (.not. changed) exit OUTERDO_T
end do OUTERDO_T
end if
end subroutine shower_sort_partons
@ %def shower_sort_partons
@ Deallocate the interaction pointers.
<<Shower core: shower: TBP>>=
procedure :: cleanup => shower_cleanup
<<Shower core: procedures>>=
subroutine shower_cleanup (shower)
class(shower_t), intent(inout) :: shower
integer :: i
if (allocated (shower%interactions)) then
do i = 1, size (shower%interactions)
if (allocated (shower%interactions(i)%i%partons)) &
deallocate (shower%interactions(i)%i%partons)
deallocate (shower%interactions(i)%i)
end do
deallocate (shower%interactions)
end if
if (allocated (shower%partons)) deallocate (shower%partons)
end subroutine shower_cleanup
@ %def shower_cleanup
@ Bookkeeping functions.
<<Shower core: shower: TBP>>=
procedure :: get_next_free_nr => shower_get_next_free_nr
<<Shower core: procedures>>=
function shower_get_next_free_nr (shower) result (next_number)
class(shower_t), intent(inout) :: shower
integer :: next_number
next_number = shower%next_free_nr
shower%next_free_nr = shower%next_free_nr + 1
end function shower_get_next_free_nr
@ %def shower_get_next_free_nr
@
<<Shower core: shower: TBP>>=
procedure :: update_max_color_nr => shower_update_max_color_nr
<<Shower core: procedures>>=
pure subroutine shower_update_max_color_nr (shower, index)
class(shower_t), intent(inout) :: shower
integer, intent(in) :: index
if (index > shower%next_color_nr) then
shower%next_color_nr = index
end if
end subroutine shower_update_max_color_nr
@ %def shower_update_max_color_nr
<<Shower core: shower: TBP>>=
procedure :: get_next_color_nr => shower_get_next_color_nr
<<Shower core: procedures>>=
function shower_get_next_color_nr (shower) result (next_color)
class(shower_t), intent(inout) :: shower
integer :: next_color
next_color = shower%next_color_nr
shower%next_color_nr = shower%next_color_nr + 1
end function shower_get_next_color_nr
@ %def shower_get_next_color_nr
@
<<Shower core: procedures>>=
subroutine shower_enlarge_partons_array (shower, custom_length)
type(shower_t), intent(inout) :: shower
integer, intent(in), optional :: custom_length
integer :: i, length, oldlength
type(parton_pointer_t), dimension(:), allocatable :: tmp_partons
call msg_debug (D_SHOWER, "shower_enlarge_partons_array")
if (present(custom_length)) then
length = custom_length
else
length = 10
end if
if (debug_active (D_SHOWER)) then
if (length < 1) then
call msg_bug ("Shower: no parton_pointers added in shower%partons")
end if
end if
if (allocated (shower%partons)) then
oldlength = size (shower%partons)
allocate (tmp_partons(1:oldlength))
do i = 1, oldlength
tmp_partons(i)%p => shower%partons(i)%p
end do
deallocate (shower%partons)
else
oldlength = 0
end if
allocate (shower%partons(1:oldlength + length))
do i = 1, oldlength
shower%partons(i)%p => tmp_partons(i)%p
end do
do i = oldlength + 1, oldlength + length
shower%partons(i)%p => null()
end do
end subroutine shower_enlarge_partons_array
@ %def shower_enlarge_partons_array
@
<<Shower core: shower: TBP>>=
procedure :: add_child => shower_add_child
<<Shower core: procedures>>=
subroutine shower_add_child (shower, prt, child)
class(shower_t), intent(inout) :: shower
type(parton_t), pointer :: prt
integer, intent(in) :: child
integer :: i, lastfree
type(parton_pointer_t) :: newprt
if (child /= 1 .and. child /= 2) then
call msg_bug ("Shower: Adding child in nonexisting place")
end if
allocate (newprt%p)
newprt%p%nr = shower%get_next_free_nr ()
!!! add new parton as child
if (child == 1) then
prt%child1 => newprt%p
else
prt%child2 => newprt%p
end if
newprt%p%parent => prt
if (associated (prt%settings)) then
newprt%p%settings => prt%settings
end if
newprt%p%interactionnr = prt%interactionnr
!!! add new parton to shower%partons list
if (associated (shower%partons (size(shower%partons))%p)) then
call shower_enlarge_partons_array (shower)
end if
!!! find last free pointer and let it point to the new parton
lastfree = 0
do i = size (shower%partons), 1, -1
if (.not. associated (shower%partons(i)%p)) then
lastfree = i
end if
end do
if (lastfree == 0) then
call msg_bug ("Shower: no free pointers found")
end if
shower%partons(lastfree)%p => newprt%p
end subroutine shower_add_child
@ %def shower_add_child
@
<<Shower core: shower: TBP>>=
procedure :: add_parent => shower_add_parent
<<Shower core: procedures>>=
subroutine shower_add_parent (shower, prt)
class(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
integer :: i, lastfree
type(parton_pointer_t) :: newprt
call msg_debug2 (D_SHOWER, "shower_add_parent: for parton nr", prt%nr)
allocate (newprt%p)
newprt%p%nr = shower%get_next_free_nr ()
!!! add new parton as parent
newprt%p%child1 => prt
prt%parent => newprt%p
if (associated (prt%settings)) then
newprt%p%settings => prt%settings
end if
newprt%p%interactionnr = prt%interactionnr
!!! add new parton to shower%partons list
if (.not. allocated (shower%partons) .or. &
associated (shower%partons(size(shower%partons))%p)) then
call shower_enlarge_partons_array (shower)
end if
!!! find last free pointer and let it point to the new parton
lastfree = 0
do i = size(shower%partons), 1, -1
if (.not. associated (shower%partons(i)%p)) then
lastfree = i
end if
end do
if (debug_active (D_SHOWER)) then
if (lastfree == 0) then
call msg_bug ("Shower: no free pointers found")
end if
end if
shower%partons(lastfree)%p => newprt%p
end subroutine shower_add_parent
@ %def shower_add_parent
@ For debugging:
<<Shower core: procedures>>=
pure function shower_get_total_momentum (shower) result (mom)
type(shower_t), intent(in) :: shower
type(vector4_t) :: mom
integer :: i
if (.not. allocated (shower%partons)) return
mom = vector4_null
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
if (shower%partons(i)%p%is_final ()) then
mom = mom + shower%partons(i)%p%momentum
end if
end do
end function shower_get_total_momentum
@ %def shower_get_total_momentum
@ Count the number of partons by going through [[shower%partons]]
whereby you can require a minimum energy [[mine]] and specify whether to
[[include_remnants]], which is done if not given.
<<Shower core: shower: TBP>>=
procedure :: get_nr_of_partons => shower_get_nr_of_partons
<<Shower core: procedures>>=
function shower_get_nr_of_partons (shower, mine, &
include_remnants, no_hard_prts, only_colored) result (nr)
class(shower_t), intent(in) :: shower
real(default), intent(in), optional :: mine
logical, intent(in), optional :: include_remnants, no_hard_prts, &
only_colored
logical :: no_hard, only_col, include_rem
integer :: nr, i
nr = 0
no_hard = .false.; if (present (no_hard_prts)) &
no_hard = no_hard_prts
only_col = .false.; if (present (only_colored)) &
only_col = only_colored
include_rem = .true.; if (present (include_remnants)) &
include_rem = include_remnants
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
associate (prt => shower%partons(i)%p)
if (.not. prt%is_final ()) cycle
if (present (only_colored)) then
if (only_col) then
if (.not. prt%is_colored ()) cycle
else
if (prt%is_colored ()) cycle
end if
end if
if (no_hard) then
if (shower%partons(i)%p%belongstointeraction) cycle
end if
if (.not. include_rem) then
if (prt%type == BEAM_REMNANT) cycle
end if
if (present(mine)) then
if (prt%momentum%p(0) < mine) cycle
end if
nr = nr + 1
end associate
end do
end function shower_get_nr_of_partons
@ %def shower_get_nr_of_partons
@
<<Shower core: procedures>>=
function shower_get_nr_of_final_colored_ME_partons (shower) result (nr)
type(shower_t), intent(in) :: shower
integer :: nr
integer :: i, j
type(parton_t), pointer :: prt
nr = 0
do i = 1, size (shower%interactions)
do j = 1, size (shower%interactions(i)%i%partons)
prt => shower%interactions(i)%i%partons(j)%p
if (.not. associated (prt)) cycle
if (.not. prt%is_colored ()) cycle
if (prt%belongstointeraction .and. prt%belongstoFSR .and. &
(prt%type /= INTERNAL)) then
nr = nr +1
end if
end do
end do
end function shower_get_nr_of_final_colored_ME_partons
@ %def shower_get_nr_of_final_colored_ME_partons
@
<<Shower core: shower: TBP>>=
procedure :: get_final_colored_ME_momenta => &
shower_get_final_colored_ME_momenta
<<Shower core: procedures>>=
subroutine shower_get_final_colored_ME_momenta (shower, momenta)
class(shower_t), intent(in) :: shower
type(vector4_t), dimension(:), allocatable, intent(out) :: momenta
type(parton_pointer_t), dimension(:), allocatable :: partons
integer :: i, j, index, s
type(parton_t), pointer :: prt
s = shower_get_nr_of_final_colored_ME_partons (shower)
if (s == 0) return
allocate (partons(1:s))
allocate (momenta(1:s))
index = 0
do i = 1, size (shower%interactions)
do j = 1, size (shower%interactions(i)%i%partons)
prt => shower%interactions(i)%i%partons(j)%p
if (.not. associated (prt)) cycle
if (.not. prt%is_colored ()) cycle
if (prt%belongstointeraction .and. prt%belongstoFSR .and. &
(prt%type /= INTERNAL)) then
index = index + 1
partons(index)%p => prt
end if
end do
end do
do i = 1, s ! pointers forbid array notation
momenta(i) = partons(i)%p%momentum
end do
end subroutine shower_get_final_colored_ME_momenta
@ %def shower_get_final_colored_ME_momenta
@
<<Shower core: procedures>>=
recursive function interaction_fsr_is_finished_for_parton &
(prt) result (finished)
type(parton_t), intent(in) :: prt
logical :: finished
if (prt%belongstoFSR) then
!!! FSR partons
if (associated (prt%child1)) then
finished = interaction_fsr_is_finished_for_parton (prt%child1) &
.and. interaction_fsr_is_finished_for_parton (prt%child2)
else
finished = prt%t <= prt%mass_squared ()
end if
else
!!! search for emitted timelike partons in ISR shower
if (.not. associated (prt%initial)) then
!!! no inital -> no ISR
finished = .true.
else if (.not. associated (prt%parent)) then
finished = .false.
else
if (.not. prt%parent%is_proton ()) then
if (associated (prt%child2)) then
finished = interaction_fsr_is_finished_for_parton (prt%parent) .and. &
interaction_fsr_is_finished_for_parton (prt%child2)
else
finished = interaction_fsr_is_finished_for_parton (prt%parent)
end if
else
if (associated (prt%child2)) then
finished = interaction_fsr_is_finished_for_parton (prt%child2)
else
!!! only second partons can come here -> if that happens FSR
!!! evolution is not existing
finished = .true.
end if
end if
end if
end if
end function interaction_fsr_is_finished_for_parton
@ %def interaction_fsr_is_finished_for_parton
@
<<Shower core: procedures>>=
function interaction_fsr_is_finished (interaction) result (finished)
type(shower_interaction_t), intent(in) :: interaction
logical :: finished
integer :: i
finished = .true.
if (.not. allocated (interaction%partons)) return
do i = 1, size (interaction%partons)
if (.not. interaction_fsr_is_finished_for_parton &
(interaction%partons(i)%p)) then
finished = .false.
exit
end if
end do
end function interaction_fsr_is_finished
@ %def interaction_fsr_is_finished
@
<<Shower core: public>>=
public :: shower_interaction_get_s
<<Shower core: procedures>>=
function shower_interaction_get_s (interaction) result (s)
type(shower_interaction_t), intent(in) :: interaction
real(default) :: s
s = (interaction%partons(1)%p%initial%momentum + &
interaction%partons(2)%p%initial%momentum)**2
end function shower_interaction_get_s
@ %def shower_interaction_get_s
@
<<Shower core: procedures>>=
function shower_fsr_is_finished (shower) result (finished)
type(shower_t), intent(in) :: shower
logical :: finished
integer :: i
finished = .true.
if (.not. allocated (shower%interactions)) return
do i = 1, size(shower%interactions)
if (.not. interaction_fsr_is_finished (shower%interactions(i)%i)) then
finished = .false.
exit
end if
end do
end function shower_fsr_is_finished
@ %def shower_fsr_is_finished
@
<<Shower core: procedures>>=
function shower_isr_is_finished (shower) result (finished)
type(shower_t), intent(in) :: shower
logical :: finished
integer :: i
type(parton_t), pointer :: prt
finished = .true.
if (.not.allocated (shower%partons)) return
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
prt => shower%partons(i)%p
if (shower%settings%isr_pt_ordered) then
if (.not. prt%belongstoFSR .and. .not. prt%simulated &
.and. prt%scale > zero) then
finished = .false.
exit
end if
else
if (.not. prt%belongstoFSR .and. .not. prt%simulated &
.and. prt%t < zero) then
finished = .false.
exit
end if
end if
end do
end function shower_isr_is_finished
@ %def shower_isr_is_finished
@
<<Shower core: procedures>>=
subroutine interaction_find_partons_nearest_to_hadron &
(interaction, prt1, prt2, isr_pt_ordered)
type(shower_interaction_t), intent(in) :: interaction
type(parton_t), pointer :: prt1, prt2
logical, intent(in) :: isr_pt_ordered
prt1 => null ()
prt2 => null ()
prt1 => interaction%partons(1)%p
do
if (associated (prt1%parent)) then
if (prt1%parent%is_proton ()) then
exit
else if ((.not. isr_pt_ordered .and. .not. prt1%parent%simulated) &
.or. (isr_pt_ordered .and. .not. prt1%simulated)) then
exit
else
prt1 => prt1%parent
end if
else
exit
end if
end do
prt2 => interaction%partons(2)%p
do
if (associated (prt2%parent)) then
if (prt2%parent%is_proton ()) then
exit
else if ((.not. isr_pt_ordered .and. .not. prt2%parent%simulated) &
.or. (isr_pt_ordered .and. .not. prt2%simulated)) then
exit
else
prt2 => prt2%parent
end if
else
exit
end if
end do
end subroutine interaction_find_partons_nearest_to_hadron
@ %def interaction_find_partons_nearest_to_hadron
@
<<Shower core: shower: TBP>>=
procedure :: update_beamremnants => shower_update_beamremnants
<<Shower core: procedures>>=
subroutine shower_update_beamremnants (shower)
class(shower_t), intent(inout) :: shower
type(parton_t), pointer :: hadron, remnant
integer :: i
real(default) :: random
!!! only proton in first interaction !!?
!!! currently only first beam-remnant will be updated
do i = 1,2
if (associated (shower%interactions(1)%i%partons(i)%p%initial)) then
hadron => shower%interactions(1)%i%partons(i)%p%initial
else
cycle
end if
remnant => hadron%child2
if (associated (remnant)) then
remnant%momentum = hadron%momentum - hadron%child1%momentum
end if
!!! generate flavor of the beam-remnant if beam was proton
if (abs (hadron%type) == PROTON .and. associated (hadron%child1)) then
if (hadron%child1%is_quark ()) then
!!! decide if valence (u,d) or sea quark (s,c,b)
if ((abs (hadron%child1%type) <= 2) .and. &
(hadron%type * hadron%child1%type > zero)) then
!!! valence quark
if (abs (hadron%child1%type) == 1) then
!!! if d then remaining diquark is uu_1
remnant%type = sign (UU1, hadron%type)
else
call shower%rng%generate (random)
!!! if u then remaining diquark is ud_0 or ud_1
if (random < 0.75_default) then
remnant%type = sign (UD0, hadron%type)
else
remnant%type = sign (UD1, hadron%type)
end if
end if
remnant%c1 = hadron%child1%c2
remnant%c2 = hadron%child1%c1
else if ((hadron%type * hadron%child1%type) < zero) then
!!! antiquark
if (.not. associated (remnant%child1)) then
call shower%add_child (remnant, 1)
end if
if (.not. associated (remnant%child2)) then
call shower%add_child (remnant, 2)
end if
call shower%rng%generate (random)
if (random < 0.6666_default) then
!!! 2/3 into udq + u
if (abs (hadron%child1%type) == 1) then
remnant%child1%type = sign (NEUTRON, hadron%type)
else if (abs (hadron%child1%type) == 2) then
remnant%child1%type = sign (PROTON, hadron%type)
else if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (SIGMA0, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (SIGMACPLUS, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (SIGMAB0, hadron%type)
end if
remnant%child2%type = sign (2, hadron%type)
else
!!! 1/3 into uuq + d
if (abs (hadron%child1%type) == 1) then
remnant%child1%type = sign (PROTON, hadron%type)
else if (abs (hadron%child1%type) == 2) then
remnant%child1%type = sign (DELTAPLUSPLUS, hadron%type)
else if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (SIGMAPLUS, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (SIGMACPLUSPLUS, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (SIGMABPLUS, hadron%type)
end if
remnant%child2%type = sign (1, hadron%type)
end if
remnant%c1 = hadron%child1%c2
remnant%c2 = hadron%child1%c1
remnant%child1%c1 = 0
remnant%child1%c2 = 0
remnant%child2%c1 = remnant%c1
remnant%child2%c2 = remnant%c2
else
!!! sea quark
if (.not. associated (remnant%child1)) then
call shower%add_child (remnant, 1)
end if
if (.not. associated (remnant%child2)) then
call shower%add_child (remnant, 2)
end if
call shower%rng%generate (random)
if (random < 0.5_default) then
!!! 1/2 into usbar + ud_0
if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (KPLUS, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (D0, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (BPLUS, hadron%type)
end if
remnant%child2%type = sign (UD0, hadron%type)
else if (random < 0.6666_default) then
!!! 1/6 into usbar + ud_1
if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (KPLUS, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (D0, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (BPLUS, hadron%type)
end if
remnant%child2%type = sign (UD1, hadron%type)
else
!!! 1/3 into dsbar + uu_1
if (abs (hadron%child1%type) == 3) then
remnant%child1%type = sign (K0, hadron%type)
else if (abs (hadron%child1%type) == 4) then
remnant%child1%type = sign (DPLUS, hadron%type)
else if (abs (hadron%child1%type) == 5) then
remnant%child1%type = sign (B0, hadron%type)
end if
remnant%child2%type = sign (UU1, hadron%type)
end if
remnant%c1 = hadron%child1%c2
remnant%c2 = hadron%child1%c1
remnant%child1%c1 = 0
remnant%child1%c2 = 0
remnant%child2%c1 = remnant%c1
remnant%child2%c2 = remnant%c2
end if
else if (hadron%child1%is_gluon ()) then
if (.not.associated (remnant%child1)) then
call shower%add_child (remnant, 1)
end if
if (.not.associated (remnant%child2)) then
call shower%add_child (remnant, 2)
end if
call shower%rng%generate (random)
if (random < 0.5_default) then
!!! 1/2 into u + ud_0
remnant%child1%type = sign (2, hadron%type)
remnant%child2%type = sign (UD0, hadron%type)
else if (random < 0.6666_default) then
!!! 1/6 into u + ud_1
remnant%child1%type = sign (2, hadron%type)
remnant%child2%type = sign (UD1, hadron%type)
else
!!! 1/3 into d + uu_1
remnant%child1%type = sign (1, hadron%type)
remnant%child2%type = sign (UU1, hadron%type)
end if
remnant%c1 = hadron%child1%c2
remnant%c2 = hadron%child1%c1
if (hadron%type > 0) then
remnant%child1%c1 = remnant%c1
remnant%child2%c2 = remnant%c2
else
remnant%child1%c2 = remnant%c2
remnant%child2%c1 = remnant%c1
end if
end if
remnant%initial => hadron
if (associated (remnant%child1)) then
remnant%child1%initial => hadron
remnant%child2%initial => hadron
!!! don't care about on-shellness for now
remnant%child1%momentum = 0.5_default * remnant%momentum
remnant%child2%momentum = 0.5_default * remnant%momentum
!!! but care about on-shellness for baryons
if (mod (remnant%child1%type, 100) >= 10) then
!!! check if the third quark is set -> meson or baryon
remnant%child1%t = remnant%child1%mass_squared ()
remnant%child1%momentum = [remnant%child1%momentum%p(0), &
(remnant%child1%momentum%p(1:3) / &
remnant%child1%momentum%p(1:3)**1) * &
sqrt (remnant%child1%momentum%p(0)**2 - remnant%child1%t)]
remnant%child2%momentum = remnant%momentum &
- remnant%child1%momentum
end if
end if
end if
end do
end subroutine shower_update_beamremnants
@ %def shower_update_beamremnants
@
<<Shower core: procedures>>=
subroutine interaction_apply_lorentztrafo (interaction, L)
type(shower_interaction_t), intent(inout) :: interaction
type(lorentz_transformation_t), intent(in) :: L
type(parton_t), pointer :: prt
integer :: i
!!! ISR part
do i = 1,2
prt => interaction%partons(i)%p
!!! loop over ancestors
MOTHERS: do
!!! boost parton
call parton_apply_lorentztrafo (prt, L)
if (associated (prt%child2)) then
!!! boost emitted timelike parton (and daughters)
call parton_apply_lorentztrafo_recursive (prt%child2, L)
end if
if (associated (prt%parent)) then
if (.not. prt%parent%is_proton ()) then
prt => prt%parent
else
exit
end if
else
exit
end if
end do MOTHERS
end do
!!! FSR part
if (associated (interaction%partons(3)%p%parent)) then
!!! pseudo Parton-Shower histora has been generated -> find
!!! mother and go on from there recursively
prt => interaction%partons(3)%p
do while (associated (prt%parent))
prt => prt%parent
end do
call parton_apply_lorentztrafo_recursive (prt, L)
else
do i = 3, size (interaction%partons)
call parton_apply_lorentztrafo (interaction%partons(i)%p, L)
end do
end if
end subroutine interaction_apply_lorentztrafo
@ %def interaction_apply_lorentztrafo
@
<<Shower core: procedures>>=
subroutine shower_apply_lorentztrafo (shower, L)
type(shower_t), intent(inout) :: shower
type(lorentz_transformation_t), intent(in) :: L
integer :: i
do i = 1, size (shower%interactions)
call interaction_apply_lorentztrafo (shower%interactions(i)%i, L)
end do
end subroutine shower_apply_lorentztrafo
@ %def shower_apply_lorentztrafo
@ This boosts partons belonging to the interaction to the
center-of-mass frame of its partons nearest to the hadron.
<<Shower core: procedures>>=
subroutine interaction_boost_to_CMframe (interaction, isr_pt_ordered)
type(shower_interaction_t), intent(inout) :: interaction
logical, intent(in) :: isr_pt_ordered
type(vector4_t) :: beta
type(parton_t), pointer :: prt1, prt2
call interaction_find_partons_nearest_to_hadron &
(interaction, prt1, prt2, isr_pt_ordered)
beta = prt1%momentum + prt2%momentum
beta = beta / beta%p(0)
if (debug_active (D_SHOWER)) then
if (beta**2 > one) then
call msg_error ("Shower: boost to CM frame: beta > 1")
return
end if
end if
if (space_part(beta)**2 > tiny_13) then
call interaction_apply_lorentztrafo (interaction, &
boost(space_part(beta)**1 / &
sqrt (one - space_part(beta)**2), -direction(beta)))
end if
end subroutine interaction_boost_to_CMframe
@ %def interaction_boost_to_CMframe
@ This boosts every interaction to the center-of-mass-frame of its
partons nearest to the hadron.
<<Shower core: shower: TBP>>=
procedure :: boost_to_CMframe => shower_boost_to_CMframe
<<Shower core: procedures>>=
subroutine shower_boost_to_CMframe (shower)
class(shower_t), intent(inout) :: shower
integer :: i
do i = 1, size (shower%interactions)
call interaction_boost_to_CMframe &
(shower%interactions(i)%i, shower%settings%isr_pt_ordered)
end do
! TODO: (bcn 2015-03-23) this shouldnt be here !
call shower%update_beamremnants ()
end subroutine shower_boost_to_CMframe
@ %def shower_boost_to_CMframe
@ This boost all partons so that initial partons have their assigned
$x$-value.
<<Shower core: shower: TBP>>=
procedure :: boost_to_labframe => shower_boost_to_labframe
<<Shower core: procedures>>=
subroutine shower_boost_to_labframe (shower)
class(shower_t), intent(inout) :: shower
integer :: i
do i = 1, size (shower%interactions)
call interaction_boost_to_labframe &
(shower%interactions(i)%i, shower%settings%isr_pt_ordered)
end do
end subroutine shower_boost_to_labframe
@ %def shower_boost_to_labframe
@ This boosts all partons so that initial partons have their
assigned $x$-value.
<<Shower core: procedures>>=
subroutine interaction_boost_to_labframe (interaction, isr_pt_ordered)
type(shower_interaction_t), intent(inout) :: interaction
logical, intent(in) :: isr_pt_ordered
type(parton_t), pointer :: prt1, prt2
type(vector3_t) :: beta
call interaction_find_partons_nearest_to_hadron &
(interaction, prt1, prt2, isr_pt_ordered)
if (.not. associated (prt1%initial) .or. .not. &
associated (prt2%initial)) then
return
end if
!!! transform partons to overall labframe.
beta = vector3_canonical(3) * &
((prt1%x * prt2%momentum%p(0) - &
prt2%x * prt1%momentum%p(0)) / &
(prt1%x * prt2%momentum%p(3) - &
prt2%x * prt1%momentum%p(3)))
if (beta**1 > tiny_10) &
call interaction_apply_lorentztrafo (interaction, &
boost (beta**1 / sqrt(one - beta**2), -direction(beta)))
end subroutine interaction_boost_to_labframe
@ %def interaction_boost_to_labframe
@ Only rotate to z if inital hadrons are given (and they are assumed
to be aligned along the z-axis).
<<Shower core: procedures>>=
subroutine interaction_rotate_to_z (interaction, isr_pt_ordered)
type(shower_interaction_t), intent(inout) :: interaction
logical, intent(in) :: isr_pt_ordered
type(parton_t), pointer :: prt1, prt2
call interaction_find_partons_nearest_to_hadron &
(interaction, prt1, prt2, isr_pt_ordered)
if (associated (prt1%initial)) then
call interaction_apply_lorentztrafo (interaction, &
rotation_to_2nd (space_part (prt1%momentum), &
vector3_canonical(3) * sign (one, &
prt1%initial%momentum%p(3))))
end if
end subroutine interaction_rotate_to_z
@ %def interaction_rotate_to_z
@ Rotate initial partons to lie along $\pm z$ axis.
<<Shower core: shower: TBP>>=
procedure :: rotate_to_z => shower_rotate_to_z
<<Shower core: procedures>>=
subroutine shower_rotate_to_z (shower)
class(shower_t), intent(inout) :: shower
integer :: i
do i = 1, size (shower%interactions)
call interaction_rotate_to_z &
(shower%interactions(i)%i, shower%settings%isr_pt_ordered)
end do
! TODO: (bcn 2015-03-23) this shouldnt be here !
call shower%update_beamremnants ()
end subroutine shower_rotate_to_z
@ %def shower_rotate_to_z
@ Return if there are no initials, electron-hadron collision not
implemented.
<<Shower core: procedures>>=
subroutine interaction_generate_primordial_kt &
(interaction, primordial_kt_width, primordial_kt_cutoff, rng)
type(shower_interaction_t), intent(inout) :: interaction
real(default), intent(in) :: primordial_kt_width, primordial_kt_cutoff
class(rng_t), intent(inout), allocatable :: rng
type(parton_t), pointer :: had1, had2
type(vector4_t) :: momenta(2)
type(vector3_t) :: beta
real(default) :: pt (2), phi(2)
real(default) :: shat
real(default) :: btheta, bphi
integer :: i
if (vanishes (primordial_kt_width)) return
if (.not. associated (interaction%partons(1)%p%initial) .or. &
.not. associated (interaction%partons(2)%p%initial)) then
return
end if
had1 => interaction%partons(1)%p%initial
had2 => interaction%partons(2)%p%initial
!!! copy momenta and energy
momenta(1) = had1%child1%momentum
momenta(2) = had2%child1%momentum
GENERATE_PT_PHI: do i = 1, 2
!!! generate transverse momentum and phi
GENERATE_PT: do
call rng%generate (pt (i))
pt(i) = primordial_kt_width * sqrt(-log(pt(i)))
if (pt(i) < primordial_kt_cutoff) exit
end do GENERATE_PT
call rng%generate (phi (i))
phi(i) = twopi * phi(i)
end do GENERATE_PT_PHI
!!! adjust momenta
shat = (momenta(1) + momenta(2))**2
momenta(1) = [momenta(1)%p(0), &
pt(1) * cos(phi(1)), &
pt(1) * sin(phi(1)), &
momenta(1)%p(3)]
momenta(2) = [momenta(2)%p(0), &
pt(2) * cos(phi(2)), &
pt(2) * sin(phi(2)), &
momenta(2)%p(3)]
beta = [momenta(1)%p(1) + momenta(2)%p(1), &
momenta(1)%p(2) + momenta(2)%p(2), zero] / sqrt(shat)
momenta(1) = boost (beta**1 / sqrt(one - beta**2), -direction(beta)) &
* momenta(1)
bphi = azimuthal_angle (momenta(1))
btheta = polar_angle (momenta(1))
call interaction_apply_lorentztrafo (interaction, &
rotation (cos(bphi), sin(bphi), 3) * rotation(cos(btheta), &
sin(btheta), 2) * rotation(cos(-bphi), sin(-bphi), 3))
call interaction_apply_lorentztrafo (interaction, &
boost (beta**1 / sqrt(one - beta**2), -direction(beta)))
end subroutine interaction_generate_primordial_kt
@ %def interaction_generate_primordial_kt
@
<<Shower core: shower: TBP>>=
procedure :: generate_primordial_kt => shower_generate_primordial_kt
<<Shower core: procedures>>=
subroutine shower_generate_primordial_kt (shower)
class(shower_t), intent(inout) :: shower
integer :: i
do i = 1, size (shower%interactions)
call interaction_generate_primordial_kt (shower%interactions(i)%i, &
shower%settings%isr_primordial_kt_width, &
shower%settings%isr_primordial_kt_cutoff, shower%rng)
end do
! TODO: (bcn 2015-03-23) this shouldnt be here !
call shower%update_beamremnants ()
end subroutine shower_generate_primordial_kt
@ %def shower_generate_primordial_kt
@ Output.
<<Shower core: procedures>>=
subroutine interaction_write (interaction, unit)
type(shower_interaction_t), intent(in) :: interaction
integer, intent(in), optional :: unit
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
if (associated (interaction%partons(1)%p)) then
if (associated (interaction%partons(1)%p%initial)) &
call interaction%partons(1)%p%initial%write (u)
end if
if (associated (interaction%partons(2)%p)) then
if (associated (interaction%partons(2)%p%initial)) &
call interaction%partons(2)%p%initial%write (u)
end if
if (allocated (interaction%partons)) then
do i = 1, size (interaction%partons)
call interaction%partons(i)%p%write (u)
end do
end if
write (u, "(A)")
end subroutine interaction_write
@ %def interaction_write
@
<<Shower core: shower: TBP>>=
procedure :: write => shower_write
<<Shower core: procedures>>=
subroutine shower_write (shower, unit)
class(shower_t), intent(in) :: shower
integer, intent(in), optional :: unit
integer :: i, u
u = given_output_unit (unit); if (u < 0) return
write (u, "(1x,A)") "------------------------------"
write (u, "(1x,A)") "WHIZARD internal parton shower"
write (u, "(1x,A)") "------------------------------"
call shower%pdf_data%write (u)
if (size (shower%interactions) > 0) then
write (u, "(3x,A)") "Interactions: "
do i = 1, size (shower%interactions)
write (u, "(4x,A,I0)") "Interaction number ", i
if (.not. associated (shower%interactions(i)%i)) then
call msg_fatal ("Shower: missing interaction in shower")
end if
call interaction_write (shower%interactions(i)%i, u)
end do
else
write (u, "(3x,A)") "[no interactions in shower]"
end if
write (u, "(A)")
if (allocated (shower%partons)) then
write (u, "(5x,A)") "Partons:"
do i = 1, size (shower%partons)
if (associated (shower%partons(i)%p)) then
call shower%partons(i)%p%write (u)
if (i < size (shower%partons)) then
if (associated (shower%partons(i + 1)%p)) then
if (shower%partons(i)%p%belongstointeraction .and. &
.not. shower%partons(i + 1)%p%belongstointeraction) then
call write_separator (u)
end if
end if
end if
end if
end do
else
write (u, "(5x,A)") "[no partons in shower]"
end if
write (u, "(4x,A)") "Total Momentum: "
call vector4_write (shower_get_total_momentum (shower))
write (u, "(1x,A,L1)") "ISR finished: ", shower_isr_is_finished (shower)
write (u, "(1x,A,L1)") "FSR finished: ", shower_fsr_is_finished (shower)
end subroutine shower_write
@ %def shower_write
@ We combine the [[particle_set]] from the hard interaction with the
partons of the shower. For simplicity, we do not maintain the
mother-daughter-relations of the shower. Hadronic [[beam_remnants]] of
the old [[particle_set]] are removed as they are provided, including
proper flavor information, by the ISR shower.
<<Shower core: shower: TBP>>=
procedure :: combine_with_particle_set => shower_combine_with_particle_set
<<Shower core: procedures>>=
subroutine shower_combine_with_particle_set (shower, particle_set, &
model_in, model_hadrons)
class(shower_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model_in
class(model_data_t), intent(in), target :: model_hadrons
type(particle_t), dimension(:), allocatable :: particles
integer, dimension(:), allocatable :: hard_colored_ids, &
shower_partons_ids, incoming_ids, outgoing_ids
class(model_data_t), pointer :: model
logical, dimension(:), allocatable :: hard_colored_mask
integer :: n_shower_partons, n_remnants, i, j
integer :: n_in, n_out, n_beam, n_tot_old
if (signal_is_pending ()) return
call msg_debug (D_SHOWER, "shower_combine_with_particle_set")
call msg_debug (D_SHOWER, "Particle set before replacing")
if (debug_active (D_SHOWER)) &
call particle_set%write (summary=.true., compressed=.true.)
n_shower_partons = shower%get_nr_of_partons (only_colored = &
.true., no_hard_prts = .true.)
n_remnants = shower%get_nr_of_partons (only_colored = .false., &
no_hard_prts = .true.)
if (n_shower_partons + n_remnants > 0) then
call particle_set%without_hadronic_remnants &
(particles, n_tot_old, n_shower_partons + n_remnants)
call count_and_allocate ()
call replace_outgoings ()
call set_hard_colored_as_resonant_parents_for_shower ()
call add_to_pset (n_tot_old, .true.)
call add_to_pset (n_tot_old + n_remnants, .false.)
call particle_set%replace (particles)
end if
call msg_debug (D_SHOWER, 'Particle set after replacing')
if (debug_active (D_SHOWER)) &
call particle_set%write (summary=.true., compressed=.true.)
contains
<<Shower core: shower combine with particle set: procedures>>
end subroutine shower_combine_with_particle_set
@ %def shower_combine_with_particle_set
<<Shower core: shower combine with particle set: procedures>>=
subroutine count_and_allocate ()
n_beam = particle_set%get_n_beam ()
n_in = particle_set%get_n_in ()
n_out = particle_set%get_n_out ()
allocate (hard_colored_mask (size (particles)))
hard_colored_mask = (particles%get_status () == PRT_INCOMING .or. &
particles%get_status () == PRT_OUTGOING) .and. &
particles%is_colored ()
allocate (hard_colored_ids (count (hard_colored_mask)))
hard_colored_ids = pack ([(i, i=1, size (particles))], hard_colored_mask)
allocate (shower_partons_ids (n_shower_partons))
shower_partons_ids = [(n_tot_old + n_remnants + i, i=1, n_shower_partons)]
allocate (incoming_ids(n_in))
incoming_ids = [(n_beam + i, i=1, n_in)]
allocate (outgoing_ids(n_out))
outgoing_ids = [(n_tot_old - n_out + i, i=1, n_out )]
if (debug_active (D_SHOWER)) then
print *, 'n_remnants = ', n_remnants
print *, 'n_shower_partons = ', n_shower_partons
print *, 'n_tot_old = ', n_tot_old
print *, 'n_beam = ', n_beam
print *, 'n_in, n_out = ', n_in, n_out
end if
end subroutine count_and_allocate
@
<<Shower core: shower combine with particle set: procedures>>=
subroutine replace_outgoings ()
do i = 1, size (shower%interactions)
if (i > 1) then
call msg_bug ('shower_combine_with_particle_set assumes 1 interaction')
end if
associate (interaction => shower%interactions(i)%i)
do j = 3, size (interaction%partons)
if (associated (interaction%partons(j)%p)) then
call replace_parton_in_particles (j, interaction%partons(j)%p)
end if
end do
end associate
end do
end subroutine replace_outgoings
@
<<Shower core: shower combine with particle set: procedures>>=
subroutine replace_parton_in_particles (j, prt)
integer, intent(in) :: j
type(parton_t), intent(in) :: prt
integer :: idx
if (j <= 2) then
idx = n_beam + j
else
idx = n_tot_old - n_out - n_in + j
end if
call particles(idx)%set_momentum (prt%momentum)
end subroutine replace_parton_in_particles
@
<<Shower core: shower combine with particle set: procedures>>=
subroutine set_hard_colored_as_resonant_parents_for_shower ()
do i = 1, n_tot_old
if (hard_colored_mask (i)) then
if (has_splitted (i)) then
call particles(i)%add_children (shower_partons_ids)
if (particles(i)%get_status () == PRT_OUTGOING) then
call particles(i)%set_status (PRT_RESONANT)
end if
end if
end if
end do
end subroutine set_hard_colored_as_resonant_parents_for_shower
@
<<Shower core: shower combine with particle set: procedures>>=
function has_splitted (i) result (splitted)
logical :: splitted
integer, intent(in) :: i
splitted = .false.
do j = 1, size (shower%partons)
if (.not. associated (shower%partons(j)%p)) cycle
if (particles(i)%flv%get_pdg () == shower%partons(j)%p%type) then
if (all (nearly_equal (particles(i)%p%p, &
shower%partons(j)%p%momentum%p))) then
splitted = shower%partons(j)%p%is_branched ()
end if
end if
end do
end function has_splitted
@
<<Shower core: shower combine with particle set: procedures>>=
subroutine add_to_pset (offset, remnants)
integer, intent(in) :: offset
logical, intent(in) :: remnants
integer :: i, j
j = offset
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
associate (prt => shower%partons(i)%p)
if (.not. prt%is_final () .or. &
prt%belongstointeraction) cycle
if (remnants) then
if (prt%is_colored ()) cycle
else
if (.not. (prt%is_colored ())) cycle
end if
j = j + 1
call find_model (model, prt%type, model_in, model_hadrons)
particles (j) = prt%to_particle (model)
if (remnants) then
call particles(j)%set_parents ([prt%initial%nr])
call particles(prt%initial%nr)%add_child (j)
else
call particles(j)%set_parents (hard_colored_ids)
end if
end associate
end do
end subroutine add_to_pset
@
<<Shower core: shower: TBP>>=
procedure :: write_lhef => shower_write_lhef
<<Shower core: procedures>>=
subroutine shower_write_lhef (shower, unit)
class(shower_t), intent(in) :: shower
integer, intent(in), optional :: unit
integer :: u
integer :: i
integer :: c1, c2
u = given_output_unit (unit); if (u < 0) return
write(u,'(A)') '<LesHouchesEvents version="1.0">'
write(u,'(A)') '<-- not a complete lhe file - just one event -->'
write(u,'(A)') '<event>'
write(u, *) 2 + shower%get_nr_of_partons (), 1, 1.0, 1.0, 1.0, 1.0
!!! write incoming partons
do i = 1, 2
if (abs (shower%partons(i)%p%type) < 1000) then
c1 = 0
c2 = 0
if (shower%partons(i)%p%is_colored ()) then
if (shower%partons(i)%p%c1 /= 0) c1 = 500 + shower%partons(i)%p%c1
if (shower%partons(i)%p%c2 /= 0) c2 = 500 + shower%partons(i)%p%c2
end if
write (u,*) shower%partons(i)%p%type, -1, 0, 0, c1, c2, &
shower%partons(i)%p%momentum%p(1), &
shower%partons(i)%p%momentum%p(2), &
shower%partons(i)%p%momentum%p(3), &
shower%partons(i)%p%momentum%p(0), &
shower%partons(i)%p%momentum**2, zero, 9.0
else
write (u,*) shower%partons(i)%p%type, -9, 0, 0, 0, 0, &
shower%partons(i)%p%momentum%p(1), &
shower%partons(i)%p%momentum%p(2), &
shower%partons(i)%p%momentum%p(3), &
shower%partons(i)%p%momentum%p(0), &
shower%partons(i)%p%momentum**2, zero, 9.0
end if
end do
!!! write outgoing partons
do i = 3, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
if (.not. shower%partons(i)%p%is_final ()) cycle
c1 = 0
c2 = 0
if (shower%partons(i)%p%is_colored ()) then
if (shower%partons(i)%p%c1 /= 0) c1 = 500 + shower%partons(i)%p%c1
if (shower%partons(i)%p%c2 /= 0) c2 = 500 + shower%partons(i)%p%c2
end if
write (u,*) shower%partons(i)%p%type, 1, 1, 2, c1, c2, &
shower%partons(i)%p%momentum%p(1), &
shower%partons(i)%p%momentum%p(2), &
shower%partons(i)%p%momentum%p(3), &
shower%partons(i)%p%momentum%p(0), &
shower%partons(i)%p%momentum**2, zero, 9.0
end do
write(u,'(A)') '</event>'
write(u,'(A)') '</LesHouchesEvents>'
end subroutine shower_write_lhef
@ %def shower_write_lhef
@
<<Shower core: procedures>>=
subroutine shower_replace_parent_by_hadron (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
type(parton_t), pointer :: remnant => null()
if (associated (prt%parent)) then
call shower_remove_parton_from_partons (shower, prt%parent)
deallocate (prt%parent)
end if
if (.not. associated (prt%initial%child2)) then
call shower%add_child (prt%initial, 2)
end if
prt%parent => prt%initial
prt%parent%child1 => prt
! make other child to be a beam-remnant
remnant => prt%initial%child2
remnant%type = BEAM_REMNANT
remnant%momentum = prt%parent%momentum - prt%momentum
remnant%x = one - prt%x
remnant%parent => prt%initial
remnant%t = zero
end subroutine shower_replace_parent_by_hadron
@ %def shower_replace_parent_by_hadron
@
<<Shower core: procedures>>=
subroutine shower_get_first_ISR_scale_for_parton (shower, prt, tmax)
type(shower_t), intent(inout), target :: shower
type(parton_t), intent(inout), target :: prt
real(default), intent(in), optional :: tmax
real(default) :: t, tstep, random, integral, temp1
real(default) :: temprand
if (present(tmax)) then
t = max (max (-shower%settings%isr_tscalefactor * prt%momentum%p(0)**2, &
-abs(tmax)), prt%t)
else
t = max (-shower%settings%isr_tscalefactor * prt%momentum%p(0)**2, prt%t)
end if
call shower%rng%generate (random)
random = -twopi * log(random)
!!! compare Integral and log(random) instead of random and exp(-Integral)
integral = zero
call prt%set_simulated (.false.)
do
call shower%rng%generate (temprand)
tstep = max (abs (0.01_default * t) * temprand, 0.1_default * &
shower%settings%min_virtuality)
if (t + 0.5_default * tstep > - shower%settings%min_virtuality) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
exit
end if
prt%t = t + 0.5_default * tstep
temp1 = integral_over_z_simple (prt, (random - integral) / tstep)
integral = integral + tstep * temp1
if (integral > random) then
prt%t = t + 0.5_default * tstep
exit
end if
t = t + tstep
end do
if (prt%t > - shower%settings%min_virtuality) then
call shower_replace_parent_by_hadron (shower, prt)
end if
contains
function integral_over_z_simple (prt, final) result (integral)
type(parton_t), intent(inout) :: prt
real(default), intent(in) :: final
real(default), volatile :: integral
real(default), parameter :: zstepfactor = one
real(default), parameter :: zstepmin = 0.0001_default
real(default) :: z, zstep, minz, maxz
real(default) :: pdfsum
integer :: quark, d_nf
integral = zero
if (debug2_active (D_SHOWER)) then
print *, "D: integral_over_z_simple: t = ", prt%t
end if
minz = prt%x
! maxz = maxzz(shat, s, shower%settings%isr_z_cutoff, shower%settings%isr_minenergy)
maxz = shower%settings%isr_z_cutoff
z = minz
d_nf = shower%settings%max_n_flavors
!!! TODO -> Adapt zstep to structure of divergencies
if (prt%child1%is_gluon ()) then
!!! gluon coming from g->gg
do
call shower%rng%generate (temprand)
zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
zstep = min(zstep, maxz - z)
integral = integral + zstep * (D_alpha_s_isr ((one - &
(z + 0.5_default * zstep)) * abs(prt%t), &
shower%settings) / (abs(prt%t))) * &
P_ggg (z + 0.5_default * zstep) * &
shower%get_pdf (prt%initial%type, &
prt%x / (z + 0.5_default * zstep), abs(prt%t), GLUON)
if (integral > final) then
exit
end if
z = z + zstep
if (z >= maxz) then
exit
end if
end do
!!! gluon coming from q->qg ! correctly implemented yet?
if (integral < final) then
z = minz
do
call shower%rng%generate (temprand)
zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
zstep = min(zstep, maxz - z)
pdfsum = zero
do quark = -d_nf, d_nf
if (quark == 0) cycle
pdfsum = pdfsum + shower%get_pdf (prt%initial%type, &
prt%x / (z + 0.5_default * zstep), abs(prt%t), quark)
end do
integral = integral + zstep * (D_alpha_s_isr &
((z + 0.5_default * zstep) * abs(prt%t), &
shower%settings) / (abs(prt%t))) * &
P_qqg (one - (z + 0.5_default * zstep)) * pdfsum
if (integral > final) then
exit
end if
z = z + zstep
if (z >= maxz) then
exit
end if
end do
end if
else if (prt%child1%is_quark ()) then
!!! quark coming from q->qg
do
call shower%rng%generate(temprand)
zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
zstep = min(zstep, maxz - z)
integral = integral + zstep * (D_alpha_s_isr ((one - &
(z + 0.5_default * zstep)) * abs(prt%t), &
shower%settings) / (abs(prt%t))) * &
P_qqg (z + 0.5_default * zstep) * &
shower%get_pdf (prt%initial%type, &
prt%x / (z + 0.5_default * zstep), abs(prt%t), prt%type)
if (integral > final) then
exit
end if
z = z + zstep
if (z >= maxz) then
exit
end if
end do
!!! quark coming from g->qqbar
if (integral < final) then
z = minz
do
call shower%rng%generate (temprand)
zstep = max(zstepmin, temprand * zstepfactor * z*(one - z))
zstep = min(zstep, maxz - z)
integral = integral + zstep * (D_alpha_s_isr &
((one - (z + 0.5_default * zstep)) * abs(prt%t), &
shower%settings) / (abs(prt%t))) * &
P_gqq (z + 0.5_default * zstep) * &
shower%get_pdf (prt%initial%type, &
prt%x / (z + 0.5_default * zstep), abs(prt%t), GLUON)
if (integral > final) then
exit
end if
z = z + zstep
if (z >= maxz) then
exit
end if
end do
end if
end if
integral = integral / shower%get_pdf (prt%initial%type, prt%x, &
abs(prt%t), prt%type)
end function integral_over_z_simple
end subroutine shower_get_first_ISR_scale_for_parton
@ %def shower_get_first_ISR_scale_for_parton
@
<<Shower core: procedures>>=
subroutine shower_prepare_for_simulate_isr_pt (shower, interaction)
type(shower_t), intent(inout) :: shower
type(shower_interaction_t), intent(inout) :: interaction
real(default) :: s
s = (interaction%partons(1)%p%momentum + &
interaction%partons(2)%p%momentum)**2
interaction%partons(1)%p%scale = shower%settings%isr_tscalefactor * 0.25_default * s
interaction%partons(2)%p%scale = shower%settings%isr_tscalefactor * 0.25_default * s
end subroutine shower_prepare_for_simulate_isr_pt
@ %def shower_prepare_for_simulate_isr_pt
@
<<Shower core: procedures>>=
subroutine shower_prepare_for_simulate_isr_ana_test (shower, prt1, prt2)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt1, prt2
type(parton_t), pointer :: prt, prta, prtb
real(default) :: scale, factor, E
integer :: i
if (.not. associated (prt1%initial) .or. .not. associated (prt2%initial)) then
return
end if
scale = - (prt1%momentum + prt2%momentum) ** 2
call prt1%set_simulated ()
call prt2%set_simulated ()
call shower%add_parent (prt1)
call shower%add_parent (prt2)
factor = sqrt (energy (prt1%momentum)**2 - scale) / &
space_part_norm(prt1%momentum)
prt1%parent%type = prt1%type
prt1%parent%z = one
prt1%parent%momentum = prt1%momentum
prt1%parent%t = scale
prt1%parent%x = prt1%x
prt1%parent%initial => prt1%initial
prt1%parent%belongstoFSR = .false.
prt1%parent%c1 = prt1%c1
prt1%parent%c2 = prt1%c2
prt2%parent%type= prt2%type
prt2%parent%z = one
prt2%parent%momentum = prt2%momentum
prt2%parent%t = scale
prt2%parent%x = prt2%x
prt2%parent%initial => prt2%initial
prt2%parent%belongstoFSR = .false.
prt2%parent%c1 = prt2%c1
prt2%parent%c2 = prt2%c2
call shower_get_first_ISR_scale_for_parton (shower, prt1%parent)
call shower_get_first_ISR_scale_for_parton (shower, prt2%parent)
!!! redistribute energy among first partons
prta => prt1%parent
prtb => prt2%parent
E = energy (prt1%momentum + prt2%momentum)
prta%momentum%p(0) = (E**2 - prtb%t + prta%t) / (two * E)
prtb%momentum%p(0) = E - prta%momentum%p(0)
call prt1%parent%set_simulated ()
call prt2%parent%set_simulated ()
!!! rescale momenta
do i = 1, 2
if (i == 1) then
prt => prt1%parent
else
prt => prt2%parent
end if
factor = sqrt (energy (prt%momentum)**2 - prt%t) &
/ space_part_norm (prt%momentum)
prt%momentum = vector4_moving (energy (prt%momentum), &
factor * space_part (prt%momentum))
end do
if (prt1%parent%t < zero) then
call shower%add_parent (prt1%parent)
prt1%parent%parent%momentum = prt1%parent%momentum
prt1%parent%parent%t = prt1%parent%t
prt1%parent%parent%x = prt1%parent%x
prt1%parent%parent%initial => prt1%parent%initial
prt1%parent%parent%belongstoFSR = .false.
call shower%add_child (prt1%parent%parent, 2)
end if
if (prt2%parent%t < zero) then
call shower%add_parent (prt2%parent)
prt2%parent%parent%momentum = prt2%parent%momentum
prt2%parent%parent%t = prt2%parent%t
prt2%parent%parent%x = prt2%parent%x
prt2%parent%parent%initial => prt2%parent%initial
prt2%parent%parent%belongstoFSR = .false.
call shower%add_child (prt2%parent%parent, 2)
end if
end subroutine shower_prepare_for_simulate_isr_ana_test
@ %def shower_prepare_for_simulate_isr_ana_test
@
<<Shower core: procedures>>=
subroutine shower_add_children_of_emitted_timelike_parton (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), pointer :: prt
if (prt%t > prt%mass_squared () + shower%settings%min_virtuality) then
if (prt%is_quark ()) then
!!! q -> qg
call shower%add_child (prt, 1)
prt%child1%type = prt%type
prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
prt%child1%t = prt%t
call shower%add_child (prt, 2)
prt%child2%type = GLUON
prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
prt%child2%t = prt%t
else
if (int (prt%x) > 0) then
call shower%add_child (prt, 1)
prt%child1%type = int (prt%x)
prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
prt%child1%t = prt%t
call shower%add_child (prt, 2)
prt%child2%type = -int (prt%x)
prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
prt%child2%t= prt%t
else
call shower%add_child (prt, 1)
prt%child1%type = GLUON
prt%child1%momentum%p(0) = prt%z * prt%momentum%p(0)
prt%child1%t = prt%t
call shower%add_child (prt, 2)
prt%child2%type = GLUON
prt%child2%momentum%p(0) = (one - prt%z) * prt%momentum%p(0)
prt%child2%t = prt%t
end if
end if
end if
end subroutine shower_add_children_of_emitted_timelike_parton
@ %def shower_add_children_of_emitted_timelike_parton
@
<<Shower core: procedures>>=
subroutine shower_simulate_children_ana (shower,prt)
type(shower_t), intent(inout), target :: shower
type(parton_t), intent(inout) :: prt
real(default), dimension(1:2) :: random, integral
integer, dimension(1:2) :: gtoqq
integer :: daughter
type(parton_t), pointer :: daughterprt
integer :: n_loop
if (signal_is_pending ()) return
if (debug2_active (D_SHOWER)) &
print *, "D: shower_simulate_children_ana: for parton " , prt%nr
gtoqq = 0
if (.not. associated (prt%child1) .or. .not. associated (prt%child2)) then
call msg_error ("Shower: error in simulate_children_ana: no children.")
return
end if
<<Set beam-remnants and internal partons as simulated>>
integral = zero
!!! impose constraints by angular ordering -> cf. (26) of Gaining analytic control
!!! check if no branchings are possible
if (.not. prt%child1%simulated) then
prt%child1%t = min (prt%child1%t, &
0.5_default * prt%child1%momentum%p(0)**2 * (one - &
prt%get_costheta ()))
if (.not. associated (prt%child1%settings)) &
prt%child1%settings => shower%settings
if (min (prt%child1%t, prt%child1%momentum%p(0)**2) < &
prt%child1%mass_squared () + &
prt%child1%settings%min_virtuality) then
prt%child1%t = prt%child1%mass_squared ()
call prt%child1%set_simulated ()
end if
end if
if (.not. prt%child2%simulated) then
prt%child2%t = min (prt%child2%t, &
0.5_default * prt%child2%momentum%p(0)**2 * (one - &
prt%get_costheta ()))
if (.not. associated (prt%child2%settings)) &
prt%child2%settings => shower%settings
if (min (prt%child2%t, prt%child2%momentum%p(0)**2) < &
prt%child2%mass_squared () + &
prt%child2%settings%min_virtuality) then
prt%child2%t = prt%child2%mass_squared ()
call prt%child2%set_simulated ()
end if
end if
call shower%rng%generate (random)
n_loop = 0
do
if (signal_is_pending ()) return
n_loop = n_loop + 1
if (n_loop > 900) then
!!! try with massless quarks
treat_duscb_quarks_massless = .true.
end if
if (n_loop > 1000) then
call msg_message ("simulate_children_ana failed for parton ", prt%nr)
call msg_warning ("too many loops in simulate_children_ana")
call shower%write ()
shower%valid = .false.
return
end if
!!! check if a branching in the range t(i) to t(i) - tstep(i) occurs
if (.not. prt%child1%simulated) then
call parton_simulate_stept &
(prt%child1, shower%rng, integral(1), random(1), gtoqq(1))
end if
if (.not. prt%child2%simulated) then
call parton_simulate_stept &
(prt%child2, shower%rng, integral(2), random(2), gtoqq(2))
end if
if (prt%child1%simulated .and. prt%child2%simulated) then
if (sqrt (prt%t) <= sqrt (prt%child1%t) + sqrt (prt%child2%t)) then
<<Repeat the simulation for the parton with the lower virtuality>>
else
exit
end if
end if
end do
call parton_apply_costheta (prt, shower%rng)
<<Add children>>
call shower_parton_update_color_connections (shower, prt)
end subroutine shower_simulate_children_ana
@ %def shower_simulate_children_ana
@
<<Set beam-remnants and internal partons as simulated>>=
if (HADRON_REMNANT <= abs (prt%type) .and. abs (prt%type) <= HADRON_REMNANT_OCTET) then
!!! prt is beam-remnant
call prt%set_simulated ()
return
end if
!!! check if partons are "internal" -> fixed scale
if (prt%child1%type == INTERNAL) then
call prt%child1%set_simulated ()
end if
if (prt%child2%type == INTERNAL) then
call prt%child2%set_simulated ()
end if
@
<<Repeat the simulation for the parton with the lower virtuality>>=
!!! virtuality : t - m**2 (assuming it's not fixed)
if (prt%child1%type == INTERNAL .and. prt%child2%type == INTERNAL) then
call msg_fatal &
("Shower: both partons fixed, but momentum not conserved")
else if (prt%child1%type == INTERNAL) then
!!! reset child2
call prt%child2%set_simulated (.false.)
prt%child2%t = min (prt%child1%t, (sqrt (prt%t) - &
sqrt (prt%child1%t))**2)
integral(2) = zero
call shower%rng%generate (random(2))
else if (prt%child2%type == INTERNAL) then
! reset child1
call prt%child1%set_simulated (.false.)
prt%child1%t = min (prt%child2%t, (sqrt (prt%t) - &
sqrt (prt%child2%t))**2)
integral(1) = zero
call shower%rng%generate (random(1))
else if (prt%child1%t - prt%child1%mass_squared () > &
prt%child2%t - prt%child2%mass_squared ()) then
!!! reset child2
call prt%child2%set_simulated (.false.)
prt%child2%t = min (prt%child1%t, (sqrt (prt%t) - &
sqrt (prt%child1%t))**2)
integral(2) = zero
call shower%rng%generate (random(2))
else
!!! reset child1 ! TODO choose child according to their t
call prt%child1%set_simulated (.false.)
prt%child1%t = min (prt%child2%t, (sqrt (prt%t) - &
sqrt (prt%child2%t))**2)
integral(1) = zero
call shower%rng%generate (random(1))
end if
@
<<Add children>>=
if (.not. associated (prt%child1%settings)) &
prt%child1%settings => shower%settings
if (.not. associated (prt%child2%settings)) &
prt%child2%settings => shower%settings
do daughter = 1, 2
if (signal_is_pending ()) return
if (daughter == 1) then
daughterprt => prt%child1
else
daughterprt => prt%child2
end if
if (daughterprt%t < daughterprt%mass_squared () + &
daughterprt%settings%min_virtuality) then
cycle
end if
if (.not. (daughterprt%is_quark () .or. daughterprt%is_gluon ())) then
cycle
end if
if (daughterprt%is_quark ()) then
!!! q -> qg
call shower%add_child (daughterprt, 1)
daughterprt%child1%type = daughterprt%type
daughterprt%child1%momentum%p(0) = daughterprt%z * &
daughterprt%momentum%p(0)
daughterprt%child1%t = daughterprt%t
call shower%add_child (daughterprt, 2)
daughterprt%child2%type = GLUON
daughterprt%child2%momentum%p(0) = (one - daughterprt%z) * &
daughterprt%momentum%p(0)
daughterprt%child2%t = daughterprt%t
else if (daughterprt%is_gluon ()) then
if (gtoqq(daughter) > 0) then
call shower%add_child (daughterprt, 1)
daughterprt%child1%type = gtoqq (daughter)
daughterprt%child1%momentum%p(0) = &
daughterprt%z * daughterprt%momentum%p(0)
daughterprt%child1%t = daughterprt%t
call shower%add_child (daughterprt, 2)
daughterprt%child2%type = - gtoqq (daughter)
daughterprt%child2%momentum%p(0) = (one - &
daughterprt%z) * daughterprt%momentum%p(0)
daughterprt%child2%t = daughterprt%t
else
call shower%add_child (daughterprt, 1)
daughterprt%child1%type = GLUON
daughterprt%child1%momentum%p(0) = &
daughterprt%z * daughterprt%momentum%p(0)
daughterprt%child1%t = daughterprt%t
call shower%add_child (daughterprt, 2)
daughterprt%child2%type = GLUON
daughterprt%child2%momentum%p(0) = (one - &
daughterprt%z) * daughterprt%momentum%p(0)
daughterprt%child2%t = daughterprt%t
end if
end if
end do
@
@ The recoiler is [[otherprt]]. Instead of the random number and the
exponential of the integral, we compare the logarithm of the random
number and the integral.
<<Shower core: procedures>>=
subroutine shower_isr_step_pt (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), target, intent(inout) :: prt
type(parton_t), pointer :: otherprt
real(default) :: scale, scalestep
real(default), volatile :: integral
real(default) :: random, factor
real(default) :: temprand1, temprand2
otherprt => shower%find_recoiler (prt)
scale = prt%scale
call shower%rng%generate (temprand1)
call shower%rng%generate (temprand2)
scalestep = max (abs (scalefactor1 * scale) * temprand1, &
scalefactor2 * temprand2 * D_Min_scale)
call shower%rng%generate (random)
random = - twopi * log(random)
integral = zero
if (scale - 0.5_default * scalestep < D_Min_scale) then
!!! close enough to cut-off scale -> ignore
prt%scale = zero
prt%t = prt%mass_squared ()
call prt%set_simulated ()
else
prt%scale = scale - 0.5_default * scalestep
factor = scalestep * (D_alpha_s_isr (prt%scale, &
shower%settings) / (prt%scale * &
shower%get_pdf (prt%initial%type, prt%x, prt%scale, prt%type)))
integral = integral + factor * integral_over_z_isr_pt &
(prt, otherprt, (random - integral) / factor)
if (integral > random) then
!!! prt%scale set above and prt%z set in integral_over_z_isr_pt
call prt%set_simulated ()
prt%t = - prt%scale / (one - prt%z)
else
prt%scale = scale - scalestep
end if
end if
contains
function integral_over_z_isr_pt (prt, otherprt, final) &
result (integral)
type(parton_t), intent(inout) :: prt, otherprt
real(default), intent(in) :: final
real(default), volatile :: integral
real(default) :: mbr, r
real(default) :: zmin, zmax, z, zstep
integer :: n_bin
integer, parameter :: n_total_bins = 100
real(default) :: quarkpdfsum
real(default) :: temprand
integer :: quark, d_nf
quarkpdfsum = zero
d_nf = shower%settings%max_n_flavors
if (debug2_active (D_SHOWER)) then
print *, "D: integral_over_z_isr_pt: for scale = ", prt%scale
end if
integral = zero
mbr = (prt%momentum + otherprt%momentum)**1
zmin = prt%x
zmax = min (one - (sqrt (prt%scale) / mbr) * &
(sqrt(one + 0.25_default * prt%scale / mbr**2) - &
0.25_default * sqrt(prt%scale) / mbr), shower%settings%isr_z_cutoff)
zstep = (zmax - zmin) / n_total_bins
if (debug_active (D_SHOWER)) then
if (zmin > zmax) then
call msg_bug(" error in integral_over_z_isr_pt: zmin > zmax ")
integral = zero
end if
end if
!!! divide the range [zmin:zmax] in n_total_bins
BINS: do n_bin = 1, n_total_bins
z = zmin + zstep * (n_bin - 0.5_default)
!!! z-value in the middle of the bin
if (prt%is_gluon ()) then
QUARKS: do quark = -d_nf, d_nf
if (quark == 0) cycle quarks
quarkpdfsum = quarkpdfsum + shower%get_pdf &
(prt%initial%type, prt%x / z, prt%scale, quark)
end do QUARKS
!!! g -> gg or q -> gq
integral = integral + (zstep / z) * ((P_ggg (z) + &
P_ggg (one - z)) * shower%get_pdf (prt%initial%type, &
prt%x / z, prt%scale, GLUON) + P_qqg (one - z) * quarkpdfsum)
else if (prt%is_quark ()) then
!!! q -> qg or g -> qq
integral = integral + (zstep / z) * ( P_qqg (z) * &
shower%get_pdf (prt%initial%type, prt%x / z, prt%scale, &
prt%type) + &
P_gqq(z) * shower%get_pdf (prt%initial%type, prt%x / z, &
prt%scale, GLUON))
else
! call msg_fatal ("Bug neither quark nor gluon in" &
! // " integral_over_z_isr_pt")
end if
if (integral > final) then
prt%z = z
call shower%rng%generate (temprand)
!!! decide type of father partons
if (prt%is_gluon ()) then
if (temprand > (P_qqg (one - z) * quarkpdfsum) / &
((P_ggg (z) + P_ggg (one - z)) * shower%get_pdf &
(prt%initial%type, prt%x / z, prt%scale, GLUON) &
+ P_qqg (one - z) * quarkpdfsum)) then
!!! gluon => gluon + gluon
prt%aux_pt = GLUON
else
!!! quark => quark + gluon
!!! decide which quark flavor the parent is
r = temprand * quarkpdfsum
WHICH_QUARK: do quark = -d_nf, d_nf
if (quark == 0) cycle WHICH_QUARK
if (r > quarkpdfsum - shower%get_pdf (prt%initial%type, &
prt%x / z, prt%scale, quark)) then
prt%aux_pt = quark
exit WHICH_QUARK
else
quarkpdfsum = quarkpdfsum - shower%get_pdf &
(prt%initial%type, prt%x / z, prt%scale, quark)
end if
end do WHICH_QUARK
end if
else if (prt%is_quark ()) then
if (temprand > (P_qqg (z) * shower%get_pdf (prt%initial%type, &
prt%x / z, prt%scale, prt%type)) / &
(P_qqg (z) * shower%get_pdf (prt%initial%type, prt%x / z, &
prt%scale, prt%type) + &
P_gqq (z) * shower%get_pdf (prt%initial%type, prt%x / z, &
prt%scale, GLUON))) then
!!! gluon => quark + antiquark
prt%aux_pt = GLUON
else
!!! quark => quark + gluon
prt%aux_pt = prt%type
end if
end if
exit BINS
end if
end do BINS
end function integral_over_z_isr_pt
end subroutine shower_isr_step_pt
@ %def shower_isr_step_pt
@ This function returns a pointer to the parton with the next ISR
branching, while FSR branchings are ignored.
<<Shower core: shower: TBP>>=
procedure :: generate_next_isr_branching_veto => &
shower_generate_next_isr_branching_veto
<<Shower core: procedures>>=
function shower_generate_next_isr_branching_veto &
(shower) result (next_brancher)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t) :: next_brancher
integer :: i
type(parton_t), pointer :: prt
real(default) :: random
!!! pointers to branchable partons
type(parton_pointer_t), dimension(:), allocatable :: partons
integer :: n_partons
real(default) :: weight
real(default) :: temp1, temp2, temp3, E3
if (signal_is_pending ()) return
if (shower%settings%isr_pt_ordered) then
next_brancher = shower%generate_next_isr_branching ()
return
end if
next_brancher%p => null()
!!! branchable partons
n_partons = 0
do i = 1,size (shower%partons)
prt => shower%partons(i)%p
if (.not. associated (prt)) cycle
if (prt%belongstoFSR) cycle
if (prt%is_final ()) cycle
if (.not. prt%belongstoFSR .and. prt%simulated) cycle
n_partons = n_partons + 1
end do
if (n_partons == 0) then
return
end if
allocate (partons(1:n_partons))
n_partons = 1
do i = 1, size (shower%partons)
prt => shower%partons(i)%p
if (.not. associated (prt)) cycle
if (prt%belongstoFSR) cycle
if (prt%is_final ()) cycle
if (.not. prt%belongstoFSR .and. prt%simulated) cycle
partons(n_partons)%p => shower%partons(i)%p
n_partons = n_partons + 1
end do
!!! generate initial trial scales
do i = 1, size (partons)
if (signal_is_pending ()) return
call generate_next_trial_scale (partons(i)%p)
end do
do
!!! search for parton with the highest trial scale
prt => partons(1)%p
do i = 1, size (partons)
if (prt%t >= zero) cycle
if (abs (partons(i)%p%t) > abs (prt%t)) then
prt => partons(i)%p
end if
end do
if (prt%t >= zero) then
next_brancher%p => null()
exit
end if
!!! generate trial z and type of mother prt
call generate_trial_z_and_typ (prt)
!!! weight with pdf and alpha_s
temp1 = (D_alpha_s_isr ((one - prt%z) * abs(prt%t), &
shower%settings) / sqrt (alphasxpdfmax))
temp2 = shower%get_xpdf (prt%initial%type, prt%x, prt%t, &
prt%type) / sqrt (alphasxpdfmax)
temp3 = shower%get_xpdf (prt%initial%type, prt%child1%x, prt%child1%t, &
prt%child1%type) / &
shower%get_xpdf (prt%initial%type, prt%child1%x, prt%t, &
prt%child1%type)
! TODO: (bcn 2015-02-19) ???
if (temp1 * temp2 * temp3 > one) then
print *, "weights:", temp1, temp2, temp3
end if
weight = (D_alpha_s_isr ((one - prt%z) * abs(prt%t), &
shower%settings)) * &
shower%get_xpdf (prt%initial%type, prt%x, prt%t, prt%type) * &
shower%get_xpdf (prt%initial%type, prt%child1%x, prt%child1%t, &
prt%child1%type) / &
shower%get_xpdf &
(prt%initial%type, prt%child1%x, prt%t, prt%child1%type)
if (weight > alphasxpdfmax) then
print *, "Setting alphasxpdfmax from ", alphasxpdfmax, " to ", weight
alphasxpdfmax = weight
end if
weight = weight / alphasxpdfmax
call shower%rng%generate (random)
if (weight < random) then
!!! discard branching
call generate_next_trial_scale (prt)
cycle
end if
!!! branching accepted so far
!!! generate emitted parton
prt%child2%t = abs(prt%t)
prt%child2%momentum%p(0) = sqrt (abs(prt%t))
if (shower%settings%isr_only_onshell_emitted_partons) then
prt%child2%t = prt%child2%mass_squared ()
else
call prt%child2%next_t_ana (shower%rng)
end if
if (thetabar (prt, shower%find_recoiler (prt), &
shower%settings%isr_angular_ordered, E3)) then
prt%momentum%p(0) = E3
prt%child2%momentum%p(0) = E3 - prt%child1%momentum%p(0)
!!! found branching
call prt%generate_ps_ini (shower%rng)
next_brancher%p => prt
call prt%set_simulated ()
exit
else
call generate_next_trial_scale (prt)
cycle
end if
end do
if (.not. associated (next_brancher%p)) then
!!! no further branching found -> all partons emitted by hadron
print *, "--all partons emitted by hadrons---"
do i = 1, size(partons)
call shower_replace_parent_by_hadron (shower, partons(i)%p%child1)
end do
end if
!!! some bookkeeping
call shower%sort_partons ()
! call shower%boost_to_CMframe () ! really necessary?
! call shower%rotate_to_z () ! really necessary?
contains
subroutine generate_next_trial_scale (prt)
type(parton_t), pointer, intent(inout) :: prt
real(default) :: random, F
real(default) :: zmax = 0.99_default !! ??
call shower%rng%generate (random)
F = one !!! TODO
F = alphasxpdfmax / (two * pi)
if (prt%child1%is_quark ()) then
F = F * (integral_over_P_gqq (prt%child1%x, zmax) + &
integral_over_P_qqg (prt%child1%x, zmax))
else if (prt%child1%is_gluon ()) then
F = F * (integral_over_P_ggg (prt%child1%x, zmax) + &
two * shower%settings%max_n_flavors * &
integral_over_P_qqg (one - zmax, one - prt%child1%x))
else
call msg_bug("neither quark nor gluon in generate_next_trial_scale")
end if
F = F / shower%get_xpdf (prt%child1%initial%type, prt%child1%x, &
prt%child1%t, prt%child1%type)
prt%t = prt%t * random**(one / F)
if (abs (prt%t) - prt%mass_squared () < &
prt%settings%min_virtuality) then
prt%t = prt%mass_squared ()
end if
end subroutine generate_next_trial_scale
subroutine generate_trial_z_and_typ (prt)
type(parton_t), pointer, intent(inout) :: prt
real(default) :: random
real(default) :: z, zstep, zmin, integral
real(default) :: zmax = 0.99_default !! ??
call msg_debug (D_SHOWER, "generate_trial_z_and_typ")
call shower%rng%generate (random)
integral = zero
!!! decide which branching a->bc occurs
if (prt%child1%is_quark ()) then
if (random < integral_over_P_qqg (prt%child1%x, zmax) / &
(integral_over_P_qqg (prt%child1%x, zmax) + &
integral_over_P_gqq (prt%child1%x, zmax))) then
prt%type = prt%child1%type
prt%child2%type = GLUON
integral = integral_over_P_qqg (prt%child1%x, zmax)
else
prt%type = GLUON
prt%child2%type = - prt%child1%type
integral = integral_over_P_gqq (prt%child1%x, zmax)
end if
else if (prt%child1%is_gluon ()) then
if (random < integral_over_P_ggg (prt%child1%x, zmax) / &
(integral_over_P_ggg (prt%child1%x, zmax) + two * &
shower%settings%max_n_flavors * &
integral_over_P_qqg (one - zmax, &
one - prt%child1%x))) then
prt%type = GLUON
prt%child2%type = GLUON
integral = integral_over_P_ggg (prt%child1%x, zmax)
else
call shower%rng%generate (random)
prt%type = 1 + floor(random * shower%settings%max_n_flavors)
call shower%rng%generate (random)
if (random > 0.5_default) prt%type = - prt%type
prt%child2%type = prt%type
integral = integral_over_P_qqg (one - zmax, &
one - prt%child1%x)
end if
else
call msg_bug("neither quark nor gluon in generate_next_trial_scale")
end if
!!! generate the z-value
!!! z between prt%child1%x and zmax
! prt%z = one - random * (one - prt%child1%x) ! TODO
call shower%rng%generate (random)
zmin = prt%child1%x
zstep = max(0.1_default, 0.5_default * (zmax - zmin))
z = zmin
if (zmin > zmax) then
print *, " zmin = ", zmin, " zmax = ", zmax
call msg_fatal ("Shower: zmin greater than zmax")
end if
!!! procedure pointers would be helpful here
if (prt%is_quark () .and. prt%child1%is_quark ()) then
do
zstep = min(zstep, 0.5_default * (zmax - z))
if (abs(zstep) < 0.00001) exit
if (integral_over_P_qqg (zmin, z) < random * integral) then
if (integral_over_P_qqg (zmin, min(z + zstep, zmax)) &
< random * integral) then
z = min (z + zstep, zmax)
cycle
else
zstep = zstep * 0.5_default
cycle
end if
end if
end do
else if (prt%is_quark () .and. prt%child1%is_gluon ()) then
do
zstep = min(zstep, 0.5_default * (zmax - z))
if (abs(zstep) < 0.00001) exit
if (integral_over_P_qqg (zmin, z) < random * integral) then
if (integral_over_P_qqg (zmin, min(z + zstep, zmax)) &
< random * integral) then
z = min(z + zstep, zmax)
cycle
else
zstep = zstep * 0.5_default
cycle
end if
end if
end do
else if (prt%is_gluon () .and. prt%child1%is_quark ()) then
do
zstep = min(zstep, 0.5_default * (zmax - z))
if (abs (zstep) < 0.00001) exit
if (integral_over_P_gqq (zmin, z) < random * integral) then
if (integral_over_P_gqq (zmin, min(z + zstep, zmax)) &
< random * integral) then
z = min (z + zstep, zmax)
cycle
else
zstep = zstep * 0.5_default
cycle
end if
end if
end do
else if (prt%is_gluon () .and. prt%child1%is_gluon ()) then
do
zstep = min(zstep, 0.5_default * (zmax - z))
if (abs (zstep) < 0.00001) exit
if (integral_over_P_ggg (zmin, z) < random * integral) then
if (integral_over_P_ggg (zmin, min(z + zstep, zmax)) &
< random * integral) then
z = min(z + zstep, zmax)
cycle
else
zstep = zstep * 0.5_default
cycle
end if
end if
end do
else
end if
prt%z = z
prt%x = prt%child1%x / prt%z
end subroutine generate_trial_z_and_typ
end function shower_generate_next_isr_branching_veto
@ %def shower_generate_next_isr_branching_veto
@
<<Shower core: shower: TBP>>=
procedure :: find_recoiler => shower_find_recoiler
<<Shower core: procedures>>=
function shower_find_recoiler (shower, prt) result(recoiler)
class(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
type(parton_t), pointer :: recoiler
type(parton_t), pointer :: otherprt1, otherprt2
integer :: n_int
otherprt1 => null()
otherprt2 => null()
DO_INTERACTIONS: do n_int = 1, size(shower%interactions)
otherprt1 => shower%interactions(n_int)%i%partons(1)%p
otherprt2 => shower%interactions(n_int)%i%partons(2)%p
PARTON1: do
if (associated (otherprt1%parent)) then
if (.not. otherprt1%parent%is_proton () .and. &
otherprt1%parent%simulated) then
otherprt1 => otherprt1%parent
if (associated (otherprt1, prt)) then
exit PARTON1
end if
else
exit PARTON1
end if
else
exit PARTON1
end if
end do PARTON1
PARTON2: do
if (associated (otherprt2%parent)) then
if (.not. otherprt2%parent%is_proton () .and. &
otherprt2%parent%simulated) then
otherprt2 => otherprt2%parent
if (associated (otherprt2, prt)) then
exit PARTON2
end if
else
exit PARTON2
end if
else
exit PARTON2
end if
end do PARTON2
if (associated (otherprt1, prt) .or. associated (otherprt2, prt)) then
exit DO_INTERACTIONS
end if
if (associated (otherprt1%parent, prt) .or. &
associated (otherprt2%parent, prt)) then
exit DO_INTERACTIONS
end if
end do DO_INTERACTIONS
recoiler => null()
if (associated (otherprt1%parent, prt)) then
recoiler => otherprt2
else if (associated (otherprt2%parent, prt)) then
recoiler => otherprt1
else if (associated (otherprt1, prt)) then
recoiler => otherprt2
else if (associated (otherprt2, prt)) then
recoiler => otherprt1
else
call shower%write ()
call prt%write ()
call msg_error ("shower_find_recoiler: no otherparton found")
end if
end function shower_find_recoiler
@ %def shower_find_recoiler
@
<<Shower core: procedures>>=
subroutine shower_isr_step (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), target, intent(inout) :: prt
type(parton_t), pointer :: otherprt => null()
real(default) :: t, tstep
real(default), volatile :: integral
real(default) :: random
real(default) :: temprand1, temprand2
otherprt => shower%find_recoiler (prt)
! if (.not. otherprt%child1%belongstointeraction) then
! otherprt => otherprt%child1
! end if
if (signal_is_pending ()) return
t = max(prt%t, prt%child1%t)
call shower%rng%generate (random)
! compare Integral and log(random) instead of random and exp(-Integral)
random = - twopi * log(random)
integral = zero
call shower%rng%generate (temprand1)
call shower%rng%generate (temprand2)
tstep = max (abs (0.02_default * t) * temprand1, &
0.02_default * temprand2 * shower%settings%min_virtuality)
if (t + 0.5_default * tstep > - shower%settings%min_virtuality) then
prt%t = prt%mass_squared ()
call prt%set_simulated ()
else
prt%t = t + 0.5_default * tstep
integral = integral + tstep * &
integral_over_z_isr (shower, prt, otherprt,(random - integral) / tstep)
if (integral > random) then
prt%t = t + 0.5_default * tstep
prt%x = prt%child1%x / prt%z
call prt%set_simulated ()
else
prt%t = t + tstep
end if
end if
end subroutine shower_isr_step
@ %def shower_isr_step
<<Shower core: procedures>>=
function integral_over_z_isr (shower, prt, otherprt, final) result (integral)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout) :: prt, otherprt
real(default), intent(in) :: final
!!! !!! !!! volatile argument: gfortran 7 aggressive optimization (#809)
real(default), volatile :: integral
real(default) :: minz, maxz, shat,s
integer :: quark
!!! calculate shat -> s of parton-parton system
shat = (otherprt%momentum + prt%child1%momentum)**2
!!! calculate s -> s of hadron-hadron system
s = (otherprt%initial%momentum + prt%initial%momentum)**2
integral = zero
minz = prt%child1%x
maxz = maxzz (shat, s, shower%settings%isr_z_cutoff, &
shower%settings%isr_minenergy)
!!! for gluon
if (prt%child1%is_gluon ()) then
!!! 1: g->gg
prt%type = GLUON
prt%child2%type = GLUON
prt%child2%t = abs(prt%t)
call integral_over_z_part_isr &
(shower, prt, otherprt, shat, minz, maxz, integral, final)
if (integral > final) then
return
else
!!! 2: q->gq
do quark = - shower%settings%max_n_flavors, &
shower%settings%max_n_flavors
if (quark == 0) cycle
prt%type = quark
prt%child2%type = quark
prt%child2%t = abs(prt%t)
call integral_over_z_part_isr &
(shower, prt, otherprt, shat, minz, maxz, integral, final)
if (integral > final) then
return
end if
end do
end if
else if (prt%child1%is_quark ()) then
!!! 1: q->qg
prt%type = prt%child1%type
prt%child2%type = GLUON
prt%child2%t = abs(prt%t)
call integral_over_z_part_isr &
(shower, prt,otherprt, shat, minz, maxz, integral, final)
if (integral > final) then
return
else
!!! 2: g->qqbar
prt%type = GLUON
prt%child2%type = -prt%child1%type
prt%child2%t = abs(prt%t)
call integral_over_z_part_isr &
(shower, prt,otherprt, shat, minz, maxz, integral, final)
end if
end if
end function integral_over_z_isr
@ % integral_over_z_isr
<<Shower core: procedures>>=
subroutine integral_over_z_part_isr &
(shower, prt, otherprt, shat ,minz, maxz, retvalue, final)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout) :: prt, otherprt
real(default), intent(in) :: shat, minz, maxz, final
real(default), intent(inout) :: retvalue
real(default) :: z, zstep
real(default) :: r1,r3,s1,s3
real(default) :: pdf_divisor
real(default) :: temprand
real(default), parameter :: zstepfactor = 0.1_default
real(default), parameter :: zstepmin = 0.0001_default
call msg_debug2 (D_SHOWER, "integral_over_z_part_isr")
if (signal_is_pending ()) return
pdf_divisor = shower%get_pdf &
(prt%initial%type, prt%child1%x, prt%t, prt%child1%type)
z = minz
s1 = shat + abs(otherprt%t) + abs(prt%child1%t)
r1 = sqrt (s1**2 - four * abs(otherprt%t * prt%child1%t))
ZLOOP: do
if (signal_is_pending ()) return
if (z >= maxz) then
exit
end if
call shower%rng%generate (temprand)
if (prt%child1%is_gluon ()) then
if (prt%is_gluon ()) then
!!! g-> gg -> divergencies at z->0 and z->1
zstep = max(zstepmin, temprand * zstepfactor * z * (one - z))
else
!!! q-> gq -> divergencies at z->0
zstep = max(zstepmin, temprand * zstepfactor * (one - z))
end if
else
if (prt%is_gluon ()) then
!!! g-> qqbar -> no divergencies
zstep = max(zstepmin, temprand * zstepfactor)
else
!!! q-> qg -> divergencies at z->1
zstep = max(zstepmin, temprand * zstepfactor * (one - z))
end if
end if
zstep = min(zstep, maxz - z)
prt%z = z + 0.5_default * zstep
s3 = shat / prt%z + abs(otherprt%t) + abs(prt%t)
r3 = sqrt (s3**2 - four * abs(otherprt%t * prt%t))
!!! TODO: WHY is this if needed?
if (abs(otherprt%t) > eps0) then
prt%child2%t = min ((s1 * s3 - r1 * r3) / &
(two * abs(otherprt%t)) - abs(prt%child1%t) - &
abs(prt%t), abs(prt%child1%t))
else
prt%child2%t = abs(prt%child1%t)
end if
do
prt%child2%momentum%p(0) = sqrt (abs(prt%child2%t))
if (shower%settings%isr_only_onshell_emitted_partons) then
prt%child2%t = prt%child2%mass_squared ()
else
call prt%child2%next_t_ana (shower%rng)
end if
!!! take limits by recoiler into account
prt%momentum%p(0) = (shat / prt%z + &
abs(otherprt%t) - abs(prt%child1%t) - &
prt%child2%t) / (two * sqrt(shat))
prt%child2%momentum%p(0) = &
prt%momentum%p(0) - prt%child1%momentum%p(0)
!!! check if E and t of prt%child2 are consistent
if (prt%child2%momentum%p(0)**2 < prt%child2%t &
.and. prt%child2%t > prt%child2%mass_squared ()) then
!!! E is too small to have p_T^2 = E^2 - t > 0
!!! -> cycle to find another solution
cycle
else
!!! E is big enough -> exit
exit
end if
end do
if (thetabar (prt, otherprt, shower%settings%isr_angular_ordered) &
.and. pdf_divisor > zero &
.and. prt%child2%momentum%p(0) > zero) then
retvalue = retvalue + (zstep / prt%z) * &
(D_alpha_s_isr ((one - prt%z) * prt%t, &
shower%settings) * &
P_prt_to_child1 (prt) * &
shower%get_pdf (prt%initial%type, prt%child1%x / prt%z, &
prt%t, prt%type)) / (abs(prt%t) * pdf_divisor)
end if
if (retvalue > final) then
exit
else
z = z + zstep
end if
end do ZLOOP
end subroutine integral_over_z_part_isr
@ % integral_over_z_part_isr
@ This returns a pointer to the parton with the next ISR branching, again
FSR branchings are ignored.
<<Shower core: shower: TBP>>=
procedure :: generate_next_isr_branching => &
shower_generate_next_isr_branching
<<Shower core: procedures>>=
function shower_generate_next_isr_branching &
(shower) result (next_brancher)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t) :: next_brancher
integer i, index
type(parton_t), pointer :: prt
next_brancher%p => null()
do
if (signal_is_pending ()) return
if (shower_isr_is_finished (shower)) exit
!!! find mother with highest |t| or pt to be simulated
index = 0
call shower%sort_partons ()
do i = 1,size (shower%partons)
prt => shower%partons(i)%p
if (.not. associated (prt)) cycle
if (.not. shower%settings%isr_pt_ordered) then
if (prt%belongstointeraction) cycle
end if
if (prt%belongstoFSR) cycle
if (prt%is_final ()) cycle
if (.not. prt%belongstoFSR .and. prt%simulated) cycle
index = i
exit
end do
if (debug_active (D_SHOWER)) then
if (index == 0) then
call msg_fatal(" no branchable partons found")
end if
end if
prt => shower%partons(index)%p
!!! ISR simulation
if (shower%settings%isr_pt_ordered) then
call shower_isr_step_pt (shower, prt)
else
call shower_isr_step (shower, prt)
end if
if (prt%simulated) then
if (prt%t < zero) then
next_brancher%p => prt
if (.not. shower%settings%isr_pt_ordered) &
call prt%generate_ps_ini (shower%rng)
exit
else
if (.not. shower%settings%isr_pt_ordered) then
call shower_replace_parent_by_hadron (shower, prt%child1)
else
call shower_replace_parent_by_hadron (shower, prt)
end if
end if
end if
end do
!!! some bookkeeping
call shower%sort_partons ()
call shower%boost_to_CMframe () !!! really necessary?
call shower%rotate_to_z () !!! really necessary?
end function shower_generate_next_isr_branching
@ %def shower_generate_next_isr_branching
@ This is a loop which searches for all emitted and branched partons.
<<Shower core: shower: TBP>>=
procedure :: generate_fsr_for_isr_partons => &
shower_generate_fsr_for_partons_emitted_in_ISR
<<Shower core: procedures>>=
subroutine shower_generate_fsr_for_partons_emitted_in_ISR (shower)
class(shower_t), intent(inout) :: shower
integer :: n_int, i
type(parton_t), pointer :: prt
if (shower%settings%isr_only_onshell_emitted_partons) return
call msg_debug (D_SHOWER, "shower_generate_fsr_for_partons_emitted_in_ISR")
INTERACTIONS_LOOP: do n_int = 1, size (shower%interactions)
INCOMING_PARTONS_LOOP: do i = 1, 2
if (signal_is_pending ()) return
prt => shower%interactions(n_int)%i%partons(i)%p
PARENT_PARTONS_LOOP: do
if (associated (prt%parent)) then
if (.not. prt%parent%is_proton ()) then
prt => prt%parent
else
exit
end if
else
exit
end if
if (associated (prt%child2)) then
if (prt%child2%is_branched ()) then
call shower_parton_generate_fsr (shower, prt%child2)
end if
else
! call msg_fatal ("Shower: no child2 associated?")
end if
end do PARENT_PARTONS_LOOP
end do INCOMING_PARTONS_LOOP
end do INTERACTIONS_LOOP
end subroutine shower_generate_fsr_for_partons_emitted_in_ISR
@ %def shower_generate_fsr_for_partons_emitted_in_ISR
@ This executes the branching generated by
[[shower_generate_next_isr_branching]], that means it generates the
flavors, momenta, etc.
<<Shower core: shower: TBP>>=
procedure :: execute_next_isr_branching => shower_execute_next_isr_branching
<<Shower core: procedures>>=
subroutine shower_execute_next_isr_branching (shower, prtp)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t), intent(inout) :: prtp
type(parton_t), pointer :: prt, otherprt
type(parton_t), pointer :: prta, prtb, prtc, prtr
real(default) :: mbr
real(default) :: phirand
call msg_debug (D_SHOWER, "shower_execute_next_isr_branching")
if (.not. associated (prtp%p)) then
call msg_fatal ("Shower: prtp not associated")
end if
prt => prtp%p
if ((.not. shower%settings%isr_pt_ordered .and. &
prt%t > - shower%settings%min_virtuality) .or. &
(shower%settings%isr_pt_ordered .and. prt%scale < D_Min_scale)) then
call msg_error ("Shower: no branching to be executed.")
end if
otherprt => shower%find_recoiler (prt)
if (shower%settings%isr_pt_ordered) then
!!! get the recoiler
otherprt => shower%find_recoiler (prt)
if (associated (otherprt%parent)) then
!!! Why only for pt ordered
if (.not. otherprt%parent%is_proton () .and. &
shower%settings%isr_pt_ordered) otherprt => otherprt%parent
end if
if (.not. associated (prt%parent)) then
call shower%add_parent (prt)
end if
prt%parent%belongstoFSR = .false.
if (.not. associated (prt%parent%child2)) then
call shower%add_child (prt%parent, 2)
end if
prta => prt%parent !!! new parton a with branching a->bc
prtb => prt !!! former parton
prtc => prt%parent%child2 !!! emitted parton
prtr => otherprt !!! recoiler
mbr = (prtb%momentum + prtr%momentum)**1
!!! 1. assume you are in the restframe
!!! 2. rotate by random phi
call shower%rng%generate (phirand)
phirand = twopi * phirand
call shower_apply_lorentztrafo (shower, &
rotation(cos(phirand), sin(phirand),vector3_canonical(3)))
!!! 3. Put the b off-shell
!!! and
!!! 4. construct the massless a
!!! and the parton (eventually emitted by a)
!!! generate the flavor of the parent (prta)
if (prtb%aux_pt /= 0) prta%type = prtb%aux_pt
if (prtb%is_quark ()) then
if (prta%type == prtb%type) then
!!! (anti)-quark -> (anti-)quark + gluon
prta%type = prtb%type ! quarks have same flavor
prtc%type = GLUON ! emitted gluon
else
!!! gluon -> quark + antiquark
prta%type = GLUON
prtc%type = - prtb%type
end if
else if (prtb%is_gluon ()) then
prta%type = GLUON
prtc%type = GLUON
else
! STOP "Bug in shower_execute_next_branching: neither quark nor gluon"
end if
prta%initial => prtb%initial
prta%belongstoFSR = .false.
prta%scale = prtb%scale
prta%x = prtb%x / prtb%z
prtb%momentum = vector4_moving ((mbr**2 + prtb%t) / (two * mbr), &
vector3_canonical(3) * &
sign ((mbr**2 - prtb%t) / (two * mbr), &
prtb%momentum%p(3)))
prtr%momentum = vector4_moving ((mbr**2 - prtb%t) / (two * mbr), &
vector3_canonical(3) * &
sign( (mbr**2 - prtb%t) / (two * mbr), &
prtr%momentum%p(3)))
prta%momentum = vector4_moving ((0.5_default / mbr) * &
((mbr**2 / prtb%z) + prtb%t - prtc%mass_squared ()), &
vector3_null)
prta%momentum = vector4_moving (prta%momentum%p(0), &
vector3_canonical(3) * &
(0.5_default / prtb%momentum%p(3)) * &
((mbr**2 / prtb%z) - two &
* prtr%momentum%p(0) * prta%momentum%p(0) ) )
if (prta%momentum%p(0)**2 - prta%momentum%p(3)**2 - &
prtc%mass_squared () > zero) then
!!! This SHOULD be always fulfilled???
prta%momentum = vector4_moving (prta%momentum%p(0), &
vector3_moving([sqrt (prta%momentum%p(0)**2 - &
prta%momentum%p(3)**2 - &
prtc%mass_squared ()), zero, &
prta%momentum%p(3)]))
end if
prtc%momentum = prta%momentum - prtb%momentum
!!! 5. rotate to have a along z-axis
call shower%boost_to_CMframe ()
call shower%rotate_to_z ()
!!! 6. rotate back in phi
call shower_apply_lorentztrafo (shower, rotation &
(cos(-phirand), sin(-phirand), vector3_canonical(3)))
else
if (prt%child2%t > prt%child2%mass_squared ()) then
call shower_add_children_of_emitted_timelike_parton &
(shower, prt%child2)
call prt%child2%set_simulated ()
end if
call shower%add_parent (prt)
call shower%add_child (prt%parent, 2)
prt%parent%momentum = prt%momentum
prt%parent%t = prt%t
prt%parent%x = prt%x
prt%parent%initial => prt%initial
prt%parent%belongstoFSR = .false.
prta => prt
prtb => prt%child1
prtc => prt%child2
end if
if (signal_is_pending ()) return
if (shower%settings%isr_pt_ordered) then
call prt%parent%generate_ps_ini (shower%rng)
else
call prt%generate_ps_ini (shower%rng)
end if
!!! add color connections
if (prtb%is_quark ()) then
if (prta%type == prtb%type) then
if (prtb%type > 0) then
!!! quark -> quark + gluon
prtc%c2 = prtb%c1
prtc%c1 = shower%get_next_color_nr ()
prta%c1 = prtc%c1
else
!!! antiquark -> antiquark + gluon
prtc%c1 = prtb%c2
prtc%c2 = shower%get_next_color_nr ()
prta%c2 = prtc%c2
end if
else
!!! gluon -> quark + antiquark
if (prtb%type > 0) then
!!! gluon -> quark + antiquark
prta%c1 = prtb%c1
prtc%c1 = 0
prtc%c2 = shower%get_next_color_nr ()
prta%c2 = prtc%c2
else
!!! gluon -> antiquark + quark
prta%c2 = prtb%c2
prtc%c1 = shower%get_next_color_nr ()
prtc%c2 = 0
prta%c1 = prtc%c1
end if
end if
else if (prtb%is_gluon ()) then
if (prta%is_gluon ()) then
!!! g -> gg
prtc%c2 = prtb%c1
prtc%c1 = shower%get_next_color_nr ()
prta%c1 = prtc%c1
prta%c2 = prtb%c2
else if (prta%is_quark ()) then
if (prta%type > 0) then
prta%c1 = prtb%c1
prta%c2 = 0
prtc%c1 = prtb%c2
prtc%c2 = 0
else
prta%c1 = 0
prta%c2 = prtb%c2
prtc%c1 = 0
prtc%c2 = prtb%c1
end if
end if
end if
call shower%sort_partons ()
call shower%boost_to_CMframe ()
call shower%rotate_to_z ()
end subroutine shower_execute_next_isr_branching
@ %def shower_execute_next_isr_branching
@
<<Shower core: procedures>>=
subroutine shower_remove_parents_and_stuff (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
type(parton_t), pointer :: actprt, nextprt
nextprt => prt%parent
actprt => null()
!!! remove children of emitted timelike parton
if (associated (prt%child2)) then
if (associated (prt%child2%child1)) then
call shower_remove_parton_from_partons_recursive &
(shower, prt%child2%child1)
end if
prt%child2%child1 => null()
if (associated (prt%child2%child2)) then
call shower_remove_parton_from_partons_recursive &
(shower, prt%child2%child2)
end if
prt%child2%child2 => null()
end if
do
actprt => nextprt
if (.not. associated (actprt)) then
exit
else if (actprt%is_proton ()) then
!!! remove beam-remnant
call shower_remove_parton_from_partons (shower, actprt%child2)
exit
end if
if (associated (actprt%parent)) then
nextprt => actprt%parent
else
nextprt => null()
end if
call shower_remove_parton_from_partons_recursive &
(shower, actprt%child2)
call shower_remove_parton_from_partons (shower, actprt)
end do
prt%parent=>null()
end subroutine shower_remove_parents_and_stuff
@ %def shower_remove_parents_and_stuff
@
<<Shower core: shower: TBP>>=
procedure :: get_ISR_scale => shower_get_ISR_scale
<<Shower core: procedures>>=
function shower_get_ISR_scale (shower) result (scale)
class(shower_t), intent(in) :: shower
real(default) :: scale
type(parton_t), pointer :: prt1, prt2
integer :: i
scale = zero
do i = 1, size (shower%interactions)
call interaction_find_partons_nearest_to_hadron &
(shower%interactions(i)%i, prt1, prt2, &
shower%settings%isr_pt_ordered)
if (.not. prt1%simulated .and. abs(prt1%scale) > scale) &
scale = abs(prt1%scale)
if (.not. prt1%simulated .and. abs(prt2%scale) > scale) &
scale = abs(prt2%scale)
end do
end function shower_get_ISR_scale
@ %def shower_get_ISR_scale
@
<<Shower core: shower: TBP>>=
procedure :: set_max_isr_scale => shower_set_max_isr_scale
<<Shower core: procedures>>=
subroutine shower_set_max_isr_scale (shower, newscale)
class(shower_t), intent(inout) :: shower
real(default), intent(in) :: newscale
real(default) :: scale
type(parton_t), pointer :: prt
integer :: i,j
call msg_debug (D_SHOWER, "shower_set_max_isr_scale: newscale", &
newscale)
if (shower%settings%isr_pt_ordered) then
scale = newscale
else
scale = - abs (newscale)
end if
INTERACTIONS: do i = 1, size (shower%interactions)
PARTONS: do j = 1, 2
prt => shower%interactions(i)%i%partons(j)%p
do
if (.not. shower%settings%isr_pt_ordered) then
if (prt%belongstointeraction) prt => prt%parent
end if
if (prt%t < scale) then
if (associated (prt%parent)) then
prt => prt%parent
else
exit !!! unresolved prt found
end if
else
exit !!! prt with scale above newscale found
end if
end do
if (.not. shower%settings%isr_pt_ordered) then
if (prt%child1%belongstointeraction .or. &
prt%is_proton ()) then
!!! don't reset scales of "first" spacelike partons
!!! in virtuality ordered shower or hadrons
cycle
end if
else
if (prt%is_proton ()) then
!!! don't reset scales of hadrons
cycle
end if
end if
if (shower%settings%isr_pt_ordered) then
prt%scale = scale
else
prt%t = scale
end if
call prt%set_simulated (.false.)
call shower_remove_parents_and_stuff (shower, prt)
end do PARTONS
end do INTERACTIONS
end subroutine shower_set_max_isr_scale
@ %def shower_set_max_isr_scale
@
<<Shower core: shower: TBP>>=
procedure :: interaction_generate_fsr_2ton => &
shower_interaction_generate_fsr_2ton
@
<<Shower core: procedures>>=
subroutine shower_interaction_generate_fsr_2ton (shower, interaction)
class(shower_t), intent(inout) :: shower
type(shower_interaction_t), intent(inout) :: interaction
type(parton_t), pointer :: prt
prt => interaction%partons(3)%p
do
if (.not. associated (prt%parent)) exit
prt => prt%parent
end do
call shower_parton_generate_fsr (shower, prt)
call shower_parton_update_color_connections (shower, prt)
end subroutine shower_interaction_generate_fsr_2ton
@ %def shower_interaction_generate_fsr_2ton
@ Perform the FSR for one parton, it is assumed, that the parton
already branched. Hence, its children are to be simulated. This
procedure is intended for branched FSR-partons emitted in the ISR.
<<Shower core: procedures>>=
subroutine shower_parton_generate_fsr (shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout), target :: prt
type(parton_pointer_t), dimension(:), allocatable :: partons
logical :: single_emission = .false.
call msg_debug (D_SHOWER, "shower_parton_generate_fsr")
if (signal_is_pending ()) return
if (debug_active (D_SHOWER)) then
if (.not. prt%is_branched ()) then
call msg_error ("shower_parton_generate_fsr: parton not branched")
return
end if
if (prt%child1%simulated .or. &
prt%child2%simulated) then
print *, "children already simulated for parton ", prt%nr
return
end if
end if
allocate (partons(1))
partons(1)%p => prt
if (single_emission) then
call shower%parton_pointer_array_generate_fsr (partons, partons)
else
call shower%parton_pointer_array_generate_fsr_recursive (partons)
end if
end subroutine shower_parton_generate_fsr
@ %def shower_parton_generate_fsr
@
<<Shower core: shower: TBP>>=
procedure :: parton_pointer_array_generate_fsr_recursive => &
shower_parton_pointer_array_generate_fsr_recursive
@
<<Shower core: procedures>>=
recursive subroutine shower_parton_pointer_array_generate_fsr_recursive &
(shower, partons)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: &
partons
type(parton_pointer_t), dimension(:), allocatable :: partons_new
call msg_debug (D_SHOWER, "shower_parton_pointer_array_generate_fsr_recursive")
if (signal_is_pending ()) return
if (size (partons) == 0) return
call shower%parton_pointer_array_generate_fsr (partons, partons_new)
call shower%parton_pointer_array_generate_fsr_recursive (partons_new)
end subroutine shower_parton_pointer_array_generate_fsr_recursive
@
<<Shower core: shower: TBP>>=
procedure :: parton_pointer_array_generate_fsr => &
shower_parton_pointer_array_generate_fsr
@
<<Shower core: procedures>>=
subroutine shower_parton_pointer_array_generate_fsr &
(shower, partons, partons_new)
class(shower_t), intent(inout) :: shower
type(parton_pointer_t), dimension(:), allocatable, intent(inout) :: &
partons
type(parton_pointer_t), dimension(:), allocatable, intent(out) :: &
partons_new
integer :: i, size_partons, size_partons_new
call msg_debug (D_SHOWER, "shower_parton_pointer_array_generate_fsr")
!!! Simulate highest/first parton
call shower_simulate_children_ana (shower, partons(1)%p)
!!! check for new daughters to be included in new_partons
size_partons = size (partons)
size_partons_new = size_partons - 1 !!! partons(1) not needed anymore
if (partons(1)%p%child1%is_branched ()) &
size_partons_new = size_partons_new + 1
if (partons(1)%p%child2%is_branched ()) &
size_partons_new = size_partons_new + 1
allocate (partons_new (1:size_partons_new))
if (size_partons > 1) then
do i = 2, size_partons
partons_new (i - 1)%p => partons(i)%p
end do
end if
if (partons(1)%p%child1%is_branched ()) &
partons_new (size_partons)%p => partons(1)%p%child1
if (partons(1)%p%child2%is_branched ()) then
!!! check if child1 is already included
if (size_partons_new == size_partons) then
partons_new (size_partons)%p => partons(1)%p%child2
else if (size_partons_new == size_partons + 1) then
partons_new (size_partons + 1)%p => partons(1)%p%child2
else
call msg_fatal ("Shower: wrong sizes in" &
// "shower_parton_pointer_array_generate_fsr")
end if
end if
deallocate (partons)
end subroutine shower_parton_pointer_array_generate_fsr
@ %def shower_parton_pointer_array_generate_fsr
@
<<Shower core: procedures>>=
recursive subroutine shower_parton_update_color_connections &
(shower, prt)
type(shower_t), intent(inout) :: shower
type(parton_t), intent(inout) :: prt
real(default) :: temprand
if (.not. associated (prt%child1) .or. &
.not. associated (prt%child2)) return
if (signal_is_pending ()) return
if (prt%is_gluon ()) then
if (prt%child1%is_quark ()) then
!!! give the quark the colorpartner and the antiquark
!!! the anticolorpartner
if (prt%child1%type > 0) then
!!! child1 is quark, child2 is antiquark
prt%child1%c1 = prt%c1
prt%child2%c2 = prt%c2
else
!!! child1 is antiquark, child2 is quark
prt%child1%c2 = prt%c2
prt%child2%c1 = prt%c1
end if
else
!!! g -> gg splitting -> random choosing of partners
call shower%rng%generate (temprand)
if (temprand > 0.5_default) then
prt%child1%c1 = prt%c1
prt%child1%c2 = shower%get_next_color_nr ()
prt%child2%c1 = prt%child1%c2
prt%child2%c2 = prt%c2
else
prt%child1%c2 = prt%c2
prt%child2%c1 = prt%c1
prt%child2%c2 = shower%get_next_color_nr ()
prt%child1%c1 = prt%child2%c2
end if
end if
else if (prt%is_quark ()) then
if (prt%child1%is_quark ()) then
if (prt%child1%type > 0) then
!!! q -> q + g
prt%child2%c1 = prt%c1
prt%child2%c2 = shower%get_next_color_nr ()
prt%child1%c1 = prt%child2%c2
else
!!! qbar -> qbar + g
prt%child2%c2 = prt%c2
prt%child2%c1 = shower%get_next_color_nr ()
prt%child1%c2 = prt%child2%c1
end if
else
if (prt%child2%type > 0) then
!!! q -> g + q
prt%child1%c1 = prt%c1
prt%child1%c2 = shower%get_next_color_nr ()
prt%child2%c1 = prt%child1%c2
else
!!! qbar -> g + qbar
prt%child1%c2 = prt%c2
prt%child1%c1 = shower%get_next_color_nr ()
prt%child2%c2 = prt%child1%c1
end if
end if
end if
call shower_parton_update_color_connections (shower, prt%child1)
call shower_parton_update_color_connections (shower, prt%child2)
end subroutine shower_parton_update_color_connections
@ %def shower_parton_update_color_connections
@ The next two routines are for PDFs. Wrapper function to return
parton densities.
<<Shower core: shower: TBP>>=
procedure :: get_pdf => shower_get_pdf
<<Shower core: procedures>>=
function shower_get_pdf (shower, mother, x, Q2, daughter) result (pdf)
<<get pdf>>
if (x > eps0) then
pdf = pdf / x
end if
end function shower_get_pdf
@ %def shower_get_pdf
<<Shower core: shower: TBP>>=
procedure :: get_xpdf => shower_get_xpdf
<<Shower core: procedures>>=
function shower_get_xpdf (shower, mother, x, Q2, daughter) result (pdf)
<<get pdf>>
end function shower_get_xpdf
@ %def shower_get_xpdf
@
<<get pdf>>=
class(shower_t), intent(inout), target :: shower
integer, intent(in) :: mother, daughter
real(default), intent(in) :: x, Q2
real(default) :: pdf
real(double), save :: f(-6:6) = 0._double
real(double), save :: lastx, lastQ2 = 0._double
pdf = zero
if (debug_active (D_SHOWER)) then
if (abs (mother) /= PROTON) then
call msg_debug (D_SHOWER, "mother", mother)
call msg_fatal ("Shower: pdf only implemented for (anti-)proton")
end if
if (.not. (abs (daughter) >= 1 .and. abs (daughter) <= 6 .or. &
daughter == GLUON)) then
call msg_debug (D_SHOWER, "daughter", daughter)
call msg_fatal ("Shower: error in pdf, unknown daughter")
end if
end if
if (x > zero .and. x < one) then
if ((dble(Q2) - lastQ2) > eps0 .or. (dble(x) - lastx) > eps0) then
call shower%pdf_data%evolve &
(dble(x), sqrt (abs (dble(Q2))), f)
end if
if (abs (daughter) >= 1 .and. abs (daughter) <= 6) then
pdf = max (f(daughter * sign (1,mother)), tiny_10)
else
pdf = max (f(0), tiny_10)
end if
end if
lastQ2 = dble(Q2)
lastx = dble(x)
@
@ Convert Whizard shower to Pythia6. Currently only works for one
interaction.
<<Shower core: shower: TBP>>=
procedure :: converttopythia => shower_converttopythia
<<Shower core: procedures>>=
subroutine shower_converttopythia (shower)
class(shower_t), intent(in) :: shower
<<PYJETS COMMON BLOCK>>
type(parton_t), pointer :: pp, ppparent
integer :: i
K = 0
do i = 1, 2
!!! get history of the event
pp => shower%interactions(1)%i%partons(i)%p
!!! add these partons to the event record
if (associated (pp%initial)) then
!!! add hadrons
K(i,1) = 21
K(i,2) = pp%initial%type
K(i,3) = 0
P(i,1:5) = pp%initial%momentum_to_pythia6 ()
!!! add partons emitted by the hadron
ppparent => pp
do while (associated (ppparent%parent))
if (ppparent%parent%is_proton ()) then
exit
else
ppparent => ppparent%parent
end if
end do
K(i+2,1) = 21
K(i+2,2) = ppparent%type
K(i+2,3) = i
P(i+2,1:5) = ppparent%momentum_to_pythia6 ()
!!! add partons in the initial state of the ME
K(i+4,1) = 21
K(i+4,2) = pp%type
K(i+4,3) = i
P(i+4,1:5) = pp%momentum_to_pythia6 ()
else
!!! for e+e- without ISR all entries are the same
K(i,1) = 21
K(i,2) = pp%type
K(i,3) = 0
P(i,1:5) = pp%momentum_to_pythia6 ()
P(i+2,:) = P(1,:)
K(i+2,:) = K(1,:)
K(i+2,3) = i
P(i+4,:) = P(1,:)
K(i+4,:) = K(1,:)
K(i+4,3) = i
P(i+4,5) = 0.
end if
end do
N = 6
!!! create intermediate (fake) Z-Boson
!K(7,1) = 21
!K(7,2) = 23
!K(7,3) = 0
!P(7,1:4) = P(5,1:4) + P(6,1:4)
!P(7,5) = P(7,4)**2 - P(7,3)**2 - P(7,2)**2 - P(7,1)**2
!N = 7
!!! include partons in the final state of the hard matrix element
do i = 1, size (shower%interactions(1)%i%partons) - 2
!!! get partons that are in the final state of the hard matrix element
pp => shower%interactions(1)%i%partons(2+i)%p
!!! add these partons to the event record
K(7+I,1) = 21
K(7+I,2) = pp%type
K(7+I,3) = 7
P(7+I,1:5) = pp%momentum_to_pythia6 ()
!N = 7 + I
N = 6 + I
end do
!!! include "Z" (again)
!N = N + 1
!K(N,1) = 11
!K(N,2) = 23
!K(N,3) = 7
!P(N,1:5) = P(7,1:5)
!nz = N
!!! include partons from the final state of the parton shower
call shower_transfer_final_partons_to_pythia (shower, 8)
!!! set "children" of "Z"
!K(nz,4) = 11
!K(nz,5) = N
!!! be sure to remove the next partons (=first obsolete partons)
!!! otherwise they might be interpreted as thrust information
K(N+1:N+3,1:3) = 0
end subroutine shower_converttopythia
@ %def shower_converttopythia
@
<<Shower core: procedures>>=
subroutine shower_transfer_final_partons_to_pythia (shower, first)
<<PYJETS COMMON BLOCK>>
type(shower_t), intent(in) :: shower
integer, intent(in) :: first
type(parton_t), pointer :: prt
integer :: i, j, n_finals
type(parton_t), dimension(:), allocatable :: final_partons
type(parton_t) :: temp_parton
integer :: minindex, maxindex
prt => null()
!!! get total number of final partons
n_finals = 0
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
prt => shower%partons(i)%p
if (.not. prt%belongstoFSR) cycle
if (associated (prt%child1)) cycle
n_finals = n_finals + 1
end do
allocate (final_partons(1:n_finals))
j = 1
do i = 1, size (shower%partons)
if (.not. associated (shower%partons(i)%p)) cycle
prt => shower%partons(i)%p
if (.not. prt%belongstoFSR) cycle
if (associated (prt%child1)) cycle
final_partons(j) = shower%partons(i)%p
j = j + 1
end do
!!! move quark to front as beginning of color string
minindex = 1
maxindex = size (final_partons)
FIND_Q: do i = minindex, maxindex
if (final_partons(i)%type >= 1 .and. final_partons(i)%type <= 6) then
temp_parton = final_partons(minindex)
final_partons(minindex) = final_partons(i)
final_partons(i) = temp_parton
exit FIND_Q
end if
end do FIND_Q
!!! sort so that connected partons are next to each other, don't care about zeros
do i = 1, size (final_partons)
!!! ensure that final_partnons begins with a color (not an anticolor)
if (final_partons(i)%c1 > 0 .and. final_partons(i)%c2 == 0) then
if (i == 1) then
exit
else
temp_parton = final_partons(1)
final_partons(1) = final_partons(i)
final_partons(i) = temp_parton
exit
end if
end if
end do
do i = 1, size (final_partons) - 1
!!! search for color partner and move it to i + 1
PARTNERS: do j = i + 1, size (final_partons)
if (final_partons(j)%c2 == final_partons(i)%c1) exit PARTNERS
end do PARTNERS
if (j > size (final_partons)) then
print *, "no color connected parton found" !WRONG???
print *, "particle: ", final_partons(i)%nr, " index: ", &
final_partons(i)%c1
exit
end if
temp_parton = final_partons(i + 1)
final_partons(i + 1) = final_partons(j)
final_partons(j) = temp_parton
end do
!!! transfering partons
do i = 1, size (final_partons)
prt = final_partons(i)
N = N + 1
K(N,1) = 2
if (prt%c1 == 0) K(N,1) = 1 !!! end of color string
K(N,2) = prt%type
!K(N,3) = first
K(N,3) = 0
K(N,4) = 0
K(N,5) = 0
P(N,1:5) = prt%momentum_to_pythia6()
end do
deallocate (final_partons)
end subroutine shower_transfer_final_partons_to_pythia
@ %def shower_transfer_final_partons_to_pythia
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Interface to PYTHIA}
<<[[shower_pythia6.f90]]>>=
<<File header>>
module shower_pythia6
<<Use kinds with double>>
<<Use strings>>
use constants
use numeric_utils, only: vanishes
use io_units
use physics_defs
use diagnostics
use os_interface
use lorentz
use subevents
use shower_base
use particles
use model_data
use hep_common
use pdf
use helicities
use tauola_interface
<<Standard module head>>
<<Shower pythia6: public>>
<<Shower pythia6: variables>>
<<Shower pythia6: types>>
contains
<<Shower pythia6: procedures>>
end module shower_pythia6
@ %def shower_topythia
<<PYJETS COMMON BLOCK>>=
integer :: N, NPAD, K
real(double) :: P, V
COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5)
SAVE /PYJETS/
@
<<Shower pythia6: variables>>=
integer :: N_old
@ %def N_old
@ The PYTHIA6 shower type.
<<Shower pythia6: public>>=
public :: shower_pythia6_t
<<Shower pythia6: types>>=
type, extends (shower_base_t) :: shower_pythia6_t
integer :: initialized_for_NPRUP = 0
logical :: warning_given = .false.
contains
<<Shower pythia6: shower pythia6: TBP>>
end type shower_pythia6_t
@ %def shower_pythia6_t
@ Initialize the PYTHIA6 shower.
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: init => shower_pythia6_init
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_init (shower, settings, taudec_settings, pdf_data)
class(shower_pythia6_t), intent(out) :: shower
type(shower_settings_t), intent(in) :: settings
type(taudec_settings_t), intent(in) :: taudec_settings
type(pdf_data_t), intent(in) :: pdf_data
call msg_debug (D_SHOWER, "shower_pythia6_init")
shower%settings = settings
shower%taudec_settings = taudec_settings
call pythia6_set_verbose (settings%verbose)
call shower%pdf_data%init (pdf_data)
shower%name = "PYTHIA6"
call shower%write_msg ()
end subroutine shower_pythia6_init
@ %def shower_pythia6_init
@
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: prepare_new_event => shower_pythia6_prepare_new_event
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_prepare_new_event (shower)
class(shower_pythia6_t), intent(inout) :: shower
end subroutine shower_pythia6_prepare_new_event
@ %def shower_pythia6_prepare_new_event
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: import_particle_set => shower_pythia6_import_particle_set
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_import_particle_set &
(shower, particle_set, os_data, scale)
class(shower_pythia6_t), target, intent(inout) :: shower
type(particle_set_t), intent(in) :: particle_set
type(os_data_t), intent(in) :: os_data
real(default), intent(in) :: scale
type(particle_set_t) :: pset_reduced
call msg_debug (D_SHOWER, "shower_pythia6_import_particle_set")
if (debug_active (D_SHOWER)) then
print *, 'IDBMUP(1:2) = ', IDBMUP(1:2)
print *, 'EBMUP, PDFGUP = ', EBMUP, PDFGUP
print *, 'PDFSUP, IDWTUP = ', PDFSUP, IDWTUP
print *, "NPRUP = ", NPRUP
call particle_set%write (summary=.true., compressed=.true.)
end if
call particle_set%reduce (pset_reduced)
if (debug2_active (D_SHOWER)) then
print *, 'After particle_set%reduce: pset_reduced'
call pset_reduced%write (summary=.true., compressed=.true.)
end if
call hepeup_from_particle_set (pset_reduced, tauola_convention=.true.)
call hepeup_set_event_parameters (proc_id = 1)
call hepeup_set_event_parameters (scale = scale)
end subroutine shower_pythia6_import_particle_set
@ %def shower_pythia6_import_particle_set
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: generate_emissions => shower_pythia6_generate_emissions
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_generate_emissions &
(shower, valid, number_of_emissions)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
class(shower_pythia6_t), intent(inout), target :: shower
logical, intent(out) :: valid
integer, optional, intent(in) :: number_of_emissions
integer :: N, NPAD, K
real(double) :: P, V
common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5)
COMMON/PYDAT2/KCHG(500,4),PMAS(500,4),PARF(2000),VCKM(4,4)
COMMON/PYINT4/MWID(500),WIDS(500,5)
save /PYJETS/,/PYDAT2/,/PYINT4/
integer :: u_W2P
integer :: i
real(double) :: beta_z, pz_in, E_in
integer, parameter :: lower = 5
real(double), parameter :: beta_x = 0.0_double
real(double), parameter :: beta_y = 0.0_double
real(double), parameter :: theta = 0.0_double
real(double), parameter :: phi = 0.0_double
if (signal_is_pending ()) return
call pythia6_setup_lhe_io_units (u_W2P)
call w2p_write_lhef_event (u_W2P)
rewind (u_W2P)
call pythia6_set_last_treated_line(6)
call shower%transfer_settings ()
if (debug_active (D_SHOWER)) then
print *, ' Before pyevnt, before boosting :'
call pylist(2)
end if
call msg_debug (D_SHOWER, "calling pyevnt")
! TODO: (bcn 2015-04-24) doesnt change anything I think
! P(1,1:5) = pset_reduced%prt(1)%momentum_to_pythia6 ()
! P(2,1:5) = pset_reduced%prt(2)%momentum_to_pythia6 ()
call pyevnt ()
call pyedit(12)
do i = 1, n
if (K(i,1) == 14 .and. abs(K(i,2)) >= 11 .and. abs(K(i,2)) <= 16) then
if (K(i,4) > 0 .and. K(i,5) > 0 .and. K(i,4) < N .and. K(i,5) < N) then
K(i,1) = 11
K(i,4) = K(K(i,4),3)
K(i,5) = K(K(i,5),3)
end if
end if
end do
if (.not. shower%settings%hadron_collision) then
pz_in = pup(3,1) + pup(3,2)
E_in = pup(4,1) + pup(4,2)
beta_z = pz_in / E_in
call pyrobo (lower, N, theta, phi, beta_x, beta_y, beta_z)
end if
if (debug_active (D_SHOWER)) then
print *, ' After pyevnt, after boosting :'
call pylist(2)
if (debug2_active (D_SHOWER)) then
call pystat (5)
do i = 1, 200
print *, 'MSTJ (', i, ') = ', MSTJ(i)
print *, 'MSTU (', i, ') = ', MSTU(i)
print *, 'PMAS (', i, ') = ', PMAS(i,1), PMAS(i,2)
print *, 'MWID (', i, ') = ', MWID(i)
print *, 'PARJ (', i, ') = ', PARJ(i)
end do
end if
end if
close (u_W2P)
valid = pythia6_handle_errors ()
end subroutine shower_pythia6_generate_emissions
@ %def shower_pythia6_generate_emissions
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: make_particle_set => shower_pythia6_make_particle_set
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_make_particle_set &
(shower, particle_set, model, model_hadrons)
class(shower_pythia6_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model
class(model_data_t), intent(in), target :: model_hadrons
call shower%combine_with_particle_set (particle_set, model, model_hadrons)
end subroutine shower_pythia6_make_particle_set
@ %def shower_pythia6_make_particle_set
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: transfer_settings => shower_pythia6_transfer_settings
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_transfer_settings (shower)
class(shower_pythia6_t), intent(inout) :: shower
character(len=10) :: buffer
real(default) :: rand
logical, save :: tauola_initialized = .false.
call msg_debug (D_SHOWER, "shower_pythia6_transfer_settings")
!!! We repeat these as they are overwritten by the hadronization
call pygive ("MSTP(111)=1") !!! Allow hadronization and decays
call pygive ("MSTJ(1)=0") !!! No jet fragmentation
call pygive ("MSTJ(21)=1") !!! Allow decays but no jet fragmentation
if (shower%initialized_for_NPRUP >= NPRUP) then
call msg_debug (D_SHOWER, "calling upinit")
call upinit ()
else
if (shower%settings%isr_active) then
call pygive ("MSTP(61)=1")
else
call pygive ("MSTP(61)=0") !!! switch off ISR
end if
if (shower%settings%fsr_active) then
call pygive ("MSTP(71)=1")
else
call pygive ("MSTP(71)=0") !!! switch off FSR
end if
call pygive ("MSTP(11)=0") !!! Disable Pythias QED-ISR per default
call pygive ("MSTP(171)=1") !!! Allow variable energies
write (buffer, "(F10.5)") sqrt (abs (shower%settings%min_virtuality))
call pygive ("PARJ(82)=" // buffer)
write (buffer, "(F10.5)") shower%settings%isr_tscalefactor
call pygive ("PARP(71)=" // buffer)
write (buffer, "(F10.5)") shower%settings%fsr_lambda
call pygive ("PARP(72)=" // buffer)
write(buffer, "(F10.5)") shower%settings%isr_lambda
call pygive ("PARP(61)=" // buffer)
write (buffer, "(I10)") shower%settings%max_n_flavors
call pygive ("MSTJ(45)=" // buffer)
if (shower%settings%isr_alphas_running) then
call pygive ("MSTP(64)=2")
else
call pygive ("MSTP(64)=0")
end if
if (shower%settings%fsr_alphas_running) then
call pygive ("MSTJ(44)=2")
else
call pygive ("MSTJ(44)=0")
end if
write (buffer, "(F10.5)") shower%settings%fixed_alpha_s
call pygive ("PARU(111)=" // buffer)
write (buffer, "(F10.5)") shower%settings%isr_primordial_kt_width
call pygive ("PARP(91)=" // buffer)
write (buffer, "(F10.5)") shower%settings%isr_primordial_kt_cutoff
call pygive ("PARP(93)=" // buffer)
write (buffer, "(F10.5)") 1._double - shower%settings%isr_z_cutoff
call pygive ("PARP(66)=" // buffer)
write (buffer, "(F10.5)") shower%settings%isr_minenergy
call pygive ("PARP(65)=" // buffer)
if (shower%settings%isr_only_onshell_emitted_partons) then
call pygive ("MSTP(63)=0")
else
call pygive ("MSTP(63)=2")
end if
if (shower%settings%mlm_matching) then
call pygive ("MSTP(62)=2")
call pygive ("MSTP(67)=0")
end if
call pythia6_set_config (shower%settings%pythia6_pygive)
call msg_debug (D_SHOWER, "calling pyinit")
call PYINIT ("USER", "", "", 0D0)
call shower%rng%generate (rand)
write (buffer, "(I10)") floor (rand*900000000)
call pygive ("MRPY(1)=" // buffer)
call pygive ("MRPY(2)=0")
call pythia6_set_config (shower%settings%pythia6_pygive)
shower%initialized_for_NPRUP = NPRUP
end if
if (shower%settings%tau_dec) then
call pygive ("MSTJ(28)=2")
end if
if (pythia6_tauola_active() .and. .not. tauola_initialized) then
call wo_tauola_init_call (shower%taudec_settings)
tauola_initialized = .true.
end if
end subroutine shower_pythia6_transfer_settings
@ %def shower_pythia6_transfer_settings
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: combine_with_particle_set => &
shower_pythia6_combine_with_particle_set
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_combine_with_particle_set &
(shower, particle_set, model_in, model_hadrons)
class(shower_pythia6_t), intent(in) :: shower
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model_in
class(model_data_t), intent(in), target :: model_hadrons
call pythia6_combine_with_particle_set &
(particle_set, model_in, model_hadrons, shower%settings)
end subroutine shower_pythia6_combine_with_particle_set
@ %def shower_pythia6_combine_with_particle_set
@
\begin{tabular}{l l}
K(I,1) & pythia status code \\
& 1 = undecayed particle or unfragmented parton \\
& (single or last of parton system) \\
& 2 = unfragmented parton \\
& (followed by more partons in the same color singlet \\
& 3 = unfragmented parton (color info in K(I,4), K(I,5)) \\
& 11 = decayed particle or fragmented parton \\
& 12 = fragmented parton \\
& 13 = fragmented parton that has been removed \\
& 14 = branched parton with color info like 3 \\
& 21 = documentation lines \\
K(I,2) & PDG code \\
K(I,3) & Parent where known else 0. Unphysical to assign \\
& particles partons as parents \\
K(I,4) & Normally first daughter \\
K(I,5) & Normally last daughter
\end{tabular}
The first two particles are always the beams, in Pythia and Whizard.
We remove all beam remnants (including the ISR photons) since those are
added back in by Pythia.
@
<<Shower pythia6: public>>=
public :: pythia6_combine_with_particle_set
@
<<Shower pythia6: procedures>>=
subroutine pythia6_combine_with_particle_set (particle_set, model_in, &
model_hadrons, settings)
type(particle_set_t), intent(inout) :: particle_set
class(model_data_t), intent(in), target :: model_in
class(model_data_t), intent(in), target :: model_hadrons
type(shower_settings_t), intent(in) :: settings
class(model_data_t), pointer :: model
type(vector4_t) :: momentum
type(particle_t), dimension(:), allocatable :: particles, beams
integer :: dangling_col, dangling_anti_col, color, anti_color
integer :: i, j, py_entries, next_color, n_tot_old, parent, real_parent
integer :: pdg, status, child, hadro_start, i_py, i_whz
integer, allocatable, dimension(:) :: py_index, whz_index
logical, allocatable, dimension(:) :: valid
real(default), parameter :: py_tiny = 1E-10_default
integer :: N, NPAD, K
real(double) :: P, V
common /PYJETS/ N, NPAD, K(4000,5), P(4000,5), V(4000,5)
save /PYJETS/
integer, parameter :: KSUSY1 = 1000000, KSUSY2 = 2000000
if (signal_is_pending ()) return
if (debug_active (D_SHOWER)) then
call msg_debug (D_SHOWER, 'Combine PYTHIA6 with particle set')
call msg_debug (D_SHOWER, 'Particle set before replacing')
call particle_set%write (summary=.true., compressed=.true.)
call pylist (2)
call msg_debug (D_SHOWER, string = "settings%hadron_collision", &
value = settings%hadron_collision)
end if
if (settings%method == PS_PYTHIA6 .and. settings%hadron_collision) then
call pythia6_set_last_treated_line(2)
allocate (beams(2))
beams = particle_set%prt(1:2)
call particle_set%replace (beams)
if (debug_active (D_SHOWER)) then
call msg_debug (D_SHOWER, 'Resetting particle set to')
call particle_set%write (summary=.true., compressed=.true.)
end if
end if
call fill_hepevt_block_from_pythia ()
call count_valid_entries_in_pythia_record ()
call particle_set%without_hadronic_remnants &
(particles, n_tot_old, py_entries)
if (debug_active (D_SHOWER)) then
print *, 'n_tot_old = ', n_tot_old
print *, 'py_entries = ', py_entries
end if
call add_particles_of_pythia ()
call particle_set%replace (particles)
if (settings%hadron_collision) then
call set_parent_child_relations_from_K ()
call set_parent_child_relations_of_color_strings_to_hadrons ()
!!! call particle_set%remove_duplicates (py_tiny * 100.0_default)
else
call set_parent_child_relations_from_hepevt ()
end if
!call fix_nonemitting_outgoings ()
if (settings%method == PS_WHIZARD) then
call fudge_whizard_partons_in_hadro ()
end if
where ((particle_set%prt%status == PRT_OUTGOING .or. &
particle_set%prt%status == PRT_VIRTUAL .or. &
particle_set%prt%status == PRT_BEAM_REMNANT) .and. &
particle_set%prt%has_children ()) &
particle_set%prt%status = PRT_RESONANT
if (debug_active (D_SHOWER)) then
print *, 'Particle set after replacing'
call particle_set%write (summary=.true., compressed=.true.)
print *, ' pythia6_set_last_treated_line will set to: ', N
end if
call pythia6_set_last_treated_line(N)
contains
<<Shower pythia6: combine with particle set: procedures>>
end subroutine pythia6_combine_with_particle_set
@ %def pythia6_combine_with_particle_set
<<Shower pythia6: combine with particle set: procedures>>=
subroutine count_valid_entries_in_pythia_record ()
<<HEPEVT BLOCK>>
integer :: pset_idx
logical :: comes_from_cmshower, emitted_zero_momentum_photon, &
direct_decendent
integer, parameter :: cmshower = 94
hadro_start = 0
allocate (valid(N))
valid = .false.
FIND: do i_py = 5, N
!if (K(i_py,2) >= 91 .and. K(i_py,2) <= 94) then
if (K(i_py,2) >= 91 .and. K(i_py,2) <= 93) then
hadro_start = i_py
exit FIND
end if
end do FIND
do i_py = N, N_old+1, -1
status = K(i_py,1)
if (any (P(i_py,1:4) > 1E-8_default * P(1,4)) .and. &
(status >= 1 .and. status <= 21)) then
pset_idx = find_pythia_particle (i_py, more_fuzzy=.false.)
direct_decendent = IDHEP(JMOHEP(1,i_py)) == cmshower .and. &
JMOHEP(2,i_py) == 0
emitted_zero_momentum_photon = find_pythia_particle &
(JMOHEP(1,i_py), more_fuzzy=.false.) == pset_idx
comes_from_cmshower = status == 1 .and. &
(direct_decendent .or. emitted_zero_momentum_photon)
valid(i_py) = pset_idx == 0 .or. comes_from_cmshower
end if
end do
py_entries = count (valid)
allocate (py_index (py_entries))
allocate (whz_index (N))
whz_index = 0
end subroutine count_valid_entries_in_pythia_record
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine add_particles_of_pythia ()
integer :: whizard_status
integer :: pset_idx, start_in_py
integer :: ihelicity
type(helicity_t) :: hel
real(default) :: lifetime
type(vector4_t) :: vertex
dangling_col = 0
dangling_anti_col = 0
next_color = 500
i_whz = 1
if (settings%method == PS_PYTHIA6 .and. settings%hadron_collision) then
start_in_py = 3
else
start_in_py = 7
end if
do i_py = start_in_py, N
status = K(i_py,1)
if (valid(i_py)) then
call assign_colors (color, anti_color)
momentum = real ([P(i_py,4), P(i_py,1:3)], kind=default)
pdg = K(i_py,2)
parent = K(i_py,3)
call find_model (model, pdg, model_in, model_hadrons)
if (i_py <= 4) then
whizard_status = PRT_INCOMING
else
if (status <= 10) then
whizard_status = PRT_OUTGOING
else
whizard_status = PRT_VIRTUAL
end if
end if
call particles(n_tot_old+i_whz)%init &
(whizard_status, pdg, model, color, anti_color, momentum)
lifetime = V(i_py,5)
vertex = [real (V(i_py,4), kind=default), &
real (V(i_py,1), kind=default), &
real (V(i_py,2), kind=default), &
real (V(i_py,3), kind=default)]
if (.not. vanishes(lifetime)) &
call particles(n_tot_old+i_whz)%set_lifetime (lifetime)
if (any (.not. vanishes(real(V(i_py,1:4), kind = default)))) &
call particles(n_tot_old+i_whz)%set_vertex (vertex)
!!! Set tau helicity set by TAUOLA
if (abs (pdg) == 15) then
call wo_tauola_get_helicity (i_py, ihelicity)
call hel%init (ihelicity)
call particles(n_tot_old+i_whz)%set_helicity(hel)
call particles(n_tot_old+i_whz)%set_polarization(PRT_DEFINITE_HELICITY)
end if
py_index(i_whz) = i_py
whz_index(i_py) = n_tot_old + i_whz
i_whz = i_whz + 1
else
pset_idx = find_pythia_particle (i_py, more_fuzzy=.true.)
whz_index(i_py) = pset_idx
end if
end do
end subroutine add_particles_of_pythia
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine assign_colors (color, anti_color)
integer, intent(out) :: color, anti_color
if ((K(i_py,2) == 21) .or. (abs (K(i_py,2)) <= 8) .or. &
(abs (K(i_py,2)) >= KSUSY1+1 .and. abs (K(i_py,2)) <= KSUSY1+8) .or. &
(abs (K(i_py,2)) >= KSUSY2+1 .and. abs (K(i_py,2)) <= KSUSY2+8) .or. &
(abs (K(i_py,2)) >= 1000 .and. abs (K(i_py,2)) <= 9999) .and. &
hadro_start == 0) then
if (dangling_col == 0 .and. dangling_anti_col == 0) then
! new color string
! Gluon and gluino only color octets implemented so far
if (K(i_py,2) == 21 .or. K(i_py,2) == 1000021) then
color = next_color
dangling_col = color
next_color = next_color + 1
anti_color = next_color
dangling_anti_col = anti_color
next_color = next_color + 1
else if (K(i_py,2) > 0) then ! particles have color
color = next_color
dangling_col = color
anti_color = 0
next_color = next_color + 1
else if (K(i_py,2) < 0) then ! antiparticles have anticolor
anti_color = next_color
dangling_anti_col = anti_color
color = 0
next_color = next_color + 1
end if
else if(status == 1) then
! end of string
color = dangling_anti_col
anti_color = dangling_col
dangling_col = 0
dangling_anti_col = 0
else
! inside the string
if(dangling_col /= 0) then
anti_color = dangling_col
color = next_color
dangling_col = next_color
next_color = next_color +1
else if(dangling_anti_col /= 0) then
color = dangling_anti_col
anti_color = next_color
dangling_anti_col = next_color
next_color = next_color +1
else
call msg_bug ("Couldn't assign colors")
end if
end if
else
color = 0
anti_color = 0
end if
end subroutine assign_colors
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine fill_hepevt_block_from_pythia ()
integer :: first_daughter, second_mother_of_first_daughter, i_hep
logical :: inconsistent_mother, more_than_one_points_to_first_daugther
<<HEPEVT BLOCK>>
call pyhepc(1)
do i_hep = 1, NHEP
first_daughter = JDAHEP(1,i_hep)
if (first_daughter > 0) then
more_than_one_points_to_first_daugther = &
count (JDAHEP(1,i_hep:NHEP) == first_daughter) > 1
if (more_than_one_points_to_first_daugther) then
second_mother_of_first_daughter = JMOHEP(2,first_daughter)
! Only entries with codes 91-94 should have a second mother
if (second_mother_of_first_daughter == 0) then
inconsistent_mother = JMOHEP(1,first_daughter) /= i_hep
if (inconsistent_mother) then
JMOHEP(1,first_daughter) = i_hep
do j = i_hep + 1, NHEP
if (JDAHEP(1,j) == first_daughter) then
JMOHEP(2,first_daughter) = j
end if
end do
end if
end if
end if
end if
end do
end subroutine fill_hepevt_block_from_pythia
<<HEPEVT BLOCK>>=
integer, parameter :: NMXHEP = 4000
integer :: NEVHEP
integer :: NHEP
integer, dimension(NMXHEP) :: ISTHEP
integer, dimension(NMXHEP) :: IDHEP
integer, dimension(2, NMXHEP) :: JMOHEP
integer, dimension(2, NMXHEP) :: JDAHEP
double precision, dimension(5, NMXHEP) :: PHEP
double precision, dimension(4, NMXHEP) :: VHEP
common /HEPEVT/ &
NEVHEP, NHEP, ISTHEP, IDHEP, &
JMOHEP, JDAHEP, PHEP, VHEP
save /HEPEVT/
@ Use HEPEVT for parent-child informations
<<Shower pythia6: combine with particle set: procedures>>=
subroutine set_parent_child_relations_from_hepevt ()
integer, allocatable, dimension(:) :: parents
<<HEPEVT BLOCK>>
integer :: parent2, parent1, npar
integer :: jsearch
call msg_debug (D_SHOWER, &
"set_parent_child_relations_from_hepevt")
if (debug_active (D_SHOWER)) then
print *, 'NHEP, n, py_entries:' , NHEP, n, py_entries
call pylist(5)
end if
do i_whz = 1, py_entries
parent1 = JMOHEP(1,py_index(i_whz))
if (IDHEP(py_index(i_whz)) == 94) then
firstmother: do jsearch = parent1-1, 1, -1
if (JDAHEP(1,jsearch) /= py_index(i_whz)) then
exit firstmother
end if
parent1 = jsearch
end do firstmother
end if
parent2 = parent1
if (JMOHEP(2,py_index(i_whz)) > 0) then
parent2 = JMOHEP(2,py_index(i_whz))
- else
- if (IDHEP(py_index(i_whz)) == 94) then
- lastmother: do jsearch = parent1+1, py_index(i_whz)
- if (JDAHEP(1,jsearch) /= py_index(i_whz)) then
- exit lastmother
- end if
- parent2 = jsearch
- end do lastmother
- endif
+ end if
+ if (IDHEP(py_index(i_whz)) == 94) then
+ lastmother: do jsearch = parent1+1, py_index(i_whz)
+ if (JDAHEP(1,jsearch) /= py_index(i_whz)) then
+ exit lastmother
+ end if
+ parent2 = jsearch
+ end do lastmother
end if
allocate (parents(parent2-parent1+1))
parents = 0
child = n_tot_old + i_whz
npar = 0
do parent = parent1, parent2
if (parent > 0) then
if (parent <= 2) then
call particle_set%parent_add_child (parent, child)
else
if (whz_index(parent) > 0) then
npar = npar + 1
parents(npar) = whz_index(parent)
call particle_set%prt(whz_index(parent))%add_child (child)
end if
end if
end if
end do
parents = pack (parents, parents > 0)
if (npar > 0) call particle_set%prt(child)%set_parents (parents)
if (allocated (parents)) deallocate (parents)
end do
NHEP = 0
end subroutine set_parent_child_relations_from_hepevt
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine fix_nonemitting_outgoings ()
integer, dimension(1) :: child
integer, parameter :: cmshower = 94
do i = 1, size (particle_set%prt)
associate (p => particle_set%prt(i))
if (p%get_n_children () == 1) then
child = p%get_children ()
if (particle_set%prt(child(1))%get_pdg () == cmshower) then
j = particle_set%reverse_find_particle (p%get_pdg (), p%p)
if (j == i) then
deallocate (p%child)
p%status = PRT_OUTGOING
end if
end if
end if
end associate
end do
end subroutine fix_nonemitting_outgoings
<<Shower pythia6: combine with particle set: procedures>>=
subroutine set_parent_child_relations_from_K ()
do j = 1, py_entries
parent = K(py_index(j),3)
child = n_tot_old + j
if (parent > 0) then
if (parent >= 1 .and. parent <= 2) then
call particle_set%parent_add_child (parent, child)
else
real_parent = whz_index (parent)
if (real_parent > 0 .and. real_parent /= child) then
call particle_set%parent_add_child (real_parent, child)
end if
end if
end if
end do
end subroutine set_parent_child_relations_from_K
@
<<Shower pythia6: combine with particle set: procedures>>=
subroutine set_parent_child_relations_of_color_strings_to_hadrons ()
integer :: begin_string, end_string, old_start, next_start, real_child
integer, allocatable, dimension(:) :: parents
call msg_debug (D_SHOWER, "set_parent_child_relations_of_color_strings_to_hadrons")
call msg_debug (D_SHOWER, "hadro_start", hadro_start)
if (hadro_start > 0) then
old_start = hadro_start
do
next_start = 0
FIND: do i = old_start + 1, N
if (K(i,2) >= 91 .and. K(i,2) <= 94) then
next_start = i
exit FIND
end if
end do FIND
begin_string = K(old_start,3)
end_string = N
do i = begin_string, N
if (K(i,1) == 11) then
end_string = i
exit
end if
end do
allocate (parents (end_string - begin_string + 1))
parents = 0
real_child = whz_index (old_start)
do i = begin_string, end_string
real_parent = whz_index (i)
if (real_parent > 0) then
call particle_set%prt(real_parent)%add_child (real_child)
parents (i - begin_string + 1) = real_parent
end if
end do
call particle_set%prt(real_child)%set_parents (parents)
deallocate (parents)
if (next_start == 0) exit
old_start = next_start
end do
end if
end subroutine set_parent_child_relations_of_color_strings_to_hadrons
@ We allow to be [[more_fuzzy]] when finding particles for parent child
relations than when deciding whether we add particles or not.
<<Shower pythia6: combine with particle set: procedures>>=
function find_pythia_particle (i_py, more_fuzzy) result (j)
integer :: j
integer, intent(in) :: i_py
logical, intent(in) :: more_fuzzy
real(default) :: rel_small
pdg = K(i_py,2)
momentum = real([P(i_py,4), P(i_py,1:3)], kind=default)
if (more_fuzzy) then
rel_small = 1E-6_default
else
rel_small = 1E-10_default
end if
j = particle_set%reverse_find_particle (pdg, momentum, &
abs_smallness = py_tiny, &
rel_smallness = rel_small)
end function find_pythia_particle
@ Outgoing partons after hadronization shouldn't happen and is a dirty
fix to missing mother daughter relation. I suspect that it has to do
with the ordering of the color string but am not sure.
<<Shower pythia6: combine with particle set: procedures>>=
subroutine fudge_whizard_partons_in_hadro ()
do i = 1, size (particle_set%prt)
if (particle_set%prt(i)%status == PRT_OUTGOING .and. &
(particle_set%prt(i)%flv%get_pdg () == GLUON .or. &
particle_set%prt(i)%flv%get_pdg_abs () < 6) .or. &
particle_set%prt(i)%status == PRT_BEAM_REMNANT) then
particle_set%prt(i)%status = PRT_VIRTUAL
end if
end do
end subroutine fudge_whizard_partons_in_hadro
@ %def fudge_whizard_partons_in_hadro
@
<<Shower pythia6: shower pythia6: TBP>>=
procedure :: get_final_colored_ME_momenta => shower_pythia6_get_final_colored_ME_momenta
<<Shower pythia6: procedures>>=
subroutine shower_pythia6_get_final_colored_ME_momenta &
(shower, momenta)
class(shower_pythia6_t), intent(in) :: shower
type(vector4_t), dimension(:), allocatable, intent(out) :: momenta
<<PYJETS COMMON BLOCK>>
integer :: i, j, n_jets
if (signal_is_pending ()) return
i = 7 !!! final ME partons start in 7th row of event record
n_jets = 0
do
if (K(I,1) /= 21) exit
if ((K(I,2) == 21) .or. (abs(K(I,2)) <= 6)) then
n_jets = n_jets + 1
end if
i = i + 1
end do
if (n_jets == 0) return
allocate (momenta(1:n_jets))
i = 7
j = 1
do
if (K(I,1) /= 21) exit
if ((K(I,2) == 21) .or. (abs(K(I,2)) <= 6)) then
momenta(j) = real ([P(i,4), P(i,1:3)], kind=default)
j = j + 1
end if
i = i + 1
end do
end subroutine shower_pythia6_get_final_colored_ME_momenta
@ %def shower_pythia6_get_final_colored_ME_momenta
@
<<Shower pythia6: public>>=
public :: pythia6_setup_lhe_io_units
<<Shower pythia6: procedures>>=
subroutine pythia6_setup_lhe_io_units (u_W2P, u_P2W)
integer, intent(out) :: u_W2P
integer, intent(out), optional :: u_P2W
character(len=10) :: buffer
u_W2P = free_unit ()
if (debug_active (D_SHOWER)) then
open (unit=u_W2P, status="replace", file="whizardout.lhe", &
action="readwrite")
else
open (unit=u_W2P, status="scratch", action="readwrite")
end if
write (buffer, "(I10)") u_W2P
call pygive ("MSTP(161)=" // buffer) !!! Unit for PYUPIN (LHA)
call pygive ("MSTP(162)=" // buffer) !!! Unit for PYUPEV (LHA)
if (present (u_P2W)) then
u_P2W = free_unit ()
write (buffer, "(I10)") u_P2W
call pygive ("MSTP(163)=" // buffer)
if (debug_active (D_SHOWER)) then
open (unit=u_P2W, file="pythiaout2.lhe", status="replace", &
action="readwrite")
else
open (unit=u_P2W, status="scratch", action="readwrite")
end if
end if
end subroutine pythia6_setup_lhe_io_units
@ %def pythia6_setup_lhe_io_units
@
<<Shower pythia6: public>>=
public :: pythia6_set_config
<<Shower pythia6: procedures>>=
subroutine pythia6_set_config (pygive_all)
type(string_t), intent(in) :: pygive_all
type(string_t) :: pygive_remaining, pygive_partial
if (len (pygive_all) > 0) then
pygive_remaining = pygive_all
do while (len (pygive_remaining) > 0)
call split (pygive_remaining, pygive_partial, ";")
call pygive (char (pygive_partial))
end do
if (pythia6_get_error() /= 0) then
call msg_fatal &
(" PYTHIA6 did not recognize ps_PYTHIA_PYGIVE setting.")
end if
end if
end subroutine pythia6_set_config
@ %def pythia_6_set_config
@ Exchanging error messages with PYTHIA6.
<<Shower pythia6: public>>=
public :: pythia6_set_error
<<Shower pythia6: procedures>>=
subroutine pythia6_set_error (mstu23)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
integer, intent(in) :: mstu23
MSTU(23) = mstu23
end subroutine pythia6_set_error
@ %def pythia6_set_error
@
<<Shower pythia6: public>>=
public :: pythia6_get_error
<<Shower pythia6: procedures>>=
function pythia6_get_error () result (mstu23)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
integer :: mstu23
mstu23 = MSTU(23)
end function pythia6_get_error
@ %def pythia6_get_error
@
<<Shower pythia6: public>>=
public :: pythia6_tauola_active
<<Shower pythia6: procedures>>=
function pythia6_tauola_active () result (active)
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
logical :: active
active = MSTJ(28) == 2
end function pythia6_tauola_active
@ %def pythia6_tauola_active
@
<<Shower pythia6: public>>=
public :: pythia6_handle_errors
<<Shower pythia6: procedures>>=
function pythia6_handle_errors () result (valid)
logical :: valid
valid = pythia6_get_error () == 0
if (.not. valid) then
call pythia6_set_error (0)
end if
end function pythia6_handle_errors
@ %def pythia6_handle_errors
@
<<Shower pythia6: public>>=
public :: pythia6_set_verbose
<<Shower pythia6: procedures>>=
subroutine pythia6_set_verbose (verbose)
logical, intent(in) :: verbose
if (verbose) then
call pygive ('MSTU(13)=1')
else
call pygive ('MSTU(12)=12345') !!! No title page is written
call pygive ('MSTU(13)=0') !!! No information is written
end if
end subroutine pythia6_set_verbose
@ %def pythia6_set_verbose
@
<<Shower pythia6: public>>=
public :: pythia6_set_last_treated_line
<<Shower pythia6: procedures>>=
subroutine pythia6_set_last_treated_line (last_line)
integer,intent(in) :: last_line
N_old = last_line
end subroutine pythia6_set_last_treated_line
@ %def pythia6_set_last_treated_line
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@
<<[[pythia6_up.f]]>>=
C...UPINIT
C...Is supposed to fill the HEPRUP commonblock with info
C...on incoming beams and allowed processes.
SUBROUTINE UPINIT
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...PYTHIA commonblock: only used to provide read unit MSTP(161).
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
SAVE /PYPARS/
C...User process initialization commonblock.
INTEGER MAXPUP
PARAMETER (MAXPUP=100)
INTEGER IDBMUP,PDFGUP,PDFSUP,IDWTUP,NPRUP,LPRUP
DOUBLE PRECISION EBMUP,XSECUP,XERRUP,XMAXUP
COMMON/HEPRUP/IDBMUP(2),EBMUP(2),PDFGUP(2),PDFSUP(2),
&IDWTUP,NPRUP,XSECUP(MAXPUP),XERRUP(MAXPUP),XMAXUP(MAXPUP),
&LPRUP(MAXPUP)
SAVE /HEPRUP/
C...Lines to read in assumed never longer than 200 characters.
PARAMETER (MAXLEN=200)
CHARACTER*(MAXLEN) STRING
C...Format for reading lines.
CHARACTER(len=6) STRFMT
STRFMT='(A000)'
WRITE(STRFMT(3:5),'(I3)') MAXLEN
C...Loop until finds line beginning with "<init>" or "<init ".
100 READ(MSTP(161),STRFMT,END=130,ERR=130) STRING
IBEG=0
110 IBEG=IBEG+1
C...Allow indentation.
IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-5) GOTO 110
IF(STRING(IBEG:IBEG+5).NE.'<init>'.AND.
&STRING(IBEG:IBEG+5).NE.'<init ') GOTO 100
C...Read first line of initialization info.
READ(MSTP(161),*,END=130,ERR=130) IDBMUP(1),IDBMUP(2),EBMUP(1),
&EBMUP(2),PDFGUP(1),PDFGUP(2),PDFSUP(1),PDFSUP(2),IDWTUP,NPRUP
C...Read NPRUP subsequent lines with information on each process.
DO 120 IPR=1,NPRUP
READ(MSTP(161),*,END=130,ERR=130) XSECUP(IPR),XERRUP(IPR),
& XMAXUP(IPR),LPRUP(IPR)
120 CONTINUE
RETURN
C...Error exit: give up if initalization does not work.
130 WRITE(*,*) ' Failed to read LHEF initialization information.'
WRITE(*,*) ' Event generation will be stopped.'
CALL PYSTOP(12)
RETURN
END
@
<<[[pythia6_up.f]]>>=
C...UPEVNT
C...Dummy routine, to be replaced by a user implementing external
C...processes. Depending on cross section model chosen, it either has
C...to generate a process of the type IDPRUP requested, or pick a type
C...itself and generate this event. The event is to be stored in the
C...HEPEUP commonblock, including (often) an event weight.
C...New example: handles a standard Les Houches Events File.
SUBROUTINE UPEVNT
C...Double precision and integer declarations.
IMPLICIT DOUBLE PRECISION(A-H, O-Z)
IMPLICIT INTEGER(I-N)
C...PYTHIA commonblock: only used to provide read unit MSTP(162).
COMMON/PYPARS/MSTP(200),PARP(200),MSTI(200),PARI(200)
SAVE /PYPARS/
C...Added by WHIZARD
COMMON/PYDAT1/MSTU(200),PARU(200),MSTJ(200),PARJ(200)
SAVE/PYDAT1/
C...User process event common block.
INTEGER MAXNUP
PARAMETER (MAXNUP=500)
INTEGER NUP,IDPRUP,IDUP,ISTUP,MOTHUP,ICOLUP
DOUBLE PRECISION XWGTUP,SCALUP,AQEDUP,AQCDUP,PUP,VTIMUP,SPINUP
COMMON/HEPEUP/NUP,IDPRUP,XWGTUP,SCALUP,AQEDUP,AQCDUP,IDUP(MAXNUP),
&ISTUP(MAXNUP),MOTHUP(2,MAXNUP),ICOLUP(2,MAXNUP),PUP(5,MAXNUP),
&VTIMUP(MAXNUP),SPINUP(MAXNUP)
SAVE /HEPEUP/
C...Lines to read in assumed never longer than 200 characters.
PARAMETER (MAXLEN=200)
CHARACTER*(MAXLEN) STRING
C...Format for reading lines.
CHARACTER(len=6) STRFMT
STRFMT='(A000)'
WRITE(STRFMT(3:5),'(I3)') MAXLEN
C...Loop until finds line beginning with "<event>" or "<event ".
100 READ(MSTP(162),STRFMT,END=130,ERR=130) STRING
IBEG=0
110 IBEG=IBEG+1
C...Allow indentation.
IF(STRING(IBEG:IBEG).EQ.' '.AND.IBEG.LT.MAXLEN-6) GOTO 110
IF(STRING(IBEG:IBEG+6).NE.'<event>'.AND.
&STRING(IBEG:IBEG+6).NE.'<event ') GOTO 100
C...Read first line of event info.
READ(MSTP(162),*,END=130,ERR=130) NUP,IDPRUP,XWGTUP,SCALUP,
&AQEDUP,AQCDUP
C...Read NUP subsequent lines with information on each particle.
DO 120 I=1,NUP
READ(MSTP(162),*,END=130,ERR=130) IDUP(I),ISTUP(I),
& MOTHUP(1,I),MOTHUP(2,I),ICOLUP(1,I),ICOLUP(2,I),
& (PUP(J,I),J=1,5),VTIMUP(I),SPINUP(I)
120 CONTINUE
RETURN
C...Error exit, typically when no more events.
130 CONTINUE
C WRITE(*,*) ' Failed to read LHEF event information.'
C WRITE(*,*) ' Will assume end of file has been reached.'
NUP=0
MSTI(51)=1
C...Added by WHIZARD, mark these failed events
MSTU(23)=1
RETURN
END
@
<<[[pythia6_up.f]]>>=
C...UPVETO
C...Dummy routine, to be replaced by user, to veto event generation
C...on the parton level, after parton showers but before multiple
C...interactions, beam remnants and hadronization is added.
C...If resonances like W, Z, top, Higgs and SUSY particles are handed
C...undecayed from UPEVNT, or are generated by PYTHIA, they will also
C...be undecayed at this stage; if decayed their decay products will
C...have been allowed to shower.
C...All partons at the end of the shower phase are stored in the
C...HEPEVT commonblock. The interesting information is
C...NHEP = the number of such partons, in entries 1 <= i <= NHEP,
C...IDHEP(I) = the particle ID code according to PDG conventions,
C...PHEP(J,I) = the (p_x, p_y, p_z, E, m) of the particle.
C...All ISTHEP entries are 1, while the rest is zeroed.
C...The user decision is to be conveyed by the IVETO value.
C...IVETO = 0 : retain current event and generate in full;
C... = 1 : abort generation of current event and move to next.
SUBROUTINE UPVETO(IVETO)
C...HEPEVT commonblock.
PARAMETER (NMXHEP=4000)
COMMON/HEPEVT/NEVHEP,NHEP,ISTHEP(NMXHEP),IDHEP(NMXHEP),
&JMOHEP(2,NMXHEP),JDAHEP(2,NMXHEP),PHEP(5,NMXHEP),VHEP(4,NMXHEP)
DOUBLE PRECISION PHEP,VHEP
SAVE /HEPEVT/
C...Next few lines allow you to see what info PYVETO extracted from
C...the full event record for the first two events.
C...Delete if you don't want it.
DATA NLIST/0/
SAVE NLIST
IF(NLIST.LE.2) THEN
WRITE(*,*) ' Full event record at time of UPVETO call:'
CALL PYLIST(1)
WRITE(*,*) ' Part of event record made available to UPVETO:'
CALL PYLIST(5)
NLIST=NLIST+1
ENDIF
C...Make decision here.
IVETO = 0
RETURN
END
@ %def pythia6_up.f
@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@
<<[[ktclus.f90]]>>=
<<File header>>
module ktclus
<<Use kinds>>
<<KTCLUS: public>>
contains
<<KTCLUS: procedures>>
end module ktclus
@ %def ktclus
<<KTCLUS: procedures>>=
!C-----------------------------------------------------------------------
!C-----------------------------------------------------------------------
!C-----------------------------------------------------------------------
!C KTCLUS: written by Mike Seymour, July 1992.
!C Last modified November 2000.
!C Please send comments or suggestions to Mike.Seymour@rl.ac.uk
!C
!C This is a general-purpose kt clustering package.
!C It can handle ee, ep and pp collisions.
!C It is loosely based on the program of Siggi Bethke.
!C
!C The time taken (on a 10MIP machine) is (0.2microsec)*N**3
!C where N is the number of particles.
!C Over 90 percent of this time is used in subroutine KTPMIN, which
!C simply finds the minimum member of a one-dimensional array.
!C It is well worth thinking about optimization: on the SPARCstation
!C a factor of two increase was obtained simply by increasing the
!C optimization level from its default value.
!C
!C The approach is to separate the different stages of analysis.
!C KTCLUS does all the clustering and records a merging history.
!C It returns a simple list of the y values at which each merging
!C occured. Then the following routines can be called to give extra
!C information on the most recently analysed event.
!C KTCLUR is identical but includes an R parameter, see below.
!C KTYCUT gives the number of jets at each given YCUT value.
!C KTYSUB gives the number of sub-jets at each given YCUT value.
!C KTBEAM gives same info as KTCLUS but only for merges with the beam
!C KTJOIN gives same info as KTCLUS but for merges of sub-jets.
!C KTRECO reconstructs the jet momenta at a given value of YCUT.
!C It also gives information on which jets at scale YCUT belong to
!C which macro-jets at scale YMAC, for studying sub-jet properties.
!C KTINCL reconstructs the jet momenta according to the inclusive jet
!C definition of Ellis and Soper.
!C KTISUB, KTIJOI and KTIREC are like KTYSUB, KTJOIN and KTRECO,
!C except that they only apply to one inclusive jet at a time,
!C with the pt of that jet automatically used for ECUT.
!C KTWICH gives a list of which particles ended up in which jets.
!C KTWCHS gives the same thing, but only for subjets.
!C Note that the numbering of jets used by these two routines is
!C guaranteed to be the same as that used by KTRECO.
!C
!C The collision type and analysis type are indicated by the first
!C argument of KTCLUS. IMODE=<TYPE><ANGLE><MONO><RECOM> where
!C TYPE: 1=>ee, 2=>ep with p in -z direction, 3=>pe, 4=>pp
!C ANGLE: 1=>angular kt def., 2=>DeltaR, 3=>f(DeltaEta,DeltaPhi)
!C where f()=2(cosh(eta)-cos(phi)) is the QCD emission metric
!C MONO: 1=>derive relative pseudoparticle angles from jets
!C 2=>monotonic definitions of relative angles
!C RECOM: 1=>E recombination scheme, 2=>pt scheme, 3=>pt**2 scheme
!C
!C There are also abbreviated forms for the most common combinations:
!C IMODE=1 => E scheme in e+e- (=1111)
!C 2 => E scheme in ep (=2111)
!C 3 => E scheme in pe (=3111)
!C 4 => E scheme in pp (=4111)
!C 5 => covariant E scheme in pp (=4211)
!C 6 => covariant pt-scheme in pp (=4212)
!C 7 => covariant monotonic pt**2-scheme in pp (=4223)
!C
!C KTRECO no longer needs to reconstruct the momenta according to the
!C same recombination scheme in which they were clustered. Its first
!C argument gives the scheme, taking the same values as RECOM above.
!C
!C Note that unlike previous versions, all variables which hold y
!C values have been named in a consistent way:
!C Y() is the output scale at which jets were merged,
!C YCUT is the input scale at which jets should be counted, and
!C jet-momenta reconstructed etc,
!C YMAC is the input macro-jet scale, used in determining whether
!C or not each jet is a sub-jet.
!C The original scheme defined in our papers is equivalent to always
!C setting YMAC=1.
!C Whenever a YCUT or YMAC variable is used, it is rounded down
!C infinitesimally, so that for example, setting YCUT=Y(2) refers
!C to the scale where the event is 2-jet, even if rounding errors
!C have shifted its value slightly.
!C
!C An R parameter can be used in hadron-hadron collisions by
!C calling KTCLUR instead of KTCLUS. This is as suggested by
!C Ellis and Soper, but implemented slightly differently,
!C as in M.H. Seymour, LU TP 94/2 (submitted to Nucl. Phys. B.).
!C R**2 multiplies the single Kt everywhere it is used.
!C Calling KTCLUR with R=1 is identical to calling KTCLUS.
!C R plays a similar role to the jet radius in a cone-type algorithm,
!C but is scaled up by about 40% (ie R=0.7 in a cone algorithm is
!C similar to this algorithm with R=1).
!C Note that R.EQ.1 must be used for the e+e- and ep versions,
!C and is strongly recommended for the hadron-hadron version.
!C However, R values smaller than 1 have been found to be useful for
!C certain applications, particularly the mass reconstruction of
!C highly-boosted colour-singlets such as high-pt hadronic Ws,
!C as in M.H. Seymour, LU TP 93/8 (to appear in Z. Phys. C.).
!C Situations in which R<1 is useful are likely to also be those in
!C which the inclusive reconstruction method is more useful.
!C
!C Also included is a set of routines for doing Lorentz boosts:
!C KTLBST finds the boost matrix to/from the cm frame of a 4-vector
!C KTRROT finds the rotation matrix from one vector to another
!C KTMMUL multiplies together two matrices
!C KTVMUL multiplies a vector by a matrix
!C KTINVT inverts a transformation matrix (nb NOT a general 4 by 4)
!C KTFRAM boosts a list of vectors between two arbitrary frames
!C KTBREI boosts a list of vectors between the lab and Breit frames
!C KTHADR boosts a list of vectors between the lab and hadronic cmf
!C The last two need the momenta in the +z direction of the lepton
!C and hadron beams, and the 4-momentum of the outgoing lepton.
!C
!C The main reference is:
!C S. Catani, Yu.L. Dokshitzer, M.H. Seymour and B.R. Webber,
!C Nucl.Phys.B406(1993)187.
!C The ep version was proposed in:
!C S. Catani, Yu.L. Dokshitzer and B.R. Webber,
!C Phys.Lett.285B(1992)291.
!C The inclusive reconstruction method was proposed in:
!C S.D. Ellis and D.E. Soper,
!C Phys.Rev.D48(1993)3160.
!C
!C-----------------------------------------------------------------------
!C-----------------------------------------------------------------------
!C-----------------------------------------------------------------------
<<KTCLUS: public>>=
public :: ktclur
<<KTCLUS: procedures>>=
SUBROUTINE KTCLUR(IMODE,PP,NN,R,ECUT,Y,*)
use io_units
IMPLICIT NONE
!C---DO CLUSTER ANALYSIS OF PARTICLES IN PP
!C
!C IMODE = INPUT : DESCRIBED ABOVE
!C PP(I,J) = INPUT : 4-MOMENTUM OF Jth PARTICLE: I=1,4 => PX,PY,PZ,E
!C NN = INPUT : NUMBER OF PARTICLES
!C R = INPUT : ELLIS AND SOPER'S R PARAMETER, SEE ABOVE.
!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
!C Y(J) = OUTPUT : VALUE OF Y FOR WHICH EVENT CHANGES FROM BEING
!C J JET TO J-1 JET
!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
!C COULD NOT BE PROCESSED (MOST LIKELY DUE TO TOO MANY PARTICLES)
!C
!C NOTE THAT THE MOMENTA ARE DECLARED DOUBLE PRECISION,
!C AND ALL OTHER FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
!C
INTEGER NMAX,IM,IMODE,TYPE,ANGL,MONO,RECO,N,I,J,NN, &
IMIN,JMIN,KMIN,NUM,HIST,INJET,IABBR,NABBR
PARAMETER (NMAX=512,NABBR=7)
DOUBLE PRECISION PP(4,*)
integer :: u
!CHANGE DOUBLE PRECISION R,ECUT,Y(*),P,KT,ETOT,RSQ,KTP,KTS,KTPAIR,KTSING, &
DOUBLE PRECISION R,ECUT,Y(*),P,KT,ETOT,RSQ,KTP,KTS, &
KTMIN,ETSQ,KTLAST,KTMAX,KTTMP
LOGICAL FIRST
CHARACTER TITLE(4,4)*10
!C---KT RECORDS THE KT**2 OF EACH MERGING.
!C---KTLAST RECORDS FOR EACH MERGING, THE HIGHEST ECUT**2 FOR WHICH THE
!C RESULT IS NOT MERGED WITH THE BEAM (COULD BE LARGER THAN THE
!C KT**2 AT WHICH IT WAS MERGED IF THE KT VALUES ARE NOT MONOTONIC).
!C THIS MAY SOUND POINTLESS, BUT ITS USEFUL FOR DETERMINING WHETHER
!C SUB-JETS SURVIVED TO SCALE Y=YMAC OR NOT.
!C---HIST RECORDS MERGING HISTORY:
!C N=>DELETED TRACK N, M*NMAX+N=>MERGED TRACKS M AND N (M<N).
COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
DIMENSION INJET(NMAX),IABBR(NABBR)
DATA FIRST,TITLE,IABBR/.TRUE., &
'e+e- ','ep ','pe ','pp ', &
'angle ','DeltaR ','f(DeltaR) ','**********', &
'no ','yes ','**********','**********', &
'E ','Pt ','Pt**2 ','**********', &
1111,2111,3111,4111,4211,4212,4223/
!C---CHECK INPUT
IM=IMODE
IF (IM.GE.1.AND.IM.LE.NABBR) IM=IABBR(IM)
TYPE=MOD(IM/1000,10)
ANGL=MOD(IM/100 ,10)
MONO=MOD(IM/10 ,10)
RECO=MOD(IM ,10)
IF (NN.GT.NMAX) CALL KTWARN('KT-MAX',100,*999)
IF (NN.LT.1) CALL KTWARN('KT-LT1',100,*999)
IF (NN.LT.2.AND.TYPE.EQ.1) CALL KTWARN('KT-LT2',100,*999)
IF (TYPE.LT.1.OR.TYPE.GT.4.OR.ANGL.LT.1.OR.ANGL.GT.4.OR. &
MONO.LT.1.OR.MONO.GT.2.OR.RECO.LT.1.OR.RECO.GT.3) CALL KTWARN('KTCLUS',101,*999)
u = given_output_unit ()
IF (FIRST) THEN
WRITE (u,'(/,1X,54(''*'')/A)') &
' KTCLUS: written by Mike Seymour, July 1992.'
WRITE (u,'(A)') &
' Last modified November 2000.'
WRITE (u,'(A)') &
' Please send comments or suggestions to Mike.Seymour@rl.ac.uk'
WRITE (u,'(/A,I2,2A)') &
' Collision type =',TYPE,' = ',TITLE(TYPE,1)
WRITE (u,'(A,I2,2A)') &
' Angular variable =',ANGL,' = ',TITLE(ANGL,2)
WRITE (u,'(A,I2,2A)') &
' Monotonic definition =',MONO,' = ',TITLE(MONO,3)
WRITE (u,'(A,I2,2A)') &
' Recombination scheme =',RECO,' = ',TITLE(RECO,4)
IF (R.NE.1) THEN
WRITE (u,'(A,F5.2)') &
' Radius parameter =',R
IF (TYPE.NE.4) WRITE (u,'(A)') &
' R.NE.1 is strongly discouraged for this collision type!'
ENDIF
WRITE (u,'(1X,54(''*'')/)')
FIRST=.FALSE.
ENDIF
!C---COPY PP TO P
N=NN
NUM=NN
CALL KTCOPY(PP,N,P,(RECO.NE.1))
ETOT=0
DO I=1,N
ETOT=ETOT+P(4,I)
END DO
IF (ETOT.EQ.0) CALL KTWARN('KTCLUS',102,*999)
IF (ECUT.EQ.0) THEN
ETSQ=1/ETOT**2
ELSE
ETSQ=1/ECUT**2
ENDIF
RSQ=R**2
!C---CALCULATE ALL PAIR KT's
DO I=1,N-1
DO J=I+1,N
KTP(J,I)=-1
KTP(I,J)=KTPAIR(ANGL,P(1,I),P(1,J),KTP(J,I))
END DO
END DO
!C---CALCULATE ALL SINGLE KT's
DO I=1,N
KTS(I)=KTSING(ANGL,TYPE,P(1,I))
END DO
KTMAX=0
!C---MAIN LOOP
300 CONTINUE
!C---FIND MINIMUM MEMBER OF KTP
CALL KTPMIN(KTP,NMAX,N,IMIN,JMIN)
!C---FIND MINIMUM MEMBER OF KTS
CALL KTSMIN(KTS,NMAX,N,KMIN)
!C---STORE Y VALUE OF TRANSITION FROM N TO N-1 JETS
KTMIN=KTP(IMIN,JMIN)
KTTMP=RSQ*KTS(KMIN)
IF ((TYPE.GE.2.AND.TYPE.LE.4).AND. &
(KTTMP.LE.KTMIN.OR.N.EQ.1)) &
KTMIN=KTTMP
KT(N)=KTMIN
Y(N)=KT(N)*ETSQ
!C---IF MONO.GT.1, SEQUENCE IS SUPPOSED TO BE MONOTONIC, IF NOT, WARN
IF (KTMIN.LT.KTMAX.AND.MONO.GT.1) CALL KTWARN('KTCLUS',1,*999)
IF (KTMIN.GE.KTMAX) KTMAX=KTMIN
!C---IF LOWEST KT IS TO A BEAM, THROW IT AWAY AND MOVE LAST ENTRY UP
IF (KTMIN.EQ.KTTMP) THEN
CALL KTMOVE(P,KTP,KTS,NMAX,N,KMIN,1)
!C---UPDATE HISTORY AND CROSS-REFERENCES
HIST(N)=KMIN
INJET(N)=KMIN
DO I=N,NN
IF (INJET(I).EQ.KMIN) THEN
KTLAST(I)=KTMAX
INJET(I)=0
ELSEIF (INJET(I).EQ.N) THEN
INJET(I)=KMIN
ENDIF
END DO
!C---OTHERWISE MERGE JETS IMIN AND JMIN AND MOVE LAST ENTRY UP
ELSE
CALL KTMERG(P,KTP,KTS,NMAX,IMIN,JMIN,N,TYPE,ANGL,MONO,RECO)
CALL KTMOVE(P,KTP,KTS,NMAX,N,JMIN,1)
!C---UPDATE HISTORY AND CROSS-REFERENCES
HIST(N)=IMIN*NMAX+JMIN
INJET(N)=IMIN
DO I=N,NN
IF (INJET(I).EQ.JMIN) THEN
INJET(I)=IMIN
ELSEIF (INJET(I).EQ.N) THEN
INJET(I)=JMIN
ENDIF
END DO
ENDIF
!C---THATS ALL THERE IS TO IT
N=N-1
IF (N.GT.1 .OR. N.GT.0.AND.(TYPE.GE.2.AND.TYPE.LE.4)) GOTO 300
IF (N.EQ.1) THEN
KT(N)=1D20
Y(N)=KT(N)*ETSQ
ENDIF
RETURN
999 RETURN 1
END SUBROUTINE KTCLUR
!C-----------------------------------------------------------------------
<<KTCLUS: public>>=
public :: ktreco
<<KTCLUS: procedures>>=
!C-----------------------------------------------------------------------
SUBROUTINE KTRECO(RECO,PP,NN,ECUT,YCUT,YMAC,PJET,JET,NJET,NSUB,*)
IMPLICIT NONE
!C---RECONSTRUCT KINEMATICS OF JET SYSTEM, WHICH HAS ALREADY BEEN
!C ANALYSED BY KTCLUS. NOTE THAT NO CONSISTENCY CHECK IS MADE: USER
!C IS TRUSTED TO USE THE SAME PP VALUES AS FOR KTCLUS
!C
!C RECO = INPUT : RECOMBINATION SCHEME (NEED NOT BE SAME AS KTCLUS)
!C PP(I,J) = INPUT : 4-MOMENTUM OF Jth PARTICLE: I=1,4 => PX,PY,PZ,E
!C NN = INPUT : NUMBER OF PARTICLES
!C ECUT = INPUT : DENOMINATOR OF KT MEASURE. IF ZERO, ETOT IS USED
!C YCUT = INPUT : Y VALUE AT WHICH TO RECONSTRUCT JET MOMENTA
!C YMAC = INPUT : Y VALUE USED TO DEFINE MACRO-JETS, TO DETERMINE
!C WHICH JETS ARE SUB-JETS
!C PJET(I,J)=OUTPUT : 4-MOMENTUM OF Jth JET AT SCALE YCUT
!C JET(J) =OUTPUT : THE MACRO-JET WHICH CONTAINS THE Jth JET,
!C SET TO ZERO IF JET IS NOT A SUB-JET
!C NJET =OUTPUT : THE NUMBER OF JETS
!C NSUB =OUTPUT : THE NUMBER OF SUB-JETS (EQUAL TO THE NUMBER OF
!C NON-ZERO ENTRIES IN JET())
!C LAST ARGUMENT IS LABEL TO JUMP TO IF FOR ANY REASON THE EVENT
!C COULD NOT BE PROCESSED
!C
!C NOTE THAT THE MOMENTA ARE DECLARED DOUBLE PRECISION,
!C AND ALL OTHER FLOATING POINT VARIABLES ARE DECLARED DOUBLE PRECISION
!C
INTEGER NMAX,RECO,NUM,N,NN,NJET,NSUB,JET(*),HIST,IMIN,JMIN,I,J
PARAMETER (NMAX=512)
DOUBLE PRECISION PP(4,*),PJET(4,*)
DOUBLE PRECISION ECUT,P,KT,KTP,KTS,ETOT,RSQ,ETSQ,YCUT,YMAC,KTLAST, &
ROUND
PARAMETER (ROUND=0.99999D0)
COMMON /KTCOMM/ETOT,RSQ,P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX), &
KT(NMAX),KTLAST(NMAX),HIST(NMAX),NUM
!C---CHECK INPUT
IF (RECO.LT.1.OR.RECO.GT.3) THEN
PRINT *,'RECO=',RECO
CALL KTWARN('KTRECO',100,*999)
ENDIF
!C---COPY PP TO P
N=NN
IF (NUM.NE.NN) CALL KTWARN('KTRECO',101,*999)
CALL KTCOPY(PP,N,P,(RECO.NE.1))
IF (ECUT.EQ.0) THEN
ETSQ=1/ETOT**2
ELSE
ETSQ=1/ECUT**2
ENDIF
!C---KEEP MERGING UNTIL YCUT
100 IF (ETSQ*KT(N).LT.ROUND*YCUT) THEN
IF (HIST(N).LE.NMAX) THEN
CALL KTMOVE(P,KTP,KTS,NMAX,N,HIST(N),0)
ELSE
IMIN=HIST(N)/NMAX
JMIN=HIST(N)-IMIN*NMAX
CALL KTMERG(P,KTP,KTS,NMAX,IMIN,JMIN,N,0,0,0,RECO)
CALL KTMOVE(P,KTP,KTS,NMAX,N,JMIN,0)
ENDIF
N=N-1
IF (N.GT.0) GOTO 100
ENDIF
!C---IF YCUT IS TOO LARGE THERE ARE NO JETS
NJET=N
NSUB=N
IF (N.EQ.0) RETURN
!C---SET UP OUTPUT MOMENTA
DO I=1,NJET
IF (RECO.EQ.1) THEN
DO J=1,4
PJET(J,I)=P(J,I)
END DO
ELSE
PJET(1,I)=P(6,I)*COS(P(8,I))
PJET(2,I)=P(6,I)*SIN(P(8,I))
PJET(3,I)=P(6,I)*SINH(P(7,I))
PJET(4,I)=P(6,I)*COSH(P(7,I))
ENDIF
JET(I)=I
END DO
!C---KEEP MERGING UNTIL YMAC TO FIND THE FATE OF EACH JET
300 IF (ETSQ*KT(N).LT.ROUND*YMAC) THEN
IF (HIST(N).LE.NMAX) THEN
IMIN=0
JMIN=HIST(N)
NSUB=NSUB-1
ELSE
IMIN=HIST(N)/NMAX
JMIN=HIST(N)-IMIN*NMAX
IF (ETSQ*KTLAST(N).LT.ROUND*YMAC) NSUB=NSUB-1
ENDIF
DO I=1,NJET
IF (JET(I).EQ.JMIN) JET(I)=IMIN
IF (JET(I).EQ.N) JET(I)=JMIN
END DO
N=N-1
IF (N.GT.0) GOTO 300
ENDIF
RETURN
999 RETURN 1
END SUBROUTINE KTRECO
!C-----------------------------------------------------------------------
<<KTCLUS: procedures>>=
!C-----------------------------------------------------------------------
FUNCTION KTPAIR(ANGL,P,Q,ANGLE)
IMPLICIT NONE
!C---CALCULATE LOCAL KT OF PAIR, USING ANGULAR SCHEME:
!C 1=>ANGULAR, 2=>DeltaR, 3=>f(DeltaEta,DeltaPhi)
!C WHERE f(eta,phi)=2(COSH(eta)-COS(phi)) IS THE QCD EMISSION METRIC
!C---IF ANGLE<0, IT IS SET TO THE ANGULAR PART OF THE LOCAL KT ON RETURN
!C IF ANGLE>0, IT IS USED INSTEAD OF THE ANGULAR PART OF THE LOCAL KT
INTEGER ANGL
! CHANGE DOUBLE PRECISION P(9),Q(9),KTPAIR,R,KTMDPI,ANGLE,ETA,PHI,ESQ
DOUBLE PRECISION P(9),Q(9),KTPAIR,R,ANGLE,ETA,PHI,ESQ
!C---COMPONENTS OF MOMENTA ARE PX,PY,PZ,E,1/P,PT,ETA,PHI,PT**2
R=ANGLE
IF (ANGL.EQ.1) THEN
IF (R.LE.0) R=2*(1-(P(1)*Q(1)+P(2)*Q(2)+P(3)*Q(3))*(P(5)*Q(5)))
ESQ=MIN(P(4),Q(4))**2
ELSEIF (ANGL.EQ.2.OR.ANGL.EQ.3) THEN
IF (R.LE.0) THEN
ETA=P(7)-Q(7)
PHI=KTMDPI(P(8)-Q(8))
IF (ANGL.EQ.2) THEN
R=ETA**2+PHI**2
ELSE
R=2*(COSH(ETA)-COS(PHI))
ENDIF
ENDIF
ESQ=MIN(P(9),Q(9))
ELSEIF (ANGL.EQ.4) THEN
ESQ=(1d0/(P(5)*Q(5))-P(1)*Q(1)-P(2)*Q(2)- &
P(3)*Q(3))*2D0/(P(5)*Q(5))/(0.0001D0+1d0/P(5)+1d0/Q(5))**2
R=1d0
ELSE
CALL KTWARN('KTPAIR',200,*999)
STOP
ENDIF
KTPAIR=ESQ*R
IF (ANGLE.LT.0) ANGLE=R
999 END FUNCTION KTPAIR
!C-----------------------------------------------------------------------
FUNCTION KTSING(ANGL,TYPE,P)
IMPLICIT NONE
!C---CALCULATE KT OF PARTICLE, USING ANGULAR SCHEME:
!C 1=>ANGULAR, 2=>DeltaR, 3=>f(DeltaEta,DeltaPhi)
!C---TYPE=1 FOR E+E-, 2 FOR EP, 3 FOR PE, 4 FOR PP
!C FOR EP, PROTON DIRECTION IS DEFINED AS -Z
!C FOR PE, PROTON DIRECTION IS DEFINED AS +Z
INTEGER ANGL,TYPE
DOUBLE PRECISION P(9),KTSING,COSTH,R,SMALL
DATA SMALL/1D-4/
IF (ANGL.EQ.1.OR.ANGL.EQ.4) THEN
COSTH=P(3)*P(5)
IF (TYPE.EQ.2) THEN
COSTH=-COSTH
ELSEIF (TYPE.EQ.4) THEN
COSTH=ABS(COSTH)
ELSEIF (TYPE.NE.1.AND.TYPE.NE.3) THEN
CALL KTWARN('KTSING',200,*999)
STOP
ENDIF
R=2*(1-COSTH)
!C---IF CLOSE TO BEAM, USE APPROX 2*(1-COS(THETA))=SIN**2(THETA)
IF (R.LT.SMALL) R=(P(1)**2+P(2)**2)*P(5)**2
KTSING=P(4)**2*R
ELSEIF (ANGL.EQ.2.OR.ANGL.EQ.3) THEN
KTSING=P(9)
ELSE
CALL KTWARN('KTSING',201,*999)
STOP
ENDIF
999 END FUNCTION KTSING
!C-----------------------------------------------------------------------
SUBROUTINE KTPMIN(A,NMAX,N,IMIN,JMIN)
IMPLICIT NONE
!C---FIND THE MINIMUM MEMBER OF A(NMAX,NMAX) WITH IMIN < JMIN <= N
INTEGER NMAX,N,IMIN,JMIN,KMIN,I,J,K
!C---REMEMBER THAT A(X+(Y-1)*NMAX)=A(X,Y)
!C THESE LOOPING VARIABLES ARE J=Y-2, I=X+(Y-1)*NMAX
DOUBLE PRECISION A(*),AMIN
K=1+NMAX
KMIN=K
AMIN=A(KMIN)
DO J=0,N-2
DO I=K,K+J
IF (A(I).LT.AMIN) THEN
KMIN=I
AMIN=A(KMIN)
ENDIF
END DO
K=K+NMAX
END DO
JMIN=KMIN/NMAX+1
IMIN=KMIN-(JMIN-1)*NMAX
END SUBROUTINE KTPMIN
!C-----------------------------------------------------------------------
SUBROUTINE KTSMIN(A,NMAX,N,IMIN)
IMPLICIT NONE
!C---FIND THE MINIMUM MEMBER OF A
INTEGER N,NMAX,IMIN,I
DOUBLE PRECISION A(NMAX)
IMIN=1
DO I=1,N
IF (A(I).LT.A(IMIN)) IMIN=I
END DO
END SUBROUTINE KTSMIN
!C-----------------------------------------------------------------------
SUBROUTINE KTCOPY(A,N,B,ONSHLL)
IMPLICIT NONE
!C---COPY FROM A TO B. 5TH=1/(3-MTM), 6TH=PT, 7TH=ETA, 8TH=PHI, 9TH=PT**2
!C IF ONSHLL IS .TRUE. PARTICLE ENTRIES ARE PUT ON-SHELL BY SETTING E=P
INTEGER I,N
DOUBLE PRECISION A(4,N)
LOGICAL ONSHLL
DOUBLE PRECISION B(9,N),ETAMAX,SINMIN,EPS
DATA ETAMAX,SINMIN,EPS/10,0,1D-6/
!C---SINMIN GETS CALCULATED ON FIRST CALL
IF (SINMIN.EQ.0) SINMIN=1/COSH(ETAMAX)
DO I=1,N
B(1,I)=A(1,I)
B(2,I)=A(2,I)
B(3,I)=A(3,I)
B(4,I)=A(4,I)
B(5,I)=SQRT(A(1,I)**2+A(2,I)**2+A(3,I)**2)
IF (ONSHLL) B(4,I)=B(5,I)
IF (B(5,I).EQ.0) B(5,I)=1D-10
B(5,I)=1/B(5,I)
B(9,I)=A(1,I)**2+A(2,I)**2
B(6,I)=SQRT(B(9,I))
B(7,I)=B(6,I)*B(5,I)
IF (B(7,I).GT.SINMIN) THEN
B(7,I)=A(4,I)**2-A(3,I)**2
IF (B(7,I).LE.EPS*B(4,I)**2.OR.ONSHLL) B(7,I)=B(9,I)
B(7,I)=LOG((B(4,I)+ABS(B(3,I)))**2/B(7,I))/2
ELSE
B(7,I)=ETAMAX+2
ENDIF
B(7,I)=SIGN(B(7,I),B(3,I))
IF (A(1,I).EQ.0 .AND. A(2,I).EQ.0) THEN
B(8,I)=0
ELSE
B(8,I)=ATAN2(A(2,I),A(1,I))
ENDIF
END DO
END SUBROUTINE KTCOPY
!C-----------------------------------------------------------------------
SUBROUTINE KTMERG(P,KTP,KTS,NMAX,I,J,N,TYPE,ANGL,MONO,RECO)
IMPLICIT NONE
!C---MERGE THE Jth PARTICLE IN P INTO THE Ith PARTICLE
!C J IS ASSUMED GREATER THAN I. P CONTAINS N PARTICLES BEFORE MERGING.
!C---ALSO RECALCULATING THE CORRESPONDING KTP AND KTS VALUES IF MONO.GT.0
!C FROM THE RECOMBINED ANGULAR MEASURES IF MONO.GT.1
!C---NOTE THAT IF MONO.LE.0, TYPE AND ANGL ARE NOT USED
INTEGER ANGL,RECO,TYPE,I,J,K,N,NMAX,MONO
DOUBLE PRECISION P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX),PT,PTT, &
! CHANGE KTMDPI,KTUP,PI,PJ,ANG,KTPAIR,KTSING,ETAMAX,EPS
KTUP,PI,PJ,ANG,ETAMAX,EPS
KTUP(I,J)=KTP(MAX(I,J),MIN(I,J))
DATA ETAMAX,EPS/10,1D-6/
IF (J.LE.I) CALL KTWARN('KTMERG',200,*999)
!C---COMBINE ANGULAR MEASURES IF NECESSARY
IF (MONO.GT.1) THEN
DO K=1,N
IF (K.NE.I.AND.K.NE.J) THEN
IF (RECO.EQ.1) THEN
PI=P(4,I)
PJ=P(4,J)
ELSEIF (RECO.EQ.2) THEN
PI=P(6,I)
PJ=P(6,J)
ELSEIF (RECO.EQ.3) THEN
PI=P(9,I)
PJ=P(9,J)
ELSE
CALL KTWARN('KTMERG',201,*999)
STOP
ENDIF
IF (PI.EQ.0.AND.PJ.EQ.0) THEN
PI=1
PJ=1
ENDIF
KTP(MAX(I,K),MIN(I,K))= &
(PI*KTUP(I,K)+PJ*KTUP(J,K))/(PI+PJ)
ENDIF
END DO
ENDIF
IF (RECO.EQ.1) THEN
!C---VECTOR ADDITION
P(1,I)=P(1,I)+P(1,J)
P(2,I)=P(2,I)+P(2,J)
P(3,I)=P(3,I)+P(3,J)
!c P(4,I)=P(4,I)+P(4,J) ! JA
P(5,I)=SQRT(P(1,I)**2+P(2,I)**2+P(3,I)**2)
P(4,I)=P(5,I) ! JA (Massless scheme)
IF (P(5,I).EQ.0) THEN
P(5,I)=1
ELSE
P(5,I)=1/P(5,I)
ENDIF
ELSEIF (RECO.EQ.2) THEN
!C---PT WEIGHTED ETA-PHI ADDITION
PT=P(6,I)+P(6,J)
IF (PT.EQ.0) THEN
PTT=1
ELSE
PTT=1/PT
ENDIF
P(7,I)=(P(6,I)*P(7,I)+P(6,J)*P(7,J))*PTT
P(8,I)=KTMDPI(P(8,I)+P(6,J)*PTT*KTMDPI(P(8,J)-P(8,I)))
P(6,I)=PT
P(9,I)=PT**2
ELSEIF (RECO.EQ.3) THEN
!C---PT**2 WEIGHTED ETA-PHI ADDITION
PT=P(9,I)+P(9,J)
IF (PT.EQ.0) THEN
PTT=1
ELSE
PTT=1/PT
ENDIF
P(7,I)=(P(9,I)*P(7,I)+P(9,J)*P(7,J))*PTT
P(8,I)=KTMDPI(P(8,I)+P(9,J)*PTT*KTMDPI(P(8,J)-P(8,I)))
P(6,I)=P(6,I)+P(6,J)
P(9,I)=P(6,I)**2
ELSE
CALL KTWARN('KTMERG',202,*999)
STOP
ENDIF
!C---IF MONO.GT.0 CALCULATE NEW KT MEASURES. IF MONO.GT.1 USE ANGULAR ONES.
IF (MONO.LE.0) RETURN
!C---CONVERTING BETWEEN 4-MTM AND PT,ETA,PHI IF NECESSARY
IF (ANGL.NE.1.AND.RECO.EQ.1) THEN
P(9,I)=P(1,I)**2+P(2,I)**2
P(7,I)=P(4,I)**2-P(3,I)**2
IF (P(7,I).LE.EPS*P(4,I)**2) P(7,I)=P(9,I)
IF (P(7,I).GT.0) THEN
P(7,I)=LOG((P(4,I)+ABS(P(3,I)))**2/P(7,I))/2
IF (P(7,I).GT.ETAMAX) P(7,I)=ETAMAX+2
ELSE
P(7,I)=ETAMAX+2
ENDIF
P(7,I)=SIGN(P(7,I),P(3,I))
IF (P(1,I).NE.0.AND.P(2,I).NE.0) THEN
P(8,I)=ATAN2(P(2,I),P(1,I))
ELSE
P(8,I)=0
ENDIF
ELSEIF (ANGL.EQ.1.AND.RECO.NE.1) THEN
P(1,I)=P(6,I)*COS(P(8,I))
P(2,I)=P(6,I)*SIN(P(8,I))
P(3,I)=P(6,I)*SINH(P(7,I))
P(4,I)=P(6,I)*COSH(P(7,I))
IF (P(4,I).NE.0) THEN
P(5,I)=1/P(4,I)
ELSE
P(5,I)=1
ENDIF
ENDIF
ANG=0
DO K=1,N
IF (K.NE.I.AND.K.NE.J) THEN
IF (MONO.GT.1) ANG=KTUP(I,K)
KTP(MIN(I,K),MAX(I,K))= &
KTPAIR(ANGL,P(1,I),P(1,K),ANG)
ENDIF
END DO
KTS(I)=KTSING(ANGL,TYPE,P(1,I))
999 END SUBROUTINE KTMERG
!C-----------------------------------------------------------------------
SUBROUTINE KTMOVE(P,KTP,KTS,NMAX,N,J,IOPT)
IMPLICIT NONE
!C---MOVE THE Nth PARTICLE IN P TO THE Jth POSITION
!C---ALSO MOVING KTP AND KTS IF IOPT.GT.0
INTEGER I,J,N,NMAX,IOPT
DOUBLE PRECISION P(9,NMAX),KTP(NMAX,NMAX),KTS(NMAX)
DO I=1,9
P(I,J)=P(I,N)
END DO
IF (IOPT.LE.0) RETURN
DO I=1,J-1
KTP(I,J)=KTP(I,N)
KTP(J,I)=KTP(N,I)
END DO
DO I=J+1,N-1
KTP(J,I)=KTP(I,N)
KTP(I,J)=KTP(N,I)
END DO
KTS(J)=KTS(N)
END SUBROUTINE KTMOVE
!C-----------------------------------------------------------------------
<<KTCLUS: procedures>>=
FUNCTION KTMDPI(PHI)
IMPLICIT NONE
!C---RETURNS PHI, MOVED ONTO THE RANGE [-PI,PI)
DOUBLE PRECISION KTMDPI,PHI,PI,TWOPI,THRPI,EPS
PARAMETER (PI=3.14159265358979324D0,TWOPI=6.28318530717958648D0, &
THRPI=9.42477796076937972D0)
PARAMETER (EPS=1D-15)
KTMDPI=PHI
IF (KTMDPI.LE.PI) THEN
IF (KTMDPI.GT.-PI) THEN
GOTO 100
ELSEIF (KTMDPI.GT.-THRPI) THEN
KTMDPI=KTMDPI+TWOPI
ELSE
KTMDPI=-MOD(PI-KTMDPI,TWOPI)+PI
ENDIF
ELSEIF (KTMDPI.LE.THRPI) THEN
KTMDPI=KTMDPI-TWOPI
ELSE
KTMDPI=MOD(PI+KTMDPI,TWOPI)-PI
ENDIF
100 IF (ABS(KTMDPI).LT.EPS) KTMDPI=0
END FUNCTION KTMDPI
!C-----------------------------------------------------------------------
SUBROUTINE KTWARN(SUBRTN,ICODE,*)
!C DEALS WITH ERRORS DURING EXECUTION
!C SUBRTN = NAME OF CALLING SUBROUTINE
!C ICODE = ERROR CODE: - 99 PRINT WARNING & CONTINUE
!C 100-199 PRINT WARNING & JUMP
!C 200- PRINT WARNING & STOP DEAD
!C-----------------------------------------------------------------------
INTEGER ICODE
CHARACTER(len=6) SUBRTN
WRITE (6,10) SUBRTN,ICODE
10 FORMAT(/' KTWARN CALLED FROM SUBPROGRAM ',A6,': CODE =',I4/)
IF (ICODE.LT.100) RETURN
IF (ICODE.LT.200) RETURN 1
STOP
END SUBROUTINE KTWARN
!C-----------------------------------------------------------------------
!C-----------------------------------------------------------------------
!C-----------------------------------------------------------------------
@ %def ktclus ktclur ktycut ktysub
@ %def ktbeam ktjoin ktreco ktincl
@ %def ktisub ktijoi ktirec ktwich
@ %def ktwchs ktfram ktbrei kthadr
@ %def ktpair ktsing ktpmin ktsmin
@ %def ktcopy ktmerg ktmove ktunit
@ %def ktlbst ktrrot ktvmul ktmmul
@ %def ktinvt ktmdpi ktwarn

File Metadata

Mime Type
text/x-diff
Expires
Tue, Nov 19, 4:53 PM (1 d, 12 h)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
3805257
Default Alt Text
(858 KB)

Event Timeline