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]]>>= <> module event_base <> use kinds, only: i64 <> use io_units use string_utils, only: lower_case use diagnostics use model_data use particles <> <> <> <> <> contains <> end module event_base @ %def event_base @ \subsection{generic event type} <>= public :: generic_event_t <>= 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 <> end type generic_event_t @ %def generic_event_t @ \subsection{Initialization} This determines the number of alternate weights and sqme values. <>= procedure :: base_init => generic_event_init <>= 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. <>= 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 <>= 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: <>= procedure :: get_particle_set_ptr => generic_event_get_particle_set_ptr <>= 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: <>= procedure :: link_particle_set => generic_event_link_particle_set <>= 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. <>= 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 <>= 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 @ <>= procedure :: get_n_alt => generic_event_get_n_alt <>= 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 @ <>= 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 <>= 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 @ <>= 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 <>= 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. <>= procedure :: set => generic_event_set <>= 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). <>= procedure (generic_event_write), deferred :: write <>= 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. <>= procedure (generic_event_generate), deferred :: generate <>= 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. <>= procedure (generic_event_set_hard_particle_set), deferred :: & set_hard_particle_set <>= 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. <>= procedure (generic_event_set_index), deferred :: set_index procedure (generic_event_handler), deferred :: reset_index procedure (generic_event_increment_index), deferred :: increment_index @ <>= 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. <>= procedure (generic_event_handler), deferred :: evaluate_expressions @ Select internal parameters <>= procedure (generic_event_select), deferred :: select <>= 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. <>= procedure (generic_event_get_model_ptr), deferred :: get_model_ptr <>= 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. <>= 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 <>= 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. <>= procedure (generic_event_set_alpha_qcd_forced), deferred :: & set_alpha_qcd_forced procedure (generic_event_set_scale_forced), deferred :: & set_scale_forced <>= 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. <>= procedure :: reset_contents => generic_event_reset_contents procedure :: base_reset_contents => generic_event_reset_contents <>= 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. <>= procedure :: pacify_particle_set => generic_event_pacify_particle_set <>= 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. <>= 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. <>= public :: event_normalization_mode public :: event_normalization_string <>= 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. <>= public :: event_normalization_update <>= 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. <>= public :: event_callback_t <>= 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 <>= 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. <>= 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. <>= public :: event_callback_nop_t <>= 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 <>= 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]]>>= <> module eio_data <> <> use io_units use numeric_utils use diagnostics use event_base <> <> <> contains <> 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. <>= public :: event_sample_data_t <>= 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 <> end type event_sample_data_t @ %def event_sample_data_t @ Initialize: allocate for the number of processes <>= procedure :: init => event_sample_data_init <>= 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. <>= procedure :: write => event_sample_data_write <>= 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]]>>= <> module eio_data_ut use unit_tests use eio_data_uti <> <> contains <> end module eio_data_ut @ %def eio_data_ut @ <<[[eio_data_uti.f90]]>>= <> module eio_data_uti <> <> use event_base use eio_data <> <> contains <> end module eio_data_uti @ %def eio_data_ut @ API: driver for the unit tests below. <>= public :: eio_data_test <>= subroutine eio_data_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_data_test @ %def eio_data_test @ \subsubsection{Event Sample Data} Print the contents of a sample data block. <>= call test (eio_data_1, "eio_data_1", & "event sample data", & u, results) <>= public :: eio_data_1 <>= 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. <>= call test (eio_data_2, "eio_data_2", & "event normalization", & u, results) <>= public :: eio_data_2 <>= 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]]>>= <> module eio_base use kinds, only: i64 <> use io_units use diagnostics use model_data use event_base use eio_data <> <> <> <> contains <> 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. <>= public :: eio_t <>= 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 <> 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. <>= procedure (eio_write), deferred :: write <>= 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. <>= procedure (eio_final), deferred :: final <>= 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. <>= procedure :: set_splitting => eio_set_splitting <>= 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. <>= procedure :: update_split_count => eio_update_split_count <>= 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. <>= procedure :: set_filename => eio_set_filename <>= 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. <>= procedure :: set_fallback_model => eio_set_fallback_model <>= 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. <>= procedure (eio_init_out), deferred :: init_out <>= 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. <>= procedure (eio_init_in), deferred :: init_in <>= 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. <>= procedure (eio_switch_inout), deferred :: switch_inout <>= 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. <>= procedure :: split_out => eio_split_out <>= 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. <>= procedure :: file_size_kbytes => eio_file_size_kbytes <>= 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. <>= procedure (eio_output), deferred :: output <>= 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. <>= procedure (eio_input_i_prc), deferred :: input_i_prc procedure (eio_input_event), deferred :: input_event <>= 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 @ <>= procedure (eio_skip), deferred :: skip <>= 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]]>>= <> module eio_base_ut use unit_tests use eio_base_uti <> <> <> contains <> end module eio_base_ut @ %def eio_base_ut @ <<[[eio_base_uti.f90]]>>= <> module eio_base_uti <> <> use io_units use lorentz use model_data use particles use event_base use eio_data use eio_base <> <> <> <> <> contains <> <> end module eio_base_uti @ %def eio_base_ut @ API: driver for the unit tests below. <>= public :: eio_base_test <>= subroutine eio_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> 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. <>= 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. <>= public :: eio_prepare_test, eio_cleanup_test <>= 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: <>= 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 <>= public :: eio_prepare_fallback_model, eio_cleanup_fallback_model <>= 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. <>= 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 <> end type eio_test_t @ %def eio_test_t @ Write to screen. Pretend that this is an actual event format. <>= procedure :: write => eio_test_write <>= 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. <>= procedure :: final => eio_test_final <>= 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. <>= procedure :: init_out => eio_test_init_out <>= 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. <>= procedure :: init_in => eio_test_init_in <>= 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. <>= procedure :: switch_inout => eio_test_switch_inout <>= 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. <>= procedure :: output => eio_test_output <>= 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. <>= procedure :: input_i_prc => eio_test_input_i_prc procedure :: input_event => eio_test_input_event <>= 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 @ <>= procedure :: skip => eio_test_skip <>= 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} <>= call test (eio_base_1, "eio_base_1", & "read and write event contents", & u, results) <>= public :: eio_base_1 <>= 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]]>>= <> module eio_direct <> <> 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 <> <> <> contains <> end module eio_direct @ %def eio_direct @ \subsection{Type} <>= public :: eio_direct_t <>= 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 <> end type eio_direct_t @ %def eio_direct_t @ \subsection{Common Methods} Output. <>= procedure :: write => eio_direct_write <>= 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. <>= procedure :: final => eio_direct_final <>= 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 <>= procedure :: init_out => eio_direct_init_out <>= 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 @ <>= procedure :: init_in => eio_direct_init_in <>= 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 <>= procedure :: switch_inout => eio_direct_switch_inout <>= 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. <>= procedure :: output => eio_direct_output <>= 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. <>= procedure :: input_i_prc => eio_direct_input_i_prc procedure :: input_event => eio_direct_input_event <>= 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. <>= procedure :: skip => eio_direct_skip <>= 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} <>= 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 <>= 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. <>= procedure :: get_momentum_array => eio_direct_get_momentum_array <>= 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. <>= procedure :: init_direct => eio_direct_init_direct <>= 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. <>= procedure :: set_event_index => eio_direct_set_event_index procedure :: reset_event_index => eio_direct_reset_event_index <>= 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. <>= procedure :: set_selection_indices => eio_direct_set_selection_indices <>= 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). <>= 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 <>= 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]]>>= <> module eio_direct_ut use unit_tests use eio_direct_uti <> <> contains <> end module eio_direct_ut @ %def eio_direct_ut @ <<[[eio_direct_uti.f90]]>>= <> module eio_direct_uti <> <> 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 <> <> contains <> end module eio_direct_uti @ %def eio_direct_ut @ API: driver for the unit tests below. <>= public :: eio_direct_test <>= subroutine eio_direct_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_direct_test @ %def eio_direct_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_direct_1, "eio_direct_1", & "read and write event contents", & u, results) <>= public :: eio_direct_1 <>= 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]]>>= <> module eio_checkpoints <> use io_units use diagnostics use cputime use event_base use eio_data use eio_base <> <> <> <> contains <> end module eio_checkpoints @ %def eio_checkpoints @ \subsection{Type} <>= public :: eio_checkpoints_t <>= 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 <> end type eio_checkpoints_t @ %def eio_checkpoints_t @ \subsection{Specific Methods} Set parameters that are specifically used for checkpointing. <>= procedure :: set_parameters => eio_checkpoints_set_parameters <>= 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. <>= procedure :: write => eio_checkpoints_write <>= 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. <>= procedure :: final => eio_checkpoints_final <>= 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. <>= procedure :: init_out => eio_checkpoints_init_out <>= 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. <>= procedure :: init_in => eio_checkpoints_init_in <>= 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. <>= procedure :: switch_inout => eio_checkpoints_switch_inout <>= 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. <>= procedure :: output => eio_checkpoints_output <>= 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. <>= procedure :: startup => eio_checkpoints_startup <>= 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. <>= procedure :: message => eio_checkpoints_message <>= 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. <>= procedure :: shutdown => eio_checkpoints_shutdown <>= 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 <>= procedure :: input_i_prc => eio_checkpoints_input_i_prc procedure :: input_event => eio_checkpoints_input_event <>= 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 @ <>= procedure :: skip => eio_checkpoints_skip <>= 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} <>= 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]]>>= <> module eio_checkpoints_ut use unit_tests use eio_checkpoints_uti <> <> contains <> end module eio_checkpoints_ut @ %def eio_checkpoints_ut @ <<[[eio_checkpoints_uti.f90]]>>= <> module eio_checkpoints_uti <> <> use event_base use eio_data use eio_base use eio_checkpoints use eio_base_ut, only: eio_prepare_test, eio_cleanup_test <> <> contains <> end module eio_checkpoints_uti @ %def eio_checkpoints_ut @ API: driver for the unit tests below. <>= public :: eio_checkpoints_test <>= subroutine eio_checkpoints_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_checkpoints_test @ %def eio_checkpoints_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_checkpoints_1, "eio_checkpoints_1", & "read and write event contents", & u, results) <>= public :: eio_checkpoints_1 <>= 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]]>>= <> module eio_callback use kinds, only: i64 <> use io_units use diagnostics use cputime use event_base use eio_data use eio_base <> <> <> contains <> end module eio_callback @ %def eio_callback @ \subsection{Type} <>= public :: eio_callback_t <>= 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 <> 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). <>= procedure :: set_parameters => eio_callback_set_parameters <>= 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. <>= procedure :: write => eio_callback_write <>= 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. <>= procedure :: final => eio_callback_final <>= 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. <>= procedure :: init_out => eio_callback_init_out <>= 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. <>= procedure :: init_in => eio_callback_init_in <>= 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. <>= procedure :: switch_inout => eio_callback_switch_inout <>= 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. <>= procedure :: output => eio_callback_output <>= 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. <>= procedure :: input_i_prc => eio_callback_input_i_prc procedure :: input_event => eio_callback_input_event <>= 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 @ <>= procedure :: skip => eio_callback_skip <>= 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]]>>= <> module eio_weights <> <> use io_units use diagnostics use event_base use eio_data use eio_base <> <> <> contains <> end module eio_weights @ %def eio_weights @ \subsection{Type} <>= public :: eio_weights_t <>= type, extends (eio_t) :: eio_weights_t logical :: writing = .false. integer :: unit = 0 logical :: pacify = .false. contains <> end type eio_weights_t @ %def eio_weights_t @ \subsection{Specific Methods} Set pacify flags. <>= procedure :: set_parameters => eio_weights_set_parameters <>= 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. <>= procedure :: write => eio_weights_write <>= 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. <>= procedure :: final => eio_weights_final <>= 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. <>= procedure :: init_out => eio_weights_init_out <>= 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. <>= procedure :: init_in => eio_weights_init_in <>= 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. <>= procedure :: switch_inout => eio_weights_switch_inout <>= 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. <>= procedure :: output => eio_weights_output <>= 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. <>= procedure :: input_i_prc => eio_weights_input_i_prc procedure :: input_event => eio_weights_input_event <>= 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 @ <>= procedure :: skip => eio_weights_skip <>= 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]]>>= <> module eio_weights_ut use unit_tests use eio_weights_uti <> <> contains <> end module eio_weights_ut @ %def eio_weights_ut @ <<[[eio_weights_uti.f90]]>>= <> module eio_weights_uti <> <> 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 <> <> contains <> end module eio_weights_uti @ %def eio_weights_ut @ API: driver for the unit tests below. <>= public :: eio_weights_test <>= subroutine eio_weights_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_weights_test @ %def eio_weights_test @ \subsubsection{Simple event} We test the implementation of all I/O methods. <>= call test (eio_weights_1, "eio_weights_1", & "read and write event contents", & u, results) <>= public :: eio_weights_1 <>= 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. <>= call test (eio_weights_2, "eio_weights_2", & "multiple weights", & u, results) <>= public :: eio_weights_2 <>= 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. <>= call test (eio_weights_3, "eio_weights_3", & "check passed-flag", & u, results) <>= public :: eio_weights_3 <>= 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]]>>= <> module eio_dump use, intrinsic :: iso_fortran_env, only: output_unit use kinds, only: i64 <> 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 <> <> <> contains <> end module eio_dump @ %def eio_dump @ \subsection{Type} <>= public :: eio_dump_t <>= 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 <> 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. <>= procedure :: set_parameters => eio_dump_set_parameters <>= 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. <>= procedure :: write => eio_dump_write <>= 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. <>= procedure :: final => eio_dump_final <>= 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. <>= procedure :: init_out => eio_dump_init_out <>= 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. <>= procedure :: init_in => eio_dump_init_in <>= 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. <>= procedure :: switch_inout => eio_dump_switch_inout <>= 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). <>= procedure :: output => eio_dump_output <>= 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. <>= procedure :: input_i_prc => eio_dump_input_i_prc procedure :: input_event => eio_dump_input_event <>= 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 @ <>= procedure :: skip => eio_dump_skip <>= 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]]>>= <> module eio_dump_ut use unit_tests use eio_dump_uti <> <> contains <> end module eio_dump_ut @ %def eio_dump_ut @ <<[[eio_dump_uti.f90]]>>= <> module eio_dump_uti <> <> 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 <> <> contains <> end module eio_dump_uti @ %def eio_dump_ut @ API: driver for the unit tests below. <>= public :: eio_dump_test <>= subroutine eio_dump_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_dump_test @ %def eio_dump_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_dump_1, "eio_dump_1", & "write event contents", & u, results) <>= public :: eio_dump_1 <>= 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]]>>= <> module eio_ascii <> use io_units use diagnostics use event_base use eio_data use eio_base use hep_common use hep_events <> <> <> contains <> end module eio_ascii @ %def eio_ascii @ \subsection{Type} <>= public :: eio_ascii_t <>= 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 <> end type eio_ascii_t @ %def eio_ascii_t @ <>= public :: eio_ascii_ascii_t <>= type, extends (eio_ascii_t) :: eio_ascii_ascii_t end type eio_ascii_ascii_t @ %def eio_ascii_ascii_t @ <>= public :: eio_ascii_athena_t <>= 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. <>= public :: eio_ascii_debug_t <>= 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 @ <>= public :: eio_ascii_hepevt_t <>= type, extends (eio_ascii_t) :: eio_ascii_hepevt_t end type eio_ascii_hepevt_t @ %def eio_ascii_hepevt_t @ <>= public :: eio_ascii_hepevt_verb_t <>= type, extends (eio_ascii_t) :: eio_ascii_hepevt_verb_t end type eio_ascii_hepevt_verb_t @ %def eio_ascii_hepevt_verb_t @ <>= public :: eio_ascii_lha_t <>= type, extends (eio_ascii_t) :: eio_ascii_lha_t end type eio_ascii_lha_t @ %def eio_ascii_lha_t @ <>= public :: eio_ascii_lha_verb_t <>= type, extends (eio_ascii_t) :: eio_ascii_lha_verb_t end type eio_ascii_lha_verb_t @ %def eio_ascii_lha_verb_t @ <>= public :: eio_ascii_long_t <>= type, extends (eio_ascii_t) :: eio_ascii_long_t end type eio_ascii_long_t @ %def eio_ascii_long_t @ <>= public :: eio_ascii_mokka_t <>= type, extends (eio_ascii_t) :: eio_ascii_mokka_t end type eio_ascii_mokka_t @ %def eio_ascii_mokka_t @ <>= public :: eio_ascii_short_t <>= 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. <>= procedure :: set_parameters => eio_ascii_set_parameters <>= 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. <>= procedure :: write => eio_ascii_write <>= 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. <>= procedure :: final => eio_ascii_final <>= 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. <>= procedure :: init_out => eio_ascii_init_out <>= 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. <>= procedure :: check_normalization => eio_ascii_check_normalization <>= 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. <>= procedure :: init_in => eio_ascii_init_in <>= 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. <>= procedure :: switch_inout => eio_ascii_switch_inout <>= 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.) <>= procedure :: split_out => eio_ascii_split_out <>= 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. <>= procedure :: output => eio_ascii_output <>= 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. <>= procedure :: input_i_prc => eio_ascii_input_i_prc procedure :: input_event => eio_ascii_input_event <>= 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 @ <>= procedure :: skip => eio_ascii_skip <>= 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]]>>= <> module eio_ascii_ut use unit_tests use eio_ascii_uti <> <> contains <> end module eio_ascii_ut @ %def eio_ascii_ut @ <<[[eio_ascii_uti.f90]]>>= <> module eio_ascii_uti <> <> 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 <> <> contains <> end module eio_ascii_uti @ %def eio_ascii_uti @ API: driver for the unit tests below. <>= public :: eio_ascii_test <>= subroutine eio_ascii_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> 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]]: <>= call test (eio_ascii_1, "eio_ascii_1", & "read and write event contents, format [ascii]", & u, results) <>= public :: eio_ascii_1 <>= 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) == " ") 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]]: <>= call test (eio_ascii_2, "eio_ascii_2", & "read and write event contents, format [athena]", & u, results) <>= public :: eio_ascii_2 <>= 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) == " ") 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]]: <>= call test (eio_ascii_3, "eio_ascii_3", & "read and write event contents, format [debug]", & u, results) <>= public :: eio_ascii_3 <>= 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) == " ") 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]]: <>= call test (eio_ascii_4, "eio_ascii_4", & "read and write event contents, format [hepevt]", & u, results) <>= public :: eio_ascii_4 <>= 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) == " ") 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): <>= call test (eio_ascii_5, "eio_ascii_5", & "read and write event contents, format [lha]", & u, results) <>= public :: eio_ascii_5 <>= 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) == " ") 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]]: <>= call test (eio_ascii_6, "eio_ascii_6", & "read and write event contents, format [long]", & u, results) <>= public :: eio_ascii_6 <>= 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) == " ") 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]]: <>= call test (eio_ascii_7, "eio_ascii_7", & "read and write event contents, format [mokka]", & u, results) <>= public :: eio_ascii_7 <>= 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) == " ") 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]]: <>= call test (eio_ascii_8, "eio_ascii_8", & "read and write event contents, format [short]", & u, results) <>= public :: eio_ascii_8 <>= 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) == " ") 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: <>= call test (eio_ascii_9, "eio_ascii_9", & "read and write event contents, format [lha_verb]", & u, results) <>= public :: eio_ascii_9 <>= 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) == " ") 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]]: <>= call test (eio_ascii_10, "eio_ascii_10", & "read and write event contents, format [hepevt_verb]", & u, results) <>= public :: eio_ascii_10 <>= 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) == " ") 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]]>>= <> module hep_common <> use kinds, only: double use constants <> 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 <> <> <> <> <> <> contains <> end module hep_common @ %def hep_common @ \subsection{Event characteristics} The maximal number of particles in an event record. <>= integer, parameter, public :: MAXNUP = 500 @ %def MAXNUP @ The number of particles in this event. <>= integer, public :: NUP @ %def NUP @ The process ID for this event. <>= integer, public :: IDPRUP @ %def IDPRUP @ The weight of this event ($\pm 1$ for unweighted events). <>= double precision, public :: XWGTUP @ %def XWGTUP @ The factorization scale that is used for PDF calculation ($-1$ if undefined). <>= double precision, public :: SCALUP @ %def SCALUP @ The QED and QCD couplings $\alpha$ used for this event ($-1$ if undefined). <>= double precision, public :: AQEDUP double precision, public :: AQCDUP @ %def AQEDUP AQCDUP @ \subsection{Particle characteristics} The PDG code: <>= 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$. <>= integer, dimension(MAXNUP), public :: ISTUP @ %def ISTUP @ Index of first and last mother. <>= 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. <>= 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. <>= double precision, dimension(5,MAXNUP), public :: PUP @ %def PUP @ Invariant lifetime (distance) from production to decay in mm. <>= 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$. <>= 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. <>= integer, parameter, public :: MAXPUP = 100 @ %def MAXPUP @ The beam PDG codes. <>= integer, dimension(2), public :: IDBMUP @ %def IDBMUP @ The beam energies in GeV. <>= double precision, dimension(2), public :: EBMUP @ %def EBMUP @ The PDF group and set for the two beams. (Undefined: use $-1$; LHAPDF: use group = $0$). <>= 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. <>= integer, public :: IDWTUP @ %def IDWTUP @ The number of different processes. <>= 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.) <>= 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. <>= double precision, dimension(MAXPUP), public :: XMAXUP @ %def XMAXUP @ Internal ID of the selected process, matches [[IDPRUP]] below. <>= integer, dimension(MAXPUP), public :: LPRUP @ %def LPRUP @ \subsubsection{The common block} <>= 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. <>= public :: heprup_init <>= 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. <>= public :: assure_heprup <>= 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. <>= public :: combine_lhef_with_particle_set <>= 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) /= '' .and. & string(IBEG:IBEG+6) /= ' 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 @ <>= public :: w2p_write_lhef_event <>= 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 ("<>"), 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. <>= public :: heprup_get_run_parameters <>= 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. <>= public :: heprup_set_lhapdf_id <>= 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. <>= public :: heprup_set_process_parameters <>= 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. <>= public :: heprup_get_process_parameters <>= 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. <>= public :: heprup_write_verbose <>= 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. <>= public :: heprup_write_lhef <>= 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. <>= public :: heprup_write_ascii <>= 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. <>= public :: heprup_read_lhef <>= 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} <>= 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. <>= public :: hepeup_init public :: hepeup_set_event_parameters <>= 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. <>= public :: hepeup_get_event_parameters <>= 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. <>= public :: hepeup_set_particle <>= 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. <>= public :: hepeup_set_particle_lifetime <>= 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. <>= public :: hepeup_set_particle_spin <>= interface hepeup_set_particle_spin module procedure hepeup_set_particle_spin_pol end interface <>= 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. <>= public :: hepeup_get_particle <>= 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: <>= 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. <>= integer :: NEVHEP @ %def NEVHEP @ [[NHEP]] holds the number of entries for this event. <>= 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. <>= integer, dimension(NMXHEP), public :: ISTHEP @ %def ISTHEP @ The Particle Data Group has proposed standard particle codes, which are to be stored in [[IDHEP(N)]]. <>= 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. <>= 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. <>= 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. <>= 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. <>= 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: <>= integer, dimension(NMXHEP) :: hepevt_pol @ %def hepevt_pol @ By this variable the identity of the current process is given, defined via the LPRUP codes. <>= 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. <>= double precision, public :: eventweightlh @ %def eventweightlh @ There are the values for the electromagnetic and the strong coupling constants, $\alpha_{em}$ and $\alpha_s$. <>= double precision, public :: alphaqedlh, alphaqcdlh @ %def alphaqedlh, alphaqcdlh @ This is the squared scale $Q$ of the event. <>= double precision, dimension(10), public :: scalelh @ %def scalelh @ Finally, these variables contain the spin information and the color/anticolor flow of the particles. <>= 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. <>= 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. <>= integer :: hepevt_n_out, hepevt_n_remnants @ %def hepevt_n_out, hepevt_n_remnants @ <>= 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. <>= 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. <>= public :: hepevt_init public :: hepevt_set_event_parameters <>= 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. <>= public :: hepevt_set_particle <>= 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. <>= public :: hepevt_write_verbose <>= 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. <>= public :: hepeup_write_verbose <>= 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. <>= public :: hepeup_write_lhef public :: hepeup_write_lha <>= 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. <>= public :: hepevt_write_hepevt public :: hepevt_write_ascii public :: hepevt_write_athena public :: hepevt_write_mokka <>= 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. <>= public :: hepeup_read_lhef <>= 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]]. <>= public :: hepeup_from_particle_set <>= 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. <>= public :: hepeup_to_particle_set <>= 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. <>= public :: hepevt_from_particle_set <>= 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]]>>= <> module hepmc_interface use, intrinsic :: iso_c_binding !NODEP! <> <> use constants, only: PI use lorentz use flavors use colors use helicities use polarizations <> <> <> <> <> contains <> 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. <>= interface logical(c_bool) function hepmc_available () bind(C) import end function hepmc_available end interface <>= public :: hepmc_is_available <>= 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. <>= public :: hepmc_four_vector_t <>= 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. <>= 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 <>= public :: hepmc_four_vector_init <>= 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 <>= 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. <>= 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 <>= public :: hepmc_four_vector_final <>= 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. <>= 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 <>= public :: hepmc_four_vector_to_vector4 <>= 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. <>= public :: hepmc_polarization_t <>= 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.} <>= 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 <>= public :: hepmc_polarization_init <>= interface hepmc_polarization_init module procedure hepmc_polarization_init_pol module procedure hepmc_polarization_init_hel module procedure hepmc_polarization_init_int end interface <>= 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. <>= interface subroutine polarization_delete (pol_obj) bind(C) import type(c_ptr), value :: pol_obj end subroutine polarization_delete end interface @ %def polarization_delete <>= public :: hepmc_polarization_final <>= 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). <>= 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 <>= public :: hepmc_polarization_to_pol <>= 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. <>= public :: hepmc_polarization_to_hel <>= 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. <>= public :: hepmc_particle_t <>= 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. <>= 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 <>= public :: hepmc_particle_init <>= 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. <>= 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. <>= 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 <>= public :: hepmc_particle_set_color <>= 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]]. <>= 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 <>= public :: hepmc_particle_set_polarization <>= 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 <>= 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. <>= 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 <>= public :: hepmc_particle_get_barcode <>= 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. <>= 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 <>= public :: hepmc_particle_get_momentum <>= 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). <>= 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 <>= public :: hepmc_particle_get_mass_squared <>= 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: <>= 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 <>= public :: hepmc_particle_get_pdg <>= 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: <>= 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 <>= public :: hepmc_particle_get_status <>= 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 <>= 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. <>= public :: hepmc_particle_is_beam <>= 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). <>= 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 <>= public :: hepmc_particle_get_production_vertex public :: hepmc_particle_get_decay_vertex <>= 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. <>= public :: hepmc_particle_get_n_parents public :: hepmc_particle_get_n_children <>= 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. <>= public :: hepmc_particle_get_parent_barcodes public :: hepmc_particle_get_child_barcodes <>= 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. <>= 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 <>= public :: hepmc_particle_get_polarization <>= 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). <>= 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 <>= public :: hepmc_particle_get_color <>= 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 @ <>= 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 @ <>= public :: hepmc_vertex_to_vertex <>= 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). <>= public :: hepmc_vertex_t <>= 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. <>= 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 <>= public :: hepmc_vertex_init <>= 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: <>= 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 <>= public :: hepmc_vertex_is_valid <>= 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. <>= 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 <>= public :: hepmc_vertex_add_particle_in public :: hepmc_vertex_add_particle_out @ %def gen_vertex_add_particle_in gen_vertex_add_particle_out <>= 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. <>= 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 <>= public :: hepmc_vertex_get_n_in public :: hepmc_vertex_get_n_out <>= 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. <>= public :: hepmc_vertex_particle_in_iterator_t <>= 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. <>= 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 <>= public :: hepmc_vertex_particle_in_iterator_init <>= 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. <>= 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 <>= public :: hepmc_vertex_particle_in_iterator_final <>= 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 <>= 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 <>= public :: hepmc_vertex_particle_in_iterator_advance <>= 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 <>= 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 <>= public :: hepmc_vertex_particle_in_iterator_reset <>= 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. <>= 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 <>= public :: hepmc_vertex_particle_in_iterator_is_valid <>= 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.) <>= 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 <>= public :: hepmc_vertex_particle_in_iterator_get <>= 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. <>= public :: hepmc_vertex_particle_out_iterator_t <>= 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. <>= 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 <>= public :: hepmc_vertex_particle_out_iterator_init <>= 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. <>= 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 <>= public :: hepmc_vertex_particle_out_iterator_final <>= 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 <>= 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 <>= public :: hepmc_vertex_particle_out_iterator_advance <>= 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 <>= 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 <>= public :: hepmc_vertex_particle_out_iterator_reset <>= 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. <>= 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 <>= public :: hepmc_vertex_particle_out_iterator_is_valid <>= 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.) <>= 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 <>= public :: hepmc_vertex_particle_out_iterator_get <>= 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. <>= public :: hepmc_event_t <>= 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. <>= 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 <>= public :: hepmc_event_init <>= 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. <>= 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 <>= public :: hepmc_event_final <>= 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. <>= 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 <>= public :: hepmc_event_print <>= 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. <>= 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 <>= public :: hepmc_event_get_event_index <>= 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 <>= 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 <>= public :: hepmc_event_set_process_id <>= 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 <>= 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 <>= public :: hepmc_event_get_process_id <>= 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 <>= 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 <>= public :: hepmc_event_set_scale <>= 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 <>= 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 <>= public :: hepmc_event_get_scale <>= 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}$. <>= 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 <>= public :: hepmc_event_set_alpha_qcd <>= 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}$. <>= 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 <>= public :: hepmc_event_get_alpha_qcd <>= 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}$. <>= 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 <>= public :: hepmc_event_set_alpha_qed <>= 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}$. <>= 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 <>= public :: hepmc_event_get_alpha_qed <>= 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. <>= 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. <>= real(default), parameter :: pb_per_fb = 1.e-3_default @ %def pb_per_fb @ <>= public :: hepmc_event_clear_weights <>= 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. <>= 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 @ <>= public :: hepmc_event_add_weight <>= 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). <>= 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 <>= public :: hepmc_event_get_weights_size <>= 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.) <>= 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 <>= public :: hepmc_event_get_weight <>= 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. <>= 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 <>= public :: hepmc_event_add_vertex <>= 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). <>= 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 <>= public :: hepmc_event_set_signal_process_vertex <>= 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). <>= 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 <>= public :: hepmc_event_get_signal_process_vertex <>= 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. <>= public :: hepmc_event_set_beam_particles <>= 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. <>= 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. <>= public :: hepmc_event_set_cross_section <>= 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. <>= 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. <>= public :: hepmc_event_particle_iterator_t <>= 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. <>= 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 <>= public :: hepmc_event_particle_iterator_init <>= 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. <>= 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 <>= public :: hepmc_event_particle_iterator_final <>= 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 <>= 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 <>= public :: hepmc_event_particle_iterator_advance <>= 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 <>= 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 <>= public :: hepmc_event_particle_iterator_reset <>= 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. <>= 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 <>= public :: hepmc_event_particle_iterator_is_valid <>= 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.) <>= 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 <>= public :: hepmc_event_particle_iterator_get <>= 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. <>= public :: hepmc_iostream_t <>= 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. <>= 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 <>= public :: hepmc_iostream_open_out <>= 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. <>= 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 <>= public :: hepmc_iostream_open_in <>= 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: <>= 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 <>= public :: hepmc_iostream_close <>= 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. <>= 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 <>= public :: hepmc_iostream_write_event <>= 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. <>= 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 <>= public :: hepmc_iostream_read_event <>= 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]]>>= <> module hepmc_interface_ut use unit_tests use hepmc_interface_uti <> <> contains <> end module hepmc_interface_ut @ %def hepmc_interface_ut @ <<[[hepmc_interface_uti.f90]]>>= <> module hepmc_interface_uti <> <> use io_units use lorentz use flavors use colors use polarizations use hepmc_interface <> <> contains <> end module hepmc_interface_uti @ %def hepmc_interface_ut @ API: driver for the unit tests below. <>= public :: hepmc_interface_test <>= subroutine hepmc_interface_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> 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. <>= call test (hepmc_interface_1, "hepmc_interface_1", & "check HepMC interface", & u, results) <>= public :: hepmc_interface_1 <>= 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]]>>= <> module lcio_interface use, intrinsic :: iso_c_binding !NODEP! <> <> use constants, only: PI use diagnostics use lorentz use flavors use colors use helicities use polarizations <> <> <> <> contains <> 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. <>= interface logical(c_bool) function lcio_available () bind(C) import end function lcio_available end interface <>= public :: lcio_is_available <>= 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. <>= public :: lcio_run_header_t <>= 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. <>= 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 <>= 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 <>= public :: lcio_run_header_init <>= 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:" // "<>") end subroutine lcio_run_header_init @ %def lcio_run_header_init @ <>= 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 <>= public :: lcio_run_header_write <>= 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. <>= public :: lccollection_t <>= type :: lccollection_t private type(c_ptr) :: obj end type lccollection_t @ %def lccollection_t @ Initializer. <>= interface type(c_ptr) function new_lccollection () bind(C) import end function new_lccollection end interface @ %def new_lccollection <>= public :: lcio_event_t <>= 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. <>= 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 @ <>= public :: lcio_event_init <>= 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. <>= 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. <>= 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 <>= public :: show_lcio_event <>= 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. <>= 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 <>= public :: write_lcio_event <>= 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 @ <>= public :: lcio_event_final <>= 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 @ <>= 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 @ <>= public :: lcio_event_set_weight <>= 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 @ <>= public :: lcio_event_set_alpha_qcd <>= 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 @ <>= public :: lcio_event_set_scale <>= 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 @ <>= public :: lcio_event_set_sqrts <>= 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 @ <>= public :: lcio_event_set_xsec <>= 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 @ <>= public :: lcio_event_set_beam <>= 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 @ <>= public :: lcio_event_set_polarization <>= 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 @ <>= public :: lcio_event_set_beam_file <>= 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 @ <>= public :: lcio_event_set_process_name <>= 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 @ <>= 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 <>= public :: lcio_event_add_coll <>= 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. <>= public :: lcio_particle_t <>= type :: lcio_particle_t private type(c_ptr) :: obj end type lcio_particle_t @ %def lcio_particle_t @ Constructor. <>= 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 @ <>= 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 <>= public :: lcio_particle_add_to_evt_coll <>= 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 @ <>= public :: lcio_particle_init <>= 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. <>= 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. <>= 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 <>= public :: lcio_particle_set_color <>= 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). <>= 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 <>= public :: lcio_particle_get_flow <>= 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. <>= 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 <>= 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 <>= public :: lcio_particle_get_momentum <>= 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). <>= 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 <>= public :: lcio_particle_get_mass_squared <>= 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. <>= 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 @ @ <>= public :: lcio_particle_get_vertex public :: lcio_particle_get_time <>= 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.} <>= 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 @ <>= public :: lcio_polarization_init <>= interface lcio_polarization_init module procedure lcio_polarization_init_pol module procedure lcio_polarization_init_hel module procedure lcio_polarization_init_int end interface <>= 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). <>= 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 <>= public :: lcio_particle_to_pol <>= 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. <>= public :: lcio_particle_to_hel <>= 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. <>= 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 @ <>= public :: lcio_particle_set_vtx <>= 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 @ <>= public :: lcio_particle_set_t <>= 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 @ <>= 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 <>= public :: lcio_particle_set_parent <>= 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 @ <>= 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 <>= public :: lcio_particle_get_status <>= 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. <>= 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 @ <>= public :: lcio_particle_get_pdg <>= 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. <>= 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 @ <>= 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 @ <>= public :: lcio_particle_get_n_parents <>= 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 @ <>= public :: lcio_particle_get_n_children <>= 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. <>= 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 <>= 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 @ <>= public :: lcio_get_n_parents <>= 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 @ <>= public :: lcio_get_n_children <>= 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. <>= public :: lcio_writer_t <>= 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. <>= 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 <>= public :: lcio_writer_open_out <>= 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: <>= 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 <>= public :: lcio_writer_close <>= 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. <>= 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 <>= public :: lcio_event_write <>= 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. <>= public :: lcio_reader_t <>= 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. <>= 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 <>= public :: lcio_open_file <>= 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: <>= 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 <>= public :: lcio_reader_close <>= 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. <>= 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 <>= public :: lcio_read_event <>= 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. <>= 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 <>= public :: lcio_event_get_event_index <>= 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. <>= 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 <>= public :: lcio_event_get_process_id <>= 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. <>= 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 <>= @ <>= public :: lcio_event_get_n_tot <>= 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. <>= 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 @ <>= public :: lcio_event_get_alphas <>= 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 @ <>= public :: lcio_event_get_scaleval <>= 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. <>= 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 @ <>= public :: lcio_event_get_particle <>= 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]]>>= <> module lcio_interface_ut use unit_tests use lcio_interface_uti <> <> contains <> end module lcio_interface_ut @ %def lcio_interface_ut @ <<[[lcio_interface_uti.f90]]>>= <> module lcio_interface_uti <> <> use io_units use lorentz use flavors use colors use polarizations use lcio_interface <> <> contains <> end module lcio_interface_uti @ %def lcio_interface_ut @ API: driver for the unit tests below. <>= public :: lcio_interface_test <>= subroutine lcio_interface_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine lcio_interface_test @ %def lcio_interface_test @ <>= call test (lcio_interface_1, "lcio_interface_1", & "check LCIO interface", & u, results) <>= public :: lcio_interface_1 <>= 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]]>>= <> module hep_events <> <> 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 <> <> contains <> end module hep_events @ %def hep_events @ \subsection{Data Transfer: events} Fill the HEPEUP block, given a \whizard\ event object. <>= public :: hepeup_from_event <>= 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. <>= public :: hepeup_to_event <>= 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. <>= public :: hepevt_from_event <>= 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. <>= 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 @ <>= public :: hepmc_event_from_particle_set <>= 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. <>= 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 <>= public :: hepmc_event_to_particle_set <>= 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. <>= public :: hepmc_to_event <>= 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. <>= public :: particle_to_lcio <>= 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. <>= public :: particle_from_lcio_particle <>= 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 @ <>= public :: lcio_event_from_particle_set <>= 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. <>= public :: lcio_event_to_particle_set <>= 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 @ <>= public :: lcio_to_event <>= 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]]>>= <> module hep_events_ut use unit_tests use hepmc_interface, only: HEPMC_IS_AVAILABLE use hep_events_uti <> <> contains <> end module hep_events_ut @ %def hep_events_ut @ <<[[hep_events_uti.f90]]>>= <> module hep_events_uti <> <> 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 <> <> contains <> end module hep_events_uti @ %def hep_events_ut @ API: driver for the unit tests below. <>= public :: hep_events_test <>= subroutine hep_events_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> 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$. <>= if (hepmc_is_available ()) then call test (hep_events_1, "hep_events_1", & "check HepMC event routines", & u, results) end if <>= public :: hep_events_1 <>= 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]]>>= <> module eio_lhef <> <> 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 <> <> <> contains <> 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. <>= public :: eio_lhef_t <>= 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 <> end type eio_lhef_t @ %def eio_lhef_t @ \subsection{Specific Methods} Set parameters that are specifically used with LHEF. <>= procedure :: set_parameters => eio_lhef_set_parameters <>= 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. <>= procedure :: write => eio_lhef_write <>= 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. <>= procedure :: final => eio_lhef_final <>= 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. <>= procedure :: common_init => eio_lhef_common_init <>= 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. <>= procedure :: init_tags => eio_lhef_init_tags <>= 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 ("<>"))], & .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. <>= procedure :: init_out => eio_lhef_init_out <>= 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. <>= procedure :: init_in => eio_lhef_init_in <>= 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. <>= procedure :: merge_data => eio_merge_data <>= 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. <>= procedure :: switch_inout => eio_lhef_switch_inout <>= 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.) <>= procedure :: split_out => eio_lhef_split_out <>= 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. <>= procedure :: output => eio_lhef_output <>= 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)') "" 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)') "" 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 [[]] tag. <>= procedure :: input_i_prc => eio_lhef_input_i_prc <>= 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. <>= procedure :: input_event => eio_lhef_input_event <>= 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 @ <>= procedure :: skip => eio_lhef_skip <>= 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). <>= procedure :: write_header => eio_lhef_write_header procedure :: write_footer => eio_lhef_write_footer <>= 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 ("<>"), 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. <>= procedure :: read_header => eio_lhef_read_header <>= 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. <>= procedure :: read_init_10 => eio_lhef_read_init_10 <>= 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} <>= procedure :: write_init_20 => eio_lhef_write_init_20 <>= 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. <>= procedure :: read_init_20 => eio_lhef_read_init_20 <>= 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. <>= procedure :: write_event_20 => eio_lhef_write_event_20 <>= 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. <>= procedure :: read_event_20 => eio_lhef_read_event_20 <>= 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} <>= procedure :: write_init_30 => eio_lhef_write_init_30 <>= 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. <>= procedure :: read_init_30 => eio_lhef_read_init_30 <>= 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. <>= procedure :: write_event_30 => eio_lhef_write_event_30 <>= 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. <>= procedure :: read_event_30 => eio_lhef_read_event_30 <>= 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]]>>= <> module eio_lhef_ut use unit_tests use eio_lhef_uti <> <> contains <> end module eio_lhef_ut @ %def eio_lhef_ut @ <<[[eio_lhef_uti.f90]]>>= <> module eio_lhef_uti <> <> 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 <> <> contains <> end module eio_lhef_uti @ %def eio_lhef_ut @ API: driver for the unit tests below. <>= public :: eio_lhef_test <>= subroutine eio_lhef_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> 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. <>= call test (eio_lhef_1, "eio_lhef_1", & "write version 1.0", & u, results) <>= public :: eio_lhef_1 <>= 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) == " ") 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. <>= call test (eio_lhef_2, "eio_lhef_2", & "write version 2.0", & u, results) <>= public :: eio_lhef_2 <>= 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) == ">= call test (eio_lhef_3, "eio_lhef_3", & "write version 3.0", & u, results) <>= public :: eio_lhef_3 <>= 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) == ">= call test (eio_lhef_4, "eio_lhef_4", & "read version 1.0", & u, results) <>= public :: eio_lhef_4 <>= 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)") '' write (u_file, "(A)") '
' write (u_file, "(A)") ' content' write (u_file, "(A)") ' Text' write (u_file, "(A)") ' ' write (u_file, "(A)") '
' write (u_file, "(A)") '' 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)") '' write (u_file, "(A)") '' 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)") '' write (u_file, "(A)") '' 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. <>= call test (eio_lhef_5, "eio_lhef_5", & "read version 2.0", & u, results) <>= public :: eio_lhef_5 <>= 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)") '' write (u_file, "(A)") '
' write (u_file, "(A)") '
' write (u_file, "(A)") '' 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)") 'WHIZARD& &' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") '' 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)") '1.0000000000E+00' write (u_file, "(A)") '' write (u_file, "(A)") '' 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. <>= call test (eio_lhef_6, "eio_lhef_6", & "read version 3.0", & u, results) <>= public :: eio_lhef_6 <>= 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)") '' write (u_file, "(A)") '
' write (u_file, "(A)") '
' write (u_file, "(A)") '' 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)") 'WHIZARD& &' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") '' write (u_file, "(A)") '' 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)") '1.0000000000E+00' write (u_file, "(A)") '' write (u_file, "(A)") '' 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]]>>= <> module eio_stdhep use kinds, only: i32, i64 <> use io_units use string_utils use diagnostics use event_base use hep_common use hep_events use eio_data use eio_base <> <> <> <> contains <> end module eio_stdhep @ %def eio_stdhep @ \subsection{Type} <>= public :: eio_stdhep_t <>= 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 <> end type eio_stdhep_t @ %def eio_stdhep_t @ <>= public :: eio_stdhep_hepevt_t <>= type, extends (eio_stdhep_t) :: eio_stdhep_hepevt_t end type eio_stdhep_hepevt_t @ %def eio_stdhep_hepevt_t @ <>= public :: eio_stdhep_hepeup_t <>= type, extends (eio_stdhep_t) :: eio_stdhep_hepeup_t end type eio_stdhep_hepeup_t @ %def eio_stdhep_hepeup_t @ <>= public :: eio_stdhep_hepev4_t <>= 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. <>= procedure :: set_parameters => eio_stdhep_set_parameters <>= 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. <>= procedure :: write => eio_stdhep_write <>= 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. <>= procedure :: final => eio_stdhep_final <>= 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. <>= procedure :: common_init => eio_stdhep_common_init <>= 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.) <>= procedure :: split_out => eio_stdhep_split_out <>= 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 <>", 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 <>", eio%n_events_expected) call stdhep_write (100) type is (eio_stdhep_hepev4_t) call stdhep_init_out (char (eio%filename), & "WHIZARD <>", 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. <>= procedure :: init_out => eio_stdhep_init_out <>= 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 <>", 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 <>", eio%n_events_expected) call stdhep_write (100) type is (eio_stdhep_hepev4_t) call stdhep_init_out (char (eio%filename), & "WHIZARD <>", 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. <>= procedure :: init_in => eio_stdhep_init_in <>= 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. <>= procedure :: switch_inout => eio_stdhep_switch_inout <>= 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. <>= procedure :: output => eio_stdhep_output <>= 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. <>= procedure :: input_i_prc => eio_stdhep_input_i_prc procedure :: input_event => eio_stdhep_input_event <>= 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 <>= procedure :: skip => eio_stdhep_skip <>= 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. <>= public :: stdhep_init_out public :: stdhep_init_in public :: stdhep_write public :: stdhep_end <>= 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} <>= 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]]>>= <> module eio_stdhep_ut use unit_tests use eio_stdhep_uti <> <> contains <> end module eio_stdhep_ut @ %def eio_stdhep_ut @ <<[[eio_stdhep_uti.f90]]>>= <> module eio_stdhep_uti <> <> 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 <> <> contains <> end module eio_stdhep_uti @ %def eio_stdhep_ut @ API: driver for the unit tests below. <>= public :: eio_stdhep_test <>= subroutine eio_stdhep_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> 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: <>= call test (eio_stdhep_1, "eio_stdhep_1", & "read and write event contents, format [stdhep]", & u, results) <>= public :: eio_stdhep_1 <>= 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: <>= call test (eio_stdhep_2, "eio_stdhep_2", & "read and write event contents, format [stdhep]", & u, results) <>= public :: eio_stdhep_2 <>= 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. <>= call test (eio_stdhep_3, "eio_stdhep_3", & "read StdHep file, HEPEVT block", & u, results) <>= public :: eio_stdhep_3 <>= 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. <>= call test (eio_stdhep_4, "eio_stdhep_4", & "read StdHep file, HEPRUP/HEPEUP block", & u, results) <>= public :: eio_stdhep_4 <>= 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]]>>= <> module eio_hepmc <> 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 <> <> <> contains <> 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]]. <>= public :: eio_hepmc_t <>= 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 <> end type eio_hepmc_t @ %def eio_hepmc_t @ \subsection{Specific Methods} Set parameters that are specifically used with HepMC. <>= procedure :: set_parameters => eio_hepmc_set_parameters <>= 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. <>= procedure :: write => eio_hepmc_write <>= 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. <>= procedure :: final => eio_hepmc_final <>= 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. <>= procedure :: split_out => eio_hepmc_split_out <>= 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. <>= procedure :: common_init => eio_hepmc_common_init <>= 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. <>= procedure :: init_out => eio_hepmc_init_out <>= 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. <>= procedure :: init_in => eio_hepmc_init_in <>= 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. <>= procedure :: switch_inout => eio_hepmc_switch_inout <>= 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. <>= procedure :: output => eio_hepmc_output <>= 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. <>= procedure :: input_i_prc => eio_hepmc_input_i_prc procedure :: input_event => eio_hepmc_input_event <>= 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 @ <>= procedure :: skip => eio_hepmc_skip <>= 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]]>>= <> module eio_hepmc_ut use unit_tests use eio_hepmc_uti <> <> contains <> end module eio_hepmc_ut @ %def eio_hepmc_ut @ <<[[eio_hepmc_uti.f90]]>>= <> module eio_hepmc_uti <> <> 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 <> <> contains <> end module eio_hepmc_uti @ %def eio_hepmc_ut @ API: driver for the unit tests below. <>= public :: eio_hepmc_test <>= subroutine eio_hepmc_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_hepmc_test @ %def eio_hepmc_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_hepmc_1, "eio_hepmc_1", & "write event contents", & u, results) <>= public :: eio_hepmc_1 <>= 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. <>= call test (eio_hepmc_2, "eio_hepmc_2", & "read event contents", & u, results) <>= public :: eio_hepmc_2 <>= 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]]>>= <> module eio_lcio <> 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 <> <> <> contains <> 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. <>= public :: eio_lcio_t <>= 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 <> end type eio_lcio_t @ %def eio_lcio_t @ \subsection{Specific Methods} Set parameters that are specifically used with LCIO. <>= procedure :: set_parameters => eio_lcio_set_parameters <>= 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. <>= procedure :: write => eio_lcio_write <>= 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. <>= procedure :: final => eio_lcio_final <>= 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. <>= procedure :: split_out => eio_lcio_split_out <>= 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. <>= procedure :: common_init => eio_lcio_common_init <>= 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. <>= procedure :: init_out => eio_lcio_init_out <>= 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. <>= procedure :: init_in => eio_lcio_init_in <>= 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. <>= procedure :: switch_inout => eio_lcio_switch_inout <>= 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. <>= procedure :: output => eio_lcio_output <>= 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. <>= procedure :: input_i_prc => eio_lcio_input_i_prc procedure :: input_event => eio_lcio_input_event <>= 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 @ <>= procedure :: skip => eio_lcio_skip <>= 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]]>>= <> module eio_lcio_ut use unit_tests use eio_lcio_uti <> <> contains <> end module eio_lcio_ut @ %def eio_lcio_ut @ <<[[eio_lcio_uti.f90]]>>= <> module eio_lcio_uti <> <> 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 <> <> contains <> end module eio_lcio_uti @ %def eio_lcio_ut @ API: driver for the unit tests below. <>= public :: eio_lcio_test <>= subroutine eio_lcio_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine eio_lcio_test @ %def eio_lcio_test @ \subsubsection{Test I/O methods} We test the implementation of all I/O methods. <>= call test (eio_lcio_1, "eio_lcio_1", & "write event contents", & u, results) <>= public :: eio_lcio_1 <>= 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. <>= call test (eio_lcio_2, "eio_lcio_2", & "read event contents", & u, results) <>= public :: eio_lcio_2 <>= 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]]>>= <> module shower_base <> <> 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 <> <> <> <> <> contains <> end module shower_base @ %def shower_base @ \subsection{Shower implementations} <>= public :: PS_WHIZARD, PS_PYTHIA6, PS_PYTHIA8, PS_UNDEFINED <>= 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 <>= public :: shower_method_of_string <>= 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 @ <>= public :: shower_method_to_string <>= 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. <>= public :: shower_settings_t <>= 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 <> end type shower_settings_t @ %def shower_settings_t @ Read in the shower settings (and flags whether matching and hadronization are switched on). <>= procedure :: init => shower_settings_init <>= 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 @ <>= procedure :: write => shower_settings_write <>= 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. <>= public :: shower_base_t <>= 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 <> end type shower_base_t @ %def shower_base_t @ <>= procedure :: write_msg => shower_base_write_msg <>= 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 @ <>= procedure :: import_rng => shower_base_import_rng <>= 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. <>= procedure (shower_base_init), deferred :: init <>= 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 @ <>= procedure (shower_base_prepare_new_event), deferred :: prepare_new_event <>= 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 @ <>= procedure (shower_base_import_particle_set), deferred :: import_particle_set <>= 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 @ <>= procedure (shower_base_generate_emissions), deferred :: generate_emissions <>= 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 @ <>= procedure (shower_base_make_particle_set), deferred :: make_particle_set <>= 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 @ <>= procedure (shower_base_get_final_colored_ME_momenta), deferred :: & get_final_colored_ME_momenta <>= 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. <>= 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: <>= 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: <>= real(default), public :: scalefactor1 = 0.02_default real(default), public :: scalefactor2 = 0.02_default @ %def scalefactor1 scalefactor2 @ <>= public :: D_alpha_s_isr public :: D_alpha_s_fsr <>= 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. <>= public :: mass_type public :: mass_squared_type <>= 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$. <>= public :: number_of_flavors <>= 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]]>>= <> module shower_base_ut use unit_tests use shower_base_uti <> <> contains <> end module shower_base_ut @ %def shower_base_ut @ <<[[shower_base_uti.f90]]>>= <> module shower_base_uti <> <> use format_utils, only: write_separator use variables use shower_base <> <> contains <> end module shower_base_uti @ %def shower_base_ut @ API: driver for the unit tests below. <>= public :: shower_base_test <>= subroutine shower_base_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> 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. <>= call test (shower_base_1, "shower_base_1", & "Shower settings", & u, results) <>= public :: shower_base_1 <>= 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]]>>= <> module shower_partons <> 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 <> <> <> contains <> 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]]. <>= public :: parton_t <>= 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 <> end type parton_t @ %def parton_t @ <>= public :: parton_pointer_t <>= type :: parton_pointer_t type(parton_t), pointer :: p => null () end type parton_pointer_t @ %def parton_pointer_t @ \subsection{Routines} <>= procedure :: to_particle => parton_to_particle <>= 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 @ <>= public :: parton_of_particle <>= ! 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 @ <>= procedure :: to_status => parton_to_status <>= 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 @ <>= procedure :: to_color => parton_to_color <>= 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 <>= public :: parton_copy <>= 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. <>= procedure :: get_costheta => parton_get_costheta <>= 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. <>= procedure :: get_costheta_mass => parton_get_costheta_mass <>= 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. <>= procedure :: get_costheta_motherfirst => parton_get_costheta_motherfirst <>= 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. <>= procedure :: get_beta => parton_get_beta @ <>= 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. <>= procedure :: write => parton_write <>= 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 ", TAB, "", TAB // TAB, & "", TAB, "" 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)") "", TAB // TAB, "", TAB // TAB, & "", TAB // TAB, "", TAB, "", TAB, "" 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 @ <>= procedure :: is_final => parton_is_final <>= 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 @ <>= procedure :: is_branched => parton_is_branched <>= 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 @ <>= procedure :: set_simulated => parton_set_simulated <>= 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 @ <>= public :: parton_set_parent <>= 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 @ <>= public :: parton_get_parent <>= 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 @ <>= public :: parton_set_initial <>= 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 @ <>= public :: parton_get_initial <>= 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 @ <>= public :: parton_set_child <>= 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 @ <>= public :: parton_get_child <>= 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 @ <>= procedure :: is_quark => parton_is_quark <>= 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 @ <>= procedure :: is_squark => parton_is_squark <>= 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 <>= procedure :: is_gluon => parton_is_gluon <>= 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 @ <>= procedure :: is_gluino => parton_is_gluino <>= 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 @ <>= procedure :: is_proton => parton_is_proton <>= 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. <>= procedure :: is_colored => parton_is_colored <>= 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 @ <>= procedure :: mass => parton_mass <>= 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 @ <>= procedure :: mass_squared => parton_mass_squared <>= 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 @ <>= procedure :: momentum_to_pythia6 => parton_momentum_to_pythia6 <>= 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 @ <>= public :: P_prt_to_child1 <>= 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. <>= public :: thetabar <>= 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 @ <>= public :: parton_apply_costheta <>= 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 @ <>= public :: parton_apply_lorentztrafo <>= 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 @ <>= public :: parton_apply_lorentztrafo_recursive <>= 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 <>= procedure :: generate_ps => parton_generate_ps <>= 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 <> 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 @ <>= 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. <>= procedure :: generate_ps_ini => parton_generate_ps_ini <>= 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 <> 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} <>= procedure :: next_t_ana => parton_next_t_ana <>= 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. <>= 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. <>= public :: parton_simulate_stept <>= 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.) <> 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 @ <>= 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. <>= public :: maxzz <>= 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]]>>= <> module shower_core <> <> 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 <> <> <> <> <> contains <> end module shower_core @ %def shower_core @ <>= public :: shower_interaction_t <>= 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. <>= public :: shower_t <>= 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 <> end type shower_t @ %def shower_t @ <>= procedure :: init => shower_init <>= 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 @ <>= procedure :: prepare_new_event => shower_prepare_new_event <>= 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. <>= procedure :: activate_multiple_interactions => shower_activate_multiple_interactions <>= 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 @ @ <>= procedure :: import_particle_set => shower_import_particle_set <>= 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 <> end subroutine shower_import_particle_set @ %def shower_import_particle_set <>= 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 @ <>= 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 @ <>= 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 @ <>= procedure :: generate_emissions => shower_generate_emissions <>= 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 @ <>= procedure :: make_particle_set => shower_make_particle_set <>= 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: <>= 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. <>= procedure :: add_interaction_2ton => shower_add_interaction_2ton <>= 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 <> 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 <> 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 ! !> ! else <> ! 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 <> end subroutine shower_add_interaction_2ton @ %def shower_add_interaction_2ton @ <>= 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) @ <>= 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) @ <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 @ <>= procedure :: simulate_no_isr_shower => shower_simulate_no_isr_shower <>= 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 @ <>= procedure :: simulate_no_fsr_shower => shower_simulate_no_fsr_shower <>= 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 @ <>= 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. <>= 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. <>= 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 @ <>= procedure :: sort_partons => shower_sort_partons <>= 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. <>= procedure :: cleanup => shower_cleanup <>= 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. <>= procedure :: get_next_free_nr => shower_get_next_free_nr <>= 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 @ <>= procedure :: update_max_color_nr => shower_update_max_color_nr <>= 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 <>= procedure :: get_next_color_nr => shower_get_next_color_nr <>= 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 @ <>= 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 @ <>= procedure :: add_child => shower_add_child <>= 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 @ <>= procedure :: add_parent => shower_add_parent <>= 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: <>= 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. <>= procedure :: get_nr_of_partons => shower_get_nr_of_partons <>= 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 @ <>= 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 @ <>= procedure :: get_final_colored_ME_momenta => & shower_get_final_colored_ME_momenta <>= 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 @ <>= 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 @ <>= 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 @ <>= public :: shower_interaction_get_s <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 @ <>= procedure :: update_beamremnants => shower_update_beamremnants <>= 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 @ <>= 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 @ <>= 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. <>= 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. <>= procedure :: boost_to_CMframe => shower_boost_to_CMframe <>= 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. <>= procedure :: boost_to_labframe => shower_boost_to_labframe <>= 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. <>= 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). <>= 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. <>= procedure :: rotate_to_z => shower_rotate_to_z <>= 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. <>= 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 @ <>= procedure :: generate_primordial_kt => shower_generate_primordial_kt <>= 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. <>= 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 @ <>= procedure :: write => shower_write <>= 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. <>= procedure :: combine_with_particle_set => shower_combine_with_particle_set <>= 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 <> end subroutine shower_combine_with_particle_set @ %def shower_combine_with_particle_set <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 @ <>= procedure :: write_lhef => shower_write_lhef <>= 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)') '' write(u,'(A)') '<-- not a complete lhe file - just one event -->' write(u,'(A)') '' 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)') '' write(u,'(A)') '' end subroutine shower_write_lhef @ %def shower_write_lhef @ <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 @ <>= 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 <> 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 <> else exit end if end if end do call parton_apply_costheta (prt, shower%rng) <> call shower_parton_update_color_connections (shower, prt) end subroutine shower_simulate_children_ana @ %def shower_simulate_children_ana @ <>= 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 @ <>= !!! 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 @ <>= 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. <>= 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. <>= procedure :: generate_next_isr_branching_veto => & shower_generate_next_isr_branching_veto <>= 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 @ <>= procedure :: find_recoiler => shower_find_recoiler <>= 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 @ <>= 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 <>= 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 <>= 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. <>= procedure :: generate_next_isr_branching => & shower_generate_next_isr_branching <>= 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. <>= procedure :: generate_fsr_for_isr_partons => & shower_generate_fsr_for_partons_emitted_in_ISR <>= 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. <>= procedure :: execute_next_isr_branching => shower_execute_next_isr_branching <>= 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 @ <>= 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 @ <>= procedure :: get_ISR_scale => shower_get_ISR_scale <>= 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 @ <>= procedure :: set_max_isr_scale => shower_set_max_isr_scale <>= 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 @ <>= procedure :: interaction_generate_fsr_2ton => & shower_interaction_generate_fsr_2ton @ <>= 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. <>= 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 @ <>= procedure :: parton_pointer_array_generate_fsr_recursive => & shower_parton_pointer_array_generate_fsr_recursive @ <>= 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 @ <>= procedure :: parton_pointer_array_generate_fsr => & shower_parton_pointer_array_generate_fsr @ <>= 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 @ <>= 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. <>= procedure :: get_pdf => shower_get_pdf <>= function shower_get_pdf (shower, mother, x, Q2, daughter) result (pdf) <> if (x > eps0) then pdf = pdf / x end if end function shower_get_pdf @ %def shower_get_pdf <>= procedure :: get_xpdf => shower_get_xpdf <>= function shower_get_xpdf (shower, mother, x, Q2, daughter) result (pdf) <> end function shower_get_xpdf @ %def shower_get_xpdf @ <>= 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. <>= procedure :: converttopythia => shower_converttopythia <>= subroutine shower_converttopythia (shower) class(shower_t), intent(in) :: shower <> 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 @ <>= subroutine shower_transfer_final_partons_to_pythia (shower, first) <> 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]]>>= <> module shower_pythia6 <> <> 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 <> <> <> <> contains <> end module shower_pythia6 @ %def shower_topythia <>= integer :: N, NPAD, K real(double) :: P, V COMMON/PYJETS/N,NPAD,K(4000,5),P(4000,5),V(4000,5) SAVE /PYJETS/ @ <>= integer :: N_old @ %def N_old @ The PYTHIA6 shower type. <>= public :: shower_pythia6_t <>= type, extends (shower_base_t) :: shower_pythia6_t integer :: initialized_for_NPRUP = 0 logical :: warning_given = .false. contains <> end type shower_pythia6_t @ %def shower_pythia6_t @ Initialize the PYTHIA6 shower. <>= procedure :: init => shower_pythia6_init <>= 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 @ @ <>= procedure :: prepare_new_event => shower_pythia6_prepare_new_event <>= 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 <>= procedure :: import_particle_set => shower_pythia6_import_particle_set <>= 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 @ <>= procedure :: generate_emissions => shower_pythia6_generate_emissions <>= 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 @ <>= procedure :: make_particle_set => shower_pythia6_make_particle_set <>= 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 @ <>= procedure :: transfer_settings => shower_pythia6_transfer_settings <>= 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 <>= procedure :: combine_with_particle_set => & shower_pythia6_combine_with_particle_set <>= 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. @ <>= public :: pythia6_combine_with_particle_set @ <>= 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 <> end subroutine pythia6_combine_with_particle_set @ %def pythia6_combine_with_particle_set <>= subroutine count_valid_entries_in_pythia_record () <> 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 @ <>= 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 @ <>= 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 @ <>= 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 <> 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 <>= 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 <>= subroutine set_parent_child_relations_from_hepevt () integer, allocatable, dimension(:) :: parents <> 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 @ <>= 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 <>= 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 @ <>= 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. <>= 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. <>= 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 @ <>= procedure :: get_final_colored_ME_momenta => shower_pythia6_get_final_colored_ME_momenta <>= 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 <> 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 @ <>= public :: pythia6_setup_lhe_io_units <>= 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 @ <>= public :: pythia6_set_config <>= 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. <>= public :: pythia6_set_error <>= 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 @ <>= public :: pythia6_get_error <>= 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 @ <>= public :: pythia6_tauola_active <>= 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 @ <>= public :: pythia6_handle_errors <>= 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 @ <>= public :: pythia6_set_verbose <>= 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 @ <>= public :: pythia6_set_last_treated_line <>= 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 "" or "'.AND. &STRING(IBEG:IBEG+5).NE.'>= 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 "" or "'.AND. &STRING(IBEG:IBEG+6).NE.'>= 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]]>>= <> module ktclus <> <> contains <> end module ktclus @ %def ktclus <>= !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= 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----------------------------------------------------------------------- <>= public :: ktclur <>= 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>= public :: ktreco <>= !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----------------------------------------------------------------------- <>= !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----------------------------------------------------------------------- <>= 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