Index: branches/attic/whizard.attic.nw =================================================================== --- branches/attic/whizard.attic.nw (revision 8607) +++ branches/attic/whizard.attic.nw (revision 8608) @@ -1,22153 +0,0 @@ -% -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- -% This file temporarily holds stuff that has been removed from -% the main file whizard.nw, but may still be reused in part before -@%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -@ -\chapter{Process Libraries} -Initialize a process configuration. The configuration is -[[intent(inout)]] such that any [[next]] pointer is kept if an -existing configuration is overwritten. Otherwise, -all contents are reset. -<>= - subroutine process_configuration_init & - (prc_conf, ci_type, prc_id, model, prt_in, prt_out, method, status, & - restrictions, omega_flags, known_md5sum, omega_openmp, & - nlo_setup) - type(process_configuration_t), intent(inout) :: prc_conf - integer, intent(in) :: ci_type - type(string_t), intent(in) :: prc_id - type(model_t), intent(in), target :: model - type(string_t), dimension(:), intent(in) :: prt_in, prt_out - integer, intent(in), optional :: status - integer, intent(in), optional :: method - type(string_t), intent(in), optional :: restrictions, omega_flags - character(32), intent(in), optional :: known_md5sum - logical, intent(in), optional :: omega_openmp - type(nlo_setup_t), intent(in), optional :: & - nlo_setup - prc_conf%ci_type = ci_type - prc_conf%id = prc_id - prc_conf%model => model - prc_conf%n_in = size (prt_in) - prc_conf%n_out = size (prt_out) - prc_conf%n_tot = prc_conf%n_in + prc_conf%n_out - if (allocated (prc_conf%prt_in)) deallocate (prc_conf%prt_in) - allocate (prc_conf%prt_in (prc_conf%n_in)) - if (allocated (prc_conf%prt_out)) deallocate (prc_conf%prt_out) - allocate (prc_conf%prt_out (prc_conf%n_out)) - prc_conf%prt_in = prt_in - prc_conf%prt_out = prt_out - if (present (status)) then - prc_conf%status = status - else - prc_conf%status = STAT_CONFIGURED - end if - if (present (method)) then - if (method == PRC_SUM) call msg_bug ("process_configuration_init " // & - "called for PRC_SUM") - prc_conf%method = method - else - prc_conf%method = PRC_OMEGA - end if - if (present (restrictions)) then - prc_conf%restrictions = canonicalize_restrictions (restrictions, model) - else - prc_conf%restrictions = "" - end if - if (present (omega_flags)) then - prc_conf%omega_flags = omega_flags - else - prc_conf%omega_flags = "" - end if - if (present (omega_openmp)) then - select case (prc_conf%method) - case (PRC_OMEGA) - prc_conf%omega_openmp = omega_openmp - case default - prc_conf%omega_openmp = .false. - end select - else - prc_conf%omega_openmp = .false. - end if - if (present (known_md5sum)) then - prc_conf%md5sum = known_md5sum - else - call process_configuration_compute_md5sum (prc_conf) - end if - if (present (nlo_setup)) then - prc_conf%nlo_setup = nlo_setup - end if - end subroutine process_configuration_init - -@ %def process_configuration_init -@ -\subsection{Canonicalize particle names} -The [[restrictions]] string can contain particle names, but if it is passed -verbatim to the matrix element generator, only those particles that the latter -knows will be understood. Therefore, we tokenize the string, translate the -particle names, and return the string with translations. -<>= - function canonicalize_restrictions (string, model) result (newstring) - type(string_t) :: newstring - type(string_t), intent(in) :: string - type(model_t), intent(in), target :: model - type(stream_t), target :: stream - type(lexer_t) :: lexer - type(lexeme_t) :: lexeme - type(string_t) :: token - if (string == "") return - if (extract (string, 1, 1) == "!") return - newstring = "!" - call lexer_init (lexer, & - comment_chars = "", & - quote_chars = "'", & - quote_match = "'", & - single_chars = "+~:", & - special_class = (/ "&" /), & - keyword_list = null ()) - call stream_init (stream, string) - call lexer_assign_stream (lexer, stream) - TRANSFORM_TOKENS: do - call lex (lexeme, lexer) - if (lexeme_is_eof (lexeme)) exit TRANSFORM_TOKENS - if (lexeme_is_break (lexeme)) then - call msg_message ("Restriction string = " & - // '"' // char (string) // '"') - call msg_fatal ("Syntax error in restrictions specification") - exit TRANSFORM_TOKENS - end if - token = lexeme_get_contents (lexeme) - select case (lexeme_get_type (lexeme)) - case (T_NUMERIC) - newstring = newstring // token - case (T_IDENTIFIER) - select case (char (extract (token, 1, 1))) - case ("+", "~", "&", ":") - newstring = newstring // token - case default - newstring = newstring // canonicalize_prt (token, model) - end select - case (T_QUOTED) - newstring = newstring // canonicalize_prt (token, model) - case default - call msg_bug ("Token type error in restrictions specification") - end select - end do TRANSFORM_TOKENS - call stream_final (stream) - end function canonicalize_restrictions - -@ %def canonicalize_restrictions -@ Transform a particle string into its flavor code and back; this yields the -canonical name. -<>= - function canonicalize_prt (string, model) result (newstring) - type(string_t) :: newstring - type(string_t), intent(in) :: string - type(model_t), intent(in), target :: model - type(flavor_t) :: flv - integer :: pdg - pdg = model_get_particle_pdg (model, string) - if (pdg == 0) then - call msg_fatal ("Undefined particle in restrictions specification") - end if - call flavor_init (flv, pdg, model) - newstring = flavor_get_name (flv) - end function canonicalize_prt - -@ %def canonicalize_prt -@ -\subsection{Process library data} -This object contains filenames, the complete set of process -configuration data, the C filehandle interface for the shared library, -and procedure pointers for the library functions. - -The contents of this type are public because we do not want to have -another wrapper around the procedure pointer components. - -Note: The procedure pointer [[prc_get_id]] triggers a bug in -nagfor5.2(649) [incorrect C generated], apparently related to the -string argument of this procedure. Fortunately, we can live without -it. -<>= - public :: process_library_t -<>= - type :: process_library_t - ! private - logical :: static = .false. - integer :: status = STAT_UNKNOWN - type(string_t) :: basename - type(string_t) :: srcname - type(string_t) :: libname - integer :: n_prc = 0 - type(process_configuration_t), pointer :: prc_first => null () - type(process_configuration_t), pointer :: prc_last => null () - type(dlaccess_t) :: dlaccess - procedure(prc_get_n_processes), nopass, pointer :: & - get_n_processes => null () - procedure(prc_get_stringptr), nopass, pointer :: & - get_process_id_ptr => null () - procedure(prc_get_stringptr), nopass, pointer :: & - get_model_name_ptr => null () - procedure(prc_get_stringptr), nopass, pointer :: & - get_md5sum_ptr => null () - procedure(prc_get_log), nopass, pointer :: & - get_openmp_status => null () - procedure(prc_get_int), nopass, pointer :: get_n_in => null () - procedure(prc_get_int), nopass, pointer :: get_n_out => null () - procedure(prc_get_int), nopass, pointer :: get_n_flv => null () - procedure(prc_get_int), nopass, pointer :: get_n_hel => null () - procedure(prc_get_int), nopass, pointer :: get_n_col => null () - procedure(prc_get_int), nopass, pointer :: get_n_cin => null () - procedure(prc_get_int), nopass, pointer :: get_n_cf => null () - procedure(prc_set_int_tab1), nopass, pointer :: set_flv_state => null () - procedure(prc_set_int_tab1), nopass, pointer :: set_hel_state => null () - procedure(prc_set_int_tab2), nopass, pointer :: set_col_state => null () - procedure(prc_set_cf_tab), nopass, pointer :: set_color_factors => null () - procedure(prc_get_fptr), nopass, pointer :: & - get_fptr => null() -! procedure(prc_get_int), nopass, pointer :: get_ci_type => null () -! procedure(prclib_unload_hook), nopass, pointer :: unload_hook => null () -! procedure(prclib_reload_hook), nopass, pointer :: reload_hook => null () - end type process_library_t - -@ %def process_library_t -@ Just allocate the configuration array and set filenames, the rest -comes later. Note that because libtool may be used, the actual -[[libname]] can be determined only after the library has been created. -<>= - public :: process_library_init -<>= - subroutine process_library_init (prc_lib, name, os_data) - type(process_library_t), intent(out) :: prc_lib - type(string_t), intent(in) :: name - type(os_data_t), intent(in) :: os_data - prc_lib%basename = name - prc_lib%srcname = name // os_data%fc_src_ext - prc_lib%status = STAT_CONFIGURED - end subroutine process_library_init - -@ %def process_library_init -@ Delete the process configuration list, if any. -<>= - subroutine process_library_clear_configuration (prc_lib) - type(process_library_t), intent(inout) :: prc_lib - type(process_configuration_t), pointer :: current - do while (associated (prc_lib%prc_first)) - current => prc_lib%prc_first - prc_lib%prc_first => current%next - deallocate (current) - end do - prc_lib%prc_last => null () - prc_lib%n_prc = 0 - end subroutine process_library_clear_configuration - -@ %def process_library_clear_configuration -@ Close the library access if it is open. Delete the -process-configuration list. -<>= - public :: process_library_final -<>= - subroutine process_library_final (prc_lib) - type(process_library_t), intent(inout) :: prc_lib - if (.not. prc_lib%static) call dlaccess_final (prc_lib%dlaccess) - call process_library_clear_configuration (prc_lib) - end subroutine process_library_final - -@ %def process_library_final -@ Given a pointer to a library, return the next pointer. -<>= - public :: process_library_advance -<>= - subroutine process_library_advance (prc_lib) - type(process_library_t), pointer :: prc_lib - prc_lib => prc_lib%next - end subroutine process_library_advance - -@ %def process_library_advance -@ Output (called by the 'show' command): -<>= - public :: process_library_write -<>= - subroutine process_library_write (prc_lib, unit) - type(process_library_t), intent(in) :: prc_lib - integer, intent(in), optional :: unit - type(string_t) :: status - type(process_configuration_t), pointer :: current - select case (prc_lib%status) - case (STAT_UNKNOWN) - status = "[unknown]" - case (STAT_CONFIGURED) - status = "[open]" - case (STAT_CODE_GENERATED) - status = "[generated code]" - case (STAT_COMPILED) - status = "[compiled]" - case (STAT_LOADED) - if (prc_lib%static) then - status = "[static]" - else - status = "[loaded]" - end if - end select - call msg_message ("Process library: " // char (prc_lib%basename) & - // " " // char (status), unit) - current => prc_lib%prc_first - do while (associated (current)) - call process_configuration_write (current, unit) - current => current%next - end do - end subroutine process_library_write - -@ %def process_library_write -@ -\subsection{Accessing contents} -Tell/set if the library is static or dynamic -<>= - public :: process_library_set_static - public :: process_library_is_static -<>= - subroutine process_library_set_static (prc_lib, flag) - type(process_library_t), intent(inout) :: prc_lib - logical, intent(in) :: flag - prc_lib%static = flag - end subroutine process_library_set_static - - function process_library_is_static (prc_lib) result (flag) - logical :: flag - type(process_library_t), intent(in) :: prc_lib - flag = prc_lib%static - end function process_library_is_static - -@ %def process_library_set_static -@ %def process_library_is_static -@ Return the nominal compilation status of a library. -<>= - public :: process_library_is_compiled - public :: process_library_is_loaded -<>= - function process_library_is_compiled (prc_lib) result (flag) - logical :: flag - type(process_library_t), intent(in) :: prc_lib - flag = prc_lib%status >= STAT_COMPILED - end function process_library_is_compiled - - function process_library_is_loaded (prc_lib) result (flag) - logical :: flag - type(process_library_t), intent(in) :: prc_lib - flag = prc_lib%status >= STAT_LOADED - end function process_library_is_loaded - -@ %def process_library_is_compiled -@ %def process_library_is_loaded -@ Return the name of a library (the basename). -<>= - public :: process_library_get_name -<>= - function process_library_get_name (prc_lib) result (name) - type(string_t) :: name - type(process_library_t), intent(in) :: prc_lib - name = prc_lib%basename - end function process_library_get_name - -@ %def process_library_get_name -@ Return the number of processes defined so far. -<>= - public :: process_library_get_n_processes -<>= - function process_library_get_n_processes (prc_lib) result (n) - integer :: n - type(process_library_t), intent(in) :: prc_lib - n = prc_lib%n_prc - end function process_library_get_n_processes - -@ %def process_library_get_n_processes -@ Return the pointer to a process with specified tag. -<>= - function process_library_get_process_ptr (prc_lib, prc_id) result (current) - type(process_library_t), intent(in), target :: prc_lib - type(string_t), intent(in) :: prc_id - type(process_configuration_t), pointer :: current - current => prc_lib%prc_first - do while (associated (current)) - if (current%id == prc_id) return - current => current%next - end do - end function process_library_get_process_ptr - -@ %def process_library_get_process_ptr -@ Return the index of a process with specified tag. If the process is -not found, return zero. -<>= - public :: process_library_get_process_index -<>= - function process_library_get_process_index (prc_lib, prc_id) result (index) - integer :: index - type(process_library_t), intent(in), target :: prc_lib - type(string_t), intent(in) :: prc_id - type(process_configuration_t), pointer :: current - index = 0 - current => prc_lib%prc_first - do while (associated (current)) - index = index + 1 - if (current%id == prc_id) return - current => current%next - end do - index = 0 - end function process_library_get_process_index - -@ %def process_library_get_process_index -@ -Query the core interaction type of a process. -<>= - public :: process_library_get_ci_type -<>= - function process_library_get_ci_type (prc_lib, prc_id) result (id) - type(process_library_t), intent(in), target :: prc_lib - type(string_t), intent(in) :: prc_id - integer :: id - type(process_configuration_t), pointer :: current - current => prc_lib%prc_first - do while (associated (current)) - if (current%id == prc_id) then - id = current%ci_type - return - end if - current => current%next - end do - id = -1 - end function process_library_get_ci_type - -@ %def process_library_get_ci_type -@ -Get the children of a process sum. -<>= - public :: process_library_get_sum_child -<>= - function process_library_get_sum_child (prc_lib, id, i) result (child) - type(process_library_t), intent(in), target :: prc_lib - type(string_t), intent(in) :: id - integer, intent(in) :: i - type(string_t) :: child - type(process_configuration_t), pointer :: current - child = "" - current => prc_lib%prc_first - do while (associated (current)) - if (current%id == id) then - if (current%method == PRC_SUM) then - select case (i) - case (1); child = current%child1 - case (2); child = current%child2 - end select - end if - return - end if - current => current%next - end do - end function process_library_get_sum_child -@ %def process_library_get_sum_child -@ -Apply a nlo setup list. -<>= - public :: process_library_apply_nlo_setup -<>= - subroutine process_library_apply_nlo_setup (prc_lib, prc_id, setup) - type(process_library_t), intent(inout), target :: prc_lib - type(string_t), intent(in) :: prc_id - type(nlo_setup_list_t), intent(in) :: setup - type(process_configuration_t), pointer :: process - process => prc_lib%prc_first - do while (associated (process)) - if (process%id == prc_id) exit - process => process%next - end do - if (.not. associated (process)) then - call msg_bug ("process_library_apply_nlo_setup called on " & - // "nonexisting process. This is a BUG.") - end if - call nlo_setup_apply_list (process%nlo_setup, setup) - end subroutine process_library_apply_nlo_setup - -@ %def process_library_apply_nlo_setup. -@ - -Retrieve the dipole config. -<>= - public :: process_library_get_nlo_setup -<>= -function process_library_get_nlo_setup (prc_lib, prc_id) result (config) -type(process_library_t), intent(in), target :: prc_lib -type(string_t), intent(in) :: prc_id -type(nlo_setup_t) :: config -type(process_configuration_t), pointer :: process - process => prc_lib%prc_first - do while (associated (process)) - if (process%id == prc_id) exit - process => process%next - end do - if (.not. associated (process)) call msg_bug ( & - "process_library_get_nlo_setup called on nonexisting process. " & - // "This is a BUG.") - config = process%nlo_setup -end function process_library_get_nlo_setup -@ %def process_library_get_nlo_setup -@ - -\subsection{Creating a process library} -Configure a specific process in the list. First check if the process -exists, then either edit the existing process configuration or initiate -a new one. If a status is given, mark the process configuration -accordingly. Overwrite any existing configuration for the given -process ID. If the [[rebuild_library]] flag is set, do this silently and -reset the status. If it is absent or unset, we want to keep the old -configuration as far as possible. If the checksum has changed issue a -warning that the configuration was overwritten. If the old status was -higher, keep it. -<>= - public :: process_library_append -<>= - subroutine process_library_append & - (prc_lib, ci_type, prc_id, model, prt_in, prt_out, method, & - status, restrictions, omega_flags, & - rebuild_library, message, known_md5sum, & - omega_openmp, nlo_setup) - type(process_library_t), intent(inout), target :: prc_lib - integer, intent(in) :: ci_type - type(string_t), intent(in) :: prc_id - type(model_t), intent(in), target :: model - type(string_t), dimension(:), intent(in) :: prt_in, prt_out - integer, intent(in), optional :: status, method - type(string_t), intent(in), optional :: restrictions, omega_flags - logical, intent(in), optional :: rebuild_library, message, omega_openmp - character(32), intent(in), optional :: known_md5sum - type(nlo_setup_t), intent(in), optional :: nlo_setup - type(process_configuration_t), pointer :: current - character(32) :: old_md5sum - integer :: old_status, old_ci_type - logical :: keep_status - logical :: msg - logical :: old_omega_openmp, new_omega_openmp - keep_status = .true. - if (present (rebuild_library)) keep_status = .not. rebuild_library - msg = .false.; if (present (message)) msg = message - if (.not. present (method)) then - new_omega_openmp = omega_openmp - else - select case (method) - case (PRC_OMEGA) - new_omega_openmp = omega_openmp - case default - new_omega_openmp = .false. - end select - end if - current => process_library_get_process_ptr (prc_lib, prc_id) - if (associated (current)) then - old_md5sum = current%md5sum - old_status = current%status - old_omega_openmp = current%omega_openmp - old_ci_type = current%ci_type - if (present (nlo_setup)) then - call process_configuration_init & - (current, ci_type, prc_id, model, prt_in, prt_out, method, status, & - restrictions, omega_flags, known_md5sum, new_omega_openmp, & - nlo_setup) - else - call process_configuration_init & - (current, ci_type, prc_id, model, prt_in, prt_out, method, status, & - restrictions, omega_flags, known_md5sum, new_omega_openmp, & - current%nlo_setup) - end if - if (size (prt_in) == 0) then - call msg_warning ("Process '" // char (prc_id) & - // "': matrix element vanishes in selected model '" & - // char (model_get_name (model)) // "'") - else if (keep_status) then - if ((current%md5sum == old_md5sum) .and. & - (old_omega_openmp .eqv. new_omega_openmp) .and. & - (old_ci_type == ci_type)) then - if (current%status <= old_status) then - call msg_message ("Process '" // char (prc_id) & - // "': keeping configuration") - current%status = old_status - else - call msg_message ("Process '" // char (prc_id) & - // "': updating configuration") - end if - else - call msg_warning ("Process '" // char (prc_id) & - // "': configuration changed, overwriting.") - end if - else - if ((current%md5sum /= old_md5sum) .or. & - (current%omega_openmp .neqv. old_omega_openmp)) then - call msg_message ("Process '" // char (prc_id) & - // "': ignoring previous configuration") - end if - end if - else - allocate (current) - if (associated (prc_lib%prc_last)) then - prc_lib%prc_last%next => current - else - prc_lib%prc_first => current - end if - prc_lib%prc_last => current - prc_lib%n_prc = prc_lib%n_prc + 1 - call process_library_check_name_consistency (prc_id, prc_lib) - call process_configuration_init & - (current, ci_type, prc_id, model, prt_in, prt_out, method, status, & - restrictions, omega_flags, known_md5sum, new_omega_openmp, & - nlo_setup) - call process_update_code_status (current, keep_status) - if (msg) call msg_message & - ("Added process to library '" // char (prc_lib%basename) // "':") - end if - if (msg) call process_configuration_write (current) - end subroutine process_library_append - -@ %def process_library_append -The same, but for a [[PRC_SUM]] type stub proces. -<>= - public :: process_library_append_prc_sum -<>= - subroutine process_library_append_prc_sum & - (prc_lib, proc_id, child1, child2, nlo_setup, message) - type(process_library_t), intent(inout), target :: prc_lib - type(string_t), intent(in) :: proc_id - type(string_t), intent(in), optional :: child1, child2 - type(nlo_setup_t), intent(in), optional :: nlo_setup - logical, intent(in), optional :: message - logical :: msg - type(process_configuration_t), pointer :: current - msg = .false.; if (present (message)) msg = message - current => process_library_get_process_ptr (prc_lib, proc_id) - if (associated (current)) then - call process_configuration_init_sum (current, proc_id, child1, child2, & - nlo_setup) - else - allocate (current) - if (associated (prc_lib%prc_last)) then - prc_lib%prc_last%next => current - else - prc_lib%prc_first => current - end if - prc_lib%prc_last => current - prc_lib%n_prc = prc_lib%n_prc + 1 - call process_library_check_name_consistency (proc_id, prc_lib) - call process_configuration_init_sum & - (current, proc_id, child1, child2, nlo_setup) - if (msg) call msg_message & - ("Added process to library '" // char (prc_lib%basename) // "':") - end if - if (msg) call process_configuration_write (current) - end subroutine process_library_append_prc_sum - -@ %def process_library_append_prc_sum - -@ Look for an existing file for the current process and its MD5 -signature. If successful and a rebuild flag is set, reset the status -to [[STAT_CODE_GENERATED]]. Otherwise, just issue appropriate -diagnostic messages. -<>= - subroutine process_update_code_status (prc_conf, keep_status) - type(process_configuration_t), intent(inout) :: prc_conf - logical, intent(in) :: keep_status - type(string_t) :: filename - logical :: exist, found - integer :: u, iostat - character(80) :: buffer - character(32) :: md5sum - logical :: omega_openmp - if (prc_conf%method == PRC_SUM) return - filename = prc_conf%id // ".f90" - inquire (file=char(filename), exist=exist) - if (exist) then - found = .false. - u = free_unit () - omega_openmp = .false. - open (u, file=char(filename), action="read") - SCAN_FILE: do - read (u, "(A)", iostat=iostat) buffer - select case (iostat) - case (0) - if (buffer(1:12) == " md5sum =") then - md5sum = buffer(15:47) - found = .true. - end if - if (buffer(1:5) == "!$OMP") omega_openmp = .true. ! $ - case default - exit SCAN_FILE - end select - end do SCAN_FILE - close (u) - if (found) then - if (keep_status) then - if (prc_conf%status < STAT_CODE_GENERATED) then - if ((md5sum == prc_conf%md5sum) .and. & - (omega_openmp .eqv. prc_conf%omega_openmp)) then - call msg_message ("Process '" // char (prc_conf%id) & - // "': using existing source code") - prc_conf%status = STAT_CODE_GENERATED - else - call msg_warning ("Process '" // char (prc_conf%id) & - // "': will overwrite existing source code") - end if - else if ((md5sum /= prc_conf%md5sum) .or. & - (omega_openmp .neqv. prc_conf%omega_openmp)) then - call msg_warning ("Process '" // char (prc_conf%id) & - // "': source code and loaded checksums differ") - end if - else if (prc_conf%status < STAT_CODE_GENERATED) then - call msg_message ("Process '" // char (prc_conf%id) & - // "': ignoring existing source code") - end if - else - call msg_warning ("Process '" // char (prc_conf%id) & - // "': No MD5 sum found in source code") - end if - end if - end subroutine process_update_code_status - -@ %def source_code_exists -@ Check whether all processes in the current library are configured, -compiled and loaded, and update the library status accordingly. - -If the library needs recompilation, unload it now if necessary. -<>= - public :: process_library_update_status -<>= - subroutine process_library_update_status (prc_lib) - type(process_library_t), intent(inout), target :: prc_lib - type(process_configuration_t), pointer :: prc_conf - integer :: initial_status - initial_status = prc_lib%status - prc_conf => prc_lib%prc_first - do while (associated (prc_conf)) - if (prc_conf%method /= PRC_SUM) & - prc_lib%status = min (prc_lib%status, prc_conf%status) - prc_conf => prc_conf%next - end do - if (initial_status == STAT_LOADED .and. prc_lib%status < STAT_LOADED) & - call process_library_unload (prc_lib) - end subroutine process_library_update_status - -@ %def process_library_update_status -@ Recover process configuration from a loaded library. Existing -configurations for processes present in the loaded library will be -overwritten. If the process is a process sum, we add it to the process library -without specifying the child processes; the process definitions in SINDARIN will -later add those with the proper values. Return the pointer to the model -appropriate for the loaded library. -<>= - subroutine process_library_load_configuration & - (prc_lib, os_data, model) - type(process_library_t), intent(inout), target :: prc_lib - type(os_data_t), intent(in) :: os_data - type(model_t), pointer :: model - integer :: n_prc, p, n_flv, n_in, n_out, n_tot, i - integer(c_int) :: pid - integer, dimension(:,:), allocatable :: flv_state - integer(c_int), dimension(:,:), allocatable, target :: flv_state_tmp - type(string_t) :: prc_id, model_name, filename, restrictions, omega_flags - type(string_t), dimension(:), allocatable :: prt_in, prt_out - logical :: omega_openmp - character(32) :: md5sum - integer :: ci_type - n_prc = prc_lib% get_n_prc () - SCAN_PROCESSES: do p = 1, n_prc - pid = p - ci_type = prc_lib%get_ci_type (pid) - prc_id = process_library_get_process_id (prc_lib, pid) - if (ci_type == CI_SUM) then - call process_library_append_prc_sum (prc_lib, prc_id) - cycle - end if - md5sum = process_library_get_process_md5sum (prc_lib, pid) - model_name = process_library_get_process_model_name (prc_lib, pid) - restrictions = process_library_get_process_restrictions (prc_lib, pid) - omega_flags = process_library_get_process_omega_flags (prc_lib, pid) - omega_openmp = process_library_get_openmp_status (prc_lib, pid) - filename = model_name // ".mdl" - model => null () - call model_list_read_model (model_name, filename, os_data, model) - if (.not. associated (model)) then - call msg_error ("Process library '" // char (prc_lib%basename) & - // "', process '" // char (prc_id) // "': " & - // "model unavailable, process skipped") - cycle SCAN_PROCESSES - end if - n_in = prc_lib% get_n_in (pid) - n_out = prc_lib% get_n_out (pid) - n_tot = n_in + n_out - n_flv = prc_lib% get_n_flv (pid) - allocate (flv_state (n_tot, n_flv)) - allocate (flv_state_tmp (n_tot, n_flv)) - allocate (prt_in (n_in )) - allocate (prt_out (n_out)) - call prc_lib% set_flv_state (pid, & - c_loc (flv_state_tmp), & - int((/n_tot, n_flv/), kind=c_int)) - flv_state = flv_state_tmp - do i = 1, n_in - prt_in(i) = particle_name_string (flv_state (i, :), model) - end do - do i = 1, n_out - prt_out(i) = particle_name_string (flv_state (n_in+i, :), model) - end do - call process_library_append & - (prc_lib, ci_type, prc_id, model, prt_in, prt_out, & - status=STAT_LOADED, & - restrictions=restrictions, omega_flags=omega_flags, & - known_md5sum=md5sum, omega_openmp=omega_openmp) - deallocate (prt_in, prt_out, flv_state, flv_state_tmp) - end do SCAN_PROCESSES - contains - function particle_name_string (ff, model) result (prt) - type(string_t) :: prt - integer, dimension(:), intent(in) :: ff - type(model_t), intent(in), target :: model - type(flavor_t) :: flv - integer :: i - prt = "" - do i = 1, size (ff) - if (all (ff(i) /= ff(:i-1))) then - call flavor_init (flv, ff(i), model) - if (prt /= "") prt = prt // ":" - prt = prt // flavor_get_name (flv) - end if - end do - end function particle_name_string - end subroutine process_library_load_configuration - -@ %def process_library_load_configuration -<>= - public :: process_library_get_process_id - public :: process_library_get_process_pid - public :: process_library_get_process_md5sum - public :: process_library_get_process_model_name - public :: process_library_get_openmp_status -<>= - function process_library_get_process_id (prc_lib, pid) result (process_id) - type(string_t) :: process_id - type(process_library_t), intent(in), target :: prc_lib - integer(c_int), intent(in) :: pid - type(c_ptr) :: cptr - integer(c_int) :: len - character(kind=c_char), dimension(:), pointer :: char_array - integer, dimension(1) :: shape - call prc_lib% get_process_id (pid, cptr, len) - if (c_associated (cptr)) then - shape(1) = len - call c_f_pointer (cptr, char_array, shape) - process_id = char_from_array (char_array) - call prc_lib% get_process_id (0_c_int, cptr, len) - else - process_id = "" - end if - end function process_library_get_process_id - - function process_library_get_process_pid (prc_lib, id) result (process_pid) - type(process_library_t), intent(in) :: prc_lib - type(string_t), intent(in) :: id - integer :: process_pid, pid, n_proc - process_pid = -1 - n_proc = process_library_get_n_processes (prc_lib) - if (n_proc <= 0) return - do pid = 1, n_proc - if (process_library_get_process_id (prc_lib, pid) == id) then - process_pid = pid - return - end if - end do - end function process_library_get_process_pid - - function process_library_get_process_model_name & - (prc_lib, pid) result (model_name) - type(string_t) :: model_name - type(process_library_t), intent(in), target :: prc_lib - integer(c_int), intent(in) :: pid - type(c_ptr) :: cptr - integer(c_int) :: len - character(kind=c_char), dimension(:), pointer :: char_array - integer, dimension(1) :: shape - call prc_lib% get_model_name (pid, cptr, len) - if (c_associated (cptr)) then - shape(1) = len - call c_f_pointer (cptr, char_array, shape) - model_name = char_from_array (char_array) - call prc_lib% get_model_name (0_c_int, cptr, len) - else - model_name = "" - end if - end function process_library_get_process_model_name - - function process_library_get_process_restrictions & - (prc_lib, pid) result (restrictions) - type(string_t) :: restrictions - type(process_library_t), intent(in), target :: prc_lib - integer(c_int), intent(in) :: pid - type(c_ptr) :: cptr - integer(c_int) :: len - character(kind=c_char), dimension(:), pointer :: char_array - integer, dimension(1) :: shape - call prc_lib% get_restrictions (pid, cptr, len) - if (c_associated (cptr)) then - shape(1) = len - call c_f_pointer (cptr, char_array, shape) - restrictions = char_from_array (char_array) - call prc_lib% get_restrictions (0_c_int, cptr, len) - else - restrictions = "" - end if - end function process_library_get_process_restrictions - - function process_library_get_process_omega_flags & - (prc_lib, pid) result (omega_flags) - type(string_t) :: omega_flags - type(process_library_t), intent(in), target :: prc_lib - integer(c_int), intent(in) :: pid - type(c_ptr) :: cptr - integer(c_int) :: len - character(kind=c_char), dimension(:), pointer :: char_array - integer, dimension(1) :: shape - call prc_lib% get_omega_flags (pid, cptr, len) - if (c_associated (cptr)) then - shape(1) = len - call c_f_pointer (cptr, char_array, shape) - omega_flags = char_from_array (char_array) - call prc_lib% get_omega_flags (0_c_int, cptr, len) - else - omega_flags = "" - end if - end function process_library_get_process_omega_flags - - function process_library_get_openmp_status & - (prc_lib, pid) result (openmp_status) - type(process_library_t), intent(in), target :: prc_lib - integer(c_int), intent(in) :: pid - logical :: openmp_status - type(c_ptr) :: cptr - openmp_status = prc_lib%get_openmp_status (pid) - end function process_library_get_openmp_status - - recursive function process_library_get_process_md5sum & - (prc_lib, pid) result (md5sum) - type(string_t) :: md5sum - type(process_library_t), intent(in), target :: prc_lib - integer(c_int), intent(in) :: pid - type(c_ptr) :: cptr - integer(c_int) :: len - character(kind=c_char), dimension(:), pointer :: char_array - integer, dimension(1) :: shape - type(process_configuration_t), pointer :: current - integer :: i - md5sum = "" - if (prc_lib%get_ci_type (pid) == CI_SUM) then - current => prc_lib%prc_first - do i = 1, pid - 1 - if (associated (current)) current => current%next - end do - if (associated (current)) md5sum = & - process_configuration_prc_sum_md5sum (current, prc_lib) - return - end if - call prc_lib% get_md5sum (pid, cptr, len) - if (c_associated (cptr)) then - shape(1) = len - call c_f_pointer (cptr, char_array, shape) - md5sum = char_from_array (char_array) - call prc_lib% get_md5sum (0_c_int, cptr, len) - end if - end function process_library_get_process_md5sum -@ %def process_library_get_process_id -@ %def process_library_get_process_model_name -@ %def process_library_get_process_restrictions -@ %def process_library_get_process_omega_flags -@ %def process_library_get_process_md5sum -@ %def process_library_get_process_pid -@ %def process_library_get_openmp_status -@ Auxiliary: Transform a character array into a character string. -<>= - function char_from_array (a) result (char) - character(kind=c_char), dimension(:), intent(in) :: a - character(len=size(a)) :: char - integer :: i - do i = 1, len (char) - char(i:i) = a(i) - end do - end function char_from_array - -@ %def char_from_array -@ Generate process source code. Do this for all processes which have -just been configured, unless there is a source-code file with -identical MD5sum. -<>= - public :: process_library_generate_code -<>= - subroutine process_library_generate_code (prc_lib, os_data, simulate) - type(process_library_t), intent(in) :: prc_lib - type(os_data_t), intent(in) :: os_data - logical, intent(in), optional :: simulate - type(process_configuration_t), pointer :: current - integer :: status - call msg_message ("Generating code for process library '" & - // char (process_library_get_name (prc_lib)) // "'") - current => prc_lib%prc_first - SCAN_PROCESSES: do while (associated (current)) - select case (current%status) - case (STAT_CONFIGURED) - select case (current%method) - case (PRC_OMEGA) - call call_omega (current, os_data, status, simulate) - if (status == 0) then - current%status = STAT_CODE_GENERATED - else - call msg_error ("Process '" // char (current%id) & - // "': code generation failed") - end if - case (PRC_TEST) - call write_unit_matrix_element (current, os_data, status, unit=.false.) - if (status == 0) then - current%status = STAT_CODE_GENERATED - else - call msg_error ("Process '" // char (current%id) & - // "': code generation failed") - end if - case (PRC_UNIT) - call write_unit_matrix_element (current, os_data, status, unit=.true.) - if (status == 0) then - current%status = STAT_CODE_GENERATED - else - call msg_error ("Process '" // char (current%id) & - // "': code generation failed") - end if - case default - call msg_fatal ("These methods are not yet implemented.") - end select - case (STAT_CODE_GENERATED:) - call msg_message ("Skipping process '" // char (current%id) & - // "' (source code exists)") - case default - call msg_message ("Skipping process '" // char (current%id) & - // "' (undefined configuration)") - end select - current => current%next - end do SCAN_PROCESSES - end subroutine process_library_generate_code - -@ %def process_library_generate_code -@ Call \oMega\ for process-code generation. -<>= - subroutine call_omega (prc_conf, os_data, status, simulate) - type(process_configuration_t), intent(in) :: prc_conf - type(os_data_t), intent(in) :: os_data - integer, intent(out) :: status - logical, intent(in), optional :: simulate - type(string_t) :: command_string, binary_name - type(string_t) :: model_id, omega_mode, omega_cascade, omega_kmatrix, & - omega_openmp - integer :: j - logical :: sim, binary_found - sim = .false.; if (present (simulate)) sim = simulate - call msg_message ("Calling O'Mega for process '" & - // char (prc_conf%id) // "'") - model_id = model_get_name (prc_conf%model) - binary_name = "omega_" // model_id // ".opt" - binary_found = .false. - select case (char (model_id)) - case ("SM_km") - omega_kmatrix = " -target:kmatrix_write" - case default - omega_kmatrix = "" - end select - if (prc_conf%omega_openmp) then - omega_openmp = " -target:openmp " - call msg_message ("Enabling OpenMP support in O'Mega") -! call msg_message ("WARNING: enabling OpenMP support in O'Mega --- " & -! // "make sure that _both_ ") -! call msg_message (" WHIZARD _and_ the matrix element are compiled with " & -! // "the proper OpenMP compiler flags.") -! call msg_message (" Be prepared for broken results if you compile only " & -! // " the matrix element with OpenMP flags.") - else - omega_openmp = "" - end if - if (.not. os_data%use_testfiles) then - command_string = os_data%whizard_omega_binpath_local & - // "/" // binary_name - inquire (file=char (command_string), exist=binary_found) - end if - if (.not. binary_found) then - command_string = os_data%whizard_omega_binpath // "/" // binary_name - inquire (file=char (command_string), exist=binary_found) - end if - if (.not. binary_found) & - call msg_fatal ("O'Mega binary """ // char (binary_name) // """ not found") - select case (prc_conf%n_in) - case (1); omega_mode = "-decay" - case (2); omega_mode = "-scatter" - end select - if (prc_conf%restrictions == "") then - omega_cascade = "" - else if (extract (prc_conf%restrictions, 1, 1) == "!") then - omega_cascade = " -cascade '" & - // extract (prc_conf%restrictions, 2) // "'" - else - omega_cascade = " -cascade '" // prc_conf%restrictions // "'" - end if - command_string = command_string & - // " -o " // prc_conf%id // ".f90" & - // " -target:whizard" & - // " -target:parameter_module parameters_" // model_id & - // " -target:module opr_" // prc_conf%id & - // omega_kmatrix // omega_openmp & - // " -target:md5sum " // prc_conf%md5sum & - // omega_cascade & - // " -fusion:progress" & - // " " // prc_conf%omega_flags & - // " " // omega_mode - command_string = command_string // " " - do j = 1, prc_conf%n_in - if (j == 1) then - command_string = command_string // "'" - else - command_string = command_string // " " - end if - command_string = command_string // prc_conf%prt_in(j) - end do - command_string = command_string // " ->" - do j = 1, prc_conf%n_out - command_string = command_string & - // " " // prc_conf%prt_out(j) - end do - command_string = command_string // "'" - if (sim) then - command_string = "cp " // os_data%whizard_testdatapath // "/" & - // prc_conf%id // ".f90 ." - call msg_message ("[call not executed, instead: copy file from " & - // char (os_data%whizard_testdatapath) // "]") - end if - call os_system_call (command_string, status, verbose=.true.) - end subroutine call_omega - -@ %def call_omega -@ -\subsection{Interface file for the generated modules} -<>= - public :: process_library_write_driver -<>= - subroutine process_library_write_driver (prc_lib) - - type(process_library_t), intent(inout) :: prc_lib - type(string_t) :: filename, prefix - type(string_t), dimension(:), allocatable :: prc_id, mod_prc_id, model - type(string_t), dimension(:), allocatable :: restrictions, omega_flags - integer, dimension(:), allocatable :: n_par, ci_type - logical, dimension(:), allocatable :: virtual - character(32), dimension(:), allocatable :: md5sum - type(process_configuration_t), pointer :: current - integer :: u, i, n_prc - - call msg_message ("Writing interface code for process library '" // & - char (process_library_get_name (prc_lib)) // "'") - prefix = prc_lib%basename // "_" - - n_prc = prc_lib%n_prc - allocate (prc_id (n_prc), mod_prc_id (n_prc), model (n_prc)) - allocate (restrictions (n_prc), omega_flags (n_prc)) - allocate (n_par (n_prc), md5sum (n_prc), ci_type (n_prc)) - allocate (virtual(n_prc)) - current => prc_lib%prc_first - do i = 1, n_prc - ci_type(i) = current%ci_type - prc_id(i) = current%id - if (current%method == PRC_SUM) then - virtual(i) = .true. - current => current%next - cycle - end if - virtual(i) = .false. - mod_prc_id(i) = & - process_library_get_module_name (current%id,current%method) - model(i) = model_get_name (current%model) - restrictions(i) = current%restrictions - omega_flags(i) = current%omega_flags - n_par(i) = model_get_n_parameters (current%model) - md5sum(i) = current%md5sum - current => current%next - end do - filename = prc_lib%basename // "_interface.f90" - u = free_unit () - open (unit=u, file=char(prc_lib%basename // ".f90"), action="write") - write (u, "(A)") "! WHIZARD process interface" - write (u, "(A)") "!" - write (u, "(A)") "! Automatically generated file, do not edit" - call write_get_n_processes_fun () - call write_get_process_id_fun () - call write_get_model_name_fun () - call write_get_restrictions_fun () - call write_get_omega_flags_fun () - call write_get_openmp_status_fun () - call write_get_md5sum_fun () - call write_string_to_array_fun () - call write_get_int_fun ("n_in", "number_particles_in") - call write_get_int_fun ("n_out", "number_particles_out") - call write_get_int_fun ("n_flv", "number_flavor_states") - call write_get_int_fun ("n_hel", "number_spin_states") - call write_get_int_fun ("n_col", "number_color_flows") - call write_get_int_fun ("n_cin", "number_color_indices") - call write_get_int_fun ("n_cf", "number_color_factors") - call write_set_int_sub1 ("flv_state", "flavor_states") - call write_set_int_sub1 ("hel_state", "spin_states") - call write_set_int_sub2 ("col_state", "color_flows", "ghost_flag") - call write_set_cf_tab_sub () - call write_init_get_fptr () - call write_final_get_fptr () - call write_update_alpha_s_get_fptr () - call write_reset_helicity_selection_get_fptr () - call write_new_event_get_fptr () - call write_is_allowed_get_fptr () - call write_get_amplitude_get_fptr () - call write_get_ci_type - close (u) - - prc_lib%status = max (prc_lib%status, STAT_CODE_GENERATED) - - contains - - function logical_to_string (flag) result (str) - logical, intent(in) :: flag - type(string_t) :: str - if (flag) then - str = ".true." - else - str = ".false." - end if - end function logical_to_string - - subroutine write_get_n_processes_fun () - write (u, "(A)") "" - write (u, "(A)") "! Return the number of processes in this library" - write (u, "(A)") "function " // char (prefix) & - // "get_n_processes () result (n) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int) :: n" - write (u, "(A,I0)") " n = ", n_prc - write (u, "(A)") "end function " // char (prefix) & - // "get_n_processes" - end subroutine write_get_n_processes_fun - - subroutine write_get_process_id_fun () - write (u, "(A)") "" - write (u, "(A)") "! Return the process ID of process #i (as a C pointer to a character array)" - write (u, "(A)") "subroutine " // char (prefix) & - // "get_process_id (i, cptr, len) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: i" - write (u, "(A)") " type(c_ptr), intent(inout) :: cptr" - write (u, "(A)") " integer(c_int), intent(out) :: len" - write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a" - call write_string_to_array_interface () - write (u, "(A)") " select case (i)" - write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)" - do i = 1, n_prc - write (u, "(A,I0,A)") " case (", i, "); " & - // "call " // char (prefix) & - // "string_to_array ('" // char (prc_id(i)) // "', a)" - end do - write (u, "(A)") " end select" - write (u, "(A)") " if (allocated (a)) then" - write (u, "(A)") " cptr = c_loc (a)" - write (u, "(A)") " len = size (a)" - write (u, "(A)") " else" - write (u, "(A)") " cptr = c_null_ptr" - write (u, "(A)") " len = 0" - write (u, "(A)") " end if" - write (u, "(A)") "end subroutine " // char (prefix) & - // "get_process_id" - end subroutine write_get_process_id_fun - - subroutine write_get_model_name_fun () - write (u, "(A)") "" - write (u, "(A)") "! Return the model name for process #i (as a C pointer to a character array)" - write (u, "(A)") "subroutine " // char (prefix) & - // "get_model_name (i, cptr, len) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: i" - write (u, "(A)") " type(c_ptr), intent(inout) :: cptr" - write (u, "(A)") " integer(c_int), intent(out) :: len" - write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a" - call write_string_to_array_interface () - write (u, "(A)") " select case (i)" - write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(A,I0,A)") " case (", i, "); " & - // "call " // char (prefix) & - // "string_to_array ('" // char (model(i)) // "', a)" - end do - write (u, "(A)") " end select" - write (u, "(A)") " if (allocated (a)) then" - write (u, "(A)") " cptr = c_loc (a)" - write (u, "(A)") " len = size (a)" - write (u, "(A)") " else" - write (u, "(A)") " cptr = c_null_ptr" - write (u, "(A)") " len = 0" - write (u, "(A)") " end if" - write (u, "(A)") "end subroutine " // char (prefix) & - // "get_model_name" - end subroutine write_get_model_name_fun - - subroutine write_get_restrictions_fun () - write (u, "(A)") "" - write (u, "(A)") "! Return the restriction string process #i (as a C pointer to a character array)" - write (u, "(A)") "subroutine " // char (prefix) & - // "get_restrictions (i, cptr, len) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: i" - write (u, "(A)") " type(c_ptr), intent(inout) :: cptr" - write (u, "(A)") " integer(c_int), intent(out) :: len" - write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a" - call write_string_to_array_interface () - write (u, "(A)") " select case (i)" - write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(A,I0,A)") " case (", i, "); " & - // "call " // char (prefix) & - // "string_to_array ('" // char (restrictions(i)) // "', a)" - end do - write (u, "(A)") " end select" - write (u, "(A)") " if (allocated (a)) then" - write (u, "(A)") " cptr = c_loc (a)" - write (u, "(A)") " len = size (a)" - write (u, "(A)") " else" - write (u, "(A)") " cptr = c_null_ptr" - write (u, "(A)") " len = 0" - write (u, "(A)") " end if" - write (u, "(A)") "end subroutine " // char (prefix) & - // "get_restrictions" - end subroutine write_get_restrictions_fun - - subroutine write_get_omega_flags_fun () - write (u, "(A)") "" - write (u, "(A)") "! Return the omega flags for process #i (as a C pointer to a character array)" - write (u, "(A)") "subroutine " // char (prefix) & - // "get_omega_flags (i, cptr, len) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: i" - write (u, "(A)") " type(c_ptr), intent(inout) :: cptr" - write (u, "(A)") " integer(c_int), intent(out) :: len" - write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a" - call write_string_to_array_interface () - write (u, "(A)") " select case (i)" - write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(A,I0,A)") " case (", i, "); " & - // "call " // char (prefix) & - // "string_to_array ('" // char (omega_flags(i)) // "', a)" - end do - write (u, "(A)") " end select" - write (u, "(A)") " if (allocated (a)) then" - write (u, "(A)") " cptr = c_loc (a)" - write (u, "(A)") " len = size (a)" - write (u, "(A)") " else" - write (u, "(A)") " cptr = c_null_ptr" - write (u, "(A)") " len = 0" - write (u, "(A)") " end if" - write (u, "(A)") "end subroutine " // char (prefix) & - // "get_omega_flags" - end subroutine write_get_omega_flags_fun - - subroutine write_get_openmp_status_fun () - write (u, "(A)") "" - write (u, "(A)") "! Return the OpenMP support status" - write (u, "(A)") "function " // char (prefix) & - // "get_openmp_status (i) result (openmp_status) bind(C)" - write (u, "(A)") " use iso_c_binding" - call write_use_lines ("openmp_supported", "openmp_supported") - write (u, "(A)") " integer(c_int), intent(in) :: i" - write (u, "(A)") " logical(c_bool) :: openmp_status" - write (u, "(A)") " select case (i)" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(A,I0,A)") " case (", i, "); " & - // "openmp_status = " // char (prc_id(i)) // "_openmp_supported ()" - end do - write (u, "(A)") " end select" - write (u, "(A)") "end function " // char (prefix) & - // "get_openmp_status" - end subroutine write_get_openmp_status_fun - - subroutine write_get_md5sum_fun () - integer :: i - write (u, "(A)") "" - write (u, "(A)") "! Return the MD5 sum for the process configuration (as a C pointer to a character array)" - write (u, "(A)") "subroutine " // char (prefix) & - // "get_md5sum (i, cptr, len) bind(C)" - write (u, "(A)") " use iso_c_binding" - call write_use_lines ("md5sum", "md5sum") - write (u, "(A)") " integer(c_int), intent(in) :: i" - write (u, "(A)") " type(c_ptr), intent(inout) :: cptr" - write (u, "(A)") " integer(c_int), intent(out) :: len" - write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, target, save :: a" - call write_string_to_array_interface () - write (u, "(A)") " select case (i)" - write (u, "(A)") " case (0); if (allocated (a)) deallocate (a)" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(A,I0,A)") " case (", i, "); " & - // "call " // char (prefix) & - // "string_to_array (" // char (prc_id(i)) & - // "_md5sum (), a)" - end do - write (u, "(A)") " end select" - write (u, "(A)") " if (allocated (a)) then" - write (u, "(A)") " cptr = c_loc (a)" - write (u, "(A)") " len = size (a)" - write (u, "(A)") " else" - write (u, "(A)") " cptr = c_null_ptr" - write (u, "(A)") " len = 0" - write (u, "(A)") " end if" - write (u, "(A)") "end subroutine " // char (prefix) & - // "get_md5sum" - end subroutine write_get_md5sum_fun - - subroutine write_string_to_array_interface () - write (u, "(2x,A)") "interface" - write (u, "(5x,A)") "subroutine " // char (prefix) & - // "string_to_array (string, a)" - write (u, "(5x,A)") " use iso_c_binding" - write (u, "(5x,A)") " character(*), intent(in) :: string" - write (u, "(5x,A)") " character(kind=c_char), dimension(:), allocatable, intent(out) :: a" - write (u, "(5x,A)") "end subroutine " // char (prefix) & - // "string_to_array" - write (u, "(2x,A)") "end interface" - end subroutine write_string_to_array_interface - - subroutine write_string_to_array_fun () - write (u, "(A)") "" - write (u, "(A)") "! Auxiliary: convert character string to array pointer" - write (u, "(A)") "subroutine " // char (prefix) & - // "string_to_array (string, a)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " character(*), intent(in) :: string" - write (u, "(A)") " character(kind=c_char), dimension(:), allocatable, intent(out) :: a" - write (u, "(A)") " integer :: i" - write (u, "(A)") " allocate (a (len (string)))" - write (u, "(A)") " do i = 1, size (a)" - write (u, "(A)") " a(i) = string(i:i)" - write (u, "(A)") " end do" - write (u, "(A)") "end subroutine " // char (prefix) & - // "string_to_array" - end subroutine write_string_to_array_fun - - subroutine write_get_int_fun (vname, fname) - character(*), intent(in) :: vname, fname - write (u, "(A)") "" - write (u, "(A)") "! Return the value of " // vname - write (u, "(A)") "function " // char (prefix) & - // "get_" // vname // " (pid)" & - // " result (" // vname // ") bind(C)" - write (u, "(A)") " use iso_c_binding" - call write_use_lines (vname, fname) - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " integer(c_int) :: " // vname - call write_case_lines (vname // " = ", "_" // vname // " ()") - write (u, "(A)") "end function " // char (prefix) & - // "get_" // vname - end subroutine write_get_int_fun - - subroutine write_set_int_sub1 (vname, fname) - character(*), intent(in) :: vname, fname - write (u, "(A)") "" - write (u, "(A)") "! Set table: " // vname - write (u, "(A)") "subroutine " // char (prefix) & - // "set_" // vname & - // " (pid, cptr, shape) bind(C)" - write (u, "(A)") " use iso_c_binding" - call write_use_lines (vname, fname) - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_ptr), intent(in) :: cptr" - write (u, "(A)") " integer(c_int), dimension(2), intent(in) :: shape" - write (u, "(A)") " integer(c_int), dimension(:,:), pointer :: " // vname - if (kind(1) /= c_int) then - write (u, "(A)") " integer, dimension(:,:), allocatable :: " & - // vname // "_tmp" - end if - write (u, "(A)") " call c_f_pointer (cptr, " // vname // ", shape)" - if (kind(1) == c_int) then - call write_case_lines ("call ", "_" // vname // " (" // vname // ")") - else - write (u, "(A)") " allocate (" & - // vname // "_tmp (shape(1), shape(2)))" - call write_case_lines ("call ", & - "_" // vname // " (" // vname // "_tmp)") - write (u, "(A)") " " // vname // " = " // vname // "_tmp" - end if - write (u, "(A)") "end subroutine " // char (prefix) & - // "set_" // vname - end subroutine write_set_int_sub1 - - subroutine write_set_int_sub2 (vname, fname, lname) - character(*), intent(in) :: vname, fname, lname - write (u, "(A)") "" - write (u, "(A)") "! Set tables: " // vname // ", " // lname - write (u, "(A)") "subroutine " // char (prefix) & - // "set_" // vname & - // " (pid, cptr, shape, lcptr, lshape) bind(C)" - write (u, "(A)") " use iso_c_binding" - call write_use_lines (vname, fname) - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_ptr), intent(in) :: cptr" - write (u, "(A)") " integer(c_int), dimension(3), intent(in) :: shape" - write (u, "(A)") " type(c_ptr), intent(in) :: lcptr" - write (u, "(A)") " integer(c_int), dimension(2), intent(in) :: lshape" - write (u, "(A)") " integer(c_int), dimension(:,:,:), pointer :: " & - // vname - write (u, "(A)") " logical(c_bool), dimension(:,:), pointer :: " & - // lname - if (kind(1) /= c_int) then - write (u, "(A)") " integer, dimension(:,:), allocatable :: " & - // vname // "_tmp" - end if - if (kind(.true.) /= c_bool) then - write (u, "(A)") " logical, dimension(:,:), allocatable :: " & - // lname // "_tmp" - end if - write (u, "(A)") " call c_f_pointer (cptr, " // vname // ", shape)" - write (u, "(A)") " call c_f_pointer (lcptr, " // lname // ", lshape)" - if (kind(1) /= c_int) then - write (u, "(A)") " allocate (" & - // vname // "_tmp (shape(1), shape(2), shape(3)))" - end if - if (kind(.true.) /= c_bool) then - write (u, "(A)") " allocate (" & - // lname // "_tmp (lshape(1), lshape(2)))" - end if - if (kind(1) == c_int) then - if (kind(.true.) == c_bool) then - call write_case_lines ("call ", & - "_" // vname // " (" // vname // ", " // lname // ")") - else - call write_case_lines ("call ", & - "_" // vname // " (" // vname // ", " // lname // "_tmp)") - write (u, "(A)") " " // lname // " = " // lname // "_tmp" - end if - else - if (kind(.true.) == c_bool) then - call write_case_lines ("call ", & - "_" // vname // " (" // vname // "_tmp, " // lname // ")") - else - call write_case_lines ("call ", & - "_" // vname // " (" // vname // "_tmp, " // lname // "_tmp)") - write (u, "(A)") " " // lname // " = " // lname // "_tmp" - end if - write (u, "(A)") " " // vname // " = " // vname // "_tmp" - end if - write (u, "(A)") "end subroutine " // char (prefix) & - // "set_" // vname - end subroutine write_set_int_sub2 - - subroutine write_set_cf_tab_sub () - write (u, "(A)") "" - write (u, "(A)") "subroutine " // char (prefix) & - // "set_cf_table (pid, iptr1, iptr2, cptr, shape) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " use omega_color" - call write_use_lines ("color_factors", "color_factors") - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_ptr), intent(in) :: iptr1, iptr2, cptr" - write (u, "(A)") " integer(c_int), dimension(1), intent(in) :: shape" - write (u, "(A)") " integer(c_int), dimension(:), pointer :: " & - // "cf_index1, cf_index2" - write (u, "(A)") " complex(c_default_complex), dimension(:), " & - // "pointer :: col_factor" - write (u, "(A)") " type(omega_color_factor), dimension(:), " & - // "allocatable :: cf" - write (u, "(A)") " call c_f_pointer (iptr1, cf_index1, shape)" - write (u, "(A)") " call c_f_pointer (iptr2, cf_index2, shape)" - write (u, "(A)") " call c_f_pointer (cptr, col_factor, shape)" - write (u, "(A)") " allocate (cf (shape(1)))" - call write_case_lines ("call ", "_color_factors (cf)") - write (u, "(A)") " cf_index1 = cf%i1" - write (u, "(A)") " cf_index2 = cf%i2" - write (u, "(A)") " col_factor = cf%factor" - write (u, "(A)") "end subroutine " // char (prefix) // "set_cf_table" - end subroutine write_set_cf_tab_sub - - subroutine write_init_get_fptr () - write (u, "(A)") "" - write (u, "(A)") "! Return pointer to function: 'init'" - write (u, "(A)") "subroutine " // char (prefix) & - // "init_get_fptr (pid, fptr) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_funptr), intent(out) :: fptr" - write (u, "(A)") " abstract interface" - write (u, "(A)") " subroutine prc_init (par) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " real(c_default_float), dimension(*), " & - // "intent(in) :: par" - write (u, "(A)") " end subroutine prc_init" - write (u, "(A)") " end interface" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A)") "procedure(prc_init), bind(C) :: " & - // char (prc_id(i)) // "_init" - end do - call write_case_lines ("fptr = c_funloc (", "_init)") - write (u, "(A)") "end subroutine " // char (prefix) & - // "init_get_fptr" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, *) - write (u, "(A)") "subroutine " // char (prc_id(i)) & - // "_init (par) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " use " // char (mod_prc_id(i)) - write (u, "(A)") " real(c_default_float), dimension(*), " & - // "intent(in) :: par" - if (c_default_float == default) then - write (u, "(A)") " call init (par)" - else - write (u, "(A, I0)") " integer, parameter :: n_par = ", n_par(i) - write (u, "(A)") " real(default), dimension(n_par) :: fpar" - write (u, "(A)") " fpar = par" - write (u, "(A)") " call init (fpar)" - end if - write (u, "(A)") "end subroutine " // char (prc_id(i)) // "_init" - end do - end subroutine write_init_get_fptr - - subroutine write_final_get_fptr () - write (u, "(A)") "" - write (u, "(A)") "! Return pointer to function: 'final'" - write (u, "(A)") "subroutine " // char (prefix) & - // "final_get_fptr (pid, fptr) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_funptr), intent(out) :: fptr" - write (u, "(A)") " abstract interface" - write (u, "(A)") " subroutine prc_final () bind(C)" - write (u, "(A)") " end subroutine prc_final" - write (u, "(A)") " end interface" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A)") "procedure(prc_final), bind(C) :: " & - // char (prc_id(i)) // "_final" - end do - call write_case_lines ("fptr = c_funloc (", "_final)") - write (u, "(A)") "end subroutine " // char (prefix) & - // "final_get_fptr" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, *) - write (u, "(A)") "subroutine " // char (prc_id(i)) & - // "_final () bind(C)" - write (u, "(A)") " use " // char (mod_prc_id(i)) - write (u, "(A)") " call final ()" - write (u, "(A)") "end subroutine " // char (prc_id(i)) // "_final" - end do - end subroutine write_final_get_fptr - - subroutine write_update_alpha_s_get_fptr () - write (u, "(A)") "" - write (u, "(A)") "! Return pointer to function: 'update_alpha_s'" - write (u, "(A)") "subroutine " // char (prefix) & - // "update_alpha_s_get_fptr (pid, fptr) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_funptr), intent(out) :: fptr" - write (u, "(A)") " abstract interface" - write (u, "(A)") " subroutine prc_update_alpha_s (alpha_s) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " real(c_default_float), " & - // "intent(in) :: alpha_s" - write (u, "(A)") " end subroutine prc_update_alpha_s" - write (u, "(A)") " end interface" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A)") "procedure(prc_update_alpha_s), bind(C) :: " & - // char (prc_id(i)) // "_update_alpha_s" - end do - call write_case_lines ("fptr = c_funloc (", "_update_alpha_s)") - write (u, "(A)") "end subroutine " // char (prefix) & - // "update_alpha_s_get_fptr" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, *) - write (u, "(A)") "subroutine " // char (prc_id(i)) & - // "_update_alpha_s (alpha_s) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " use " // char (mod_prc_id(i)) - write (u, "(A)") " real(c_default_float), " & - // "intent(in) :: alpha_s" - if (c_default_float == default) then - write (u, "(A)") " call update_alpha_s (alpha_s)" - else - write (u, "(A)") " call update_alpha_s " & - // "(real (alpha_s, c_default_float))" - end if - write (u, "(A)") "end subroutine " // char (prc_id(i)) & - // "_update_alpha_s" - end do - end subroutine write_update_alpha_s_get_fptr - - subroutine write_reset_helicity_selection_get_fptr () - write (u, "(A)") "" - write (u, "(A)") "! Return pointer to function: " & - // "'reset_helicity_selection'" - write (u, "(A)") "subroutine " // char (prefix) & - // "reset_helicity_selection_get_fptr (pid, fptr) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_funptr), intent(out) :: fptr" - write (u, "(A)") " abstract interface" - write (u, "(A)") " subroutine " & - // "prc_reset_helicity_selection (threshold, cutoff) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " real(c_default_float), " & - // "intent(in) :: threshold" - write (u, "(A)") " integer(c_int), " & - // "intent(in) :: cutoff" - write (u, "(A)") " end subroutine prc_reset_helicity_selection" - write (u, "(A)") " end interface" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A)") "procedure(prc_reset_helicity_selection), " & - // "bind(C) :: " & - // char (prc_id(i)) // "_reset_helicity_selection" - end do - call write_case_lines ("fptr = c_funloc (", "_reset_helicity_selection)") - write (u, "(A)") "end subroutine " // char (prefix) & - // "reset_helicity_selection_get_fptr" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, *) - write (u, "(A)") "subroutine " // char (prc_id(i)) & - // "_reset_helicity_selection (threshold, cutoff) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " use " // char (mod_prc_id(i)) - write (u, "(A)") " real(c_default_float), " & - // "intent(in) :: threshold" - write (u, "(A)") " integer(c_int), " & - // "intent(in) :: cutoff" - write (u, "(A)") " real(default) :: rthreshold" - write (u, "(A)") " integer :: icutoff" - write (u, "(A)") " rthreshold = threshold" - write (u, "(A)") " icutoff = cutoff" - write (u, "(A)") " call reset_helicity_selection " & - // "(rthreshold, icutoff)" - write (u, "(A)") "end subroutine " // char (prc_id(i)) & - // "_reset_helicity_selection" - end do - end subroutine write_reset_helicity_selection_get_fptr - - subroutine write_new_event_get_fptr () - write (u, "(A)") "" - write (u, "(A)") "! Return pointer to function: 'new_event'" - write (u, "(A)") "subroutine " // char (prefix) & - // "new_event_get_fptr (pid, fptr) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_funptr), intent(out) :: fptr" - write (u, "(A)") " abstract interface" - write (u, "(A)") " subroutine prc_new_event (p) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " real(c_default_float), dimension(0:3,*), " & - // "intent(in) :: p" - write (u, "(A)") " end subroutine prc_new_event" - write (u, "(A)") " end interface" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A)") "procedure(prc_new_event), bind(C) :: " & - // char (prc_id(i)) // "_new_event" - end do - call write_case_lines ("fptr = c_funloc (", "_new_event)") - write (u, "(A)") "end subroutine " // char (prefix) & - // "new_event_get_fptr" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, *) - write (u, "(A)") "subroutine " // char (prc_id(i)) & - // "_new_event (p) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " use " // char (mod_prc_id(i)) - write (u, "(A)") " real(c_default_float), dimension(0:3,*), " & - // "intent(in) :: p" - if (c_default_float == default) then - write (u, "(A)") " call new_event (p)" - else - write (u, "(A)") " integer :: n_tot" - write (u, "(A)") " real(default), dimension(:,:), " & - // "allocatable :: k" - write (u, "(A)") " n_tot = " & - // "number_particles_in () + number_particles_out ()" - write (u, "(A)") " allocate (k (0:3,n_tot))" - write (u, "(A)") " k = p" - write (u, "(A)") " call new_event (k)" - end if - write (u, "(A)") "end subroutine " // char (prc_id(i)) // "_new_event" - end do - end subroutine write_new_event_get_fptr - - subroutine write_is_allowed_get_fptr () - write (u, "(A)") "" - write (u, "(A)") "! Return pointer to function: 'is_allowed'" - write (u, "(A)") "subroutine " // char (prefix) & - // "is_allowed_get_fptr (pid, fptr) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_funptr), intent(out) :: fptr" - write (u, "(A)") " abstract interface" - write (u, "(A)") " function " & - // "prc_is_allowed (flv, hel, col) result (flag) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " logical(c_bool) :: flag" - write (u, "(A)") " integer(c_int), intent(in) :: flv, hel, col" - write (u, "(A)") " end function prc_is_allowed" - write (u, "(A)") " end interface" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A)") "procedure(prc_is_allowed), bind(C) :: " & - // char (prc_id(i)) // "_is_allowed" - end do - call write_case_lines ("fptr = c_funloc (", "_is_allowed)") - write (u, "(A)") "end subroutine " // char (prefix) & - // "is_allowed_get_fptr" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, *) - write (u, "(A)") "function " // char (prc_id(i)) & - // "_is_allowed (flv, hel, col) result (flag) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " use " // char (mod_prc_id(i)) - write (u, "(A)") " logical(c_bool) :: flag" - write (u, "(A)") " integer(c_int), intent(in) :: flv, hel, col" - if (c_int == kind(1)) then - write (u, "(A)") " flag = is_allowed (flv, hel, col)" - else - write (u, "(A)") " integer :: iflv, ihel, icol" - write (u, "(A)") " iflv = flv; ihel = hel; icol = col" - write (u, "(A)") " flag = is_allowed (iflv, ihel, icol)" - end if - write (u, "(A)") "end function " // char (prc_id(i)) & - // "_is_allowed" - end do - end subroutine write_is_allowed_get_fptr - - subroutine write_get_amplitude_get_fptr () - write (u, "(A)") "" - write (u, "(A)") "! Return pointer to function: 'get_amplitude'" - write (u, "(A)") "subroutine " // char (prefix) & - // "get_amplitude_get_fptr (pid, fptr) " & - // "bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: pid" - write (u, "(A)") " type(c_funptr), intent(out) :: fptr" - write (u, "(A)") " abstract interface" - write (u, "(A)") " function " & - // "prc_get_amplitude (flv, hel, col) result (amp) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " complex(c_default_complex) :: amp" - write (u, "(A)") " integer(c_int), intent(in) :: flv, hel, col" - write (u, "(A)") " end function prc_get_amplitude" - write (u, "(A)") " end interface" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A)") "procedure(prc_get_amplitude), bind(C) :: " & - // char (prc_id(i)) // "_get_amplitude" - end do - call write_case_lines ("fptr = c_funloc (", "_get_amplitude)") - write (u, "(A)") "end subroutine " // char (prefix) & - // "get_amplitude_get_fptr" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, *) - write (u, "(A)") "function " // char (prc_id(i)) & - // "_get_amplitude (flv, hel, col) result (amp) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use kinds" - write (u, "(A)") " use " // char (mod_prc_id(i)) - write (u, "(A)") " complex(c_default_complex) :: amp" - write (u, "(A)") " integer(c_int), intent(in) :: flv, hel, col" - if (c_int == kind(1)) then - write (u, "(A)") " amp = get_amplitude (flv, hel, col)" - else - write (u, "(A)") " integer :: iflv, ihel, icol" - write (u, "(A)") " iflv = flv; ihel = hel; icol = col" - write (u, "(A)") " amp = get_amplitude (iflv, ihel, icol)" - end if - write (u, "(A)") "end function " // char (prc_id(i)) & - // "_get_amplitude" - end do - end subroutine write_get_amplitude_get_fptr - - subroutine write_get_ci_type - write (u, "(A)") "" - write (u, "(A)") "! Return the core interaction type of process #i" - write (u, "(A)") "function " // char (prefix) // & - "get_ci_type (i) result (ci_type) bind(C)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " integer(c_int), intent(in) :: i" - write (u, "(A)") " integer(c_int) :: ci_type" - write (u, "(A)") " select case (i)" - do i = 1, n_prc - write (u, "(A,I0,A,I0)") " case (", i, "); ci_type = ", ci_type(i) - end do - write (u, "(A)") " end select" - write (u, "(A)") "end function " // char (prefix) // "get_ci_type" - end subroutine write_get_ci_type - - subroutine write_use_lines (vname, fname) - character(*), intent(in) :: vname, fname - integer :: i - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A)") "use " // char (mod_prc_id(i)) // ", only: " & - // char (prc_id(i)) // "_" // vname // " => " // fname - end do - end subroutine write_use_lines - - subroutine write_case_lines (cmd1, cmd2) - character(*), intent(in) :: cmd1, cmd2 - integer :: i - write (u, "(A)") " select case (pid)" - do i = 1, n_prc - if (virtual(i)) cycle - write (u, "(2x,A,I0,A)") "case(", i, "); " & - // cmd1 // char (prc_id(i)) // cmd2 - end do - write (u, "(A)") " end select" - end subroutine write_case_lines - - end subroutine process_library_write_driver - -@ %def process_library_write_driver -@ -\subsection{User code library access} -The static executable must incorporate user-defined code for various -tasks. In ordinary execution, this is linked dynamically in the same -way as the process code. Therefore, we include it here. -<>= - public :: user_procs_t -<>= - type :: user_procs_t - type(string_t), dimension(:), allocatable :: cut - type(string_t), dimension(:), allocatable :: event_shape - type(string_t), dimension(:), allocatable :: obs_real_unary - type(string_t), dimension(:), allocatable :: obs_real_binary - type(string_t), dimension(:), allocatable :: sf - end type user_procs_t - -@ %def user_procs_t -@ Declare the procedures with appropriate interfaces -<>= - subroutine write_user_code_declarations (u, user_procs) - integer, intent(in) :: u - type(user_procs_t), intent(in) :: user_procs - integer :: i - do i = 1, size (user_procs%cut) - write (u, "(A)") " procedure(user_cut_fun), bind(C) :: " & - // char (user_procs%cut(i)) - end do - do i = 1, size (user_procs%event_shape) - write (u, "(A)") " procedure(user_event_shape_fun), bind(C) :: " & - // char (user_procs%event_shape(i)) - end do - do i = 1, size (user_procs%obs_real_unary) - write (u, "(A)") " procedure(user_obs_real_unary), bind(C) :: " & - // char (user_procs%obs_real_unary(i)) - end do - do i = 1, size (user_procs%obs_real_binary) - write (u, "(A)") " procedure(user_obs_real_binary), bind(C) :: " & - // char (user_procs%obs_real_binary(i)) - end do - end subroutine write_user_code_declarations - -@ %def write_user_code_declarations -@ Write access code for the procedures -<>= - subroutine write_user_code_access (u, user_procs) - integer, intent(in) :: u - type(user_procs_t), intent(in) :: user_procs - write (u, "(5x,A)") "select case (fname)" - call write_access (user_procs%cut) - call write_access (user_procs%event_shape) - call write_access (user_procs%obs_real_unary) - call write_access (user_procs%obs_real_binary) - call write_sf_access (user_procs%sf) - write (u, "(5x,A)") "case default" - write (u, "(5x,A)") " c_fptr = c_null_funptr" - write (u, "(5x,A)") "end select" - contains - subroutine write_access (procname) - type(string_t), dimension(:), intent(in) :: procname - integer :: i - do i = 1, size (procname) - call write_access_line (procname(i)) - end do - end subroutine write_access - subroutine write_sf_access (procname) - type(string_t), dimension(:), intent(in) :: procname - integer :: i - do i = 1, size (procname) - call write_access_line (procname(i) // "_info") - call write_access_line (procname(i) // "_mask") - call write_access_line (procname(i) // "_state") - call write_access_line (procname(i) // "_kinematics") - call write_access_line (procname(i) // "_evaluate") - end do - end subroutine write_sf_access - subroutine write_access_line (procname) - type(string_t), intent(in) :: procname - write (u, "(5x,A)") "case ('" // char (procname) // "')" - write (u, "(8x,A)") "c_fptr = c_funloc (" // char (procname) // ")" - end subroutine write_access_line - end subroutine write_user_code_access - -@ %def write_user_code_access -@ -\subsection{Library manager} -When static libraries are compiled, procedure pointer are not assigned -by a dlopen mechanism, but must be done at program startup. Mainly -for this task we write a library manager which links to the static -libraries as they are defined by the user. - -For each library, it has to assign all possible interface function to -a C function pointer, which then is dereferenced in the same way as it -is done for dlopened libraries. -<>= - public :: write_library_manager -<>= - subroutine write_library_manager (libname, user_procs) - - type(string_t), dimension(:), intent(in) :: libname - type(user_procs_t), intent(in) :: user_procs - integer :: u, i - - call msg_message ("Writing library manager code") - u = free_unit () - open (unit=u, file="libmanager.f90", action="write", status="replace") - write (u, "(A)") "! WHIZARD library manager" - write (u, "(A)") "!" - write (u, "(A)") "! Automatically generated file, do not edit" - write (u, "(A)") "" - write (u, "(A)") "function libmanager_get_n_libs () result (n)" - write (u, "(A)") " implicit none" - write (u, "(A)") " integer :: n" - write (u, "(A,1x,I0)") " n =", size (libname) - write (u, "(A)") "end function libmanager_get_n_libs" - write (u, "(A)") "" - write (u, "(A)") "function libmanager_get_libname (i) result (name)" - write (u, "(A)") " use iso_varying_string, string_t => varying_string" - write (u, "(A)") " implicit none" - write (u, "(A)") " type(string_t) :: name" - write (u, "(A)") " integer, intent(in) :: i" - write (u, "(A)") " select case (i)" - do i = 1, size (libname) - call write_lib_name (i, libname(i)) - end do - write (u, "(A)") " case default; name = ''" - write (u, "(A)") " end select" - write (u, "(A)") "end function libmanager_get_libname" - write (u, "(A)") "" - write (u, "(A)") "function libmanager_get_c_funptr (libname, fname) " & - // "result (c_fptr)" - write (u, "(A)") " use iso_c_binding" - write (u, "(A)") " use prclib_interfaces" - write (u, "(A)") " use user_code_interface" - write (u, "(A)") " implicit none" - write (u, "(A)") " type(c_funptr) :: c_fptr" - write (u, "(A)") " character(*), intent(in) :: libname, fname" - do i = 1, size (libname) - call write_lib_declarations (libname(i)) - end do - if (has_user_lib) call write_user_code_declarations (u, user_procs) - write (u, "(A)") " select case (libname)" - do i = 1, size (libname) - call write_lib_code (libname(i)) - end do - if (has_user_lib) then - write (u, "(A)") " case ('user')" - call write_user_code_access (u, user_procs) - end if - write (u, "(A)") " case default" - write (u, "(A)") " c_fptr = c_null_funptr" - write (u, "(A)") " end select" - write (u, "(A)") "end function libmanager_get_c_funptr" - close (u) - - contains - - subroutine write_lib_name (i, libname) - integer, intent(in) :: i - type(string_t), intent(in) :: libname - write (u, "(A,I0,A)") " case (", i, "); name = '" // char (libname) & - // "'" - end subroutine write_lib_name - - subroutine write_lib_declarations (libname) - type(string_t), intent(in) :: libname - write (u, "(A)") " procedure(prc_get_n_processes), bind(C) :: " & - // char (libname)// "_" // "get_n_processes" - write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " & - // char (libname)// "_" // "get_process_id" - write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " & - // char (libname)// "_" // "get_model_name" - write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " & - // char (libname)// "_" // "get_restrictions" - write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " & - // char (libname)// "_" // "get_omega_flags" - write (u, "(A)") " procedure(prc_get_stringptr), bind(C) :: " & - // char (libname)// "_" // "get_md5sum" - write (u, "(A)") " procedure(prc_get_int), bind(C) :: " & - // char (libname)// "_" // "get_n_in" - write (u, "(A)") " procedure(prc_get_int), bind(C) :: " & - // char (libname)// "_" // "get_n_out" - write (u, "(A)") " procedure(prc_get_int), bind(C) :: " & - // char (libname)// "_" // "get_n_flv" - write (u, "(A)") " procedure(prc_get_int), bind(C) :: " & - // char (libname)// "_" // "get_n_hel" - write (u, "(A)") " procedure(prc_get_int), bind(C) :: " & - // char (libname)// "_" // "get_n_col" - write (u, "(A)") " procedure(prc_get_int), bind(C) :: " & - // char (libname)// "_" // "get_n_cin" - write (u, "(A)") " procedure(prc_get_int), bind(C) :: " & - // char (libname)// "_" // "get_n_cf" - write (u, "(A)") " procedure(prc_get_log), bind(C) :: " & - // char (libname)// "_" // "get_openmp_status" - write (u, "(A)") " procedure(prc_set_int_tab1), bind(C) :: " & - // char (libname)// "_" // "set_flv_state" - write (u, "(A)") " procedure(prc_set_int_tab1), bind(C) :: " & - // char (libname)// "_" // "set_hel_state" - write (u, "(A)") " procedure(prc_set_int_tab2), bind(C) :: " & - // char (libname)// "_" // "set_col_state" - write (u, "(A)") " procedure(prc_set_cf_tab), bind(C) :: " & - // char (libname)// "_" // "set_cf_table" - write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " & - // char (libname)// "_" // "init_get_fptr" - write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " & - // char (libname)// "_" // "final_get_fptr" - write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " & - // char (libname)// "_" // "update_alpha_s_get_fptr" - write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " & - // char (libname)// "_" // "new_event_get_fptr" - write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " & - // char (libname)// "_" // "reset_helicity_selection_get_fptr" - write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " & - // char (libname)// "_" // "is_allowed_get_fptr" - write (u, "(A)") " procedure(prc_get_fptr), bind(C) :: " & - // char (libname)// "_" // "get_amplitude_get_fptr" - write (u, "(A)") " procedure(prc_get_int), bind(C) :: " & - // char (libname)// "_" // "get_ci_type" - end subroutine write_lib_declarations - - subroutine write_lib_code (libname) - type(string_t), intent(in) :: libname - write (u, "(2x,A)") "case ('" // char (libname) // "')" - write (u, "(2x,A)") " select case (fname)" - call write_fun_code (char (libname), "get_n_processes") - call write_fun_code (char (libname), "get_process_id") - call write_fun_code (char (libname), "get_model_name") - call write_fun_code (char (libname), "get_restrictions") - call write_fun_code (char (libname), "get_omega_flags") - call write_fun_code (char (libname), "get_md5sum") - call write_fun_code (char (libname), "get_n_in") - call write_fun_code (char (libname), "get_n_out") - call write_fun_code (char (libname), "get_n_flv") - call write_fun_code (char (libname), "get_n_hel") - call write_fun_code (char (libname), "get_n_col") - call write_fun_code (char (libname), "get_n_cin") - call write_fun_code (char (libname), "get_n_cf") - call write_fun_code (char (libname), "get_openmp_status") - call write_fun_code (char (libname), "set_flv_state") - call write_fun_code (char (libname), "set_hel_state") - call write_fun_code (char (libname), "set_col_state") - call write_fun_code (char (libname), "set_cf_table") - call write_fun_code (char (libname), "init_get_fptr") - call write_fun_code (char (libname), "final_get_fptr") - call write_fun_code (char (libname), "update_alpha_s_get_fptr") - call write_fun_code (char (libname), "reset_helicity_selection_get_fptr") - call write_fun_code (char (libname), "new_event_get_fptr") - call write_fun_code (char (libname), "is_allowed_get_fptr") - call write_fun_code (char (libname), "get_amplitude_get_fptr") - call write_fun_code (char (libname), "get_ci_type") - write (u, "(2x,A)") " case default" - write (u, "(2x,A)") " print *, fname" - write (u, "(2x,A)") " stop 'WHIZARD bug: " & - // "libmanager cannot handle this function'" - write (u, "(2x,A)") " end select" - end subroutine write_lib_code - - subroutine write_fun_code (prefix, fname) - character(*), intent(in) :: prefix, fname - write (u, "(5x,A)") "case ('" // fname // "')" - write (u, "(5x,A)") " c_fptr = c_funloc (" // prefix & - // "_" // fname // ")" - end subroutine write_fun_code - - end subroutine write_library_manager - -@ %def write_library_manager -@ These are the interfaces of the functions provided by the library -manager. -<>= -<> -<>= - interface - function libmanager_get_n_libs () result (n) - integer :: n - end function libmanager_get_n_libs - end interface - -@ %def libmanager_get_n_libs -<>= - interface - function libmanager_get_libname (i) result (name) - use iso_varying_string, string_t => varying_string !NODEP! - type(string_t) :: name - integer, intent(in) :: i - end function libmanager_get_libname - end interface - -@ %def libmanager_get_libname -<>= - interface - function libmanager_get_c_funptr (libname, fname) result (c_fptr) - use iso_c_binding !NODEP! - type(c_funptr) :: c_fptr - character(*), intent(in) :: libname, fname - end function libmanager_get_c_funptr - end interface - -@ %def libmanager_get_c_funptr -@ -\subsection{Compile and link a library} -The process library proper consists of the process-specific Fortran -source files and the driver (interface) -<>= - public :: process_library_compile -<>= - subroutine process_library_compile & - (prc_lib, os_data, recompile_library, objlist_link) - type(process_library_t), intent(inout) :: prc_lib - type(os_data_t), intent(in) :: os_data - logical, intent(in) :: recompile_library - type(string_t), intent(out) :: objlist_link - type(string_t) :: objlist_comp - type(process_configuration_t), pointer :: current - type(string_t) :: ext - integer :: i - if (prc_lib%status == STAT_LOADED) call process_library_unload (prc_lib) - call msg_message ("Compiling process library '" // & - char (process_library_get_name (prc_lib)) // "'") - objlist_comp = "" - objlist_link = "" - if (os_data%use_libtool) then - ext = ".lo" - else - ext = os_data%obj_ext - end if - current => prc_lib%prc_first - SCAN_PROCESSES: do i = 1, prc_lib%n_prc - if (current%method == PRC_SUM) then - current => current%next - cycle - end if - objlist_link = objlist_link // " " // current%id // ext - if (recompile_library) & - current%status = min (STAT_CODE_GENERATED, current%status) - if (current%status == STAT_CODE_GENERATED) then - objlist_comp = objlist_comp // " " // current%id // ext - call os_compile_shared (current%id, os_data) - current%status = STAT_COMPILED - else - call msg_message ("Skipping process '" // char (current%id) & - // "' (object code exists)") - end if - current => current%next - end do SCAN_PROCESSES - if (objlist_comp /= "") then - call os_compile_shared (prc_lib%basename, os_data) - objlist_link = objlist_link // " " // prc_lib%basename // ext - else - call msg_message ("Skipping library '" & - // char (prc_lib%basename) & - // "' (no processes have been recompiled)") - objlist_link = "" - end if - prc_lib%status = STAT_COMPILED - end subroutine process_library_compile - -@ %def process_library_compile -<>= - public :: process_library_link -<>= - subroutine process_library_link (prc_lib, os_data, objlist) - type(process_library_t), intent(in) :: prc_lib - type(os_data_t), intent(in) :: os_data - type(string_t), intent(in) :: objlist - type(os_data_t) :: local_os_data - local_os_data = os_data - local_os_data%ldflags = os_data%ldflags & - // " " // get_modellibs_flags (prc_lib, os_data) - if (objlist /= "") then - call os_link_shared (objlist, prc_lib%basename, local_os_data) - end if - end subroutine process_library_link - -@ %def process_library_link -@ -\subsection{Standalone executable} -Compile the library bundle and link with the libraries as a standalone -executable -<>= - public :: compile_library_manager -<>= - subroutine compile_library_manager (os_data) - type(os_data_t), intent(in) :: os_data - call msg_message ("Compiling library manager") - call os_compile_shared (var_str ("libmanager"), os_data) - end subroutine compile_library_manager - -@ %def compile_library_manager -<>= - public :: link_executable -<>= - subroutine link_executable (libname, exec_name, flags, os_data) - type(string_t), dimension(:), intent(in) :: libname - type(string_t), intent(in) :: exec_name, flags - type(os_data_t), intent(in) :: os_data - type(string_t) :: objlist, ext_o, ext_a - integer :: i - if (os_data%use_libtool) then - ext_o = ".lo" - ext_a = ".la" - else - ext_o = ".o" - ext_a = ".a" - end if - objlist = "libmanager" // ext_o - do i = 1, size (libname) - objlist = objlist // " " // libname(i) // ext_a - end do - if (has_user_lib) then - objlist = objlist // " user" // ext_a - end if - call os_link_static (objlist // flags, exec_name, os_data) - end subroutine link_executable - -@ %def link_executable -@ -\subsection{Loading a library} -This loads a process library. We assume that it resides in the -current directory. - -Loading the library assigns all procedure pointers to procedures -within the library. - -Unloading is done by the finalizer. -<>= - public :: process_library_load -<>= - subroutine process_library_load (prc_lib, os_data, model, var_list, ignore) - type(process_library_t), intent(inout), target :: prc_lib - type(os_data_t), intent(in) :: os_data - type(model_t), pointer, optional :: model - type(var_list_t), intent(inout) :: var_list - logical, intent(in), optional :: ignore - type(c_funptr) :: c_fptr - type(model_t), pointer :: mdl - type(string_t) :: prefix - logical :: ignore_error - ignore_error = .false.; if (present (ignore)) ignore_error = ignore - if (prc_lib%status == STAT_LOADED) then - if (.not. ignore_error) then - call msg_message ("Process library '" // char (prc_lib%basename) & - // "' is already loaded") - end if - return - end if - if (prc_lib%static) then - call msg_message ("Loading static process library '" & - // char (prc_lib%basename) // "'") - else - call msg_message ("Loading process library '" & - // char (prc_lib%basename) // "'") - prc_lib%libname = os_get_dlname (prc_lib%basename, os_data, ignore) - if (prc_lib%libname == "") return - call dlaccess_init (prc_lib%dlaccess, var_str ("."), & - prc_lib%libname, os_data) - call process_library_check_dlerror (prc_lib) - end if - prefix = prc_lib%basename - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_n_processes")) - call c_f_procpointer (c_fptr, prc_lib%get_n_prc) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_process_id")) - call c_f_procpointer (c_fptr, prc_lib%get_process_id) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_model_name")) - call c_f_procpointer (c_fptr, prc_lib%get_model_name) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_restrictions")) - call c_f_procpointer (c_fptr, prc_lib%get_restrictions) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_omega_flags")) - call c_f_procpointer (c_fptr, prc_lib%get_omega_flags) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_openmp_status")) - call c_f_procpointer (c_fptr, prc_lib%get_openmp_status) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_md5sum")) - call c_f_procpointer (c_fptr, prc_lib%get_md5sum) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_n_in")) - call c_f_procpointer (c_fptr, prc_lib%get_n_in) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_n_out")) - call c_f_procpointer (c_fptr, prc_lib%get_n_out) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_n_flv")) - call c_f_procpointer (c_fptr, prc_lib%get_n_flv) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_n_hel")) - call c_f_procpointer (c_fptr, prc_lib%get_n_hel) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_n_col")) - call c_f_procpointer (c_fptr, prc_lib%get_n_col) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_n_cin")) - call c_f_procpointer (c_fptr, prc_lib%get_n_cin) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_n_cf")) - call c_f_procpointer (c_fptr, prc_lib%get_n_cf) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("set_flv_state")) - call c_f_procpointer (c_fptr, prc_lib%set_flv_state) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("set_hel_state")) - call c_f_procpointer (c_fptr, prc_lib%set_hel_state) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("set_col_state")) - call c_f_procpointer (c_fptr, prc_lib%set_col_state) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("set_cf_table")) - call c_f_procpointer (c_fptr, prc_lib%set_cf_table) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("init_get_fptr")) - call c_f_procpointer (c_fptr, prc_lib%init_get_fptr) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("final_get_fptr")) - call c_f_procpointer (c_fptr, prc_lib%final_get_fptr) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("update_alpha_s_get_fptr")) - call c_f_procpointer (c_fptr, prc_lib%update_alpha_s_get_fptr) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("new_event_get_fptr")) - call c_f_procpointer (c_fptr, prc_lib%new_event_get_fptr) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("reset_helicity_selection_get_fptr")) - call c_f_procpointer (c_fptr, prc_lib%reset_helicity_selection_get_fptr) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("is_allowed_get_fptr")) - call c_f_procpointer (c_fptr, prc_lib%is_allowed_get_fptr) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_amplitude_get_fptr")) - call c_f_procpointer (c_fptr, prc_lib%get_amplitude_get_fptr) - c_fptr = process_library_get_c_funptr & - (prc_lib, prefix, var_str ("get_ci_type")) - call c_f_procpointer (c_fptr, prc_lib%get_ci_type) - call process_library_load_configuration (prc_lib, os_data, mdl) - prc_lib%status = STAT_LOADED - if (associated (prc_lib%reload_hook)) & - call prc_lib%reload_hook (process_library_get_name (prc_lib)) - call var_list_set_string (var_list, var_str ("$library_name"), & - process_library_get_name (prc_lib), is_known=.true.) ! $ - if (present (model)) model => mdl - end subroutine process_library_load - -@ %def process_library_load -@ Unload a process library. Necessary before recompiling and -reloading. -<>= - public :: process_library_unload -<>= - subroutine process_library_unload (prc_lib) - type(process_library_t), intent(inout) :: prc_lib - call msg_message ("Unloading process library '" // & - char (process_library_get_name (prc_lib)) // "'") - if (associated (prc_lib%unload_hook)) & - call prc_lib%unload_hook (process_library_get_name(prc_lib)) - call dlaccess_final (prc_lib%dlaccess) - prc_lib%status = STAT_CODE_GENERATED - end subroutine process_library_unload - -@ %def process_library_unload -@ Register hooks for un- / reloading the process library. -<>= - public :: process_library_set_unload_hook - public :: process_library_set_reload_hook -<>= - subroutine process_library_set_unload_hook (prc_lib, hook) - type(process_library_t), intent(inout), target :: prc_lib - procedure(prclib_unload_hook), pointer, intent(in) :: hook - prc_lib%unload_hook => hook - end subroutine process_library_set_unload_hook - - subroutine process_library_set_reload_hook (prc_lib, hook) - type(process_library_t), intent(inout), target :: prc_lib - procedure(prclib_reload_hook), pointer, intent(in) :: hook - prc_lib%reload_hook => hook - end subroutine process_library_set_reload_hook - -@ %def process_library_set_unload_hook -@ %def process_library_set_reload_hook -@ Get a C function pointer to a procedure belonging to the process -library interface and check for an error condition. -<>= - function process_library_get_c_funptr & - (prc_lib, prefix, fname) result (c_fptr) - type(c_funptr) :: c_fptr - type(process_library_t), intent(inout) :: prc_lib - type(string_t), intent(in) :: prefix, fname - type(string_t) :: full_name - full_name = prefix // "_" // fname - if (prc_lib%static) then - c_fptr = libmanager_get_c_funptr (char (prefix), char (fname)) - else - c_fptr = dlaccess_get_c_funptr (prc_lib%dlaccess, full_name) - call process_library_check_dlerror (prc_lib) - end if - end function process_library_get_c_funptr - -@ %def process_library_get_c_funptr -@ Check for an error condition and signal it. -<>= - subroutine process_library_check_dlerror (prc_lib) - type(process_library_t), intent(in) :: prc_lib - if (dlaccess_has_error (prc_lib%dlaccess)) then - call msg_fatal (char (dlaccess_get_error (prc_lib%dlaccess))) - end if - end subroutine process_library_check_dlerror - -@ %def process_library_check_dlerror -@ -\subsection{The library store} -We want to handle several libraries in parallel, therefore we -introduce a global library store, similar to the model and process -lists. The store is a module variable. -<>= - type :: process_library_store_t - private - type(process_library_t), pointer :: first => null () - type(process_library_t), pointer :: last => null () - end type process_library_store_t - -@ %def process_library_store_t -<>= - type(process_library_store_t), save :: process_library_store -@ %def process_library_store -@ Append a new library, if it does not yet exist, and return a pointer -to it. -<>= - public :: process_library_store_append -<>= - subroutine process_library_store_append (name, os_data, prc_lib) - type(string_t), intent(in) :: name - type(os_data_t), intent(in) :: os_data - type(process_library_t), pointer :: prc_lib - prc_lib => process_library_store_get_ptr (name) - if (.not. associated (prc_lib)) then - call msg_message & - ("Initializing process library '" // char (name) // "'") - allocate (prc_lib) - call process_library_init (prc_lib, name, os_data) - if (associated (process_library_store%last)) then - process_library_store%last%next => prc_lib - else - process_library_store%first => prc_lib - end if - process_library_store%last => prc_lib - end if - end subroutine process_library_store_append - -@ %def process_library_store_append -@ Finalizer. This closes all open libraries. -<>= - public :: process_library_store_final -<>= - subroutine process_library_store_final () - type(process_library_t), pointer :: current - do while (associated (process_library_store%first)) - current => process_library_store%first - process_library_store%first => current%next - call process_library_final (current) - deallocate (current) - end do - process_library_store%last => null () - end subroutine process_library_store_final - -@ %def process_library_store_final -@ Load all libraries -<>= - public :: process_library_store_load -<>= - subroutine process_library_store_load (os_data, var_list) - type(os_data_t), intent(in) :: os_data - type(var_list_t), intent(inout), optional :: var_list - type(process_library_t), pointer :: current - current => process_library_store%first - do while (associated (current)) - call process_library_load (current, os_data, var_list=var_list) - current => current%next - end do - end subroutine process_library_store_load - -@ %def process_library_store_load -@ Get a pointer to an existing (named) library -<>= - public :: process_library_store_get_ptr -<>= - function process_library_store_get_ptr (name) result (prc_lib) - type(process_library_t), pointer :: prc_lib - type(string_t), intent(in) :: name - prc_lib => process_library_store%first - do while (associated (prc_lib)) - if (prc_lib%basename == name) exit - prc_lib => prc_lib%next - end do - end function process_library_store_get_ptr - -@ %def process_library_store_get_ptr -@ Get a pointer to the first/next library -<>= - public :: process_library_store_get_first -<>= - function process_library_store_get_first () result (prc_lib) - type(process_library_t), pointer :: prc_lib - prc_lib => process_library_store%first - end function process_library_store_get_first - -@ %def process_library_store_get_first -@ -\subsection{Preloading static libraries} -Static libraries are static, so it is sensible to load them all at -startup. (By default, they are linked, but not loaded in the sense -that a [[process_library]] object exists for them.) This can be done -using this routine. -<>= - public :: process_library_store_load_static -<>= - subroutine process_library_store_load_static & - (os_data, prc_lib, model, var_list) - type(os_data_t), intent(in) :: os_data - type(process_library_t), pointer :: prc_lib - type(model_t), pointer :: model - type(var_list_t), intent(inout) :: var_list - integer :: n, i - type(string_t), dimension(:), allocatable :: libname - n = libmanager_get_n_libs () - allocate (libname (n)) - do i = 1, n - libname(i) = libmanager_get_libname (i) - end do - do i = 1, n - call process_library_store_append (libname(i), os_data, prc_lib) - call process_library_set_static (prc_lib, .true.) - call process_library_load (prc_lib, os_data, model, var_list) - end do - end subroutine process_library_store_load_static - -@ %def process_library_store_load_static -@ -Distinguish the module name, depending on the method of the process. -<>= - function process_library_get_module_name (id, method) result (mod_id) - type(string_t), intent(in) :: id - integer, intent(in) :: method - type(string_t) :: mod_id - select case (method) - case (PRC_OMEGA) - mod_id = "opr_" // id - case (PRC_TEST, PRC_UNIT) - mod_id = "tpr_" // id - case default - mod_id = id - end select - end function process_library_get_module_name -@ %def process_library_get_module_name -@ -\subsection{Test} -<>= - public :: process_libraries_test -<>= - subroutine process_libraries_test () - type(model_t), pointer :: model - type(process_library_t), pointer :: prc_lib => null () - type(string_t), dimension(:), allocatable :: prt_in, prt_out - type(os_data_t) :: os_data - type(string_t) :: objlist - type(var_list_t), pointer :: var_list => null () - integer :: n_prc - allocate (var_list) - allocate (prc_lib) - call process_library_store_final - call os_data_init (os_data) - print *, "*** Read model file" - call syntax_model_file_init () - call model_list_read_model & - (var_str("SM"), var_str("SM.mdl"), os_data, model) - call syntax_model_file_final () - print *, "*** Create library 'proc' with two processes" - print *, "* Setup process configuration" - call var_list_append_string (var_list, name = "$library_name", sval = "proc") ! $ - call process_library_store_append (var_str ("proc"), os_data, prc_lib) - allocate (prt_in (1), prt_out (2)) - prt_in(1) = "Z" - prt_out(1) = "e1" - prt_out(2) = "E1" - call process_library_append & - (prc_lib, CI_OMEGA, var_str ("zee"), model, prt_in, prt_out, & - method = PRC_TEST) - deallocate (prt_in, prt_out) - allocate (prt_in (2), prt_out (2)) - prt_in(1) = "g" - prt_in(2) = "g" - prt_out(1) = "u" - prt_out(2) = "U" - call process_library_append & - (prc_lib, CI_OMEGA, var_str ("uu"), model, prt_in, prt_out, & - method = PRC_TEST) - print * - print *, "* Generate code" - call process_library_generate_code (prc_lib, os_data) - print * - print *, "* Write driver file 'proc_interface.f90'" - call process_library_write_driver (prc_lib) - print * - print *, "* Compile and link as 'libproc.so'" - call process_library_compile (prc_lib, os_data, .false., objlist) - call process_library_link (prc_lib, os_data, objlist) - print * - print *, "* Load shared libraries" - call process_library_load (prc_lib, os_data, var_list = var_list) - print * - print *, "* Execute 'get_n_processes' from the shared library named 'proc'" - print * - prc_lib => process_library_store_get_ptr (var_str ("proc")) - n_prc = prc_lib% get_n_prc () - print *, "n_prc = ", n_prc - if (n_prc .ne. 2) then - call msg_fatal (" Process library test failed.") - else - call msg_message ("Successful.") - end if - print * - print *, "* Cleanup" - call process_library_store_final - call var_list_final (var_list) - deallocate (var_list) - end subroutine process_libraries_test - -@ %def process_libraries_test -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\chapter{Integration and Event Generation} -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Hard interactions} -This module is concerned with the matrix element of an elementary -interaction (typically, a hard scattering or heavy-particle decay). -The module does not hold phase space information. -<<[[hard_interactions.f90]]>>= -<> - -module hard_interactions - - use iso_c_binding !NODEP! - use kinds !NODEP! -<> -<> - use diagnostics !NODEP! - use lorentz !NODEP! - use os_interface - use variables - use models - use flavors - use helicities - use colors - use quantum_numbers - use state_matrices - use interactions - use evaluators - use particles - use prclib_interfaces - use process_libraries - -<> - -<> - -<> - -<> - -contains - -<> - -end module hard_interactions -@ %def hard_interactions -@ -\subsection{The hard-interaction data type} -We define a special data type that accesses the process library. -While constant data are stored as data, the process-specific functions -for initialization, calculation and finalization are stored as -procedure pointers. -<>= - type :: hard_interaction_data_t - type(string_t) :: id - type(model_t), pointer :: model => null () - integer :: n_tot = 0 - integer :: n_in = 0 - integer :: n_out = 0 - integer :: n_flv = 0 - integer :: n_hel = 0 - integer :: n_col = 0 - integer :: n_cin = 0 - integer :: n_cf = 0 - real(default), dimension(:), allocatable :: par - integer, dimension(:,:), allocatable :: flv_state, hel_state - integer, dimension(:,:,:), allocatable :: col_state - logical, dimension(:,:), allocatable :: ghost_flag - integer, dimension(:,:), allocatable :: col_flow_index - complex(default), dimension(:), allocatable :: col_factor - procedure(prc_init), nopass, pointer :: init => null () - procedure(prc_final), nopass, pointer :: final => null () - procedure(prc_update_alpha_s), nopass, pointer :: update_alpha_s => null () - procedure(prc_reset_helicity_selection), nopass, pointer :: & - reset_helicity_selection => null () - procedure(prc_new_event), nopass, pointer :: new_event => null () - procedure(prc_is_allowed), nopass, pointer :: is_allowed => null () - procedure(prc_get_amplitude), nopass, pointer :: get_amplitude => null () - end type hard_interaction_data_t - -@ %def hard_interaction_data_t -@ Initialize the hard process, using the process ID and the model -parameters. - -Assigning flavor/helicity/color tables: we need an intermediate -allocatable array to serve as a C pointer target; the C pointer is -passed to the process library where it is dereferenced and the array -is filled. In principle, this copying step is necessary only if the -Fortran and C types differ (which happens for the logical type). -However, since this is not critical, we do it anyway. - -For incoming particles, the particle color is inverted. This is -useful for squaring the color flow, but has to be undone before -convoluting with structure functions. - -We define additional functions for finalizing and resetting the pointers into -the process library when the library is reloaded. -<>= - subroutine hard_interaction_data_unload (data) - type(hard_interaction_data_t), intent(inout) :: data - call data%final - nullify (data%init) - nullify (data%final) - nullify (data%update_alpha_s) - nullify (data%reset_helicity_selection) - nullify (data%new_event) - nullify (data%is_allowed) - nullify (data%get_amplitude) - end subroutine hard_interaction_data_unload - - subroutine hard_interaction_data_reload (data, prc_lib, pid) - type(hard_interaction_data_t), intent(inout) :: data - type(process_library_t), intent(in) :: prc_lib - integer, optional :: pid - integer :: the_pid - type(c_funptr) :: fptr - if (present (pid)) then - the_pid = pid - else - the_pid = process_library_get_process_pid (prc_lib, data%id) - if (the_pid <= 0) call msg_bug & - ("Invalid process ID '" // char (data%id) // "'") - end if - call prc_lib% init_get_fptr (the_pid, fptr) - call c_f_procpointer (fptr, data% init) - call prc_lib% final_get_fptr (the_pid, fptr) - call c_f_procpointer (fptr, data% final) - call prc_lib% update_alpha_s_get_fptr (the_pid, fptr) - call c_f_procpointer (fptr, data% update_alpha_s) - call prc_lib% reset_helicity_selection_get_fptr (the_pid, fptr) - call c_f_procpointer (fptr, data% reset_helicity_selection) - call prc_lib% new_event_get_fptr (the_pid, fptr) - call c_f_procpointer (fptr, data% new_event) - call prc_lib% is_allowed_get_fptr (the_pid, fptr) - call c_f_procpointer (fptr, data% is_allowed) - call prc_lib% get_amplitude_get_fptr (the_pid, fptr) - call c_f_procpointer (fptr, data% get_amplitude) - end subroutine hard_interaction_data_reload - -<>= - subroutine hard_interaction_data_init & - (data, prc_lib, process_index, process_id, model) - type(hard_interaction_data_t), intent(out) :: data - type(process_library_t), intent(in) :: prc_lib - integer, intent(in) :: process_index - type(string_t), intent(in) :: process_id - type(model_t), intent(in), target :: model - integer(c_int) :: pid - type(string_t) :: model_name - integer(c_int), dimension(:,:), allocatable, target :: flv_state, hel_state - integer(c_int), dimension(:,:,:), allocatable, target :: col_state - logical(c_bool), dimension(:,:), allocatable, target :: ghost_flag - integer(c_int), dimension(:), allocatable, target :: cf_index1, cf_index2 - complex(c_default_complex), dimension(:), allocatable, target :: col_factor - integer :: c, i - if (.not. associated (prc_lib% get_process_id)) then - call msg_fatal ("Process library '" // char (prc_lib%basename) // "':" & - // " procedures unavailable (missing compile command?)") - data%id = "" - return - end if - pid = process_index - data%id = process_library_get_process_id (prc_lib, pid) - if (data%id /= process_id) then - call msg_bug ("Process ID mismatch: requested '" & - // char (process_id) // "' but found '" // char (data%id) // "'") - end if - data%model => model - model_name = process_library_get_process_model_name (prc_lib, pid) - if (model_get_name (data%model) /= model_name) then - call msg_warning ("Process '" // char (process_id) // "': " & - // "temporarily resetting model from '" & - // char (model_get_name (data%model)) // "' to '" & - // char (model_name) // "'") - data%model => model_list_get_model_ptr (model_name) - if (.not. associated (data%model)) then - call msg_fatal ("Model '" // char (model_name) & - // "' is not initialized") - end if - end if - data%n_in = prc_lib% get_n_in (pid) - data%n_out = prc_lib% get_n_out (pid) - data%n_tot = data%n_in + data%n_out - data%n_flv = prc_lib% get_n_flv (pid) - data%n_hel = prc_lib% get_n_hel (pid) - data%n_col = prc_lib% get_n_col (pid) - data%n_cin = prc_lib% get_n_cin (pid) - data%n_cf = prc_lib% get_n_cf (pid) - if (data%n_flv == 0) then - call msg_warning ("Process '" // char (process_id) // "': " & - // "matrix element vanishes.") - end if - call model_parameters_to_array (data%model, data%par) - allocate (data%flv_state (data%n_tot, data%n_flv)) - allocate (data%hel_state (data%n_tot, data%n_hel)) - allocate (data%col_state (data%n_cin, data%n_tot, data%n_col)) - allocate (data%ghost_flag (data%n_tot, data%n_col)) - allocate (data%col_flow_index (2, data%n_cf)) - allocate (data%col_factor (data%n_cf)) - allocate (flv_state (data%n_tot, data%n_flv)) - allocate (hel_state (data%n_tot, data%n_hel)) - allocate (col_state (data%n_cin, data%n_tot, data%n_col)) - allocate (ghost_flag (data%n_tot, data%n_col)) - allocate (cf_index1 (data%n_cf)) - allocate (cf_index2 (data%n_cf)) - allocate (col_factor (data%n_cf)) - call prc_lib% set_flv_state (pid, & - c_loc (flv_state), & - int((/data%n_tot, data%n_flv/), kind=c_int)) - data%flv_state = flv_state - call prc_lib% set_hel_state (pid, & - c_loc (hel_state), & - int((/data%n_tot, data%n_hel/), kind=c_int)) - data%hel_state = hel_state - call prc_lib% set_col_state (pid, & - c_loc (col_state), & - int((/data%n_cin, data%n_tot, data%n_col/), kind=c_int), & - c_loc (ghost_flag), & - int((/data%n_tot, data%n_col/), kind=c_int)) - if (data%n_cin /= 2) & - call msg_bug ("Process library '" // char (prc_lib%basename) // "':" & - // " number of color indices must be two") - forall (c = 1:2, i = 1:data%n_in) - data%col_state(c,i,:) = - col_state(3-c,i,:) - end forall - forall (i = data%n_in+1:data%n_tot) - data%col_state(:,i,:) = col_state(:,i,:) - end forall - data%ghost_flag = ghost_flag - call prc_lib% set_cf_table (pid, & - c_loc (cf_index1), c_loc (cf_index2), c_loc (col_factor), & - int ((/data%n_cf/), kind=c_int)) - data%col_flow_index(1,:) = cf_index1 - data%col_flow_index(2,:) = cf_index2 - data%col_factor = col_factor - call hard_interaction_data_reload (data, prc_lib, pid=pid) - call hard_interaction_data_check_masses (data) - end subroutine hard_interaction_data_init - -@ %def hard_interaction_data_init -@ %def hard_interaction_data_unload -@ %def hard_interaction_data_reload -@ I/O: -<>= - subroutine hard_interaction_data_write (data, unit) - type(hard_interaction_data_t), intent(in) :: data - integer, intent(in), optional :: unit - integer :: f, h, c, n, i - integer :: u - u = output_unit (unit); if (u < 0) return - write (u, *) "Process '", char (trim (data%id)), "'" - write (u, *) "n_tot = ", data%n_tot - write (u, *) "n_in = ", data%n_in - write (u, *) "n_out = ", data%n_out - write (u, *) "n_flv = ", data%n_flv - write (u, *) "n_hel = ", data%n_hel - write (u, *) "n_col = ", data%n_col - write (u, *) "n_cin = ", data%n_cin - write (u, *) "n_cf = ", data%n_cf - write (u, *) "Model parameters:" - do i = 1, size (data%par) - write (u, *) i, data%par(i) - end do - write (u, *) "Flavor states:" - do f = 1, data%n_flv - write (u, *) f, ":", data%flv_state (:,f) - end do - write (u, *) "Helicity states:" - do h = 1, data%n_hel - write (u, *) h, ":", data%hel_state (:,h) - end do - write (u, *) "Color states:" - do c = 1, data%n_col - write (u, "(I5,A)", advance="no") c, ":" - do n = 1, data%n_tot - write (u, "('/')", advance="no") - if (data%ghost_flag (n, c)) write (u, "('*')", advance="no") - do i = 1, data%n_cin - if (data%col_state(i,n,c) == 0) cycle - write (u, "(I3)", advance="no") data%col_state(i,n,c) - end do - end do - write (u, "('/')") - end do - write (u, *) "Color factors:" - do c = 1, data%n_cf - write (u, "(I5,A,2(I4,1x))", advance="no") c, ":", & - data%col_flow_index(:,c) - write (u, *) data%col_factor(c) - end do - end subroutine hard_interaction_data_write - -@ %def hard_interaction_data_write -@ -\subsection{The hard-interaction type} -The type contains an interaction that is used to store the bare matrix -element values. The flavor/helicity/color arrays are used to identify -each matrix element for the amplitude function. Furthermore, there -are three evaluators for the trace (the squared matrix element -proper), the squared matrix element with color factors, possibly -exclusive in some quantum numbers, and the squared matrix element -broken down by color flows. The latter two are needed only for the -simulation of complete events, not for integration. - -For the integrated dipoles we need copies of the hard interaction which share -everything apart from the kinematics and the actual values of the matrix -elements. Copies are marked with the [[is_copy]] flag, and -[[hard_interaction_data_t]] points to the original data. -<>= - public :: hard_interaction_t -<>= - type :: hard_interaction_t - private - logical :: initialized = .false. - logical :: is_copy = .false. - type(hard_interaction_data_t), pointer :: data => null () - integer :: n_values = 0 - integer, dimension(:), allocatable :: flv, hel, col - type(interaction_t) :: int - type(evaluator_t) :: eval_trace - type(evaluator_t) :: eval_sqme - type(evaluator_t) :: eval_flows - end type hard_interaction_t - -@ %def hard_interaction -@ Initializer. Set up the hard-process data and build the -corresponding interaction structure. In parallel, assign the allowed -flavor/helicity/color indices to the corresponding index arrays. For -each valid combination, a matrix element pointer is prepared which is -inserted as a new leaf in the interaction quantum-number tree. - -In addition to initialization, we also provide subroutines for partial -finalization and re-initialization if the process library is reloaded, or the -parameters are changed. -<>= - public :: hard_interaction_init - public :: hard_interaction_unload - public :: hard_interaction_reload - public :: hard_interaction_update_parameters -<>= - subroutine hard_interaction_init & - (hi, prc_lib, process_index, process_id, model) - type(hard_interaction_t), intent(out), target :: hi - type(process_library_t), intent(in) :: prc_lib - integer, intent(in) :: process_index - type(string_t), intent(in) :: process_id - type(model_t), intent(in), target :: model - type(flavor_t), dimension(:), allocatable :: flv - type(color_t), dimension(:), allocatable :: col - type(helicity_t), dimension(:), allocatable :: hel - type(quantum_numbers_t), dimension(:), allocatable :: qn - integer :: f, h, c, i, n - hi%is_copy = .false. - allocate (hi%data) - call hard_interaction_data_init & - (hi%data, prc_lib, process_index, process_id, model) - if (hi%data%id == "") return - call hi%data% init (real (hi%data%par, c_default_float)) - call interaction_init & - (hi%int, hi%data%n_in, 0, hi%data%n_out, set_relations=.true.) - call hard_interaction_reset_helicity_selection (hi, 0._default, 0) - n = 0 - do f = 1, hi%data%n_flv - do h = 1, hi%data%n_hel - do c = 1, hi%data%n_col - if (hi%data%is_allowed (f, h, c)) n = n + 1 - end do - end do - end do - hi%n_values = n - allocate (hi%flv (n), hi%hel (n), hi%col (n)) - allocate (flv (hi%data%n_tot), col (hi%data%n_tot), hel (hi%data%n_tot)) - allocate (qn (hi%data%n_tot)) - i = 0 - do f = 1, hi%data%n_flv - do h = 1, hi%data%n_hel - do c = 1, hi%data%n_col - if (hi%data%is_allowed (f, h, c)) then - i = i + 1 - hi%flv(i) = f - hi%hel(i) = h - hi%col(i) = c - call flavor_init (flv, hi%data%flv_state(:,f), hi%data%model) - call color_init_from_array (col, hi%data%col_state(:,:,c), & - hi%data%ghost_flag(:,c)) - call helicity_init (hel, hi%data%hel_state(:,h)) - call quantum_numbers_init (qn, flv, col, hel) - call interaction_add_state (hi%int, qn) - end if - end do - end do - end do - call interaction_freeze (hi%int) - hi%initialized = .true. - end subroutine hard_interaction_init - - subroutine hard_interaction_unload (hi) - type(hard_interaction_t), intent(inout), target :: hi - if (hi%is_copy .or. .not. associated (hi%data%final)) return - call hard_interaction_data_unload (hi%data) - end subroutine hard_interaction_unload - - subroutine hard_interaction_reload (hi, prc_lib) - type(hard_interaction_t), intent(inout), target :: hi - type(process_library_t), intent(in) :: prc_lib - if (hi%is_copy .or. associated (hi%data%init)) return - call hard_interaction_data_reload (hi%data, prc_lib) - call hi%data% init (real (hi%data%par, c_default_float)) - end subroutine hard_interaction_reload - - subroutine hard_interaction_update_parameters (hi) - type(hard_interaction_t), intent(inout), target :: hi - if (hi%is_copy) return - call model_parameters_to_array (hi%data%model, hi%data%par) - call hi%data% init (real (hi%data%par, c_default_float)) - end subroutine hard_interaction_update_parameters - -@ %def hard_interaction_init -@ %def hard_interaction_unload -@ %def hard_interaction_reload -@ %def hard_interaction_update_parameters -@ Finalizer: -<>= - public :: hard_interaction_final -<>= - subroutine hard_interaction_final (hi) - type(hard_interaction_t), intent(inout) :: hi - hi%initialized = .false. - if (.not. hi%is_copy .and. associated (hi%data)) then - if (associated (hi%data% final)) call hi%data% final () - deallocate (hi%data) - nullify (hi%data) - end if - call interaction_final (hi%int) - call evaluator_final (hi%eval_trace) - call evaluator_final (hi%eval_flows) - call evaluator_final (hi%eval_sqme) - hi%n_values = 0 - if (allocated (hi%flv)) deallocate (hi%flv) - if (allocated (hi%hel)) deallocate (hi%hel) - if (allocated (hi%col)) deallocate (hi%col) - end subroutine hard_interaction_final - -@ %def hard_interaction_final -@ I/O: -<>= - public :: hard_interaction_write -<>= - subroutine hard_interaction_write & - (hi, unit, verbose, show_momentum_sum, show_mass, write_comb) - type(hard_interaction_t), intent(in) :: hi - integer, intent(in), optional :: unit - logical, intent(in), optional :: verbose, show_momentum_sum, show_mass - logical, intent(in), optional :: write_comb - integer :: u, i - u = output_unit (unit); if (u < 0) return - if (hi%is_copy) then - write (u, "(1x,A)") "Hard interaction (copy):" - else - write (u, "(1x,A)") "Hard interaction:" - call hard_interaction_data_write (hi%data, u) - end if - if (present (write_comb)) then - if (write_comb .and. hi%n_values /= 0) then - write (u, "(1x,A)") "Allowed f/h/c index combinations:" - do i = 1, hi%n_values - write (u, *) i, ":", hi%flv(i), hi%hel(i), hi%col(i) - end do - end if - end if - write (u, *) - call interaction_write & - (hi%int, unit, verbose, show_momentum_sum, show_mass) - write (u, *) repeat ("- ", 36) - write (u, "(A)") "Trace including color factors (hard interaction)" - call evaluator_write & - (hi%eval_trace, unit, verbose, show_momentum_sum, show_mass) - write (u, *) repeat ("- ", 36) - write (u, "(A)") "Exclusive sqme including color factors (hard interaction)" - call evaluator_write & - (hi%eval_sqme, unit, verbose, show_momentum_sum, show_mass) - write (u, *) repeat ("- ", 36) - write (u, "(A)") "Color flow coefficients (hard interaction)" - call evaluator_write & - (hi%eval_flows, unit, verbose, show_momentum_sum, show_mass) - end subroutine hard_interaction_write - -@ %def hard_interaction_write -@ Defined assignment. Deep copy (except for procedure pointers, of -course). -<>= - public :: assignment(=) -<>= - interface assignment(=) - module procedure hard_interaction_assign - end interface - -<>= - subroutine hard_interaction_assign (hi_out, hi_in) - type(hard_interaction_t), intent(out) :: hi_out - type(hard_interaction_t), intent(in) :: hi_in - hi_out%initialized = hi_in%initialized - hi_out%is_copy = hi_in%is_copy - if (hi_out%is_copy) then - hi_out%data => hi_in%data - else - allocate (hi_out%data) - hi_out%data = hi_in%data - end if - hi_out%n_values = hi_in%n_values - if (allocated (hi_in%flv)) then - allocate (hi_out%flv (size (hi_in%flv))) - hi_out%flv = hi_in%flv - end if - if (allocated (hi_in%hel)) then - allocate (hi_out%hel (size (hi_in%hel))) - hi_out%hel = hi_in%hel - end if - if (allocated (hi_in%col)) then - allocate (hi_out%col (size (hi_in%col))) - hi_out%col = hi_in%col - end if - hi_out%int = hi_in%int - hi_out%eval_trace = hi_in%eval_trace - call evaluator_replace_interaction (hi_out%eval_trace, hi_out%int) - hi_out%eval_sqme = hi_in%eval_sqme - call evaluator_replace_interaction (hi_out%eval_sqme, hi_out%int) - hi_out%eval_flows = hi_in%eval_flows - call evaluator_replace_interaction (hi_out%eval_flows, hi_out%int) - end subroutine hard_interaction_assign - -@ %def hard_interaction_assign -@ Create a copy. Evaluators are not copied but must be recreated manually. -<>= - public :: hard_interaction_make_copy -<>= - subroutine hard_interaction_make_copy (hi_out, hi_in) - type(hard_interaction_t), intent(in) :: hi_in - type(hard_interaction_t), intent(out) :: hi_out - hi_out%initialized = hi_in%initialized - hi_out%is_copy = .true. - hi_out%data => hi_in%data - hi_out%n_values = hi_in%n_values - if (allocated (hi_in%flv)) then - allocate (hi_out%flv (size (hi_in%flv))) - hi_out%flv = hi_in%flv - end if - if (allocated (hi_in%hel)) then - allocate (hi_out%hel (size (hi_in%hel))) - hi_out%hel = hi_in%hel - end if - if (allocated (hi_in%col)) then - allocate (hi_out%col (size (hi_in%col))) - hi_out%col = hi_in%col - end if - hi_out%int = hi_in%int - end subroutine hard_interaction_make_copy - -@ %def hard_interaction_make_copy - -\subsection{Access contents} -Whether we have a valid data set: -<>= - public :: hard_interaction_is_valid -<>= - function hard_interaction_is_valid (hi) result (flag) - logical :: flag - type(hard_interaction_t), intent(in) :: hi - flag = hi%initialized - end function hard_interaction_is_valid - -@ %def hard_interaction_is_valid -@ The alphanumeric ID. -<>= - public :: hard_interaction_get_id -<>= - function hard_interaction_get_id (hi) result (id) - type(string_t) :: id - type(hard_interaction_t), intent(in) :: hi - id = hi%data%id - end function hard_interaction_get_id - -@ %def hard_interaction_get_id -@ The model as used for the hard interaction. -<>= - public :: hard_interaction_get_model_ptr -<>= - function hard_interaction_get_model_ptr (hi) result (model) - type(model_t), pointer :: model - type(hard_interaction_t), intent(in) :: hi - model => hi%data%model - end function hard_interaction_get_model_ptr - -@ %def hard_interaction_get_model_ptr -@ Particle counts. -<>= - public :: hard_interaction_get_n_in - public :: hard_interaction_get_n_out - public :: hard_interaction_get_n_tot -<>= - pure function hard_interaction_get_n_in (hi) result (n_in) - integer :: n_in - type(hard_interaction_t), intent(in) :: hi - n_in = hi%data%n_in - end function hard_interaction_get_n_in - - pure function hard_interaction_get_n_out (hi) result (n_out) - integer :: n_out - type(hard_interaction_t), intent(in) :: hi - n_out = hi%data%n_out - end function hard_interaction_get_n_out - - pure function hard_interaction_get_n_tot (hi) result (n_tot) - integer :: n_tot - type(hard_interaction_t), intent(in) :: hi - n_tot = hi%data%n_tot - end function hard_interaction_get_n_tot - -@ %def hard_interaction_get_n_in -@ %def hard_interaction_get_n_out -@ %def hard_interaction_get_n_tot -@ Quantum number counts. -<>= - public :: hard_interaction_get_n_flv - public :: hard_interaction_get_n_col - public :: hard_interaction_get_n_hel -<>= - pure function hard_interaction_get_n_flv (hi) result (n_flv) - integer :: n_flv - type(hard_interaction_t), intent(in) :: hi - n_flv = hi%data%n_flv - end function hard_interaction_get_n_flv - - pure function hard_interaction_get_n_col (hi) result (n_col) - integer :: n_col - type(hard_interaction_t), intent(in) :: hi - n_col = hi%data%n_col - end function hard_interaction_get_n_col - - pure function hard_interaction_get_n_hel (hi) result (n_hel) - integer :: n_hel - type(hard_interaction_t), intent(in) :: hi - n_hel = hi%data%n_hel - end function hard_interaction_get_n_hel - -@ %def hard_interaction_get_n_flv -@ %def hard_interaction_get_n_col -@ %def hard_interaction_get_n_hel -@ Particle tables. -<>= - public :: hard_interaction_get_flv_states -<>= - function hard_interaction_get_flv_states (hi) result (flv_state) - integer, dimension(:,:), allocatable :: flv_state - type(hard_interaction_t), intent(in) :: hi - allocate (flv_state (size (hi%data%flv_state, 1), & - size (hi%data%flv_state, 2))) - flv_state = hi%data%flv_state - end function hard_interaction_get_flv_states - -@ %def hard_interaction_get_flv_states -@ Color factor tables. -<>= - public :: hard_interaction_get_n_cf -<>= - pure function hard_interaction_get_n_cf (hi) result (n_cf) - integer :: n_cf - type(hard_interaction_t), intent(in) :: hi - n_cf = hi%data%n_cf - end function hard_interaction_get_n_cf - -@ %def hard_interaction_get_n_cf -@ Incoming particles. Consider only the first entry in -the array of flavor combinations. - -If the process is forbidden and no flavor states are present, create -at least an initial state with undefined particles. -<>= - public :: hard_interaction_get_first_pdg_in -<>= - function hard_interaction_get_first_pdg_in (hi) result (pdg) - integer, dimension(:), allocatable :: pdg - type(hard_interaction_t), intent(in) :: hi - allocate (pdg (hi%data%n_in)) - if (hi%data%n_flv > 0) then - pdg = hi%data%flv_state (:hi%data%n_in, 1) - else - pdg = 0 - end if - end function hard_interaction_get_first_pdg_in - -@ %def hard_interaction_get_first_pdg_in -@ The analogous function for outgoing particles. Again, only the -first entry in the array of flavor combinations. -<>= - public :: hard_interaction_get_first_pdg_out -<>= - function hard_interaction_get_first_pdg_out (hi) result (pdg) - integer, dimension(:), allocatable :: pdg - type(hard_interaction_t), intent(in) :: hi - allocate (pdg (hi%data%n_out)) - if (hi%data%n_flv > 0) then - pdg = hi%data%flv_state (hi%data%n_in+1:hi%data%n_tot, 1) - else - pdg = 0 - end if - end function hard_interaction_get_first_pdg_out - -@ %def hard_interaction_get_first_pdg_out -@ This procedure is used for checking whether some of the final-state -particles can initiate decay cascades. We check only the first row in the -flavor array, since unstable particles are massive and should not be subject -to flavor summation. Thus they must be common to all rows. -<>= - public :: hard_interaction_get_unstable_products -<>= - subroutine hard_interaction_get_unstable_products (hi, flv_unstable) - type(hard_interaction_t), intent(in) :: hi - type(flavor_t), dimension(:), intent(out), allocatable :: flv_unstable - type(model_t), pointer :: model - integer, dimension(hi%data%n_out) :: pdg_out - type(flavor_t) :: flv - integer :: i - model => hi%data%model - if (associated (model) .and. size (hi%data%flv_state, 2) /= 0) then - pdg_out = hi%data%flv_state(hi%data%n_in+1:,1) - do i = 1, size (pdg_out) - if (pdg_out(i) /= 0) then - call flavor_init (flv, pdg_out(i), model) - if (flavor_is_stable (flv)) then - where (pdg_out(i:) == pdg_out(i)) pdg_out(i:) = 0 - else - where (pdg_out(i+1:) == pdg_out(i)) pdg_out(i+1:) = 0 - end if - end if - end do - allocate (flv_unstable (count (pdg_out /= 0))) - call flavor_init & - (flv_unstable, pack (pdg_out, pdg_out /= 0), model) - else - allocate (flv_unstable (0)) - end if - end subroutine hard_interaction_get_unstable_products - -@ %def hard_interaction_get_unstable_products -@ -\subsection{Evaluators} -This procedure initializes the evaluator that computes the matrix -element squared, traced over all outgoing quantum numbers. Whether -the trace over incoming quantum numbers is done, depends on the -specified mask -- except for color which is always summed. -<>= - public :: hard_interaction_init_trace -<>= - subroutine hard_interaction_init_trace & - (hi, qn_mask_in, use_hi_color_factors, nc) - type(hard_interaction_t), intent(inout), target :: hi - type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in - logical, intent(in), optional :: use_hi_color_factors - integer, intent(in), optional :: nc - logical :: use_hi_cf - type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask - if (present (use_hi_color_factors)) then - use_hi_cf = use_hi_color_factors - else - use_hi_cf = .false. - end if - allocate (qn_mask (hi%data%n_tot)) - qn_mask(:hi%data%n_in) = & - new_quantum_numbers_mask (.false., .true., .false.) & - .or. qn_mask_in - qn_mask(hi%data%n_in+1:) = & - new_quantum_numbers_mask (.true., .true., .true.) - if (use_hi_cf) then - call evaluator_init_square (hi%eval_trace, hi%int, qn_mask, & - hi%data%col_flow_index, hi%data%col_factor, hi%col, nc=nc) - else - call evaluator_init_square (hi%eval_trace, hi%int, qn_mask, nc=nc) - end if - end subroutine hard_interaction_init_trace - -@ %def hard_interaction_init_trace -@ This procedure initializes the evaluator that computes the matrix -element square separated in parts (e.g., polarization components). -Polarization is kept in the initial state (if allowed by -[[qn_mask_in]]) and for those final-state -particles which are marked as unstable. The incoming-particle mask -can also be used to sum over incoming flavor. -<>= - public :: hard_interaction_init_sqme -<>= - subroutine hard_interaction_init_sqme & - (hi, qn_mask_in, use_hi_color_factors, nc) - type(hard_interaction_t), intent(inout), target :: hi - type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in - logical, intent(in), optional :: use_hi_color_factors - integer, intent(in), optional :: nc - logical :: use_hi_cf - type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask - type(flavor_t), dimension(:), allocatable :: flv - integer :: i - logical :: helmask, helmask_hd - if (present (use_hi_color_factors)) then - use_hi_cf = use_hi_color_factors - else - use_hi_cf = .false. - end if - allocate (qn_mask (hi%data%n_tot), flv (hi%data%n_flv)) - qn_mask(:hi%data%n_in) = & - new_quantum_numbers_mask (.false., .true., .false.) & - .or. qn_mask_in - do i = hi%data%n_in + 1, hi%data%n_tot - call flavor_init (flv, hi%data%flv_state(i,:), hi%data%model) - if (.not. all (flavor_is_stable (flv))) then - helmask = all (flavor_decays_isotropically (flv)) - helmask_hd = all (flavor_decays_diagonal (flv)) - else - helmask = all (.not. flavor_is_polarized (flv)) - helmask_hd = .true. - end if - qn_mask(i) = new_quantum_numbers_mask (.false., .true., & - helmask, mask_hd = helmask_hd) - end do - if (use_hi_cf) then - call evaluator_init_square (hi%eval_sqme, hi%int, qn_mask, & - hi%data%col_flow_index, hi%data%col_factor, hi%col, nc=nc) - else - call evaluator_init_square (hi%eval_sqme, hi%int, qn_mask, nc=nc) - end if - end subroutine hard_interaction_init_sqme - -@ %def hard_interaction_init_sqme -@ This procedure initializes the evaluator that computes the -contributions to color flows, neglecting color interference. -The incoming-particle mask can be used to sum over incoming flavor. -<>= - public :: hard_interaction_init_flows -<>= - subroutine hard_interaction_init_flows (hi, qn_mask_in) - type(hard_interaction_t), intent(inout), target :: hi - type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in - type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask - type(flavor_t), dimension(:), allocatable :: flv - integer :: i - logical :: helmask, helmask_hd - allocate (qn_mask (hi%data%n_tot), flv (hi%data%n_flv)) - qn_mask(:hi%data%n_in) = & - new_quantum_numbers_mask (.false., .false., .false.) & - .or. qn_mask_in - do i = hi%data%n_in + 1, hi%data%n_tot - call flavor_init (flv, hi%data%flv_state(i,:), hi%data%model) - if (.not. all (flavor_is_stable (flv))) then - helmask = all (flavor_decays_isotropically (flv)) - helmask_hd = all (flavor_decays_diagonal (flv)) - else - helmask = all (.not. flavor_is_polarized (flv)) - helmask_hd = .true. - end if - qn_mask(i) = new_quantum_numbers_mask (.false., .false., & - helmask, mask_hd = helmask_hd) - end do - call evaluator_init_square (hi%eval_flows, hi%int, qn_mask, & - expand_color_flows = .true.) - end subroutine hard_interaction_init_flows - -@ %def hard_interaction_init_flows -@ Finalize the previous evaluators. -<>= - public :: hard_interaction_final_sqme - public :: hard_interaction_final_flows -<>= - subroutine hard_interaction_final_sqme (hi) - type(hard_interaction_t), intent(inout) :: hi - call evaluator_final (hi%eval_sqme) - end subroutine hard_interaction_final_sqme - - subroutine hard_interaction_final_flows (hi) - type(hard_interaction_t), intent(inout) :: hi - call evaluator_final (hi%eval_flows) - end subroutine hard_interaction_final_flows - -@ %def hard_interaction_final_sqme hard_interaction_final_flows -@ -\subsection{Matrix-element evaluation} -Update the $\alpha_s$ value used by the matrix element (if any). -<>= - public :: hard_interaction_update_alpha_s -<>= - subroutine hard_interaction_update_alpha_s (hi, alpha_s) - type(hard_interaction_t), intent(inout) :: hi - real(default), intent(in) :: alpha_s - real(c_default_float) :: c_alpha_s - c_alpha_s = alpha_s - call hi%data% update_alpha_s (c_alpha_s) - end subroutine hard_interaction_update_alpha_s - -@ %def hard_interaction_update_alpha_s -@ Reset the helicity selection counters that are used to speed up -things by dropping zero helicity channels after [[cutoff]] tries. -<>= - public :: hard_interaction_reset_helicity_selection -<>= - subroutine hard_interaction_reset_helicity_selection (hi, threshold, cutoff) - type(hard_interaction_t), intent(inout) :: hi - real(default), intent(in) :: threshold - integer, intent(in) :: cutoff - real(c_default_float) :: c_threshold - integer(c_int) :: c_cutoff - c_threshold = threshold - c_cutoff = cutoff - call hi%data% reset_helicity_selection (c_threshold, c_cutoff) - end subroutine hard_interaction_reset_helicity_selection - -@ %def hard_interaction_reset_helicity_selection -@ -This interfaces the matrix element proper. First, we request a new -matrix element value to be computed from the given momenta. Then, we -extract all values that are known to be allowed and assign them to the -matrix element array. This array consists of pointers to the -interaction values, so in fact the latter are calculated. - -Although it may be irrelevant, this is an obvious place for parallel -execution, so write a forall assignment. Making the assignment -elemental is not possible because [[get_amplitude]] is a procedure -pointer. [This is deactivated; to be checked again.] - -After the matrix element data are read, we evaluate the squared matrix -element ([[eval_trace]]). -square and the -color-flow coefficients. -<>= - public :: hard_interaction_evaluate -<>= - subroutine hard_interaction_evaluate (hi) - type(hard_interaction_t), intent(inout), target :: hi - integer :: i - complex(default) :: val - call hi%data% new_event & - (array_from_vector4 (interaction_get_momenta (hi%int))) -! forall (i = 1:hi%n_values) -! hi%me(i) = hi%data% get_amplitude (hi%flv(i), hi%hel(i), hi%col(i)) -! end forall - do i = 1, hi%n_values - val = hi%data% get_amplitude (hi%flv(i), hi%hel(i), hi%col(i)) - call interaction_set_matrix_element (hi%int, i, val) - end do - call evaluator_evaluate (hi%eval_trace) - end subroutine hard_interaction_evaluate - -@ %def hard_interaction_evaluate -@ The extra evaluators (squared matrix element without trace, color -flows) need only be evaluated for simulation events that pass the -unweighting step. This follows the previous routine. -<>= - public :: hard_interaction_evaluate_sqme - public :: hard_interaction_evaluate_flows -<>= - subroutine hard_interaction_evaluate_sqme (hi) - type(hard_interaction_t), intent(inout), target :: hi - call evaluator_receive_momenta (hi%eval_sqme) - call evaluator_evaluate (hi%eval_sqme) - end subroutine hard_interaction_evaluate_sqme - - subroutine hard_interaction_evaluate_flows (hi) - type(hard_interaction_t), intent(inout), target :: hi - call evaluator_receive_momenta (hi%eval_flows) - call evaluator_evaluate (hi%eval_flows) - end subroutine hard_interaction_evaluate_flows - -@ %def hard_interaction_evaluate_sqme hard_interaction_evaluate_flows -@ This provides direct access to the matrix element, squared and -traced over all quantum numbers. It is not used for ordinary evaluation. -<>= - public :: hard_interaction_compute_sqme_sum -<>= - function hard_interaction_compute_sqme_sum (hi, p) result (sqme) - real(default) :: sqme - type(hard_interaction_t), intent(inout), target :: hi - type(vector4_t), dimension(:), intent(in) :: p - call interaction_set_momenta (hi%int, p) - call hard_interaction_evaluate (hi) - sqme = evaluator_sum (hi%eval_trace) - end function hard_interaction_compute_sqme_sum - -@ %def hard_interaction_compute_sqme_sum -@ -\subsection{Access results} -<>= - public :: hard_interaction_get_int_ptr -<>= - function hard_interaction_get_int_ptr (hi) result (int) - type(interaction_t), pointer :: int - type(hard_interaction_t), intent(in), target :: hi - int => hi%int - end function hard_interaction_get_int_ptr - -@ %def hard_interaction_get_int_ptr -<>= - public :: hard_interaction_get_eval_trace_ptr - public :: hard_interaction_get_eval_sqme_ptr - public :: hard_interaction_get_eval_flows_ptr -<>= - function hard_interaction_get_eval_trace_ptr (hi) result (eval) - type(evaluator_t), pointer :: eval - type(hard_interaction_t), intent(in), target :: hi - eval => hi%eval_trace - end function hard_interaction_get_eval_trace_ptr - - function hard_interaction_get_eval_sqme_ptr (hi) result (eval) - type(evaluator_t), pointer :: eval - type(hard_interaction_t), intent(in), target :: hi - eval => hi%eval_sqme - end function hard_interaction_get_eval_sqme_ptr - - function hard_interaction_get_eval_flows_ptr (hi) result (eval) - type(evaluator_t), pointer :: eval - type(hard_interaction_t), intent(in), target :: hi - eval => hi%eval_flows - end function hard_interaction_get_eval_flows_ptr - -@ %def hard_interaction_get_eval_trace_ptr -@ %def hard_interaction_get_eval_sqme_ptr -@ %def hard_interaction_get_eval_flows_ptr -@ -\subsection{Reconstruction} -Reconstruct the kinematics of the hard interaction from a given particle set. -The particle set may have been decayed, and the particle order is not -necessarily correct. -<>= - public :: hard_interaction_recover_kinematics -<>= - subroutine hard_interaction_recover_kinematics (hi, pset) - type(hard_interaction_t), intent(inout) :: hi - type(particle_set_t), intent(in) :: pset - call particle_set_extract_interaction (pset, hi%int, hi%data%flv_state) - end subroutine hard_interaction_recover_kinematics - -@ %def hard_interaction_recover_kinematics -@ -\subsection{Process summary} -Write an account of the allowed quantum numbers. -<>= - public :: hard_interaction_write_state_summary -<>= - subroutine hard_interaction_write_state_summary (hi, unit) - type(hard_interaction_t), intent(in), target :: hi - integer, intent(in), optional :: unit - type(state_iterator_t) :: it - integer :: u, i, f, h, c - character(1) :: sgn - u = output_unit (unit) - call state_iterator_init (it, interaction_get_state_matrix_ptr (hi%int)) - do while (state_iterator_is_valid (it)) - i = state_iterator_get_me_index (it) - f = hi%flv(i) - h = hi%hel(i) - c = hi%col(i) - if (hi%data% is_allowed (f, h, c)) then - sgn = "+" - else - sgn = " " - end if - write (u, "(1x,A1,1x,I0,2x)", advance="no") sgn, i - call quantum_numbers_write (state_iterator_get_quantum_numbers (it), u) - write (u, *) - call state_iterator_advance (it) - end do - end subroutine hard_interaction_write_state_summary - -@ %def hard_interaction_write_state_summary -@ -\subsection{Test} -<>= - public :: hard_interaction_test -<>= - subroutine hard_interaction_test (model) - type(model_t), target :: model - type(process_library_t), pointer :: prc_lib => null () - type(os_data_t), pointer :: os_data => null () - type(hard_interaction_t), pointer :: hi => null () - type(var_list_t), pointer :: var_list => null () - type(vector4_t), dimension(4) :: p - type(quantum_numbers_mask_t), dimension(2) :: qn_mask_in - type(quantum_numbers_mask_t), dimension(4) :: qn_mask - real(default) :: sqme, mh - allocate (hi) - allocate (prc_lib) - allocate (os_data) - allocate (var_list) - call os_data_init (os_data) - call msg_message ("*** Load library 'test_me'") - call msg_message & - (" [must exist and contain process 'test_me_eemm' (test_me.sin)]") - call var_list_append_string & - (var_list, name = "$library_name", sval = "test_me") ! $ - call process_library_init (prc_lib, var_str("test_me"), os_data) - call process_library_load (prc_lib, os_data, var_list = var_list) - call msg_message () - call msg_message ("*** Create hard interaction") - call hard_interaction_init (hi, prc_lib, 1, var_str ("test_me_eemm"), model) - qn_mask_in = new_quantum_numbers_mask (.true., .true., .true.) - call hard_interaction_init_trace (hi, qn_mask_in) - print *, "Interaction: n_values = ", & - interaction_get_n_matrix_elements (hi%int) - qn_mask_in = new_quantum_numbers_mask (.false., .false., .false., .true.) - call hard_interaction_init_sqme (hi, qn_mask_in) - call hard_interaction_init_flows (hi, qn_mask_in) - p(1) = vector4_moving (250._default, 250._default, 3) - p(2) = vector4_moving (250._default,-250._default, 3) - p(3) = rotation (1._default, 1) * p(1) - p(4) = p(1) + p(2) - p(3) - call msg_message () - call msg_message ("*** Evaluate new event") - sqme = hard_interaction_compute_sqme_sum (hi, p) - call hard_interaction_evaluate_sqme (hi) - call hard_interaction_evaluate_flows (hi) - call hard_interaction_write (hi) - print * - print *, "sqme sum =", sqme - print * - print *, "*** Cleanup" - call hard_interaction_final (hi) - call process_library_final (prc_lib) - end subroutine hard_interaction_test - -@ %def hard_interaction_test -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Core interactions} - -This is in abstraction above the hard core interaction which can be either a -% -\begin{itemize} -\item \oMega\ tree level matrix element ($\rightarrow$ [[hard_interaction_t]]) -% -\item NLO matrix element via BLHA -% -\item Dipole -% -\item Subtractor combining dipole and matrix element -% -\end{itemize} - -Evaluating a dipole or a recombined matrix element requires a much more involved -kinematical setup than the straightforward evaluation of a simple matrix -element: -% -\begin{itemize} -\item In order for real dipole subtraction terms to be analytically integrable, -the additional emission must always be recombined with the emitter. For the same -reason, the cuts and the renormalization / factorization scales must depend only -on those recombined momenta. Thus, a $n+1$ particle subtraction term built from -$m$ individual dipoles can lead to as much as $m$ different $n$ particle phase -space points which have to be considered separately. As filling a histogram bin -is equivalent to integrating the recombined momenta over a restricted subset of -phase space, these $m$ points have to be treated as separate events in the event -generation. In the following, these points will be referred to as ``out'' -points. -% -\item Integrating dipole components involving an initial particle as either -emitter or spectator leads to a convolution integral of the form -% -\[ -\mathcal{D} = - \int_0^1 dx\; \left(\int d\phi A(x) - \int d\phi(x) B(x)\right) + - \int d\phi\;C -\] -% -where the second integral is over the phase space associated with the the -initial state kinematics \emph{after} the additional emission. -Both the phasespace integrals over $A$ and $B$ are singular for $x\rightarrow 1$ -and only the difference is finite. This cancellation can be implemented by -calculating $\phi(1)$ and $\phi(x)$ from the same set of random variables $\xi$ -in the phase space sampling. In the limit $x\rightarrow 1$, the those points -will coincide, and the cancellation between the two terms will render the sum -finite. Thus, the phasespace ``forks'' into two different configurations which I -will refer to as ``in''points. As a typical subtraction terms will involve -emissions from both inital state partons, there will usually be three different -``in'' points which also lead to three different ``out'' points. - -In the language using plus distribution, this approach corresponds to directly -evaluating the prescription for the plus distribution in the integration over -the MC hypercube. -% -\item Recombining the real subtraction term with the real emission matrix -element requires a collinear / IR safe recombination of the additional emission -with the emitter. Together with the first bullet, this suggests treating both -the dipole and the matrix element as $n+1$ particle processes only for the -purpose of phase space generation and effectively as $n$ particle processes -everywhere else. -\end{itemize} -% - -The workflow for evaluating the core interaction at a phase space point should -look like the following: -% -\begin{enumerate} -\item Draw random variables $\xi$. -\item Determine parton level kinematics from structure function chain and -communicate them to the core interaction. -\item Query the boosts defining any additional ``in'' points from the core -interactions. -\item Generate all ``in'' points and hand them over to the core interaction. -\item Get the ``out'' kinematics from the core interaction which should proceed -via associated [[interaction_t]] objects. -\item Evaluate cuts and scales, communicate the result to the core interaction. -\item Evaluate core interaction. This will fill in the matrix elements in the -[[interaction_t]] objects and evaluators associated with the ``out'' points. -\item Evaluate the structure function chain for the different ``out'' points. -\item Calculate the jacobians, communicate them together with phase space volume -etc. to the core interaction as ``weight''. -\item The final value of the sample function can now be retrieved from -evaluators multiplying the desity matrices associated with the structure -function chain and the core interaction after summing this product over the -``out'' points with the proper (jacobian) weights. -\end{enumerate} -% -Subsequent event generation should be straightforward, with the ``out'' -configurations being treated as separate weighted events. The weights may be -negative and can get large, but for a collinear / IR safe observe, they will add -to a finite value in each histogram bin. The [[core_interaction_t]] interface -should facilitate this chain. - -NOTES: -\begin{itemize} -\item I still am not clear how a good way of stating the recombination criteriom -should look like. The ideal solution should give the flexibility to cover most -physically interesting cases. However, I think it is safe to defer this as the -necessary functionality is mostly encapsulated in [[core_interaction_t]]. -% -\item Unpolarized dipoles should suffice for a start. After the setup detailed -above has been implemented, the extension to polarized dipoles (massive dipoles, -cut dipoles, whatever) will be straightforward and localized \emph{only} to the -core interaction and dipole modules. -% -\item The simple approach to calculating the dipoles currently implemented -applies only to photon / gluon radiation. Photon / gluon splitting in the -initial / final states is more involved and requires a sum over emitter, -spectator and emitted parton. To this end, a much more involved mapping between -the Born flavor states and the dipole flavor states is required. -\end{itemize} - -In order to avoid cyclic dependencies, this module is split into -[[core_interactions_config]] (which holds all declarations which are necessary -to describe the configuration of the core interaction) and -[[core_interactions]] (the actual implementation. - -<<[[core_interactions_config.f90]]>>= -<> - -module core_interactions_config - - use kinds !NODEP! - <> - use diagnostics !NODEP! - -<> - -<> - -<> - -contains - -<> - -end module core_interactions_config -@ %def core_interactions_config -@ -<<[[core_interactions.f90]]>>= -<> - -module core_interactions - - use kinds !NODEP! -<> -<> - use diagnostics !NODEP! - use lorentz !NODEP! - use models - use flavors - use helicities - use colors - use quantum_numbers - use state_matrices - use interactions - use evaluators - use particles - use prclib_interfaces - use process_libraries - use hard_interactions - use core_interactions_config - use dipoles_integrated_qed - use dipoles_real_qed - use photon_recombination - use nlo_setup - -<> - -<> - -<> - -<> - -<> - -contains - -<> - -end module core_interactions -@ %def core_interactions -@ - -\subsection{Configuration} - -A tag discriminates between the different underlying matrix element types -<>= -integer, parameter, public :: & - CI_OMEGA=1, CI_BLHA=2, CI_DIPOLE_INTEGRATED_QED=3, & - CI_DIPOLE_REAL_QED=4, CI_DIPOLE_INTEGRATED_QCD=5, CI_DIPOLE_REAL_QCD=6, & - CI_SUM = 11, CI_PHOTON_RECOMBINATION = 12, CI_UNDEFINED = -1 - -@ %def CI_OMEGA CI_BLHA CI_DIPOLE_INTEGRATED_QED CI_DIPOLE_REAL_QED -@ %def CI_DIPOLE_INTEGRATED_QCD CI_DIPOLE_REAL_QCD -@ %def CI_SUBTRACTED_VIRT_QED CI_SUBTRACTED_REAL_QED -@ %def CI_SUBTRACTED_REAL_QCD CI_SUBTRACTED_VIRT_QCD -@ %def CI_UNDEFINED CI_SUM CI_PHOTON_RECOMBINATION -@ -Return a textual description of the core interaction type. We will need it -often, so we define a function. -<>= -public :: core_interaction_type_description -<>= -function core_interaction_type_description (id) result (desc) -integer, intent(in) :: id -type(string_t) :: desc - select case (id) - case (CI_OMEGA) - desc = "O'Mega matrix element" - case (CI_BLHA) - desc = "BLHA matrix element" - case (CI_DIPOLE_INTEGRATED_QED) - desc = "Integrated QED dipole" - case (CI_DIPOLE_REAL_QED) - desc = "Unintegrated QED dipole" - case (CI_DIPOLE_INTEGRATED_QCD) - desc = "Integrated QCD dipole" - case (CI_DIPOLE_REAL_QCD) - desc = "Unintegrated QCD dipole" - case (CI_SUM) - desc = "Sum of two interactions" - case (CI_PHOTON_RECOMBINATION) - desc = "Tree level with photon emission recombined" - case default - desc = "[undefined]" - end select -end function core_interaction_type_description - -@ %def core_interaction_type_description -@ - -\subsection{Implementation} - -As the program proceeds along the evaluation chain, the state of the core -interaction objects is advanced using tags: -% -\begin{enumerate} -\item [[CI_STATE_CLEAR]] A new evaluation cycle begins. -% -\item [[CI_STATE_SEED_MOMENTA_SET]] The ingoing seed momenta have been -communicated to the interaction objects and any additional convolution parameters -have been set via [[core_interaction_set_x]]. Triggers the evaluation of the -auxiliary kinematics. -% -\item [[CI_STATE_MOMENTA_SET]] All ingoing momenta have been set. This triggers -the evaluation of the ``out'' kinematics. -% -\item [[CI_STATE_EVALUATE]] Cuts (and scales) have been set up. After -this point, [[core_interaction_evaluate]] may be called. -% -\item [[CI_STATE_WEIGHTS_SET]] All phasespace weights (jacobians times volume -factors) have been set via [[core_interaction_set_weight]]. Triggers the -computation of the ``out'' weights. -\end{enumerate} -% -To advance the state, [[core_interaction_set_state]] is called. -<>= -integer, public, parameter :: CI_STATE_CLEAR=1, & - CI_STATE_SEED_MOMENTA_SET=2, CI_STATE_MOMENTA_SET=3, CI_STATE_EVALUATE=4, & - CI_STATE_WEIGHTS_SET=5 - -@ %def CI_STATE_CLEAR CI_STATE_SEED_MOMENTA_SET CI_STATE_EVALUATE -@ %def CI_STATE_WEIGHTS_SET CI_STATE_MOMENTA_SET -@ -The [[core_interaction_t]] type wraps around the different ``subclasses''. -<>= -public :: core_interaction_t -<>= -type core_interaction_t - private - integer :: type = CI_UNDEFINED - integer :: state = CI_STATE_CLEAR - type(hard_interaction_t) :: hard_interaction - logical :: me_passed_cut - real(kind=default) :: me_weight - integer :: me_n_in, me_n_out, me_n_tot - type(dipole_integrated_qed_t) :: dipole_integrated_qed - type(dipole_real_qed_t) :: dipole_real_qed - type(core_interaction_sum_t), pointer :: core_interaction_sum - type(photon_recombination_t) :: photon_recombination -end type core_interaction_t - -@ %def core_interaction_t -@ -Initialization. -<>= -public :: core_interaction_init -<>= -recursive subroutine core_interaction_init (ci, prc_lib, process_index, & - process_id, model, nlo_setup) -type(core_interaction_t), intent(out), target :: ci -type(process_library_t), intent(in) :: prc_lib -integer, intent(in) :: process_index -type(string_t), intent(in) :: process_id -type(model_t), intent(in), target :: model -type(nlo_setup_t), intent(in), optional :: nlo_setup - ci%type = process_library_get_ci_type (prc_lib, process_id) - if (ci%type < 0) call msg_bug ("core_interaction_init: undefined type") - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_init (ci%hard_interaction, & - prc_lib, process_index, process_id, model) - ci%me_n_in = hard_interaction_get_n_in (ci%hard_interaction) - ci%me_n_out = hard_interaction_get_n_out (ci%hard_interaction) - ci%me_n_tot = hard_interaction_get_n_tot (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_init (ci%dipole_integrated_qed, & - prc_lib, process_index, process_id, model, nlo_setup = nlo_setup) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_init (ci%dipole_real_qed, & - prc_lib, process_index, process_id, model, nlo_setup = nlo_setup) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_init (ci%photon_recombination, & - prc_lib, process_index, process_id, model, nlo_setup = nlo_setup) - case (CI_SUM) - call core_interaction_init_sum (ci, prc_lib, process_id, & - process_index, model, nlo_setup = nlo_setup) - case default - call msg_bug ("core_interaction_init: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_init - -@ %def core_interaction_init -@ -Init a [[CI_SUM]] type core interaction. -<>= -recursive subroutine core_interaction_init_sum & - (ci, prc_lib, process_id, pid, model, nlo_setup) -type(core_interaction_t), intent(out), target :: ci -type(process_library_t), intent(in) :: prc_lib -type(string_t), intent(in) :: process_id -integer, intent(in) :: pid -type(model_t), target, intent(in) :: model -type(nlo_setup_t), intent(in), optional :: nlo_setup -type(nlo_setup_t) :: setup -type(core_interaction_sum_t) :: cis -type(core_interaction_t) :: ci1, ci2 -type(string_t) :: id1, id2 -integer :: pid1, pid2 - if (present (nlo_setup)) then - setup = nlo_setup - else - setup = process_library_get_nlo_setup (prc_lib, process_id) - end if - id1 = process_library_get_sum_child (prc_lib, process_id, 1) - id2 = process_library_get_sum_child (prc_lib, process_id, 2) - pid1 = process_library_get_process_pid (prc_lib, id1) - pid2 = process_library_get_process_pid (prc_lib, id2) - if (pid1 < 0) then - call not_found (id1) - return - end if - if (pid2 < 0) then - call not_found (id2) - return - end if - call core_interaction_init (ci1, prc_lib, pid1, id1, model, nlo_setup = setup) - call core_interaction_init (ci2, prc_lib, pid2, id2, model, nlo_setup = setup) - allocate (ci%core_interaction_sum) - call core_interaction_sum_init (ci%core_interaction_sum, ci1, ci2, & - process_id) - ci%type = CI_SUM - call core_interaction_final (ci1) - call core_interaction_final (ci2) - -contains - - subroutine not_found (id) - type(string_t), intent(in) :: id - call msg_error ("process " // char (id) // " does not exist" // & - " in process library " // char (process_library_get_name (prc_lib))) - end subroutine not_found - -end subroutine core_interaction_init_sum - -@ %def core_interaction_init_sum -@ -Finalization. -<>= -public :: core_interaction_final -<>= -recursive subroutine core_interaction_final (ci) -type(core_interaction_t), intent(inout) :: ci - select case (ci%type) - case (CI_UNDEFINED) - case (CI_OMEGA) - call hard_interaction_final (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_final (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_final (ci%dipole_real_qed) - case (CI_SUM) - call core_interaction_sum_final (ci%core_interaction_sum) - deallocate (ci%core_interaction_sum) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_final (ci%photon_recombination) - case default - call msg_bug ("core_interaction_final: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select - ci%type = CI_UNDEFINED -end subroutine core_interaction_final - -@ %def core_interaction_final -@ -Return the core interaction type. -<>= -public :: core_interaction_get_type -<>= -function core_interaction_get_type (ci) result (t) -type(core_interaction_t), intent(in) :: ci -integer ::t - t = ci%type -end function core_interaction_get_type - -@ %def core_interaction_get_type -@ -Process library unload and reload hooks. -<>= -public :: core_interaction_unload -public :: core_interaction_reload -<>= -recursive subroutine core_interaction_unload (ci) -type(core_interaction_t), intent(inout) :: ci - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_unload (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_unload (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_unload (ci%dipole_real_qed) - case (CI_SUM) - call core_interaction_unload (ci%core_interaction_sum%ci1) - call core_interaction_unload (ci%core_interaction_sum%ci2) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_unload (ci%photon_recombination) - case default - call msg_bug ("core_interaction_unload: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_unload - -recursive subroutine core_interaction_reload (ci, prc_lib) -type(core_interaction_t), intent(inout) :: ci -type(process_library_t), intent(in) :: prc_lib - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_reload (ci%hard_interaction, prc_lib) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_reload (ci%dipole_integrated_qed, & - prc_lib) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_reload (ci%dipole_real_qed, prc_lib) - case (CI_SUM) - call core_interaction_reload (ci%core_interaction_sum%ci1, prc_lib) - call core_interaction_reload (ci%core_interaction_sum%ci2, prc_lib) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_reload (ci%photon_recombination, prc_lib) - case default - call msg_bug ("core_interaction_reload: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_reload - -@ %def core_interaction_unload core_interaction_reload -Update the model parameters -<>= -public :: core_interaction_update_parameters -<>= -recursive subroutine core_interaction_update_parameters (ci) -type(core_interaction_t), intent(inout) :: ci - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_update_parameters (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_update_parameters (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_update_parameters (ci%dipole_real_qed) - case (CI_SUM) - call core_interaction_update_parameters (ci%core_interaction_sum%ci1) - call core_interaction_update_parameters (ci%core_interaction_sum%ci2) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_update_parameters (ci%photon_recombination) - case default - call msg_bug ("core_interaction_update_parameters: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_update_parameters - -@ %def core_interaction_update_parameters -@ -Write contents. -<>= -public :: core_interaction_write -<>= -recursive subroutine core_interaction_write & - (ci, unit, verbose, show_momentum_sum, show_mass, write_comb) -type(core_interaction_t), intent(in) :: ci -integer, intent(in), optional :: unit -logical, intent(in), optional :: verbose, show_momentum_sum, show_mass -logical, intent(in), optional :: write_comb -integer :: u - u = output_unit (unit) - write (u, "(1X,A)") "Core interaction type: " // & - char (core_interaction_type_description (ci%type)) - select case (ci%type) - case (CI_OMEGA) - write (u, "(1X,A)") "Hard interaction:" - call hard_interaction_write (ci%hard_interaction, & - unit, verbose, show_momentum_sum, show_mass, write_comb) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_write (ci%dipole_integrated_qed, unit) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_write (ci%dipole_real_qed, unit) - case (CI_SUM) - call core_interaction_sum_write (ci%core_interaction_sum, & - unit, verbose, show_momentum_sum, show_mass, write_comb) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_write (ci%photon_recombination, & - unit, verbose, show_momentum_sum, show_mass, write_comb) - case default - call msg_bug ("core_interaction_write: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_write - -@ %def core_interaction_write -@ -Assignment operator. -<>= -public :: assignment(=) -<>= -interface assignment(=) - module procedure core_interaction_assign -end interface -<>= -recursive subroutine core_interaction_assign (ci_out, ci_in) -type(core_interaction_t), intent(in) :: ci_in -type(core_interaction_t), intent(inout) :: ci_out - call core_interaction_final (ci_out) - ci_out%type = ci_in%type - select case (ci_in%type) - case (CI_OMEGA) - ci_out%hard_interaction = ci_in%hard_interaction - ci_out%me_passed_cut = ci_in%me_passed_cut - ci_out%me_weight = ci_in%me_weight - ci_out%me_n_in = ci_in%me_n_in - ci_out%me_n_out = ci_in%me_n_out - ci_out%me_n_tot = ci_in%me_n_tot - case (CI_DIPOLE_INTEGRATED_QED) - ci_out%dipole_integrated_qed = ci_in%dipole_integrated_qed - case (CI_DIPOLE_REAL_QED) - ci_out%dipole_real_qed = ci_in%dipole_real_qed - case (CI_SUM) - allocate (ci_out%core_interaction_sum) - ci_out%core_interaction_sum = ci_in%core_interaction_sum - case (CI_PHOTON_RECOMBINATION) - ci_out%photon_recombination = ci_in%photon_recombination - case default - call msg_bug ("core_interaction_assign: not implemented: " & - // char (core_interaction_type_description (ci_in%type))) - end select -end subroutine core_interaction_assign - -@ %def core_interaction_assign -@ -Sanity check. -<>= -public :: core_interaction_is_valid -<>= -recursive function core_interaction_is_valid (ci) result (stat) -type(core_interaction_t), intent(in) :: ci -logical :: stat - if (ci%type < 0) then - stat = .false. - return - end if - select case (ci%type) - case (CI_OMEGA) - stat = hard_interaction_is_valid (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - stat = dipole_integrated_qed_is_valid (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - stat = dipole_real_qed_is_valid (ci%dipole_real_qed) - case (CI_SUM) - stat = core_interaction_sum_is_valid (ci%core_interaction_sum) - case (CI_PHOTON_RECOMBINATION) - stat = photon_recombination_is_valid (ci%photon_recombination) - case default - call msg_bug ("core_interaction_is_valid: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_is_valid - -@ %def core_interaction_is_valid -@ -Process ID. -<>= -public :: core_interaction_get_id -<>= -recursive function core_interaction_get_id (ci) result (id) -type(core_interaction_t), intent(in) :: ci -type(string_t) :: id - select case (ci%type) - case (CI_OMEGA) - id = hard_interaction_get_id (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - id = dipole_integrated_qed_get_id (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - id = dipole_real_qed_get_id (ci%dipole_real_qed) - case (CI_SUM) - id = ci%core_interaction_sum%id - case (CI_PHOTON_RECOMBINATION) - id = photon_recombination_get_id (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_id: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_id - -@ %def core_interaction_get_id -@ -Model pointer. -<>= -public :: core_interaction_get_model_ptr -<>= -recursive function core_interaction_get_model_ptr (ci) result (model) -type(core_interaction_t), intent(in) :: ci -type(model_t), pointer :: model - select case (ci%type) - case (CI_OMEGA) - model => hard_interaction_get_model_ptr (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - model => dipole_integrated_qed_get_model_ptr ( & - ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - model => dipole_real_qed_get_model_ptr (ci%dipole_real_qed) - case (CI_SUM) - model => core_interaction_get_model_ptr (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - model => photon_recombination_get_model_ptr (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_model_ptr: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_model_ptr - -@ %def core_interaction_get_model_ptr -@ -Particle counts. Two variants exist, one for obtaining the effective particle -count after recombination ([[_eff]]), and one for the actual particle count in -the integration ([[_real]]). -<>= -public :: core_interaction_get_n_in -public :: core_interaction_get_n_out_eff -public :: core_interaction_get_n_tot_eff -public :: core_interaction_get_n_out_real -public :: core_interaction_get_n_tot_real -<>= -recursive function core_interaction_get_n_in (ci) result (n_in) -type(core_interaction_t), intent(in) :: ci -integer :: n_in - select case (ci%type) - case (CI_OMEGA) - n_in = ci%me_n_in - case (CI_DIPOLE_INTEGRATED_QED) - n_in = dipole_integrated_qed_get_n_in (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n_in = dipole_real_qed_get_n_in (ci%dipole_real_qed) - case (CI_SUM) - n_in = core_interaction_get_n_in (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - n_in = 2 - case default - call msg_bug ("core_interaction_get_n_in: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_in - -recursive function core_interaction_get_n_out_eff (ci) result (n_out) -type(core_interaction_t), intent(in) :: ci -integer :: n_out - select case (ci%type) - case (CI_OMEGA) - n_out = ci%me_n_out - case (CI_DIPOLE_INTEGRATED_QED) - n_out = dipole_integrated_qed_get_n_out (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n_out = dipole_real_qed_get_n_out_eff (ci%dipole_real_qed) - case (CI_SUM) - n_out = core_interaction_get_n_out_eff (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - n_out = photon_recombination_get_n_out_eff (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_n_out_eff: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_out_eff - -recursive function core_interaction_get_n_tot_eff (ci) result (n_tot) -type(core_interaction_t), intent(in) :: ci -integer :: n_tot - select case (ci%type) - case (CI_OMEGA) - n_tot = ci%me_n_tot - case (CI_DIPOLE_INTEGRATED_QED) - n_tot = dipole_integrated_qed_get_n_tot (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n_tot = dipole_real_qed_get_n_tot_eff (ci%dipole_real_qed) - case (CI_SUM) - n_tot = core_interaction_get_n_tot_eff (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - n_tot = photon_recombination_get_n_tot_eff (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_n_tot: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_tot_eff - -recursive function core_interaction_get_n_out_real (ci) result (n_out) -type(core_interaction_t), intent(in) :: ci -integer :: n_out - select case (ci%type) - case (CI_OMEGA) - n_out = ci%me_n_out - case (CI_DIPOLE_INTEGRATED_QED) - n_out = dipole_integrated_qed_get_n_out (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n_out = dipole_real_qed_get_n_out_real (ci%dipole_real_qed) - case (CI_SUM) - n_out = core_interaction_get_n_out_real (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - n_out = photon_recombination_get_n_out_real (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_n_out_real: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_out_real - -recursive function core_interaction_get_n_tot_real (ci) result (n_tot) -type(core_interaction_t), intent(in) :: ci -integer :: n_tot - select case (ci%type) - case (CI_OMEGA) - n_tot = ci%me_n_tot - case (CI_DIPOLE_INTEGRATED_QED) - n_tot = dipole_integrated_qed_get_n_tot (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n_tot = dipole_real_qed_get_n_tot_real (ci%dipole_real_qed) - case (CI_SUM) - n_tot = core_interaction_get_n_tot_real (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - n_tot = photon_recombination_get_n_tot_real (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_n_tot: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_tot_real - -@ %def core_interaction_get_n_in core_interaction_get_n_out_eff -@ %def core_interaction_get_n_tot_eff -@ %def core_interaction_get_n_out_real -@ %def core_interaction_get_n_tot_real -@ -Quantum number counts. For [[core_interaction_n_flv]], there are again two -[[_eff]] and [[_real]] versions. As the other two methods are currently unused, -they are hidden for the moment -<>= -public :: core_interaction_get_n_flv_eff -public :: core_interaction_get_n_flv_real -!public :: core_interaction_get_n_col -!public :: core_interaction_get_n_hel -<>= -recursive function core_interaction_get_n_flv_eff (ci) result (n_flv) -type(core_interaction_t), intent(in) :: ci -integer :: n_flv - select case (ci%type) - case (CI_OMEGA) - n_flv = hard_interaction_get_n_flv (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - n_flv = dipole_integrated_qed_get_n_flv (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n_flv = dipole_real_qed_get_n_flv (ci%dipole_real_qed) - case (CI_SUM) - n_flv = core_interaction_get_n_flv_eff (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - n_flv = photon_recombination_get_n_flv (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_n_flv_eff: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_flv_eff - -recursive function core_interaction_get_n_flv_real (ci) result (n_flv) -type(core_interaction_t), intent(in) :: ci -integer :: n_flv - select case (ci%type) - case (CI_OMEGA) - n_flv = hard_interaction_get_n_flv (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - n_flv = dipole_integrated_qed_get_n_flv (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n_flv = dipole_real_qed_get_n_flv (ci%dipole_real_qed) - case (CI_SUM) - n_flv = core_interaction_get_n_flv_real (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - n_flv = photon_recombination_get_n_flv (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_n_flv_real: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_flv_real - -! Currently unused -recursive function core_interaction_get_n_col (ci) result (n_col) -type(core_interaction_t), intent(in) :: ci -integer :: n_col - select case (ci%type) - case (CI_OMEGA) - n_col = hard_interaction_get_n_col (ci%hard_interaction) - case default - call msg_bug ("core_interaction_get_n_col: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_col - -! Currently unused -recursive function core_interaction_get_n_hel (ci) result (n_hel) -type(core_interaction_t), intent(in) :: ci -integer :: n_hel - select case (ci%type) - case (CI_OMEGA) - n_hel = hard_interaction_get_n_hel (ci%hard_interaction) - case default - call msg_bug ("core_interaction_get_n_hel: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_hel - -@ %def core_interaction_get_n_flv_eff core_interaction_get_n_col -@ %def core_interaction_get_n_hel core_interaction_get_n_flv_real -@ -Particle tables. Again, we have [[_eff]] and [[_real]]. -<>= -public :: core_interaction_get_flv_states_eff -public :: core_interaction_get_flv_states_real -<>= -recursive function core_interaction_get_flv_states_eff (ci) result (flv_state) -type(core_interaction_t), intent(in) :: ci -integer, dimension(:, :), allocatable :: flv_state - select case (ci%type) - case (CI_OMEGA) - allocate (flv_state (& - size (hard_interaction_get_flv_states (ci%hard_interaction), dim=1), & - size (hard_interaction_get_flv_states (ci%hard_interaction), dim=2) & - )) - flv_state = hard_interaction_get_flv_states (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - allocate (flv_state ( & - dipole_integrated_qed_get_n_tot (ci%dipole_integrated_qed), & - dipole_integrated_qed_get_n_flv (ci%dipole_integrated_qed))) - flv_state = dipole_integrated_qed_get_flv_states ( & - ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - allocate (flv_state ( & - dipole_real_qed_get_n_tot_eff (ci%dipole_real_qed), & - dipole_real_qed_get_n_flv (ci%dipole_real_qed))) - flv_state = dipole_real_qed_get_flv_states_eff (ci%dipole_real_qed) - case (CI_SUM) - allocate (flv_state ( & - core_interaction_get_n_tot_eff (ci%core_interaction_sum%ci1), & - core_interaction_get_n_flv_eff (ci%core_interaction_sum%ci1))) - flv_state = core_interaction_get_flv_states_eff ( & - ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - allocate (flv_state( & - photon_recombination_get_n_tot_eff (ci%photon_recombination), & - photon_recombination_get_n_flv (ci%photon_recombination))) - flv_state = photon_recombination_get_flv_states_eff & - (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_flv_state_eff: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_flv_states_eff - -recursive function core_interaction_get_flv_states_real (ci) result (flv_state) -type(core_interaction_t), intent(in) :: ci -integer, dimension(:, :), allocatable :: flv_state - select case (ci%type) - case (CI_OMEGA) - allocate (flv_state (& - size (hard_interaction_get_flv_states (ci%hard_interaction), dim=1), & - size (hard_interaction_get_flv_states (ci%hard_interaction), dim=2) & - )) - flv_state = hard_interaction_get_flv_states (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - allocate (flv_state ( & - dipole_integrated_qed_get_n_tot (ci%dipole_integrated_qed), & - dipole_integrated_qed_get_n_flv (ci%dipole_integrated_qed))) - flv_state = dipole_integrated_qed_get_flv_states ( & - ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - allocate (flv_state ( & - dipole_real_qed_get_n_tot_real (ci%dipole_real_qed), & - dipole_real_qed_get_n_flv (ci%dipole_real_qed))) - flv_state = dipole_real_qed_get_flv_states_real (ci%dipole_real_qed) - case (CI_SUM) - allocate (flv_state ( & - core_interaction_get_n_tot_real (ci%core_interaction_sum%ci1), & - core_interaction_get_n_flv_real (ci%core_interaction_sum%ci1))) - flv_state = core_interaction_get_flv_states_real ( & - ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - allocate (flv_state( & - photon_recombination_get_n_tot_real (ci%photon_recombination), & - photon_recombination_get_n_flv (ci%photon_recombination))) - flv_state = photon_recombination_get_flv_states_real & - (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_flv_state_real: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_flv_states_real - -@ %def core_interaction_get_flv_states_eff -@ %def core_interaction_get_flv_states_real -@ -Color flow count. Again, I am not yet sure how to map this to dipoles \& friends -but, luckily, it isn't used anywhere right now, so I'll hide it for the moment. -<>= -!public :: core_interaction_get_n_cf -<>= -! Currently unused -recursive function core_interaction_get_n_cf (ci) result (n_cf) -type(core_interaction_t), intent(in) :: ci -integer :: n_cf - select case (ci%type) - case (CI_OMEGA) - n_cf = hard_interaction_get_n_cf (ci%hard_interaction) - case (CI_SUM) - n_cf = core_interaction_get_n_cf (ci%core_interaction_sum%ci1) - case default - call msg_bug ("core_interaction_get_n_cf: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_cf - -@ %def core_interactions_get_n_cf -@ -Incoming and outgoing particles. Only the first particle in a flavor product is -considered. Again, we have [[_eff]] and [[_real]] -<>= -public :: core_interaction_get_first_pdg_in -public :: core_interaction_get_first_pdg_out_eff -public :: core_interaction_get_first_pdg_out_real -<>= -recursive function core_interaction_get_first_pdg_in (ci) result (pdg_in) -type(core_interaction_t), intent(in) :: ci -integer, dimension(:), allocatable :: pdg_in - select case (ci%type) - case (CI_OMEGA) - allocate (pdg_in (size (hard_interaction_get_first_pdg_in ( & - ci%hard_interaction)))) - pdg_in = hard_interaction_get_first_pdg_in (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - allocate (pdg_in (dipole_integrated_qed_get_n_in ( & - ci%dipole_integrated_qed))) - pdg_in = dipole_integrated_qed_get_first_pdg_in ( & - ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - allocate (pdg_in (dipole_real_qed_get_n_in (ci%dipole_real_qed))) - pdg_in = dipole_real_qed_get_first_pdg_in (ci%dipole_real_qed) - case (CI_SUM) - allocate (pdg_in (core_interaction_get_n_in & - (ci%core_interaction_sum%ci1))) - pdg_in = core_interaction_get_first_pdg_in & - (ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - allocate (pdg_in(2)) - pdg_in = photon_recombination_get_first_pdg_in & - (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_first_pdg_in: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_first_pdg_in - -recursive function core_interaction_get_first_pdg_out_eff (ci) result (pdg_out) -type(core_interaction_t), intent(in) :: ci -integer, dimension(:), allocatable :: pdg_out - select case (ci%type) - case (CI_OMEGA) - allocate (pdg_out (size (hard_interaction_get_first_pdg_out ( & - ci%hard_interaction)))) - pdg_out = hard_interaction_get_first_pdg_out (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - allocate (pdg_out (dipole_integrated_qed_get_n_out ( & - ci%dipole_integrated_qed))) - pdg_out = dipole_integrated_qed_get_first_pdg_out ( & - ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - allocate (pdg_out (dipole_real_qed_get_n_out_eff (ci%dipole_real_qed))) - pdg_out = dipole_real_qed_get_first_pdg_out_eff (ci%dipole_real_qed) - case (CI_SUM) - allocate (pdg_out (core_interaction_get_n_out_eff ( & - ci%core_interaction_sum%ci1))) - pdg_out = core_interaction_get_first_pdg_out_eff ( & - ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - allocate (pdg_out(photon_recombination_get_n_out_eff ( & - ci%photon_recombination))) - pdg_out = photon_recombination_get_first_pdg_out_eff ( & - ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_first_pdg_out_eff: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_first_pdg_out_eff - -recursive function core_interaction_get_first_pdg_out_real (ci) result (pdg_out) -type(core_interaction_t), intent(in) :: ci -integer, dimension(:), allocatable :: pdg_out - select case (ci%type) - case (CI_OMEGA) - allocate (pdg_out (size (hard_interaction_get_first_pdg_out ( & - ci%hard_interaction)))) - pdg_out = hard_interaction_get_first_pdg_out (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - allocate (pdg_out (dipole_integrated_qed_get_n_out ( & - ci%dipole_integrated_qed))) - pdg_out = dipole_integrated_qed_get_first_pdg_out ( & - ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - allocate (pdg_out (dipole_real_qed_get_n_out_real ( & - ci%dipole_real_qed))) - pdg_out = dipole_real_qed_get_first_pdg_out_real ( & - ci%dipole_real_qed) - case (CI_SUM) - allocate (pdg_out (core_interaction_get_n_out_real ( & - ci%core_interaction_sum%ci1))) - pdg_out = core_interaction_get_first_pdg_out_real ( & - ci%core_interaction_sum%ci1) - case (CI_PHOTON_RECOMBINATION) - allocate (pdg_out(photon_recombination_get_n_out_real ( & - ci%photon_recombination))) - pdg_out = photon_recombination_get_first_pdg_out_real ( & - ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_first_pdg_out_real: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_first_pdg_out_real -@ %def core_interaction_get_first_pdg_in -@ %core_interaction_get_first_pdg_out_eff -@ %core_interaction_get_first_pdg_out_real -@ -Check for decaying final state products. Only the first entry of each flavor -product is considered. The method operates on the effective final state. -<>= -public :: core_interaction_get_unstable_products -<>= -recursive subroutine core_interaction_get_unstable_products (ci, flavors) -type(core_interaction_t), intent(in) :: ci -type(flavor_t), dimension(:), allocatable, intent(out) :: flavors - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_get_unstable_products (ci%hard_interaction, & - flavors) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_get_unstable_products ( & - ci%dipole_integrated_qed, flavors) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_get_unstable_products (ci%dipole_real_qed, flavors) - case (CI_SUM) - call core_interaction_get_unstable_products ( & - ci%core_interaction_sum%ci1, flavors) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_get_unstable_products ( & - ci%photon_recombination, flavors) - case default - call msg_bug ("core_interaction_get_unstable_products: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_get_unstable_products - -@ %def core_interaction_get_unstable_products -@ -Evaluator init. All evaluators refer to the effective state. -<>= -public :: core_interaction_init_trace -public :: core_interaction_init_sqme -public :: core_interaction_init_flows -<>= -recursive subroutine core_interaction_init_trace & - (ci, qn_mask_in, use_hi_color_factors, nc) -type(core_interaction_t), intent(inout), target :: ci -type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in -logical, intent(in), optional :: use_hi_color_factors -integer, intent(in), optional :: nc - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_init_trace (ci%hard_interaction, & - qn_mask_in, use_hi_color_factors, nc) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_init_trace (ci%dipole_integrated_qed, & - qn_mask_in) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_init_trace (ci%dipole_real_qed, qn_mask_in) - case (CI_SUM) - call core_interaction_init_trace (ci%core_interaction_sum%ci1, & - qn_mask_in, use_hi_color_factors, nc) - call core_interaction_init_trace (ci%core_interaction_sum%ci2, & - qn_mask_in, use_hi_color_factors, nc) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_init_trace (ci%photon_recombination, & - qn_mask_in) - case default - call msg_bug ("core_interaction_init_trace: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_init_trace - -recursive subroutine core_interaction_init_sqme & - (ci, qn_mask_in, use_hi_color_factors, nc) -type(core_interaction_t), intent(inout), target :: ci -type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in -logical, intent(in), optional :: use_hi_color_factors -integer, intent(in), optional :: nc - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_init_sqme (ci%hard_interaction, & - qn_mask_in, use_hi_color_factors, nc) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_init_sqme ( & - ci%dipole_integrated_qed, qn_mask_in) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_init_sqme (ci%dipole_real_qed, qn_mask_in) - case (CI_SUM) - call core_interaction_init_sqme (ci%core_interaction_sum%ci1, & - qn_mask_in, use_hi_color_factors, nc) - call core_interaction_init_sqme (ci%core_interaction_sum%ci2, & - qn_mask_in, use_hi_color_factors, nc) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_init_sqme (ci%photon_recombination, & - qn_mask_in) - case default - call msg_bug ("core_interaction_init_sqme: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_init_sqme - -recursive subroutine core_interaction_init_flows (ci, qn_mask_in) -type(core_interaction_t), intent(inout), target :: ci -type(quantum_numbers_mask_t), dimension(:), intent(in) :: qn_mask_in - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_init_flows (ci%hard_interaction, qn_mask_in) - case (CI_SUM) - call core_interaction_init_flows (ci%core_interaction_sum%ci1, & - qn_mask_in) - call core_interaction_init_flows (ci%core_interaction_sum%ci2, & - qn_mask_in) - case default - call msg_bug ("core_interaction_init_flows: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_init_flows - -@ %def core_interaction_init_sqme core_interaction_init_sqme -@ %def core_interaction_init_flows -@ -Evaluator final. -<>= -public :: core_interaction_final_sqme -public :: core_interaction_final_flows -<>= -recursive subroutine core_interaction_final_sqme (ci) -type(core_interaction_t), intent(inout) :: ci - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_final_sqme (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_final_sqme (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_final_sqme (ci%dipole_real_qed) - case (CI_SUM) - call core_interaction_final_sqme (ci%core_interaction_sum%ci1) - call core_interaction_final_sqme (ci%core_interaction_sum%ci2) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_final_sqme (ci%photon_recombination) - case default - call msg_bug ("core_interaction_final_sqme: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_final_sqme - -recursive subroutine core_interaction_final_flows (ci) -type(core_interaction_t), intent(inout) :: ci - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_final_flows (ci%hard_interaction) - case (CI_SUM) - call core_interaction_final_flows (ci%core_interaction_sum%ci1) - call core_interaction_final_flows (ci%core_interaction_sum%ci2) - case default - call msg_bug ("core_interaction_final_flows: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_final_flows - -@ %def core_interaction_final_sqme core_interaction_final_flows -@ -Update $\alpha_s$. -<>= -public :: core_interaction_update_alpha_s -<>= -recursive subroutine core_interaction_update_alpha_s (ci, as, index) -type(core_interaction_t), intent(inout) :: ci -real(kind=default), intent(in) :: as -integer, optional, intent(in) :: index - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_update_alpha_s (ci%hard_interaction, as) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_update_alpha_s ( & - ci%dipole_integrated_qed, as, index) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_update_alpha_s ( & - ci%dipole_real_qed, as, index) - case (CI_SUM) - call core_interaction_update_alpha_s ( & - ci%core_interaction_sum%ci1, as, index) - call core_interaction_update_alpha_s ( & - ci%core_interaction_sum%ci2, as, index) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_update_alpha_s (ci%photon_recombination, as) - case default - call msg_bug ("core_interaction_update_alpha_s: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_update_alpha_s - -@ %def core_interaction_update_alpha_s -@ -Reset the helicity selection (\oMega). -<>= -public :: core_interaction_reset_helicity_selection -<>= -recursive subroutine core_interaction_reset_helicity_selection (ci, threshold, cutoff) -type(core_interaction_t), intent(inout) :: ci -real(default), intent(in) :: threshold -integer, intent(in) :: cutoff - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_reset_helicity_selection (ci%hard_interaction, & - threshold, cutoff) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_reset_helicity_selection ( & - ci%dipole_integrated_qed, threshold, cutoff) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_reset_helicity_selection (ci%dipole_real_qed, & - threshold, cutoff) - case (CI_SUM) - call core_interaction_reset_helicity_selection ( & - ci%core_interaction_sum%ci1, threshold, cutoff) - call core_interaction_reset_helicity_selection ( & - ci%core_interaction_sum%ci2, threshold, cutoff) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_reset_helicity_selection ( & - ci%photon_recombination, threshold, cutoff) - case default - call msg_bug ("core_interaction_reset_helicity_selection: not " & - // "implemeneted: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_reset_helicity_selection - -@ %def core_interaction_reset_helicity_selection -@ -Evaluation. -<>= -public :: core_interaction_evaluate -<>= -recursive subroutine core_interaction_evaluate (ci) -type(core_interaction_t), intent(inout) :: ci - if (ci%state < CI_STATE_EVALUATE) call msg_bug ( & - "core interaction: premature evaluation") - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_evaluate (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_evaluate (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_evaluate (ci%dipole_real_qed) - case (CI_SUM) - call core_interaction_evaluate (ci%core_interaction_sum%ci1) - call core_interaction_evaluate (ci%core_interaction_sum%ci2) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_evaluate (ci%photon_recombination) - case default - call msg_bug ("core_interaction_evaluate: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_evaluate - -@ %def core_interaction_evaluate -@ -Extra evaluators. -<>= -public :: core_interaction_evaluate_sqme -public :: core_interaction_evaluate_flows -<>= -recursive subroutine core_interaction_evaluate_sqme (ci) -type(core_interaction_t), intent(inout) :: ci - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_evaluate_sqme (ci%hard_interaction) - case (CI_SUM) - call core_interaction_evaluate_sqme (ci%core_interaction_sum%ci1) - call core_interaction_evaluate_sqme (ci%core_interaction_sum%ci2) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_evaluate_sqme (ci%photon_recombination) - case default - call msg_bug ("core_interaction_evaluate_sqme: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_evaluate_sqme - -recursive subroutine core_interaction_evaluate_flows (ci) -type(core_interaction_t), intent(inout) :: ci - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_evaluate_flows (ci%hard_interaction) - case (CI_SUM) - call core_interaction_evaluate_flows (ci%core_interaction_sum%ci1) - call core_interaction_evaluate_flows (ci%core_interaction_sum%ci2) - case default - call msg_bug ("core_interaction_evaluate_flows: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_evaluate_flows - -@ %def core_interaction_evaluate_sqme core_interaction_evaluate_flows -@ -Direct acces to the squared matrix element traced over all quantum numbers. -<>= -public :: core_interaction_compute_sqme_sum -<>= -recursive function core_interaction_compute_sqme_sum (ci, p, index) result (sqme) -type(core_interaction_t), intent(inout) :: ci -type(vector4_t), intent(in), dimension(:) :: p -integer, intent(in), optional :: index -real(kind=default) :: sqme -logical :: weights - select case (ci%type) - case (CI_OMEGA) - sqme = hard_interaction_compute_sqme_sum (ci%hard_interaction, p) - case (CI_SUM) - sqme = core_interaction_compute_sqme_sum (ci%core_interaction_sum%ci1, & - p, index) + & - core_interaction_compute_sqme_sum (ci%core_interaction_sum%ci2, & - p, index) - case (CI_PHOTON_RECOMBINATION) - sqme = photon_recombination_compute_sqme_sum ( & - ci%photon_recombination, p) - case default - call msg_bug ("core_interaction_compute_sqme_sum: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_compute_sqme_sum - -@ %def core_interaction_compute_sqme_sum -@ -Pointers to the interaction and to the evaluators. -<>= -public :: core_interaction_get_int_ptr -public :: core_interaction_get_eval_trace_ptr -public :: core_interaction_get_eval_sqme_ptr -public :: core_interaction_get_eval_flows_ptr -<>= -recursive function core_interaction_get_int_ptr (ci, index) result (int) - type(core_interaction_t), intent(in), target :: ci - integer, intent(in) :: index - type(interaction_t), pointer :: int - select case (ci%type) - case (CI_OMEGA) - int => hard_interaction_get_int_ptr (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - int => dipole_integrated_qed_get_int_ptr ( & - ci%dipole_integrated_qed, index) - case (CI_DIPOLE_REAL_QED) - int => dipole_real_qed_get_int_ptr (ci%dipole_real_qed, index) - case (CI_SUM) - int => core_interaction_get_int_ptr (& - ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), & - ci_sum_multiplex_out (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - int => photon_recombination_get_int_ptr (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_int_ptr: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_int_ptr - -recursive function core_interaction_get_eval_trace_ptr (ci, index) result (eval_trace) - type(core_interaction_t), intent(in), target :: ci - integer, intent(in), optional :: index - type(evaluator_t), pointer :: eval_trace - select case (ci%type) - case (CI_OMEGA) - eval_trace => hard_interaction_get_eval_trace_ptr (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - eval_trace => dipole_integrated_qed_get_eval_trace_ptr ( & - ci%dipole_integrated_qed, index) - case (CI_DIPOLE_REAL_QED) - eval_trace => dipole_real_qed_get_eval_trace_ptr ( & - ci%dipole_real_qed, index) - case (CI_SUM) - eval_trace => core_interaction_get_eval_trace_ptr ( & - ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), & - ci_sum_multiplex_out (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - eval_trace => photon_recombination_get_eval_trace_ptr ( & - ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_eval_trace_ptr: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_eval_trace_ptr - -recursive function core_interaction_get_eval_sqme_ptr (ci, index) result (eval_sqme) -type(core_interaction_t), intent(in), target :: ci -integer, intent(in), optional :: index -type(evaluator_t), pointer :: eval_sqme - select case (ci%type) - case (CI_OMEGA) - eval_sqme => hard_interaction_get_eval_sqme_ptr (ci%hard_interaction) - case (CI_DIPOLE_INTEGRATED_QED) - eval_sqme => dipole_integrated_qed_get_eval_sqme_ptr ( & - ci%dipole_integrated_qed, index) - case (CI_DIPOLE_REAL_QED) - eval_sqme => dipole_real_qed_get_eval_sqme_ptr ( & - ci%dipole_real_qed, index) - case (CI_SUM) - eval_sqme => core_interaction_get_eval_sqme_ptr ( & - ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), & - ci_sum_multiplex_out (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - eval_sqme => photon_recombination_get_eval_sqme_ptr ( & - ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_eval_sqme_ptr: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_eval_sqme_ptr - -recursive function core_interaction_get_eval_flows_ptr (ci, index) result (eval_flows) -type(core_interaction_t), intent(in), target :: ci -integer, intent(in) :: index -type(evaluator_t), pointer :: eval_flows - select case (ci%type) - case (CI_OMEGA) - eval_flows => hard_interaction_get_eval_flows_ptr (ci%hard_interaction) - case (CI_SUM) - eval_flows => core_interaction_get_eval_flows_ptr ( & - ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), & - ci_sum_multiplex_out (ci%core_interaction_sum, index)) - case default - call msg_bug ("core_interaction_get_eval_flows_ptr: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_eval_flows_ptr - -@ %def core_interaction_get_int_ptr core_interaction_get_eval_sqme_ptr -@ %def core_interaction_get_eval_trace_ptr core_interaction_get_eval_flows_ptr -Recover the kinematics. -<>= -public :: core_interaction_recover_kinematics -<>= -recursive subroutine core_interaction_recover_kinematics (ci, pset, index) -type(core_interaction_t), intent(inout) :: ci -integer, intent(in), optional :: index -type(particle_set_t), intent(in) :: pset - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_recover_kinematics (ci%hard_interaction, & - pset) - case default - call msg_bug ("core_interaction_recover_kinematics: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_recover_kinematics - -@ %def core_interaction_recover_kinematics -@ -List allowed quantum numbers. -<>= -public :: core_interaction_write_state_summary -<>= -recursive subroutine core_interaction_write_state_summary (ci, unit) -type(core_interaction_t), intent(in) :: ci -integer, intent(in), optional :: unit - select case (ci%type) - case (CI_OMEGA) - call hard_interaction_write_state_summary (ci%hard_interaction, unit) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_write_state_summary ( & - ci%dipole_integrated_qed, unit) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_write_state_summary (ci%dipole_real_qed, unit) - case (CI_SUM) - call core_interaction_sum_write_state_summary ( & - ci%core_interaction_sum, unit) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_write_state_summary ( & - ci%photon_recombination, unit) - case default - call msg_bug ("core_interaction_write_state_summary: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_write_state_summary - -@ %def core_interaction_write_state_summary -@ -Get the number of random variables required for evaluation. -<>= -public :: core_interaction_get_n_x -<>= -function core_interaction_get_n_x (ci) result (n) -type(core_interaction_t), intent(in) :: ci -integer :: n - select case (ci%type) - case (CI_OMEGA) - n = 0 - case (CI_DIPOLE_INTEGRATED_QED) - n = 1 - case (CI_DIPOLE_REAL_QED) - n = 0 - case (CI_SUM) - n = ci%core_interaction_sum%nx1 + ci%core_interaction_sum%nx2 - case (CI_PHOTON_RECOMBINATION) - n = 0 - case default - call msg_bug ("core_interaction_get_n_x: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_x - -@ %def core_interaction_get_n_x -@ -Set any required random variables -<>= -public :: core_interaction_set_x -<>= -recursive subroutine core_interaction_set_x (ci, x) -type(core_interaction_t), intent(inout) :: ci -real(kind=default), intent(in), dimension(:) :: x - select case (ci%type) - case (CI_OMEGA) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_set_x (ci%dipole_integrated_qed, x(1)) - case (CI_DIPOLE_REAL_QED) - case (CI_SUM) - call core_interaction_sum_set_x (ci%core_interaction_sum, x) - case (CI_PHOTON_RECOMBINATION) - case default - call msg_bug ("core_interaction_set_x: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_set_x - -@ %def core_interaction_set_x -@ -Get the number of ``in'' type configurations. -<>= -public :: core_interaction_get_n_kinematics_in -<>= -function core_interaction_get_n_kinematics_in (ci) result (n) -type(core_interaction_t), intent(in) :: ci -integer :: n - select case (ci%type) - case (CI_OMEGA) - n = 1 - case (CI_DIPOLE_INTEGRATED_QED) - n = dipole_integrated_qed_get_n_kinematics (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n = 1 - case (CI_SUM) - n = ci%core_interaction_sum%nin1 + ci%core_interaction_sum%nin2 - 1 - case (CI_PHOTON_RECOMBINATION) - n = 1 - case default - call msg_bug ("core_interaction_get_n_kinematics_n: " & - // "not implemented: " // char ( & - core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_kinematics_in - -@ %def core_interaction_get_n_kinematics_in -@ -Get the number of ``out'' type configurations. -<>= -public :: core_interaction_get_n_kinematics_out -<>= -function core_interaction_get_n_kinematics_out (ci) result (n) -type(core_interaction_t), intent(in) :: ci -integer :: n - select case (ci%type) - case (CI_OMEGA) - n = 1 - case (CI_DIPOLE_INTEGRATED_QED) - n = dipole_integrated_qed_get_n_kinematics (ci%dipole_integrated_qed) - case (CI_DIPOLE_REAL_QED) - n = dipole_real_qed_get_n_kinematics_out (ci%dipole_real_qed) - case (CI_SUM) - n = ci%core_interaction_sum%nout1 + ci%core_interaction_sum%nout2 - case (CI_PHOTON_RECOMBINATION) - n = 1 - case default - call msg_bug ("core_interaction_get_n_kinematics_n: " & - // "not implemented: " // char ( & - core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_n_kinematics_out - -@ %def core_interaction_get_n_kinematics_out -@ -Query whether the kinematic setup required for evaluation is trivial --- only -one ``in'' configuration with an identical ``out'' configuration. -<>= -public :: core_interaction_trivial_kinematics -<>= -function core_interaction_trivial_kinematics (ci) result (flag) -type(core_interaction_t), intent(in) :: ci -logical :: flag - select case (ci%type) - case (CI_OMEGA) - flag = .true. - case (CI_DIPOLE_INTEGRATED_QED) - flag = .false. - case (CI_DIPOLE_REAL_QED) - flag = .false. - case (CI_SUM) - flag = .false. - case (CI_PHOTON_RECOMBINATION) - flag = .false. - case default - call msg_bug ("core_interaction_trivial_kinematics: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_trivial_kinematics - -@ %def core_interaction_trivial_kinematics -@ -Query whether a matrix element is physical, i.e. positive. -<>= -public :: core_interaction_is_physical -<>= -recursive function core_interaction_is_physical (ci) result (physical) -type(core_interaction_t), intent(in) :: ci -logical :: physical - select case (ci%type) - case (CI_OMEGA) - physical = .true. - case (CI_DIPOLE_INTEGRATED_QED) - physical = .false. - case (CI_DIPOLE_REAL_QED) - physical = .false. - case (CI_SUM) - physical = & - core_interaction_is_physical (ci%core_interaction_sum%ci1) .and. & - core_interaction_is_physical (ci%core_interaction_sum%ci2) - case (CI_PHOTON_RECOMBINATION) - physical = .true. - case default - call msg_bug ("core_interaction_is_physical: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_is_physical - -@ %def core_interaction_is_physical -@ % -Set the outgoing momentum information for an ``in'' point. The default [[index]] -is 1. Note that there is no similar function for setting the incoming momenta. -For the seed point, they are supposed to be transmitted to the ``out'' interactions -and evaluators, for the others, they are determined by the core interaction itself. -<>= -public :: core_interaction_set_momenta_out -<>= -recursive subroutine core_interaction_set_momenta_out (ci, momenta, index) -type(core_interaction_t), intent(inout), target :: ci -type(vector4_t), intent(in), dimension(:) :: momenta -integer, optional, intent(in) :: index -type(interaction_t), pointer :: int -integer :: i - select case (ci%type) - case (CI_OMEGA) - int => hard_interaction_get_int_ptr (ci%hard_interaction) - call interaction_set_momenta (int, momenta, outgoing = .true.) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_set_momenta_out ( & - ci%dipole_integrated_qed, momenta, index) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_set_momenta_out (ci%dipole_real_qed, momenta) - case (CI_SUM) - call core_interaction_sum_set_momenta_out (ci%core_interaction_sum, & - momenta, index) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_set_momenta (ci%photon_recombination, & - momenta) - case default - call msg_bug ("core_interaction_set_momenta_out: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_set_momenta_out - -@ %def core_interaction_set_momenta_out -@ -Query whether the core interaction supports extended evaluators. -<>= -public :: core_interaction_has_eval_sqme -public :: core_interaction_has_eval_flows -<>= -recursive function core_interaction_has_eval_sqme (ci) result (flag) -type(core_interaction_t), intent(in) :: ci -logical :: flag - select case (ci%type) - case (CI_OMEGA) - flag = .true. - case (CI_DIPOLE_INTEGRATED_QED) - flag = .true. - case (CI_DIPOLE_REAL_QED) - flag = .true. - case (CI_SUM) - flag = & - core_interaction_has_eval_sqme (ci%core_interaction_sum%ci1) .and. & - core_interaction_has_eval_sqme (ci%core_interaction_sum%ci2) - case (CI_PHOTON_RECOMBINATION) - flag = .true. - case default - call msg_bug ("core_interaction_has_eval_sqme: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_has_eval_sqme - -recursive function core_interaction_has_eval_flows (ci) result (flag) -type(core_interaction_t), intent(in) :: ci -logical :: flag - select case (ci%type) - case (CI_OMEGA) - flag = .true. - case (CI_DIPOLE_INTEGRATED_QED) - flag = .false. - case (CI_DIPOLE_REAL_QED) - flag = .false. - case (CI_SUM) - flag = & - core_interaction_has_eval_flows (ci%core_interaction_sum%ci1) .and. & - core_interaction_has_eval_flows (ci%core_interaction_sum%ci2) - case (CI_PHOTON_RECOMBINATION) - flag = .false. - case default - call msg_bug ("core_interaction_has_eval_flows: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_has_eval_flows - -@ %def core_interaction_has_eval_flows core_interaction_has_eval_sqme -@ -Get the incoming momenta for a specific ``in'' configuration. The default index -is $1$. As allocation-on-assignment is not available yet, we implement this as a -subroutine. -<>= -public :: core_interaction_get_momenta_in -<>= -recursive subroutine core_interaction_get_momenta_in (ci, momenta, index) -type(core_interaction_t), intent(in) :: ci -type(vector4_t), intent(out), dimension(:) :: momenta -integer, intent(in), optional :: index - select case (ci%type) - case (CI_OMEGA) - momenta = interaction_get_momenta (hard_interaction_get_int_ptr ( & - ci%hard_interaction), outgoing=.false.) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_get_momenta_in (ci%dipole_integrated_qed, & - momenta, index) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_get_momenta_in (ci%dipole_real_qed, momenta) - case (CI_SUM) - call core_interaction_get_momenta_in ( & - ci_sum_multiplex_ci_in (ci%core_interaction_sum, index), & - momenta, & - ci_sum_multiplex_in (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - momenta = photon_recombination_get_momenta_in ( & - ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_momenta_in: not implemented: " & - // char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_get_momenta_in - -@ %def core_interaction_get_momenta_in -@ -Set / get the cut status for an ``out'' configuration. Just after transitioning -to [[CI_STATE_MOMENTA_SET]], (before the actual phase space cut has been applied), -[[core_interaction_get_cut_status]] reflects whether the configuration has been -populated (which may not be the case if the phasespace generator fails to generate -valid configs for all ``in'' points). -<>= -public :: core_interaction_set_cut_status -public :: core_interaction_get_cut_status -<>= -recursive subroutine core_interaction_set_cut_status (ci, stat, index) -type(core_interaction_t), intent(inout) :: ci -logical, intent(in) :: stat -integer, intent(in), optional :: index -type(core_interaction_t), pointer :: cp - select case (ci%type) - case (CI_OMEGA) - ci%me_passed_cut = stat - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_set_cut_status (ci%dipole_integrated_qed, & - stat, index) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_set_cut_status (ci%dipole_real_qed, stat, index) - case (CI_SUM) - cp => ci_sum_multiplex_ci_out (ci%core_interaction_sum, index) - call core_interaction_set_cut_status (cp, stat, & - ci_sum_multiplex_out (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_set_cut_status (ci%photon_recombination, & - stat) - case default - call msg_bug ("core_interaction_set_cut_status: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_set_cut_status - -recursive function core_interaction_get_cut_status (ci, index) result (stat) -type(core_interaction_t), intent(in) :: ci -integer, intent(in), optional :: index -logical :: stat - select case (ci%type) - case (CI_OMEGA) - stat = ci%me_passed_cut - case (CI_DIPOLE_INTEGRATED_QED) - stat = dipole_integrated_qed_get_cut_status ( & - ci%dipole_integrated_qed, index) - case (CI_DIPOLE_REAL_QED) - stat = dipole_real_qed_get_cut_status (ci%dipole_real_qed, index) - case (CI_SUM) - stat = core_interaction_get_cut_status ( & - ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), & - ci_sum_multiplex_out (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - stat = photon_recombination_get_cut_status (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_cut_status: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_cut_status - -@ %def core_interaction_set_cut_status -@ %def core_interaction_get_cut_status -Check whether an ``in'' configuration needs a weight. -<>= -public :: core_interaction_needs_weight -<>= -recursive function core_interaction_needs_weight (ci, index) result (stat) -type(core_interaction_t), intent(in) :: ci -integer, intent(in), optional :: index -logical :: stat - select case (ci%type) - case (CI_OMEGA) - stat = ci%me_passed_cut - case (CI_DIPOLE_INTEGRATED_QED) - stat = dipole_integrated_qed_get_cut_status ( & - ci%dipole_integrated_qed, index) - case (CI_DIPOLE_REAL_QED) - stat = dipole_real_qed_any_passed (ci%dipole_real_qed) - case (CI_SUM) - stat = core_interaction_needs_weight ( & - ci_sum_multiplex_ci_in (ci%core_interaction_sum, index), & - ci_sum_multiplex_in (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - stat = photon_recombination_get_cut_status (ci%photon_recombination) - case default - call msg_bug ("core_interaction_needs_weight: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_needs_weight - -@ %def core_interaction_needs_weight -@ -Set the weight associated with an ``in'' configuration -<>= -public :: core_interaction_set_weight -<>= -recursive subroutine core_interaction_set_weight (ci, j, index) -type(core_interaction_t), intent(inout) :: ci -real(kind=default), intent(in) :: j -integer, intent(in), optional :: index - select case (ci%type) - case (CI_OMEGA) - ci%me_weight = j - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_set_weight (ci%dipole_integrated_qed, & - j, index) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_set_weight (ci%dipole_real_qed, j) - case (CI_SUM) - call core_interaction_sum_set_weight ( & - ci%core_interaction_sum, j, index) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_set_weight (ci%photon_recombination, & - j) - case default - call msg_bug ("core_interaction_set_weight: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_set_weight - -@ %def core_interaction_set_weight -@ -Get the weight associated to an ``out'' configuration. -<>= -public :: core_interaction_get_weight -<>= -recursive function core_interaction_get_weight (ci, index) result (j) -type(core_interaction_t), intent(in) :: ci -integer, intent(in), optional :: index -real(kind=default) :: j - select case (ci%type) - case (CI_OMEGA) - j = ci%me_weight - case (CI_DIPOLE_INTEGRATED_QED) - j = dipole_integrated_qed_get_weight (ci%dipole_integrated_qed, index) - case (CI_DIPOLE_REAL_QED) - j = dipole_real_qed_get_weight (ci%dipole_real_qed) - case (CI_SUM) - j = core_interaction_get_weight ( & - ci_sum_multiplex_ci_out (ci%core_interaction_sum, index), & - ci_sum_multiplex_out (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - j = photon_recombination_get_weight (ci%photon_recombination) - case default - call msg_bug ("core_interaction_get_weight: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_get_weight - -@ %def core_interaction_get_weight -@ -Set the value of the electroweak $\alpha$. -<>= -public :: core_interaction_set_alpha_qed -<>= -recursive subroutine core_interaction_set_alpha_qed (ci, alpha) -type(core_interaction_t), intent(inout) :: ci -real(kind=default), intent(in) :: alpha - select case (ci%type) - case (CI_OMEGA) - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_set_alpha_qed (ci%dipole_integrated_qed, & - alpha) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_set_alpha (ci%dipole_real_qed, alpha) - case (CI_SUM) - call core_interaction_set_alpha_qed ( & - ci%core_interaction_sum%ci1, alpha) - call core_interaction_set_alpha_qed ( & - ci%core_interaction_sum%ci2, alpha) - case (CI_PHOTON_RECOMBINATION) - case default - call msg_bug ("core_interaction_set_alpha_qed: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_set_alpha_qed - -@ %def core_interaction_set_alpha_qed -@ -Advance the state of the core interaction object. -<>= -public :: core_interaction_set_state -<>= -recursive subroutine core_interaction_set_state (ci, state) -type(core_interaction_t), intent(inout) :: ci -integer, intent(in) :: state -type(interaction_t), pointer :: int - select case (state) - case (CI_STATE_CLEAR) - case (CI_STATE_SEED_MOMENTA_SET) - if (ci%state /= CI_STATE_CLEAR) call msg_bug ( & - "core interaction: invalid state transition") - case (CI_STATE_MOMENTA_SET) - if (ci%state /= CI_STATE_SEED_MOMENTA_SET) call msg_bug ( & - "core interaction: invalid state transition") - case (CI_STATE_EVALUATE) - if (ci%state < CI_STATE_MOMENTA_SET) call msg_bug ( & - "core interaction: invalid state transition") - case (CI_STATE_WEIGHTS_SET) - if (ci%state < CI_STATE_MOMENTA_SET) call msg_bug ( & - "core interaction: invalid state transition") - case default - call msg_bug ("core interactions: transition to unknown state") - end select - select case (ci%type) - case (CI_OMEGA) - case (CI_DIPOLE_INTEGRATED_QED) - select case (state) - case (CI_STATE_CLEAR) - call dipole_integrated_qed_reset (ci%dipole_integrated_qed) - case (CI_STATE_SEED_MOMENTA_SET) - call dipole_integrated_qed_process_momenta_in ( & - ci%dipole_integrated_qed) - end select - case (CI_DIPOLE_REAL_QED) - select case (state) - case (CI_STATE_CLEAR) - call dipole_real_qed_reset (ci%dipole_real_qed) - case (CI_STATE_SEED_MOMENTA_SET) - call dipole_real_qed_digest_kinematics_in (ci%dipole_real_qed) - case (CI_STATE_MOMENTA_SET) - call dipole_real_qed_digest_kinematics_out (ci%dipole_real_qed) - end select - case (CI_SUM) - call core_interaction_set_state (ci%core_interaction_sum%ci1, state) - call core_interaction_set_state (ci%core_interaction_sum%ci2, state) - case (CI_PHOTON_RECOMBINATION) - case default - call msg_bug ("core_interaction_set_state: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select - ci%state = state -end subroutine core_interaction_set_state - -@ %def core_interaction_set_state -@ -Tell us whether the phase space generated generated a valid configuration for -an ``in'' point. -<>= -public :: core_interaction_kinematics_passed -<>= -recursive subroutine core_interaction_kinematics_passed (ci, passed, index) -type(core_interaction_t), intent(inout) :: ci -logical, intent(in) :: passed -integer, intent(in), optional :: index - select case (ci%type) - case (CI_OMEGA) - ci%me_passed_cut = passed - case (CI_DIPOLE_INTEGRATED_QED) - call dipole_integrated_qed_set_cut_status (ci%dipole_integrated_qed, & - passed, index) - case (CI_DIPOLE_REAL_QED) - call dipole_real_qed_kinematics_passed (ci%dipole_real_qed, passed) - case (CI_SUM) - call core_interaction_sum_kinematics_passed ( & - ci%core_interaction_sum, passed, index) - case (CI_PHOTON_RECOMBINATION) - call photon_recombination_kinematics_passed (ci%photon_recombination, & - passed) - case default - call msg_bug ("core_interaction_kinematics_passed: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end subroutine core_interaction_kinematics_passed - -@ %def core_interaction_kinematics_passed -@ -Query whether if $\sqrt{s}$ depends on $x$ for an ``in'' channel -<>= -public :: core_interaction_varying_sqrts -<>= -recursive function core_interaction_varying_sqrts (ci, index) result (flag) -type(core_interaction_t), intent(in) :: ci -integer, intent(in), optional :: index -logical :: flag - select case (ci%type) - case (CI_OMEGA) - flag = .false. - case (CI_DIPOLE_INTEGRATED_QED) - if (present (index)) then - flag = index > 1 - else - flag = .false. - end if - case (CI_DIPOLE_REAL_QED) - flag = .false. - case (CI_SUM) - flag = & - core_interaction_varying_sqrts ( & - ci_sum_multiplex_ci_in (ci%core_interaction_sum, index), & - ci_sum_multiplex_in (ci%core_interaction_sum, index)) - case (CI_PHOTON_RECOMBINATION) - flag = .false. - case default - call msg_bug ("core_interaction_varying_sqrts: not implemented: " // & - char (core_interaction_type_description (ci%type))) - end select -end function core_interaction_varying_sqrts - -@ %def core_interaction_varying_sqrts -@ -\subsection{The [[core_interaction_sum_t]] type} - -This type takes two [[core_interaction_t]] objects and combines them into a -single [[core_interaction_t]]. This can only work if flavor and helicity states -match. The type should go into its own module, but for this either inheritance -and polymorphism or submodules would be required, so we put it here for the time -being. For the same reason, the trivial parts of the logic are directly -implemented in the corresponding [[core_interaction_t]] methods. - -The type definition: -<>= -type :: core_interaction_sum_t - private - type(core_interaction_t), pointer :: ci1 => null (), ci2 => null () - type(string_t) :: id - logical :: valid = .false. - integer, dimension(:), allocatable :: flavor_map - integer :: nx1, nx2 - integer :: nin1, nin2, nout1, nout2 -end type core_interaction_sum_t - -@ %def core_interaction_sum_t -@ -Initialization. -<>= -recursive subroutine core_interaction_sum_init (ci, ci1, ci2, id) -type(core_interaction_sum_t), intent(out) :: ci -type(core_interaction_t), intent(in) :: ci1, ci2 -type(string_t), intent(in) :: id - ci%valid = core_interaction_sum_sane (ci, ci1, ci2) - if (.not. ci%valid) then - call msg_fatal ("core interaction sum " // char (id) // " is invalid: " & - // char (core_interaction_get_id (ci1)) // " and " // & - char (core_interaction_get_id (ci2)) // " are incompatible") - return - end if - allocate (ci%ci1, ci%ci2) - ci%ci1 = ci1 - ci%ci2 = ci2 - ci%nin1 = core_interaction_get_n_kinematics_in (ci%ci1) - ci%nin2 = core_interaction_get_n_kinematics_in (ci%ci2) - ci%nout1 = core_interaction_get_n_kinematics_out (ci%ci1) - ci%nout2 = core_interaction_get_n_kinematics_out (ci%ci2) - ci%nx1 = core_interaction_get_n_x (ci%ci1) - ci%nx2 = core_interaction_get_n_x (ci%ci2) - ci%id = id -end subroutine core_interaction_sum_init - -@ %def core_interaction_sum_init -@ -Sanity checks. -<>= -recursive function core_interaction_sum_sane (ci, ci1, ci2) result (sane) -type(core_interaction_sum_t), intent(inout) :: ci -type(core_interaction_t), intent(in) :: ci1, ci2 -logical :: sane -integer, allocatable, dimension(:,:) :: flv1, flv2 -integer :: n, n_flv -integer, allocatable, dimension(:) :: flavor_map - ! Validity - sane = core_interaction_is_valid (ci1) .and. & - core_interaction_is_valid (ci2) - ! Models - sane = model_get_name (core_interaction_get_model_ptr (ci1)) == & - model_get_name (core_interaction_get_model_ptr (ci2)) - if (.not. sane) return - ! Particle and QN counts - sane = sane .and. & - (core_interaction_get_n_in (ci1) == & - core_interaction_get_n_in (ci2)) .and. & - (core_interaction_get_n_out_eff (ci1) == & - core_interaction_get_n_out_eff (ci2)) .and. & - (core_interaction_get_n_tot_eff (ci1) == & - core_interaction_get_n_tot_eff (ci2)) .and. & - (core_interaction_get_n_out_real (ci1)) == & - core_interaction_get_n_out_real (ci2) .and. & - (core_interaction_get_n_tot_real (ci1)) == & - core_interaction_get_n_tot_real (ci2) - if (.not. sane) return - sane = sane .and. & - (core_interaction_get_n_flv_eff (ci1) == & - core_interaction_get_n_flv_eff (ci2)) .and. & - (core_interaction_get_n_flv_real (ci1) == & - core_interaction_get_n_flv_real (ci2)) - if (.not. sane) return - ! Create flavor map and check for flavor compatibility - allocate (flavor_map (core_interaction_get_n_flv_real (ci1))) - n = core_interaction_get_n_tot_real (ci1) - n_flv = core_interaction_get_n_flv_real (ci1) - allocate (flv1(n, n_flv), flv2(n, n_flv)) - flv1 = core_interaction_get_flv_states_real (ci1) - flv2 = core_interaction_get_flv_states_real (ci2) - sane = sane .and. create_flavor_map (flavor_map, flv1, flv2) - deallocate (flv1, flv2) - if (.not. sane) return - ! Check effective flavor assignents - n = core_interaction_get_n_flv_eff (ci1) - n_flv = core_interaction_get_n_flv_eff (ci1) - allocate (flv1(n, n_flv), flv2(n, n_flv)) - flv1 = core_interaction_get_flv_states_eff (ci1) - flv2 = core_interaction_get_flv_states_eff (ci2) - sane = sane .and. flavors_match (flavor_map, flv1, flv2) - deallocate (flv1, flv2) - if (.not. sane) return - ! We do _NOT_ check for PDG and unstable as this should be covered by model - ! and flavor states - ! We have a match -> transfer maps - allocate (ci%flavor_map (size (flavor_map))) - ci%flavor_map = flavor_map - deallocate (flavor_map) - -contains - - function create_flavor_map (map, flv1, flv2) result (match) - integer, dimension(:), intent(out) :: map - integer, dimension(:,:), intent(in) :: flv1, flv2 - logical :: match - logical, dimension(size (flv1, 2)) :: accounted - integer :: n, i, j - match = .false. - accounted = .false. - n = size (flv1, 2) - SCAN: do i = 1, n - do j = 1, n - if (all (flv1(:, i) == flv2(:,j))) then - if (accounted (j)) return - accounted(j) = .true. - map(i) = j - cycle SCAN - end if - if (j == n) return - end do - end do SCAN - match = .true. - end function create_flavor_map - - function flavors_match (map, flv1, flv2) result (match) - integer, dimension(:), intent(in) :: map - integer, dimension(:,:), intent(in) :: flv1, flv2 - logical :: match - integer :: i - match = .true. - do i = 1, size (flv1, 2) - match = match .and. all (flv1(:, i) == flv2(:, map(i))) - if (.not. match) return - end do - end function flavors_match - -end function core_interaction_sum_sane - -recursive function core_interaction_sum_is_valid (ci) result (valid) -type(core_interaction_sum_t) :: ci -logical :: valid - valid = ci%valid - if (.not. valid) return - valid = core_interaction_is_valid (ci%ci1) .and. & - core_interaction_is_valid (ci%ci2) -end function core_interaction_sum_is_valid - -@ %def core_interaction_sum_is_valid -@ - -Finalization. -<>= -recursive subroutine core_interaction_sum_final (ci) -type(core_interaction_sum_t), intent(inout) :: ci - if (.not. ci%valid) return - call core_interaction_final (ci%ci1) - call core_interaction_final (ci%ci2) - deallocate (ci%ci1, ci%ci2) - nullify (ci%ci1, ci%ci2) - deallocate (ci%flavor_map) - ci%valid = .false. -end subroutine core_interaction_sum_final - -@ %def core_interaction_sum_final -@ -Output. -<>= -recursive subroutine core_interaction_sum_write & - (ci, unit, verbose, show_momentum_sum, show_mass, write_comb) -type(core_interaction_sum_t), intent(in) :: ci -integer, intent(in), optional :: unit -logical, intent(in), optional :: verbose, show_momentum_sum, show_mass -logical, intent(in), optional :: write_comb -integer :: u - u = output_unit (unit) - write (u, "(1X,A)") "Process ID: " // char (ci%id) - if (.not. ci%valid) then - write (u, "(1X,A)") "INVALID" - return - end if - write (u, "(1X,A)") "Summand 1:" - call core_interaction_write (ci%ci1, & - unit, verbose, show_momentum_sum, show_mass, write_comb) - write (u) - write (u, "(1X,A)") "Summand 2:" - call core_interaction_write (ci%ci2, & - unit, verbose, show_momentum_sum, show_mass, write_comb) -end subroutine core_interaction_sum_write - -@ %def core_interaction_write -@ -Assignment. -<>= -interface assignment(=) - module procedure core_interaction_sum_assign -end interface -<>= -recursive subroutine core_interaction_sum_assign (ci_out, ci_in) -type(core_interaction_sum_t), intent(inout) :: ci_out -type(core_interaction_sum_t), intent(in) :: ci_in - call core_interaction_sum_final (ci_out) - ci_out%valid = ci_in%valid - if (.not. ci_in%valid) return - allocate (ci_out%ci1, ci_out%ci2) - ci_out%ci1 = ci_in%ci1 - ci_out%ci2 = ci_in%ci2 - ci_out%id = ci_in%id - allocate (ci_out%flavor_map (size (ci_in%flavor_map))) - ci_out%flavor_map = ci_in%flavor_map - ci_out%nin1 = ci_in%nin1 - ci_out%nin2 = ci_in%nin2 - ci_out%nout1 = ci_in%nout1 - ci_out%nout2 = ci_in%nout2 - ci_out%nx1 = ci_in%nx1 - ci_out%nx2 = ci_in%nx2 - ci_out%valid = .true. -end subroutine core_interaction_sum_assign - -@ %def core_interaction_sum_assign -@ -Multiplex indices. Note that the $n_\text{in}=1$ seed kinematics of the two -interactions are unified. -<>= -function ci_sum_multiplex_ci_in (cis, index) result (ci) -type(core_interaction_sum_t), intent(in) :: cis -integer, intent(in), optional :: index -type(core_interaction_t), pointer :: ci -integer :: i - i = 1; if (present (index)) i = index - if (i <= cis%nin1) then - ci => cis%ci1 - else - ci => cis%ci2 - end if -end function ci_sum_multiplex_ci_in - -function ci_sum_multiplex_ci_out (cis, index) result (ci) -type(core_interaction_sum_t), intent(in) :: cis -integer, intent(in), optional :: index -type(core_interaction_t), pointer :: ci -integer :: i - i = 1; if (present (index)) i = index - if (i <= cis%nout1) then - ci => cis%ci1 - else - ci => cis%ci2 - end if -end function ci_sum_multiplex_ci_out - -function ci_sum_multiplex_in (cis, index) result (ii) -type(core_interaction_sum_t), intent(in) :: cis -integer, intent(in), optional :: index -integer :: ii, i - i = 1; if (present (index)) i = index - if (i <= cis%nin1) then - ii = i - else - ii = i - cis%nin1 + 1 - end if -end function ci_sum_multiplex_in - -function ci_sum_multiplex_out (cis, index) result (ii) -type(core_interaction_sum_t), intent(in) :: cis -integer, intent(in), optional :: index -integer :: ii, i - i = 1; if (present (index)) i = index - if (i <= cis%nout1) then - ii = i - else - ii = i - cis%nout1 - end if -end function ci_sum_multiplex_out - -@ %def ci_sum_multiplex_ci_in ci_sum_multiplex_ci_out -@ %def ci_sum_multiplex_in ci_sum_multiplex_out -@ -Tell us whether a kinematic ``in'' configuration was actually generated -<>= -recursive subroutine core_interaction_sum_kinematics_passed & - (cis, passed, index) -type(core_interaction_sum_t), intent(inout) :: cis -logical, intent(in) :: passed -integer, intent(in), optional :: index -integer :: i -type(core_interaction_t), pointer :: cp - i = ci_sum_multiplex_in (cis, index) - cp => ci_sum_multiplex_ci_in (cis, index) - call core_interaction_kinematics_passed (cp, passed, i) - if (i == 1) & - call core_interaction_kinematics_passed (cis%ci2, passed, 1) -end subroutine core_interaction_sum_kinematics_passed - -@ %def core_interaction_sum_kinematics_passed -@ -Set the weight for an ``in'' config. -<>= -recursive subroutine core_interaction_sum_set_weight (cis, j, index) -type(core_interaction_sum_t), intent(inout) :: cis -real(kind=default), intent(in) :: j -integer, intent(in), optional :: index -integer :: i -type(core_interaction_t), pointer :: cp - i = ci_sum_multiplex_in (cis, index) - cp => ci_sum_multiplex_ci_in (cis, index) - call core_interaction_set_weight (cp, j, i) - if (i == 1) & - call core_interaction_set_weight (cis%ci2, j, 1) -end subroutine core_interaction_sum_set_weight - -@ %core_interaction_sum_set_weight -@ -Write state summary. -<>= -recursive subroutine core_interaction_sum_write_state_summary (ci, unit) -type(core_interaction_sum_t), intent(in) :: ci -integer, intent(in), optional :: unit -integer :: u - u = output_unit (unit) - write (u, '(1X,A)') "Summand 1:" - call core_interaction_write_state_summary (ci%ci1, u) - write (u, '()') - write (u, '(1X,A)') "Summand 2:" - call core_interaction_write_state_summary (ci%ci2, u) -end subroutine core_interaction_sum_write_state_summary - -@ %def core_interaction_sum_write_state_summary -@ -Set random variables. -<>= -recursive subroutine core_interaction_sum_set_x (ci, x) -type(core_interaction_sum_t), intent(inout) :: ci -real(kind=default), intent(in), dimension(:) :: x - call core_interaction_set_x (ci%ci1, x(:ci%nx1)) - call core_interaction_set_x (ci%ci2, x(ci%nx1 + 1:)) -end subroutine core_interaction_sum_set_x - -@ %def core_interaction_sum_set_x -@ -Set the outgoing momenta for an ``in'' point. -<>= -recursive subroutine core_interaction_sum_set_momenta_out (ci, momenta, index) -type(core_interaction_sum_t), intent(inout) :: ci -type(vector4_t), intent(in), dimension(:) :: momenta -type(core_interaction_t), pointer :: cp -integer, intent(in), optional :: index -integer :: i - i = ci_sum_multiplex_in (ci, index) - cp => ci_sum_multiplex_ci_in (ci, index) - call core_interaction_set_momenta_out (cp, momenta, i) - if (i == 1) & - call core_interaction_set_momenta_out (ci%ci2, momenta, 1) -end subroutine core_interaction_sum_set_momenta_out - -@ %def core_interaction_sum_set_momenta_out -@ - -\section{The NLO setup} - -This module encapsulates all options which constitute the setup of a NLO -process. Modification of the -setup is performed through a chained list of modification requests which -directly correspond to the corresponding SINDARIN statements. - -<<[[nlo_setup.f90]]>>= -<> - -module nlo_setup - -<> -<> - use constants !NODEP! -<> - use diagnostics !NODEP! - use md5 - use models - use flavors - use quantum_numbers - -<> - -<> - -<> - -<> - -<> - -<> - -contains - -<> - -end module nlo_setup - -@ %def -@ - -The different directives for modification of the dipole setup. -<>= - integer, parameter, public :: NLO_SETUP_NOOP = 0 - integer, parameter, public :: NLO_SETUP_SET_MREG = 1 - integer, parameter, public :: NLO_SETUP_SET_MASSES = 2 - integer, parameter, public :: NLO_SETUP_SET_CHARGES = 3 - integer, parameter, public :: NLO_SETUP_SET_MASK = 4 - integer, parameter, public :: NLO_SETUP_CLEAR_MASSES = 5 - integer, parameter, public :: NLO_SETUP_CLEAR_CHARGES = 6 - integer, parameter, public :: NLO_SETUP_CLEAR_MASK = 7 - integer, parameter, public :: NLO_SETUP_SET_RESOLVE = 8 - integer, parameter, public :: NLO_SETUP_SET_RECOMBINATION = 9 - integer, parameter, public :: NLO_SETUP_SET_MRECOMB = 10 - integer, parameter, public :: NLO_SETUP_SET_PHOTON_BEAM_SEPARATION = 11 - integer, parameter, public :: NLO_SETUP_SET_RECOMBINATION_COMPLEMENT = 12 - -@ %def -@ -The different available recombination procedures -<>= -integer, parameter, public :: NLO_RECOMBINATION_RACOON=1, & - NLO_RECOMBINATION_IGNORE_PHOTON=2, NLO_RECOMBINATION_BARBARA_WW=3, & - NLO_RECOMBINATION_INVALID=-1 - -@ %def -@ -A single request for modification consists of a queue of subsequent modification -directives. The queue is represented as a linked list. -<>= -type nlo_setup_node_t - integer :: type - real(kind=default) :: mreg - real(kind=default), dimension(:), allocatable :: masses - real(kind=default), dimension(:), allocatable :: charges - integer, dimension(:), allocatable :: mask - logical :: resolve - type(nlo_setup_node_t), pointer :: next => null () - integer :: recombination - real(kind=default) :: mrecomb, photon_beam_separation - logical :: recombination_complement = .false. -end type nlo_setup_node_t - -public :: nlo_setup_list_t -<>= -type nlo_setup_list_t - private - type(nlo_setup_node_t), pointer :: root => null () -end type nlo_setup_list_t - -@ %def nlo_setup_list_t nlo_setup_node_t -@ -Create a single node. This is private, all external code is supposed to call -[[nlo_setup_list_append]] instead. -<>= -function nlo_setup_node_create (type, mreg, masses, charges, mask, & - resolve, recombination, mrecomb, photon_beam_separation, & - recombination_complement) & - result (node) -integer :: type -real(kind=default), intent(in), optional :: mreg -real(kind=default), intent(in), dimension(:), optional :: masses, charges -integer, dimension(:), intent(in), optional :: mask -logical, intent(in), optional :: resolve -integer, intent(in), optional :: recombination -real(kind=default), intent(in), optional :: mrecomb -real(kind=default), intent(in), optional :: photon_beam_separation -logical, intent(in), optional :: recombination_complement -type(nlo_setup_node_t), pointer :: node - allocate (node) - node%type = type - select case (type) - case (NLO_SETUP_SET_MREG) - node%mreg = mreg - case (NLO_SETUP_SET_MASSES) - allocate (node%masses(size (masses))) - node%masses = masses - case (NLO_SETUP_SET_CHARGES) - allocate (node%charges(size (charges))) - node%charges = charges - case (NLO_SETUP_SET_MASK) - allocate (node%mask(size (mask))) - node%mask = mask - case (NLO_SETUP_SET_RESOLVE) - node%resolve = resolve - case (NLO_SETUP_SET_RECOMBINATION) - node%recombination = recombination - case (NLO_SETUP_SET_MRECOMB) - node%mrecomb = mrecomb - case (NLO_SETUP_SET_PHOTON_BEAM_SEPARATION) - node%photon_beam_separation = photon_beam_separation - case (NLO_SETUP_SET_RECOMBINATION_COMPLEMENT) - node%recombination_complement = recombination_complement - end select -end function nlo_setup_node_create - -@ %def nlo_setup_node_create -@ -Initialize the whole settings list. -<>= -public :: nlo_setup_list_init -<>= -subroutine nlo_setup_list_init (list) -type(nlo_setup_list_t), intent(out) :: list - nullify (list%root) -end subroutine nlo_setup_list_init - -@ %def nlo_setup_list_init -@ -Delete the list. -<>= -public :: nlo_setup_list_final -<>= -subroutine nlo_setup_list_final (list) -type(nlo_setup_list_t), intent(inout) :: list -type(nlo_setup_node_t), pointer :: node, next - node => list%root - do while (associated (node)) - next => node%next - deallocate (node) - node => next - end do - nullify (list%root) -end subroutine nlo_setup_list_final - -@ %def nlo_setup_list_final -@ -Append a settings node to the list. Wraps around -[[nlo_setup_node_create]]. -<>= -public :: nlo_setup_list_append -<>= -subroutine nlo_setup_list_append (list, type, mreg, masses, charges, & - mask, resolve, recombination, mrecomb, photon_beam_separation, & - recombination_complement) -type(nlo_setup_list_t), intent(inout) :: list -integer :: type -real(kind=default), intent(in), optional :: mreg -real(kind=default), intent(in), dimension(:), optional :: masses, charges -integer, dimension(:), intent(in), optional :: mask -logical, intent(in), optional :: resolve -integer, intent(in), optional :: recombination -real(kind=default), intent(in), optional :: mrecomb -real(kind=default), intent(in), optional :: photon_beam_separation -logical, intent(in), optional :: recombination_complement -type(nlo_setup_node_t), pointer :: new_node, node - new_node => nlo_setup_node_create (type, mreg, masses, charges, & - mask, resolve, recombination, mrecomb, & - photon_beam_separation, recombination_complement) - if (associated (list%root)) then - node => list%root - do while (associated (node%next)) - node => node%next - end do - node%next => new_node - else - list%root => new_node - end if -end subroutine nlo_setup_list_append - -@ %def nlo_setup_list_append -@ - -The actual NLO setup. The respective dipole modules need access, and -we thus keep the components public in order to avoid a proliferation of access -methods. -<>= -public :: nlo_setup_t -<>= -type nlo_setup_t - logical :: valid = .false. - real(kind=default) :: mreg = 0 - real(kind=default), dimension(:), allocatable :: charges - real(kind=default), dimension(:), allocatable :: masses - integer, dimension(:), allocatable :: mask - logical :: resolve_set = .false. - logical :: resolve - integer :: n_tot = -1 - integer :: recombination = NLO_RECOMBINATION_INVALID - real(kind=default) :: mrecomb = -1, photon_beam_separation = -1 - logical :: recombination_complement_set = .false. - logical :: recombination_complement -end type nlo_setup_t - -@ %def nlo_setup_t -@ -Initialization. Flavors are supplied upon creation, everything else is setup via -a settings list. -<>= - public :: nlo_setup_init -<>= -subroutine nlo_setup_init (dpc, n_tot) -type(nlo_setup_t), intent(out) :: dpc -integer, intent(in), optional :: n_tot - dpc%valid = .true. - if (present (n_tot)) dpc%n_tot = n_tot - dpc%resolve_set = .false. -end subroutine nlo_setup_init - -@ %def nlo_setup_init -@ -Assignment. We first create a temporary, local copy of the [[from]] operand -(which is intent inout) and -then assign it to the [[to]] operand. This hack is necessary as we will -encounter situations where both sides of the assignment are identical, although -the rhs is passed through several function calls. In this case, gfortran seems -to just pass along a pointer, and we end up invalidating the operand. Might be a -compiler bug, dunno what the standard says about this situation. -<>= - public :: assignment(=) -<>= -interface assignment(=) - module procedure nlo_setup_assign -end interface - -<>= -subroutine nlo_setup_assign (to, from) -type(nlo_setup_t), intent(inout) :: to -type(nlo_setup_t), intent(in) :: from -type(nlo_setup_t) :: tmp - call nlo_setup_assign1 (tmp, from) - call nlo_setup_assign1 (to, tmp) -end subroutine nlo_setup_assign - -subroutine nlo_setup_assign1 (to, from) -type(nlo_setup_t), intent(inout) :: to -type(nlo_setup_t), intent(in) :: from - to%valid = from%valid - to%mreg = from%mreg - to%resolve_set = from%resolve_set - to%resolve = from%resolve - to%n_tot = from%n_tot - to%recombination = from%recombination - to%mrecomb = from%mrecomb - to%photon_beam_separation = from%photon_beam_separation - to%recombination_complement_set = from%recombination_complement_set - to%recombination_complement = from%recombination_complement - if (allocated (to%charges)) deallocate (to%charges) - if (allocated (from%charges)) then - allocate (to%charges(size (from%charges))) - to%charges = from%charges - end if - if (allocated (to%masses)) deallocate (to%masses) - if (allocated (from%masses)) then - allocate (to%masses(size (from%masses))) - to%masses = from%masses - end if - if (allocated (to%mask)) deallocate (to%mask) - if (allocated (from%mask)) then - allocate (to%mask(size (from%mask))) - to%mask = from%mask - end if -end subroutine nlo_setup_assign1 - -@ %def nlo_setup_assign -@ -Check for validity. -<>= - public :: nlo_setup_valid -<>= -function nlo_setup_valid (cfg) result (valid) -type(nlo_setup_t), intent(in) :: cfg -logical :: valid - valid = cfg%valid -end function nlo_setup_valid - -@ %def nlo_setup_valid -@ -Apply a settings node. -<>= -subroutine nlo_setup_apply_node (dpc, node) -type(nlo_setup_node_t), intent(in) :: node -type(nlo_setup_t), intent(inout) :: dpc -logical :: mask_valid -integer :: i - if (.not. dpc%valid) return - select case (node%type) - case (NLO_SETUP_SET_MREG) - dpc%mreg = node%mreg - case (NLO_SETUP_SET_MASSES) - if (dpc%n_tot < 0) dpc%n_tot = size (node%masses) - if (size (node%masses) /= dpc%n_tot) then - call msg_error ("ignoring invalid collinear mass regulator list") - return - end if - if (.not. allocated (dpc%masses)) allocate (dpc%masses(dpc%n_tot)) - dpc%masses = node%masses - case (NLO_SETUP_SET_CHARGES) - if (dpc%n_tot < 0) dpc%n_tot = size (node%charges) - if (size (node%charges) /= dpc%n_tot) then - call msg_error ("ignoring invalid charge list") - return - end if - if (.not. allocated (dpc%charges)) allocate (dpc%charges(dpc%n_tot)) - dpc%charges = node%charges - case (NLO_SETUP_SET_MASK) - if (dpc%n_tot < 0) dpc%n_tot = size (node%mask / 2) - mask_valid = all (node%mask > 0) .and. all (node%mask <= dpc%n_tot) & - .and. (mod (size (node%mask), 2) == 0) - if (mask_valid) then - do i = 0, size (node%mask) / 2 - 1 - mask_valid = mask_valid .and. (node%mask(2*i+1) /= node%mask(2*i+2)) - end do - end if - if (.not. mask_valid) then - call msg_error ("ignoring invalid dipole mask") - return - end if - if (allocated (dpc%mask)) deallocate (dpc%mask) - allocate (dpc%mask(size (node%mask))) - dpc%mask = node%mask - case (NLO_SETUP_CLEAR_MASSES) - if (allocated (dpc%masses)) deallocate (dpc%masses) - case (NLO_SETUP_CLEAR_CHARGES) - if (allocated (dpc%charges)) deallocate (dpc%charges) - case (NLO_SETUP_CLEAR_MASK) - if (allocated (dpc%mask)) deallocate (dpc%mask) - case (NLO_SETUP_SET_RESOLVE) - dpc%resolve_set = .true. - dpc%resolve = node%resolve - case (NLO_SETUP_SET_RECOMBINATION) - dpc%recombination = node%recombination - case (NLO_SETUP_SET_MRECOMB) - dpc%mrecomb = node%mrecomb - case (NLO_SETUP_SET_PHOTON_BEAM_SEPARATION) - dpc%photon_beam_separation = node%photon_beam_separation - case (NLO_SETUP_SET_RECOMBINATION_COMPLEMENT) - dpc%recombination_complement_set = .true. - dpc%recombination_complement = node%recombination_complement - end select -end subroutine nlo_setup_apply_node - -@ %def nlo_setup_apply_node -@ -Iterate over the list and apply all nodes. -<>= -public :: nlo_setup_apply_list -<>= -subroutine nlo_setup_apply_list (dpc, list) -type(nlo_setup_t), intent(inout) :: dpc -type(nlo_setup_list_t), intent(in) :: list -type(nlo_setup_node_t), pointer :: node - node => list%root - do while (associated (node)) - call nlo_setup_apply_node (dpc, node) - node => node%next - end do -end subroutine nlo_setup_apply_list - -@ -@ %def -Output. -<>= -public :: nlo_setup_write -<>= -subroutine nlo_setup_write (dpc, unit) -type(nlo_setup_t), intent(in) :: dpc -integer, intent(in) :: unit -integer :: i, u -type(string_t) :: buffer - if (.not. dpc%valid) return - call msg_message (" NLO process setup", unit) - call msg_message (" soft mass regulator = " // real2char (sqrt (dpc%mreg)), & - unit) - if (allocated (dpc%masses)) then - buffer = " collinear mass regulators = " // render_array (dpc%masses) - else - buffer = " collinear mass regulators = [from model]" - end if - call msg_message (char (buffer), unit) - if (allocated (dpc%mask)) then - buffer = " mask = " - do i = 0, size (dpc%mask) / 2 - 1 - buffer = buffer // " " // int2string (dpc%mask(2*i+1)) & - // ":" // int2string (dpc%mask(2*i+2)) - end do - else - buffer = " no mask" - end if - call msg_message (char (buffer), unit) - if (dpc%resolve_set) call msg_message ( & - " resolve = " // char (log2str (dpc%resolve)), unit) - call msg_message (" recombination = " // int2char ( & - dpc%recombination), unit) - if (dpc%mrecomb > 0) call msg_message (" mrecomb = " // & - real2char (dpc%mrecomb), unit) - if (dpc%photon_beam_separation > 0) call msg_message ( & - "photon_beam_separation = " // real2char (dpc%photon_beam_separation), & - unit) - if (dpc%recombination_complement_set) call msg_message ( & - "recombination_complement = " // char (log2str ( & - dpc%recombination_complement)), unit) - -contains - -function render_array (x) result (s) -real(kind=default), intent(in), dimension(:) :: x -type(string_t) :: s -integer :: i - s = "" - do i = 1, size (x) - s = s // real2string (x(i)) // " " - end do - s = trim (s) -end function render_array - -function log2str (l) result (s) -logical, intent(in) :: l -type(string_t) :: s - if (l) then - s = "true" - else - s = "false" - end if -end function log2str - -end subroutine nlo_setup_write -@ %def -@ -Calculate the MD5. -<>= -public :: nlo_setup_md5sum -<>= -function nlo_setup_md5sum (nlo_setup) result (md5) -type(nlo_setup_t), intent(in) :: nlo_setup -character(32) :: md5 -integer :: u - u = free_unit () - open (unit=u, status="scratch") - call nlo_setup_write (nlo_setup, u) - rewind (u) - md5 = md5sum (u) - close (u) -end function nlo_setup_md5sum - -@ %def nlo_setup_md5sum -@ - -\section{Dipoles and subtraction terms} - -These modules implement the calculation of integrated and real QED / QCD -dipoles. HIGHLY EXPERIMENTAL. The logic is split into a configuration module and -several modules implementing the different types of dipoles. The dipoles are -split in five different modules: -% -\begin{itemize} -\item [[dipoles_integrated_qed]], [[dipoles_real_qed]], -[[dipoles_integrated_qcd]], [[dipoles_real_qcd]]: the different types of -subtraction terms have dedicated modules. -\end{itemize} - -\subsection{Integrated QED dipoles} - -<<[[dipoles_integrated_qed.f90]]>>= -<> - -module dipoles_integrated_qed - -<> -<> - use constants !NODEP! -<> - use diagnostics !NODEP! - use sm_physics !NODEP! - use md5 - use lorentz !NODEP! - use models - use flavors - use quantum_numbers - use interactions - use evaluators - use particles - use hard_interactions - use quantum_numbers - use nlo_setup - use process_libraries - -<> - -<> - -<> - -<> - -<> - -<> - -contains - -<> - -end module dipoles_integrated_qed -@ %def dipoles_integrated_qed -@ % -The different types of dipole components. -<>= -integer, parameter :: DIPOLE_FF = 1, DIPOLE_IF = 2, DIPOLE_FI = 3, & - DIPOLE_II = 4 -@ %def DIPOLE_FF DIPOLE_IF DIPOLE_FI DIPOLE_II -% -A single dipole component. -<>= -type dipole_qed_single_t - integer :: em, sp - integer :: type -end type dipole_qed_single_t - -@ %def -@ % -The [[kinematic_configuration_t]] type represents both the ``vanilla'' and the -twisted kinematics. -<>= -type kinematic_configuration_t - ! Kinematics - type(vector4_t), dimension(:), allocatable :: momenta - real(kind=default) :: weight - logical :: passed=.true. - real(default) :: alphas - ! Dipoles, dipole values, charge factors and cache - integer :: n_components - integer, dimension(:), allocatable :: components_map - type(dipole_qed_single_t), dimension(:), allocatable :: components - real(default), dimension(:), allocatable :: component_values - real(default), dimension(:,:), allocatable :: charge_factors - integer, dimension(:), allocatable :: me_factor_map - real(default), dimension(:), allocatable :: me_factors - ! Interactions and evaluators - type(evaluator_t) :: eval_square - type(evaluator_t) :: eval_trace - type(evaluator_t) :: eval_sqme -end type kinematic_configuration_t - -@ %def -@ % -The actual dipole type. -<>= -public :: dipole_integrated_qed_t -<>= -type dipole_integrated_qed_t - private - integer :: n_tot - logical :: have_sqme = .false. - real(kind=default) :: alpha=0 - real(kind=default) :: mreg=0 - real(kind=default) :: x=0 - logical :: alphas_updated = .false. - type(flavor_t), dimension(:,:), allocatable :: flavor_states - real(kind=default), dimension(:), allocatable :: masses - type(kinematic_configuration_t), dimension(0:2) :: kinematics - integer, dimension(:), allocatable :: kinematics_map - type(dipole_qed_single_t), dimension(:), allocatable :: dipoles - type(hard_interaction_t) :: hi -end type dipole_integrated_qed_t - -@ %def -@ % -Initialization. A lot of stuff. -<>= -public :: dipole_integrated_qed_init -<>= -subroutine dipole_integrated_qed_init & - (dp, prc_lib, process_index, process_id, model, alpha, nlo_setup) -type(dipole_integrated_qed_t), intent(out) :: dp -type(process_library_t), intent(in) :: prc_lib -integer, intent(in) :: process_index -type(string_t), intent(in) :: process_id -type(nlo_setup_t) :: dpc -type(model_t), target :: model -real(kind=default), intent(in), optional :: alpha -type(nlo_setup_t), intent(in), optional :: nlo_setup -type(dipole_qed_single_t), dimension(:), allocatable :: tmp -logical, dimension(2) :: splits -integer :: i, j, k, n, n_flv -integer, allocatable, dimension(:,:) :: pdg_states -real(default), dimension(:), allocatable :: charge_sums -type(flavor_t) :: flv_em, flv_sp -type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask - if (present (nlo_setup)) then - dpc = nlo_setup - else - dpc = process_library_get_nlo_setup (prc_lib, process_id) - end if - ! Hard interaction - call hard_interaction_init (dp%hi, prc_lib, process_index, process_id, model) - if (hard_interaction_get_n_in (dp%hi) /= 2) call msg_bug ( & - "dipoles for decay processes are not supported yet.") - dp%n_tot = hard_interaction_get_n_tot (dp%hi) - if (dp%n_tot /= dpc%n_tot .and. dpc%n_tot > 0) then - call msg_error ("mismatch in dipole setup.") - dpc%n_tot = -1 - if (allocated (dpc%masses)) deallocate (dpc%masses) - if (allocated (dpc%charges)) deallocate (dpc%charges) - if (allocated (dpc%mask)) deallocate (dpc%mask) - end if - ! Flavor states - n_flv = hard_interaction_get_n_flv (dp%hi) - allocate (dp%flavor_states(dp%n_tot, n_flv)) - allocate (pdg_states(dp%n_tot, n_flv)) - pdg_states = hard_interaction_get_flv_states (dp%hi) - do i = 1, n_flv - call flavor_init (dp%flavor_states(: ,i), pdg_states(:, i), model) - end do - ! Masses - allocate (dp%masses(dp%n_tot)) - if (allocated (dpc%masses)) then - dp%masses = dpc%masses**2 - else - dp%masses = flavor_get_mass (dp%flavor_states(:, 1))**2 - end if - ! Alpha / mreg - if (present (alpha)) dp%alpha = alpha - dp%mreg = dpc%mreg**2 - ! Count number of charged flavor (sums) - allocate (charge_sums(dp%n_tot)) - charge_sums = 0 - do i = 1, n_flv - charge_sums = charge_sums + abs (flavor_get_charge (dp%flavor_states(:, i))) - end do - n = count (charge_sums > epsilon (1._default)) - allocate (tmp(n**2 - n)) - splits = .false. - ! Build dipole list - n = 1 - do i = 1, dp%n_tot - do j = 1, dp%n_tot - if (i == j) cycle - if (abs (charge_sums(i) * charge_sums(j)) < epsilon (one)) cycle - if (.not. in_mask (i, j, dpc%mask)) cycle - tmp(n)%em = i - tmp(n)%sp = j - if (max (i, j) == 2) then - tmp(n)%type = DIPOLE_II - splits(i) = .true. - elseif (i <= 2) then - tmp(n)%type = DIPOLE_IF - splits(i) = .true. - elseif (j <= 2) then - tmp(n)%type = DIPOLE_FI - splits(j) = .true. - else - tmp(n)%type = DIPOLE_FF - end if - n = n + 1 - end do - end do - allocate (dp%dipoles(n-1)) - if (n > 1) dp%dipoles = tmp(1:n - 1) - allocate (dp%kinematics_map (count (splits) + 1)) - ! Build kinematics map - dp%kinematics_map(1) = 0 - i = 2 - do j = 1, 2 - if (splits (j)) then - dp%kinematics_map(i) = j - i = i + 1 - end if - end do - ! Initialize kinematic configs - allocate (qn_mask(dp%n_tot)) - call quantum_numbers_mask_init (qn_mask, .false., .true., .true.) - do i = 1, size (dp%kinematics_map) - j = dp%kinematics_map(i) - allocate (dp%kinematics(j)%momenta(dp%n_tot)) - call evaluator_init_square (dp%kinematics(j)%eval_square, & - hard_interaction_get_int_ptr (dp%hi), qn_mask) - ! Count the contributing dipole components and setup arrays - allocate (dp%kinematics(j)%components_map(size (dp%dipoles))) - if (j == 0) then - n = size (dp%dipoles) - dp%kinematics(j)%n_components = n - allocate ( & - dp%kinematics(j)%components(n), & - dp%kinematics(j)%component_values(n) & - ) - dp%kinematics(j)%components = dp%dipoles - dp%kinematics(j)%components_map = (/(k, k = 1, n)/) - else - n = 0 - do k = 1, size (dp%dipoles) - select case (dp%dipoles(k)%type) - case (DIPOLE_FF) - case (DIPOLE_IF, DIPOLE_II) - if (dp%dipoles(k)%em == j) n = n + 1 - case (DIPOLE_FI) - if (dp%dipoles(k)%sp == j) n = n + 1 - end select - end do - allocate ( & - dp%kinematics(j)%components(n), & - dp%kinematics(j)%component_values(n) & - ) - dp%kinematics(j)%n_components = n - n = 1 - do k = 1, size (dp%dipoles) - select case (dp%dipoles(k)%type) - case (DIPOLE_FF) - cycle - case (DIPOLE_IF, DIPOLE_II) - if (dp%dipoles(k)%em /= j) cycle - case (DIPOLE_FI) - if (dp%dipoles(k)%sp /= j) cycle - end select - dp%kinematics(j)%components_map(k) = n - dp%kinematics(j)%components(n) = dp%dipoles(k) - n = n + 1 - end do - end if - ! Build the list of charge factors - allocate (dp%kinematics(j)%charge_factors( & - dp%kinematics(j)%n_components, n_flv)) - do k = 1, n_flv - do n = 1, dp%kinematics(j)%n_components - flv_em = dp%flavor_states(dp%kinematics(j)%components(n)%em, k) - flv_sp = dp%flavor_states(dp%kinematics(j)%components(n)%sp, k) - dp%kinematics(j)%charge_factors(n, k) = & - flavor_get_charge (flv_em) * flavor_get_charge (flv_sp) - end do - end do - ! Setup the matrix element factor map - allocate (dp%kinematics(j)%me_factors (n_flv)) - call setup_me_factor_map (dp%kinematics(j)) - end do - dp%have_sqme = .false. - -contains - - subroutine setup_me_factor_map (kin) - type(kinematic_configuration_t), intent(inout) :: kin - type(interaction_t), pointer :: int - integer :: i, j - type(flavor_t), dimension(:), allocatable :: flvs - integer :: iflv - allocate (flvs(dp%n_tot)) - int => evaluator_get_int_ptr (kin%eval_square) - allocate (kin%me_factor_map (interaction_get_n_matrix_elements (int))) - do i = 1, size (kin%me_factor_map) - flvs = quantum_numbers_get_flavor ( & - interaction_get_quantum_numbers (int, i)) - iflv = -1 - do j = 1, n_flv - if (all (flvs == dp%flavor_states (:, j))) then - iflv = j - exit - end if - end do - if (iflv < 0) call msg_bug ( & - "flavor state mismatch in dipole_integrated_qed_init") - kin%me_factor_map(i) = iflv - end do - end subroutine setup_me_factor_map - -end subroutine dipole_integrated_qed_init - -@ %def dipole_integrated_qed_init -@ % -Check whether a dipole is allowed by the mask. -<>= -function in_mask (em, sp, mask) result (flag) -integer, intent(in) :: em, sp -integer, dimension(:), intent(in), allocatable :: mask -logical :: flag -integer :: i - flag = .true. - if (.not. allocated(mask)) return - if (size (mask) == 0) return - do i = 0, size (mask) / 2 - 1 - if (em == mask(2*i + 1) .and. sp == mask(2*i + 2)) return - end do - flag = .false. -end function in_mask - -@ %def in_mask -@ % -Initialize and finalize the various evaluators. -<>= -public :: dipole_integrated_qed_init_trace -public :: dipole_integrated_qed_init_sqme -public :: dipole_integrated_qed_final_sqme -<>= -subroutine dipole_integrated_qed_init_trace & - (dp, qn_mask_in) -type(dipole_integrated_qed_t), intent(inout), target :: dp -type(quantum_numbers_mask_t), dimension(2), intent(in) :: qn_mask_in -type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask -integer :: i, j - allocate (qn_mask (dp%n_tot)) - qn_mask(1:2) = qn_mask_in - call quantum_numbers_mask_init (qn_mask(3:), .true., .true., .true.) - do i = 1, size (dp%kinematics_map) - j = dp%kinematics_map(i) - call evaluator_init_qn_sum (dp%kinematics(j)%eval_trace, & - dp%kinematics(j)%eval_square, qn_mask) - end do -end subroutine dipole_integrated_qed_init_trace - -subroutine dipole_integrated_qed_init_sqme (dp, qn_mask_in) -type(dipole_integrated_qed_t), intent(inout) :: dp -type(quantum_numbers_mask_t), dimension(2), intent(in) :: qn_mask_in -type(quantum_numbers_mask_t), dimension(dp%n_tot) :: qn_mask -integer :: i, j - qn_mask(:2) = qn_mask_in - call quantum_numbers_mask_init (qn_mask(3:), .false., .true., .true.) - if (all (qn_mask_in .eqv. interaction_get_mask (evaluator_get_int_ptr ( & - dp%kinematics(0)%eval_square), (/1, 2/)))) then - do i = 1, size (dp%kinematics_map) - j = dp%kinematics_map(i) - call evaluator_init_identity (dp%kinematics(j)%eval_sqme, & - dp%kinematics(j)%eval_square) - end do - else - do i = 1, size (dp%kinematics_map) - j = dp%kinematics_map(i) - call evaluator_init_qn_sum (dp%kinematics(j)%eval_sqme, & - dp%kinematics(j)%eval_square, qn_mask) - end do - end if - dp%have_sqme = .true. -end subroutine dipole_integrated_qed_init_sqme - -subroutine dipole_integrated_qed_final_sqme (dp) -type(dipole_integrated_qed_t), intent(inout) :: dp -integer :: i - if (.not. dp%have_sqme) return - do i = 1, size (dp%kinematics_map) - call evaluator_final (dp%kinematics(dp%kinematics_map(i))%eval_sqme) - end do - dp%have_sqme = .false. -end subroutine dipole_integrated_qed_final_sqme - -@ %def dipole_integrated_qed_init_trace -@ %def dipole_integrated_qed_init_sqme -@ %def dipole_integrated_qed_final_sqme -@ - -Finalization. -<>= -public :: dipole_integrated_qed_final -<>= -subroutine dipole_integrated_qed_final (dp) -type(dipole_integrated_qed_t), intent(inout) :: dp -integer :: i, j - if (allocated (dp%kinematics_map)) then - do i = 1, size (dp%kinematics_map) - j = dp%kinematics_map(i) - call evaluator_final (dp%kinematics(j)%eval_square) - call evaluator_final (dp%kinematics(j)%eval_trace) - deallocate (dp%kinematics(j)%momenta) - deallocate (dp%kinematics(j)%components_map) - deallocate (dp%kinematics(j)%components) - deallocate (dp%kinematics(j)%charge_factors) - deallocate (dp%kinematics(j)%me_factor_map) - deallocate (dp%kinematics(j)%me_factors) - end do - deallocate (dp%kinematics_map) - end if - if (allocated (dp%flavor_states)) deallocate (dp%flavor_states) - if (allocated (dp%masses)) deallocate (dp%masses) - if (allocated (dp%dipoles)) deallocate (dp%dipoles) - call hard_interaction_final (dp%hi) -end subroutine dipole_integrated_qed_final - -@ %def dipole_integrated_qed_final -@ % -Assignment. -<>= -public :: assignment(=) -<>= -interface assignment(=) - module procedure dipole_integrated_qed_assign -end interface -<>= -subroutine dipole_integrated_qed_assign (to, from) -type(dipole_integrated_qed_t), intent(out) :: to -type(dipole_integrated_qed_t), intent(in) :: from -integer :: i, j - to%n_tot = from%n_tot - to%alpha = from%alpha - to%mreg = from%mreg - to%x = from%x - allocate (to%flavor_states(size ( & - from%flavor_states, 1), size (from%flavor_states, 2))) - to%flavor_states = from %flavor_states - allocate (to%masses (size (from%masses))) - to%masses = from%masses - allocate (to%dipoles (size (from%dipoles))) - to%dipoles = from%dipoles - to%hi = from%hi - allocate (to%kinematics_map (size (from%kinematics_map))) - to%kinematics_map = from%kinematics_map - do i = 1, size (to%kinematics_map) - j = to%kinematics_map(j) - call kinematics_assign (to%kinematics(j), from%kinematics(j)) - call evaluator_replace_interaction (to%kinematics(j)%eval_square, int1 = & - hard_interaction_get_int_ptr (to%hi)) - end do - -contains - - subroutine kinematics_assign (k_to, k_from) - type(kinematic_configuration_t), intent(out) :: k_to - type(kinematic_configuration_t), intent(in) :: k_from - allocate (k_to%momenta (size ( & - k_from%momenta))) - k_to%momenta = k_from%momenta - k_to%weight = k_from%weight - k_to%passed = k_from%passed - k_to%n_components = k_from%n_components - allocate (k_to%components_map (size (k_from%components_map))) - k_to%components_map = k_from%components_map - allocate (k_to%components (size (k_from%components))) - k_to%components = k_from%components - allocate (k_to%component_values (size (k_from%component_values))) - k_to%component_values = k_from%component_values - allocate (k_to%charge_factors (size (k_from%charge_factors, 1), & - size (k_from%charge_factors, 2))) - k_to%charge_factors = k_from%charge_factors - allocate (k_to%me_factor_map (size (k_from%me_factor_map))) - k_to%me_factor_map = k_from%me_factor_map - allocate (k_to%me_factors (size (k_from%me_factors))) - k_to%me_factors = k_from%me_factors - k_to%eval_square = k_from%eval_square - k_to%eval_trace = k_from%eval_trace - k_to%eval_sqme = k_from%eval_sqme - call evaluator_replace_interaction (k_to%eval_sqme, & - hard_interaction_get_int_ptr (to%hi)) - call evaluator_replace_interaction (k_to%eval_trace, int1 = & - evaluator_get_int_ptr (k_to%eval_square)) - if (from%have_sqme) call evaluator_replace_interaction (k_to%eval_sqme, & - int1 = evaluator_get_int_ptr (k_to%eval_square)) - end subroutine kinematics_assign - -end subroutine dipole_integrated_qed_assign - -@ %def dipole_integrated_qed_assign -@ -Prepare for a new evaluation cycle. -<>= -public :: dipole_integrated_qed_reset -<>= -subroutine dipole_integrated_qed_reset (dp) -type(dipole_integrated_qed_t), intent(inout) :: dp - dp%kinematics(dp%kinematics_map)%passed = .false. -end subroutine dipole_integrated_qed_reset - -@ %def dipole_integrated_qed_reset -@ -Set / get $\alpha$. -<>= -public :: dipole_integrated_qed_get_alpha_qed -public :: dipole_integrated_qed_set_alpha_qed -<>= -function dipole_integrated_qed_get_alpha_qed (dp) result (alpha) -type(dipole_integrated_qed_t), intent(in) :: dp -real(kind=default) :: alpha - alpha = dp%alpha -end function dipole_integrated_qed_get_alpha_qed - -subroutine dipole_integrated_qed_set_alpha_qed (dp, alpha) -type(dipole_integrated_qed_t), intent(inout) :: dp -real(kind=default), intent(in) :: alpha - dp%alpha = alpha -end subroutine dipole_integrated_qed_set_alpha_qed - -@ %def dipole_integrated_qed_set_alpha_qed -@ %def dipole_integrated_qed_get_alpha_qed -@ % -Get the number of in / out kinematics. -<>= -public :: dipole_integrated_qed_get_n_kinematics -<>= -function dipole_integrated_qed_get_n_kinematics (dp) result (n) -type(dipole_integrated_qed_t), intent(in) :: dp -integer :: n - n = size (dp%kinematics_map) -end function dipole_integrated_qed_get_n_kinematics - -@ %def dipole_integrated_qed_get_n_kinematics -@ % -Get / set $x$. -<>= -public :: dipole_integrated_qed_get_x -public :: dipole_integrated_qed_set_x -<>= -function dipole_integrated_qed_get_x (dp) result (x) -type(dipole_integrated_qed_t), intent(in) :: dp -real(kind=default) :: x - x = dp%x -end function dipole_integrated_qed_get_x - -subroutine dipole_integrated_qed_set_x (dp, x) -type(dipole_integrated_qed_t), intent(inout) :: dp -real(kind=default), intent(in) :: x - dp%x = x -end subroutine dipole_integrated_qed_set_x - -@ %def dipole_integrated_qed_set_x -@ %def dipole_integrated_qed_get_x -@ % -Salvage the seed momenta from the interactions and calculate the twisted momenta. -<>= -public :: dipole_integrated_qed_process_momenta_in -<>= -subroutine dipole_integrated_qed_process_momenta_in (dp) -type(dipole_integrated_qed_t), intent(inout) :: dp -integer :: n, i, j - dp%kinematics(0)%momenta = interaction_get_momenta ( & - evaluator_get_int_ptr (dp%kinematics(0)%eval_square)) - do n = 2, size (dp%kinematics_map) - i = dp%kinematics_map (n) - if (i == 1) then - j = 2 - else - j = 1 - end if - dp%kinematics(i)%momenta(i) = dp%x * dp%kinematics(0)%momenta(i) - dp%kinematics(i)%momenta(j) = dp%kinematics(0)%momenta(j) - end do -end subroutine dipole_integrated_qed_process_momenta_in - -@ %def dipole_integrated_qed_process_momenta_in -@ -<>= -pure function get_index (dp, index) result (i) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, intent(in), optional :: index -integer :: i - i = 1; if (present (index)) i = dp%kinematics_map(index) -end function get_index - -@ %def get_index -@ -Retrieve the incoming momenta. -<>= -public :: dipole_integrated_qed_get_momenta_in -<>= -subroutine dipole_integrated_qed_get_momenta_in (dp, momenta, index) -type(dipole_integrated_qed_t), intent(in) :: dp -type(vector4_t), dimension(2), intent(out) :: momenta -integer, intent(in), optional :: index - momenta = dp%kinematics(get_index (dp, index))%momenta(1:2) -end subroutine dipole_integrated_qed_get_momenta_in - -@ %def dipole_integrated_qed_get_momenta_in -@ -Set outgoing momenta. -<>= -public :: dipole_integrated_qed_set_momenta_out -<>= -subroutine dipole_integrated_qed_set_momenta_out (dp, momenta, index) -type(dipole_integrated_qed_t), intent(inout) :: dp -type(vector4_t), intent(in), dimension(:) :: momenta -integer, intent(in), optional :: index -integer :: i -type(interaction_t), pointer :: int - i = get_index (dp, index) - dp%kinematics(i)%momenta(3:) = momenta - int => evaluator_get_int_ptr (dp%kinematics(i)%eval_square) - call interaction_set_momenta (int, dp%kinematics(i)%momenta) -end subroutine dipole_integrated_qed_set_momenta_out - -@ %def dipole_integrated_qed_set_momenta_out -@ % -Set / get the phasespace weight (jacobian * volume) -<>= -public :: dipole_integrated_qed_set_weight -public :: dipole_integrated_qed_get_weight -<>= -subroutine dipole_integrated_qed_set_weight (dp, weight, index) -type(dipole_integrated_qed_t), intent(inout) :: dp -real(default), intent(in) :: weight -integer, intent(in), optional :: index - dp%kinematics(get_index (dp, index))%weight = weight -end subroutine dipole_integrated_qed_set_weight - -function dipole_integrated_qed_get_weight (dp, index) result (weight) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, intent(in), optional :: index -real(default) :: weight - weight = dp%kinematics(get_index (dp, index))%weight -end function dipole_integrated_qed_get_weight - -@ %def dipole_integrated_qed_set_weight -@ %def dipole_integrated_qed_get_weight -@ -Set / get the cut status. -<>= -public :: dipole_integrated_qed_get_cut_status -public :: dipole_integrated_qed_set_cut_status -<>= -subroutine dipole_integrated_qed_set_cut_status (dp, passed, index) -type(dipole_integrated_qed_t), intent(inout) :: dp -logical, intent(in) :: passed -integer, intent(in), optional :: index - dp%kinematics(get_index (dp, index))%passed = passed -end subroutine dipole_integrated_qed_set_cut_status - -function dipole_integrated_qed_get_cut_status (dp, index) result (passed) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, intent(in), optional :: index -logical :: passed - passed = dp%kinematics(get_index (dp, index))%passed -end function dipole_integrated_qed_get_cut_status - -@ %def dipole_integrated_qed_set_cut_status -@ %def dipole_integrated_qed_get_cut_status -@ -Evaluate the subtraction term, fill the interactions and evaluate the trace. -<>= -public :: dipole_integrated_qed_evaluate -<>= -function doublify (str) result (res) -character(*), intent(in) :: str -character(255) :: res -integer :: n - res = str - n = scan (res, 'eEdD') - if (n < 1) then - res = trim (res) // "d0" - else - res(n:n) = "d" - end if -end function doublify - -subroutine dipole_integrated_qed_evaluate (dp) -type(dipole_integrated_qed_t), intent(inout) :: dp -integer :: em, sp -integer :: i, j, k, n_me -real(kind=default) :: p2 -type(interaction_t), pointer :: hi_int, square_int -real(kind=default) :: dpfac_b, dpfac_c, dpfac_a -type(vector4_t) :: pcms -real(default) :: shat, alpi - forall (i = 1:size (dp%kinematics_map)) & - dp%kinematics(dp%kinematics_map(i))%component_values = 0 - pcms = dp%kinematics(0)%momenta(1) + dp%kinematics(0)%momenta(2) - shat = pcms * pcms - alpi = - dp%alpha / two / pi - SCAN: do i = 1, size (dp%dipoles) - em = dp%dipoles(i)%em - sp = dp%dipoles(i)%sp - select case (dp%dipoles(i)%type) - case (DIPOLE_FF) - if (.not. dp%kinematics(0)%passed) cycle SCAN - p2 = (dp%kinematics(0)%momenta(em) + & - dp%kinematics(0)%momenta(sp))**2 - dp%kinematics(0)%component_values(i) = & - (ll (p2, dp%masses(em), dp%mreg) - pi**2/three + three/two) - case (DIPOLE_IF) - if (dp%kinematics(em)%passed) then - p2 = (dp%kinematics(em)%momenta(sp) - & - dp%kinematics(em)%momenta(em))**2 - j = dp%kinematics(em)%components_map(i) - dp%kinematics(em)%component_values(j) = - & - gai (abs (p2), dp%x, dp%masses(em)) / dp%x - end if - if (dp%kinematics(0)%passed) then - p2 = (dp%kinematics(0)%momenta(sp) - & - dp%kinematics(0)%momenta(em))**2 - dp%kinematics(0)%component_values(i) = - ( & - - gai (abs (p2), dp%x, dp%masses(em)) & - + (ll (abs (p2), dp%masses(em), dp%mreg) + & - pi**2/6._default - one) & - ) - end if - case (DIPOLE_FI) - if (dp%kinematics(sp)%passed) then - p2 = (dp%kinematics(sp)%momenta(em) - & - dp%kinematics(sp)%momenta(sp))**2 - j = dp%kinematics(sp)%components_map(i) - dp%kinematics(sp)%component_values(j) = - gia (dp%x) / dp%x - end if - if (dp%kinematics(0)%passed) then - p2 = (dp%kinematics(0)%momenta(em) - & - dp%kinematics(0)%momenta(sp))**2 - dp%kinematics(0)%component_values(i) = - ( & - - gia (dp%x) & - + (ll (abs (p2), dp%masses(em), dp%mreg) - & - pi**2/two + three/two) & - ) - end if - case (DIPOLE_II) - if (dp%kinematics(em)%passed) then - j = dp%kinematics(em)%components_map(i) - dp%kinematics(em)%component_values(j) = & - gab(shat, dp%x, dp%masses(em)) / dp%x - end if - if (dp%kinematics(0)%passed) then - dp%kinematics(0)%component_values(i) = ( & - - gab(shat, dp%x, dp%masses(em)) & - + (ll (shat, dp%masses(em), dp%mreg) - & - pi**2/three + two) & - ) - end if - dpfac_a = - (-dp%alpha / two / pi) * & - gab (shat, dp%x, dp%masses(em)) - dpfac_b = (-dp%alpha / two / pi) * ( & - ll (shat, dp%masses(em), dp%mreg) - pi**2/three + two) - end select - end do SCAN - hi_int => hard_interaction_get_int_ptr (dp%hi) - do i = 1, size (dp%kinematics_map) - j = dp%kinematics_map(i) - square_int => evaluator_get_int_ptr (dp%kinematics(j)%eval_square) - n_me = interaction_get_n_matrix_elements (square_int) - if (dp%alphas_updated) & - call hard_interaction_update_alpha_s (dp%hi, dp%kinematics(j)%alphas) - call interaction_set_momenta (hi_int, dp%kinematics(j)%momenta) - call hard_interaction_evaluate (dp%hi) - call evaluator_evaluate (dp%kinematics(j)%eval_square) - forall (k = 1:size (dp%flavor_states, 2)) & - dp%kinematics(j)%me_factors(k) = dot_product ( & - dp%kinematics(j)%component_values, & - dp%kinematics(j)%charge_factors(:, k) & - ) - do k = 1, n_me - call interaction_set_matrix_element ( & - square_int, k, & - interaction_get_matrix_element (square_int, k) * alpi * & - dp%kinematics(j)%me_factors( dp%kinematics(j)%me_factor_map(k)) & - ) - end do - call evaluator_receive_momenta (dp%kinematics(j)%eval_trace) - call evaluator_evaluate (dp%kinematics(j)%eval_trace) - if (dp%have_sqme) then - call evaluator_receive_momenta (dp%kinematics(j)%eval_sqme) - call evaluator_evaluate (dp%kinematics(j)%eval_sqme) - end if - end do -! call debug_hook (dp) - -contains - -pure function pp (x) result (y) -real(kind=default), intent(in) :: x -real(kind=default) :: y - y = (one + x*x) / (one - x) -end function pp - -pure function ll (p2, m2, mreg2) result (y) -real(kind=default), intent(in) :: p2, m2, mreg2 -real(kind=default) :: y -real(kind=default) :: lm2, lmreg2 - lm2 = log (m2/p2) - lmreg2 = log (mreg2/p2) - y = lm2*lmreg2 + lmreg2 - (lm2**2 - lm2) / two -end function ll - -pure function gai (p2, x, m2) result (y) -real(kind=default), intent(in) :: p2, x, m2 -real(kind=default) :: y - y = pp (x) * (log (abs (p2)/m2/x) - one) & - - two*log (two - x)/(one - x) + (one + x)*log (one - x) + one - x -end function gai - -pure function gia (x) result (y) -real(kind=default), intent(in) :: x -real(kind=default) :: y - y = (two * log ((two - x)/(one - x)) - three/two) / (one - x) -end function gia - -pure function gab (s, x, m2) result (y) -real(kind=default), intent(in) :: s, x, m2 -real(kind=default) :: y - y = pp (x) * (log (s/m2) - one) + (one - x) -end function gab - -subroutine debug_hook (dp) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, parameter :: max_calls=10 -integer, save :: u -logical, save :: firstcall=.true., active=.false. -integer, save :: count -integer :: err, i, mu -real(kind=default) :: cached = -1 -type(kinematic_configuration_t) :: k - if (.not. active) return - if (firstcall) then - if (size (dp%dipoles) /= 1) then - active = .false. - return - end if - u = free_unit () - open (unit=u, file="excerpt.out", status="replace", action="write", iostat=err) - if (err /= 0) then - active = .false. - return - end if - count = 1 - firstcall = .false. - end if - k = dp%kinematics(0) - write (u, '(A)') " if (i .eq. " // int2char (count) // ") then" - do i = 1, size (k%momenta) - do mu = 0, 3 - write (u, '(A)') " p(" // int2char(i) // "," // int2char(mu) // & - ") = " // trim (doublify (real2char (vector4_get_component ( & - k%momenta(i), mu)))) - end do - end do - write (u, '(A)') " s = " // trim (real2char (shat)) - write (u, '(A)') " x = " // trim (real2char (dp%x)) - write (u, '(A)') " me = " // trim (real2char (real ( interaction_sum & - (evaluator_get_int_ptr (k%eval_trace)), default))) - write (u, '(A)') " weight = " // trim (real2char (k%weight)) - write (u, '(A)') "" - count = count + 1 - if (count > max_calls) then - close (u) - active = .false. - end if -end subroutine debug_hook - -end subroutine dipole_integrated_qed_evaluate - -@ %def dipole_integrated_qed_evaluate -@ % -<>= -public :: dipole_integrated_qed_write -<>= -subroutine dipole_integrated_qed_write (dp, unit) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, intent(in) :: unit -integer :: i, u -type(string_t) :: buffer -character(*), parameter :: del = repeat ("-", 80) - u = output_unit (unit); if (u < 0) return - write (u, '(A)') "massless integrated QED dipole" - write (u, '(3X,A)') "alpha: " // real2char (dp%alpha) - write (u, '(3X,A)') "soft mass regulator: " // real2char (sqrt (dp%mreg)) - write (u, '(3X,A)') "collinear mass regulators:" - buffer = "" - do i = 1, size (dp%masses) - buffer = trim (buffer) // real2string (sqrt (dp%masses(i))) // " " - end do - write (u, '(5X,A)') trim (char (buffer)) - write (u, '(3X,A)') "Kinematics:" - write (u, '(3X,A)') del - do i = 1, size (dp%kinematics_map) - write (u, '(3X,A,I0)') "Configuration ", i - call write_kinematic (dp%kinematics(dp%kinematics_map(i))) - write (u, '(3X,A)') del - end do - -contains - - subroutine write_kinematic (k) - type(kinematic_configuration_t), intent(in) :: k - integer :: i - write (u, '(3X,A,E20.14)') "weight = ", k%weight - write (u, '(3X,A,L1)') "passed = ", k%passed - write (u, '(3X,A,1X)', advance = "no") "dipole components =" - do i = 1, k%n_components - write (u, "(I0,':',I0,' ')", advance='no') & - k%components(i)%em, k%components(i)%sp - end do - write (u, '(A)') - write (u, '(3X,A)') "components map =" - write (u, '(6X,I0)') k%components_map - write (u, '(3X,A)') "charge factors =" - do i = 1, size (k%charge_factors, 2) - write (u, '(6X,E20.14)') k%charge_factors(:, i) - end do - write (u, '(3X,A)') "me_factor_map =" - write (u, '(6X)', advance = "no") - do i = 1, size (k%me_factor_map) - write (u, '(I0,1X)', advance = "no") k%me_factor_map(i) - end do - write (u, '(A)') - write (u, '(6X,I2)') k%me_factor_map - write (u, '(3X,A)') "me_factors =" - write (u, '(6X,E20.14)') k%me_factors - write (u, '(6X,E10.5)') k%charge_factors - end subroutine - -end subroutine dipole_integrated_qed_write -@ %def -@ -Wrappers around the hard interaction object to complete the interface for the -core interaction type. -<>= -public :: dipole_integrated_qed_unload -public :: dipole_integrated_qed_reload -public :: dipole_integrated_qed_update_parameters -public :: dipole_integrated_qed_get_model_ptr -public :: dipole_integrated_qed_get_n_in -public :: dipole_integrated_qed_get_n_out -public :: dipole_integrated_qed_get_n_tot -public :: dipole_integrated_qed_get_n_flv -public :: dipole_integrated_qed_get_flv_states -public :: dipole_integrated_qed_get_first_pdg_in -public :: dipole_integrated_qed_get_first_pdg_out -public :: dipole_integrated_qed_get_unstable_products -public :: dipole_integrated_qed_reset_helicity_selection -public :: dipole_integrated_qed_update_alpha_s -public :: dipole_integrated_qed_get_int_ptr -public :: dipole_integrated_qed_get_eval_trace_ptr -public :: dipole_integrated_qed_get_eval_sqme_ptr -public :: dipole_integrated_qed_write_state_summary -public :: dipole_integrated_qed_is_valid -public :: dipole_integrated_qed_get_id -<>= -subroutine dipole_integrated_qed_unload (dp) -type(dipole_integrated_qed_t), intent(inout) :: dp - call hard_interaction_unload (dp%hi) -end subroutine dipole_integrated_qed_unload - -subroutine dipole_integrated_qed_reload (dp, prc_lib) -type(dipole_integrated_qed_t), intent(inout) :: dp -type(process_library_t), intent(in) :: prc_lib - call hard_interaction_reload (dp%hi, prc_lib) -end subroutine dipole_integrated_qed_reload - -subroutine dipole_integrated_qed_update_parameters (dp) -type(dipole_integrated_qed_t), intent(inout) :: dp - call hard_interaction_update_parameters (dp%hi) -end subroutine dipole_integrated_qed_update_parameters - -function dipole_integrated_qed_get_model_ptr (dp) result (model) -type(dipole_integrated_qed_t), intent(in) :: dp -type(model_t), pointer :: model - model => hard_interaction_get_model_ptr (dp%hi) -end function dipole_integrated_qed_get_model_ptr - -function dipole_integrated_qed_get_n_in (dp) result (n) -type(dipole_integrated_qed_t), intent(in) :: dp -integer :: n - n = hard_interaction_get_n_in (dp%hi) -end function dipole_integrated_qed_get_n_in - -function dipole_integrated_qed_get_n_out (dp) result (n) -type(dipole_integrated_qed_t), intent(in) :: dp -integer :: n - n = hard_interaction_get_n_out (dp%hi) -end function dipole_integrated_qed_get_n_out - -function dipole_integrated_qed_get_n_tot (dp) result (n) -type(dipole_integrated_qed_t), intent(in) :: dp -integer :: n - n = dp%n_tot -end function dipole_integrated_qed_get_n_tot - -function dipole_integrated_qed_get_n_flv (dp) result (n) -type(dipole_integrated_qed_t), intent(in) :: dp -integer :: n - n = size (dp%flavor_states, 2) -end function dipole_integrated_qed_get_n_flv - -function dipole_integrated_qed_get_flv_states (dp) result (flv) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, dimension(:,:), allocatable :: flv - allocate (flv (size (dp%flavor_states, 1), size (dp%flavor_states, 2))) - flv = hard_interaction_get_flv_states (dp%hi) -end function dipole_integrated_qed_get_flv_states - -function dipole_integrated_qed_get_first_pdg_in (dp) result (pdg) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, dimension(2) :: pdg - pdg = hard_interaction_get_first_pdg_in (dp%hi) -end function dipole_integrated_qed_get_first_pdg_in - -function dipole_integrated_qed_get_first_pdg_out (dp) result (pdg) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, dimension(dp%n_tot - 2) :: pdg - pdg = hard_interaction_get_first_pdg_out (dp%hi) -end function dipole_integrated_qed_get_first_pdg_out - -subroutine dipole_integrated_qed_get_unstable_products (dp, flavors) -type(dipole_integrated_qed_t), intent(in) :: dp -type(flavor_t), dimension(:), allocatable :: flavors - call hard_interaction_get_unstable_products (dp%hi, flavors) -end subroutine dipole_integrated_qed_get_unstable_products - -subroutine dipole_integrated_qed_reset_helicity_selection & - (dp, threshold, cutoff) -type(dipole_integrated_qed_t), intent(inout) :: dp -real(default), intent(in) :: threshold -integer, intent(in) :: cutoff - call hard_interaction_reset_helicity_selection (dp%hi, threshold, cutoff) -end subroutine dipole_integrated_qed_reset_helicity_selection - -subroutine dipole_integrated_qed_update_alpha_s (dp, alphas, index) -type(dipole_integrated_qed_t), intent(inout) :: dp -real(default), intent(in) :: alphas -integer, intent(in), optional :: index -integer :: i - dp%kinematics(get_index (dp, index))%alphas = alphas - dp%alphas_updated = .true. -end subroutine dipole_integrated_qed_update_alpha_s - -function dipole_integrated_qed_get_int_ptr (dp, index) result (int) -type(dipole_integrated_qed_t), intent(in), target :: dp -integer, intent(in), optional :: index -type(interaction_t), pointer :: int - int => evaluator_get_int_ptr ( & - dp%kinematics(get_index (dp, index))%eval_square) -end function dipole_integrated_qed_get_int_ptr - -function dipole_integrated_qed_get_eval_trace_ptr (dp, index) result (eval) -type(dipole_integrated_qed_t), intent(in), target :: dp -integer, intent(in), optional :: index -type(evaluator_t), pointer :: eval - eval => dp%kinematics(get_index (dp, index))%eval_trace -end function dipole_integrated_qed_get_eval_trace_ptr - -function dipole_integrated_qed_get_eval_sqme_ptr (dp, index) result (eval) -type(dipole_integrated_qed_t), intent(in), target :: dp -integer, intent(in), optional :: index -type(evaluator_t), pointer :: eval - eval => dp%kinematics(get_index (dp, index))%eval_sqme -end function dipole_integrated_qed_get_eval_sqme_ptr - -subroutine dipole_integrated_qed_write_state_summary (dp, unit) -type(dipole_integrated_qed_t), intent(in) :: dp -integer, intent(in), optional :: unit - call hard_interaction_write_state_summary (dp%hi, unit) -end subroutine dipole_integrated_qed_write_state_summary - -function dipole_integrated_qed_is_valid (dp) result (flag) -type(dipole_integrated_qed_t), intent(in) :: dp -logical :: flag - flag = hard_interaction_is_valid (dp%hi) -end function dipole_integrated_qed_is_valid - -function dipole_integrated_qed_get_id (dp) result (id) -type(dipole_integrated_qed_t), intent(in) :: dp -type(string_t) :: id - id = hard_interaction_get_id (dp%hi) -end function dipole_integrated_qed_get_id - -@ %def dipole_integrated_qed_unload -@ %def dipole_integrated_qed_reload -@ %def dipole_integrated_qed_update_parameters -@ %def dipole_integrated_qed_get_model_ptr -@ %def dipole_integrated_qed_get_n_in -@ %def dipole_integrated_qed_get_n_out -@ %def dipole_integrated_qed_get_n_tot -@ %def dipole_integrated_qed_get_n_flv -@ %def dipole_integrated_qed_get_flv_states -@ %def dipole_integrated_qed_get_first_pdg_in -@ %def dipole_integrated_qed_get_first_pdg_out -@ %def dipole_integrated_qed_get_unstable_products -@ %def dipole_integrated_qed_reset_helicity_selection -@ %def dipole_integrated_qed_update_alpha_s -@ %def dipole_integrated_qed_get_int_ptr -@ %def dipole_integrated_qed_get_eval_trace_ptr -@ %def dipole_integrated_qed_get_eval_sqme_ptr -@ %def dipole_integrated_qed_write_state_summary -@ %def dipole_integrated_qed_is_valid -@ %def dipole_integrated_qed_get_id -@ - -\subsection{Real QED Dipoles} - -Real QED dipoles. - -<<[[dipoles_real_qed.f90]]>>= -<> - -module dipoles_real_qed - -<> -<> - use constants !NODEP! -<> - use diagnostics !NODEP! - use sm_physics !NODEP! - use md5 - use lorentz !NODEP! - use models - use flavors - use quantum_numbers - use interactions - use evaluators - use particles - use hard_interactions - use quantum_numbers - use nlo_setup - use process_libraries - use interactions - use state_matrices - -<> - -<> - -<> - -<> - -<> - -<> - -contains - -<> - -end module dipoles_real_qed -@ %def dipoles_integrated_qed -@ % -The different dipole types. -<>= -integer, parameter :: DIPOLE_FF = 1, DIPOLE_IF = 2, DIPOLE_FI = 3, & - DIPOLE_II = 5 -integer, parameter :: DIPOLE_RAD = 1, DIPOLE_SPLIT = 2 -@ %def DIPOLE_FF DIPOLE_IF DIPOLE_FI DIPOLE_II -@ % -A single dipole component. -<>= -type dipole_single_t - integer :: em, sp - integer :: type, splitting -end type dipole_single_t - -@ %def dipole_single_t -@ -Each emitter / spectator combination is associated with a phase space -configuration. -<>= -type kinematic_configuration_t - ! Kinematics - type(vector4_t), dimension(:), allocatable :: momenta - logical :: passed = .true. - real(default) :: alphas - ! Dipole - type(dipole_single_t) :: component - real(default) :: component_value - real(default), dimension(:), allocatable :: charge_factors - integer, dimension(:), allocatable :: me_factor_map - real(default), dimension(:), allocatable :: me_factors - ! Evaluators - type(evaluator_t) :: eval_square - type(evaluator_t) :: eval_trace - type(evaluator_t) :: eval_sqme -end type kinematic_configuration_t - -@ %def kinematics_configuration_t -@ -The actual subtraction term. If [[resolve]] is switched on, the dipole presents -a single out interaction including the resolved photon --- this is intented only -for debugging and benchmarking purposes. If [[resolve]] is off, every dipole -component corresponds to a distinct out configuration which does not include the -photon and is equipped with the twisted kinematics of the core matrix element. -This ensures that the photon is treated similarly both in the numerical and the -analytical integration. - -Note that [[tot]] and [[eff]] have a different -meaning here w.r.t. the [[core_interaction]] methods: [[n_eff]] is the number of -legs of the core $2\rightarrow n$ interaction, why [[n_tot]] is the number of -legs of the out interactions (either $n+2$ or $n+3$, depending on the status of -[[resolve]]). -<>= -public :: dipole_real_qed_t -<>= -type dipole_real_qed_t - private - logical :: resolve = .false. - logical :: photon_splittings = .false. - logical :: have_sqme = .false. - integer :: n_tot, n_eff - real(kind=default) :: alpha = 0 - real(kind=default) :: mreg = 0 - logical :: alphas_updated = .false. - type(flavor_t), dimension(:,:), allocatable :: & - flavor_states_tot, flavor_states_eff - real(kind=default), dimension(:), allocatable :: masses - type(dipole_single_t), dimension(:), allocatable :: dipoles - type(hard_interaction_t) :: hi - integer, dimension(:), allocatable :: active_particles - type(vector4_t), dimension(:), allocatable :: momenta - real(kind=default) :: weight - type(kinematic_configuration_t), dimension(:), allocatable :: kinematics - ! Collapse the subtraction terms into a single density matrix if resolve is - ! set - type(interaction_t) :: int_resolved - type(evaluator_t) :: trace_resolved - type(evaluator_t) :: sqme_resolved - logical :: passed - ! Workspace for evaluation - real(default), dimension(:,:), allocatable :: inv, xia, xab, yij -end type dipole_real_qed_t - -@ %def -@ % -Initialization. Lotsa stuff. -<>= -public :: dipole_real_qed_init -<>= -subroutine dipole_real_qed_init & - (dp, prc_lib, process_index, process_id, model, alpha, nlo_setup) -type(dipole_real_qed_t), intent(out) :: dp -type(process_library_t), intent(in) :: prc_lib -integer, intent(in) :: process_index -type(string_t), intent(in) :: process_id -type(model_t), target :: model -real(kind=default), intent(in), optional :: alpha -type(nlo_setup_t), intent(in), optional :: nlo_setup -type(nlo_setup_t) :: dpc -integer :: n_flv -integer, dimension(:,:), allocatable :: pdg_states -real, dimension(:), allocatable :: charge_sum -logical, dimension(:), allocatable :: active_particle -type(dipole_single_t), dimension(:), allocatable :: tmp -integer :: i, j, n, em, sp, n_eff, n_tot - if (present (nlo_setup)) then - dpc = nlo_setup - else - dpc = process_library_get_nlo_setup (prc_lib, process_id) - end if - dp%resolve = .false. - if (dpc%resolve_set) dp%resolve = dpc%resolve - ! Hard interaction - call hard_interaction_init (dp%hi, prc_lib, process_index, process_id, model) - if (hard_interaction_get_n_in (dp%hi) /= 2) call msg_bug ( & - "dipoles for decay processes are not supported yet.") - dp%n_eff = hard_interaction_get_n_tot (dp%hi) - if (dp%n_eff /= dpc%n_tot .and. dpc%n_tot > 0) then - call msg_error ("mismatch in dipole setup.") - dpc%n_tot = -1 - if (allocated (dpc%charges)) deallocate (dpc%charges) - if (allocated (dpc%masses)) deallocate (dpc%masses) - if (allocated (dpc%mask)) deallocate (dpc%mask) - end if - if (dp%resolve) then - dp%n_tot = dp%n_eff + 1 - else - dp%n_tot = dp%n_eff - end if - ! gfortran refuses to refer to the entries directly in the contains section - n_tot = dp%n_tot - n_eff = dp%n_eff - ! Flavor states - n_flv = hard_interaction_get_n_flv (dp%hi) - allocate (dp%flavor_states_tot(n_tot, n_flv)) - allocate (dp%flavor_states_eff(n_eff, n_flv)) - allocate (pdg_states(n_eff, n_flv)) - pdg_states = hard_interaction_get_flv_states (dp%hi) - do i = 1, n_flv - call flavor_init (dp%flavor_states_eff(:, i), pdg_states(:, i), model) - call flavor_init (dp%flavor_states_tot(:n_eff, i), & - pdg_states(:, i), model) - if (dp%resolve) call flavor_init ( & - dp%flavor_states_tot(n_tot, i), 22, model) - end do - ! Masses - allocate (dp%masses (n_eff)) - if (allocated (dpc%masses)) then - dp%masses = dpc%masses ** 2 - else - dp%masses = flavor_get_mass (dp%flavor_states_eff(:, 1)) ** 2 - end if - ! Alpha / mreg - if (present (alpha)) dp%alpha = alpha - dp%mreg = dpc%mreg - ! Mometa - allocate (dp%momenta(n_eff+1)) - ! Count the charged flavors - allocate (charge_sum(n_eff)) - charge_sum = 0 - do i = 1, n_flv - charge_sum = charge_sum + abs (flavor_get_charge ( & - dp%flavor_states_eff(:, i))) - end do - n = count (charge_sum > epsilon (one)) - ! Determine dipole components - allocate (tmp(2*(n**2 - n))) - allocate (active_particle(n_eff)) - active_particle = .false. - n = 1 - do i = 1, n_eff - do j = 1, n_eff - if (i == j) cycle - if (abs (charge_sum(i) * charge_sum(j)) < epsilon (one)) cycle - if (.not. in_mask (i, j, dpc%mask)) cycle - active_particle(i) = .true. - active_particle(j) = .true. - tmp(n)%em = i - tmp(n)%sp = j - tmp(n)%splitting = DIPOLE_RAD - if (max (i, j) == 2) then - tmp(n)%type = DIPOLE_II - elseif (i <= 2) then - tmp(n)%type = DIPOLE_IF - elseif (j <= 2) then - tmp(n)%type = DIPOLE_FI - else - tmp(n)%type = DIPOLE_FF - end if - n = n + 1 - end do - end do - allocate (dp%dipoles(n-1)) - if (n > 1) dp%dipoles = tmp(1:n-1) - allocate (dp%active_particles(count (active_particle))) - i = 1 - do j = 1, n_eff - if (active_particle(j)) then - dp%active_particles(i) = j - i = i + 1 - end if - end do - ! Workspace - allocate ( & - dp%inv(n_eff+1, n_eff+1), & - dp%xia(3:n_eff, 2), & - dp%xab(2, 2), & - dp%yij(3:n_eff, 3:n_eff) & - ) - ! Kinematic configurations - allocate (dp%kinematics(size (dp%dipoles))) - do i = 1, size (dp%dipoles) - call init_kinematic_configuration (i, dp%kinematics(i)) - end do - if (dp%resolve .and. size (dp%dipoles) > 0) call setup_int_resolved - dp%have_sqme = .false. - -contains - - subroutine setup_int_resolved - type(quantum_numbers_mask_t), dimension(n_tot) :: qn_mask - type(quantum_numbers_t), dimension(n_tot) :: qn - type(flavor_t) :: flv - type(interaction_t), pointer :: int_src - integer :: i, me_index - int_src => evaluator_get_int_ptr (dp%kinematics(1)%eval_square) - qn_mask(:n_eff) = interaction_get_mask (int_src) - call quantum_numbers_mask_init (qn_mask(n_tot), & - .false., .true., .true.) - call flavor_init (flv, 22, model) - call quantum_numbers_init (qn(n_tot), flv) - call interaction_init (dp%int_resolved, 2, 0, n_tot - 2, & - mask = qn_mask, & - resonant = (/interaction_get_resonance_flags (int_src), .false./) & - ) - do i = 3, n_tot - call interaction_relate (dp%int_resolved, 1, i) - call interaction_relate (dp%int_resolved, 2, i) - end do - do i = 1, interaction_get_n_matrix_elements (int_src) - qn(:n_eff) = interaction_get_quantum_numbers (int_src, i) - call interaction_add_state (dp%int_resolved, qn, & - me_index = me_index) - if (me_index /= i) call msg_bug ( & - "internal error in dipole_real_qed_init") - end do - call interaction_freeze (dp%int_resolved) - end subroutine setup_int_resolved - - subroutine init_kinematic_configuration (i, k) - integer, intent(in) :: i - type(kinematic_configuration_t), intent(out) :: k - type(quantum_numbers_mask_t), dimension(n_eff) :: qn_mask - integer :: j, l - type(interaction_t), pointer :: int_square - type(flavor_t), dimension(n_eff) :: flv - call quantum_numbers_mask_init (qn_mask, .false., .true., .true.) - call evaluator_init_square (k%eval_square, & - hard_interaction_get_int_ptr (dp%hi), qn_mask) - k%component = dp%dipoles(i) - allocate (k%charge_factors (n_flv)) - forall (j = 1:n_flv) & - k%charge_factors (j) = & - flavor_get_charge (dp%flavor_states_eff(k%component%em, j)) * & - flavor_get_charge (dp%flavor_states_eff(k%component%sp, j)) - int_square => evaluator_get_int_ptr (k%eval_square) - allocate (k%me_factors(n_flv)) - allocate (k%me_factor_map(interaction_get_n_matrix_elements (int_square))) - do j = 1, size (k%me_factor_map) - flv = quantum_numbers_get_flavor ( & - interaction_get_quantum_numbers (int_square, j)) - do l = 1, n_flv - if (all (flv == dp%flavor_states_eff(:, l))) exit - end do - k%me_factor_map(j) = l - end do - allocate (k%momenta(n_eff)) - end subroutine init_kinematic_configuration - - function in_mask (em, sp, mask) result (flag) - integer, intent(in) :: em, sp - integer, dimension(:), intent(in), allocatable :: mask - logical :: flag - integer :: i - flag = .true. - if (.not. allocated(mask)) return - if (size (mask) == 0) return - do i = 0, size (mask) / 2 - 1 - if (em == mask(2*i + 1) .and. sp == mask(2*i + 2)) return - end do - flag = .false. - end function in_mask - -end subroutine dipole_real_qed_init - -@ %def dipole_real_qed_init -@ % -<>= -public :: dipole_real_qed_final -<>= -subroutine dipole_real_qed_final (dp) -type(dipole_real_qed_t), intent(inout) :: dp -integer :: i - if (allocated (dp%kinematics)) then - do i = 1, size (dp%kinematics) - call kinematic_configuration_final (dp%kinematics(i)) - end do - deallocate (dp%kinematics) - end if - if (allocated (dp%flavor_states_tot)) deallocate (dp%flavor_states_tot) - if (allocated (dp%flavor_states_eff)) deallocate (dp%flavor_states_eff) - if (allocated (dp%masses)) deallocate (dp%masses) - if (allocated (dp%dipoles)) deallocate (dp%dipoles) - call hard_interaction_final (dp%hi) - if (allocated (dp%active_particles)) deallocate (dp%active_particles) - if (allocated (dp%momenta)) deallocate (dp%momenta) - if (dp%resolve) then - call interaction_final (dp%int_resolved) - call evaluator_final (dp%trace_resolved) - end if - if (allocated (dp%inv)) deallocate (dp%inv) - if (allocated (dp%xia)) deallocate (dp%xia) - if (allocated (dp%xab)) deallocate (dp%xab) - if (allocated (dp%yij)) deallocate (dp%yij) -contains - - subroutine kinematic_configuration_final (k) - type(kinematic_configuration_t), intent(inout) :: k - deallocate (k%momenta) - deallocate (k%charge_factors) - deallocate (k%me_factor_map) - deallocate (k%me_factors) - call evaluator_final (k%eval_square) - call evaluator_final (k%eval_trace) - end subroutine kinematic_configuration_final - -end subroutine dipole_real_qed_final - -@ %def dipole_real_qed_final -@ % -Initialize the trace. -<>= -public :: dipole_real_qed_init_trace -<>= -subroutine dipole_real_qed_init_trace (dp, qn_mask_in) -type(dipole_real_qed_t), intent(inout) :: dp -type(quantum_numbers_mask_t), intent(in), dimension(2) :: qn_mask_in -type(quantum_numbers_mask_t), dimension(dp%n_tot) :: qn_mask -integer :: i - qn_mask(:2) = qn_mask_in - call quantum_numbers_mask_init (qn_mask(3:), .true., .true., .true.) - if (dp%resolve) then - call evaluator_init_qn_sum (dp%trace_resolved, dp%int_resolved, qn_mask) - else - do i = 1, size (dp%kinematics) - call evaluator_init_qn_sum (dp%kinematics(i)%eval_trace, & - dp%kinematics(i)%eval_square, qn_mask) - end do - end if -end subroutine dipole_real_qed_init_trace - -@ %def dipole_real_qed_init_trace -@ % -Initialize / finalize the sqme evaluator. -<>= -public :: dipole_real_qed_init_sqme -public :: dipole_real_qed_final_sqme -<>= -subroutine dipole_real_qed_init_sqme (dp, qn_mask_in) -type(dipole_real_qed_t), intent(inout) :: dp -type(quantum_numbers_mask_t), intent(in), dimension(2) :: qn_mask_in -type(quantum_numbers_mask_t), dimension(dp%n_tot) :: qn_mask -integer :: i - qn_mask(:2) = qn_mask_in - call quantum_numbers_mask_init (qn_mask(3:), .false., .true., .true.) - if (dp%resolve) then - if (all (qn_mask_in .eqv. & - interaction_get_mask (dp%int_resolved, (/1, 2/)))) then - call evaluator_init_identity (dp%sqme_resolved, dp%int_resolved) - else - call evaluator_init_qn_sum (dp%sqme_resolved, dp%int_resolved, & - qn_mask) - end if - else - if (size (dp%kinematics) < 1) return - if (all (qn_mask_in .eqv. interaction_get_mask (evaluator_get_int_ptr ( & - dp%kinematics(1)%eval_square), (/1, 2/)))) then - do i = 1, size (dp%kinematics) - call evaluator_init_identity (dp%kinematics(i)%eval_sqme, & - dp%kinematics(i)%eval_square) - end do - else - do i = 1, size (dp%kinematics) - call evaluator_init_qn_sum (dp%kinematics(i)%eval_sqme, & - dp%kinematics(i)%eval_square, qn_mask) - end do - end if - end if - dp%have_sqme = .true. -end subroutine dipole_real_qed_init_sqme - -subroutine dipole_real_qed_final_sqme (dp) -type(dipole_real_qed_t), intent(inout) :: dp -integer :: i - if (.not. dp%have_sqme) return - if (dp%resolve) then - call evaluator_final (dp%sqme_resolved) - else - do i = 1, size (dp%kinematics) - call evaluator_final (dp%kinematics(i)%eval_sqme) - end do - end if - dp%have_sqme = .false. -end subroutine dipole_real_qed_final_sqme - -@ %def dipole_real_qed_init_sqme dipole_real_qed_final_sqme -@ -Assignment. Sigh, allocation on assignment would be a real boon here. -<>= -public :: assignment(=) -<>= -interface assignment(=) - module procedure dipole_real_qed_assign -end interface -<>= -subroutine dipole_real_qed_assign (to, from) -type(dipole_real_qed_t), intent(out) :: to -type(dipole_real_qed_t), intent(in) :: from -integer :: i - to%resolve = from%resolve - to%photon_splittings = from%photon_splittings - to%n_tot = from%n_tot - to%n_eff = from%n_eff - to%alpha = from%alpha - to%mreg = from%mreg - to%alphas_updated = from%alphas_updated - to%have_sqme = from%have_sqme - allocate (to%flavor_states_tot (from%n_tot, & - size (from%flavor_states_tot, 2))) - to%flavor_states_tot = from%flavor_states_tot - allocate (to%flavor_states_eff(from%n_eff, & - size (from%flavor_states_eff, 2))) - to%flavor_states_eff = from%flavor_states_eff - allocate (to%masses(size (from%masses))) - to%masses = from%masses - allocate (to%dipoles(size (from%dipoles))) - to%dipoles = from%dipoles - to%hi = from%hi - allocate (to%active_particles(size (from%active_particles))) - to%active_particles = from%active_particles - allocate (to%momenta(size (from%momenta))) - to%momenta = from%momenta - to%weight = from%weight - allocate (to%kinematics(size (from%kinematics))) - do i = 1, size (to%kinematics) - call kinematic_configuration_assign (to%kinematics(i), & - from%kinematics(i)) - end do - to%int_resolved = from%int_resolved - to%trace_resolved = from%trace_resolved - to%sqme_resolved = from%sqme_resolved - to%passed = from%passed - if (to%resolve) then - call evaluator_replace_interaction (to%trace_resolved, & - to%int_resolved) - if (from%have_sqme) & - call evaluator_replace_interaction (to%sqme_resolved, & - to%int_resolved) - end if - allocate ( & - to%inv(to%n_eff+1, to%n_eff+1), & - to%xia(3:to%n_eff, 2), & - to%xab(2, 2), & - to%yij(3:to%n_eff, 3:to%n_eff) & - ) - to%inv = from%inv - to%xia = from%xia - to%xab = from%xab - to%yij = from%yij - -contains - - subroutine kinematic_configuration_assign (k_to, k_from) - type(kinematic_configuration_t), intent(in) :: k_from - type(kinematic_configuration_t), intent(out) :: k_to - allocate (k_to%momenta(size (k_from%momenta))) - k_to%momenta = k_from%momenta - k_to%passed = k_from%passed - k_to%alphas = k_from%alphas - k_to%component = k_from%component - k_to%component_value = k_from%component_value - allocate (k_to%charge_factors(size (k_from%charge_factors))) - k_to%charge_factors = k_from%charge_factors - allocate (k_to%me_factor_map(size (k_from%me_factor_map))) - k_to%me_factor_map = k_from%me_factor_map - allocate (k_to%me_factors(size (k_from%me_factors))) - k_to%me_factors = k_from%me_factors - k_to%eval_square = k_from%eval_square - k_to%eval_trace = k_from%eval_trace - k_to%eval_sqme = k_from%eval_sqme - call evaluator_replace_interaction (k_to%eval_square, & - hard_interaction_get_int_ptr (to%hi)) - if (.not. to%resolve) then - call evaluator_replace_interaction ( & - k_to%eval_trace, evaluator_get_int_ptr (k_to%eval_square)) - if (from%have_sqme) call evaluator_replace_interaction ( & - k_to%eval_sqme, evaluator_get_int_ptr (k_to%eval_square)) - end if - end subroutine kinematic_configuration_assign - -end subroutine dipole_real_qed_assign - -@ %def dipole_real_qed_assign -@ -Prepare for a new evaluation cycle. -<>= -public :: dipole_real_qed_reset -<>= -subroutine dipole_real_qed_reset (dp) -type(dipole_real_qed_t), intent(inout) :: dp -integer :: i - dp%passed = .false. - do i = 1, size (dp%kinematics) - dp%kinematics(i)%passed = .false. - end do -end subroutine dipole_real_qed_reset - -@ %def dipole_real_qed_reset -@ -Set / get electroweak $\alpha$. -<>= -public :: dipole_real_qed_get_alpha -public :: dipole_real_qed_set_alpha -<>= -function dipole_real_qed_get_alpha (dp) result (alpha) -type(dipole_real_qed_t), intent(in) :: dp -real(kind=default) :: alpha - alpha = dp%alpha -end function dipole_real_qed_get_alpha - -subroutine dipole_real_qed_set_alpha (dp, alpha) -type(dipole_real_qed_t), intent(inout) :: dp -real(kind=default), intent(in) :: alpha - dp%alpha = alpha -end subroutine dipole_real_qed_set_alpha - -@ %def dipole_real_qed_set_alpha dipole_real_qed_get_alpha -@ % -Get the number of out type kinematics. -<>= -public :: dipole_real_qed_get_n_kinematics_out -<>= -function dipole_real_qed_get_n_kinematics_out (dp) result (n) -type(dipole_real_qed_t), intent(in) :: dp -integer :: n - if (dp%resolve) then - n = 1 - else - n = size (dp%kinematics) - end if -end function dipole_real_qed_get_n_kinematics_out - -@ %def dipole_real_qed_get_n_kinematics_out -@ -Get the ingoing momenta. -<>= -public :: dipole_real_qed_get_momenta_in -<>= -subroutine dipole_real_qed_get_momenta_in (dp, mom) -type(dipole_real_qed_t), intent(in) :: dp -type(vector4_t), dimension(2), intent(out) :: mom - mom = dp%momenta(:2) -end subroutine dipole_real_qed_get_momenta_in - -@ %def dipole_real_qed_get_momenta_in -@ -Set the outgoing momenta. -<>= -public :: dipole_real_qed_set_momenta_out -<>= -subroutine dipole_real_qed_set_momenta_out (dp, mom) -type(dipole_real_qed_t), intent(inout) :: dp -type(vector4_t), intent(in), dimension(:) :: mom - dp%momenta(3:) = mom -end subroutine dipole_real_qed_set_momenta_out - -@ %def dipole_real_qed_set_momenta_out -@ -Set / get the phasespace weight. -<>= -public :: dipole_real_qed_set_weight -public :: dipole_real_qed_get_weight -<>= -subroutine dipole_real_qed_set_weight (dp, weight) -type(dipole_real_qed_t), intent(inout) :: dp -real(kind=default), intent(in) :: weight - dp%weight = weight -end subroutine dipole_real_qed_set_weight - -function dipole_real_qed_get_weight (dp) result (weight) -type(dipole_real_qed_t), intent(in) :: dp -real(kind=default) :: weight - weight = dp%weight -end function dipole_real_qed_get_weight - -@ %def dipole_real_qed_get_weight dipole_real_qed_set_weight -@ -Get / set the cut status. -<>= -public :: dipole_real_qed_kinematics_passed -public :: dipole_real_qed_get_cut_status -public :: dipole_real_qed_set_cut_status -public :: dipole_real_qed_any_passed -<>= -subroutine dipole_real_qed_kinematics_passed (dp, stat) -type(dipole_real_qed_t), intent(inout) :: dp -logical, intent(in) :: stat -integer :: i - if (dp%resolve) then - dp%passed = stat - end if - dp%kinematics(:)%passed = stat -end subroutine dipole_real_qed_kinematics_passed - -subroutine dipole_real_qed_set_cut_status (dp, stat, index) -type(dipole_real_qed_t), intent(inout) :: dp -logical, intent(in) :: stat -integer, intent(in), optional :: index -integer :: i - i = 1; if (present (index)) i = index - if (dp%resolve) then - dp%passed = stat - end if - dp%kinematics(i)%passed = stat -end subroutine dipole_real_qed_set_cut_status - -function dipole_real_qed_get_cut_status (dp, index) result (stat) -type(dipole_real_qed_t), intent(in) :: dp -integer, intent(in), optional :: index -logical :: stat -integer :: i - i = 1; if (present (index)) i = index - if (dp%resolve) then - stat = dp%passed - else - stat = dp%kinematics(i)%passed - end if -end function dipole_real_qed_get_cut_status - -function dipole_real_qed_any_passed (dp) result (stat) -type(dipole_real_qed_t), intent(in) :: dp -logical :: stat - if (dp%resolve) then - stat = dp%passed - else - stat = any (dp%kinematics(:)%passed) - end if -end function dipole_real_qed_any_passed - -@ %def dipole_real_qed_kinematics_passed -@ %def dipole_real_qed_set_cut_status -@ %def dipole_real_qed_get_cut_status -@ %def dipole_real_qed_any_passed -@ -Calculate the dipole kinematics. -<>= -public :: dipole_real_qed_digest_kinematics_out -public :: dipole_real_qed_digest_kinematics_in -<>= -subroutine dipole_real_qed_digest_kinematics_in (dp) -type(dipole_real_qed_t), intent(inout) :: dp - if (dp%resolve) then - dp%momenta(:2) = interaction_get_momenta (dp%int_resolved, & - outgoing = .false.) - else - dp%momenta(:2) = interaction_get_momenta (evaluator_get_int_ptr ( & - dp%kinematics(1)%eval_square), outgoing = .false.) - end if -end subroutine dipole_real_qed_digest_kinematics_in - -subroutine dipole_real_qed_digest_kinematics_out (dp) -type(dipole_real_qed_t), intent(inout) :: dp -integer :: i, j, a, b, m, em, sp -type(vector4_t) :: k, pab, pabprime, psum -type(interaction_t), pointer :: int -real(default) :: pab2 - m = dp%n_eff + 1 - do i = 1, size (dp%active_particles) - a = dp%active_particles(i) - dp%inv(a, m) = dp%momenta(a) * dp%momenta(m) - dp%inv(m, a) = dp%inv(a, m) - do j = i + 1, size (dp%active_particles) - b = dp%active_particles(j) - dp%inv(a, b) = dp%momenta(a) * dp%momenta(b) - dp%inv(b, a) = dp%inv(a, b) - end do - end do - do i = 1, size (dp%active_particles) - do j = 1, size (dp%active_particles) - if (i == j) cycle - a = dp%active_particles(i) - b = dp%active_particles(j) - if (a > 2 .and. b > 2) & - dp%yij(a, b) = dp%inv(a, m) / (dp%inv(a, b) + & - dp%inv(a, m) + dp%inv(b, m)) - if (a > 2 .and. b < 3) & - dp%xia(a, b) = (dp%inv(b, a) + dp%inv(b, m) - dp%inv(a, m)) / & - (dp%inv(b, a) + dp%inv (b, m)) - if (a < 3 .and. b < 3) & - dp%xab(a, b) = (dp%inv(a, b) - dp%inv(a, m) - dp%inv(b, m)) / & - dp%inv(a, b) - end do - end do - k = dp%momenta(m) - do i = 1, size (dp%kinematics) - em = dp%kinematics(i)%component%em - sp = dp%kinematics(i)%component%sp - select case (dp%kinematics(i)%component%type) - case (DIPOLE_FF) - dp%kinematics(i)%momenta = dp%momenta(:dp%n_eff) - dp%kinematics(i)%momenta(sp) = & - dp%momenta(sp) / (one - dp%yij(em, sp)) - dp%kinematics(i)%momenta(em) = dp%momenta(em) + k - dp%yij(em, sp) * & - dp%kinematics(i)%momenta(sp) - case (DIPOLE_IF) - dp%kinematics(i)%momenta = dp%momenta(:dp%n_eff) - dp%kinematics(i)%momenta(em) = dp%xia(sp, em) * dp%momenta(em) - dp%kinematics(i)%momenta(sp) = & - dp%momenta(sp) + k - (one - dp%xia(sp, em)) * & - dp%momenta(em) - case (DIPOLE_FI) - dp%kinematics(i)%momenta = dp%momenta(:dp%n_eff) - dp%kinematics(i)%momenta(em) = & - dp%momenta(em) + k - (one - dp%xia(em, sp)) * & - dp%momenta(sp) - dp%kinematics(i)%momenta(sp) = dp%xia(em, sp) * dp%momenta(sp) - case (DIPOLE_II) - dp%kinematics(i)%momenta(em) = dp%xab(em, sp) * dp%momenta(em) - dp%kinematics(i)%momenta(sp) = dp%momenta(sp) - pab = dp%momenta(em) + dp%momenta(sp) - k - pabprime = dp%kinematics(i)%momenta(em) + dp%momenta(sp) - pab2 = pab * pab - psum = pab + pabprime - forall (j = 3:dp%n_eff) dp%kinematics(i)%momenta(j) = dp%momenta(j) - & - psum * (psum * dp%momenta(j)) / (pab2 + pab * pabprime) + & - pabprime * (pab * dp%momenta(j)) * two / pab2 - end select - int => evaluator_get_int_ptr (dp%kinematics(i)%eval_square) - call interaction_set_momenta (int, dp%kinematics(i)%momenta) - end do - if (dp%resolve) call interaction_set_momenta ( & - dp%int_resolved, dp%momenta) -end subroutine dipole_real_qed_digest_kinematics_out - -@ %def dipole_real_qed_digest_kinematics_out -@ %def dipole_real_qed_digest_kinematics_in -@ -Complete the dipole evaluation and set the matrix elements. -<>= -public :: dipole_real_qed_evaluate -<>= -subroutine dipole_real_qed_evaluate (dp) -type(dipole_real_qed_t), intent(inout) :: dp -integer :: i, j, a, b, m, em, sp -real(default), dimension(3:dp%n_eff+1, 3:dp%n_eff+1) :: zij -real(default), dimension(3:dp%n_eff+1, 2) :: zia -type(vector4_t) :: k -type(interaction_t), pointer :: hi_int, int_square -complex(default), dimension(:), allocatable :: me -real(default) :: pref -integer :: n_me - -real(default) :: sqme - - pref = dp%alpha * four * pi - if (dp%resolve) then - n_me = interaction_get_n_matrix_elements (dp%int_resolved) - allocate (me(n_me)) - me = 0 - if (.not. dp%passed) then - call interaction_set_matrix_element (dp%int_resolved, me) - call evaluator_evaluate (dp%trace_resolved) - return - end if - end if - m = dp%n_eff + 1 - do i = 1, size (dp%active_particles) - do j = 1, size (dp%active_particles) - if (i == j) cycle - a = dp%active_particles(i) - b = dp%active_particles(j) - if (a > 2 .and. b > 2) & - zij(a, b) = dp%inv(a, b) / (dp%inv(a, b) + dp%inv(b, m)) - if (a > 2 .and. b < 3) & - zia(a, b) = dp%inv(b, a) / (dp%inv(b, a) + dp%inv (b, m)) - end do - end do - k = dp%momenta(m) - hi_int => hard_interaction_get_int_ptr (dp%hi) - do i = 1, size (dp%kinematics) - em = dp%kinematics(i)%component%em - sp = dp%kinematics(i)%component%sp - if (dp%kinematics(i)%passed) then - select case (dp%kinematics(i)%component%type) - case (DIPOLE_FF) - dp%kinematics(i)%component_value = & - ( two / (one - zij(em, sp) * (one - dp%yij(em, sp))) & - - one - zij(em, sp)) / dp%inv(em, m) / (one - dp%yij(em, sp)) - case (DIPOLE_IF) - dp%kinematics(i)%component_value = & - - ( two / (two - dp%xia(sp, em) - zia(sp, em)) & - - one - dp%xia(sp, em) ) / dp%inv(em, m) / dp%xia(sp, em) - case (DIPOLE_FI) - dp%kinematics(i)%component_value = & - - ( two / (two - dp%xia(em, sp) - zia(em, sp)) & - - one - zia(em, sp) ) / dp%inv(em, m) / dp%xia(em, sp) - case (DIPOLE_II) - dp%kinematics(i)%component_value = & - (two / (one - dp%xab(em, sp)) - one - dp%xab(em, sp) & - ) / dp%inv(em, m) / dp%xab(em, sp) - end select - else - dp%kinematics(i)%component_value = 0 - end if - dp%kinematics(i)%me_factors = dp%kinematics(i)%component_value * & - dp%kinematics(i)%charge_factors * pref - int_square => evaluator_get_int_ptr (dp%kinematics(i)%eval_square) - if (dp%alphas_updated) call hard_interaction_update_alpha_s ( & - dp%hi, dp%kinematics(i)%alphas) - call interaction_set_momenta (hi_int, dp%kinematics(i)%momenta) - call hard_interaction_evaluate (dp%hi) - call evaluator_evaluate (dp%kinematics(i)%eval_square) - sqme = evaluator_sum (dp%kinematics(i)%eval_square) - do j = 1, interaction_get_n_matrix_elements (int_square) - call interaction_set_matrix_element (int_square, j, & - interaction_get_matrix_element (int_square, j) * & - dp%kinematics(i)%me_factors( & - dp%kinematics(i)%me_factor_map(j)) & - ) - end do - if (.not. dp%resolve) then - call evaluator_receive_momenta (dp%kinematics(i)%eval_trace) - call evaluator_evaluate (dp%kinematics(i)%eval_trace) - end if - if (dp%have_sqme .and. .not. dp%resolve) then - call evaluator_receive_momenta (dp%kinematics(i)%eval_sqme) - call evaluator_evaluate (dp%kinematics(i)%eval_sqme) - end if - end do - if (dp%resolve) then - do i = 1, size (dp%kinematics) - int_square => evaluator_get_int_ptr (dp%kinematics(i)%eval_square) - do j = 1, n_me - me(j) = me(j) + interaction_get_matrix_element ( & - int_square, j) - end do - end do - call interaction_set_matrix_element (dp%int_resolved, me) - call evaluator_receive_momenta (dp%trace_resolved) - call evaluator_evaluate (dp%trace_resolved) - if (dp%have_sqme) then - call evaluator_receive_momenta (dp%sqme_resolved) - call evaluator_receive_momenta (dp%sqme_resolved) - end if - end if -! call debug_hook - -contains - - subroutine debug_hook - logical, save :: first = .true., active = .true. - integer, save :: u, cnt = 1 - integer :: err, i - type(quantum_numbers_mask_t), dimension(2) :: qn - if (first) then - first = .false. - u = free_unit () - call quantum_numbers_mask_init (qn, .true., .true., .true.) - call hard_interaction_init_trace (dp%hi, qn) - open (u, file="dipole_real_debug.out", status="replace", & - action="write", iostat=err) - if (err /= 0) then - active = .false. - return - end if - end if - write (u, '(A)') "! phase space point " // int2char (cnt) - do i = 1, 7 - call write_momentum (dp%momenta(i), u) - end do - write (u, '(A)') "! dipole value: " // real2char ( & - real (evaluator_sum (dp%trace_resolved), default) * three) - if (size (dp%kinematics) == 1) then - write (u, '(A)') "! matrix element: " // real2char (sqme * three) - write (u, '(A)') "! matrix element (reference) : " // real2char ( & - hard_interaction_compute_sqme_sum ( & - dp%hi, dp%kinematics(1)%momenta) * three) - write (u, '(A)') "! twisted momenta:" - do i = 1, 6 - call write_momentum (dp%kinematics(1)%momenta(i), u, "! ") - end do - end if - write (u, '(A)') - cnt = cnt + 1 - if (cnt > 10) then - close (u) - active = .false. - end if - end subroutine debug_hook - - subroutine write_momentum (p, u, prefix) - type(vector4_t), intent(in) :: p - integer, intent(in) :: u - character, intent(in), optional :: prefix - integer :: i - if (present (prefix)) write (u, '(A)', advance="no") prefix - do i = 0, 3 - write (u, '(E20.12,2X)', advance="no") vector4_get_component (p, i) - end do - write (u, '(A)') - end subroutine write_momentum - -end subroutine dipole_real_qed_evaluate - -@ %def dipole_real_qed_evaluate -@ -Output -<>= -public :: dipole_real_qed_write -<>= -subroutine dipole_real_qed_write (dp, unit, verbose) -type(dipole_real_qed_t), intent(in) :: dp -integer, intent(in), optional :: unit -logical, intent(in), optional :: verbose -character(*), parameter :: del = repeat ("-", 80) -logical :: v -integer :: u, i - u = output_unit (unit) - v = .false.; if (present (verbose)) v = verbose - write (u, '(A)') "massless unintegrated QED dipole" - write (u, '(3X,A,L1)') "resolve = ", dp%resolve - write (u, '(3X,A,L1)') "photon_splittings = ", dp%resolve - write (u, '(3X,A,I2)') "n_tot = ", dp%n_tot - write (u, '(3X,A,I2)') "n_eff = ", dp%n_eff - write (u, '(3X,A,E12.5)') "alpha = ", dp%alpha - write (u, '(3X,A,E12.5)') "mreg = ", dp%mreg - write (u, '(3X,A)') "flavor_states_tot = " - do i = 1, size (dp%flavor_states_tot, 2) - call write_int_list (flavor_get_pdg (dp%flavor_states_tot(:, i))) - end do - write (u, '(3X,A)') "flavor_states_eff = " - do i = 1, size (dp%flavor_states_eff, 2) - call write_int_list (flavor_get_pdg (dp%flavor_states_eff(:, i))) - end do - write (u, '(3X,A)') "masses = " - call write_real_list (dp%masses) - write (u, '(3X,A)') "active_particles = " - call write_int_list (dp%active_particles) - write (u, '(3X,A)') "dipoles = " - write (u, '(6X)', advance="no") - do i = 1, size (dp%dipoles) - write (u, '(A,2X)', advance="no") char (dipole (dp%dipoles(i))) - end do - write (u, '(A)') - if (v) then - if (dp%resolve) write (u, '(3X,L1)') "passed = ", dp%passed - call section ("Hard interaction:") - call hard_interaction_write (dp%hi) - if (dp%resolve) then - call section ("Interaction:") - call interaction_write (dp%int_resolved) - call section ("Evaluator:") - call evaluator_write (dp%trace_resolved) - write (u, '(A)') del - write (u, '(A)') - end if - end if - do i = 1, size (dp%kinematics) - write (u, '(3X,A,I3,A)') "kinematics(", i, ") = " - call write_kinematic_config (dp%kinematics(i)) - end do - -contains - - subroutine section (n) - character(*), intent(in) :: n - write (u, '(A)') - write (u, '(A)') n - write (u, '(A)') del - end subroutine section - - subroutine write_real_list (x, indent) - real(default), dimension(:), intent(in) :: x - integer, intent(in), optional :: indent - integer :: i, ind - ind = 6; if (present (indent)) ind = indent - write (u, '(A)', advance="no") repeat (" ", ind) - do i = 1, size (x) - write (u, '(E12.5,2X)', advance="no") x(i) - end do - write (u, '(A)') - end subroutine write_real_list - - subroutine write_int_list (j, indent) - integer, intent(in), dimension(:) :: j - integer, intent(in), optional :: indent - integer :: i, ind - ind = 6; if (present (indent)) ind = indent - write (u, '(A)', advance="no") repeat (" ", ind) - do i = 1, size (j) - write (u, '(A,2X)', advance="no") int2char (j(i)) - end do - write (u, '(A)') - end subroutine write_int_list - - function dipole (dp) result (str) - type(dipole_single_t) :: dp - type(string_t) :: str - str = int2string (dp%em) // ":" // int2string (dp%sp) - end function dipole - - subroutine write_kinematic_config (k) - type(kinematic_configuration_t), intent(in) :: k - write (u, '(6X,A)') "component = " // char (dipole (k%component)) - write (u, '(6X,A)') "charge factors = " - call write_real_list (k%charge_factors, 9) - write (u, '(6X,A)') "me_factor_map = " - call write_int_list (k%me_factor_map, 9) - if (v) then - write (u, '(6X,A,L1)') "passed = ", k%passed - write (u, '(6X,A,E12.5)') "component_value = ", k%component_value - write (u, '(6X,A)') "me_factors = " - call write_real_list (k%me_factors) - call section ("Evaluator (square):") - call evaluator_write (k%eval_square) - call section ("Evaluator (trace):") - call evaluator_write (k%eval_trace) - write (u, '(A)') del - write (u, '(A)') - end if - end subroutine write_kinematic_config - -end subroutine dipole_real_qed_write - -@ %def dipole_real_qed_write -@ -Particle number queries: -<>= -public :: dipole_real_qed_get_n_in -public :: dipole_real_qed_get_n_out_eff -public :: dipole_real_qed_get_n_out_real -public :: dipole_real_qed_get_n_tot_eff -public :: dipole_real_qed_get_n_tot_real -public :: dipole_real_qed_get_n_flv -<>= -function dipole_real_qed_get_n_in (dp) result (n) -type(dipole_real_qed_t), intent(in) :: dp -integer :: n - n = 2 -end function dipole_real_qed_get_n_in - -function dipole_real_qed_get_n_out_eff (dp) result (n) -type(dipole_real_qed_t), intent(in) :: dp -integer :: n - n = dp%n_tot - 2 -end function dipole_real_qed_get_n_out_eff - -function dipole_real_qed_get_n_out_real (dp) result (n) -type(dipole_real_qed_t), intent(in) :: dp -integer :: n - n = dp%n_eff - 1 -end function dipole_real_qed_get_n_out_real - -function dipole_real_qed_get_n_tot_eff (dp) result (n) -type(dipole_real_qed_t), intent(in) :: dp -integer :: n - n = dp%n_tot -end function dipole_real_qed_get_n_tot_eff - -function dipole_real_qed_get_n_tot_real (dp) result (n) -type(dipole_real_qed_t), intent(in) :: dp -integer :: n - n = dp%n_eff + 1 -end function dipole_real_qed_get_n_tot_real - -function dipole_real_qed_get_n_flv (dp) result (n) -type(dipole_real_qed_t), intent(in) :: dp -integer :: n - n = size (dp%flavor_states_eff, 2) -end function dipole_real_qed_get_n_flv - -@ %def dipole_real_qed_get_n_in -@ %def dipole_real_qed_get_n_out_eff -@ %def dipole_real_qed_get_n_out_real -@ %def dipole_real_qed_get_n_tot_eff -@ %def dipole_real_qed_get_n_tot_real -@ %def dipole_real_qed_get_n_flv -@ -Flavor states. -<>= -public :: dipole_real_qed_get_flv_states_eff -public :: dipole_real_qed_get_flv_states_real -public :: dipole_real_qed_get_first_pdg_in -public :: dipole_real_qed_get_first_pdg_out_eff -public :: dipole_real_qed_get_first_pdg_out_real -<>= -function dipole_real_qed_get_flv_states_eff (dp) result (flv) -type(dipole_real_qed_t), intent(in) :: dp -integer, dimension(:,:), allocatable :: flv -integer :: i - allocate (flv (size (dp%flavor_states_tot, 1), size (dp%flavor_states_tot, 2))) - forall (i = 1:size (flv, 2)) & - flv(:, i) = flavor_get_pdg (dp%flavor_states_tot(:, i)) -end function dipole_real_qed_get_flv_states_eff - -function dipole_real_qed_get_flv_states_real (dp) result (flv) -type(dipole_real_qed_t), intent(in) :: dp -integer, dimension(:,:), allocatable :: flv -integer :: i - allocate (flv (size (dp%flavor_states_eff, 1) + 1, size (dp%flavor_states_eff, 2))) - forall (i = 1:size (flv, 2)) & - flv(:dp%n_eff, i) = flavor_get_pdg (dp%flavor_states_eff(:, i)) - flv(dp%n_eff + 1, :) = 22 -end function dipole_real_qed_get_flv_states_real - -function dipole_real_qed_get_first_pdg_in (dp) result (pdg) -type(dipole_real_qed_t), intent(in) :: dp -integer, dimension(2) :: pdg - pdg = flavor_get_pdg (dp%flavor_states_eff(:2, 1)) -end function dipole_real_qed_get_first_pdg_in - -function dipole_real_qed_get_first_pdg_out_eff (dp) result (pdg) -type(dipole_real_qed_t), intent(in) :: dp -integer, dimension(dp%n_tot-2) :: pdg - pdg = flavor_get_pdg (dp%flavor_states_tot(3:, 1)) -end function dipole_real_qed_get_first_pdg_out_eff - -function dipole_real_qed_get_first_pdg_out_real (dp) result (pdg) -type(dipole_real_qed_t), intent(in) :: dp -integer, dimension(dp%n_eff-1) :: pdg - pdg(:dp%n_eff-2) = flavor_get_pdg (dp%flavor_states_eff(3:, 1)) - pdg(dp%n_eff-1) = 22 -end function dipole_real_qed_get_first_pdg_out_real - -@ %def dipole_real_qed_get_flv_states_eff -@ %def dipole_real_qed_get_flv_states_real -@ %def dipole_real_qed_get_first_pdg_in -@ %def dipole_real_qed_get_first_pdg_out_eff -@ %def dipole_real_qed_get_first_pdg_out_real -@ -Complete the core interaction interface with wrappers around the contained hard -interaction object. -<>= -public :: dipole_real_qed_unload -public :: dipole_real_qed_reload -public :: dipole_real_qed_update_parameters -public :: dipole_real_qed_get_model_ptr -public :: dipole_real_qed_get_unstable_products -public :: dipole_real_qed_reset_helicity_selection -public :: dipole_real_qed_update_alpha_s -public :: dipole_real_qed_get_int_ptr -public :: dipole_real_qed_get_eval_trace_ptr -public :: dipole_real_qed_get_eval_sqme_ptr -public :: dipole_real_qed_write_state_summary -public :: dipole_real_qed_is_valid -public :: dipole_real_qed_get_id -<>= -subroutine dipole_real_qed_unload (dp) -type(dipole_real_qed_t), intent(inout) :: dp - call hard_interaction_unload (dp%hi) -end subroutine dipole_real_qed_unload - -subroutine dipole_real_qed_reload (dp, prc_lib) -type(dipole_real_qed_t), intent(inout) :: dp -type(process_library_t), intent(in) :: prc_lib - call hard_interaction_reload (dp%hi, prc_lib) -end subroutine dipole_real_qed_reload - -subroutine dipole_real_qed_update_parameters (dp) -type(dipole_real_qed_t), intent(inout) :: dp - call hard_interaction_update_parameters (dp%hi) -end subroutine dipole_real_qed_update_parameters - -function dipole_real_qed_get_model_ptr (dp) result (model) -type(dipole_real_qed_t), intent(in) :: dp -type(model_t), pointer :: model - model => hard_interaction_get_model_ptr (dp%hi) -end function dipole_real_qed_get_model_ptr - -subroutine dipole_real_qed_get_unstable_products (dp, flavors) -type(dipole_real_qed_t), intent(in) :: dp -type(flavor_t), dimension(:), allocatable :: flavors - call hard_interaction_get_unstable_products (dp%hi, flavors) -end subroutine dipole_real_qed_get_unstable_products - -subroutine dipole_real_qed_reset_helicity_selection & - (dp, threshold, cutoff) -type(dipole_real_qed_t), intent(inout) :: dp -real(default), intent(in) :: threshold -integer, intent(in) :: cutoff - call hard_interaction_reset_helicity_selection (dp%hi, threshold, cutoff) -end subroutine dipole_real_qed_reset_helicity_selection - -subroutine dipole_real_qed_update_alpha_s (dp, alphas, index) -type(dipole_real_qed_t), intent(inout) :: dp -real(default), intent(in) :: alphas -integer, intent(in), optional :: index -integer :: i - i = 1; if (present (index)) i = index - dp%kinematics(i)%alphas = alphas - dp%alphas_updated = .true. -end subroutine dipole_real_qed_update_alpha_s - -function dipole_real_qed_get_int_ptr (dp, index) result (int) -type(dipole_real_qed_t), intent(in), target :: dp -integer, intent(in), optional :: index -integer :: i -type(interaction_t), pointer :: int - i = 1; if (present (index)) i = index - if (dp%resolve) then - int => dp%int_resolved - else - int => evaluator_get_int_ptr (dp%kinematics(i)%eval_square) - end if -end function dipole_real_qed_get_int_ptr - -function dipole_real_qed_get_eval_trace_ptr (dp, index) result (eval) -type(dipole_real_qed_t), intent(in), target :: dp -integer, intent(in), optional :: index -type(evaluator_t), pointer :: eval -integer :: i - i = 1; if (present (index)) i = index - if (dp%resolve) then - eval => dp%trace_resolved - else - eval => dp%kinematics(i)%eval_trace - end if -end function dipole_real_qed_get_eval_trace_ptr - -function dipole_real_qed_get_eval_sqme_ptr (dp, index) result (eval) -type(dipole_real_qed_t), intent(in), target :: dp -integer, intent(in), optional :: index -type(evaluator_t), pointer :: eval -integer :: i - i = 1; if (present (index)) i = index - if (dp%resolve) then - eval => dp%sqme_resolved - else - eval => dp%kinematics(i)%eval_sqme - end if -end function dipole_real_qed_get_eval_sqme_ptr - -subroutine dipole_real_qed_write_state_summary (dp, unit) -type(dipole_real_qed_t), intent(in) :: dp -integer, intent(in), optional :: unit - call hard_interaction_write_state_summary (dp%hi, unit) -end subroutine dipole_real_qed_write_state_summary - -function dipole_real_qed_is_valid (dp) result (flag) -type(dipole_real_qed_t), intent(in) :: dp -logical :: flag - flag = hard_interaction_is_valid (dp%hi) -end function dipole_real_qed_is_valid - -function dipole_real_qed_get_id (dp) result (id) -type(dipole_real_qed_t), intent(in) :: dp -type(string_t) :: id - id = hard_interaction_get_id (dp%hi) -end function dipole_real_qed_get_id - -@ %def dipole_real_qed_unload -@ %def dipole_real_qed_reload -@ %def dipole_real_qed_update_parameters -@ %def dipole_real_qed_get_model_ptr -@ %def dipole_real_qed_get_unstable_products -@ %def dipole_real_qed_reset_helicity_selection -@ %def dipole_real_qed_update_alpha_s -@ %def dipole_real_qed_get_int_ptr -@ %def dipole_real_qed_get_eval_trace_ptr -@ %def dipole_real_qed_get_eval_sqme_ptr -@ %def dipole_real_qed_write_state_summary -@ %def dipole_real_qed_is_valid -@ %def dipole_real_qed_get_id -@ - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Recombinators} - -Recombinators are core interactions which map a hard interaction with an extra -soft or collinear emission to a interaction where the emission is recombined -with the emitter. We currently only implement this for an extra photon emission, -QCD and photon splitting are more complicated. Also, the recombination criterion -is currently hardcoded, but a flexible solution invoking WHIZARD's %' -powerful expressions is desirable as the final solution. - -In order to simplify the integration over the phasespace in which no -recombination happens, the recombinators support a ``complement'' mode of -operation. In the mode, the contained hard interaction is wrapped directly, and -the only modification is an enforced cut on the complement of the recombination -criterion. - -\subsection{Photon recombination} - -<<[[photon_recombination.f90]]>>= -<> - -module photon_recombination - -<> -<> - use constants !NODEP! -<> - use diagnostics !NODEP! - use sm_physics !NODEP! - use md5 - use lorentz !NODEP! - use models - use flavors - use quantum_numbers - use interactions - use evaluators - use particles - use hard_interactions - use quantum_numbers - use nlo_setup - use process_libraries - -<> - -<> - -<> - -<> - -<> - -<> - -contains - -<> - -end module photon_recombination -@ %def photon_recombination -@ -The [[photon_recombination_t]] type. -<>= -public :: photon_recombination_t -<>= -type :: photon_recombination_t - private - integer :: recombination_method = NLO_RECOMBINATION_RACOON - type(hard_interaction_t) :: hi - type(evaluator_t) :: eval_square, eval_rec - type(evaluator_t) :: eval_trace, eval_sqme - integer :: iphoton - integer :: n_tot, n_flv - integer, dimension(:,:), allocatable :: flv_states_orig, flv_states - integer, dimension(:), allocatable :: first_pdg_orig, first_pdg - integer, dimension(:), allocatable :: index_map - logical, dimension(:), allocatable :: charged - logical :: valid = .false. - real(kind=default) :: mrecomb, photon_beam_separation - type(vector4_t), dimension(:), allocatable :: p_orig, p_rec - logical :: passed - real(kind=default) :: weight - logical :: complement = .false. -end type photon_recombination_t - -@ %def photon_recombination_t -@ -Initialization. -<>= -public :: photon_recombination_init -<>= -subroutine photon_recombination_init (pr, prc_lib, process_index, process_id, & - model, nlo_setup) -type(photon_recombination_t), intent(out) :: pr -type(process_library_t), intent(in) :: prc_lib -integer, intent(in) :: process_index -type(string_t), intent(in) :: process_id -type(model_t), intent(in), target :: model -type(nlo_setup_t), intent(in), optional :: nlo_setup -integer :: i, j -type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask -type(nlo_setup_t) :: setup -logical, dimension(:), allocatable :: drop - call hard_interaction_init (pr%hi, prc_lib, process_index, process_id, model) - pr%valid = hard_interaction_is_valid (pr%hi) - if (.not. pr%valid) then - call cleanup - return - end if - if (hard_interaction_get_n_in (pr%hi) /= 2) then - call cleanup - return - end if - pr%n_tot = hard_interaction_get_n_tot (pr%hi) - 1 - pr%n_flv = hard_interaction_get_n_flv (pr%hi) - allocate (pr%flv_states_orig(pr%n_tot + 1, pr%n_flv)) - pr%flv_states_orig = hard_interaction_get_flv_states (pr%hi) - ! Identify photon - pr%iphoton = find_index (pr%flv_states_orig(:,1), 22) - if (pr%iphoton < 3) then - call cleanup - return - end if - ! Build index map - allocate (pr%index_map(pr%n_tot)) - i = 1 - do j = 1, pr%n_tot + 1 - if (pr%flv_states_orig(j, 1) == 22) cycle - pr%index_map(i) = j - i = i + 1 - end do - ! Check for consinstency and build reduced state list - allocate (pr%flv_states(pr%n_tot, pr%n_flv)) - do i = 1, pr%n_flv - if (count (pr%flv_states_orig(:, i) == 22) /= 1 .or. & - pr%flv_states_orig(pr%iphoton, i) /= 22) then - call cleanup - return - end if - pr%flv_states(:, i) = pr%flv_states_orig(pr%index_map, i) - end do - ! Identify charged final states and check for consistency - allocate (pr%charged (pr%n_tot + 1)) - pr%charged = is_charged (pr%flv_states_orig(:,1)) - do i = 2, pr%n_flv - if (.not. all (pr%charged(3:) .eqv. & - is_charged (pr%flv_states_orig(3:,i)))) then - call cleanup - call msg_warning (& - "mixed neutral-charged flavor products in the final state") - call msg_warning ("are not supported by photon recombination yet") - return - end if - end do - ! Effective and original 1st outgoing PDGs - allocate (pr%first_pdg_orig (pr%n_tot - 1), & - pr%first_pdg(pr%n_tot - 2)) - pr%first_pdg_orig = hard_interaction_get_first_pdg_out (pr%hi) - pr%first_pdg = pr%first_pdg_orig (pr%index_map(3:) - 2) - allocate (qn_mask(pr%n_tot + 1)) - ! Allocate momenta - allocate (pr%p_orig(pr%n_tot + 1), pr%p_rec(pr%n_tot)) - ! Setup the recombination method - if (present (nlo_setup)) then - setup = nlo_setup - else - setup = process_library_get_nlo_setup (prc_lib, process_id) - end if - pr%recombination_method = NLO_RECOMBINATION_RACOON - pr%mrecomb = 1 - pr%photon_beam_separation = 5._default * degree - if (setup%recombination > 0) & - pr%recombination_method = setup%recombination - if (setup%mrecomb > 0) pr%mrecomb = setup%mrecomb - if (setup%photon_beam_separation > 0) & - pr%photon_beam_separation = setup%photon_beam_separation - if (setup%recombination_complement_set) & - pr%complement = setup%recombination_complement - ! Complement mode? - if (.not. pr%complement) then - ! Init the square evaluator - call quantum_numbers_mask_init (qn_mask, .false., .true., .false.) - call evaluator_init_square (pr%eval_square, & - hard_interaction_get_int_ptr (pr%hi), qn_mask) - ! Init the recombination evaluator which drops the photon - allocate (drop(pr%n_tot + 1)) - drop = .false. - drop(pr%iphoton) = .true. - call evaluator_init_qn_sum (pr%eval_rec, pr%eval_square, qn_mask, drop) - end if - -contains - - function find_index (i, j) result (k) - integer, intent(in), dimension(:) :: i - integer, intent(in) :: j - integer :: k - do k = 1, size (i) - if (i(k) == j) return - end do - k = -1 - end function find_index - - subroutine cleanup - call msg_warning ("process " // char (process_id) // & - " not suitable for photon recombination") - if (allocated (pr%flv_states_orig)) deallocate (pr%flv_states_orig) - if (allocated (pr%flv_states)) deallocate (pr%flv_states) - if (allocated (pr%p_orig)) deallocate (pr%p_orig) - if (allocated (pr%p_rec)) deallocate (pr%p_rec) - if (allocated (pr%charged)) deallocate (pr%charged) - if (allocated (pr%first_pdg_orig)) deallocate (pr%first_pdg_orig) - if (allocated (pr%first_pdg)) deallocate (pr%first_pdg) - if (allocated (pr%index_map)) deallocate (pr%index_map) - pr%valid = .false. - end subroutine cleanup - - function is_charged (flv) result (chrg) - integer, dimension(:) :: flv - logical, dimension(size (flv)) :: chrg - integer :: i - do i = 1, size (flv) - chrg(i) = abs (particle_data_get_charge (model_get_particle_ptr ( & - model, flv(i)))) > 0 - end do - end function is_charged - -end subroutine photon_recombination_init - -@ %def photon_recombination_init -Finalization -<>= -public :: photon_recombination_final -<>= -subroutine photon_recombination_final (pr) -type(photon_recombination_t), intent(inout) :: pr - call hard_interaction_final (pr%hi) - if (.not. pr%valid) return - call evaluator_final (pr%eval_square) - call evaluator_final (pr%eval_rec) - call evaluator_final (pr%eval_trace) - call evaluator_final (pr%eval_sqme) - if (allocated (pr%flv_states_orig)) deallocate (pr%flv_states_orig) - if (allocated (pr%flv_states)) deallocate (pr%flv_states) - if (allocated (pr%p_orig)) deallocate (pr%p_orig) - if (allocated (pr%p_rec)) deallocate (pr%p_rec) - if (allocated (pr%charged)) deallocate (pr%charged) - if (allocated (pr%first_pdg_orig)) deallocate (pr%first_pdg_orig) - if (allocated (pr%first_pdg)) deallocate (pr%first_pdg) - if (allocated (pr%index_map)) deallocate (pr%index_map) - pr%valid = .false. -end subroutine photon_recombination_final - -@ %def photon_recombination_final -@ -Init the trace evaluator. -<>= -public :: photon_recombination_init_trace -<>= -subroutine photon_recombination_init_trace (pr, qn_mask_in) -type(photon_recombination_t), intent(inout) :: pr -type(quantum_numbers_mask_t), dimension(2), intent(in) :: qn_mask_in -type(quantum_numbers_mask_t), dimension(pr%n_tot) :: qn_mask - if (pr%complement) then - call hard_interaction_init_trace (pr%hi, qn_mask_in) - else - qn_mask(:2) = qn_mask_in - call quantum_numbers_mask_init (qn_mask(3:), .true., .true., .true.) - call evaluator_init_qn_sum (pr%eval_trace, pr%eval_rec, qn_mask) - end if -end subroutine photon_recombination_init_trace - -@ %def photon_recombination_init_trace -@ -Init the sqme evaluator. -<>= -public :: photon_recombination_init_sqme -<>= -subroutine photon_recombination_init_sqme (pr, qn_mask_in) -type(photon_recombination_t), intent(inout) :: pr -type(quantum_numbers_mask_t), dimension(2), intent(in) :: qn_mask_in -type(quantum_numbers_mask_t), dimension(pr%n_tot) :: qn_mask - if (pr%complement) then - call hard_interaction_init_sqme (pr%hi, qn_mask_in) - else - qn_mask(:2) = qn_mask_in - call quantum_numbers_mask_init (qn_mask(3:), .false., .true., .true.) - call evaluator_init_qn_sum (pr%eval_sqme, pr%eval_rec, qn_mask) - end if -end subroutine photon_recombination_init_sqme - -@ %def photon_recombination_init_sqme -@ -Set the momenta and perform the recombination. -<>= -public :: photon_recombination_set_momenta -<>= -subroutine photon_recombination_set_momenta (pr, p) -type(photon_recombination_t), intent(inout) :: pr -type(vector4_t), dimension(:), intent(in) :: p -type(interaction_t), pointer :: int - if (pr%complement) then - int => hard_interaction_get_int_ptr (pr%hi) - else - int => evaluator_get_int_ptr (pr%eval_rec) - end if - pr%p_orig(:2) = interaction_get_momenta (int, (/1, 2/)) - pr%p_orig(3:) = p - pr%passed = .false. - pr%p_rec = pr%p_orig(pr%index_map) - select case (pr%recombination_method) - case (NLO_RECOMBINATION_RACOON) - call recombination_racoon - case (NLO_RECOMBINATION_IGNORE_PHOTON) - pr%passed = .true. - case (NLO_RECOMBINATION_BARBARA_WW) - call recombination_barbara_ww - case default - call msg_bug ("photon_recombination_set_momenta: invalid " // & - "photon recombination prescription") - end select - if (pr%complement) then - call interaction_set_momenta (int, pr%p_orig) - pr%passed = .not. pr%passed - else - call interaction_set_momenta (int, pr%p_rec) - end if - -contains - - subroutine recombination_racoon - real(kind=default) :: thetaph - integer :: i, j, imin - real(default) :: mmin, m - thetaph = polar_angle (pr%p_orig(pr%iphoton)) - if (thetaph < pr%photon_beam_separation) then - pr%passed = .true. - pr%p_rec(1) = pr%p_rec(1) - pr%p_orig(pr%iphoton) - elseif (thetaph > pi - pr%photon_beam_separation) then - pr%passed = .true. - pr%p_rec(2) = pr%p_rec(2) - pr%p_orig(pr%iphoton) - else - mmin = huge (1._default) - imin = -1 - do i = 3, pr%n_tot - if (.not. pr%charged (pr%index_map(i))) cycle - m = invariant_mass (pr%p_orig(pr%iphoton) + pr%p_rec(i)) - if (m < mmin) then - mmin = m - imin = i - end if - end do - if (mmin < pr%mrecomb .and. imin > 0) then - pr%passed = .true. - pr%p_rec(imin) = pr%p_rec(imin) + pr%p_orig(pr%iphoton) - end if - end if - end subroutine recombination_racoon - - subroutine recombination_barbara_ww - real(default), parameter :: drrec = 0.1_default, ymax = 5._default, & - ptmax = 1._default - real(default) :: y, drmin, dr - integer :: i, imin - y = rapidity (pr%p_orig(pr%iphoton)) - if (abs (y) > ymax) then - pr%passed = .true. - return - end if - imin = -1 - drmin = huge (1._default) - do i = 3, pr%n_tot - if (.not. pr%charged (pr%index_map (i))) cycle - dr = eta_phi_distance (pr%p_orig(pr%iphoton), pr%p_rec (i)) - if (dr < drmin) then - drmin = dr - imin = i - end if - end do - if (drmin < drrec .and. imin > 0) then - pr%passed = .true. - pr%p_rec(imin) = pr%p_rec(imin) + pr%p_orig(pr%iphoton) - return - end if - if (transverse_part (pr%p_orig(pr%iphoton)) < ptmax) then - pr%passed = .true. - end if - end subroutine recombination_barbara_ww - -end subroutine photon_recombination_set_momenta - -@ %def photon_recombination_set_momenta -@ -Evaluate. -<>= -public :: photon_recombination_evaluate -public :: photon_recombination_evaluate_sqme -<>= -subroutine photon_recombination_evaluate (pr) -type(photon_recombination_t), intent(inout) :: pr -type(interaction_t), pointer :: int - if (pr%complement) then - call hard_interaction_evaluate (pr%hi) - call evaluator_evaluate (pr%eval_trace) - else - int => hard_interaction_get_int_ptr (pr%hi) - call interaction_set_momenta (int, pr%p_orig) - call evaluator_receive_momenta (pr%eval_square) - call hard_interaction_evaluate (pr%hi) - call evaluator_evaluate (pr%eval_square) - call evaluator_evaluate (pr%eval_rec) - call evaluator_evaluate (pr%eval_trace) - end if -end subroutine photon_recombination_evaluate - -subroutine photon_recombination_evaluate_sqme (pr) -type(photon_recombination_t), intent(inout) :: pr - if (pr%complement) then - call hard_interaction_evaluate_sqme (pr%hi) - else - call evaluator_receive_momenta (pr%eval_sqme) - call evaluator_evaluate (pr%eval_sqme) - end if -end subroutine photon_recombination_evaluate_sqme - -@ %def photon_recombination_evaluate -@ %def photon_recombination_evaluate_sqme -@ -Output. -<>= -public :: photon_recombination_write -<>= -subroutine photon_recombination_write (pr, unit, & - verbose, show_momentum_sum, show_mass, write_comb) -type(photon_recombination_t), intent(in) :: pr -integer, intent(in), optional :: unit -logical, intent(in), optional :: verbose, show_momentum_sum, show_mass -logical, intent(in), optional :: write_comb -integer :: u - u = output_unit (unit) - write (u, '(A)') "QED photon recombination" - if (.not. pr%valid) then - write (u, '(A)') " invalid" - return - end if - select case (pr%recombination_method) - case (NLO_RECOMBINATION_RACOON) - write (u, '(A)') " recombination method: racoon (beam separation: " // & - trim (real2char (pr%photon_beam_separation)) // & - ", recmbination scale: " // trim (real2char (pr%mrecomb)) // ")" - case (NLO_RECOMBINATION_IGNORE_PHOTON) - write (u, '(A)') " recombination method: ignore photon" - case default - write (u, '(A)') " recombination method: invalid" - end select - if (pr%complement) write (u, '(A)') " complement mode" - write (u, '(A)') "hard interaction" - call hard_interaction_write & - (pr%hi, u, verbose, show_momentum_sum, show_mass, write_comb) - if (pr%complement) return - write (u, '(A)') "Square evaluator" - call evaluator_write & - (pr%eval_square, u, verbose, show_momentum_sum, show_mass, write_comb) - write (u, '(A)') "Recombination evaluator" - call evaluator_write & - (pr%eval_rec, u, verbose, show_momentum_sum, show_mass, write_comb) - write (u, '(A)') "Trace evaluator" - call evaluator_write & - (pr%eval_trace, u, verbose, show_momentum_sum, show_mass, write_comb) - write (u, '(A)') "Sqme evaluator" - call evaluator_write & - (pr%eval_sqme, u, verbose, show_momentum_sum, show_mass, write_comb) -end subroutine photon_recombination_write - -@ %def photon_recombination_write -@ -Assignment. -<>= -public :: assignment(=) -<>= -interface assignment(=) - module procedure photon_recombination_assign -end interface - -<>= -subroutine photon_recombination_assign (pr_out, pr_in) -type(photon_recombination_t), intent(inout) :: pr_out -type(photon_recombination_t), intent(in) :: pr_in - call photon_recombination_final (pr_out) - if (.not. pr_in%valid) return - pr_out%recombination_method = pr_in%recombination_method - pr_out%hi = pr_in%hi - pr_out%eval_square = pr_in%eval_square - call evaluator_replace_interaction (pr_out%eval_square, & - hard_interaction_get_int_ptr (pr_out%hi)) - pr_out%eval_rec = pr_in%eval_rec - call evaluator_replace_interaction (pr_out%eval_rec, & - evaluator_get_int_ptr (pr_out%eval_square)) - pr_out%eval_trace = pr_in%eval_trace - call evaluator_replace_interaction (pr_out%eval_trace, & - evaluator_get_int_ptr (pr_out%eval_rec)) - pr_out%eval_sqme = pr_in%eval_sqme - call evaluator_replace_interaction (pr_out%eval_sqme, & - evaluator_get_int_ptr (pr_out%eval_rec)) - pr_out%iphoton = pr_in%iphoton - pr_out%n_tot = pr_in%n_tot - pr_out%n_flv = pr_in%n_flv - allocate ( & - pr_out%flv_states_orig (pr_in%n_tot + 1, pr_in%n_flv), & - pr_out%flv_states (pr_in%n_tot, pr_in%n_flv), & - pr_out%first_pdg_orig(pr_in%n_tot - 1), & - pr_out%first_pdg(pr_in%n_tot - 2), & - pr_out%charged(pr_in%n_tot + 1), & - pr_out%p_orig(pr_in%n_tot + 1), & - pr_out%p_rec(pr_in%n_tot), & - pr_out%index_map(pr_in%n_tot) & - ) - pr_out%flv_states_orig = pr_in%flv_states_orig - pr_out%flv_states = pr_in%flv_states - pr_out%first_pdg_orig = pr_in%first_pdg_orig - pr_out%first_pdg = pr_in%first_pdg - pr_out%charged = pr_in%charged - pr_out%valid = pr_in%valid - pr_out%mrecomb = pr_in%mrecomb - pr_out%photon_beam_separation = pr_in%photon_beam_separation - pr_out%p_orig = pr_in%p_orig - pr_out%p_rec = pr_in%p_rec - pr_out%valid = pr_in%valid - pr_out%weight = pr_in%weight - pr_out%index_map = pr_in%index_map - pr_out%complement = pr_in%complement -end subroutine photon_recombination_assign - -@ %def photon_recombination_assign -@ -Misc glue to [[core_interaction]]. -<>= -public :: photon_recombination_unload -public :: photon_recombination_reload -public :: photon_recombination_update_parameters -public :: photon_recombination_is_valid -public :: photon_recombination_get_id -public :: photon_recombination_get_model_ptr -public :: photon_recombination_get_n_out_eff -public :: photon_recombination_get_n_tot_eff -public :: photon_recombination_get_n_out_real -public :: photon_recombination_get_n_tot_real -public :: photon_recombination_get_n_flv -public :: photon_recombination_get_flv_states_eff -public :: photon_recombination_get_flv_states_real -public :: photon_recombination_get_first_pdg_in -public :: photon_recombination_get_first_pdg_out_eff -public :: photon_recombination_get_first_pdg_out_real -public :: photon_recombination_get_unstable_products -public :: photon_recombination_final_sqme -public :: photon_recombination_update_alpha_s -public :: photon_recombination_reset_helicity_selection -public :: photon_recombination_compute_sqme_sum -public :: photon_recombination_get_int_ptr -public :: photon_recombination_get_eval_trace_ptr -public :: photon_recombination_get_eval_sqme_ptr -public :: photon_recombination_write_state_summary -public :: photon_recombination_get_momenta_in -public :: photon_recombination_set_cut_status -public :: photon_recombination_get_cut_status -public :: photon_recombination_kinematics_passed -public :: photon_recombination_set_weight -public :: photon_recombination_get_weight -<>= -subroutine photon_recombination_unload (pr) -type(photon_recombination_t), intent(inout) :: pr - call hard_interaction_unload (pr%hi) -end subroutine photon_recombination_unload - -subroutine photon_recombination_reload (pr, prc_lib) -type(photon_recombination_t), intent(inout) :: pr -type(process_library_t), intent(in) :: prc_lib - call hard_interaction_reload (pr%hi, prc_lib) -end subroutine photon_recombination_reload - -subroutine photon_recombination_update_parameters (pr) -type(photon_recombination_t), intent(inout) :: pr - call hard_interaction_update_parameters (pr%hi) -end subroutine photon_recombination_update_parameters - -function photon_recombination_is_valid (pr) result (valid) -type(photon_recombination_t), intent(in) :: pr -logical :: valid - valid = pr%valid -end function photon_recombination_is_valid - -function photon_recombination_get_id (pr) result (id) -type(photon_recombination_t), intent(in) :: pr -type(string_t) :: id - id = hard_interaction_get_id (pr%hi) -end function photon_recombination_get_id - -function photon_recombination_get_model_ptr (pr) result (model) -type(photon_recombination_t), intent(in) :: pr -type(model_t), pointer :: model - model => hard_interaction_get_model_ptr (pr%hi) -end function photon_recombination_get_model_ptr - -function photon_recombination_get_n_out_eff (pr) result (n) -type(photon_recombination_t), intent(in) :: pr -integer :: n - if (pr%complement) then - n = hard_interaction_get_n_out (pr%hi) - else - n = pr%n_tot - 2 - end if -end function photon_recombination_get_n_out_eff - -function photon_recombination_get_n_tot_eff (pr) result (n) -type(photon_recombination_t), intent(in) :: pr -integer :: n - if (pr%complement) then - n = hard_interaction_get_n_tot (pr%hi) - else - n = pr%n_tot - end if -end function photon_recombination_get_n_tot_eff - -function photon_recombination_get_n_out_real (pr) result (n) -type(photon_recombination_t), intent(in) :: pr -integer :: n - if (pr%complement) then - n = hard_interaction_get_n_out (pr%hi) - else - n = pr%n_tot - 1 - end if -end function photon_recombination_get_n_out_real - -function photon_recombination_get_n_tot_real (pr) result (n) -type(photon_recombination_t), intent(in) :: pr -integer :: n - if (pr%complement) then - n = hard_interaction_get_n_tot (pr%hi) - else - n = pr%n_tot + 1 - end if -end function photon_recombination_get_n_tot_real - -function photon_recombination_get_n_flv (pr) result (n) -type(photon_recombination_t), intent(in) :: pr -integer :: n - n = pr%n_flv -end function photon_recombination_get_n_flv - -function photon_recombination_get_flv_states_eff (pr) result (flv) -type(photon_recombination_t), intent(in) :: pr -integer, dimension(:,:), allocatable :: flv - if (pr%complement) then - allocate (flv(pr%n_tot + 1, pr%n_flv)) - flv = pr%flv_states_orig - else - allocate (flv(pr%n_tot, pr%n_flv)) - flv = pr%flv_states - end if -end function photon_recombination_get_flv_states_eff - -function photon_recombination_get_flv_states_real (pr) result (flv) -type(photon_recombination_t), intent(in) :: pr -integer, dimension(:,:), allocatable :: flv - allocate (flv(pr%n_tot + 1, pr%n_flv)) - flv = pr%flv_states_orig -end function photon_recombination_get_flv_states_real - -function photon_recombination_get_first_pdg_in (pr) result (pdg) -type(photon_recombination_t), intent(in) :: pr -integer, dimension(2) :: pdg - pdg = hard_interaction_get_first_pdg_in (pr%hi) -end function photon_recombination_get_first_pdg_in - -function photon_recombination_get_first_pdg_out_eff (pr) result (pdg) -type(photon_recombination_t), intent(in) :: pr -integer, dimension(:), allocatable :: pdg - if (pr%complement) then - allocate (pdg(pr%n_tot - 1)) - pdg = pr%first_pdg_orig - else - allocate (pdg(pr%n_tot - 2)) - pdg = pr%first_pdg - end if -end function photon_recombination_get_first_pdg_out_eff - -function photon_recombination_get_first_pdg_out_real (pr) result (pdg) -type(photon_recombination_t), intent(in) :: pr -integer, dimension(:), allocatable :: pdg - allocate (pdg(pr%n_tot - 1)) - pdg = pr%first_pdg_orig -end function photon_recombination_get_first_pdg_out_real - -subroutine photon_recombination_get_unstable_products (pr, flavors) -type(photon_recombination_t), intent(in) :: pr -type(flavor_t), dimension(:), allocatable, intent(out) :: flavors - call hard_interaction_get_unstable_products (pr%hi, flavors) -end subroutine photon_recombination_get_unstable_products - -subroutine photon_recombination_final_sqme (pr) -type(photon_recombination_t), intent(inout) :: pr - if (pr%complement) then - call hard_interaction_final_sqme (pr%hi) - else - call evaluator_final (pr%eval_sqme) - end if -end subroutine photon_recombination_final_sqme - -subroutine photon_recombination_update_alpha_s (pr, as) -type(photon_recombination_t), intent(inout) :: pr -real(kind=default), intent(in) :: as - call hard_interaction_update_alpha_s (pr%hi, as) -end subroutine photon_recombination_update_alpha_s - -subroutine photon_recombination_reset_helicity_selection (pr, threshold, cutoff) -type(photon_recombination_t), intent(inout) :: pr -real(kind=default), intent(in) :: threshold -integer, intent(in) :: cutoff - call hard_interaction_reset_helicity_selection (pr%hi, threshold, cutoff) -end subroutine photon_recombination_reset_helicity_selection - -function photon_recombination_compute_sqme_sum (pr, p) result (f) -type(photon_recombination_t), intent(inout) :: pr -type(vector4_t), intent(in), dimension(:) :: p -real(kind=default) :: f -type(interaction_t), pointer :: int - if (pr%complement) then - f = hard_interaction_compute_sqme_sum (pr%hi, p) - return - end if - int => evaluator_get_int_ptr (pr%eval_rec) - call interaction_set_momenta (int, p(:2), outgoing = .false.) - call photon_recombination_set_momenta (pr, p(3:)) - if (.not. pr%passed) then - f = 0 - return - end if - call evaluator_receive_momenta (pr%eval_trace) - call photon_recombination_evaluate (pr) - f = evaluator_sum (pr%eval_trace) -end function photon_recombination_compute_sqme_sum - -function photon_recombination_get_int_ptr (pr) result (int) -type(photon_recombination_t), intent(in), target :: pr -type(interaction_t), pointer :: int - if (pr%complement) then - int => hard_interaction_get_int_ptr (pr%hi) - else - int => evaluator_get_int_ptr (pr%eval_rec) - end if -end function photon_recombination_get_int_ptr - -function photon_recombination_get_eval_trace_ptr (pr) result (eval) -type(photon_recombination_t), intent(in), target :: pr -type(evaluator_t), pointer :: eval - if (pr%complement) then - eval => hard_interaction_get_eval_trace_ptr (pr%hi) - else - eval => pr%eval_trace - end if -end function photon_recombination_get_eval_trace_ptr - -function photon_recombination_get_eval_sqme_ptr (pr) result (eval) -type(photon_recombination_t), intent(in), target :: pr -type(evaluator_t), pointer :: eval - if (pr%complement) then - eval => hard_interaction_get_eval_sqme_ptr (pr%hi) - else - eval => pr%eval_sqme - end if -end function photon_recombination_get_eval_sqme_ptr - -subroutine photon_recombination_write_state_summary (pr, unit) -type(photon_recombination_t), intent(in) :: pr -integer, intent(in), optional :: unit - call hard_interaction_write_state_summary (pr%hi, unit) -end subroutine photon_recombination_write_state_summary - -function photon_recombination_get_momenta_in (pr) result (p) -type(photon_recombination_t), intent(in) :: pr -type(vector4_t), dimension(2) :: p - if (pr%complement) then - p = interaction_get_momenta (hard_interaction_get_int_ptr (pr%hi), & - outgoing = .false.) - else - p = interaction_get_momenta (evaluator_get_int_ptr (pr%eval_rec), & - outgoing = .false.) - end if -end function photon_recombination_get_momenta_in - -subroutine photon_recombination_set_cut_status (pr, stat) -type(photon_recombination_t), intent(inout) :: pr -logical, intent(in) :: stat - pr%passed = pr%passed .and. stat -end subroutine photon_recombination_set_cut_status - -subroutine photon_recombination_kinematics_passed (pr, stat) -type(photon_recombination_t), intent(inout) :: pr -logical, intent(in) :: stat - pr%passed = stat -end subroutine photon_recombination_kinematics_passed - -function photon_recombination_get_cut_status (pr) result (stat) -type(photon_recombination_t), intent(in) :: pr -logical :: stat - stat = pr%passed -end function photon_recombination_get_cut_status - -subroutine photon_recombination_set_weight (pr, weight) -type(photon_recombination_t), intent(inout) :: pr -real(kind=default), intent(in) :: weight - pr%weight = weight -end subroutine photon_recombination_set_weight - -function photon_recombination_get_weight (pr) result (weight) -type(photon_recombination_t), intent(in) :: pr -real(kind=default) :: weight - weight = pr%weight -end function photon_recombination_get_weight - -@ %def photon_recombination_unload -@ %def photon_recombination_reload -@ %def photon_recombination_update_parameters -@ %def photon_recombination_is_valid -@ %def photon_recombination_get_id -@ %def photon_recombination_get_model_ptr -@ %def photon_recombination_get_n_out_eff -@ %def photon_recombination_get_n_tot_eff -@ %def photon_recombination_get_n_out_real -@ %def photon_recombination_get_n_tot_real -@ %def photon_recombination_get_n_flv -@ %def photon_recombination_get_flv_states_eff -@ %def photon_recombination_get_flv_states_real -@ %def photon_recombination_get_first_pdg_in -@ %def photon_recombination_get_first_pdg_out_eff -@ %def photon_recombination_get_first_pdg_out_real -@ %def photon_recombination_get_unstable_products -@ %def photon_recombination_final_sqme -@ %def photon_recombination_update_alpha_s -@ %def photon_recombination_reset_helicity_selection -@ %def photon_recombination_compute_sqme_sum -@ %def photon_recombination_get_int_ptr -@ %def photon_recombination_get_eval_trace_ptr -@ %def photon_recombination_get_eval_sqme_ptr -@ %def photon_recombination_write_state_summary -@ %def photon_recombination_get_momenta_in -@ %def photon_recombination_set_cut_status -@ %def photon_recombination_get_cut_status -@ %def photon_recombination_kinematics_passed -@ %def photon_recombination_set_weight -@ %def photon_recombination_get_weight -@ - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{BLHA interface} - -These modules implement the communication with one loop matrix element providers -according to the Binoth LesHouches Accord Interface. The actual matrix -element(s) are loaded as a dynamic library. - -The module is split into a configuration interface which manages configuration -and handles the request and contract files, a module which interfaces the OLP -matrix elements and a driver. - -<<[[blha_config.f90]]>>= -<> - -module blha_config - -<> -<> - use constants !NODEP! -<> - use diagnostics !NODEP! - use md5 - use models - use flavors - use quantum_numbers - use pdg_arrays - use sorting - use lexers - use parser - use syntax_rules - use ifiles - use limits, only: EOF !NODEP! - -<> - -<> - -<> - -<> - -<> - -<> - -contains - -<> - -end module blha_config - -@ %def blha_config -@ -<<[[blha_interface.f90]]>>= -<> - -module blha_interface - -<> -<> - use constants !NODEP! -<> - use diagnostics !NODEP! - use sm_physics !NODEP! - use md5 - use lorentz !NODEP! - use models - use flavors - use quantum_numbers - use interactions - use evaluators - use particles - use quantum_numbers - use blha_config - use, intrinsic :: iso_c_binding !NODEP! - use os_interface - -<> - -<> - -<> - -<> - -<> - -<> - -contains - -<> - -end module blha_interface -@ %def blha_interface -@ % -<<[[blha_driver.f90]]>>= -<> - -module blha_driver - -<> -<> - use constants !NODEP! -<> - use diagnostics !NODEP! - use sm_physics !NODEP! - use md5 - use lorentz !NODEP! - use models - use flavors - use quantum_numbers - use interactions - use evaluators - use particles - use quantum_numbers - use blha_config - use blha_interface - -<> - -<> - -<> - -<> - -<> - -<> - -contains - -<> - -end module blha_driver -@ %def blha_driver -@ % - -\subsection{Configuration} - -Parameters to enumerate the different options in the order. -<>= -integer, public, parameter :: & - BLHA_MEST_SUM=1, BLHA_MEST_AVG=2, BLHA_MEST_OTHER=3 -integer, public, parameter :: & - BLHA_CT_QCD=1, BLHA_CT_EW=2, BLHA_CT_QED=3, BLHA_CT_OTHER=4 -integer, public, parameter :: & - BLHA_IRREG_CDR=1, BLHA_IRREG_DRED=2, BLHA_IRREG_THV=3, & - BLHA_IRREG_MREG=4, BLHA_IRREG_OTHER=5 -integer, public, parameter :: & - BLHA_SUBMODE_NONE = 1, BLHA_SUBMODE_OTHER = 2 -integer, public, parameter :: & - BLHA_MPS_ONSHELL=1, BLHA_MPS_OTHER=2 -integer, public, parameter :: & - BLHA_MODE_GOSAM=1, BLHA_MODE_GENERIC=2 -integer, public, parameter :: & - BLHA_OM_NONE=1, BLHA_OM_NOCPL=2, BLHA_OM_OTHER=3 -@ %def -@ -This type encapsulates a BLHA request. -<>= -public :: blha_configuration_t -public :: blha_cfg_process_node_t -<>= -type :: blha_cfg_process_node_t - integer, dimension(:), allocatable :: pdg_in, pdg_out - integer, dimension(:), allocatable :: fingerprint - integer :: nsub - integer, dimension(:), allocatable :: ids - type(blha_cfg_process_node_t), pointer :: next => null () -end type blha_cfg_process_node_t - -type :: blha_configuration_t - type(string_t) :: name - type(model_t), pointer :: model - type(string_t) :: md5 - logical :: dirty = .true. - integer :: n_proc = 0 - integer :: mode = BLHA_MODE_GENERIC - type(blha_cfg_process_node_t), pointer :: processes => null () - integer, dimension(2) :: matrix_element_square_type = BLHA_MEST_SUM - type(string_t), dimension (2) :: matrix_element_square_type_other - integer :: correction_type = BLHA_CT_QCD - type(string_t) :: correction_type_other - integer :: irreg = BLHA_IRREG_THV - type(string_t) :: irreg_other - integer :: massive_particle_scheme = BLHA_MPS_ONSHELL - type(string_t) :: massive_particle_scheme_other - integer :: subtraction_mode = BLHA_SUBMODE_NONE - type(string_t) :: subtraction_mode_other - type(string_t) :: model_file - logical :: subdivide_subprocesses = .false. - integer :: alphas_power = -1, alpha_power = -1 - integer :: operation_mode = BLHA_OM_NONE - type(string_t) :: operation_mode_other -end type blha_configuration_t - -@ %def -@ -Creation. -<>= -public :: blha_configuration_init -<>= -subroutine blha_configuration_init (cfg, name, model, mode) -type(blha_configuration_t), intent(out) :: cfg -type(string_t), intent(in) :: name -type(model_t), target, intent(in) :: model -integer, intent(in), optional :: mode - cfg%name = name - cfg%model => model - if (present (mode)) cfg%mode = mode -end subroutine blha_configuration_init - -@ %def -@ -Destruction. -<>= -public :: blha_configuration_final -<>= -subroutine blha_configuration_final (cfg) -type(blha_configuration_t), intent(inout) :: cfg -type(blha_cfg_process_node_t), pointer :: cur, next - cur => cfg%processes - do while (associated (cur)) - next => cur%next - deallocate (cur) - nullify (cur) - cur => next - end do -end subroutine blha_configuration_final - -@ %def -@ -Merge sort a process list w.r.t. to the process fingerprints. This is necessary -for canonicalizing the process list prior to calculating the MD5 sum. -<>= -subroutine sort_processes (list, n) -type(blha_cfg_process_node_t), pointer :: list -integer, intent(in), optional :: n -integer :: cout -type :: pnode - type(blha_cfg_process_node_t), pointer :: p -end type pnode -type(pnode), dimension(:), allocatable :: array -integer :: count, i, s, i1, i2, i3 -type(blha_cfg_process_node_t), pointer :: node - if (present (n)) then - count = n - else - node => list - count = 0 - do while (associated (node)) - node => node%next - count = count + 1 - end do - end if - ! Store list nodes into an array - if (count == 0) return - allocate (array(count)) - i = 1 - node => list - do i = 1, count - array(i)%p => node - node => node%next - end do - s = 1 - ! Merge sort the array - do while (s < count) - i = 0 - i1 = 1 - i2 = s - do while (i2 < count) - i3 = min (s*(i+2), count) - array(i1:i3) = merge (array(i1:i2), array(i2+1:i3)) - i = i + 2 - i1 = s*i+1 - i2 = s*(i+1) - end do - s = s * 2 - end do - ! Relink according to their new order - list => array(1)%p - nullify (array(count)%p%next) - node => list - do i = 2, count - node%next => array(i)%p - node => node%next - end do - -contains - -! .le. comparision -function lt (n1, n2) result (predicate) -type(blha_cfg_process_node_t), intent(in) :: n1, n2 -logical :: predicate -integer :: i - predicate = .true. - do i = 1, size (n1%fingerprint) - if (n1%fingerprint(i) < n2%fingerprint(i)) return - if (n1%fingerprint(i) > n2%fingerprint(i)) then - predicate = .false. - return - end if - end do -end function lt - -! Sorting core --- merge two sorted chunks -function merge (l1, l2) result (lo) -type(pnode), dimension(:), intent(in) :: l1, l2 -type(pnode), dimension(size (l1) + size (l2)) :: lo -integer :: i, i1, i2 - i1 = 1 - i2 = 1 - do i = 1, size (lo) - if (i1 > size (l1)) then - lo(i)%p => l2(i2)%p - i2 = i2 + 1 - elseif (i2 > size (l2)) then - lo(i)%p => l1(i1)%p - i1 = i1 + 1 - elseif (lt (l1(i1)%p, l2(i2)%p)) then - lo(i)%p => l1(i1)%p - i1 = i1 + 1 - else - lo(i)%p => l2(i2)%p - i2 = i2 + 1 - end if - end do -end function merge - -end subroutine sort_processes -@ %def -@ -Append a process. This expands the flavor sum, sorts it and then eliminates -any duplicates. -<>= -public :: blha_configuration_append_process -<>= -subroutine blha_configuration_append_process (cfg, pdg_in, pdg_out, nsub, ids) -type(blha_configuration_t), intent(inout) :: cfg -type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out -integer, optional, intent(in) :: nsub -integer, optional, dimension(:), intent(in) :: ids -type(blha_cfg_process_node_t), pointer :: root, node, tmp -! Multiindex for counting through the PDG numbers -integer, dimension(size (pdg_in)) :: i_in -integer, dimension(size (pdg_out)) :: i_out -! Handle the list of lists -type :: ilist - integer, dimension(:), allocatable :: i -end type ilist -type(ilist), dimension(size (pdg_in)) :: ilist_i -type(ilist), dimension(size (pdg_out)) :: ilist_o -integer :: i, j, nproc -logical :: inc - ! Extract PDGs into integer lists - do i = 1, size (pdg_in) - ilist_i(i)%i = pdg_in(i) - end do - do i = 1, size (pdg_out) - ilist_o(i)%i = pdg_out(i) - end do - i_in = 1 - i_out = 1 - allocate (root) - node => root - ! Perform the expansion - nproc = 0 - EXPAND: do - ! Transfer the PDG selection... - allocate (node%pdg_in(size (pdg_in))) - allocate (node%pdg_out(size (pdg_out))) - allocate (node%fingerprint (size (pdg_in) + size (pdg_out))) - if (present (nsub)) node%nsub = nsub - if (present (ids)) then - allocate (node%ids(size (ids))) - node%ids = ids - end if - forall (j=1:size(ilist_i)) & - node%pdg_in(j) = ilist_i(j)%i(i_in(j)) - forall (j=1:size(ilist_o)) & - node%pdg_out(j) = ilist_o(j)%i(i_out(j)) - node%fingerprint = (/ node%pdg_in, sort (node%pdg_out) /) - nproc = nproc + 1 - inc = .false. - ! ... and increment the multiindex - do j = 1, size (i_out) - if (i_out(j) < size (ilist_o(j)%i)) then - i_out(j) = i_out(j) + 1 - inc = .true. - exit - else - i_out(j) = 1 - end if - end do - if (.not. inc) then - do j = 1, size (i_in) - if (i_in(j) < size (ilist_i(j)%i)) then - i_in(j) = i_in(j) + 1 - inc = .true. - exit - else - i_in(j) = 1 - end if - end do - end if - if (.not. inc) exit EXPAND - allocate (node%next) - node => node%next - end do EXPAND - ! Do the sorting - call sort_processes (root, nproc) - ! Kill duplicates - node => root - do while (associated (node)) - if (.not. associated (node%next)) exit - if (all (node%fingerprint == node%next%fingerprint)) then - tmp => node%next%next - deallocate (node%next) - node%next => tmp - nproc = nproc - 1 - else - node => node%next - end if - end do - ! Append the remaining list - if (associated (cfg%processes)) then - node => cfg%processes - do while (associated (node%next)) - node => node%next - end do - node%next => root - else - cfg%processes => root - end if - cfg%n_proc = cfg%n_proc + nproc - cfg%dirty = .true. - -end subroutine blha_configuration_append_process - -@ %def -@ -Change parameter(s). -<>= -public :: blha_configuration_set -<>= -subroutine blha_configuration_set ( cfg, & - matrix_element_square_type_hel, matrix_element_square_type_hel_other, & - matrix_element_square_type_col, matrix_element_square_type_col_other, & - correction_type, correction_type_other, & - irreg, irreg_other, & - massive_particle_scheme, massive_particle_scheme_other, & - subtraction_mode, subtraction_mode_other, & - model_file, subdivide_subprocesses, alphas_power, alpha_power, & - operation_mode, operation_mode_other) -type(blha_configuration_t), intent(inout) :: cfg -integer, optional, intent(in) :: matrix_element_square_type_hel -type(string_t), optional, intent(in) :: matrix_element_square_type_hel_other -integer, optional, intent(in) :: matrix_element_square_type_col -type(string_t), optional, intent(in) :: matrix_element_square_type_col_other -integer, optional, intent(in) :: correction_type -type(string_t), optional, intent(in) :: correction_type_other -integer, optional, intent(in) :: irreg -type(string_t), optional, intent(in) :: irreg_other -integer, optional, intent(in) :: massive_particle_scheme -type(string_t), optional, intent(in) :: massive_particle_scheme_other -integer, optional, intent(in) :: subtraction_mode -type(string_t), optional, intent(in) :: subtraction_mode_other -type(string_t), optional, intent(in) :: model_file -logical, optional, intent(in) :: subdivide_subprocesses -integer, intent(in), optional :: alphas_power, alpha_power -integer, intent(in), optional :: operation_mode -type(string_t), intent(in), optional :: operation_mode_other - if (present (matrix_element_square_type_hel)) & - cfg%matrix_element_square_type(1) = matrix_element_square_type_hel - if (present (matrix_element_square_type_hel_other)) & - cfg%matrix_element_square_type_other(1) = matrix_element_square_type_hel_other - if (present (matrix_element_square_type_col)) & - cfg%matrix_element_square_type(2) = matrix_element_square_type_col - if (present (matrix_element_square_type_col_other)) & - cfg%matrix_element_square_type_other(2) = matrix_element_square_type_col_other - if (present (correction_type)) & - cfg%correction_type = correction_type - if (present (correction_type_other)) & - cfg%correction_type_other = correction_type_other - if (present (irreg)) & - cfg%irreg = irreg - if (present (irreg_other)) & - cfg%irreg_other = irreg_other - if (present (massive_particle_scheme)) & - cfg%massive_particle_scheme = massive_particle_scheme - if (present (massive_particle_scheme_other)) & - cfg%massive_particle_scheme_other = massive_particle_scheme_other - if (present (subtraction_mode)) & - cfg%subtraction_mode = subtraction_mode - if (present (subtraction_mode_other)) & - cfg%subtraction_mode_other = subtraction_mode_other - if (present (model_file)) & - cfg%model_file = model_file - if (present (subdivide_subprocesses)) & - cfg%subdivide_subprocesses = subdivide_subprocesses - if (present (alphas_power)) & - cfg%alphas_power = alphas_power - if (present (alpha_power)) & - cfg%alpha_power = alpha_power - if (present (operation_mode)) & - cfg%operation_mode = operation_mode - if (present (operation_mode_other)) & - cfg%operation_mode_other = operation_mode_other - cfg%dirty = .true. -end subroutine blha_configuration_set - -@ %def -@ -Print the BLHA file. Internal mode is intented for md5summing only. -<>= -public :: blha_configuration_write -<>= -subroutine blha_configuration_write (cfg, unit, internal) -type(blha_configuration_t), intent(in) :: cfg -integer, intent(in), optional :: unit -logical, intent(in), optional :: internal -integer :: u -logical :: full -type(string_t) :: buf -type(blha_cfg_process_node_t), pointer :: node -integer :: i -character(3) :: pdg_char -character(len=25), parameter :: pad = " " - u = output_unit (unit) - full = .true.; if (present (internal)) full = .not. internal - if (full .and. cfg%dirty) call msg_bug ( & - "BUG: attempted to write out a dirty BLHA configuration") - if (full) then - write (u,'(A)') "# BLHA order written by WHIZARD <>" - write (u,'(A)') - end if - select case (cfg%mode) - case (BLHA_MODE_GOSAM); buf = "GoSam" - case default; buf = "vanilla" - end select - write (u,'(A)') "# BLHA interface mode: " // char (buf) - write (u,'(A)') "# process: " // char (cfg%name) - write (u,'(A)') "# model: " // char (model_get_name (cfg%model)) - if (full) then - write (u,'(A)') - write (u,'(A)') '#@WO MD5 "' // char (cfg%md5) // '"' - write (u,'(A)') - end if - if (all (cfg%matrix_element_square_type == BLHA_MEST_SUM)) then - buf = "CHsummed" - elseif (all (cfg%matrix_element_square_type == BLHA_MEST_AVG)) then - buf = "CHaveraged" - else - buf = (render_mest ("H", cfg%matrix_element_square_type(1), & - cfg%matrix_element_square_type_other(1)) // " ") // & - render_mest ("C", cfg%matrix_element_square_type(2), & - cfg%matrix_element_square_type_other(2)) - end if - write (u,'(A25,A)') "MatrixElementSquareType" // pad, char (buf) - select case (cfg%correction_type) - case (BLHA_CT_QCD); buf = "QCD" - case (BLHA_CT_EW); buf = "EW" - case (BLHA_CT_QED); buf = "QED" - case default; buf = cfg%correction_type_other - end select - write (u,'(A25,A)') "CorrectionType" // pad, char (buf) - select case (cfg%irreg) - case (BLHA_IRREG_CDR); buf = "CDR" - case (BLHA_IRREG_DRED); buf = "DRED" - case (BLHA_IRREG_THV); buf = "tHV" - case (BLHA_IRREG_MREG); buf = "MassReg" - case default; buf = cfg%irreg_other - end select - write (u,'(A25,A)') "IRregularisation" // pad, char (buf) - select case (cfg%massive_particle_scheme) - case (BLHA_MPS_ONSHELL); buf = "OnShell" - case default; buf = cfg%massive_particle_scheme_other - end select - write (u,'(A25,A)') "MassiveParticleScheme" // pad, char (buf) - select case (cfg%subtraction_mode) - case (BLHA_SUBMODE_NONE); buf = "None" - case default; buf = cfg%subtraction_mode_other - end select - write (u,'(A25,A)') "IRsubtractionMethod" // pad, char (buf) - write (u,'(A25,A)') "ModelFile" // pad, char (cfg%model_file) - if (cfg%subdivide_subprocesses) then - write (u,'(A25,A)') "SubdivideSubprocesses" // pad, "yes" - else - write (u,'(A25,A)') "SubdivideSubprocess" // pad, "no" - end if - if (cfg%alphas_power >= 0) write (u,'(A25,A)') & - "AlphasPower" // pad, int2char (cfg%alphas_power) - if (cfg%alpha_power >= 0) write (u,'(A25,A)') & - "AlphaPower " // pad, int2char (cfg%alpha_power) - if (full) then - write (u,'(A)') - write (u,'(A)') "# Process definitions" - write (u,'(A)') - end if - node => cfg%processes - do while (associated (node)) - buf = "" - do i = 1, size (node%pdg_in) - write (pdg_char,'(I3)') node%pdg_in(i) - buf = (buf // pdg_char) // " " - end do - buf = buf // "-> " - do i = 1, size (node%pdg_out) - write (pdg_char,'(I3)') node%pdg_out(i) - buf = (buf // pdg_char) // " " - end do - write (u,'(A)') char (trim (buf)) - node => node%next - end do - -contains - -function render_mest (prefix, mest, other) result (tag) -character, intent(in) :: prefix -integer, intent(in) :: mest -type(string_t), intent(in) :: other -type(string_t) :: tag - select case (mest) - case (BLHA_MEST_AVG); tag = prefix // "averaged" - case (BLHA_MEST_SUM); tag = prefix // "summed" - case default; tag = other - end select -end function render_mest - -end subroutine blha_configuration_write - -@ %def -@ -``Freeze'' the configuration by calculating the MD5 sum. -<>= -public :: blha_configuration_freeze -<>= -subroutine blha_configuration_freeze (cfg) -type(blha_configuration_t), intent(inout) :: cfg -integer u - if (.not. cfg%dirty) return - call sort_processes (cfg%processes) - u = free_unit () - open (unit=u, status="scratch", action="readwrite") - call blha_configuration_write (cfg, u, internal=.true.) - rewind (u) - cfg%md5 = md5sum (u) - cfg%dirty = .false. - close (u) -end subroutine blha_configuration_freeze - -@ %def -@ -Read a contract file, again creating a [[blha_configuration_t]] object. -<>= -public :: blha_read_contract -<>= -interface blha_read_contract - module procedure blha_read_contract_unit, blha_read_contract_file -end interface -<>= -subroutine blha_read_contract_file (cfg, ok, fname, success) -type(blha_configuration_t), intent(inout) :: cfg -logical, intent(out) :: ok -type(string_t), intent(in) :: fname -logical, intent(out), optional :: success -integer :: u, stat - u = free_unit () - open (u, file=char (fname), status="old", action="read", iostat=stat) - if (stat /= 0) then - if (present (success)) then - success = .false. - return - else - call msg_bug ('Unable to open contract file "' // char (fname) // '"') - end if - end if - call blha_read_contract_unit (cfg, ok, u, success) - close (u) -end subroutine blha_read_contract_file - -subroutine blha_read_contract_unit (cfg, ok, u, success) -type(blha_configuration_t), intent(inout) :: cfg -logical, intent(out) :: ok -integer, intent(in) :: u -logical, intent(out), optional :: success -type(stream_t) :: stream -type(ifile_t) :: preprocessed -type(lexer_t) :: lexer -type(parse_tree_t) :: parse_tree -type(string_t) :: md5 - call stream_init (stream, u) - call contract_preprocess (stream, preprocessed) - call stream_final (stream) - call stream_init (stream, preprocessed) - call blha_init_lexer (lexer) - call lexer_assign_stream (lexer, stream) - call parse_tree_init (parse_tree, syntax_blha_contract, lexer) - call blha_transfer_contract (cfg, ok, parse_tree, success) - call blha_configuration_write (cfg, internal=.true.) - call lexer_final (lexer) - call stream_final (stream) - call ifile_final (preprocessed) - if (ok) then - md5 = cfg%md5 - call blha_configuration_freeze (cfg) - if (char (trim (md5 )) /= "") then - if (md5 /= cfg%md5) then - call msg_warning ("BLHA contract does not match the recorded " & - // "checksum --- this counts as an error!") - ok = .false. - end if - else - call msg_warning ("It seems the OLP scrubbed our checksum, unable " & - // "to check contract consistency.") - end if - end if -end subroutine blha_read_contract_unit - -@ %def -@ -Walk the parse tree and transfer the results to the [[blha_configuration]] -object. The [[goto]] is a poor man's %' -replacement for exceptions which would be an appropiate error handling -mechanism here. -<>= -subroutine blha_transfer_contract (cfg, ok, parse_tree, success) -type(blha_configuration_t), intent(inout) :: cfg -logical, intent(out) :: ok -type(parse_tree_t), intent(in), target :: parse_tree -logical, intent(out), optional :: success -type(parse_node_t), pointer :: pn_root, pn_line, pn_request, pn_result, & - pn_key, pn_opt, pn_state_in, pn_state_out, pn_pdg -type(string_t) :: emsg -integer :: nopt, i, nsub -integer, dimension(:), allocatable :: ids -logical, dimension(2) :: flags -type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out - ok = .true. - pn_root => parse_tree_get_root_ptr (parse_tree) - pn_line => parse_node_get_sub_ptr (pn_root) - do while (associated (pn_line)) - pn_request => parse_node_get_sub_ptr (pn_line) - if (.not. associated (pn_request)) cycle - if (char (parse_node_get_rule_key (pn_request)) == "process") then - pn_result => parse_node_get_sub_ptr (pn_line, 2) - pn_state_in => parse_node_get_sub_ptr (pn_request, 1) - pn_state_out => parse_node_get_sub_ptr (pn_request, 3) - allocate (pdg_in (parse_node_get_n_sub (pn_state_in))) - allocate (pdg_out (parse_node_get_n_sub (pn_state_out))) - i = 1 - pn_pdg => parse_node_get_sub_ptr (pn_state_in) - do while (associated (pn_pdg)) - pdg_in(i) = (/get_int (pn_pdg)/) - pn_pdg => parse_node_get_next_ptr (pn_pdg) - i = i + 1 - end do - i = 1 - pn_pdg => parse_node_get_sub_ptr (pn_state_out) - do while (associated (pn_pdg)) - pdg_out(i) = (/get_int (pn_pdg)/) - pn_pdg => parse_node_get_next_ptr (pn_pdg) - i = i + 1 - end do - i = parse_node_get_n_sub (pn_result) - emsg = "broken process line" - if (i < 2) goto 10 - pn_opt => parse_node_get_sub_ptr (pn_result, 2) - do while (associated (pn_opt)) - if (char (parse_node_get_rule_key (pn_opt)) == "string") then - call msg_warning ("While reading the BLHA contract: " // & - 'the OLP returned an error for a process: "' // & - char (parse_node_get_string (pn_opt)) // '"') - ok = .false. - return - end if - pn_opt => parse_node_get_next_ptr (pn_opt) - end do - pn_opt => parse_node_get_sub_ptr (pn_result, 2) - nsub = get_int (pn_opt) - if (nsub /= i - 2) goto 10 - allocate (ids(nsub)) - i = 1 - pn_opt => parse_node_get_next_ptr (pn_opt) - do while (associated (pn_opt)) - ids(i) = get_int (pn_opt) - pn_opt => parse_node_get_next_ptr (pn_opt) - end do - call blha_configuration_append_process (cfg, pdg_in, pdg_out, & - nsub=nsub, ids=ids) - deallocate (pdg_in, pdg_out, ids) - else - pn_result => parse_node_get_sub_ptr (parse_node_get_next_ptr (pn_request), 2) - pn_key => parse_node_get_sub_ptr (pn_request) - pn_opt => parse_node_get_next_ptr (pn_key) - nopt = parse_node_get_n_sub (pn_request) - 1 - select case (char (parse_node_get_rule_key (pn_key))) - case ("md5") - cfg%md5 = parse_node_get_string (pn_opt) - case ("modelfile") - cfg%model_file = get_fname (pn_opt) - call check_result (pn_result, "ModelFile") - case ("irregularisation") - select case (lower_case (char (parse_node_get_string (pn_opt)))) - case ("cdr"); cfg%irreg = BLHA_IRREG_CDR - case ("dred"); cfg%irreg = BLHA_IRREG_DRED - case ("thv"); cfg%irreg = BLHA_IRREG_THV - case ("mreg"); cfg%irreg = BLHA_IRREG_MREG - case default - cfg%irreg = BLHA_IRREG_OTHER - cfg%irreg_other = parse_node_get_string (pn_opt) - end select - call check_result (pn_result, "IRRegularisation") - case ("irsubtractionmethod") - select case (lower_case (char (parse_node_get_string (pn_opt)))) - case ("none"); cfg%subtraction_mode = BLHA_SUBMODE_NONE - case default - cfg%subtraction_mode = BLHA_SUBMODE_OTHER - cfg%subtraction_mode_other = parse_node_get_string(pn_opt) - end select - call check_result (pn_result, "IRSubtractionMethod") - case ("massiveparticlescheme") - select case (lower_case (char (parse_node_get_string (pn_opt)))) - case ("onshell") - cfg%massive_particle_scheme = BLHA_MPS_ONSHELL - case default - cfg%massive_particle_scheme = BLHA_MPS_OTHER - cfg%massive_particle_scheme_other = & - parse_node_get_string (pn_opt) - end select - call check_result (pn_result, "MassiveParticleScheme") - case ("matrixelementsquaretype") - select case (nopt) - case (1) - select case (lower_case (char (parse_node_get_string (pn_opt)))) - case ("chsummed") - cfg%matrix_element_square_type = BLHA_MEST_SUM - case ("chaveraged") - cfg%matrix_element_square_type = BLHA_MEST_AVG - case default - emsg = "invalid MatrixElementSquareType: " // & - parse_node_get_string (pn_opt) - goto 10 - end select - case (2) - do i = 1, 2 - pn_opt => parse_node_get_next_ptr (pn_key, i) - select case (lower_case (char (parse_node_get_string ( & - pn_opt)))) - case ("csummed") - cfg%matrix_element_square_type(2) = BLHA_MEST_SUM - flags(2) = .true. - case ("caveraged") - cfg%matrix_element_square_type(2) = BLHA_MEST_AVG - flags(2) = .true. - case ("hsummed") - cfg%matrix_element_square_type(1) = BLHA_MEST_SUM - flags(1) = .true. - case ("haveraged") - cfg%matrix_element_square_type(1) = BLHA_MEST_AVG - flags(1) = .true. - case default - emsg = "invalid MatrixElementSquareType: " // & - parse_node_get_string (pn_opt) - goto 10 - end select - end do - if (.not. all (flags)) then - emsg = "MatrixElementSquareType: setup not exhaustive" - goto 10 - end if - case default - emsg = "MatrixElementSquareType: too many options" - goto 10 - end select - call check_result (pn_result, "MatrixElementSquareType") - case ("correctiontype") - select case (lower_case (char (parse_node_get_string (pn_opt)))) - case ("qcd"); cfg%correction_type = BLHA_CT_QCD - case ("qed"); cfg%correction_type = BLHA_CT_QED - case ("ew"); cfg%correction_type = BLHA_CT_EW - case default - cfg%correction_type = BLHA_CT_OTHER - cfg%correction_type_other = parse_node_get_string (pn_opt) - end select - call check_result (pn_result, "CorrectionType") - case ("alphaspower") - cfg%alphas_power = get_int (pn_opt) - call check_result (pn_result, "AlphasPower") - case ("alphapower") - cfg%alpha_power = get_int (pn_opt) - call check_result (pn_result, "AlphaPower") - case ("subdividesubprocess") - select case (lower_case (char (parse_node_get_string (pn_opt)))) - case ("yes"); cfg%subdivide_subprocesses = .true. - case ("no"); cfg%subdivide_subprocesses = .false. - case default - emsg = 'SubdivideSubprocess: invalid argument "' // & - parse_node_get_string (pn_opt) // '"' - goto 10 - end select - call check_result (pn_result, "SubdivideSubprocess") - case default - emsg = "unknown statement: " // parse_node_get_rule_key (pn_key) - goto 10 - end select - end if - pn_line => parse_node_get_next_ptr (pn_line) - end do - if (present (success)) success = .true. - return -10 continue - if (present (success)) then - call msg_error ("Error reading BLHA contract: " // char (emsg)) - success = .false. - return - else - call msg_fatal ("Error reading BLHA contract: " // char (emsg)) - end if - -contains - -function get_int (pn) result (i) -type(parse_node_t), pointer :: pn -integer :: i - if (char (parse_node_get_rule_key (pn)) == "integer") then - i = parse_node_get_integer (pn) - else - i = parse_node_get_integer (parse_node_get_sub_ptr (pn, 2)) - if (char (parse_node_get_rule_key (parse_node_get_sub_ptr (pn))) & - == "-") i = -i - end if -end function get_int - -subroutine check_result (pn, step) -type(parse_node_t), pointer :: pn -character(*), intent(in) :: step -type(string_t) :: res - res = parse_node_get_string (pn) - if (char (trim (res)) == "") then - call msg_warning ("BLHA contract file: " // step // & - ": OLP didn't return a status --- assuming an error") - ok = .false. - elseif (char (upper_case (res)) /= "OK") then - call msg_warning ("BLHA contract file: " // step // ': OLP error "' // & - char (res) // '"') - ok = .false. - end if -end subroutine check_result - -function get_fname (pn) result (fname) -type(parse_node_t), pointer :: pn -type(string_t) :: fname -type(parse_node_t), pointer :: pn_component - if (char (parse_node_get_rule_key (pn)) == "string") then - fname = parse_node_get_string (pn) - else - fname = "" - pn_component => parse_node_get_sub_ptr (pn) - do while (associated (pn_component)) - if (char (parse_node_get_rule_key (pn_component)) == "id") then - fname = fname // parse_node_get_string (pn_component) - else - fname = fname // parse_node_get_key (pn_component) - end if - pn_component => parse_node_get_next_ptr (pn_component) - end do - end if -end function get_fname - -end subroutine blha_transfer_contract - -@ %def -@ -Init the lexer. -<>= -subroutine blha_init_lexer (lexer) -type(lexer_t), intent(inout) :: lexer - call lexer_init (lexer, & - comment_chars = "#", & - quote_chars = '"', & - quote_match = '"', & - single_chars = '{}|./\:', & - special_class = (/"->"/), & - keyword_list = syntax_get_keyword_list_ptr (syntax_blha_contract), & - upper_case_keywords = .false. & - ) -end subroutine blha_init_lexer - -@ %def -@ -Define the parser syntax table. -<>= -type(syntax_t), target :: syntax_blha_contract -<>= -public :: syntax_blha_contract_init -<>= -subroutine syntax_blha_contract_init () -type(ifile_t) :: ifile - call ifile_append (ifile, "SEQ contract = line*") - call ifile_append (ifile, "KEY '->'") - call ifile_append (ifile, "KEY '.'") - call ifile_append (ifile, "KEY '/'") - call ifile_append (ifile, "KEY '\'") - call ifile_append (ifile, "KEY '+'") - call ifile_append (ifile, "KEY '-'") - call ifile_append (ifile, "KEY '|'") - call ifile_append (ifile, "KEY ':'") - call ifile_append (ifile, "IDE id") - call ifile_append (ifile, "INT integer") - call ifile_append (ifile, "ALT sign = '+' | '-'") - call ifile_append (ifile, "SEQ signed_integer = sign integer") - call ifile_append (ifile, "QUO string = '""'...'""'") - call ifile_append (ifile, "GRO line = '{' line_contents '}'") - call ifile_append (ifile, "SEQ line_contents = request result?") - call ifile_append (ifile, "ALT request = definition | process") - call ifile_append (ifile, "ALT definition = option_unary | option_nary | " & - // "option_path | option_numeric") - call ifile_append (ifile, "KEY matrixelementsquaretype") - call ifile_append (ifile, "KEY irregularisation") - call ifile_append (ifile, "KEY massiveparticlescheme") - call ifile_append (ifile, "KEY irsubtractionmethod") - call ifile_append (ifile, "KEY modelfile") - call ifile_append (ifile, "KEY operationmode") - call ifile_append (ifile, "KEY subdividesubprocess") - call ifile_append (ifile, "KEY alphaspower") - call ifile_append (ifile, "KEY alphapower") - call ifile_append (ifile, "KEY correctiontype") - call ifile_append (ifile, "KEY md5") - call ifile_append (ifile, "SEQ option_unary = key_unary arg") - call ifile_append (ifile, "SEQ option_nary = key_nary arg+") - call ifile_append (ifile, "SEQ option_path = key_path arg_path") - call ifile_append (ifile, "SEQ option_numeric = key_numeric arg_numeric") - call ifile_append (ifile, "ALT key_unary = irregularisation | " & - // "massiveparticlescheme | irsubtractionmethod | subdividesubprocess | " & - // "correctiontype | md5") - call ifile_append (ifile, "ALT key_nary = matrixelementsquaretype | " & - // "operationmode") - call ifile_append (ifile, "ALT key_numeric = alphaspower | alphapower") - call ifile_append (ifile, "ALT key_path = modelfile") - call ifile_append (ifile, "ALT arg = id | string") - call ifile_append (ifile, "ALT arg_numeric = integer | signed_integer") - call ifile_append (ifile, "ALT arg_path = filename | string") - call ifile_append (ifile, "SEQ filename = filename_atom+") - call ifile_append (ifile, "ALT filename_atom = id | '.' | '/' | '\' | ':'") - call ifile_append (ifile, "SEQ process = state '->' state") - call ifile_append (ifile, "SEQ state = pdg+") - call ifile_append (ifile, "ALT pdg = integer | signed_integer") - call ifile_append (ifile, "SEQ result = '|' result_atom+") - call ifile_append (ifile, "ALT result_atom = integer | string") - call syntax_init (syntax_blha_contract, ifile) - call ifile_final (ifile) -end subroutine syntax_blha_contract_init - -@ %def -@ -<>= -public :: syntax_blha_contract_final -<>= -subroutine syntax_blha_contract_final - call syntax_final (syntax_blha_contract) -end subroutine syntax_blha_contract_final - -@ %def -@ -As the contract file is line-oriented, we apply a preprocessing step which -reformats the file in a way suitable for our free-form parser. -<>= -subroutine contract_preprocess (stream, ifile) -type(stream_t), intent(inout) :: stream -type(ifile_t), intent(out) :: ifile -type(string_t) :: buf, reg, transformed -integer :: stat, n - buf = "" - LINES: do - call stream_get_record (stream, reg, stat) - select case (stat) - case (0) - case (EOF); exit LINES - case default - call msg_bug ("I/O error while reading BLHA contract file") - end select - buf = buf // trim (reg) - ! Take care of continuation lines - if (char (extract (buf, len (buf), len(buf))) == '&') then - buf = extract (buf, 1, len (buf) - 1) // " " - cycle LINES - end if - buf = adjustl (buf) - ! Transform #@WO comments into ordinary statements - if (char (extract (buf, 1, 4)) == "#@WO") & - buf = extract (buf, 5) - ! Kill comments and blank lines - if ((char (trim (buf)) == "") .or. & - (char (extract (buf, 1, 1)) == "#")) then - buf = "" - cycle LINES - end if - ! Chop off any end-of-line comments - call split (buf, reg, "#") - ! Split line into order and result - call split (reg, buf, "|") - reg = trim (adjustl (reg)) - buf = trim (adjustl (buf)) - ! Check whether the order is a process definition - n = scan (buf, ">") - if (n == 0) then - ! No -> quote result - reg = ('"' // reg) // '"' - else - ! Yes -> leave any numbers as they are, quote any leftovers - n = scan (reg, "0123456789", back=.true.) - if (n < len (reg)) & - reg = char (extract (reg, 1, n)) // ' "' // & - char (trim (adjustl (extract (reg, n+1)))) // '"' - end if - ! Enclose the line into curly brackets - transformed = "{" // char (buf) // " | " // char (reg) // "}" - call ifile_append (ifile, transformed) - buf = "" - end do LINES -end subroutine contract_preprocess - -@ %def -@ -Test. -<>= -public :: blha_config_test -<>= -subroutine blha_config_test (model, cfg, ok) -type(pdg_array_t), dimension(2) :: pdg_in -type(pdg_array_t), dimension(4) :: pdg_out -type(model_t), pointer :: model -type(blha_configuration_t), intent(out) :: cfg -logical, intent(out) :: ok -integer :: u -logical :: flag - ok = .false. - pdg_in(1) = (/1, 2, -1, -2/) - pdg_in(2) = pdg_in(1) - pdg_out(1) = pdg_in(1) - pdg_out(2) = (/11/) - pdg_out(3) = (/-11/) - pdg_out(4) = pdg_out(1) - call blha_configuration_init (cfg, var_str ("test"), model) - call blha_configuration_set (cfg, alphas_power = 2, alpha_power = 3) - call blha_configuration_append_process (cfg, pdg_in, pdg_out) - call blha_configuration_freeze (cfg) - print * - call blha_configuration_write (cfg) - print * - call blha_configuration_final (cfg) - call blha_configuration_init (cfg, var_str ("test"), model, & - mode=BLHA_MODE_GOSAM) - call blha_configuration_set (cfg, alphas_power = 0, & - model_file = var_str ("test.slha")) - pdg_in(1) = (/1/) - pdg_in(2) = (/-1/) - pdg_out(1) = (/22/) - pdg_out(2) = (/22/) - call blha_configuration_append_process (cfg, pdg_in, pdg_out(1:2)) - call blha_configuration_freeze (cfg) - u = free_unit () - open (u, file="test.blha.order", action="write", status="replace") - call blha_configuration_write (cfg, u) - call blha_configuration_final (cfg) - inquire (file="test.blha.contract", exist=flag) - if (.not. flag) return - call blha_configuration_init (cfg, var_str ("test"), model, mode=BLHA_MODE_GOSAM) - call blha_read_contract (cfg, ok, var_str ("test.blha.contract"), success=flag) - print *, "Reading back processed configuration: success? ", ok -end subroutine blha_config_test - -@ %def -@ - -\subsection{OLP matrix element interface} - -The prototypes of the OLP functions. -<>= -abstract interface - subroutine ext_olp_start (file, status) bind(c) - import - character(c_char), dimension(*), intent(in) :: file - integer(c_int), intent(out) :: status - end subroutine ext_olp_Start - - subroutine ext_olp_evalsubprocess (label, momenta, scale, parameters, amp) & - bind(c) - import - integer(c_int), intent(in), value :: label - real(c_double), dimension(*), intent(in) :: momenta - real(c_double), intent(in), value :: scale - real(c_double), dimension(*), intent(in) :: parameters - real(c_double), dimension(*), intent(out) :: amp - end subroutine ext_olp_evalsubprocess - - subroutine ext_olp_finalize () bind(c) - end subroutine ext_olp_finalize - - subroutine ext_olp_option (assignment, status) bind(c) - import - character(c_char), dimension(*), intent(in) :: assignment - integer(c_int), intent(out) :: status - end subroutine ext_olp_option -end interface - -@ %def -@ -The OLP library is encapsulated together with the configuration in derived type: -<>= -public :: blha_olp_t -<>= -type :: blha_olp_t - private - type(blha_configuration_t) :: cfg - type(string_t) :: library - integer :: n_in, n_out, n_flv, n_hel, n_col - integer, dimension(:,:), allocatable :: flv_state - logical :: color_summed = .true., flavor_summed = .true. - logical :: loaded = .false. - type(dlaccess_t) :: lib_handle - procedure(ext_olp_start), pointer, nopass :: olp_start => null () - procedure(ext_olp_evalsubprocess), pointer, nopass :: & - olp_evalsubprocess => null () - procedure(ext_olp_finalize), pointer, nopass :: olp_finalize => null () - procedure(ext_olp_option), pointer, nopass :: olp_option => null () -end type blha_olp_t - -@ %def -@ -Init the [[blha_olp_t]] object and try to dlopen the library. -<>= -public :: blha_olp_init -<>= -subroutine blha_olp_init (olp, cfg, library, success) -type(blha_olp_t), intent(out) :: olp -type(string_t), intent(in), optional :: library -type(blha_configuration_t), intent(in) :: cfg -logical, intent(out), optional :: success -type(blha_cfg_process_node_t), pointer :: node -type(string_t) :: prefix, libname -type(c_funptr) :: fptr -integer :: olp_status - success = .true. - node => cfg%processes - if (.not. associated (node)) then - call error ("blha_interface_init: empty process list") - return - end if - olp%n_in = size (node%pdg_in) - olp%n_out = size (node%pdg_out) - do while (associated (node)) - if ((olp%n_in /= size (node%pdg_in)) .or. & - (olp%n_out /= size (node%pdg_out))) then - call error ("blha_interface_init: inconsistent process list") - return - end if - node => node%next - end do - if (present (library)) then - olp%library = library - else - olp%library = cfg%name // ".so" - end if - if (char (extract (olp%library, 1, 1)) == "/") then - prefix = "" - libname = extract (olp%library, 2) - else - prefix = "." - libname = olp%library - end if - call dlaccess_init (olp%lib_handle, prefix, libname) - if (dlaccess_has_error (olp%lib_handle)) then - call error ("blha_interface_init: error opening library: " // & - char (dlaccess_get_error (olp%lib_handle))) - call dlaccess_final (olp%lib_handle) - return - end if - fptr = dlaccess_get_c_funptr (olp%lib_handle, var_str ("OLP_Start")) - if (.not. check_dlstate ()) return - call c_f_procpointer (fptr, olp%olp_start) - fptr = dlaccess_get_c_funptr (olp%lib_handle, var_str ("OLP_EvalSubProcess")) - if (.not. check_dlstate ()) return - call c_f_procpointer (fptr, olp%olp_evalsubprocess) - if (olp%cfg%mode == BLHA_MODE_GOSAM) then - fptr = dlaccess_get_c_funptr (olp%lib_handle, var_str ("OLP_Finalize")) - if (.not. check_dlstate ()) return - call c_f_procpointer (fptr, olp%olp_finalize) - fptr = dlaccess_get_c_funptr (olp%lib_handle, var_str ("OLP_Option")) - if (.not. check_dlstate ()) return - call c_f_procpointer (fptr, olp%olp_option) - end if - call olp%olp_start (string_f2c (cfg%model_file), olp_status) - if (olp_status /= 1) then - call error ("blha_interface_init: OLP initialization failed") - call dlaccess_final (olp%lib_handle) - end if - success = .true. - olp%loaded = .true. - -contains - -function check_dlstate () result (ok) -logical :: ok - ok = .not. dlaccess_has_error (olp%lib_handle) - if (.not. ok) then - call error ("blha_interface_init: error loading library: " // & - char (dlaccess_get_error (olp%lib_handle))) - call dlaccess_final (olp%lib_handle) - end if -end function check_dlstate - - -subroutine error (msg) -character(*), intent(in) :: msg - if (present (success)) then - call msg_error (msg) - success = .false. - else - call msg_fatal (msg) - end if -end subroutine error - -end subroutine blha_olp_init - -@ %def -@ - -Finalization -<>= -public :: blha_olp_final -<>= -subroutine blha_olp_final (olp) -type(blha_olp_t), intent(inout) :: olp - if (.not. olp%loaded) return - if (associated (olp%olp_finalize)) call olp%olp_finalize - call dlaccess_final (olp%lib_handle) - olp%loaded = .false. -end subroutine blha_olp_final - -@ %def blha_olp_final -@ - -Test. -<>= -public :: blha_interface_test -<>= -subroutine blha_interface_test (cfg, ok) -type(blha_configuration_t), intent(inout) :: cfg -type(blha_olp_t) :: olp -logical, intent(out) :: ok - call blha_olp_init (olp, cfg, library=var_str ("blha_test.so"), success=ok) - print *, "loading OLP library: success?", ok - call blha_olp_final (olp) -end subroutine blha_interface_test - -@ %def -@ - -\subsection{OLP driver} - -<>= -public :: blha_test -<>= -subroutine blha_test (model) -type(model_t), pointer :: model -type (blha_configuration_t) :: cfg -logical :: ok - call blha_config_test (model, cfg, ok) - if (ok) call blha_interface_test (cfg, ok) -end subroutine blha_test - -@ %def -@ -\subsection{Phase-space workspace} -This is not yet implemented: - -% Global kinematics is described by the two parameters [[sqrts]] -% (c.m.\ energy) and [[lt]], which implements the relation between lab -% and c.m.\ frame. -% -% The [[n_trees]] and [[n_groves]] refer to the [[forest]] component, -% they denote the number of integration parameterizations -% (channels/trees) and channel groups (groves), respectively. -% -% The [[forest]] component is the workspace where for each sampling -% point, integration parameters are related to kinematic variables. It -% consists of an array of trees, each of which describes a particular -% relation between parameters and kinematics that belongs to a -% particular channel in the multichannel sampling algorithm. -% -% The [[x]] component is the array of integration parameters. In the -% multi-channel integration setup, one row of parameters -% corresponds to the sampling channel selected for the current sampling -% point. The other rows are computed backwards from the kinematics, -% they are the parameter values that belong to the same kinematics in -% another channel. -% -% Each channel is, after kinematics evaluation, associated with a weight -% which we denote as the [[phs_factor]]. There is also a global -% [[phs_volume]] factor and a [[vamp_phs_factor]] which are common to -% all channels. -<>= -! real(default) :: sqrts = 0 -! type(lorentz_transformation_t) :: lt = identity -! integer :: n_trees = 0 -! integer :: n_groves = 0 -! type(phs_forest_t) :: forest -! real(default), dimension(:,:), allocatable :: x -! real(default), dimension(:), allocatable :: factor -! real(default) :: volume = 0 -! real(default) :: vamp_phs_factor = 0 -<>= -@ -@ -\subsection{VAMP Configuration} -This object contains all configuration data that are specific for a -setup of VAMP grids. It also contains the grids themselves. - -The [[filename]] string will be used for reading/writing grids from/to disk. - -The [[grid_parameters]] object contains all VAMP-related configuration -data. - -[[n_channels]] is the number of distinct parameterizations (channels) -for the current VAMP dataset. This is the dimension of the grid array. - -[[n_dim]] is the number of integration dimensions for the current VAMP -dataset. - -The [[grids]] component is the actual grid array. An instance of the -process will take a copy of this and use it as workspace. - -The [[vamp_eq]] object declares equivalences between different -channels in the VAMP grid array, which may involve permutations and -reflections of the grid dimensions. - -The two [[history]] entries record the VAMP integration history for -the current process object and VAMP data set. -<>= - type :: process_vamp_data_t - private -! type(string_t) :: grid_filename -! type(grid_parameters_t) :: grid_parameters -! integer :: n_channels = 0 -! integer :: n_dim = 0 -! type(vamp_grids) :: grids -! type(vamp_equivalences_t) :: equivalences -! type(vamp_history), dimension(:), allocatable :: history -! type(vamp_history), dimension(:,:), allocatable :: histories - contains - <> - end type process_vamp_data_t - -@ %def process_vamp_data_t -@ We can choose whether we write the equivalences and the histories. -The grids will not be written; they are usually on file. -<>= - procedure :: write => process_vamp_data_write -<>= - subroutine process_vamp_data_write (vamp, u, equivalences, history, histories) - class(process_vamp_data_t), intent(in) :: vamp - integer, intent(in) :: u - logical, intent(in) :: equivalences, history, histories -! write (u, *) " Grid base filename = '", char (vamp%grid_filename), "'" -! call vamp%grid_parameters%write (u) -! write (u, *) " Number of channels = ", vamp%n_channels -! write (u, *) " Number of dimensions = ", vamp%n_dim -! write (u, *) " VAMP grids [not shown / on file]" -! if (equivalences) then -! write (u, *) " List of channel equivalences:" -! call vamp_equivalences_write (vamp%equivalences, u) -! else -! write (u, *) " List of channel equivalences: [not shown]" -! end if -! if (allocated (vamp%history)) then -! if (history) then -! write (u, *) " VAMP global history:" -! call vamp_write_history (u, vamp%history) -! else -! write (u, *) " VAMP global history: [not shown]" -! end if -! else -! write (u, *) " VAMP global history: [not allocated]" -! end if -! if (allocated (vamp%histories)) then -! if (histories) then -! write (u, *) " VAMP channel histories:" -! call vamp_write_history (u, vamp%histories) -! else -! write (u, *) " VAMP channel histories: [not shown]" -! end if -! else -! write (u, *) " VAMP channel histories: [not allocated]" -! end if - end subroutine process_vamp_data_write - -@ %def process_vamp_data_write -@ -@ -\subsection{Grid parameters} -This is a transparent container. It holds the parameters that are -stored in grid files, and are checked when grid files are read. -<>= - public :: grid_parameters_t -<>= - type :: grid_parameters_t - integer :: threshold_calls = 0 - integer :: min_calls_per_channel = 10 - integer :: min_calls_per_bin = 10 - integer :: min_bins = 3 - integer :: max_bins = 20 - logical :: stratified = .true. - logical :: use_vamp_equivalences = .true. - real(default) :: channel_weights_power = 0.25_default - contains - <> - end type grid_parameters_t - -@ %def grid_parameters_t -@ I/O: -<>= - procedure :: write => grid_parameters_write -<>= - subroutine grid_parameters_write (grid_par, unit) - class(grid_parameters_t), intent(in) :: grid_par - integer, intent(in), optional :: unit - integer :: u - u = output_unit (unit) - write (u, *) "threshold_calls = ", grid_par%threshold_calls - write (u, *) "min_calls_per_channel = ", grid_par%min_calls_per_channel - write (u, *) "min_calls_per_bin = ", grid_par%min_calls_per_bin - write (u, *) "min_bins = ", grid_par%min_bins - write (u, *) "max_bins = ", grid_par%max_bins - write (u, *) "stratified = ", grid_par%stratified - write (u, *) "use_vamp_equivalences = ", grid_par%use_vamp_equivalences - write (u, *) "channel_weights_power = ", grid_par%channel_weights_power - end subroutine grid_parameters_write - -@ %def grid_parameters_write -<>= - subroutine grid_parameters_read (grid_par, unit) - type(grid_parameters_t), intent(out) :: grid_par - integer, intent(in) :: unit - character(30) :: dummy - character :: equals - read (unit, *) dummy, equals, grid_par%threshold_calls - read (unit, *) dummy, equals, grid_par%min_calls_per_channel - read (unit, *) dummy, equals, grid_par%min_calls_per_bin - read (unit, *) dummy, equals, grid_par%min_bins - read (unit, *) dummy, equals, grid_par%max_bins - read (unit, *) dummy, equals, grid_par%stratified - read (unit, *) dummy, equals, grid_par%use_vamp_equivalences - read (unit, *) dummy, equals, grid_par%channel_weights_power - end subroutine grid_parameters_read - -@ %def grid_parameters_read -<>= - interface operator(==) - module procedure grid_parameters_eq - end interface -<>= - function grid_parameters_eq (gp1, gp2) result (eq) - logical :: eq - type(grid_parameters_t), intent(in) :: gp1, gp2 - eq = gp1%threshold_calls == gp2%threshold_calls & - .and. gp1%min_calls_per_channel == gp2%min_calls_per_channel & - .and. gp1%min_calls_per_bin == gp2%min_calls_per_bin & - .and. gp1%min_bins == gp2%min_bins & - .and. gp1%max_bins == gp2%max_bins & - .and.(gp1%stratified .eqv. gp2%stratified )& - .and.(gp1%use_vamp_equivalences .eqv. gp2%use_vamp_equivalences)& - .and. gp1%channel_weights_power == gp2%channel_weights_power - end function grid_parameters_eq - -@ %def grid_parameters_eq -<>= - interface operator(/=) - module procedure grid_parameters_ne - end interface -<>= - function grid_parameters_ne (gp1, gp2) result (ne) - logical :: ne - type(grid_parameters_t), intent(in) :: gp1, gp2 - ne = gp1%threshold_calls /= gp2%threshold_calls & - .or. gp1%min_calls_per_channel /= gp2%min_calls_per_channel & - .or. gp1%min_calls_per_bin /= gp2%min_calls_per_bin & - .or. gp1%min_bins /= gp2%min_bins & - .or. gp1%max_bins /= gp2%max_bins & - .or.(gp1%stratified .neqv. gp2%stratified )& - .or.(gp1%use_vamp_equivalences .neqv. gp2%use_vamp_equivalences)& - .or. gp1%channel_weights_power /= gp2%channel_weights_power - end function grid_parameters_ne - -@ %def grid_parameters_ne -@ -\subsection{MD5 sum collection for grid files} -For checking input in detail, grid files hold various MD5 sums that -correspond to input data. This is a transparent container. -<>= - public :: md5sum_grids_t -<>= - type :: md5sum_grids_t - character(32) :: process = "" - character(32) :: model = "" - character(32) :: parameters = "" - character(32) :: phs = "" - character(32) :: beams = "" - character(32) :: sf_list = "" - character(32) :: mappings = "" - character(32) :: cuts = "" - character(32) :: weight = "" - character(32) :: scale = "" - character(32) :: fac_scale = "" - character(32) :: ren_scale = "" - character(32) :: alpha_s = "" - character(32) :: nlo_setup = "" - end type md5sum_grids_t - -@ %def md5sum_grids_t -<>= - subroutine md5sum_grids_write (md5sum, unit) - type(md5sum_grids_t), intent(in) :: md5sum - integer, intent(in), optional :: unit - integer :: u - u = output_unit (unit) - write (u, *) " md5sum_process = ", '"', md5sum%process, '"' - write (u, *) " md5sum_model = ", '"', md5sum%model, '"' - write (u, *) " md5sum_parameters = ", '"', md5sum%parameters, '"' - write (u, *) " md5sum_phase_space = ", '"', md5sum%phs, '"' - write (u, *) " md5sum_beams = ", '"', md5sum%beams, '"' - write (u, *) " md5sum_sf_list = ", '"', md5sum%sf_list, '"' - write (u, *) " md5sum_mappings = ", '"', md5sum%mappings, '"' - write (u, *) " md5sum_cuts = ", '"', md5sum%cuts, '"' - write (u, *) " md5sum_weight = ", '"', md5sum%weight, '"' - write (u, *) " md5sum_scale = ", '"', md5sum%scale, '"' - write (u, *) " md5sum_fac_scale = ", '"', md5sum%fac_scale, '"' - write (u, *) " md5sum_ren_scale = ", '"', md5sum%ren_scale, '"' - write (u, *) " md5sum_alpha_s = ", '"', md5sum%alpha_s, '"' - write (u, *) " md5sum_nlo_setup = ", '"', md5sum%nlo_setup, '"' - end subroutine md5sum_grids_write - -@ %def md5sum_grids_write - - -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Processes} - -\subsection{Copy routines} - -The copying routine performs a deep copy, which then can be used as a -process instance for generating new sampling points or complete -events. This means, that all information is self-contained -with no pointers pointing back to the original process object or its -subobjects. Data is copied from -initialization and structural information up to the developed -integration grids. Information specific for the sampling point may be -copied or left empty; the assumption is that the copy will be used for -creating new, independent sampling points. - -The target process must be provided with the [[target]] attribute, -because there will be pointers pointing to it or its subobjects. -Conversely, the procedure should not create persistent pointers to the -source process, so this does not need the attribute. - -The source of the copy is polymorphic in principle, so we may apply -this for an extension of the [[process_t]] type. However, the target -must be a plain [[process_t]] object. - -To emphasize that this is neither a complete snapshot not a shallow -copy, we do not overload assignment with this routine. Furthermore, keeping -pointer consistency requires extra arguments for some of the -sub-copies. This would not be possible via defined assignment. -<>= - procedure :: copy_to => process_copy_to -<>= - subroutine process_copy_to (process, copy) - class(process_t), intent(in) :: process - type(process_t), intent(out), target :: copy - integer :: i - copy%type = process%type - call process%meta%copy_to (copy%meta) - call process%config%copy_to (copy%config) - call process%beams%copy_to (copy%beams) - if (allocated (process%strfun)) then - allocate (copy%strfun (size (process%strfun))) - do i = 1, size (process%strfun) - call process%strfun(i)%copy_to (copy%strfun(i)) - end do - end if - if (allocated (process%vamp)) then - allocate (copy%vamp (size (process%vamp))) - do i = 1, size (process%vamp) - call process%vamp(i)%copy_to (copy%vamp(i)) - end do - end if - if (allocated (process%technical_phs)) then - allocate (copy%technical_phs (size (process%technical_phs))) - do i = 1, size (process%technical_phs) - call process%technical_phs(i)%copy_to (copy%technical_phs(i)) - end do - end if - if (allocated (process%effective_state)) then - allocate (copy%effective_state (size (process%effective_state))) - do i = 1, size (process%effective_state) - call process%effective_state(i)%copy_to & - (copy%effective_state(i), copy) - end do - end if - if (allocated (process%component)) then - allocate (copy%component (size (process%component))) - do i = 1, size (process%component) - call process%component(i)%copy_to (copy%component(i)) - end do - end if - if (allocated (process%results)) then - allocate (copy%results (size (process%results))) - do i = 1, size (process%results) - call process%results(i)%copy_to (copy%results(i)) - end do - end if - end subroutine process_copy_to - -@ %def process_copy_to -@ The process instance inherits all data. -Deep-copying a variable list is done by the [[snapshot]] subroutine. -<>= - procedure :: copy_to => process_metadata_copy_to -<>= - subroutine process_metadata_copy_to (meta, copy) - class(process_metadata_t), intent(in) :: meta - type(process_metadata_t), intent(out) :: copy - copy%id = meta%id - copy%run_id = meta%run_id - call var_list_init_snapshot (copy%var_list, meta%var_list) - end subroutine process_metadata_copy_to - -@ %def process_metadata_copy_to -@ The configuration data contain pointers, which should be just -shallow-copied. The QCD record contains only atomic data. Therefore, -a straightforward assignment is sufficient. -<>= - procedure :: copy_to => process_config_data_copy_to -<>= - subroutine process_config_data_copy_to (config, copy) - class(process_config_data_t), intent(in) :: config - type(process_config_data_t), intent(out) :: copy - copy = config - end subroutine process_config_data_copy_to - -@ %def process_config_data_copy_to -@ -<>= - procedure :: copy_to => process_beam_data_copy_to -<>= - subroutine process_beam_data_copy_to (beam, copy) - class(process_beam_data_t), intent(in) :: beam - type(process_beam_data_t), intent(out) :: copy - copy%sqrts = beam%sqrts - copy%use_beams = beam%use_beams - if (beam%use_beams) call beam%data%copy_to (copy%data) - copy%azimuthal_dependence = beam%azimuthal_dependence - copy%lab_is_cm_frame = beam%lab_is_cm_frame - end subroutine process_beam_data_copy_to - -@ %def process_beam_data_copy_to -@ For copying the structure function chain, there is defined assignment. -We have to call this explicitly, since the assignment is not type-bound. -<>= - procedure :: copy_to => process_strfun_data_copy_to -<>= - subroutine process_strfun_data_copy_to (strfun, copy) - class(process_strfun_data_t), intent(in) :: strfun - type(process_strfun_data_t), intent(out) :: copy - copy%n_strfun = strfun%n_strfun - copy%n_mcvar = strfun%n_mcvar - copy%sfchain = strfun%sfchain - end subroutine process_strfun_data_copy_to - -@ %def process_strfun_data_copy_to -@ Here we have to use VAMP's support for deep copy. For histories, -there is currently no support, so we have to skip them. For the -equivalence set, there is defined assignment. -<>= - procedure :: copy_to => process_vamp_data_copy_to -<>= - subroutine process_vamp_data_copy_to (vamp, copy) - class(process_vamp_data_t), intent(in) :: vamp - type(process_vamp_data_t), intent(out) :: copy - copy%grid_filename = vamp%grid_filename - copy%grid_parameters = vamp%grid_parameters - copy%n_channels = vamp%n_channels - copy%n_dim = vamp%n_dim - call vamp_copy_grids (copy%grids, vamp%grids) - copy%equivalences = vamp%equivalences - ! should copy histories here - end subroutine process_vamp_data_copy_to - -@ %def process_vamp_data_copy_to -@ The forest needs a copy of structure, not content. The arrays are -allocated with matching shape, but left empty. (MOLD argument would -be more elegant.) The [[passed]] component is default-initialized as -false. -<>= - procedure :: copy_to => process_technical_phs_copy_to -<>= - subroutine process_technical_phs_copy_to (phs, copy) - class(process_technical_phs_t), intent(in) :: phs - type(process_technical_phs_t), intent(out) :: copy - copy%is_seed = phs%is_seed - copy%sqrts = phs%sqrts - copy%lt = phs%lt - copy%n_trees = phs%n_trees - copy%n_groves = phs%n_groves - call phs%forest%copy_to (copy%forest) - allocate (copy%x (size (phs%x, 1), size (phs%x, 2))); copy%x = 0 - allocate (copy%factor (size (phs%factor))); copy%factor = 0 - copy%volume = phs%volume - copy%vamp_phs_factor = 0 - end subroutine process_technical_phs_copy_to - -@ %def process_technical_phs_copy_to - call state%fac_scale_expr%copy_to (copy%fac_scale_expr) - call state%ren_scale_expr%copy_to (copy%ren_scale_expr) - call state%reweighting_expr%copy_to (copy%reweighting_expr) - copy%alpha_s_at_scale = state%alpha_s_at_scale - copy%sqme = state%sqme - copy%has_separate_evaluators = state%has_separate_evaluators - if (state%has_separate_evaluators) then - allocate (state%eval_trace) - allocate (state%eval_sqme) - allocate (state%eval_flows) - call state%eval_trace%copy_to (copy%eval_trace) - call state%eval_sqme%copy_to (copy%eval_sqme) - call state%eval_flows%copy_to (copy%eval_flows) - else - copy%eval_trace => & - process_copy%component(copy%i_component)%get_eval_trace_ptr () - copy%eval_sqme => & - process_copy%component(copy%i_component)%get_eval_sqme_ptr () - copy%eval_flows => & - process_copy%component(copy%i_component)%get_eval_flows_ptr () - end if - end subroutine process_effective_state_copy_to - -@ %def process_effective_state_copy_to -@ The process pointer must point to the process copy. - -The evaluation status indicates a fresh instance. Index arrays are -assigned via allocation-on-assignment. - -The copy has rely on the copy method of the core component. -Assuming that we cannot (yet) take advantage of the MOLD argument (for -allocate), we call a separate method of the process-variant object -which creates a new uninitialized instance of identical type. -<>= - procedure :: copy_to => process_component_copy_to -<>= - subroutine process_component_copy_to (component, copy, process_copy) - class(process_component_t), intent(in) :: component - type(process_component_t), intent(out) :: copy - type(process_t), intent(in), target :: process_copy - copy%process_ptr => process_copy - select case (component%evaluation_status) - case (CI_STATE_UNDEFINED) - copy%evaluation_status = CI_STATE_UNDEFINED - case default - copy%evaluation_status = CI_STATE_CLEAR - end select - copy%i_mcset = component%i_mcset - copy%i_vamp = component%i_vamp - copy%i_sfchain = component%i_sfchain - copy%i_technical_phs = component%i_technical_phs - copy%i_effective_state = component%i_effective_state - call component%core%allocate_instance (copy%core) - call component%core%copy_to (copy%core) - end subroutine process_component_copy_to - -@ %def process_component_copy_to -@ - - -\subsection{Process status} -This is a block that allows to follow the evaluation status of the -current call, and to trace the status of the current sample. -<>= - public :: process_status_t -<>= - type :: process_status_t - logical :: called = .false. - logical :: passed_strfun_chain = .false. - logical :: passed_mass_threshold = .false. - logical :: passed_kinematics = .false. - logical :: passed_cuts = .false. - logical :: passed_evaluation = .false. - integer :: n_called = 0 - integer :: n_passed_strfun_chain = 0 - integer :: n_passed_mass_threshold = 0 - integer :: n_passed_kinematics = 0 - integer :: n_passed_cuts = 0 - integer :: n_passed_evaluation = 0 - end type process_status_t - -@ %def process_status_t -@ Complete account (for the process log) -<>= - subroutine process_status_write (status, unit) - type(process_status_t), intent(in) :: status - integer, intent(in), optional :: unit - integer :: u - u = output_unit (unit); if (u < 0) return -1 format (1x,A,L1,3x,I9) - write (u, *) "Process evaluation status (count):" - write (u, 1) " called = ", status%called, & - status%n_called - write (u, 1) " passed strfun_chain = ", status%passed_strfun_chain, & - status%n_passed_strfun_chain - write (u, 1) " passed mass_threshold = ", status%passed_mass_threshold, & - status%n_passed_mass_threshold - write (u, 1) " passed kinematics = ", status%passed_kinematics, & - status%n_passed_kinematics - write (u, 1) " passed cuts = ", status%passed_cuts, & - status%n_passed_cuts - write (u, 1) " passed evaluation = ", status%passed_evaluation, & - status%n_passed_evaluation - end subroutine process_status_write - -@ %def process_status_write -@ Counters only (for evaluating complete samples) -<>= - public :: process_status_write_counters -<>= - subroutine process_status_write_counters (status, unit) - type(process_status_t), intent(in) :: status - integer, intent(in), optional :: unit - integer :: u - u = output_unit (unit); if (u < 0) return -1 format (2x,A,1x,I9) - call msg_message ("Process evaluation counters:", unit=u) - write (msg_buffer, 1) "called = ", & - status%n_called - call msg_message (unit=u) - write (msg_buffer, 1) "passed strfun_chain = ", & - status%n_passed_strfun_chain - call msg_message (unit=u) - write (msg_buffer, 1) "passed mass_threshold = ", & - status%n_passed_mass_threshold - call msg_message (unit=u) - write (msg_buffer, 1) "passed kinematics = ", & - status%n_passed_kinematics - call msg_message (unit=u) - write (msg_buffer, 1) "passed cuts = ", & - status%n_passed_cuts - call msg_message (unit=u) - write (msg_buffer, 1) "passed evaluation = ", & - status%n_passed_evaluation - call msg_message (unit=u) - end subroutine process_status_write_counters - -@ %def process_status_write_counters -<>= - subroutine process_status_reset_flags (status) - type(process_status_t), intent(inout) :: status - status%called = .false. - status%passed_strfun_chain = .false. - status%passed_mass_threshold = .false. - status%passed_kinematics = .false. - status%passed_cuts = .false. - status%passed_evaluation = .false. - end subroutine process_status_reset_flags - -@ %def process_status_reset_flags -@ Complete reset. Make use of default initialization. -<>= - subroutine process_status_reset_counters (status) - type(process_status_t), intent(out) :: status - end subroutine process_status_reset_counters - -@ %def process_status_reset_counters -@ Set a flag and increment the associated counters: -<>= - subroutine process_status_called (status) - type(process_status_t), intent(inout) :: status - status%called = .true. - status%n_called = status%n_called + 1 - end subroutine process_status_called - - subroutine process_status_passed_strfun_chain (status) - type(process_status_t), intent(inout) :: status - status%passed_strfun_chain = .true. - status%n_passed_strfun_chain = status%n_passed_strfun_chain + 1 - end subroutine process_status_passed_strfun_chain - - subroutine process_status_passed_mass_threshold (status) - type(process_status_t), intent(inout) :: status - status%passed_mass_threshold = .true. - status%n_passed_mass_threshold = status%n_passed_mass_threshold + 1 - end subroutine process_status_passed_mass_threshold - - subroutine process_status_passed_kinematics (status) - type(process_status_t), intent(inout) :: status - status%passed_kinematics = .true. - status%n_passed_kinematics = status%n_passed_kinematics + 1 - end subroutine process_status_passed_kinematics - - subroutine process_status_passed_cuts (status) - type(process_status_t), intent(inout) :: status - status%passed_cuts = .true. - status%n_passed_cuts = status%n_passed_cuts + 1 - end subroutine process_status_passed_cuts - - subroutine process_status_passed_evaluation (status) - type(process_status_t), intent(inout) :: status - status%passed_evaluation = .true. - status%n_passed_evaluation = status%n_passed_evaluation + 1 - end subroutine process_status_passed_evaluation - -@ %def process_status_called -@ %def process_status_passed_strfun_chain -@ %def process_status_passed_mass_threshold -@ %def process_status_passed_kinematics -@ %def process_status_passed_cuts -@ %def process_status_passed_evaluation -@ -\subsection{Kinematics data} - -Two additional derived types encapsulate the information associated to the -``in'' and ``out'' phasespace points. As the first ``out'' point is the only -one in the usual case of ordinary matrix elements, it is treated special. In -particular, the identity evaluator used for snapshotting the structure function -chain is unset, and the corresponding interaction points directly into the -chain. -<>= - type :: kinematic_configuration_in_t -! type(phs_forest_t) :: forest -! real(default), dimension(:,:), allocatable :: x -! real(default), dimension(:), allocatable :: phs_factor -! real(default) :: phs_volume = 0 -! real(default) :: vamp_phs_factor = 0 -! real(default) :: sqrts = 0 -! type(lorentz_transformation_t) :: lt = identity -! logical :: passed - end type kinematic_configuration_in_t - - type :: kinematic_configuration_out_t -! type(subevt_t) :: subevt -! type(eval_tree_t) :: cut_expr -! type(eval_tree_t) :: scale_expr -! type(eval_tree_t) :: fac_scale_expr -! type(eval_tree_t) :: ren_scale_expr -! type(eval_tree_t) :: reweighting_expr -! real(kind=default) :: sqme -! real(kind=default) :: phs_weight = 0 -! real(kind=default) :: reweighting_factor = 0 -! real(kind=default) :: scale = 0 -! real(kind=default) :: fac_scale = 0 -! real(kind=default) :: ren_scale = 0 -! real(kind=default) :: alpha_s_at_scale = 0 -! type(evaluator_t) :: eval_trace - type(evaluator_t) :: eval_beam_flows -! type(evaluator_t) :: eval_sqme -! type(evaluator_t) :: eval_flows - type(interaction_t), pointer :: strfun - type(evaluator_t) :: strfun_snapshot -! logical :: passed - end type kinematic_configuration_out_t - -@ %def kinematic_configuration_in_t -@ %def kinematic_configuration_out_t -@ -\subsection{The process type} -<>= - public :: process_t -<>= - type :: process_t_obsolete - private -! integer :: type = PRC_UNKNOWN - type(process_t), pointer :: copy => null () - logical :: is_original = .true. - type(process_t), pointer :: original => null () - type(process_t), pointer :: working_copy => null () - logical :: in_use = .true. -! type(string_t) :: id - logical :: initialized = .false. - logical :: has_matrix_element = .false. - logical :: use_hi_color_factors = .false. -! logical :: use_beams = .true. - logical :: has_extra_evaluators = .true. - logical :: beams_are_set = .false. - logical :: is_cascade_decay = .false. - type(flavor_t), dimension(:), allocatable :: flv_in - type(flavor_t), dimension(:), allocatable :: flv_out_eff - type(flavor_t), dimension(:), allocatable :: flv_out_real -! type(beam_data_t) :: beam_data -! character(32) :: md5sum = "" - type(process_library_t), pointer :: prc_lib => null () - integer :: lib_index = 0 - integer :: store_index = 0 -! type(model_t), pointer :: model -! integer :: n_strfun = 0 -! integer :: n_par_strfun = 0 - integer :: n_par_phs = 0 - integer :: n_par_ci = 0 - integer :: n_par = 0 -! logical :: azimuthal_dependence = .false. - logical :: vamp_grids_defined = .false. -! logical :: sqrts_known = .false. - logical :: sqrts_hat_known = .false. -! real(default) :: sqrts = 0 - real(default) :: sqrts_hat = 0 - real(default), dimension(:), allocatable :: x_strfun - real(default), dimension(:), allocatable :: x_phs - real(default), dimension(:), allocatable :: x_ci - integer :: n_channels = 0 - integer :: n_bins = 0 - integer :: channel = 0 -! logical :: lab_is_cm_frame = .true. - type(lorentz_transformation_t) :: lt_cm_to_lab = identity - type(process_status_t) :: status - real(default), dimension(:), allocatable :: mass_in - real(default) :: flux_factor = 0 - real(default) :: averaging_factor = 0 - real(default) :: sf_mapping_factor = 0 - real(default) :: sample_function_value = 0 - logical :: negative_weights = .false. -! type(qcd_parameters_t) :: qcd - character(32) :: md5sum_alpha_s - ! type(strfun_chain_t) :: sfchain -! type(core_interaction_t) :: ci -! integer :: ci_type = CI_UNDEFINED - logical :: fatal_beam_decay = .true. - character(32) :: md5sum_phs = "" -! type(vamp_equivalences_t) :: vamp_eq - integer, dimension(:), allocatable :: j_beam - integer, dimension(:), allocatable :: j_in - ! j_out applies to the _effective_ final state - integer, dimension(:), allocatable :: j_out -! type(var_list_t) :: var_list -! type(parse_node_t), pointer :: cut_pn => null () -! type(parse_node_t), pointer :: weight_pn => null () -! type(parse_node_t), pointer :: scale_pn => null () -! type(parse_node_t), pointer :: fac_scale_pn => null () -! type(parse_node_t), pointer :: ren_scale_pn => null () - logical, dimension(:), allocatable :: active_channel -! type(string_t) :: filename_current_grid -! type(string_t) :: filename_best_grid - type(md5sum_grids_t) :: md5sum_grids -! type(grid_parameters_t) :: grid_parameters - integer, dimension(:), allocatable :: pass_array - integer, dimension(:), allocatable :: n_calls_array -! type(vamp_grids) :: grids -! type(vamp_history), dimension(:), allocatable :: v_history -! type(vamp_history), dimension(:,:), allocatable :: v_histories - type(integration_results_t) :: results -! type(kinematic_configuration_in_t), allocatable, dimension(:) :: & -! kinematics_in -! type(kinematic_configuration_out_t), allocatable, dimension(:) :: & -! kinematics_out -! integer :: n_kinematics_in = 0 -! integer :: n_kinematics_out = 0 - logical :: trivial_kinematics = .false. - integer, dimension(:), allocatable :: sqme_diagonal_entries - character(32) :: md5sum_nlo_setup - end type process_t_obsolete - -@ %def process_t -@ Initialization. We set up the hard-interaction parameters and make -them available in the variable list (which extends the variable list -of the current model). Finally, we initialize the subevent that -is used for evaluating expressions. - -The flag [[use_beams]] may be set false. In that case, beam (and -structure function) data are meaningless or are skipped. For a -scattering process, a head-to-head collision is assumed. For a decay -process, the particle is assumed to decay in its rest frame. The -initial state is assumed unpolarized. - -If a variable list is provided as an argument, it replaces the model -variable list. This implies that it should be linked to the model -variable list. -<>= - subroutine process_init & - (process, prc_lib, process_lib_index, process_store_index, & - process_id, model, var_list, use_beams) - type(process_t), intent(out), target :: process - type(process_library_t), intent(in), target :: prc_lib - integer, intent(in) :: process_lib_index - integer, intent(in) :: process_store_index - type(string_t), intent(in) :: process_id - type(model_t), intent(in), target :: model - type(var_list_t), intent(in), target :: var_list - logical, intent(in), optional :: use_beams - integer :: n_in, n_out_eff, n_tot_eff - integer :: n_out_real, n_tot_real - integer :: n_beam - integer :: i - process%prc_lib => prc_lib - process%lib_index = process_lib_index - process%store_index = process_store_index - process%id = process_id - process%md5sum = process_library_get_process_md5sum & - (process%prc_lib, process%lib_index) - call core_interaction_init (process%ci, prc_lib, process_lib_index, & - process_id, model) - process%has_matrix_element = & - core_interaction_get_n_flv_eff (process%ci) /= 0 - process%use_hi_color_factors = & - var_list_get_lval (var_list, var_str ("?read_color_factors")) - process%model => core_interaction_get_model_ptr (process%ci) - if (.not. core_interaction_is_valid (process%ci)) then - return - else - process%id = core_interaction_get_id (process%ci) - if (.not. process%has_matrix_element) then - process%initialized = .true. - return - end if - end if - if (present (use_beams)) then - process%use_beams = use_beams - process%has_extra_evaluators = use_beams - end if -! n_in = core_interaction_get_n_in (process%ci) - n_out_real = core_interaction_get_n_out_real (process%ci) - n_tot_real = core_interaction_get_n_tot_real (process%ci) - n_out_eff = core_interaction_get_n_out_eff (process%ci) - n_tot_eff = core_interaction_get_n_tot_eff (process%ci) - select case (n_in) - case (1); process%type = PRC_DECAY - case (2); process%type = PRC_SCATTERING - end select - allocate (process%flv_in (n_in)) - call flavor_init (process%flv_in, & - core_interaction_get_first_pdg_in (process%ci), process%model) - allocate (process%flv_out_real (n_out_real)) - call flavor_init (process%flv_out_real, & - core_interaction_get_first_pdg_out_real (process%ci), process%model) - allocate (process%flv_out_eff (n_out_eff)) - call flavor_init (process%flv_out_eff, & - core_interaction_get_first_pdg_out_eff (process%ci), process%model) - allocate (process%mass_in (n_in)) - process%mass_in = flavor_get_mass (process%flv_in) - if (process%use_beams) then - n_beam = n_in - process%averaging_factor = 1 - else - n_beam = 0 - process%averaging_factor = & - 1._default / product (flavor_get_multiplicity (process%flv_in)) - end if - call process_assign_global_var_list (process, var_list) - - process%fatal_beam_decay = & - var_list_get_lval (var_list, var_str ("?fatal_beam_decay")) - - call var_list_append_int (process%var_list, & - var_str ("n_in"), n_in, intrinsic=.true.) - call var_list_append_int (process%var_list, & - var_str ("n_out_eff"), n_out_eff, intrinsic=.true.) - call var_list_append_int (process%var_list, & - var_str ("n_tot_eff"), n_tot_eff, intrinsic=.true.) - call var_list_append_int (process%var_list, & - var_str ("n_out_real"), n_out_real, intrinsic=.true.) - call var_list_append_int (process%var_list, & - var_str ("n_tot_real"), n_tot_real, intrinsic=.true.) - call var_list_append_real_ptr (process%var_list, & - var_str ("sqrts"), process%sqrts, process%sqrts_known, & - intrinsic=.true.) - call var_list_append_real_ptr (process%var_list, & - var_str ("sqrts_hat"), process%sqrts_hat, process%sqrts_hat_known, & - intrinsic=.true.) - allocate (process%j_beam (n_beam)) - allocate (process%j_in (n_in)) - allocate (process%j_out (n_out_eff)) - process%filename_current_grid = "" - process%filename_best_grid = "" - process%initialized = .true. - process%trivial_kinematics = core_interaction_trivial_kinematics ( & - process%ci) - process%n_kinematics_in = core_interaction_get_n_kinematics_in ( & - process%ci) - process%n_kinematics_out = core_interaction_get_n_kinematics_out ( & - process%ci) - allocate (process%kinematics_in (process%n_kinematics_in)) - allocate (process%kinematics_out (process%n_kinematics_out)) - process%ci_type = core_interaction_get_type (process%ci) - if (process%trivial_kinematics) then - process%negative_weights = & - var_list_get_lval (var_list, var_str ("?negative_weights")) - else - process%negative_weights = .true. - end if - process%n_par_ci = core_interaction_get_n_x (process%ci) - do i = 1, process%n_kinematics_out - call subevt_init (process%kinematics_out(i)%subevt, & - n_beam + n_in + n_out_eff) - end do - process%md5sum_nlo_setup = nlo_setup_md5sum ( & - process_library_get_nlo_setup (prc_lib, process_id)) - end subroutine process_init - -@ %def process_init -@ The QCD parameters, i.e., the treatment of $\alpha_s$, is an issue of -its own, so we delegate this to a separate subroutine. The input data -pointers should be assigned if there is a structure function setup which -contains those data. Otherwise they are null, and we take the info from -the variable list. - -If LHAPDF is required and not yet initialized, initialization is done -here as a side-effect, and the status change is recorded. -<>= - public :: process_setup_qcd -<>= - subroutine process_setup_qcd (process, lhapdf_status, pdf_builtin_status, & - lhapdf_data, pdf_builtin_data, os_data, var_list) - type(process_t), intent(inout) :: process - type(lhapdf_status_t), intent(inout) :: lhapdf_status - type(pdf_builtin_status_t), intent(inout) :: pdf_builtin_status - type(lhapdf_data_t), intent(in), pointer :: lhapdf_data - type(pdf_builtin_data_t), intent(in), pointer :: pdf_builtin_data - type(os_data_t), intent(in) :: os_data - type(var_list_t), intent(in) :: var_list - type(string_t) :: lhapdf_dir, lhapdf_file - integer :: lhapdf_member - type(string_t) :: pdf_builtin_set - call qcd_parameters_basic_setup (process%qcd, var_list) - if (associated (lhapdf_data)) then - call lhapdf_data_get_public_info (lhapdf_data, & - lhapdf_dir, lhapdf_file, lhapdf_member) - call qcd_parameters_setup_lhapdf (process%qcd, lhapdf_status, & - lhapdf_dir, lhapdf_file, lhapdf_member) - else - call qcd_parameters_setup_lhapdf (process%qcd, lhapdf_status, & - var_list=var_list) - end if - if (associated (pdf_builtin_data)) then - pdf_builtin_set = pdf_builtin_get_name (pdf_builtin_data) - call qcd_parameters_setup_pdf_builtin (process%qcd, pdf_builtin_status, & - os_data%pdf_builtin_datapath, pdf_builtin_set) - else - call qcd_parameters_setup_pdf_builtin (process%qcd, pdf_builtin_status, & - os_data%pdf_builtin_datapath, var_list=var_list) - end if - process%md5sum_alpha_s = qcd_parameters_get_md5sum (process%qcd) - end subroutine process_setup_qcd - -@ %def process_setup_qcd -Return the type of PDFs -<>= - public :: process_get_strfun_type -<>= - function process_get_strfun_type(process) result(type) - type(process_t), intent(in) :: process - integer :: type - type = strfun_chain_get_strfun_type(process%sfchain) - end function process_get_strfun_type -@ %def process_get_strfun_type -Return the member of the PDF used -<>= - public :: process_get_strfun_set -<>= - function process_get_strfun_set(process) result(set) - type(process_t), intent(in) :: process - integer :: set - set = strfun_chain_get_strfun_set(process%sfchain) - end function process_get_strfun_set -@ %def process_get_strfun_set -@ Make a snapshot of the global variable list and link it to the process -variables. This can be redone, so make sure a previous snapshot is deleted. -<>= - public :: process_assign_global_var_list -<>= - subroutine process_assign_global_var_list (process, var_list) - type(process_t), intent(inout) :: process - type(var_list_t), intent(in), optional, target :: var_list - type(var_list_t), pointer :: var_list_snapshot - var_list_snapshot => var_list_get_next_ptr (process%var_list) - if (associated (var_list_snapshot)) then - call var_list_final (var_list_snapshot) - deallocate (var_list_snapshot) - end if - allocate (var_list_snapshot) - call var_list_link (process%var_list, var_list_snapshot) - if (present (var_list)) then - call var_list_init_snapshot (var_list_snapshot, var_list) - else - call var_list_init_snapshot (var_list_snapshot, & - model_get_var_list_ptr (process%model)) - end if - end subroutine process_assign_global_var_list - -@ %def process_assign_global_var_list -@ Finalization. In process copies, some components are just pointers -to the original, so they should not be finalized separately. -<>= - recursive subroutine process_final (process) - type(process_t), intent(inout), target :: process - integer :: i - call process_delete_copies (process) - process%initialized = .false. - process%type = PRC_UNKNOWN - process%sqrts_known = .false. - process%sqrts_hat_known = .false. - if (allocated (process%sqme_diagonal_entries)) & - deallocate (process%sqme_diagonal_entries) - call strfun_chain_final (process%sfchain) - call core_interaction_final (process%ci) - do i = 1, process%n_kinematics_in - call phs_forest_final (process%kinematics_in(i)%forest) - end do - do i = 1, process%n_kinematics_out - call evaluator_final (process%kinematics_out(i)%eval_trace) - call evaluator_final (process%Kinematics_out(i)%eval_beam_flows) - call evaluator_final (process%kinematics_out(i)%eval_sqme) - call evaluator_final (process%kinematics_out(i)%eval_flows) - if (i /= 1) & - call evaluator_final (process%kinematics_out(i)%strfun_snapshot) - if (process%is_original) then - call eval_tree_final (process%kinematics_out(i)%cut_expr) - call eval_tree_final (process%kinematics_out(i)%reweighting_expr) - call eval_tree_final (process%kinematics_out(i)%scale_expr) - call eval_tree_final (process%kinematics_out(i)%fac_scale_expr) - call eval_tree_final (process%kinematics_out(i)%ren_scale_expr) - end if - end do - call vamp_equivalences_final (process%vamp_eq) - if (process%is_original) then - call var_list_final (process%var_list) - end if - if (process%vamp_grids_defined) then - call vamp_delete_grids (process%grids) - end if - call process_final_vamp_history (process) - end subroutine process_final - -@ %def process_final -@ Output. This prints lots of stuff. The [[verbose]] option is for -state matrices, the [[show_momentum_sum]] option prints the sums of -incoming and outgoing momenta for all interactions, and the -[[show_mass]] option computes and prints the signed invariant mass for -all four-momenta. -<>= - public :: process_write -<>= - subroutine process_write & - (process, unit, verbose, show_momentum_sum, show_mass) - type(process_t), intent(in) :: process - integer, intent(in), optional :: unit - logical, intent(in), optional :: verbose, show_momentum_sum, show_mass - integer :: u, i, j - u = output_unit (unit); if (u < 0) return - write (u, "(A)") repeat ("=", 72) - write (u, *) "Process data:", process%lib_index, & - "(", char (process%id), ")" - select case (process%type) - case (PRC_UNKNOWN); write (u, *) " [unknown]" - case (PRC_DECAY); write (u, *) " [decay]" - case (PRC_SCATTERING); write (u, *) " [scattering]" - end select - write (u, *) " is cascade decay = ", process%is_cascade_decay - write (u, *) " use separate beam setup = ", process%use_beams - call beam_data_write (process%beam_data, u) - if (process%use_beams) then - write (u, *) " number of structure functions = ", process%n_strfun - write (u, *) " number of strfun parameters = ", process%n_par_strfun - end if - write (u, *) " number of auxilliary parameters = ", process%n_par_ci - write (u, *) " number of phase space parameters = ", process%n_par_phs - write (u, *) " number of parameters total = ", process%n_par - write (u, *) " number of integration channels = ", process%n_channels - write (u, *) " number of bins per channel = ", process%n_bins - if (process%sqrts_known) then - write (u, *) " c.m. energy (sqrts) = ", process%sqrts - else - write (u, *) " c.m. energy (sqrts) = [unknown]" - end if - write (u, *) " number of in type phase space configurations = ", & - process%n_kinematics_in - write (u, *) " number of out type phase space configuration = ", & - process%n_kinematics_out - write (u, *) repeat ("-", 72) - call process_status_write (process%status, u) - write (u, *) repeat ("-", 72) - write (u, *) "Evaluation results:" - if (process%sqrts_hat_known) then - write (u, *) " c.m. energy (sqrts_hat) = ", process%sqrts_hat - else - write (u, *) " c.m. energy (sqrts_hat) = [unknown]" - end if - write (u, "(1x,A)", advance="no") " Colliding partons = " - if (allocated (process%flv_in)) then - do i = 1, size (process%flv_in) - if (i == 2) write (u, "(1x)", advance="no") - call flavor_write (process%flv_in(i), u) - end do - write (u, *) - else - write (u, *) "[undefined]" - end if - if (allocated (process%mass_in)) then - write (u, *) " Incoming parton masses = ", process%mass_in - else - write (u, *) " Incoming parton masses = [unknown]" - end if - write (u, *) " In-state flux factor = ", process%flux_factor - write (u, *) " Strfun mapping factor = ", process%sf_mapping_factor - if (.not. process%use_beams) then - write (u, *) " Spin averaging factor = ", process%averaging_factor - end if - write (u, *) " Sample-function value = ", & - process%sample_function_value - write (u, *) repeat ("-", 72) - write (u, *) "Structure function parameters =" - write (u, *) " Use beams = ", process%use_beams - write (u, *) " x values = " - if (allocated (process%x_strfun)) then - write (u, *) process%x_strfun - else - write (u, *) " [not allocated]" - end if - write (u, *) "Phase space integration parameters = " - if (allocated (process%x_phs)) then - write (u, *) process%x_phs - else - write (u, *) "[empty]" - end if - write (u, *) "Auxiliary parameters = " - if (allocated (process%x_ci)) then - write (u, *) process%x_ci - else - write (u, *) "[empty]" - end if - write (u, *) repeat ("-", 72) - call qcd_parameters_write (process%qcd, u) - write (u, *) repeat ("-", 72) - write (u, *) "Phase-space integration parameters (input) =" - if (allocated (process%x_phs)) then - write (u, *) process%x_phs - else - write (u, *) "[empty]" - end if - write (u, *) "Integration channel =", process%channel - if (.not. process%lab_is_cm_frame) then - write (u, *) "Tranformation c.m. -> lab =" - call lorentz_transformation_write (process%lt_cm_to_lab, u) - end if - if (process%use_beams) then - call strfun_chain_write & - (process%sfchain, unit, verbose, show_momentum_sum, show_mass) - end if - write (u, *) repeat ("-", 72) - call qcd_parameters_write (process%qcd, u) - write (u, "(A)") repeat ("-", 72) - call core_interaction_write & - (process%ci, unit, verbose, show_momentum_sum, show_mass) - write (u, "(A)") repeat ("-", 72) - call phs_forest_write (process%kinematics_in(1)%forest, unit) - write (u, "(A)") repeat ("-", 72) - call vamp_equivalences_write (process%vamp_eq, unit) - write (u, "(A)") repeat ("-", 72) - call var_list_write (process%var_list, unit) - write (u, "(A)") repeat ("-", 72) - write (u, "(A)") "Cut expression:" - call eval_tree_write (process%kinematics_out(1)%cut_expr, unit) - write (u, "(A)") repeat ("-", 72) - write (u, "(A)") "Weight expression:" - call eval_tree_write (process%kinematics_out(1)%reweighting_expr, unit) - write (u, "(A)") repeat ("-", 72) - write (u, "(A)") "General scale expression:" - call eval_tree_write (process%kinematics_out(1)%scale_expr, unit) - write (u, "(A)") repeat ("-", 72) - write (u, "(A)") "Factorization scale expression:" - call eval_tree_write (process%kinematics_out(1)%fac_scale_expr, unit) - write (u, "(A)") repeat ("-", 72) - write (u, "(A)") "Renormalization scale expression:" - call eval_tree_write (process%kinematics_out(1)%ren_scale_expr, unit) - write (u, "(A)") repeat ("-", 72) - write (u, "(A)", advance="no") & - " Beam indices (in the trace evaluator): " - if (allocated (process%j_beam)) then - write (u, *) process%j_beam - else - write (u, *) "[undefined]" - end if - write (u, "(A)", advance="no") & - " In-parton indices (in the trace evaluator): " - if (allocated (process%j_out)) then - write (u, *) process%j_in - else - write (u, *) "[undefined]" - end if - write (u, "(A)", advance="no") & - " Out-parton indices (in the trace evaluator): " - if (allocated (process%j_out)) then - write (u, *) process%j_out - else - write (u, *) "[undefined]" - end if - write (u, "(A)") repeat ("-", 72) - write (u, *) "in type phase space configurations:" - do i = 1, process%n_kinematics_in - write (u, *) "*** configuration", i, ":" - write (u, *) " passed: ", process%kinematics_in(i)%passed - write (u, *) " Phase-space integration parameters (complete) =" - if (allocated (process%kinematics_in(i)%x)) then - do j = 1, size (process%kinematics_in(i)%x, 2) - write (u, *) " ", process%kinematics_in(i)%x(:,j) - end do - else - write (u, *) " [empty]" - end if - write (u, *) " Channels: phase-space factors =" - if (allocated (process%kinematics_in(i)%phs_factor)) then - write (u, *) " ", process%kinematics_in(i)%phs_factor - else - write (u, *) " [not allocated]" - end if - write (u, *) " VAMP phs factor = ", & - process%kinematics_in(i)%vamp_phs_factor - write (u, *) " Phase space volume = ", & - process%kinematics_in(i)%phs_volume - if (i == 1) cycle - write (u, *) " sqrts = ", process%kinematics_in(i)%sqrts - write (u, "(A)") " " // repeat ("-", 68) - write (u, *) " Lorentz transformation =" - call lorentz_transformation_write (process%kinematics_in(i)%lt) - write (u, "(A)") " " // repeat ("-", 68) - end do - write (u, "(A)") repeat ("-", 72) - write (u, *) "out type phase space configurations:" - do i = 1, process%n_kinematics_out - write (u, *) "*** configuration", i, ":" - write (u, *) " passed: ", process%kinematics_out(i)%passed - write (u, *) " Squared matrix element = ", & - process%kinematics_out(i)%sqme - write (u, *) " Phasespace weight = ", & - process%kinematics_out(i)%phs_weight - write (u, *) " General scale = ", process%kinematics_out(i)%scale - write (u, *) " Renormalization scale = ", & - process%kinematics_out(i)%ren_scale - write (u, *) " Factorization scale = ", & - process%kinematics_out(i)%fac_scale - if (process%has_extra_evaluators) then - write (u, "(A)") " " // & - "Trace including color factors (beams + strfun + hard interaction)" - write (u, "(A)") " " // repeat ("-", 68) - call evaluator_write (process%kinematics_out(i)%eval_trace, & - unit, verbose, show_momentum_sum, show_mass) - write (u, "(A)") " " // repeat ("-", 68) - write (u, "(A)") " " // & - "Exclusive sqme including color factors (beams + strfun + hard interaction)" - call evaluator_write (process%kinematics_out(i)%eval_sqme, & - unit, verbose, show_momentum_sum, show_mass) - write (u, "(A)") " " // repeat ("-", 68) - write (u, "(A)") " " // & - "Color flow coefficients (beams + strfun + hard interaction)" - call evaluator_write (process%kinematics_out(i)%eval_flows, & - unit, verbose, show_momentum_sum, show_mass) - end if - if (process%use_beams) then - write (u, "(A)") " " // repeat ("-", 68) - write (u, "(A)") "Incoming beams with all color contractions" - call evaluator_write (process%kinematics_out(i)%eval_beam_flows, & - unit, verbose, show_momentum_sum, show_mass) - write (u, "(A)") " " // repeat ("-", 68) - write (u, *) " Structure function chain snapshot:" - call interaction_write (process%kinematics_out(i)%strfun, & - unit, verbose, show_momentum_sum, show_mass) - end if - write (u, "(A)") " " // repeat ("-", 68) - write (u, "(A)") "Subevent used by cuts, weight, and scale:" - call subevt_write (process%kinematics_out(i)%subevt, unit) - end do - write (u, "(A)") repeat ("-", 72) - if (process%vamp_grids_defined) then - write (u, "(A)") "Integration grid data" - write (u, *) - write (u, "(A)") "Grid file name (current) = " // '"' & - // char (process%filename_current_grid) // '"' - write (u, "(A)") "Grid file name (best) = " // '"' & - // char (process%filename_best_grid) // '"' - write (u, *) - write (u, "(A)") "MD5 sums stored in grid file" - call md5sum_grids_write (process%md5sum_grids, u) - write (u, *) - write (u, "(A)") "Grid parameters stored in grid file" - call grid_parameters_write (process%grid_parameters, u) - write (u, *) - write (u, "(A)", advance="no") "Iterations: pass array = " - if (allocated (process%pass_array)) then - write (u, *) process%pass_array - else - write (u, *) "[not allocated]" - end if - write (u, "(A)", advance="no") "Iterations: n_calls array = " - if (allocated (process%n_calls_array)) then - write (u, *) process%n_calls_array - else - write (u, *) "[not allocated]" - end if - write (u, *) - write (u, "(A)", advance="no") "VAMP grids:" - call vamp_write_grids (process%grids, u) - else - write (u, "(A)") "VAMP grids: [empty]" - end if - write (u, "(A)") repeat ("-", 72) - if (allocated (process%v_history)) then - call msg_message (" Global history [vamp]:", unit=u) - call vamp_write_history (u, process%v_history) - else - call msg_message (" Global history [vamp]: [undefined]", unit=u) - end if - write (u, "(A)") repeat ("-", 72) - if (allocated (process%v_histories)) then - call msg_message (" Channel histories [vamp]:", unit=u) - call vamp_write_history (u, process%v_histories) - else - call msg_message (" Channel histories [vamp]: [undefined]", unit=u) - end if - write (u, *) - call integration_results_write (process%results, unit) - call integration_results_write_grove_weights (process%results, unit) - end subroutine process_write - -@ %def process_write -\subsection{Process pointers} -We will need arrays of process pointers, therefore this type, which we keep -transparent: -<>= - public :: process_p -<>= - type :: process_p - type(process_t), pointer :: ptr - end type process_p - -@ %def process_p -@ Set up an array of process pointers, given the process IDs. -<>= - public :: process_ptr_array_create -<>= - subroutine process_ptr_array_create (prc_array, process_id) - type(process_p), dimension(:), intent(out), allocatable :: prc_array - type(string_t), dimension(:), intent(in) :: process_id - integer :: proc, n_proc - n_proc = size (process_id) - allocate (prc_array (n_proc)) - do proc = 1, n_proc - prc_array(proc)%ptr => process_store_get_process_ptr (process_id(proc)) - end do - end subroutine process_ptr_array_create - -@ %def process_ptr_array_create -@ -\subsection{Accessing contents} -Check if the process has been successfully initialized: -<>= - public :: process_is_valid -<>= - function process_is_valid (process) result (flag) - logical :: flag - type(process_t), intent(in) :: process - flag = process%initialized - end function process_is_valid - -@ %def process_is_valid -@ -Check whether we have trivial kinematics (aka non-subtraction). -<>= - public :: process_has_trivial_kinematics -<>= - pure function process_has_trivial_kinematics (process) result (flag) - type(process_t), intent(in) :: process - logical :: flag - flag = process%trivial_kinematics - end function process_has_trivial_kinematics - -@ %def process_has_trivial_kinematics -@ -Check if the process has a nonvanishing matrix element: -<>= - public :: process_has_matrix_element -<>= - function process_has_matrix_element (process) result (flag) - logical :: flag - type(process_t), intent(in) :: process - flag = process%has_matrix_element - end function process_has_matrix_element - -@ %def process_has_matrix_element -@ Check if the process has been integrated: -<>= - public :: process_has_integral -<>= - function process_has_integral (process) result (flag) - logical :: flag - type(process_t), intent(in) :: process - flag = integration_results_exist (process%results) - end function process_has_integral - -@ %def process_has_integral -@ Check if the uses a nontrivial beam setup: -<>= - public :: process_uses_beams -<>= - function process_uses_beams (process) result (flag) - logical :: flag - type(process_t), intent(in) :: process - flag = process%use_beams - end function process_uses_beams - -@ %def process_uses_beams -@ Return the process ID. -<>= - public :: process_get_id -<>= - function process_get_id (process) result (process_id) - type(string_t) :: process_id - type(process_t), intent(in) :: process - process_id = process%id - end function process_get_id - -@ %def process_get_id -@ Return the index in the process library: -<>= - public :: process_get_lib_index -<>= - function process_get_lib_index (process) result (index) - integer :: index - type(process_t), intent(in) :: process - index = process%lib_index - end function process_get_lib_index - -@ %def process_get_store_index -@ Return the index in the process store: -<>= - public :: process_get_store_index -<>= - function process_get_store_index (process) result (index) - integer :: index - type(process_t), intent(in) :: process - index = process%store_index - end function process_get_store_index - -@ %def process_get_store_index -@ Return the MD5 sum of the process configuration. -<>= - public :: process_get_md5sum - public :: process_get_md5sum_parameters - public :: process_get_md5sum_results - public :: process_get_md5sum_polarized -<>= - function process_get_md5sum (process) result (md5sum) - character(32) :: md5sum - type(process_t), intent(in) :: process - md5sum = process%md5sum - end function process_get_md5sum - - function process_get_md5sum_parameters (process) result (md5sum) - character(32) :: md5sum - type(process_t), intent(in) :: process - md5sum = model_get_parameters_md5sum (process%model) - end function process_get_md5sum_parameters - - function process_get_md5sum_results (process) result (md5sum) - character(32) :: md5sum - type(process_t), intent(in) :: process - md5sum = integration_results_get_md5sum (process%results) - end function process_get_md5sum_results - - function process_get_md5sum_polarized (process) result (md5sum) - character(32) :: md5sum - type(process_t), intent(in) :: process - md5sum = model_get_polarized_md5sum (process%model) - end function process_get_md5sum_polarized - -@ %def process_get_md5sum -@ %def process_get_md5sum_parameters -@ %def process_get_md5sum_results -@ Return the model pointer. -<>= - public :: process_get_model_ptr -<>= - function process_get_model_ptr (process) result (model) - type(model_t), pointer :: model - type(process_t), intent(in) :: process - model => process%model - end function process_get_model_ptr - -@ %def process_get_model_ptr -@ Return the number of partons for the hard interaction -<>= - public :: process_get_n_in - public :: process_get_n_out_real - public :: process_get_n_out_eff - public :: process_get_n_tot_real - public :: process_get_n_tot_eff -<>= - function process_get_n_in (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = core_interaction_get_n_in (process%ci) - end function process_get_n_in - - function process_get_n_out_eff (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = core_interaction_get_n_out_eff (process%ci) - end function process_get_n_out_eff - - function process_get_n_out_real (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = core_interaction_get_n_out_real (process%ci) - end function process_get_n_out_real - - function process_get_n_tot_real (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = core_interaction_get_n_tot_real (process%ci) - end function process_get_n_tot_real - - function process_get_n_tot_eff (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = core_interaction_get_n_tot_eff (process%ci) - end function process_get_n_tot_eff - - function process_get_n_flv_real (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = core_interaction_get_n_flv_real (process%ci) - end function process_get_n_flv_real - - function process_get_n_flv_eff (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = core_interaction_get_n_flv_eff (process%ci) - end function process_get_n_flv_eff - -@ %def process_get_n_in -@ %def process_get_n_out_real -@ %def process_get_n_tot_real -@ %def process_get_n_flv_real -@ %def process_get_n_out_eff -@ %def process_get_n_tot_eff -@ %def process_get_n_flv_eff -@ Return the indices of incoming beams / partons. These indices apply -to the subevents in the evaluator interactions. - -Without allocate-on-assignment, let us use subroutines. Note that the outgoing -parton indices correspond to the \emph{effective} partons in a dipole / -recombination setup. -<>= - public :: process_get_beam_index - public :: process_get_incoming_parton_index - public :: process_get_outgoing_parton_index -<>= - subroutine process_get_beam_index (process, index) - type(process_t), intent(in) :: process - integer, dimension(:), allocatable, intent(out) :: index - allocate (index (size (process%j_beam))) - index = process%j_beam - end subroutine process_get_beam_index - - subroutine process_get_incoming_parton_index (process, index) - type(process_t), intent(in) :: process - integer, dimension(:), allocatable, intent(out) :: index - allocate (index (size (process%j_in))) - index = process%j_in - end subroutine process_get_incoming_parton_index - - subroutine process_get_outgoing_parton_index (process, index) - type(process_t), intent(in) :: process - integer, dimension(:), allocatable, intent(out) :: index - allocate (index (size (process%j_out))) - index = process%j_out - end subroutine process_get_outgoing_parton_index - -@ %def process_get_beam_index -@ %def process_get_incoming_parton_index -@ %def process_get_outgoing_parton_index -@ Return the beam/incoming particle flavors and energies. -<>= - public :: process_get_beam_flv - public :: process_get_beam_energy -<>= - function process_get_beam_flv (process) result (flv_in) - type(flavor_t), dimension(:), allocatable :: flv_in - type(process_t), intent(in) :: process - allocate (flv_in (process_get_n_in (process))) - if (process%beam_data%initialized) flv_in = process%beam_data%flv - end function process_get_beam_flv - - function process_get_beam_energy (process) result (energy) - real(default), dimension(:), allocatable :: energy - type(process_t), intent(in) :: process - allocate (energy (process_get_n_in (process))) - energy = beam_data_get_energy (process%beam_data) - end function process_get_beam_energy - -@ %def process_get_beam_flv process_get_beam_energy -@ Return the number of integration parameters. -<>= - public :: process_get_n_parameters -<>= - function process_get_n_parameters (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = process%n_par - end function process_get_n_parameters - -@ %def process_get_n_parameters -@ Return the number of integration channels. -<>= - public :: process_get_n_channels -<>= - function process_get_n_channels (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = process%n_channels - end function process_get_n_channels - -@ %def process_get_n_channels -@ Return the number of bins per integration channel. -<>= - public :: process_get_n_bins -<>= - function process_get_n_bins (process) result (n) - integer :: n - type(process_t), intent(in) :: process - n = process%n_bins - end function process_get_n_bins - -@ %def process_get_n_bins -@ Return the process status record. -<>= - public :: process_get_status -<>= - function process_get_status (process) result (status) - type(process_status_t) :: status - type(process_t), intent(in) :: process - status = process%status - end function process_get_status - -@ %def process_get_status -@ Return the process scales and the $\alpha_s$ value. If no index is supplied, -the first out configuration is used. -<>= - public :: process_get_scale - public :: process_get_fac_scale - public :: process_get_ren_scale - public :: process_get_alpha_s -<>= - function process_get_scale (process, i) result (scale) - real(default) :: scale - type(process_t), intent(in) :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - scale = process%kinematics_out(idx)%scale - end function process_get_scale - - function process_get_fac_scale (process, i) result (scale) - real(default) :: scale - type(process_t), intent(in) :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - scale = process%kinematics_out(idx)%fac_scale - end function process_get_fac_scale - - function process_get_ren_scale (process, i) result (scale) - real(default) :: scale - type(process_t), intent(in) :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - scale = process%kinematics_out(idx)%ren_scale - end function process_get_ren_scale - - function process_get_alpha_s (process, i) result (alpha_s) - real(default) :: alpha_s - type(process_t), intent(in) :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - alpha_s = process%kinematics_out(idx)%alpha_s_at_scale - end function process_get_alpha_s - -@ %def process_get_scale -@ %def process_get_fac_scale -@ %def process_get_ren_scale -@ %def process_get_alpha_s -@ Return the c.m. energy and the partonic c.m. energy. -<>= - public :: process_get_sqrts - public :: process_get_sqrts_hat -<>= - function process_get_sqrts (process) result (sqrts) - real(default) :: sqrts - type(process_t), intent(in) :: process - sqrts = process%sqrts - end function process_get_sqrts - - function process_get_sqrts_hat (process) result (sqrts_hat) - real(default) :: sqrts_hat - type(process_t), intent(in) :: process - sqrts_hat = process%sqrts_hat - end function process_get_sqrts_hat - -@ %def process_get_sqrts -@ %def process_get_sqrts_hat -@ Return the squared matrix element. This includes structure -function factors and the hard interaction squared matrix element, -traced over all quantum numbers, but no phase space factors. If no index -supplied, we use the first out configuration. -<>= - public :: process_get_sqme -<>= - function process_get_sqme (process, i) result (sqme) - real(default) :: sqme - type(process_t), intent(in) :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - sqme = process%kinematics_out(idx)%sqme - end function process_get_sqme - -@ %def process_get_sqme -@ Return the user-defined reweighting factor that should be applied to the -matrix element. In the sample-function value (integration and event -generation), this is already included. Same procedure as everywhere regarding -[[i]]. -<>= - public :: process_get_reweighting_factor -<>= - function process_get_reweighting_factor (process, i) result (weight) - real(default) :: weight - type(process_t), intent(in) :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - weight = process%kinematics_out(idx)%reweighting_factor - end function process_get_reweighting_factor - -@ %def process_get_reweighting_factor -@ Return the final integration results. If [[last]] is present and -set, the final iteration; otherwise, the final average. -<>= - public :: process_get_n_calls - public :: process_get_integral - public :: process_get_error - public :: process_get_accuracy - public :: process_get_chi2 - public :: process_get_rel_error - public :: process_get_time_per_event - public :: process_get_efficiency - public :: process_get_sample_function_value -<>= - function process_get_n_calls (process, last, it, pass) result (n_calls) - integer :: n_calls - type(process_t), intent(in) :: process - logical, intent(in), optional :: last - integer, intent(in), optional :: it, pass - n_calls = integration_results_get_n_calls & - (process%results, last, it, pass) - end function process_get_n_calls - - function process_get_integral (process, last, it, pass) result (integral) - real(default) :: integral - type(process_t), intent(in) :: process - logical, intent(in), optional :: last - integer, intent(in), optional :: it, pass - integral = integration_results_get_integral & - (process%results, last, it, pass) - end function process_get_integral - - function process_get_error (process, last, it, pass) result (error) - real(default) :: error - type(process_t), intent(in) :: process - logical, intent(in), optional :: last - integer, intent(in), optional :: it, pass - error = integration_results_get_error & - (process%results, last, it, pass) - end function process_get_error - - function process_get_accuracy (process, last, it, pass) result (accuracy) - real(default) :: accuracy - type(process_t), intent(in) :: process - logical, intent(in), optional :: last - integer, intent(in), optional :: it, pass - accuracy = integration_results_get_accuracy & - (process%results, last, it, pass) - end function process_get_accuracy - - function process_get_chi2 (process, last, it, pass) result (chi2) - real(default) :: chi2 - type(process_t), intent(in) :: process - logical, intent(in), optional :: last - integer, intent(in), optional :: it, pass - chi2 = integration_results_get_chi2 & - (process%results, last, it, pass) - end function process_get_chi2 - - function process_get_efficiency (process, last, it, pass) result (efficiency) - real(default) :: efficiency - type(process_t), intent(in) :: process - logical, intent(in), optional :: last - integer, intent(in), optional :: it, pass - efficiency = integration_results_get_efficiency & - (process%results, last, it, pass) - end function process_get_efficiency - - function process_get_rel_error (process, last, it, pass) result (error) - real(default) :: error - type(process_t), intent(in) :: process - logical, intent(in), optional :: last - integer, intent(in), optional :: it, pass - real(default) :: integral, abs_error - integral = integration_results_get_integral & - (process%results, last, it, pass) - abs_error = integration_results_get_error & - (process%results, last, it, pass) - if (integral /= 0) then - error = abs_error / abs (integral) - else - error = 0 - end if - end function process_get_rel_error - - function process_get_time_per_event (process) result (tpe) - real(default) :: tpe - type(process_t), intent(in) :: process - tpe = integration_results_get_time_per_event (process%results) - end function process_get_time_per_event - - function process_get_sample_function_value (process) result (value) - real(default) :: value - type(process_t), intent(in) :: process - value = process%sample_function_value - end function process_get_sample_function_value - -@ %def process_get_n_calls -@ %def process_get_integral -@ %def process_get_error -@ %def process_get_accuracy -@ %def process_get_chi2 -@ %def process_get_efficiency -@ %def process_get_rel_error -@ %def process_get_time_per_event -@ %def process_get_sample_function_value -@ Return the current (i.e., last) integration pass index, and the -index of the last iteration \emph{within} this pass. The third -routine returns the absolute index of the last iteration. -<>= - public :: process_get_current_pass - public :: process_get_current_it -<>= - function process_get_current_pass (process) result (pass) - integer :: pass - type(process_t), intent(in) :: process - pass = integration_results_get_current_pass (process%results) - end function process_get_current_pass - - function process_get_current_it (process) result (it) - integer :: it - type(process_t), intent(in) :: process - it = integration_results_get_current_it (process%results) - end function process_get_current_it - - function process_get_last_it (process) result (it) - integer :: it - type(process_t), intent(in) :: process - it = integration_results_get_last_it (process%results) - end function process_get_last_it - -@ %def process_get_current_pass -@ %def process_get_current_it -@ Get the number of ``out'' kinematics. -<>= - public :: process_get_n_kinematics_out -<>= - function process_get_n_kinematics_out (proc) result (n) - type(process_t), intent(in) :: proc - integer :: n - n = size (proc%kinematics_out) - end function process_get_n_kinematics_out - -@ %def process_get_n_kinematics_out -@ Query whether the process (aka the core interaction) supports sqme and flow -evaluators. -<>= - public :: process_has_eval_sqme - public :: process_has_eval_flows -<>= - function process_has_eval_sqme (process) result (flag) - type(process_t), intent(in) :: process - logical :: flag - flag = core_interaction_has_eval_sqme (process%ci) - end function process_has_eval_sqme - - function process_has_eval_flows (process) result (flag) - type(process_t), intent(in) :: process - logical :: flag - flag = core_interaction_has_eval_flows (process%ci) - end function process_has_eval_flows -@ %def process_has_eval_sqme -@ %def process_has_eval_flows -@ Query whether the core interaction represents a physical (aka positive) matrix -elements. This influences the event generation. -<>= - public :: process_is_physical -<>= - function process_is_physical (process) result (flag) - type(process_t), intent(in) :: process - logical :: flag - flag = core_interaction_is_physical (process%ci) - end function process_is_physical - -@ %def process_is_physical -@ Return pointers to the sqme and flows evaluators. If no beams are -used, these are identical to the evaluators of the hard interaction. -<>= - public :: process_get_eval_sqme_ptr - public :: process_get_eval_flows_ptr -<>= - function process_get_eval_sqme_ptr (process, i) result (eval) - type(evaluator_t), pointer :: eval - type(process_t), intent(in), target :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - if (process%has_extra_evaluators) then - eval => process%kinematics_out(idx)%eval_sqme - else - eval => core_interaction_get_eval_sqme_ptr (process%ci, idx) - end if - end function process_get_eval_sqme_ptr - - function process_get_eval_flows_ptr (process, i) result (eval) - type(evaluator_t), pointer :: eval - type(process_t), intent(in), target :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - if (process%has_extra_evaluators) then - eval => process%kinematics_out(idx)%eval_flows - else - eval => core_interaction_get_eval_flows_ptr (process%ci, idx) - end if - end function process_get_eval_flows_ptr - -@ %def process_get_eval_sqme_ptr process_get_eval_flows_ptr -@ Return pointers to the interaction and to the sqme and flows -evaluators of the hard interaction. -<>= - public :: process_get_ci_int_ptr - public :: process_get_ci_eval_sqme_ptr - public :: process_get_ci_eval_flows_ptr -<>= - function process_get_ci_int_ptr (process, i) result (int) - type(interaction_t), pointer :: int - type(process_t), intent(in), target :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - int => core_interaction_get_int_ptr (process%ci, idx) - end function process_get_ci_int_ptr - - function process_get_ci_eval_sqme_ptr (process, i) result (eval) - type(evaluator_t), pointer :: eval - type(process_t), intent(in), target :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - eval => core_interaction_get_eval_sqme_ptr (process%ci, idx) - end function process_get_ci_eval_sqme_ptr - - function process_get_ci_eval_flows_ptr (process, i) result (eval) - type(evaluator_t), pointer :: eval - type(process_t), intent(in), target :: process - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - eval => core_interaction_get_eval_flows_ptr (process%ci, idx) - end function process_get_ci_eval_flows_ptr - -@ %def process_get_ci_int_ptr -@ %def process_get_ci_eval_sqme_ptr process_get_ci_eval_flows_ptr -@ Return any s-channel mapping for a particular tree in the decay -forest. -<>= -! public :: process_get_s_mapping -<>= -! subroutine process_get_s_mapping (process, channel, flag, mass, width) -! type(process_t), intent(in) :: process -! integer, intent(in) :: channel -! logical, intent(out) :: flag -! real(default), intent(out) :: mass, width -! call phs_forest_get_s_mapping & -! (process%forest, channel, flag, mass, width) -! end subroutine process_get_s_mapping - -@ %def process_get_s_mapping -@ -\subsection{Setting values directly} -Mark a process as a cascade decay. The effect is that the process -subevent will be boosted to the incoming c.m. frame (i.e., the -rest frame of the decaying particle) before applying cuts etc. -<>= - public :: process_mark_as_cascade_decay -<>= - subroutine process_mark_as_cascade_decay (process) - type(process_t), intent(inout) :: process - process%is_cascade_decay = .true. - end subroutine process_mark_as_cascade_decay - -@ %def process_mark_as_cascade_decay -@ -Some values can be set directly; this is used when reading an event -from file. -<>= - public :: process_set_scale - public :: process_set_fac_scale - public :: process_set_ren_scale - public :: process_set_alpha_s - public :: process_set_sqme -<>= - subroutine process_set_scale (process, scale, i) - type(process_t), intent(inout) :: process - real(default), intent(in) :: scale - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - process%kinematics_out(idx)%scale = scale - end subroutine process_set_scale - - subroutine process_set_fac_scale (process, scale, i) - type(process_t), intent(inout) :: process - real(default), intent(in) :: scale - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - process%kinematics_out(idx)%fac_scale = scale - end subroutine process_set_fac_scale - - subroutine process_set_ren_scale (process, scale, i) - type(process_t), intent(inout) :: process - real(default), intent(in) :: scale - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - process%kinematics_out(idx)%ren_scale = scale - end subroutine process_set_ren_scale - - subroutine process_set_alpha_s (process, alpha_s) - type(process_t), intent(inout) :: process - real(default), intent(in) :: alpha_s - process%qcd%alpha_s_at_scale = alpha_s - end subroutine process_set_alpha_s - - subroutine process_set_sqme (process, sqme, i) - type(process_t), intent(inout) :: process - real(default), intent(in) :: sqme - integer, intent(in), optional :: i - integer :: idx - idx = 1; if (present (i)) idx = i - process%kinematics_out(idx)%sqme = sqme - end subroutine process_set_sqme - -@ %def process_set_scale -@ %def process_set_fac_scale -@ %def process_set_ren_scale -@ %def process_set_alpha_s -@ %def process_set_sqme -@ - -Setting $\alpha$ is required for evaluating electroweak dipoles. -<>= -public :: process_set_alpha_qed -<>= -subroutine process_set_alpha_qed (process, alpha) -type(process_t), intent(inout) :: process -real(kind=default), intent(in) :: alpha - call core_interaction_set_alpha_qed (process%ci, alpha) -end subroutine process_set_alpha_qed - -@ %def process_set_alpha_qed -@ - -Discard previous results, starting from the current iteration. -<>= - public :: process_discard_results -<>= - subroutine process_discard_results (process, it) - type(process_t), intent(inout) :: process - integer, intent(in) :: it - call integration_results_discard (process%results, it) - end subroutine process_discard_results - -@ %def process_discard_results -@ - -\subsection{Process preparation: beams and structure functions} -Set up the chain of structure functions. The individual types of -structure functions need specific instances. These are just wrappers -around the corresponding [[strfun_chain]] procedures. - -If [[use_beams]] is false, only [[sqrts]] and [[flv]] is set, using -the decaying particle mass (decay) or the [[sqrts]] value in the -argument list (scattering) to set up a local beam record. -<>= - public :: process_setup_beams -<>= - subroutine process_setup_beams (process, beam_data, n_strfun, sqrts, flv) - type(process_t), intent(inout), target :: process - type(beam_data_t), intent(in) :: beam_data - integer, intent(in) :: n_strfun - real(default), intent(in), optional :: sqrts - type(flavor_t), dimension(:), intent(in), optional :: flv - if (.not. process_has_matrix_element (process)) return - if (process%use_beams) then - process%beam_data = beam_data - process%sqrts = beam_data%sqrts - process%sqrts_known = .true. - process%n_strfun = n_strfun - process%azimuthal_dependence = & - .not. all (polarization_is_diagonal (beam_data%pol)) - process%lab_is_cm_frame = beam_data%lab_is_cm_frame .and. n_strfun == 0 - call strfun_chain_init (process%sfchain, beam_data, n_strfun) - else - select case (process%type) - case (PRC_DECAY) - process%sqrts = process%mass_in(1) - call beam_data_init_decay (process%beam_data, process%flv_in) - case (PRC_SCATTERING) - if (present (sqrts)) then - process%sqrts = sqrts - call beam_data_init_sqrts & - (process%beam_data, process%sqrts, process%flv_in) - else - call msg_fatal ("Process setup: neither beams nor sqrts are known") - process%sqrts = 0 - end if - end select - process%sqrts_known = .true. - end if - end subroutine process_setup_beams - -@ %def process_setup_beams -@ Set the beam momenta directly without changing anything else. This -is a shortcut that is needed for initiating cascade decays (i.e., the -single beam is the decaying particle). -<>= - public :: process_set_beam_momenta -<>= - subroutine process_set_beam_momenta (process, p) - type(process_t), intent(inout), target :: process - type(vector4_t), dimension(:), intent(in) :: p - type(interaction_t), pointer :: ci_int - if (.not. process%trivial_kinematics) call msg_bug ( & - "process_set_beam_momenta not yet implemented for dipole kinematics!") - if (.not. process_has_matrix_element (process)) return - if (process%use_beams) then - call strfun_chain_set_beam_momenta (process%sfchain, p) - else - ci_int => core_interaction_get_int_ptr (process%ci, 1) - call interaction_set_momenta (ci_int, p, outgoing=.false.) - end if - process%sqrts_hat = process%sqrts - process%lab_is_cm_frame = .false. - process%beams_are_set = .true. - end subroutine process_set_beam_momenta - -@ %def process_set_beam_momenta -@ Configure structure functions. EPA: support only a single data set. - -The index [[i]] is the overall structure function counter. [[line]] -indicates the beam(s) for which the structure function applies, either -1 or 2, or 0 for both beams. -<>= - public :: process_set_strfun -<>= - interface process_set_strfun - module procedure process_set_strfun_lhapdf - module procedure process_set_strfun_pdf_builtin - module procedure process_set_strfun_isr - module procedure process_set_strfun_epa - module procedure process_set_strfun_ewa - module procedure process_set_strfun_circe1 - module procedure process_set_strfun_circe2 - module procedure process_set_strfun_escan - module procedure process_set_strfun_beam_events - module procedure process_set_strfun_user - end interface - -<>= - subroutine process_set_strfun_lhapdf & - (process, i, line, lhapdf_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters - type(lhapdf_data_t), intent(in) :: lhapdf_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, lhapdf_data, n_parameters) - end if - end subroutine process_set_strfun_lhapdf - - subroutine process_set_strfun_pdf_builtin & - (process, i, line, pdf_builtin_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters - type(pdf_builtin_data_t), intent(in) :: pdf_builtin_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, pdf_builtin_data, n_parameters) - end if - end subroutine process_set_strfun_pdf_builtin - - subroutine process_set_strfun_isr & - (process, i, line, isr_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters - type(isr_data_t), intent(in) :: isr_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, isr_data, n_parameters) - end if - end subroutine process_set_strfun_isr - - subroutine process_set_strfun_epa & - (process, i, line, epa_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters -! type(epa_data_t), dimension(:), intent(in) :: epa_data - type(epa_data_t), intent(in) :: epa_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, epa_data, n_parameters) - end if - end subroutine process_set_strfun_epa - - subroutine process_set_strfun_ewa & - (process, i, line, ewa_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters -! type(ewa_data_t), dimension(:), intent(in) :: ewa_data - type(ewa_data_t), intent(inout) :: ewa_data - integer :: k - integer, dimension(:,:), allocatable :: flvs_tot - integer, dimension(:), allocatable :: flvs - allocate (flvs_tot(process_get_n_tot_real (process), & - process_get_n_flv_real (process))) - allocate (flvs(process_get_n_flv_real (process))) - flvs_tot = core_interaction_get_flv_states_real (process%ci) - flvs(:) = abs(flvs_tot (line,:)) - do k = 1, size (flvs) - if (flvs(1) /= flvs (k)) & - call msg_fatal ("EWA approximation is not applicable when " & - // "mixing W and Z for a single beam.") - end do - if (flvs(1) < 23 .or. flvs(1) > 24) & - call msg_fatal ("Hard scattering process does not match EWA.") - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, ewa_data, n_parameters, flvs(1)) - end if - end subroutine process_set_strfun_ewa - - subroutine process_set_strfun_circe1 & - (process, i, line, circe1_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters - type(circe1_data_t), intent(in) :: circe1_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, circe1_data, n_parameters) - end if - end subroutine process_set_strfun_circe1 - - subroutine process_set_strfun_circe2 & - (process, i, line, circe2_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters - type(circe2_data_t), intent(in) :: circe2_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, circe2_data, n_parameters) - end if - end subroutine process_set_strfun_circe2 - - subroutine process_set_strfun_escan & - (process, i, line, escan_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters - type(escan_data_t), intent(in) :: escan_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, escan_data, n_parameters) - end if - end subroutine process_set_strfun_escan - - subroutine process_set_strfun_beam_events & - (process, i, line, beam_events_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters - type(beam_events_data_t), intent(in) :: beam_events_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, beam_events_data, n_parameters) - end if - end subroutine process_set_strfun_beam_events - - subroutine process_set_strfun_user & - (process, i, line, user_data, n_parameters) - type(process_t), intent(inout), target :: process - integer, intent(in) :: i, line, n_parameters - type(sf_user_data_t), intent(in) :: user_data - if (process%use_beams) then - call strfun_chain_set_strfun & - (process%sfchain, i, line, user_data, n_parameters) - end if - end subroutine process_set_strfun_user - -@ %def process_set_strfun -@ Configure structure function mappings. -<>= - public :: process_allocate_strfun_mappings - public :: process_set_strfun_mapping -<>= - subroutine process_allocate_strfun_mappings & - (process, multichannel, n_mapping) - type(process_t), intent(inout) :: process - logical, intent(in) :: multichannel - integer, intent(in), optional :: n_mapping - if (.not. multichannel .and. present (n_mapping)) then - call strfun_chain_allocate_mappings & - (process%sfchain, multichannel, n_mapping, 1) - else if (multichannel .and. .not. present (n_mapping)) then - call msg_bug ("multichannel structure functions not supported") - call strfun_chain_allocate_mappings & - (process%sfchain, multichannel, 1, process%n_channels) -! allocate (process%sf_factor (process%n_channels)) - else - print *, "multichannel = ", multichannel - call msg_bug ("allocate strfun mappings: inconsistent parameters") - end if - end subroutine process_allocate_strfun_mappings - - subroutine process_set_strfun_mapping (process, i, ch, index, type, par) - type(process_t), intent(inout) :: process - integer, intent(in) :: i, ch - integer, intent(in) :: type - integer, dimension(:), intent(in) :: index - real(default), dimension(:), intent(in) :: par - call strfun_chain_set_mapping (process%sfchain, i, ch, index, type, par) - end subroutine process_set_strfun_mapping - -@ %def process_allocate_strfun_mappings -@ %def process_set_strfun_mapping -@ Complete structure function initialization. Make evaluators within -the structure function chain, and the trace evaluator within the hard -interaction. Connect the two, and make another trace evaluator which -sums over all quantum numbers. This evaluator should have only a -single matrix element. - -NB: For a beam setup without structure functions and nontrivial -([[n_kinematics_out]] $>1$), a slight optimization might be gained by ommiting -the snapshot and directly linking all interactions / evaluators to the beam -interaction. -<>= - public :: process_connect_strfun -<>= - subroutine process_connect_strfun (process, ok) - type(process_t), intent(inout), target :: process - logical, intent(out), optional :: ok - integer, dimension(:), allocatable :: coll_index - type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in - type(quantum_numbers_mask_t) :: mask_tr - type(evaluator_t), pointer :: eval_sfchain, eval_ci - type(interaction_t), pointer :: int_beam, int_ci - integer :: n_in, i, j - if (.not. process_has_matrix_element (process)) return - n_in = core_interaction_get_n_in (process%ci) - allocate (mask_in (n_in)) - if (process%use_beams) then - call strfun_chain_make_evaluators (process%sfchain, ok) - allocate (coll_index (n_in)) - coll_index = strfun_chain_get_colliding_particles (process%sfchain) - mask_in = strfun_chain_get_colliding_particles_mask (process%sfchain) - else - mask_in = new_quantum_numbers_mask (.true., .true., .true.) - end if - call core_interaction_init_trace & - (process%ci, mask_in, process%use_hi_color_factors) - if (process%use_beams) then - int_beam => strfun_chain_get_beam_int_ptr (process%sfchain) - eval_sfchain => strfun_chain_get_last_evaluator_ptr (process%sfchain) - mask_tr = new_quantum_numbers_mask (.true., .true., .true.) - do j = 1, process%n_kinematics_out - eval_ci => core_interaction_get_eval_trace_ptr (process%ci, j) - int_ci => core_interaction_get_int_ptr (process%ci, j) - if (associated (eval_sfchain)) then - if (j == 1) then - process%kinematics_out(j)%strfun => evaluator_get_int_ptr ( & - eval_sfchain) - else - call evaluator_init_identity ( & - process%kinematics_out(j)%strfun_snapshot, eval_sfchain) - process%kinematics_out(j)%strfun => evaluator_get_int_ptr ( & - process%kinematics_out(j)%strfun_snapshot) - end if - else - if (j == 1) then - process%kinematics_out(j)%strfun => int_beam - else - call evaluator_init_identity ( & - process%kinematics_out(j)%strfun_snapshot, int_beam) - process%kinematics_out(j)%strfun => evaluator_get_int_ptr ( & - process%kinematics_out(j)%strfun_snapshot) - end if - end if - do i = 1, n_in - call interaction_set_source_link & - (int_ci, i, process%kinematics_out(j)%strfun, coll_index(i)) -! call evaluator_set_source_link & -! (eval_ci, i, process%kinematics_out(j)%strfun, coll_index(i)) - end do - call evaluator_init_product & - (process%kinematics_out(j)%eval_trace, & - process%kinematics_out(j)%strfun, eval_ci, mask_tr, mask_tr) - if (evaluator_is_empty (process%kinematics_out(j)%eval_trace)) then - call msg_fatal ("Mismatch between structure functions and hard process") - if (present (ok)) ok = .false. - return - end if - end do - process%n_par_strfun = & - strfun_chain_get_n_parameters_tot (process%sfchain) - allocate (process%x_strfun (process%n_par_strfun)) - else - ! Even without a beam setup, we make sure that all sfchain pointers point - ! to a valid (albeit empty) interaction - int_beam => strfun_chain_get_beam_int_ptr (process%sfchain) - do j = 1, process%n_kinematics_out - process%kinematics_out(j)%strfun => int_beam - end do - end if - process%n_par = process%n_par_strfun + process%n_par_ci + process%n_par_phs - if (present (ok)) ok = .true. - end subroutine process_connect_strfun - -@ %def process_connect_strfun -@ Check whether the current setting of relevant variables matches the -current beam setup. -<>= - public :: process_check_beam_setup -<>= - subroutine process_check_beam_setup (process, var_list) - type(process_t), intent(in) :: process - type(var_list_t), intent(in) :: var_list - logical :: sqrts_known - real(default) :: sqrts - sqrts_known = var_list_is_known (var_list, "sqrts") - sqrts = var_list_get_rval (var_list, "sqrts") - if (process%use_beams) then - select case (process%type) - case (PRC_SCATTERING) - if (sqrts_known) then - call beam_data_check_scattering (process%beam_data, sqrts) - else - call beam_data_check_scattering (process%beam_data) - end if - end select - end if - end subroutine process_check_beam_setup - -@ %def process_check_beam_setup -@ -\subsection{Process preparation: phase space} -Initialize the phase-space forest. First check whether the process -exists in [[filename_in]], if present, and try to read it there. If -this fails, generate a new phase-space forest and write it to -[[filename_out]], if present, otherwise to a temporary file. Then -read again. - -Because [[variable_limits]] depends on the structure function setup, -structure functions should be done first. -<>= - public :: process_setup_phase_space -<>= - subroutine process_setup_phase_space (process, rebuild_phs, & - os_data, phs_par, mapping_defaults, filename_out, & - filename_in, filename_vis, vis_channels, check_phs_file, ok) - type(process_t), intent(inout), target :: process - logical, intent(in) :: rebuild_phs - type(os_data_t), intent(in) :: os_data - type(phs_parameters_t), intent(inout) :: phs_par - type(mapping_defaults_t), intent(in) :: mapping_defaults - type(string_t), intent(in), optional :: & - filename_out, filename_in, filename_vis - logical, intent(in) :: vis_channels - logical, intent(in), optional :: check_phs_file - logical, intent(out), optional :: ok - type(string_t) :: filename, setenv_tex, setenv_mp, & - pipe, pipe_dvi - logical :: exist, check - integer :: extra_off_shell - type(cascade_set_t) :: cascade_set - logical :: variable_limits - integer :: n_in, n_out, n_tot, n_flv - type(flavor_t), dimension(:,:), allocatable :: flv - integer :: n_par_strfun - logical, dimension(:), allocatable :: strfun_rigid - character(32) :: md5sum_process, md5sum_model, md5sum_parameters - integer :: unit, unit_tex, unit_dev, status - logical :: phs_ok, phs_match, wrote_file - integer :: i - type(phs_forest_t) :: forest - phs_ok = .false. - phs_match = .false. - variable_limits = process%n_strfun /= 0 - n_in = core_interaction_get_n_in (process%ci) - n_out = core_interaction_get_n_out_real (process%ci) - n_tot = core_interaction_get_n_tot_real (process%ci) - n_flv = core_interaction_get_n_flv_real (process%ci) - allocate (flv (n_tot, n_flv)) - call flavor_init (flv, & - core_interaction_get_flv_states_real (process%ci), process%model) - md5sum_process = process%md5sum - md5sum_model = model_get_md5sum (process%model) - md5sum_parameters = model_get_parameters_md5sum (process%model) - phs_par%sqrts = process%sqrts - if (present (filename_in)) then - filename = filename_in - check = .false. - else if (.not. rebuild_phs .and. present (filename_out)) then - filename = filename_out - if (present (check_phs_file)) then - check = check_phs_file - else - check = .true. - end if - else - filename = "" - end if - if (filename /= "") then - inquire (file=char(filename), exist=exist) - if (exist) then - if (check) then - call phs_forest_read (forest, filename, & - process%id, n_in, n_out, process%model, phs_ok, & - md5sum_process, md5sum_model, md5sum_parameters, phs_par, & - phs_match) - else - call msg_warning & - ("Validity checks turned off for phase-space file " & - // "'" // char (filename) // "'") - call phs_forest_read (forest, filename, & - process%id, n_in, n_out, process%model, phs_ok) - phs_match = .true. - end if - if (phs_match) call msg_message & - ("Reading phase-space configuration from file '" & - // char (filename) // "'...") - unit = free_unit () - open (unit = unit, file = char (filename), action = "read", & - status = "old") - process%md5sum_phs = md5sum (unit) - close (unit) - if (.not. phs_ok) then - call msg_fatal ("Phase space file '" // char (filename) & - // "': No valid phase space for process '" & - // char (process%id) // "'") - if (present (ok)) ok = .false. - return - end if - else - call msg_message ("Phase space file '" // char (filename) & - // "' not found.") - phs_match = .false. - end if - end if - wrote_file = .false. - if (.not. phs_match) then - call msg_message ("Generating phase space configuration ...") - LOOP_OFF_SHELL: do extra_off_shell = 0, max (n_tot - 3, 0) - call cascade_set_generate (cascade_set, & - process%model, n_in, n_out, flv, phs_par, process%fatal_beam_decay) - if (cascade_set_is_valid (cascade_set)) then - exit LOOP_OFF_SHELL - else if (phs_par%off_shell >= max (n_tot - 3, 0)) then - call msg_error ("Process '" // char (process%id) & - // "': no valid phase-space channels found") - if (present (ok)) ok = .false. - call cascade_set_final (cascade_set) - return - else - write (msg_buffer, "(A,1x,I0)") & - "Process '" // char (process%id) & - // "': no valid phase-space channels found for " & - // "phs_off_shell =", phs_par%off_shell - call msg_warning () - call msg_message ("Increasing phs_off_shell") - phs_par%off_shell = phs_par%off_shell + 1 - end if - end do LOOP_OFF_SHELL - unit = free_unit () - if (present (filename_out)) then - open (unit, file=char(filename_out), & - action="readwrite", status="replace") - else - open (unit, action="readwrite", status="scratch") - end if - write (unit, *) "process ", char (process%id) - write (unit, *) - call cascade_set_write_process_bincode_format (cascade_set, unit) - write (unit, *) - write (unit, *) " md5sum_process = ", '"', md5sum_process, '"' - write (unit, *) " md5sum_model = ", '"', md5sum_model, '"' - write (unit, *) " md5sum_parameters = ", '"', md5sum_parameters, '"' - call phs_parameters_write (phs_par, unit) - call cascade_set_write_file_format (cascade_set, unit) - if (vis_channels) then - unit_tex = free_unit () - open (unit=unit_tex, file=char(filename_vis // ".tex"), & - action="write", status="replace") - call cascade_set_write_graph_format (cascade_set, & - filename_vis // "-graphs", process_get_id (process), unit_tex) - close (unit_tex) - call msg_message ("Writing visualized phase space channels file " & - // char(trim(filename_vis)) // "...") - if (os_data%event_analysis_ps) then - BLOCK: do - unit_dev = free_unit () - open (file = "/dev/null", unit = unit_dev, & - action = "write", iostat = status) - if (status /= 0) then - pipe = "" - pipe_dvi = "" - else - pipe = " > /dev/null" - pipe_dvi = " 2>/dev/null 1>/dev/null" - end if - close (unit_dev) - if (os_data%whizard_texpath /= "") then - setenv_tex = & - "TEXINPUTS=" // os_data%whizard_texpath // ":$TEXINPUTS " - setenv_mp = & - "MPINPUTS=" // os_data%whizard_texpath // ":$MPINPUTS " - else - setenv_tex = "" - setenv_mp = "" - end if - call os_system_call (setenv_tex // os_data%latex // " " // & - filename_vis // ".tex " // pipe, status) - if (status /= 0) exit BLOCK - if (os_data%mpost /= "") then - call os_system_call (setenv_mp // os_data%mpost // " " // & - filename_vis // "-graphs.mp" // pipe, status) - else - call msg_fatal ("Could not use MetaPOST.") - end if - if (status /= 0) exit BLOCK - call os_system_call (setenv_tex // os_data%latex // " " // & - filename_vis // ".tex" // pipe, status) - if (status /= 0) exit BLOCK - call os_system_call (os_data%dvips // " -o " // filename_vis & - // ".ps " // filename_vis // ".dvi" // pipe_dvi, status) - if (status /= 0) exit BLOCK - if (os_data%event_analysis_pdf) then - call os_system_call (os_data%ps2pdf // " " // & - filename_vis // ".ps", status) - if (status /= 0) exit BLOCK - end if - exit BLOCK - end do BLOCK - if (status /= 0) then - call msg_error ("Unable to compile analysis output file") - end if - end if - end if - call msg_message ("... done.") - call cascade_set_final (cascade_set) - rewind (unit) - call phs_forest_read (forest, unit, & - process%id, n_in, n_out, process%model, phs_ok) - rewind (unit) - process%md5sum_phs = md5sum (unit) - close (unit) - wrote_file = present (filename_out) - if (.not. phs_ok) then - call msg_bug ("Generated phase space file: " & - // "No valid phase space for process '" & - // char (process%id) // "'") - end if - end if - call phs_forest_set_flavors (forest, flv(:,1)) - call phs_forest_set_parameters & - (forest, mapping_defaults, variable_limits) - call phs_forest_setup_prt_combinations (forest) - call phs_forest_set_equivalences (forest) - if (process%use_beams) then - n_par_strfun = strfun_chain_get_n_parameters_tot (process%sfchain) - allocate (strfun_rigid (n_par_strfun)) - strfun_rigid = strfun_chain_dimension_is_rigid (process%sfchain) - else - n_par_strfun = 0 - allocate (strfun_rigid (0)) - end if - call phs_forest_setup_vamp_equivalences (forest, & - n_par_strfun + process%n_par_ci, & - (/strfun_rigid, (/(.false., i = 1, process%n_par_ci)/)/), & - process%azimuthal_dependence, & - process%vamp_eq) -! call phs_forest_set_global_mappings (forest) - process%n_channels = phs_forest_get_n_channels (forest) - process%n_par_phs = phs_forest_get_n_parameters (forest) - process%n_par = process%n_par_strfun + process%n_par_ci + process%n_par_phs - allocate (process%x_phs (process%n_par_phs)) - process%x_phs = 0 - allocate (process%x_ci (process%n_par_ci)) - process%x_ci = 0 - do i = 1, process%n_kinematics_in - allocate (process%kinematics_in(i)%x(process%n_par, process%n_channels)) - allocate (process%kinematics_in(i)%phs_factor(process%n_channels)) - process%kinematics_in(i)%x = 0 - process%kinematics_in(i)%phs_factor = 0 - process%kinematics_in(i)%forest = forest - call phs_forest_set_parameters (process%kinematics_in(i)%forest, & - mapping_defaults, variable_limits .or. & - core_interaction_varying_sqrts (process%ci, i)) - if (mapping_defaults%enable_s_mapping) then - call phs_forest_set_s_mappings (process%kinematics_in(i)%forest) - end if - end do - allocate (process%active_channel (process%n_channels)) - process%active_channel = .true. - write (msg_buffer, "(A,I0,A,I0,A)") "... found ", process%n_channels, & - " phase space channels, collected in ", & - phs_forest_get_n_groves (forest), & - " groves." - call msg_message () - write (msg_buffer, "(A,I0,A)") "Phase space: found ", & - phs_forest_get_n_equivalences (forest), & - " equivalences between channels." - call msg_message () - if (wrote_file) & - call msg_message ("Wrote phase-space configuration file '" & - // char (filename_out) // "'.") - if (present (ok)) ok = .true. - call phs_forest_final (forest) - end subroutine process_setup_phase_space - -@ %def process_setup_phase_space -@ -\subsection{Process preparation: cuts, weight and scale} -Create a [[subevt]] which holds the relevant event data which are -accessible to cuts, weight and scale. We store beams, incoming -partons, and outgoing partons. Beam remnants and any further virtual -particles are not used, neither are decay products or hadrons (which -do not exist at the integration level). There is flavor information -(as far as possible in the presence of flavor sums), but no helicity -information. - -Allocation has been done in [[process_init]]. Here, we determine the -relevant particle indices in the process (trace) evaluator and fill -the particles initially with zero momenta, but flavors taken from the -beam and hard-interaction definition. If there are flavor sums, we -choose the first flavor in the list. - -The assignment of indices relies on the assumptions that (1) the beams -come first, (2) the incoming partons are located immediately after all -structure-function virtual particles, (3) the outgoing partons are the -children of the first incoming parton. -<>= - public :: process_setup_subevt -<>= - subroutine process_setup_subevt (process) - type(process_t), intent(inout), target :: process - type(interaction_t), pointer :: int - integer :: n_beam, n_in, n_out - integer :: i - n_beam = size (process%j_beam) - n_in = size (process%j_in) - n_out = size (process%j_out) - process%j_beam = (/ (i, i = 1, n_beam) /) - process%j_in = (/ (i + strfun_chain_get_n_vir (process%sfchain), & - i = 1, n_in) /) - do i = 1, process%n_kinematics_out - if (process%use_beams) then - int => evaluator_get_int_ptr (process%kinematics_out(i)%eval_trace) - else - int => core_interaction_get_int_ptr (process%ci, i) - end if - if (i == 1) process%j_out = & - interaction_get_children (int, process%j_in(1)) - call interaction_to_subevt (int, & - process%j_beam, process%j_in, process%j_out, & - process%kinematics_out(i)%subevt) - call subevt_set_pdg_beam (process%kinematics_out(i)%subevt, & - flavor_get_pdg (beam_data_get_flavor (process%beam_data))) - call subevt_set_pdg_incoming (process%kinematics_out(i)%subevt, & - flavor_get_pdg (process%flv_in)) - call subevt_set_pdg_outgoing (process%kinematics_out(i)%subevt, & - flavor_get_pdg (process%flv_out_eff)) - end do - end subroutine process_setup_subevt - -@ %def process_setup_subevt -@ Compile the cut expression and store it as an evaluation tree inside -the process object. Also store the parse node. In subsequent calls, -the setup may be called without providing the parse node, but simply -looking it up. -<>= - public :: process_setup_cuts -<>= - subroutine process_setup_cuts (process, parse_node, md5sum) - type(process_t), intent(inout), target :: process - type(parse_node_t), intent(in), optional, target :: parse_node - character(32), intent(out), optional :: md5sum - integer :: i - if (present (parse_node)) process%cut_pn => parse_node - if (associated (process%cut_pn)) then - do i = 1, process%n_kinematics_out - call eval_tree_init_lexpr & - (process%kinematics_out(i)%cut_expr, process%cut_pn, & - process%var_list, process%kinematics_out(i)%subevt) - end do - end if - if (present (md5sum)) & - md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%cut_expr) - end subroutine process_setup_cuts - -@ %def process_setup_cuts -@ Compile the weight expression and store it as an evaluation tree inside -the process object. -<>= - public :: process_setup_weight -<>= - subroutine process_setup_weight (process, parse_node, md5sum) - type(process_t), intent(inout), target :: process - type(parse_node_t), intent(in), optional, target :: parse_node - character(32), intent(out), optional :: md5sum - integer :: i - if (present (parse_node)) process%weight_pn => parse_node - if (associated (process%weight_pn)) then - do i = 1, process%n_kinematics_out - call eval_tree_init_expr & - (process%kinematics_out(i)%reweighting_expr, process%weight_pn, & - process%var_list, process%kinematics_out(i)%subevt) - end do - end if - if (present (md5sum)) & - md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%reweighting_expr) - end subroutine process_setup_weight - -@ %def process_setup_weight -@ Compile the scale expression and store it as an evaluation tree inside -the process object. -<>= - public :: process_setup_scale -<>= - subroutine process_setup_scale (process, parse_node, md5sum) - type(process_t), intent(inout), target :: process - type(parse_node_t), intent(in), optional, target :: parse_node - character(32), intent(out), optional :: md5sum - integer :: i - if (present (parse_node)) process%scale_pn => parse_node - if (associated (process%scale_pn)) then - do i = 1, process%n_kinematics_out - call eval_tree_init_expr & - (process%kinematics_out(i)%scale_expr, process%scale_pn, & - process%var_list, process%kinematics_out(i)%subevt) - end do - end if - if (present (md5sum)) & - md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%scale_expr) - end subroutine process_setup_scale - -@ %def process_setup_scale -@ -<>= - public :: process_setup_fac_scale -<>= - subroutine process_setup_fac_scale (process, parse_node, md5sum) - type(process_t), intent(inout), target :: process - type(parse_node_t), intent(in), optional, target :: parse_node - character(32), intent(out), optional :: md5sum - integer :: i - if (present (parse_node)) process%fac_scale_pn => parse_node - if (associated (process%fac_scale_pn)) then - do i = 1, process%n_kinematics_out - call eval_tree_init_expr & - (process%kinematics_out(i)%fac_scale_expr, process%fac_scale_pn, & - process%var_list, process%kinematics_out(i)%subevt) - end do - end if - if (present (md5sum)) & - md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%fac_scale_expr) - end subroutine process_setup_fac_scale - -@ %def process_setup_fac_scale -@ -<>= - public :: process_setup_ren_scale -<>= - subroutine process_setup_ren_scale (process, parse_node, md5sum) - type(process_t), intent(inout), target :: process - type(parse_node_t), intent(in), optional, target :: parse_node - character(32), intent(out), optional :: md5sum - integer :: i - if (present (parse_node)) process%ren_scale_pn => parse_node - if (associated (process%ren_scale_pn)) then - do i = 1, process%n_kinematics_out - call eval_tree_init_expr & - (process%kinematics_out(i)%ren_scale_expr, process%ren_scale_pn, & - process%var_list, process%kinematics_out(i)%subevt) - end do - end if - if (present (md5sum)) & - md5sum = eval_tree_get_md5sum (process%kinematics_out(1)%ren_scale_expr) - end subroutine process_setup_ren_scale - -@ %def process_setup_ren_scale -@ -\subsection{Process preparation: VAMP grids} -@ Initialize the grids with uniform channel weight. -<>= - public :: process_setup_grids -<>= - subroutine process_setup_grids (process, grid_parameters, calls) - type(process_t), intent(inout), target :: process - type(grid_parameters_t), intent(in) :: grid_parameters - integer, intent(in) :: calls - integer, dimension(:), allocatable :: num_div - real(default), dimension(:), allocatable :: weights - real(default), dimension(:,:), allocatable :: region - integer :: min_calls - allocate (num_div (process%n_par)) - min_calls = grid_parameters%min_calls_per_bin * process%n_channels - if (min_calls /= 0) then - process%n_bins = max (grid_parameters%min_bins, & - min (calls / min_calls, grid_parameters%max_bins)) - else - process%n_bins = grid_parameters%max_bins - end if - allocate (region (2, process%n_par)) - region(1,:) = 0 - region(2,:) = 1 - allocate (weights (process%n_channels)) - weights = 1 - num_div = process%n_bins - call msg_message ("Creating VAMP integration grids:") - if (grid_parameters%use_vamp_equivalences) & - call msg_message ("Using phase-space channel equivalences.") - call vamp_create_grids (process%grids, region, calls, weights, & - num_div=num_div, stratified=grid_parameters%stratified) - process%vamp_grids_defined = .true. - end subroutine process_setup_grids - -@ %def process_setup_grids -@ -\subsection{Process preparation: Helicity selection counters} -The helicity selection counters can be activated and reset at startup, -removing unnecessary helicities after [[cutoff]] tries. -<>= - public :: process_reset_helicity_selection -<>= - subroutine process_reset_helicity_selection (process, threshold, cutoff) - type(process_t), intent(inout) :: process - real(default), intent(in) :: threshold - integer, intent(in) :: cutoff - call core_interaction_reset_helicity_selection & - (process%ci, threshold, cutoff) - end subroutine process_reset_helicity_selection - -@ %def process_reset_helicity_selection -@ -\subsection{Matrix element evaluation} -Kinematics. This evaluates structure functions as far as momenta are -concerned. The evaluator links automatically transfer the incoming -momenta to the hard interaction. All phase space factors are -evaluated, and the resulting momenta are stored back in the hard -interaction, from there transferred to the appropriate evaluators. - -Once the particle momenta are known, they are transferred to the -[[subevt]] that is used for cut/weight/scale evaluation. The energy -scale is computed right here. - -If [[ok]] is false, there is no valid momentum assignement for the given -$x$ parameters, and the event must be dropped. -<>= - subroutine process_set_kinematics (process, x_in, channel, ok) - type(process_t), intent(inout), target :: process - real(default), dimension(:), intent(in) :: x_in - integer, intent(in) :: channel - logical, intent(out) :: ok - integer :: n, i, off_phs, off_strfun, off_ci, n1, n2 - real(default) :: lda - real(default) :: sqrts - type(lorentz_transformation_t) :: lt - type(interaction_t), pointer :: int - type(evaluator_t), pointer :: eval - type(vector4_t), dimension(:), allocatable :: pin - type(vector4_t) :: pcm - ! Compute MC variable offsets - off_phs = 1 - off_strfun = off_phs + process%n_par_phs - off_ci = off_strfun + process%n_par_strfun - process%x_phs = x_in(off_phs:off_strfun - 1) - if (process%n_par_strfun > 0) & - process%x_strfun = x_in(off_strfun:off_ci - 1) - if (process%n_par_ci > 0) & - process%x_ci = x_in(off_ci:) - process%channel = channel - ! We need this array later - if (process%type == PRC_DECAY) then - allocate (pin(1)) - else - allocate (pin(2)) - end if - ! Calculate incoming seed momenta - if (process%use_beams) then -! ! Use beams? -> Evaluate structure function chain -!!! Commented this out because allow_s_channel_mapping no longer exists -! if (process%allow_s_channel_mapping) then -! call strfun_chain_set_kinematics (process%sfchain, process%x_strfun, & -! phs_forest_tree_has_global_mapping ( & -! process%kinematics_in(1)%forest, channel), & -! ok=ok) -! else - call strfun_chain_set_kinematics (process%sfchain, process%x_strfun, ok=ok) -!!! Previous version: Commented this out because n_par_hi no longer exists. -! n1 = process%n_par_hi -! n2 = process%n_par_hi + process%n_par_strfun -! if (strfun_chain_multichannel_enabled (process%sfchain)) then -! process%x(n1+1:n2, channel) = process%x_strfun -! call strfun_chain_set_kinematics (process%sfchain, process%x_strfun, & -! channel, n1, process%x, process%sf_factor, & -! ok=ok) -! else -! forall (i = 1:size(process%x,2)) & -! process%x(n1+1:n2,i) = process%x_strfun -! call strfun_chain_set_kinematics (process%sfchain, process%x_strfun, & -! ok=ok) -! end if -! end if - if (.not. ok) return - do i = process%n_kinematics_out, 1, -1 - if (i > 1) call evaluator_receive_momenta ( & - process%kinematics_out(i)%strfun_snapshot) - int => core_interaction_get_int_ptr (process%ci, i) - call interaction_receive_momenta (int) - end do - process%beams_are_set = .true. - process%sqrts_hat = sqrt (max (interaction_get_s (int), 0._default)) - else if (.not. process%beams_are_set) then - ! No Beams -> set the momenta directly - if (process%type == PRC_DECAY) then - pin = (/vector4_at_rest (process%mass_in(1))/) - else - pin = colliding_momenta (process%sqrts, process%mass_in) - end if - process%sqrts_hat = process%sqrts - do i = process%n_kinematics_out, 1, -1 - int => core_interaction_get_int_ptr (process%ci, i) - call interaction_set_momenta (int, pin, outgoing=.false.) - end do - else - ! We must still make sure that int is valid - int => core_interaction_get_int_ptr (process%ci, 1) -!!! Previous version -! if (process%n_par_strfun /= 0) call msg_bug & -! ("Mismatch in structure function setup: n_parameters /= 0") -! select case (process%type) -! case (PRC_DECAY) -! call interaction_set_momenta (int, & -! (/ vector4_at_rest (process%mass_in(1)) /), & -! outgoing=.false.) -! case (PRC_SCATTERING) -! call interaction_set_momenta (int, & -! colliding_momenta (process%sqrts, process%mass_in), & -! outgoing=.false.) -! end select -! process%sqrts_hat = process%sqrts -! else -! if (process%n_par_strfun /= 0) call msg_bug & -! ("Mismatch in beams/structure function setup: n_parameters /= 0") - end if - int => core_interaction_get_int_ptr (process%ci, 1) - call process_status_passed_strfun_chain (process%status) - process%sqrts_hat_known = .true. - ! Calculate flux factor - if (process%type == PRC_DECAY) then - process%flux_factor = twopi4 / (2 * process%mass_in(1)) - else - lda = lambda (process%sqrts_hat ** 2, & - process%mass_in(1) ** 2, & - process%mass_in(2) ** 2) - if (lda <= 0) then - ok = .false. - return - end if - process%flux_factor = conv * twopi4 / (2 * sqrt (lda)) - end if - call process_status_passed_mass_threshold (process%status) - ! Set the MC variables for the core interaction and tell it that we have - ! completed the ingoing seed kinematics - call core_interaction_set_x (process%ci, process%x_ci) - call core_interaction_set_state (process%ci, CI_STATE_SEED_MOMENTA_SET) - ! Setup MC hypercube - forall (n = 1 : process%n_kinematics_in) - process%kinematics_in(n)%x(:off_strfun - 1, channel) = process%x_phs - forall (i = 1 : process%n_par_strfun) & - process%kinematics_in(n)%x(off_strfun + i - 1, :) = process%x_strfun(i) - forall (i = 1 : process%n_par_ci) & - process%kinematics_in(n)%x(off_ci + i - 1, :) = process%x_ci(i) - end forall -!!! Previous version. forest is no longer part of process. -! process%sqrts_hat_known = .true. -! if (.not. process%lab_is_cm_frame) then -! process%lt_cm_to_lab = interaction_get_cm_transformation (int) -! call phs_forest_set_prt_in (process%forest, int, process%lt_cm_to_lab) -! else -! call phs_forest_set_prt_in (process%forest, int) -! end if - ! Complete the kinematics by evaluating the phs forests for all ``in'' - ! configuration - process%kinematics_in(1)%sqrts = process%sqrts_hat - do i = 1, process%n_kinematics_in - if (i > 1) then - call core_interaction_get_momenta_in (process%ci, pin, i) - pcm = sum (pin) - process%kinematics_in(i)%sqrts = sqrt (pcm * pcm) - process%kinematics_in(i)%lt = boost (pcm, process%kinematics_in(i)%sqrts) - call phs_forest_set_prt_in (process%kinematics_in(i)%forest, & - pin, process%kinematics_in(i)%lt) - else - if (.not. process%lab_is_cm_frame) then - process%lt_cm_to_lab = interaction_get_cm_transformation (int) - process%kinematics_in(i)%lt = process%lt_cm_to_lab - call phs_forest_set_prt_in (process%kinematics_in(i)%forest, & - int, process%lt_cm_to_lab) - else - call phs_forest_set_prt_in (process%kinematics_in(i)%forest, int) - end if - end if - call phs_forest_evaluate_momenta (& - process%kinematics_in(i)%forest, & - channel, process%active_channel, & - process%kinematics_in(i)%sqrts, & - process%kinematics_in(i)%x, & - process%kinematics_in(i)%phs_factor, & - process%kinematics_in(i)%phs_volume, & - ok=process%kinematics_in(i)%passed) - end do - ! The hypercube point remains valid as long as any of the phasespace points - ! passes - ok = any (process%kinematics_in(:)%passed) - if (.not. ok) return - ! Passed? -> Propagate the kinematics to the core interaction - do i = 1, process%n_kinematics_in - call core_interaction_kinematics_passed (process%ci, & - process%kinematics_in(i)%passed, i) - if (process%kinematics_in(i)%passed) then - if (i > 1 .or. .not. process%lab_is_cm_frame) then - call core_interaction_set_momenta_out (process%ci, & - phs_forest_get_momenta_out ( & - process%kinematics_in(i)%forest, & - process%kinematics_in(i)%lt), & - i) - else - call core_interaction_set_momenta_out (process%ci, & - phs_forest_get_momenta_out (process%kinematics_in(i)%forest), & - i) - end if - end if - end do - ! Advance the core interaction state, triggering the calculation of the - ! effective kinematics at the ``out'' points... - call core_interaction_set_state (process%ci, CI_STATE_MOMENTA_SET) - ! ... and forward them to the evaluators - do i = 1, process%n_kinematics_out - process%kinematics_out(i)%passed = core_interaction_get_cut_status ( & - process%ci, i) - if (process%kinematics_out(i)%passed) then - eval => core_interaction_get_eval_trace_ptr (process%ci, i) - call evaluator_receive_momenta (eval) - if (process%use_beams) call evaluator_receive_momenta ( & - process%kinematics_out(i)%eval_trace) - end if - end do - call process_status_passed_kinematics (process%status) - end subroutine process_set_kinematics - -@ %def process_set_kinematics -@ Complete phase space evaluation -<>= - public :: process_complete_kinematics -<>= - subroutine process_complete_kinematics (process, channel) - type(process_t), intent(inout), target :: process - integer, intent(in) :: channel - integer :: i - do i = 1, process%n_kinematics_in - if (process%kinematics_in(i)%passed) & - call phs_forest_evaluate_other_channels ( & - process%kinematics_in(i)%forest, & - channel, process%active_channel, & - process%kinematics_in(i)%sqrts, & - process%kinematics_in(i)%x, & - process%kinematics_in(i)%phs_factor) - end do - end subroutine process_complete_kinematics - -@ %def process_complete_kinematics -@ Recover momenta from a given particle set. -<>= - public :: process_recover_kinematics -<>= - subroutine process_recover_kinematics (process, particle_set) - type(process_t), intent(inout), target :: process - type(particle_set_t), intent(in) :: particle_set - integer :: n_in, n_out - real(default) :: lda - type(evaluator_t), pointer :: eval - type(interaction_t), pointer :: int -! Will propably never be implemented ;) - if (.not. process%trivial_kinematics) call msg_bug ( & - "Recovering process with subtraction kinematics not implemented") -! To be implemented later - if (process%use_beams) & - call msg_bug ("Recovering process with beams not implemented yet") - - call core_interaction_recover_kinematics (process%ci, particle_set) - int => core_interaction_get_int_ptr (process%ci, 1) - - process%sqrts_hat = process%sqrts - select case (process%type) - case (PRC_DECAY) - process%flux_factor = & - twopi4 / (2 * process%mass_in(1)) - case (PRC_SCATTERING) - lda = lambda (process%sqrts_hat ** 2, & - process%mass_in(1) ** 2, & - process%mass_in(2) ** 2) - if (lda <= 0) then - process%flux_factor = 0 - else - process%flux_factor = & - conv * twopi4 / (2 * sqrt (lda)) - end if - end select - process%sqrts_hat_known = .true. - if (.not. process%lab_is_cm_frame) then - process%lt_cm_to_lab = interaction_get_cm_transformation (int) - call phs_forest_set_prt_in ( & - process%kinematics_in(1)%forest, int, process%lt_cm_to_lab) - else - call phs_forest_set_prt_in (process%kinematics_in(1)%forest, int) - end if - - eval => core_interaction_get_eval_trace_ptr (process%ci, 1) - call evaluator_receive_momenta (eval) - process%kinematics_in(1)%sqrts = process%sqrts - process%kinematics_in(1)%passed = .true. - end subroutine process_recover_kinematics - -@ %def process_recover_kinematics -@ Fill the [[subevt]] which is used by cuts, weight, scale with -momenta from the [[eval_trace]] interaction. This can be done once -kinematics has been set up or recovered. - -If the optional [[transform]] flag is set, boost the momenta from the -lab to the c.m.\ frame. - -Caveat: If we want to implement casce decays @ NLO, we will have to revisit this, -I am pretty sure that handling of the boost is not consisten for this case. -<>= - public :: process_fill_subevt -<>= - subroutine process_fill_subevt (process, transform) - type(process_t), intent(inout), target :: process - logical, intent(in), optional :: transform - type(interaction_t), pointer :: int - integer :: i - logical :: tr - tr = .false.; if (present (transform)) tr = transform - do i = 1, process%n_kinematics_out - if (process%use_beams) then - int => evaluator_get_int_ptr (process%kinematics_out(i)%eval_trace) - else - int => core_interaction_get_int_ptr (process%ci, i) - end if - if (tr) then - if (.not. process%trivial_kinematics) call msg_bug ( & - "NLO cascade decays not implemented yet") - call interaction_momenta_to_subevt & - (int, process%j_beam, process%j_in, process%j_out, & - inverse (process%lt_cm_to_lab), process%kinematics_out(i)%subevt) - else - call interaction_momenta_to_subevt & - (int, process%j_beam, process%j_in, process%j_out, & - process%kinematics_out(i)%subevt) - end if - end do - end subroutine process_fill_subevt - -@ %def process_fill_subevt -@ Evaluate the cut expression and return a boolean flag (true means to -continue evaluation, false to drop the event). -<>= - function process_passes_cuts (process) result (flag) - logical :: flag - type(process_t), intent(inout), target :: process - integer :: i - logical :: passed - flag = .false. - do i = 1, process%n_kinematics_out - if (.not. process%kinematics_out(i)%passed) cycle - if (eval_tree_is_defined (process%kinematics_out(i)%cut_expr)) then - call eval_tree_evaluate (process%kinematics_out(i)%cut_expr) - if (eval_tree_result_is_known (process%kinematics_out(i)%cut_expr)) then - passed = eval_tree_get_log (process%kinematics_out(i)%cut_expr) - else - passed = .true. - end if - else - passed = .true. - end if - call core_interaction_set_cut_status (process%ci, passed, i) - process%kinematics_out(i)%passed = passed - flag = flag .or. passed - end do - end function process_passes_cuts - -@ %def process_passes_cuts -@ Evaluate the weight expression and set the value. -<>= - public :: process_compute_reweighting_factor -<>= - subroutine process_compute_reweighting_factor (process) - type(process_t), intent(inout), target :: process - integer :: i - do i = 1, process%n_kinematics_out - if (eval_tree_is_defined (process%kinematics_out(i)%reweighting_expr)) then - if (.not. process%kinematics_out(i)%passed) cycle - call eval_tree_evaluate (process%kinematics_out(i)%reweighting_expr) - if (eval_tree_result_is_known ( & - process%kinematics_out(i)%reweighting_expr)) & - then - process%kinematics_out(i)%reweighting_factor = & - eval_tree_get_real (process%kinematics_out(i)%reweighting_expr) - else - process%kinematics_out(i)%reweighting_factor = 1 - end if - else - process%kinematics_out(i)%reweighting_factor = 1 - end if - end do - end subroutine process_compute_reweighting_factor - -@ %def process_compute_reweighting_factor -@ Evaluate the scale expression(s) and return a real value. If the scale -expression is essentially undefined, return the c.m. energy of the hard -interaction. The factorization scale and renormalization scale always supersede -the general expression. -<>= - public :: process_compute_scale -<>= - subroutine process_compute_scale (process) - type(process_t), intent(inout), target :: process - integer :: i - do i = 1, process%n_kinematics_out - if (.not. process%kinematics_out(i)%passed) cycle - if (eval_tree_is_defined (process%kinematics_out(i)%scale_expr)) then - call eval_tree_evaluate (process%kinematics_out(i)%scale_expr) - if (eval_tree_result_is_known ( & - process%kinematics_out(i)%scale_expr)) & - then - process%kinematics_out(i)%scale = & - eval_tree_get_real (process%kinematics_out(i)%scale_expr) - else - process%kinematics_out(i)%scale = process%sqrts_hat - end if - else - process%kinematics_out(i)%scale = process%sqrts_hat - end if - if (eval_tree_is_defined (process%kinematics_out(i)%fac_scale_expr)) then - call eval_tree_evaluate (process%kinematics_out(i)%fac_scale_expr) - if (eval_tree_result_is_known ( & - process%kinematics_out(i)%fac_scale_expr)) & - then - process%kinematics_out(i)%fac_scale = & - eval_tree_get_real (process%kinematics_out(i)%fac_scale_expr) - else - process%kinematics_out(i)%fac_scale = process%kinematics_out(i)%scale - end if - else - process%kinematics_out(i)%fac_scale = process%kinematics_out(i)%scale - end if - if (eval_tree_is_defined (process%kinematics_out(i)%ren_scale_expr)) then - call eval_tree_evaluate (process%kinematics_out(i)%ren_scale_expr) - if (eval_tree_result_is_known ( & - process%kinematics_out(i)%ren_scale_expr)) & - then - process%kinematics_out(i)%ren_scale = & - eval_tree_get_real (process%kinematics_out(i)%ren_scale_expr) - else - process%kinematics_out(i)%ren_scale = process%kinematics_out(i)%scale - end if - else - process%kinematics_out(i)%ren_scale = process%kinematics_out(i)%scale - end if - end do - end subroutine process_compute_scale - -@ %def process_compute_scale -@ Evaluate the (jacobian) factor associated to the VAMP grids and the -phase-space factor array for the given integration channel. - -!!! JRR: WK please check: -has been taken over into mci_vamp_instance_compute_weights. The -structure function factors are missing, but should (have) be(en) taken -into account elsewhere. What about the active_channel stuff? -<>= - subroutine process_compute_vamp_phs_factor (process, weights) - type(process_t), intent(inout), target :: process - real(default), dimension(:), intent(in) :: weights - real(default), dimension(process%n_channels) :: vamp_prob - real(default) :: dp - integer :: i, n - do n = 1, process%n_kinematics_in - if (.not. process%kinematics_in(n)%passed) cycle - !$OMP PARALLEL PRIVATE(i) SHARED(process,vamp_prob) - !$OMP DO - do i = 1, process%n_channels - if (process%active_channel(i)) then - vamp_prob(i) = & - vamp_probability (process%grids%grids(i), & - process%kinematics_in(n)%x(:,i)) - else - vamp_prob(i) = 0 - end if - end do - !$OMP END DO - !$OMP END PARALLEL - dp = dot_product (weights, vamp_prob / process%kinematics_in(n)%phs_factor) - if (dp /= 0) then - process%kinematics_in(n)%vamp_phs_factor = & - vamp_prob(process%channel) / dp - else - process%kinematics_in(n)%vamp_phs_factor = 0 - end if - end do -!!! Previous version -! !$OMP END DO -! !$OMP END PARALLEL -! if (allocated (process%sf_factor)) then -! dp = dot_product (weights, & -! vamp_prob / (process%phs_factor * process%sf_factor)) -! else -! dp = dot_product (weights, vamp_prob / process%phs_factor) -! end if -! if (dp /= 0) then -! process%vamp_phs_factor = vamp_prob(process%channel) / dp -! else -! process%vamp_phs_factor = 0 -! end if - end subroutine process_compute_vamp_phs_factor - -@ %def process_compute_vamp_phs_factor -@ Update the model parameters used by the matrix element code. -<>= - public :: process_update_parameters -<>= - subroutine process_update_parameters (process) - type(process_t), intent(inout) :: process - call core_interaction_update_parameters (process%ci) - end subroutine process_update_parameters - -@ %def process_update_parameters -@ Update the $\alpha_s$ value used by the matrix element code, -depending on the computed renormalization scale. -<>= -interface - double precision function alphasPDF (Q) - double precision, intent(in) :: Q - end function alphasPDF -end interface -@ %def alphasPDF -@ -<>= - public :: process_update_alpha_s -<>= - subroutine process_update_alpha_s (process) - type(process_t), intent(inout) :: process - integer :: i - if (process%qcd%alpha_s_is_fixed) return - do i = 1, process%n_kinematics_out - if (.not. process%kinematics_out(i)%passed) cycle - call qcd_parameters_update_alpha_s (process%qcd, & - process%kinematics_out(i)%ren_scale) - call core_interaction_update_alpha_s & - (process%ci, process%qcd%alpha_s_at_scale, i) - end do - end subroutine process_update_alpha_s - -@ %def process_update_alpha_s -@ Evaluate the structure function values, the hard matrix element, and -the follow-up evaluators. We obtain the squared matrix element value -for the current event. -<>= - public :: process_evaluate -<>= - subroutine process_evaluate (process) - type(process_t), intent(inout), target :: process - integer :: i - call core_interaction_evaluate (process%ci) - do i = process%n_kinematics_out, 1, -1 - if (.not. process%kinematics_out(i)%passed) cycle - if (process%use_beams) then - call strfun_chain_evaluate (process%sfchain, & - process%kinematics_out(i)%fac_scale) - if (i > 1) call evaluator_evaluate ( & - process%kinematics_out(i)%strfun_snapshot) - end if - if (process%has_extra_evaluators) then - call evaluator_evaluate (process%kinematics_out(i)%eval_trace) - process%kinematics_out(i)%sqme = & - evaluator_sum (process%kinematics_out(i)%eval_trace) - else - process%kinematics_out(i)%sqme = evaluator_sum & - (core_interaction_get_eval_trace_ptr (process%ci, i)) & - * process%averaging_factor - end if - end do - if (process%use_beams) then - process%sf_mapping_factor = strfun_chain_get_mapping_factor ( & - process%sfchain) - else - process%sf_mapping_factor = 1 - end if -! call process_write (process, 66); stop - end subroutine process_evaluate - -@ %def process_evaluate -@ Return the squared matrix element of the hard interaction for the -given momenta, traced over all quantum numbers. This is independent -of beam setup, structure functions, phase space etc. Makes sense only -for ordinary (as in no subtraction / dipole) matrix elements. -<>= - function process_compute_sqme_sum (process, p) result (sqme) - real(default) :: sqme - type(process_t), intent(inout), target :: process - type(vector4_t), dimension(:), intent(in) :: p - if (.not. process%trivial_kinematics) call msg_bug ( & - "process_compute_sqme_sum makes no sense for subtraction kinematics") - sqme = core_interaction_compute_sqme_sum (process%ci, p, 1) - end function process_compute_sqme_sum - -@ %def process_compute_sqme_sum -@ -\subsection{Access VAMP data} -Compute the reweighting efficiency for the current grids, suitable -averaged over all active channels. -<>= - function process_get_vamp_efficiency_array (process) result (efficiency) - real(default), dimension(:), allocatable :: efficiency - type(process_t), intent(in) :: process - allocate (efficiency (process%n_channels)) - where (process%grids%grids%f_max /= 0) - efficiency = process%grids%grids%mu(1) / abs (process%grids%grids%f_max) - elsewhere - efficiency = 0 - end where - end function process_get_vamp_efficiency_array - - function process_get_vamp_efficiency (process) result (efficiency) - real(default) :: efficiency - type(process_t), intent(in) :: process - real(default), dimension(:), allocatable :: weight - real(default) :: norm - allocate (weight (process%n_channels)) - weight = process%grids%weights * abs (process%grids%grids%f_max) - norm = sum (weight) - if (norm /= 0) then - efficiency = & - dot_product (process_get_vamp_efficiency_array (process), weight) & - / norm - else - efficiency = 1 - end if - end function process_get_vamp_efficiency - -@ %def process_get_vamp_efficiency_array process_get_vamp_efficiency -@ -\subsection{Integration} -This executes one or more iterations of the VAMP integration routine. -The flags determine whether to discard previous results, to adapt -grids before integration, and to adapt the relative channel weights. -The final result is entered into the results record. - -If there is a grid filename provided, we write the current grid to file, once -after each iteration. If the flag [[write_best_grid]] is also set, we -write the grid with the lowest (i.e., best) accuracy to file. This may -be the current grid, or it may be a previous 'best' grid. -<>= - public :: process_integrate -<>= - subroutine process_integrate (process, rng, & - grid_parameters, pass, it1, it2, calls, & - discard_integrals, adapt_grids, adapt_weights, print_current, & - time_estimate, & - grids_filename, write_best_grid, md5sum, history_filename, log_filename) - type(process_t), intent(inout), target :: process - type(tao_random_state), intent(inout) :: rng - type(grid_parameters_t), intent(in) :: grid_parameters - integer, intent(in) :: pass, it1, it2, calls - logical, intent(in) :: discard_integrals - logical, intent(in) :: adapt_grids - logical, intent(in) :: adapt_weights - logical, intent(in) :: print_current - logical, intent(in) :: time_estimate - type(string_t), intent(in), optional :: grids_filename - logical, intent(in), optional :: write_best_grid - type(md5sum_grids_t), intent(in), optional :: md5sum - type(string_t), intent(in), optional :: history_filename, log_filename - integer :: it - real(default) :: integral, error, efficiency - type(time_t) :: time_start, time_end - real(default) :: sqrts - real(default), dimension(:), allocatable :: grove_weight - integer :: u - if (it1 > it2) return - u = logfile_unit () - if (present (md5sum)) then - process%md5sum_grids = process_collect_md5sum (process, md5sum) - end if - process%grid_parameters = grid_parameters - sqrts = process%sqrts - if (discard_integrals .and. it1==1) then - if (grid_parameters%use_vamp_equivalences) then - call vamp_discard_integrals (process%grids, & - calls, stratified=grid_parameters%stratified, eq=process%vamp_eq) - else - call vamp_discard_integrals (process%grids, & - calls, stratified=grid_parameters%stratified) - end if - end if - process%beams_are_set = .false. - do it = it1, it2 - if (adapt_grids) then - call process_adapt_grids (process) - end if - if (adapt_weights) then - call process_adapt_channel_weights (process, grid_parameters, calls) - end if - call process_status_reset_counters (process%status) - if (time_estimate) time_start = time_current () - if (grid_parameters%use_vamp_equivalences) then - call vamp_sample_grids & - (rng, process%grids, sample_function, process%store_index, 1, & - eq=process%vamp_eq, & - history=process%v_history(it:), & - histories=process%v_histories(it:,:), & - integral=integral, std_dev=error, negative_weights=& - process%negative_weights) - else - call vamp_sample_grids & - (rng, process%grids, sample_function, process%store_index, 1, & - history=process%v_history(it:), & - histories=process%v_histories(it:,:), & - integral=integral, std_dev=error, negative_weights=& - process%negative_weights) - end if - if (time_estimate) time_end = time_current () - efficiency = process_get_vamp_efficiency (process) - call process_get_grove_weights (process, grove_weight) - if (time_estimate) then - call integration_results_append (process%results, & - process%type, pass, 1, calls, & - integral, error, efficiency, grove_weight, time_start, time_end) - else - call integration_results_append (process%results, & - process%type, pass, 1, calls, & - integral, error, efficiency, grove_weight) - end if - process%filename_current_grid = "" - process%filename_best_grid = "" - if (present (grids_filename)) then - process%filename_current_grid = grids_filename - call write_grid_file (grids_filename, process%id, & - process%md5sum_grids, grid_parameters, & - process%results, process%grids) - if (present (write_best_grid)) then - if (write_best_grid) then - process%filename_best_grid = grids_filename // "b" - call write_best_grid_file (process%filename_best_grid, & - process%id, & - process%md5sum_grids, grid_parameters, & - process%results, process%grids) - end if - end if - end if - if (print_current) then - call integration_results_write_current (process%results) - call integration_results_write_current (process%results, unit=u) - if (u >= 0) flush (u) - end if - if (present (history_filename)) then - call integration_results_write_driver & - (process%results, history_filename) - end if - if (present (log_filename)) then - call process_write_logfile (process, log_filename) - end if - end do - end subroutine process_integrate - -@ %def process_integrate -@ Collect the MD5 sums that are relevant for reading/writing grid files. -<>= - function process_collect_md5sum (process, md5sum_global) & - result (md5sum_local) - type(md5sum_grids_t) :: md5sum_local - type(process_t), intent(in) :: process - type(md5sum_grids_t), intent(in) :: md5sum_global - md5sum_local = md5sum_global - md5sum_local%process = process%md5sum - md5sum_local%model = model_get_md5sum (process%model) - md5sum_local%parameters = model_get_parameters_md5sum (process%model) - md5sum_local%phs = process%md5sum_phs - md5sum_local%alpha_s = process%md5sum_alpha_s - md5sum_local%nlo_setup = process%md5sum_nlo_setup - end function process_collect_md5sum - -@ %def process_collect_md5sum -@ Similarly, write a number of dummy entries to the results record -which indicate skipped iterations. -<>= - public :: process_skip_iterations -<>= - subroutine process_skip_iterations (process, pass, it, n_skip) - type(process_t), intent(inout) :: process - integer, intent(in) :: pass, it, n_skip - integer :: i - do i = 1, n_skip - call integration_results_append_null (process%results, & - pass, it + i) - end do - end subroutine process_skip_iterations - -@ %def process_skip_iterations -@ In preparation for a new pass or for event generation, load a -previously stored best grid if it does not coincide with the current one. -<>= - public :: process_choose_best_grid -<>= - subroutine process_choose_best_grid (process, check_grid_file) - type(process_t), intent(inout) :: process - logical, intent(in) :: check_grid_file - integer :: it_last, it_best - type(md5sum_grids_t) :: md5sum_local - type(integration_results_t) :: results_on_file - logical :: ok - it_last = integration_results_get_last_it (process%results) - it_best = integration_results_get_best_it (process%results) - if (it_best /= 0 .and. it_best /= it_last & - .and. process%filename_best_grid /= "") then - write (msg_buffer, "(A,A,A,I0)") & - "Process ", char (process%id), & - ": Using integration grids from iteration #", & - it_best - call msg_message - call read_grid_file (process%filename_best_grid, process%id, & - check_grid_file, process%md5sum_grids, process%grid_parameters, & - results_on_file, process%grids, & - process%pass_array, process%n_calls_array, ok) - end if - end subroutine process_choose_best_grid - -@ %def process_choose_best_grid -@ This just calls the sampling function a given number of times, -discarding the results. VAMP is bypassed. - -Constructs like this are candidates for elimination by the optimizer --- as long as the sampling function is impure, this should not happen, -however. -<>= - public :: process_me_test -<>= - subroutine process_me_test & - (process, rng, n_calls, time_in_seconds, sample_function_sum) - type(process_t), intent(inout), target :: process - type(tao_random_state), intent(inout) :: rng - integer, intent(in) :: n_calls - real(default), intent(out), optional :: time_in_seconds, sample_function_sum - integer :: prc_index, i - type(time_t) :: time_start, time_end - real(default), dimension(:), allocatable :: weights - real(default) :: s - process%beams_are_set = .false. - s = 0 - allocate (weights (process%n_channels)) - weights = 1._default / size (weights) - call process_status_reset_counters (process%status) - if (present (time_in_seconds)) time_start = time_current () - do i = 1, n_calls - s = s + sample_function & - (random_xi (), process%store_index, & - weights=weights, & - channel=random_channel ()) - end do - if (present (time_in_seconds)) then - time_end = time_current () - time_in_seconds = time_end - time_start - end if - if (present (sample_function_sum)) then - sample_function_sum = s - end if - contains - function random_channel () result (channel) - integer :: channel - real(default) :: x - call tao_random_number (rng, x) - channel = ceiling (x * process%n_channels) - end function random_channel - function random_xi () result (xi) - real(default), dimension (process%n_par) :: xi - integer :: i - do i = 1, size (xi) - call tao_random_number (rng, xi(i)) - end do - end function random_xi - end subroutine process_me_test - -@ %def process_me_test -@ Create the VAMP history information: -<>= - public :: process_init_vamp_history - public :: process_final_vamp_history -<>= - subroutine process_init_vamp_history (process, n_iterations) - type(process_t), intent(inout) :: process - integer, intent(in) :: n_iterations - call process_final_vamp_history (process) - allocate (process%v_history (n_iterations)) - allocate (process%v_histories & - (n_iterations, process_get_n_channels (process))) - call vamp_create_history (process%v_history, verbose=.false.) - call vamp_create_history (process%v_histories, verbose=.false.) - end subroutine process_init_vamp_history - - subroutine process_final_vamp_history (process) - type(process_t), intent(inout) :: process - if (allocated (process%v_history)) then - call vamp_delete_history (process%v_history) - deallocate (process%v_history) - end if - if (allocated (process%v_histories)) then - call vamp_delete_history (process%v_histories) - deallocate (process%v_histories) - end if - end subroutine process_final_vamp_history - -@ %def process_init_vamp_history -@ %def process_final_vamp_history -@ Display the time estimate on screen -<>= - public :: process_write_time_estimate -<>= - subroutine process_write_time_estimate (process, unit) - type(process_t), intent(in) :: process - integer, intent(in), optional :: unit - real(default) :: time_per_event, time_per_10k - time_per_event = integration_results_get_time_per_event (process%results) - time_per_10k = 10000 * time_per_event - write (msg_buffer, "(A)") "Process '" // char (process%id) // "': " - call msg_message () - write (msg_buffer, "(A)") " time estimate for generating " & - // "10000 unweighted events: " & - // char (time2string (int (time_per_10k))) - call msg_message (unit=unit) - call write_hline (unit) - end subroutine process_write_time_estimate - -@ %def process_write_time_estimate -@ Write the VAMP grid file including a header containing metadata. -<>= - subroutine write_grid_file (filename, process_id, md5sum, & - grid_parameters, results, grids) - type(string_t), intent(in) :: filename, process_id - type(md5sum_grids_t), intent(in) :: md5sum - type(grid_parameters_t), intent(in) :: grid_parameters - type(integration_results_t), intent(in) :: results - type(vamp_grids), intent(in) :: grids - integer :: u - u = free_unit () - open (file = char (filename), unit = u, & - action = "write", status = "replace") - write (u, *) "process ", char (process_id) - call md5sum_grids_write (md5sum, u) - write (u, *) - call grid_parameters_write (grid_parameters, u) - write (u, *) - call integration_results_write & - (results, u, verbose = .true.) - write (u, *) - call vamp_write_grids (grids, u, write_integrals = .true.) - close (u) - end subroutine write_grid_file - -@ %def write_grid_file -@ Attempt to read the VAMP grid file, checking metadata for -consistency. Also read the integration results as far as they are -known. -<>= - subroutine read_grid_file (filename, process_id, & - check, md5sum, grid_parameters, results, grids, & - pass, n_calls, ok) - type(string_t), intent(in) :: filename, process_id - logical, intent(in) :: check - type(md5sum_grids_t), intent(in) :: md5sum - type(grid_parameters_t), intent(in) :: grid_parameters - type(integration_results_t), intent(out) :: results - type(vamp_grids), intent(inout) :: grids - integer, dimension(:), intent(in) :: pass, n_calls - logical, intent(out) :: ok - integer :: u - logical :: exist - character(80) :: buffer - character :: equals - character(32) :: md5sum_file - type(grid_parameters_t) :: grid_parameters_file - type(integration_results_t) :: results_file - ok = .false. - if (.not. check) call msg_warning & - ("Validity checks turned off for grid file '" & - // char (filename) // "'") - inquire (file = char (filename), exist = exist) - if (.not. exist) return - call msg_message ("Reading integration grids and results from file '" & - // char (filename) // "':") - u = free_unit () - open (file = char (filename), unit = u, action = "read", status = "old") - read (u, *) buffer - if (check .and. trim (adjustl (buffer)) /= "process") then - call msg_fatal ("Grid file: missing 'process' tag") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%process) then - call msg_message & - ("Process configuration has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%model) then - call msg_message & - ("Model has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%parameters) then - call msg_message & - ("Model parameters have changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%phs) then - call msg_message & - ("Phase-space setup has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%beams) then - call msg_message & - ("Beam setup has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%sf_list) then - call msg_message & - ("Structure-function setup has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%mappings) then - call msg_message & - ("Mapping scale parameters have changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%cuts) then - call msg_message & - ("Cut configuration has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%weight) then - call msg_message & - ("Weight expression has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%scale) then - call msg_message & - ("General scale expression has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%fac_scale) then - call msg_message & - ("Factorization scale expression has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%ren_scale) then - call msg_message & - ("Renormalization scale expression has changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (check .and. md5sum_file /= md5sum%alpha_s) then - call msg_message & - ("Alpha(QCD) specifications have changed, discarding old grid file") - close (u); return - end if - read (u, *) buffer, equals, md5sum_file - if (md5sum_file /= md5sum%nlo_setup) then - call msg_message & - ("NLO setup has changed, discarding old grid file") - close (u); return - end if - read (u, *) - call grid_parameters_read (grid_parameters_file, u) - if (check .and. grid_parameters_file /= grid_parameters) then - call msg_message & - ("Grid parameters have changed, discarding old grid file") - close (u); return - end if - read (u, *) - call integration_results_read (results_file, u) - if (check .and. .not. integration_results_iterations_are_consistent & - (results_file, pass, n_calls)) then - call msg_message & - ("Iteration parameters have changed, discarding old grid file") - close (u); return - end if - results = results_file - read (u, *) - call vamp_read_grids (grids, u) - close (u) - ok = .true. - end subroutine read_grid_file - -@ %def read_grid_file -@ Write the grid that has the optimal parameters so far, within the -current integration pass. This is determined from the current -integration results. If the best grid is not the current one, we do -nothing. -<>= - subroutine write_best_grid_file (filename, process_id, md5sum, & - grid_parameters, results, grids) - type(string_t), intent(in) :: filename, process_id - type(md5sum_grids_t), intent(in) :: md5sum - type(grid_parameters_t), intent(in) :: grid_parameters - type(integration_results_t), intent(in) :: results - type(vamp_grids), intent(in) :: grids - type(vamp_grids) :: grids_on_file - type(integration_results_t) :: results_on_file - integer :: it_current, it_best - logical :: ok - integer :: u - it_current = integration_results_get_current_it (results) - it_best = integration_results_get_best_it (results) - if (it_best == it_current) then - call write_grid_file (filename, process_id, md5sum, & - grid_parameters, results, grids) - end if - end subroutine write_best_grid_file - -@ %def write_best_grid_file -@ Store the pass and calls arrays that are currently active. They are -checked when grid files are re-read for event generation. -<>= - public :: process_store_iteration_parameters -<>= - subroutine process_store_iteration_parameters & - (process, pass_array, n_calls_array) - type(process_t), intent(inout) :: process - integer, dimension(:), intent(in) :: pass_array, n_calls_array - allocate (process%pass_array (size (pass_array))) - process%pass_array = pass_array - allocate (process%n_calls_array (size (n_calls_array))) - process%n_calls_array = n_calls_array - end subroutine process_store_iteration_parameters - -@ %def process_store_iteration_parameters -@ Wrapper for grid file reading. We supplement the MD5 sum block with extra -entries that we can determine from the process object. -<>= - public :: process_read_grid_file -<>= - subroutine process_read_grid_file (process, filename, & - check_grid_file, md5sum, grid_parameters, pass, n_calls, ok) - type(process_t), intent(inout) :: process - type(string_t), intent(in) :: filename - logical, intent(in) :: check_grid_file - type(md5sum_grids_t), intent(in) :: md5sum - type(grid_parameters_t), intent(in) :: grid_parameters - integer, dimension(:), intent(in) :: pass, n_calls - logical, intent(out) :: ok - type(md5sum_grids_t) :: md5sum_local - md5sum_local = process_collect_md5sum (process, md5sum) - call read_grid_file (filename, process%id, & - check_grid_file, md5sum_local, grid_parameters, & - process%results, process%grids, pass, n_calls, ok) - end subroutine process_read_grid_file - -@ %def process_read_grid_file -@ Adapt the binning of the VAMP grids. This is just a wrapper. -<>= - subroutine process_adapt_grids (process) - type(process_t), intent(inout), target :: process - call vamp_refine_grids (process%grids) - end subroutine process_adapt_grids - -@ %def process_adapt_grids -@ Refine the channel weights. We use a power weight just as for the -individual bins. The results are averaged within each grove. Then, -we check if the resulting weights would lead to a too small number of -calls within any channel, which is corrected. The result is fed into -VAMP. -<>= - subroutine process_adapt_channel_weights (process, grid_parameters, calls) - type(process_t), intent(inout), target :: process - type(grid_parameters_t), intent(in) :: grid_parameters - integer, intent(in) :: calls - real(default), dimension(:), allocatable :: weights - integer :: g, i0, i1, n - real(default) :: sum_weights, weight_min - logical, dimension(:), allocatable :: weight_underflow - real(default) :: sum_weight_underflow - integer :: n_underflow - allocate (weights (process%n_channels)) - weights = process%grids%weights & - * vamp_get_variance (process%grids%grids) & - ** grid_parameters%channel_weights_power - do g = 1, phs_forest_get_n_groves (process%kinematics_in(1)%forest) - call phs_forest_get_grove_bounds ( & - process%kinematics_in(1)%forest, g, i0, i1, n) - weights(i0:i1) = sum (weights(i0:i1)) / n - end do - sum_weights = sum (weights) - if (sum_weights /= 0) then - weights = weights / sum (weights) - if (grid_parameters%threshold_calls /= 0) then - weight_min = & - real (grid_parameters%threshold_calls, default) & - / calls - allocate (weight_underflow (process%n_channels)) - weight_underflow = weights /= 0 .and. weights < weight_min - n_underflow = count (weight_underflow) - sum_weight_underflow = sum (weights, mask=weight_underflow) - where (weight_underflow) - weights = weight_min - elsewhere - weights = weights & - * (1 - n_underflow * weight_min) / (1 - sum_weight_underflow) - end where - end if - call vamp_update_weights (process%grids, weights) - end if - end subroutine process_adapt_channel_weights - -@ %def process_adapt_channel_weights -@ Return a concise table of channel weights: sum over all channels that -contribute to a grove and return the grove weights. -<>= - subroutine process_get_grove_weights (process, grove_weight) - type(process_t), intent(in) :: process - real(default), dimension(:), allocatable, intent(out) :: grove_weight - integer :: n_groves, g, i0, i1, n - n_groves = phs_forest_get_n_groves (process%kinematics_in(1)%forest) - allocate (grove_weight (n_groves)) - do g = 1, n_groves - call phs_forest_get_grove_bounds (process%kinematics_in(1)%forest, & - g, i0, i1, n) - grove_weight(g) = sum (process%grids%weights(i0:i1)) - end do - end subroutine process_get_grove_weights - -@ %def process_get_grove_weights -@ -\subsection{Event generation} -Initialize event generation. For the process setup, this means that -the evaluators for the exclusive matrix element with and without -color-flow decomposition is activated. - -For the hard-interaction evaluators, we select only those entries -which are supported by the beam/structure function setup. E.g., we -select diagonal helicity only, or sum over helicity if the beams are -unpolarized. When constructing the process evaluators, we multiply -the beams by the hard-interaction evaluators and trace over all -incoming-particle quantum numbers (except for color in the color-flow -evaluator). -<>= - public :: process_setup_event_generation -<>= - subroutine process_setup_event_generation (process, qn_mask_in) - type(process_t), intent(inout), target :: process - type(quantum_numbers_mask_t), intent(in), optional :: qn_mask_in - integer, dimension(:), allocatable :: coll_index - type(quantum_numbers_mask_t), dimension(:), allocatable :: mask_in - type(quantum_numbers_mask_t) :: mask_conn_sqme, mask_conn_flows - type(evaluator_t), pointer :: eval_sqme, eval_flows - type(interaction_t), pointer :: int_hi - integer :: n_in, n_out, n_tot, i, j - type(evaluator_t), target :: eval_con - logical :: has_sqme, has_flows - if (.not. process_has_matrix_element (process)) then - call msg_warning ("Process '" // char (process%id) // "': " & - // "matrix element vanishes, no events can be generated") - return - end if - has_sqme = core_interaction_has_eval_sqme (process%ci) - has_flows = core_interaction_has_eval_flows (process%ci) - if (.not. has_sqme) call msg_bug ("event generation for " & - // char (core_interaction_type_description ( & - core_interaction_get_type (process%ci))) & - // " is not supported yet") - call process_status_reset_counters (process%status) - n_in = core_interaction_get_n_in(process%ci) - n_out = core_interaction_get_n_out_eff (process%ci) - n_tot = core_interaction_get_n_tot_eff (process%ci) - allocate (mask_in (n_in)) - if (process%use_beams) then - allocate (coll_index (n_in)) - coll_index = strfun_chain_get_colliding_particles (process%sfchain) - mask_in = strfun_chain_get_colliding_particles_mask (process%sfchain) - mask_conn_sqme = new_quantum_numbers_mask (.false., .true., .true.) - mask_conn_flows = new_quantum_numbers_mask (.false., .false., .true.) - else if (present (qn_mask_in)) then - mask_in = qn_mask_in - else - mask_in = new_quantum_numbers_mask (.false., .false., .true.) - end if - if (has_sqme) then - call core_interaction_final_sqme (process%ci) - call core_interaction_init_sqme (process%ci, mask_in, & - process%use_hi_color_factors) - call interaction_get_diagonal_entries (evaluator_get_int_ptr ( & - core_interaction_get_eval_sqme_ptr (process%ci, 1)), & - process%sqme_diagonal_entries) - end if - if (has_flows) then - call core_interaction_final_flows (process%ci) - call core_interaction_init_flows (process%ci, mask_in) - end if - do i = 1, process%n_kinematics_out - int_hi => core_interaction_get_int_ptr (process%ci, i) - call interaction_reset_momenta (int_hi) - if (has_sqme) then - call evaluator_final (process%kinematics_out(i)%eval_sqme) - if (process%use_beams) then - eval_sqme => core_interaction_get_eval_sqme_ptr (process%ci, i) - do j = 1, n_in - call evaluator_set_source_link (eval_sqme, j, & - process%kinematics_out(i)%strfun, coll_index(j)) - end do - if (process%has_extra_evaluators) & - call evaluator_init_product (process%kinematics_out(i)%eval_sqme, & - process%kinematics_out(i)%strfun, eval_sqme, mask_conn_sqme) - end if - end if - if (has_flows) then - call evaluator_final (process%kinematics_out(i)%eval_beam_flows) - call evaluator_final (process%kinematics_out(i)%eval_flows) - if (process%use_beams) then - eval_flows => core_interaction_get_eval_flows_ptr (process%ci, i) - call evaluator_init_color_contractions ( & - process%kinematics_out(i)%eval_beam_flows, & - process%kinematics_out(i)%strfun) - do j = 1, n_in - call evaluator_set_source_link (eval_flows, j, & - process%kinematics_out(i)%eval_beam_flows, coll_index(j)) - end do - if (process%has_extra_evaluators) & - call evaluator_init_product (process%kinematics_out(i)%eval_flows, & - process%kinematics_out(i)%eval_beam_flows, eval_flows, mask_conn_flows) - end if - end if - end do - end subroutine process_setup_event_generation - -@ %def process_setup_event_generation -@ Generate a weighted event. We have to select a channel. The output -is the event weight, unmodified. The [[sample_function]] fully -constructs the event in the [[process]] object, so the output [[x]] -array is not needed. - -Analysis is not yet implemented; we need a means to pass the event -weight to the recording functions. -<>= - public :: process_generate_weighted_event -<>= - subroutine process_generate_weighted_event (process, rng, weight) - type(process_t), intent(inout), target :: process - type(tao_random_state), intent(inout) :: rng - real(default), intent(out) :: weight - real(default), dimension(process%n_par) :: x - call vamp_next_event & - (x, rng, process%grids, & - sample_function, process%store_index, phi_trivial, & - weight=weight) - call process_complete_evaluators (process) - end subroutine process_generate_weighted_event - -@ %def process_generate_weighted_event -@ Generate an unweighted event. Rejection is done by \vamp. The -optional [[excess]] is nonzero by the excess weight if an event weight -exceeds the precalculated maximum that is used for rejection. After -the event has been generated, it can be analyzed. - -The transformation function [[phi]] is trivial but has to be supplied. -<>= - public :: process_generate_unweighted_event -<>= - subroutine process_generate_unweighted_event (process, rng, excess) - type(process_t), intent(inout), target :: process - type(tao_random_state), intent(inout) :: rng - real(default), intent(out), optional :: excess - real(default), dimension(process%n_par) :: x - call vamp_next_event & - (x, rng, process%grids, & - sample_function, process%store_index, phi_trivial, & - excess=excess) - call process_complete_evaluators (process) - end subroutine process_generate_unweighted_event - - function phi_trivial (xi, channel_dummy) result (x) - real(default), dimension(:), intent(in) :: xi - integer, intent(in) :: channel_dummy - real(default), dimension(size(xi)) :: x - x = xi - end function phi_trivial - -@ %def process_generate_unweighted_event -@ Complete the event: compute amplitudes/probabilities for exclusive -quantum numbers. -<>= - public :: process_complete_evaluators -<>= - subroutine process_complete_evaluators (process) - type(process_t), intent(inout), target :: process - integer :: i - if (process%use_beams) then - do i = 1, process%n_kinematics_out - if (.not. process%kinematics_out(i)%passed) cycle - call evaluator_receive_momenta ( & - process%kinematics_out(i)%eval_beam_flows) - call evaluator_evaluate ( & - process%kinematics_out(i)%eval_beam_flows) - end do - end if - call core_interaction_evaluate_sqme (process%ci) - call core_interaction_evaluate_flows (process%ci) - if (process%has_extra_evaluators) then - do i = 1, process%n_kinematics_out - if (.not. process%kinematics_out(i)%passed) cycle - call evaluator_receive_momenta ( & - process%kinematics_out(i)%eval_sqme) - call evaluator_receive_momenta ( & - process%kinematics_out(i)%eval_flows) - call evaluator_evaluate ( & - process%kinematics_out(i)%eval_sqme) - call evaluator_evaluate ( & - process%kinematics_out(i)%eval_flows) - end do - end if - end subroutine process_complete_evaluators - -@ %def process_complete_evaluators -@ This procedure is used for checking whether some of the final-state -particles can initiate decay cascades. -<>= - public :: process_get_unstable_products -<>= - subroutine process_get_unstable_products (process, flv_unstable) - type(process_t), intent(in) :: process - type(flavor_t), dimension(:), intent(out), allocatable :: flv_unstable - call core_interaction_get_unstable_products (process%ci, flv_unstable) - end subroutine process_get_unstable_products - -@ %def process_get_unstable_products -@ When the event is generated externally (e.g., read from file), we -need to fill the subevent with the process record in order to -analyze it. This is done here: -<>= - public :: process_set_particles -<>= - subroutine process_set_particles (process, particle_set) - type(process_t), intent(inout) :: process - type(particle_set_t), intent(in) :: particle_set - if (.not. process%trivial_kinematics) call msg_bug ( & - "reading events is not yet implemented for subtraction kinematics") - call particle_set_to_subevt (particle_set, process%kinematics_out(1)%subevt) - end subroutine process_set_particles - -@ %def process_set_particles -@ -\subsection{Results output} -<>= - public :: process_results_write_header - public :: process_results_write_entry - public :: process_results_write_current - public :: process_results_write_average - public :: process_results_write_current_average - public :: process_results_write_footer - public :: process_results_write -<>= - subroutine process_results_write_header (process, unit, logfile) - type(process_t), intent(in) :: process - integer, intent(in), optional :: unit - logical, intent(in), optional :: logfile - call write_dline (unit) - call write_header (process%type, unit, logfile) - call write_dline (unit) - end subroutine process_results_write_header - - subroutine process_results_write_entry (process, it, unit) - type(process_t), intent(in) :: process - integer, intent(in) :: it - integer, intent(in), optional :: unit - call integration_results_write_entry (process%results, it, unit) - end subroutine process_results_write_entry - - subroutine process_results_write_current (process, unit) - type(process_t), intent(in) :: process - integer, intent(in), optional :: unit - call integration_results_write_current (process%results, unit) - end subroutine process_results_write_current - - subroutine process_results_write_average (process, pass, unit) - type(process_t), intent(in) :: process - integer, intent(in) :: pass - integer, intent(in), optional :: unit - call write_hline (unit) - call integration_results_write_average (process%results, pass, unit) - call write_hline (unit) - end subroutine process_results_write_average - - subroutine process_results_write_current_average (process, unit) - type(process_t), intent(in) :: process - integer, intent(in), optional :: unit - call write_hline (unit) - call integration_results_write_current_average (process%results, unit) - call write_hline (unit) - end subroutine process_results_write_current_average - - subroutine process_results_write_footer (process, unit, no_line) - type(process_t), intent(in) :: process - integer, intent(in), optional :: unit - logical, intent(in), optional :: no_line - if (present (no_line)) then - if (.not. no_line) call write_dline (unit) - else - call write_dline (unit) - end if - call integration_results_write_current_average (process%results, unit) - call write_dline (unit) - end subroutine process_results_write_footer - - subroutine process_results_write (process, unit) - type(process_t), intent(in) :: process - integer, intent(in), optional :: unit - call integration_results_write (process%results, unit) - end subroutine process_results_write - -@ %def process_results_write -@ Record the integration results in the process library entry. -<>= - public :: process_record_integral -<>= - subroutine process_record_integral (process, var_list) - type(process_t), intent(inout) :: process - type(var_list_t), intent(inout) :: var_list - integer :: n_calls - real(default) :: integral, error, accuracy, chi2, efficiency - n_calls = integration_results_get_n_calls (process%results) - integral = integration_results_get_integral (process%results) - error = integration_results_get_error (process%results) - accuracy = integration_results_get_accuracy (process%results) - chi2 = integration_results_get_chi2 (process%results) - efficiency = integration_results_get_efficiency (process%results) - call var_list_init_process_results (var_list, process%id, & - n_calls, integral, error, accuracy, chi2, efficiency) - end subroutine process_record_integral - -@ %def process_record_integral -@ -\subsection{Copies} -Process copies are used for decay chains (and such). We deep-copy -most components, in particular the hard-interaction and decay-forest -workspaces. Read-only components (variable list) and eval trees are -transferred as shallow copies. - -We do not copy the extra evaluators that convolute beams and hard -matrix elements. Actually, beams should not be defined for a cascade -decay process in the first place, but we do not enforce this. -We also skip the integration results. - -Furthermore, we have to reassign all external links between interactions -within the process copy to point to the copy, not the original. - -The copy is linked to the original by a pointer. Its initial state is -[[in_use]]. - -Copies of processes with nontrivial (subtraction) kinematics are currenly -disabled, although most of the infrastructure should be in place. -<>= - subroutine process_make_copy (process, original) - type(process_t), intent(inout), target :: process - type(process_t), intent(in), target :: original - type(process_t), pointer :: copy - type(interaction_t), pointer :: copy_beam_int, strfun_int, copy_strfun_int - type(interaction_t), pointer :: hi_int, copy_hi_int - type(evaluator_t), pointer :: hi_eval_trace, copy_hi_eval_trace - type(evaluator_t), pointer :: hi_eval_sqme, copy_hi_eval_sqme - type(evaluator_t), pointer :: hi_eval_flows, copy_hi_eval_flows - integer :: i - if (.not. process%trivial_kinematics) call msg_bug ( & - "copies of processes with subtraction kinematics are not implemented yet") - if (process%type /= PRC_DECAY) call msg_bug ( & - "copies of scattering processes are not implemented") - allocate (copy) - copy%type = original%type - copy%is_original = .false. - copy%original => original - copy%initialized = original%initialized - copy%has_matrix_element = original%has_matrix_element - copy%use_hi_color_factors = original%use_hi_color_factors - copy%use_beams = original%use_beams - copy%has_extra_evaluators = .false. - copy%beams_are_set = original%beams_are_set - copy%is_cascade_decay = original%is_cascade_decay - copy%id = original%id - copy%prc_lib => original%prc_lib - copy%lib_index = original%lib_index - copy%store_index = original%store_index - copy%model => original%model - if (original%use_beams) then - copy%n_strfun = original%n_strfun - copy%n_par_strfun = original%n_par_strfun - end if - copy%n_par_phs = original%n_par_phs - copy%n_par_ci = original%n_par_ci - copy%n_par = original%n_par - copy%azimuthal_dependence = original%azimuthal_dependence - copy%vamp_grids_defined = original%vamp_grids_defined - copy%sqrts_known = original%sqrts_known - copy%sqrts = original%sqrts - if (original%use_beams) then - if (allocated (original%x_strfun)) & - allocate (copy%x_strfun (size (original%x_strfun))) - end if - if (allocated (original%x_ci)) allocate (copy%x_ci ( & - size (original%x_ci))) - if (allocated (original%x_phs)) & - allocate (copy%x_phs (size (original%x_phs))) - copy%n_channels = original%n_channels -!!! Previous version -! if (allocated (original%x)) & -! allocate (copy%x (size (original%x, 1), size (original%x, 2))) -! if (allocated (original%sf_factor)) & -! allocate (copy%sf_factor (size (original%sf_factor))) -! if (allocated (original%phs_factor)) & -! allocate (copy%phs_factor (size (original%phs_factor))) - if (allocated (original%mass_in)) then - allocate (copy%mass_in (size (original%mass_in))) - copy%mass_in = original%mass_in - end if - copy%averaging_factor = original%averaging_factor - copy%ci = original%ci - copy%vamp_eq = original%vamp_eq - allocate (copy%j_beam (size (original%j_beam))) - copy%j_beam = original%j_beam - allocate (copy%j_in (size (original%j_in))) - copy%j_in = original%j_in - allocate (copy%j_out (size (original%j_out))) - copy%j_out = original%j_out - copy%var_list = original%var_list - copy%cut_pn => original%cut_pn - copy%weight_pn => original%weight_pn - copy%scale_pn => original%scale_pn - copy%fac_scale_pn => original%fac_scale_pn - copy%ren_scale_pn => original%ren_scale_pn - if (allocated (original%active_channel)) then - allocate (copy%active_channel (size (original%active_channel))) - copy%active_channel = original%active_channel - end if - copy%filename_current_grid = original%filename_current_grid - copy%filename_best_grid = original%filename_best_grid - copy%md5sum_grids = original%md5sum_grids - copy%grid_parameters = original%grid_parameters - if (allocated (original%pass_array)) then - allocate (copy%pass_array (size (original%pass_array))) - copy%pass_array = original%pass_array - end if - if (allocated (original%n_calls_array)) then - allocate (copy%n_calls_array (size (original%n_calls_array))) - copy%n_calls_array = original%n_calls_array - end if - call vamp_copy_grids (copy%grids, original%grids) - copy%n_kinematics_in = original%n_kinematics_in - copy%n_kinematics_out = original%n_kinematics_out - allocate (copy%kinematics_in(copy%n_kinematics_in)) - allocate (copy%kinematics_out(copy%n_kinematics_out)) - do i = 1, original%n_kinematics_in - copy%kinematics_in(i)%forest = original%kinematics_in(i)%forest - if (allocated (original%kinematics_in(i)%x)) & - allocate (copy%kinematics_in(i)%x( & - size (original%kinematics_in(i)%x, dim=1), & - size (original%kinematics_in(i)%x, dim=2))) - if (allocated (original%kinematics_in(i)%phs_factor)) & - allocate (copy%kinematics_in(i)%phs_factor( & - size (original%kinematics_in(i)%phs_factor))) - end do - if (original%use_beams) copy%sfchain = original%sfchain - copy_beam_int => strfun_chain_get_beam_int_ptr (copy%sfchain) - do i = 1, original%n_kinematics_out - copy%kinematics_out(i)%subevt = original%kinematics_out(i)%subevt - copy%kinematics_out(i)%cut_expr = original%kinematics_out(i)%cut_expr - copy%kinematics_out(i)%scale_expr = original%kinematics_out(i)%scale_expr - copy%kinematics_out(i)%fac_scale_expr = & - original%kinematics_out(i)%fac_scale_expr - copy%kinematics_out(i)%ren_scale_expr = & - original%kinematics_out(i)%ren_scale_expr - copy%kinematics_out(i)%reweighting_expr = & - original%kinematics_out(i)%reweighting_expr - if (i > 1) then - call evaluator_init_identity (copy%kinematics_out(i)%strfun_snapshot, & - copy_beam_int) - copy%kinematics_out(i)%strfun => evaluator_get_int_ptr ( & - copy%kinematics_out(i)%strfun_snapshot) - else - copy%kinematics_out(i)%strfun => copy_beam_int - end if - if (original%use_beams) copy%kinematics_out(i)%eval_trace = & - original%kinematics_out(i)%eval_trace - strfun_int => original%kinematics_out(i)%strfun - copy_strfun_int => copy%kinematics_out(i)%strfun - hi_int => core_interaction_get_int_ptr (original%ci, i) - hi_eval_trace => core_interaction_get_eval_trace_ptr (original%ci, i) - hi_eval_sqme => core_interaction_get_eval_sqme_ptr (original%ci, i) - hi_eval_flows => core_interaction_get_eval_flows_ptr (original%ci, i) - copy_hi_int => core_interaction_get_int_ptr (copy%ci, i) - copy_hi_eval_trace => core_interaction_get_eval_trace_ptr (copy%ci, i) - copy_hi_eval_sqme => core_interaction_get_eval_sqme_ptr (copy%ci, i) - copy_hi_eval_flows => core_interaction_get_eval_flows_ptr (copy%ci, i) - call interaction_reassign_links & - (copy_hi_int, strfun_int, copy_strfun_int) - call evaluator_reassign_links & - (copy_hi_eval_trace, strfun_int, copy_strfun_int) - call evaluator_reassign_links & - (copy_hi_eval_sqme, strfun_int, copy_strfun_int) - call evaluator_reassign_links & - (copy_hi_eval_flows, strfun_int, copy_strfun_int) - call evaluator_reassign_links & - (copy_hi_eval_trace, hi_int, copy_hi_int) - call evaluator_reassign_links & - (copy_hi_eval_sqme, hi_int, copy_hi_int) - call evaluator_reassign_links & - (copy_hi_eval_flows, hi_int, copy_hi_int) - call evaluator_reassign_links & - (copy%kinematics_out(i)%eval_trace, strfun_int, copy_strfun_int) -! call evaluator_reassign_links & -! (copy%kinematics_out(i)%eval_sqme, strfun_int, copy_strfun_int) -! call evaluator_reassign_links & -! (copy%kinematics_out(i)%eval_flows, strfun_int, copy_strfun_int) - call evaluator_reassign_links & - (copy%kinematics_out(i)%eval_trace, hi_eval_trace, copy_hi_eval_trace) -! call evaluator_reassign_links & -! (copy%kinematics_out(i)%eval_sqme, hi_eval_sqme, copy_hi_eval_sqme) -! call evaluator_reassign_links & -! (copy%kinematics_out(i)%eval_flows, hi_eval_flows, copy_hi_eval_flows) - end do - copy%trivial_kinematics = original%trivial_kinematics - if (allocated (original%flv_in)) then - allocate (copy%flv_in(size (original%flv_in))) - copy%flv_in = original%flv_in - end if - if (allocated (original%flv_out_eff)) then - allocate (copy%flv_out_eff(size (original%flv_out_eff))) - copy%flv_out_eff = original%flv_out_eff - end if - if (allocated (original%flv_out_real)) then - allocate (copy%flv_out_real(size (original%flv_out_real))) - copy%flv_out_real = original%flv_out_real - end if - if (allocated (original%sqme_diagonal_entries)) then - allocate (copy%sqme_diagonal_entries( & - size (original%sqme_diagonal_entries))) - copy%sqme_diagonal_entries = copy%sqme_diagonal_entries - end if - process%copy => copy - end subroutine process_make_copy - -@ %def process_make_copy -@ Request a process copy. If there is a copy currently not in use, -activate it. Otherwise, make a new copy. In the original process, -point to this copy as the working copy. -<>= - public :: process_request_copy -<>= - recursive subroutine process_request_copy (process, copy, original) - type(process_t), intent(inout), target :: process - type(process_t), pointer :: copy - type(process_t), intent(inout), target, optional :: original - if (associated (process%copy)) then - if (process%copy%in_use) then - if (present (original)) then - call process_request_copy (process%copy, copy, original) - else - call process_request_copy (process%copy, copy, process) - end if - else - copy => process%copy - copy%in_use = .true. - if (present (original)) then - original%working_copy => copy - else - process%working_copy => copy - end if - end if - else - if (present (original)) then - call process_make_copy (process, original) - else - call process_make_copy (process, original=process) - end if - copy => process%copy - copy%in_use = .true. - if (present (original)) then - original%working_copy => copy - else - process%working_copy => copy - end if - end if - end subroutine process_request_copy - -@ %def process_request_copy -@ Return the working copy of a process. If there is none, return the -process itself. -<>= - function process_get_working_copy_ptr (process) result (copy) - type(process_t), intent(in), target :: process - type(process_t), pointer :: copy - if (associated (process%working_copy)) then - copy => process%working_copy - else - copy => process - end if - end function process_get_working_copy_ptr - -@ %def process_get_working_copy_ptr -@ Tag a given process copy as the working copy. When looking for the working -copy, a pointer to this one will be returned. -<>= - public :: process_tag_as_working_copy -<>= - subroutine process_tag_as_working_copy (process) - type(process_t), intent(inout), target :: process - type(process_t), pointer :: original - if (associated (process%original)) then - original => process%original - original%working_copy => process - else - call msg_bug ("Process tag as working copy failed") - end if - end subroutine process_tag_as_working_copy - -@ %def process_tag_as_working_copy -@ Mark this copy of the current process as not in use, so it can be -requested again. (Use with care! The copy will not reflect changes made to -the original process.) -<>= - public :: process_free_copy -<>= - subroutine process_free_copy (process) - type(process_t), intent(inout), target :: process - process%in_use = .false. - if (associated (process%original)) then - process%original%working_copy => null () - end if - end subroutine process_free_copy - -@ %def process_free_copy -@ Delete all copies. -<>= - public :: process_delete_copy -<>= - recursive subroutine process_delete_copies (process) - type(process_t), intent(inout), target :: process - if (associated (process%copy)) then - call process_final (process%copy) - deallocate (process%copy) - end if - end subroutine process_delete_copies - -@ %def process_delete_copies -@ -\subsection{Process store} -The process store is a container for the list of all processes. The -list is expanded as needed during program execution. The container is -implemented as a module variable. Thus, there is only one process -store in the program. - -The reason for this is the sampling function, which needs to access it -without referencing it as an argument. Instead, it takes an integer -argument which identifies the process. For direct access, we maintain -a process pointer array as a shortcut to the list. -\subsubsection{Type and object} -<>= - type :: process_entry_t - type(process_t) :: process - type(process_entry_t), pointer :: next => null () - end type process_entry_t - -@ %def process_entry_t -<>= - type :: process_store_t - integer :: n = 0 - type(process_entry_t), pointer :: first => null () - type(process_entry_t), pointer :: last => null () - type(process_p), dimension(:), allocatable :: proc - end type process_store_t - -@ %def process_store_t -<>= - type(process_store_t), save :: store - -@ %def process_store -@ Finalize. Delete the list explicitly, the pointer array is just -deallocated. -<>= - public :: process_store_final -<>= - subroutine process_store_final () - type(process_entry_t), pointer :: current - if (allocated (store%proc)) deallocate (store%proc) - store%last => null () - do while (associated (store%first)) - current => store%first - store%first => current%next - call process_final (current%process) - deallocate (current) - end do - store%n = 0 - end subroutine process_store_final - -@ %def process_store_final -@ Handlers for unloading and reloading process libraries -<>= - public :: process_store_unload - public :: process_store_reload -<>= - subroutine process_store_unload (libname) - type(string_t), intent(in) :: libname - type(process_entry_t), pointer :: entry - entry => store%first - do while (associated (entry)) - if (process_library_get_name (entry%process%prc_lib) == libname) & - call worker (entry%process) - entry => entry%next - end do - - contains - - recursive subroutine worker (process) - type(process_t), intent(inout), target :: process - call core_interaction_unload (process%ci) - if (associated (process%copy)) call worker (process%copy) - end subroutine worker - - end subroutine process_store_unload - - subroutine process_store_reload (libname) - type(string_t), intent(in) :: libname - type(process_entry_t), pointer :: entry - entry => store%first - do while (associated (entry)) - if (process_library_get_name (entry%process%prc_lib) == libname) & - call worker (entry%process) - entry => entry%next - end do - - contains - - recursive subroutine worker (process) - type(process_t), intent(inout), target :: process - call core_interaction_reload (process%ci, process%prc_lib) - if (associated (process%copy)) call worker (process%copy) - end subroutine worker - - end subroutine process_store_reload - -@ %def process_store_unload -@ %def process_store_reaload -@ Write all contents. This produces lots of output. -<>= - public :: process_store_write -<>= - subroutine process_store_write (unit) - integer, intent(in), optional :: unit - type(process_t), pointer :: process - integer :: u, i - u = output_unit (unit); if (u < 0) return - write (u, *) repeat ("%", 78) - write (u, *) "Process store contents" - do i = 1, store%n - write (u, *) repeat ("%", 78) - write (u, *) "Process No.", i - process => store%proc(i)%ptr - call process_write (process, unit) - end do - write (u, *) "Process store end" - write (u, *) repeat ("%", 78) - end subroutine process_store_write - -@ %def process_store_write -@ Write integration results (summary) -<>= - public :: process_store_write_results -<>= - subroutine process_store_write_results (unit) - integer, intent(in), optional :: unit - type(process_t), pointer :: process - type(string_t), dimension(:), allocatable :: process_id - real(default), dimension(:), allocatable :: integral, error - type(string_t), dimension(:), allocatable :: phys_unit - integer :: u, i, process_id_len - character(12) :: fmt - u = output_unit (unit); if (u < 0) return - allocate (process_id (store%n), phys_unit (store%n)) - allocate (integral (store%n), error (store%n)) - do i = 1, store%n - process => store%proc(i)%ptr - if (process%initialized) then - process_id(i) = process%id - integral(i) = process_get_integral (process) - error(i) = process_get_error (process) - select case (process%type) - case (PRC_DECAY); phys_unit(i) = "GeV" - case (PRC_SCATTERING); phys_unit(i) = "fb" - case default; phys_unit(i) = "[undefined]" - end select - else - process_id(i) = "" - end if - end do - write (u, "(A)") "|========================= Results Summary =========================|" - if (store%n == 0) then - write (u, *) "[empty]" - else - process_id_len = maxval (len (process_id)) - write (fmt, "(A,I0,A)") "(1x,A", process_id_len + 1, ")" - do i = 1, store%n - if (process_id(i) /= "") then - write (u, fmt, advance="no") char (process_id(i)) // ":" - write (u, "(1x, 1PE15.8, 1x, '+-', 1x, 1PE8.2)", advance="no") & - integral(i), error(i) - write (u, "(1x, A)") char (phys_unit(i)) - end if - end do - end if - write (u, "(A)") "|=============================================================================|" - end subroutine process_store_write_results - -@ %def process_store_write_results -@ -\subsubsection{Accessing contents} -Return the current number of processes. -<>= - function process_store_get_n_processes () result (n) - integer :: n - n = store%n - end function process_store_get_n_processes - -@ %def process_store_get_n_processes -@ Return a pointer to the process entry with given ID. If it does not -exist, return a null pointer. -<>= - function process_store_get_entry_ptr (process_id) result (entry) - type(process_entry_t), pointer :: entry - type(string_t), intent(in) :: process_id - entry => store%first - do while (associated (entry)) - if (entry%process%id == process_id) exit - entry => entry%next - end do - end function process_store_get_entry_ptr - -@ %def process_store_get_entry_ptr -@ Return the index of the process entry with given ID within the -process store. If it does not exist, return zero. -<>= - function process_store_get_process_index (process_id) result (process_index) - integer :: process_index - type(string_t), intent(in) :: process_id - type(process_entry_t), pointer :: entry - entry => process_store_get_entry_ptr (process_id) - if (associated (entry)) then - process_index = entry%process%store_index - else - process_index = 0 - end if - end function process_store_get_process_index - -@ %def process_store_get_process_index -@ Return a pointer to the process with index [[i]] or alphanumeric ID. -<>= - public :: process_store_get_process_ptr -<>= - interface process_store_get_process_ptr - module procedure process_store_get_process_ptr_int - module procedure process_store_get_process_ptr_id - end interface - -<>= - function process_store_get_process_ptr_int (i) result (process) - type(process_t), pointer :: process - integer, intent(in) :: i - if (i > 0 .and. i <= size (store%proc)) then - process => store%proc(i)%ptr - else - process => null () - end if - end function process_store_get_process_ptr_int - - function process_store_get_process_ptr_id (id) result (process) - type(process_t), pointer :: process - type(string_t), intent(in) :: id - integer :: i - do i = 1, store%n - process => store%proc(i)%ptr - if (process%id == id) return - end do - process => null () - end function process_store_get_process_ptr_id - -@ %def process_store_get_process_ptr -@ -\subsubsection{Filling the process store} -Append a new process entry and return a pointer to it, unless the -process already exists. If the process exists, finalize it and return -the pointer for fresh initialization. If it does not exist, allocate -a new entry and update the shortcut array. If the latter is full, -expand by a fixed block size. -<>= - function process_store_get_fresh_process_ptr (process_id) result (process) - type(process_t), pointer :: process - type(string_t), intent(in) :: process_id - type(process_entry_t), pointer :: current, entry - integer :: i - integer, parameter :: BLOCK_SIZE = 10 - current => process_store_get_entry_ptr (process_id) - if (associated (current)) then - call process_final (current%process) - else - allocate (current) - if (store%n == 0) then - allocate (store%proc (BLOCK_SIZE)) - store%first => current - else - store%last%next => current - end if - store%last => current - store%n = store%n + 1 - if (store%n <= size (store%proc)) then - store%proc(store%n)%ptr => current%process - else - deallocate (store%proc) - allocate (store%proc (store%n + BLOCK_SIZE)) - i = 1 - entry => store%first - do while (associated (entry)) - store%proc(i)%ptr => entry%process; i = i + 1 - entry => entry%next - end do - end if - end if - process => current%process - end function process_store_get_fresh_process_ptr - -@ %def process_store_get_fresh_process_ptr -@ Append a new process entry (or find an existing one) and initialize -it with a particular hard process, model pointer and total energy. -Return a pointer to the process object, so further process preparation -can be done by the caller. Allocate or expand the array as needed. -<>= - public :: process_store_init_process -<>= - subroutine process_store_init_process (process, & - prc_lib, process_id, model, var_list, & - use_beams) - type(process_t), pointer :: process - type(process_library_t), intent(inout), target :: prc_lib - type(string_t), intent(in) :: process_id - type(model_t), intent(in), target :: model - type(pdf_builtin_status_t) :: pdf_builtin_status - type(var_list_t), intent(in), target :: var_list - logical, intent(in) :: use_beams - integer :: process_lib_index, process_store_index - procedure(prclib_unload_hook), pointer :: unload_hook - procedure(prclib_reload_hook), pointer :: reload_hook - process_lib_index = process_library_get_process_index (prc_lib, process_id) - if (process_lib_index == 0) then - call msg_fatal ("Process '" // char (process_id) & - // "' is not available.") - end if - process_store_index = process_store_get_process_index (process_id) - process => process_store_get_fresh_process_ptr (process_id) - if (process_store_index == 0) then - process_store_index = process_store_get_n_processes () - end if - unload_hook => process_store_unload - reload_hook => process_store_reload - call process_library_set_unload_hook (prc_lib, unload_hook) - call process_library_set_reload_hook (prc_lib, reload_hook) - call process_init & - (process, prc_lib, process_lib_index, process_store_index, & - process_id, model, var_list, use_beams) - end subroutine process_store_init_process - -@ %def process_store_init_process -@ -\subsection{Sampling function} -This is the function that computes the squared matrix element in the -form needed for VAMP integration. It computes and multiplies the flux -factor for the incoming particles, the phase-space factors of the -integration channels combined with the VAMP grid jacobians to a common -phase-space factor, the phase-space volume, and the squared matrix -element of the hard interaction. The latter is only evaluated if the -event passes cuts. - -There are time-critical operations involved here, so we set breakpoints. - -When doing a mere matrix-element test, after evaluating kinematics we -do not stop if we encounter an unphysical configuration. This use -case is characterized by the absence of the [[grids]] argument. -<>= - function sample_function (xi, prc_index, weights, channel, grids) result (f) - real(default) :: f - real(default), dimension(:), intent(in) :: xi - integer, intent(in) :: prc_index - real(default), dimension(:), intent(in), optional :: weights - integer, intent(in), optional :: channel - type(vamp_grid), dimension(:), intent(in), optional :: grids - type(process_t), pointer :: process - logical :: ok - integer :: i - call terminate_now_if_signal () - process => process_get_working_copy_ptr (store%proc(prc_index)%ptr) - process%sample_function_value = 0 - call process_status_reset_flags (process%status) - call process_status_called (process%status) - call core_interaction_set_state (process%ci, CI_STATE_CLEAR) - call process_set_kinematics (process, xi, channel, ok) - if (ok) then - call process_fill_subevt (process, transform=process%is_cascade_decay) - ok = process_passes_cuts (process) - if (ok) call process_status_passed_cuts (process%status) - end if - call terminate_now_if_signal () - if (ok) then - call process_compute_scale (process) - call process_update_alpha_s (process) - call core_interaction_set_state (process%ci, CI_STATE_EVALUATE) - call process_evaluate (process) - do i = 1, process%n_kinematics_in - if (.not. process%kinematics_in(i)%passed) cycle - process%kinematics_in(i)%passed = core_interaction_needs_weight ( & - process%ci, i) - end do - call process_complete_kinematics (process, channel) - if (present (grids)) then - call process_compute_vamp_phs_factor (process, weights) - else - process%kinematics_in(:)%vamp_phs_factor = 1 - end if - do i = 1, process%n_kinematics_in - if (.not. process%kinematics_in(i)%passed) cycle - call core_interaction_set_weight (process%ci, & - process%kinematics_in(i)%phs_volume * & - process%kinematics_in(i)%vamp_phs_factor, & - i) - end do - call core_interaction_set_state (process%ci, CI_STATE_WEIGHTS_SET) - call process_compute_reweighting_factor (process) - do i = 1, process%n_kinematics_out - if (.not. process%kinematics_out(i)%passed) cycle - process%sample_function_value = process%sample_function_value + & - process%kinematics_out(i)%sqme * & - process%kinematics_out(i)%reweighting_factor * & - core_interaction_get_weight (process%ci, i) - end do - process%sample_function_value = process%sample_function_value * & - process%flux_factor * process%sf_mapping_factor - call process_status_passed_evaluation (process%status) - end if - f = process%sample_function_value - call terminate_now_if_signal () - end function sample_function - -@ %def sample_function -@ -\subsection{Old Tests} -<>= - public :: process_test -<>= - subroutine process_test () - type(os_data_t), pointer :: os_data => null () - type(process_library_t), pointer :: prc_lib => null () - type(model_t), pointer :: model => null () - type(var_list_t), pointer :: var_list => null () - allocate (os_data) - allocate (prc_lib) - allocate (var_list) - call process_library_store_final - call os_data_init (os_data) - print *, "*** Read model file" - call syntax_model_file_init () - call model_list_read_model & - (var_str("SM"), var_str("SM.mdl"), os_data, model) - var_list => model_get_var_list_ptr (model) - call syntax_pexpr_init () - call syntax_phs_forest_init () - print * - print *, "*** Create process library" - call var_list_append_string (var_list, name = "$library_name", sval = "prc_proc") ! $ - call var_list_append_log (var_list, name = "?read_color_factors", lval = .true.) - call var_list_append_log (var_list, name = "?alpha_s_is_fixed", lval = .true.) - call process_library_store_append (var_str ("prc_proc"), os_data, prc_lib) - call process_library_init (prc_lib, var_str("prc_proc"), os_data) - print * - call process_test1 (prc_lib, os_data, model, var_list) - print * - call process_test2 (prc_lib, os_data, model, var_list) - print * - call process_test3 (prc_lib, os_data, model, var_list) - print * - call process_test4 (prc_lib, os_data, model, var_list) - print * - print *, "* Cleanup" - call process_store_final () - call syntax_pexpr_final () - call syntax_phs_forest_final () - call syntax_model_file_final () - call process_library_final (prc_lib) - deallocate (prc_lib) - deallocate (os_data) - end subroutine process_test - -@ %def process_test -@ Test decay process: $Z\to e^+e^-$ (colorless); polarized and unpolarized -<>= - subroutine process_test1 (prc_lib, os_data, model, var_list) - type(process_library_t), intent(inout) :: prc_lib - type(model_t), intent(in), target :: model - type(var_list_t), intent(inout), target :: var_list - type(process_t), pointer :: process - type(string_t) :: objlist - type(string_t), dimension(:), allocatable :: prt_in, prt_out - type(os_data_t), intent(inout) :: os_data - type(phs_parameters_t) :: phs_par - type(mapping_defaults_t) :: mapping_defaults - type(flavor_t), dimension(1) :: flv - type(polarization_t), dimension(1) :: pol - type(beam_data_t) :: beam_data - type(grid_parameters_t) :: grid_parameters - type(tao_random_state) :: rng - integer :: i - logical :: rebuild_phs = .true. - logical :: discard_integrals, adapt_grids, adapt_weights, print_current - logical :: time_estimate = .true. - print *, "*** Test decay process Z -> e+ e- ***" - print * - print *, "* Initialization" - call tao_random_create (rng, 0) - allocate (prt_in (1), prt_out (2)) - print *, "setting particles for Z -> e+ e-" - prt_in(1) = "Z" - prt_out(1) = "e1" - prt_out(2) = "E1" - call process_library_append & - (prc_lib, CI_OMEGA, var_str ("zff"), model, prt_in, prt_out, method = PRC_TEST, & - message = .true. ) - deallocate (prt_in, prt_out) - allocate (prt_in (1), prt_out (2)) - print *, "setting particles for Z -> u ubar" - prt_in(1) = "Z" - prt_out(1) = "u" - prt_out(2) = "U" - call process_library_append & - (prc_lib, CI_OMEGA, var_str ("zqq"), model, prt_in, prt_out, method = PRC_TEST, & - message = .true. ) - deallocate (prt_in, prt_out) - allocate (prt_in (2), prt_out (3)) - print *, "setting particles for e+ e- -> nu nubar H" - prt_in(1) = "e1" - prt_in(2) = "E1" - prt_out(1) = "nue" - prt_out(2) = "nuebar" - prt_out(3) = "H" - call process_library_append & - (prc_lib, CI_OMEGA, var_str ("nnh"), model, prt_in, prt_out, method = PRC_TEST, & - message = .true. ) - deallocate (prt_in, prt_out) - allocate (prt_in (2), prt_out (2)) - print *, "setting particles for g g -> u ubar" - prt_in(1) = "g" - prt_in(2) = "g" - prt_out(1) = "u" - prt_out(2) = "U" - call process_library_append & - (prc_lib, CI_OMEGA, var_str ("gguu"), model, prt_in, prt_out, method = PRC_TEST, & - message = .true. ) - deallocate (prt_in, prt_out) - print * - print *, "* Generate code" - call process_library_generate_code (prc_lib, os_data) - print * - print *, "* Write driver file 'prc_proc_interface.f90'" - call process_library_write_driver (prc_lib) - print * - print *, "* Compile and link as 'libprc_proc.so'" - call process_library_compile (prc_lib, os_data, .false., objlist) - call process_library_link (prc_lib, os_data, objlist) - print * - print *, "* Load shared libraries" - call process_library_load (prc_lib, os_data, var_list = var_list) - print * - call process_store_init_process & - (process, prc_lib, var_str ("zff"), model, & - var_list, use_beams = .true.) - print * - print *, "*** Beam/strfun setup (unpolarized)" - print * - call flavor_init (flv, (/ 23 /), model) - call polarization_init_unpolarized (pol(1), flv(1)) - call beam_data_init_decay (beam_data, flv, pol) - call process_setup_beams (process, beam_data, 0) - call process_connect_strfun (process) - call process_setup_subevt (process) - print * - print *, "* Phase space setup" - call openmp_set_num_threads_verbose (1) - call process_setup_phase_space (process, rebuild_phs, & - os_data, phs_par, mapping_defaults, filename_out=var_str("zff.phs"), & - vis_channels = .false.) - call process_init_vamp_history (process, 1) - print * - print *, "*** Test integration" - print *, "* Grids setup" - grid_parameters%stratified = .false. - call process_setup_grids (process, grid_parameters, calls=9) - print * - print *, "* 1 iteration with minimal number of calls" - call process_results_write_header (process) - do i = 1, 1 - discard_integrals = i==1 - adapt_grids = .true. - adapt_weights = .true. - print_current = .true. - call process_integrate (process, rng, grid_parameters, & - 1, 1, 1, 9, & - discard_integrals, adapt_grids, adapt_weights, print_current, & - time_estimate) - end do - call process_results_write_footer (process) - print * - print *, "* Process written to 'fort.60'" - call process_write (process, 60) - print * - print *, "*** Beam/strfun setup (polarized)" - call process_store_init_process & - (process, prc_lib, var_str ("zff"), model, & - var_list, use_beams = .true.) - call flavor_init (flv, (/ 23 /), model) - call polarization_init_axis & - (pol(1), flv(1), (/ 0._default, 0._default, 1._default/)) - call beam_data_init_decay (beam_data, flv, pol) - call process_setup_beams (process, beam_data, 0) - call process_connect_strfun (process) - call process_setup_subevt (process) - print * - print *, "* Phase space setup" - call openmp_set_num_threads_verbose (1) - call process_setup_phase_space (process, rebuild_phs, & - os_data, phs_par, mapping_defaults, filename_out=var_str("zff.phs"), & - vis_channels = .false.) - call process_init_vamp_history (process, 6) - print * - print *, "*** Test integration" - print *, "* Grids setup" - grid_parameters%stratified = .false. - call process_setup_grids (process, grid_parameters, calls=10000) - print * - print *, "* 3 + 3 iterations" - call process_results_write_header (process) - do i = 1, 3 - discard_integrals = i==1 - adapt_grids = .true. - adapt_weights = .true. - print_current = .true. - call process_integrate (process, rng, grid_parameters, & - 1, 1, 1, 10000, & - discard_integrals, adapt_grids, adapt_weights, print_current, & - time_estimate) - end do - call process_results_write_current_average (process) - call process_integrate (process, rng, grid_parameters, & - 2, 1, 3, 10000, & - .true., .true., .false., .true., .true.) - call process_results_write_footer (process) - call process_write_time_estimate (process) - print * - print *, "* Process written to 'fort.61'" - call process_write (process, 61) - end subroutine process_test1 - -@ %def process_test1 -@ Test decay process: $Z\to uu$. -<>= - subroutine process_test2 (prc_lib, os_data, model, var_list) - type(process_library_t), intent(inout) :: prc_lib - type(model_t), intent(in), target :: model - type(var_list_t), intent(in), target :: var_list - type(string_t) :: objlist - type(process_t), pointer :: process - type(os_data_t), intent(inout) :: os_data - type(phs_parameters_t) :: phs_par - type(mapping_defaults_t) :: mapping_defaults - type(flavor_t), dimension(1) :: flv - type(polarization_t), dimension(1) :: pol - type(beam_data_t) :: beam_data - type(grid_parameters_t) :: grid_parameters - type(tao_random_state) :: rng - real(default) :: weight - logical :: time_estimate = .true. - integer :: i - logical :: rebuild_phs = .true. - logical :: discard_integrals, adapt_grids, adapt_weights, print_current - print *, "*** Test decay process Z -> u ubar ***" - print * - print *, "* Initialization" - call tao_random_create (rng, 0) - call process_store_init_process & - (process, prc_lib, var_str ("zqq"), model, & - var_list, use_beams=.false.) - print *, " Process ID = ", char (process%id) - print * - print *, "*** Beam/strfun setup (unpolarized)" - print * - call flavor_init (flv, (/ 23 /), model) - call polarization_init_unpolarized (pol(1), flv(1)) - call beam_data_init_decay (beam_data, flv, pol) - call process_setup_beams (process, beam_data, 0) - call process_connect_strfun (process) - call process_setup_subevt (process) - print * - print *, "* Phase space setup" - call openmp_set_num_threads_verbose (1) - call process_setup_phase_space (process, rebuild_phs, & - os_data, phs_par, mapping_defaults, filename_out=var_str("zqq.phs"), & - vis_channels = .false.) - call process_init_vamp_history (process, 1) - print * - print *, "*** Test integration" - print *, "* Grids setup" - grid_parameters%stratified = .false. - call process_setup_grids (process, grid_parameters, calls=9) - print * - print *, "* 1 iteration with minimal number of calls" - call process_results_write_header (process) - do i = 1, 1 - discard_integrals = i==1 - adapt_grids = .true. - adapt_weights = .true. - print_current = .true. - call process_integrate (process, rng, grid_parameters, & - 1, 1, 1, 9, & - discard_integrals, adapt_grids, adapt_weights, print_current, & - time_estimate) - end do - call process_results_write_footer (process) - call process_write_time_estimate (process) - print * - print *, "* Process written to 'fort.62'" - call process_write (process, 62) - print * - print *, "*** Event generation" - call process_setup_event_generation (process) - print * - print *, "* Generate weighted event" - call process_generate_weighted_event (process, rng, weight) - print * - print *, "* Process written to 'fort.63'" - call process_write (process, 63) - print *, "weight =", weight - print * - print *, "* Generate unweighted event" - call process_generate_unweighted_event (process, rng, weight) - print * - print *, "* Process written to 'fort.64'" - call process_write (process, 64) - print *, "excess weight =", weight - end subroutine process_test2 - -@ %def process_test2 -@ Test scattering process: ee->nnh (colorless) -<>= - subroutine process_test3 (prc_lib, os_data, model, var_list) - type(process_library_t), intent(inout) :: prc_lib - type(model_t), intent(in), target :: model - type(var_list_t), intent(in), target :: var_list - type(process_t), pointer :: process - type(os_data_t), intent(inout) :: os_data - type(phs_parameters_t) :: phs_par - type(mapping_defaults_t) :: mapping_defaults - type(flavor_t), dimension(2) :: flv - type(polarization_t), dimension(2) :: pol - type(beam_data_t) :: beam_data - type(grid_parameters_t) :: grid_parameters - real(default), dimension(:), allocatable :: x - logical :: time_estimate = .true. - integer :: channel - logical :: ok - integer :: i - type(tao_random_state) :: rng - logical :: rebuild_phs = .true. - logical :: discard_integrals, adapt_grids, adapt_weights, print_current - print *, "*** Test scattering process e+ e- -> nu nubar H ***" - print * - print *, "* Initialization" - call tao_random_create (rng, 0) - call process_store_init_process & - (process, prc_lib, var_str ("nnh"), model, & - var_list, use_beams = .true.) - print *, " Process ID = ", char (process%id) - print * - print *, "* Beam/strfun setup" - print * - call flavor_init (flv, (/ 11, -11 /), model) - call polarization_init_unpolarized (pol(1), flv(1)) - call polarization_init_unpolarized (pol(2), flv(2)) - call beam_data_init_sqrts (beam_data, 500._default, flv, pol) - call process_setup_beams (process, beam_data, 0) - call process_connect_strfun (process) - call process_setup_subevt (process) - print * - print *, "* Phase space setup" - call openmp_set_num_threads_verbose (1) - call process_setup_phase_space (process, rebuild_phs, & - os_data, phs_par, mapping_defaults, filename_out=var_str("nnh.phs"), & - vis_channels = .false.) - call process_init_vamp_history (process, 8) - print * - print *, "* Kinematics setup" - allocate (x (process_get_n_parameters (process))) - do i = 1, size (x) - x(i) = (i - 0.5_default) * (1._default / size (x)) - end do - channel = 1 - call process_set_kinematics (process, x, channel, ok) - print * - print *, "* Process written to 'fort.70'" - call process_write (process, 70) - print * - print *, "*** Test process evaluation" - call core_interaction_set_cut_status (process%ci, .true., 1) - call core_interaction_set_state (process%ci, CI_STATE_EVALUATE) - call process_evaluate (process) - print * - print *, "* Process written to 'fort.71'" - call process_write (process, 71) - print * - print *, "*** Test integration" - print *, "* Grids setup" - call process_setup_grids (process, grid_parameters, calls=20000) - print * - print *, "* 5 + 3 iterations" - call process_results_write_header (process) - do i = 1, 5 - discard_integrals = i==1 - adapt_grids = .true. - adapt_weights = .true. - print_current = .true. - call process_integrate (process, rng, grid_parameters, & - 1, 1, 1, 10000, & - discard_integrals, adapt_grids, adapt_weights, print_current, & - time_estimate) - end do - call process_results_write_current_average (process) - call process_integrate (process, rng, grid_parameters, & - 2, 1, 3, 20000, .true., .false., .false., .true., .true.) - call process_results_write_footer (process) - call process_write_time_estimate (process) - print * - print *, "* Process written to 'fort.72'" - call process_write (process, 72) - end subroutine process_test3 - -@ %def process_test3 -@ Test scattering process: $gg \to uu$. -<>= - subroutine process_test4 (prc_lib, os_data, model, var_list) - type(process_library_t), intent(inout) :: prc_lib - type(model_t), intent(in), target :: model - type(var_list_t), intent(in), target :: var_list - type(process_t), pointer :: process - type(os_data_t), intent(inout) :: os_data - type(phs_parameters_t) :: phs_par - type(mapping_defaults_t) :: mapping_defaults - type(flavor_t), dimension(2) :: flv - type(polarization_t), dimension(2) :: pol - type(beam_data_t) :: beam_data - type(pdf_builtin_status_t) :: pdf_builtin_status - type(pdf_builtin_data_t), dimension(2) :: data - type(stream_t), target :: stream - type(parse_tree_t) :: parse_tree - type(grid_parameters_t) :: grid_parameters - logical :: time_estimate = .true. - integer :: i - type(tao_random_state) :: rng - logical :: rebuild_phs = .true. - print *, "*** Test process setup for g g -> u ubar ***" - print * - print *, "* Initialization" - call tao_random_create (rng, 0) - call process_store_init_process & - (process, prc_lib, var_str ("gguu"), model, & - var_list, use_beams = .true.) - print *, " Process ID = ", char (process%id) - print * - print *, "* Beam/strfun setup" - print * - ! call flavor_init (flv, (/ 21, 21 /), model) - call flavor_init (flv, (/ PROTON, PROTON /), model) - call polarization_init_unpolarized (pol(1), flv(1)) - call polarization_init_unpolarized (pol(2), flv(2)) - call beam_data_init_sqrts (beam_data, 14000._default, flv, pol) - ! call process_setup_beams (process, beam_data, 0, 0) - call process_setup_beams (process, beam_data, 2) - call pdf_builtin_init (data(1), pdf_builtin_status, model, flv(1), name = & - var_str("cteq6l"), path = os_data%pdf_builtin_datapath) - call pdf_builtin_init (data(2), pdf_builtin_status, model, flv(2), name = & - var_str("cteq6l"), path = os_data%pdf_builtin_datapath) - call process_set_strfun (process, 1, 1, data(1), 1) - call process_set_strfun (process, 2, 2, data(2), 1) - call process_connect_strfun (process) - call process_setup_subevt (process) - print * - print *, "* Phase space setup" - call openmp_set_num_threads_verbose (1) - call process_setup_phase_space (process, rebuild_phs, & - os_data, phs_par, mapping_defaults, filename_out=var_str("gguu.phs"), & - vis_channels = .false.) - call process_init_vamp_history (process, 18) - print * - print *, "* Cuts setup" - call stream_init (stream, var_str ("all Pt > 50 GeV [u:d:U:D]")) - call parse_tree_init_lexpr (parse_tree, stream, .true.) - call process_setup_cuts (process, parse_tree_get_root_ptr (parse_tree)) - call parse_tree_final (parse_tree) - call stream_final (stream) - print * - print *, "* Scale setup" - call stream_init (stream, var_str ("1 TeV")) - call parse_tree_init_expr (parse_tree, stream, .true.) - call process_setup_fac_scale (process, parse_tree_get_root_ptr (parse_tree)) - call parse_tree_final (parse_tree) - call stream_final (stream) - print * - print *, "*** Test integration" - print *, "* Grids setup" - call process_setup_grids (process, grid_parameters, calls=10000) - print * - print *, "* 5 + 3 iterations" - call process_results_write_header (process) - do i = 1, 5 - call process_integrate (process, rng, grid_parameters, & - 1, 1, 1, 50000, i==1, .true., i>2, .true., .true.) - end do - call process_results_write_current_average (process) - call process_integrate (process, rng, grid_parameters, & - 2, 1, 3, 50000, .true., .false., .true., .true., .true.) - call process_results_write_footer (process) - call process_write_time_estimate (process) - print * - print *, "* Process written to 'fort.90'" - call process_write (process, 90) - end subroutine process_test4 - -@ %def process_test4 -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Decays} - -Particles can be marked as unstable, so during event generation -(cascade) decays are applied to them. For each decay mode, we -temporarily use the corresponding process entry in the process store, -which is filled and evaluated and connected to the mother process. -<<[[decays.f90]]>>= -<> - -module decays - -<> - use kinds, only: double !NODEP! -<> - use limits, only: MAX_TRIES_FOR_DECAY_CHAIN !NODEP! -<> - use diagnostics !NODEP! - use lorentz !NODEP! - use tao_random_numbers !NODEP! - use md5 - use models - use flavors - use quantum_numbers - use processes - use interactions - use evaluators - -<> - -<> - -<> - -<> - -contains - -<> - -end module decays -@ %def decays -@ -\subsection{Decay configuration} -We store the decay properties of a particular particle. First, we -need an array of process pointers. For the final-state particles, we need to -store the fact whether they are stable themselves and, if not, their decay -properties. This is necessary because it determines the quantum numbers we -need to keep for the decay products in event generation. -<>= - type :: decay_channel_t - private - type(process_t), pointer :: process => null () - real(default) :: br = 0 - type(flavor_t), dimension(:), allocatable :: unstable_products - logical, dimension(:), allocatable :: isotropic - logical, dimension(:), allocatable :: diagonal - end type decay_channel_t - -@ %def process_ptr_t -@ Decay configurations are stored in a list: -<>= - public :: decay_configuration_t -<>= - type :: decay_configuration_t - private - type(flavor_t) :: flv - type(model_t), pointer :: model => null () - real(default) :: width = 0 - logical :: isotropic = .false. - logical :: diagonal = .false. - type(decay_channel_t), dimension(:), allocatable :: channel - type(string_t), dimension(:), allocatable :: process_id - type(decay_configuration_t), pointer :: next => null () - end type decay_configuration_t - -@ %def decay_configuration_t -@ Allocate the array for a known number of decay channels. -<>= - subroutine decay_configuration_init & - (conf, flv, model, width, n_channels, isotropic, diagonal) - type(decay_configuration_t), intent(out) :: conf - type(flavor_t), intent(in) :: flv - type(model_t), intent(in), target :: model - real(default), intent(in) :: width - integer, intent(in) :: n_channels - logical, intent(in) :: isotropic, diagonal - conf%flv = flv - conf%model => model - conf%width = width - conf%isotropic = isotropic - conf%diagonal = diagonal - allocate (conf%channel (n_channels)) - allocate (conf%process_id (n_channels)) - end subroutine decay_configuration_init - -@ %def decay_configuration_init -@ Set/retrieve the pointer to the next configuration in list: -<>= - function decay_configuration_get_next_ptr (conf) result (ptr) - type(decay_configuration_t), pointer :: ptr - type(decay_configuration_t), intent(in) :: conf - ptr => conf%next - end function decay_configuration_get_next_ptr - - subroutine decay_configuration_set_next_ptr (conf, ptr) - type(decay_configuration_t), intent(inout) :: conf - type(decay_configuration_t), pointer :: ptr - conf%next => ptr - end subroutine decay_configuration_set_next_ptr - -@ %def decay_configuration_get_next_ptr -@ %def decay_configuration_set_next_ptr -@ Set a single decay channel: -<>= - public :: decay_configuration_set_channel -<>= - subroutine decay_configuration_set_channel (conf, i, process, br) - type(decay_configuration_t), intent(inout) :: conf - integer, intent(in) :: i - type(process_t), intent(in), target :: process - real(default), intent(in) :: br - integer :: n_unstable_products - conf%channel(i)%process => process - conf%channel(i)%br = br - conf%process_id(i) = process_get_id (process) - call process_get_unstable_products & - (conf%channel(i)%process, conf%channel(i)%unstable_products) - n_unstable_products = size (conf%channel(i)%unstable_products) - if (allocated (conf%channel(i)%isotropic)) & - deallocate (conf%channel(i)%isotropic) - if (allocated (conf%channel(i)%diagonal)) & - deallocate (conf%channel(i)%diagonal) - allocate (conf%channel(i)%isotropic (n_unstable_products)) - allocate (conf%channel(i)%diagonal (n_unstable_products)) - if (n_unstable_products /= 0) then - conf%channel(i)%isotropic = & - flavor_decays_isotropically (conf%channel(i)%unstable_products) - conf%channel(i)%diagonal = & - flavor_decays_diagonal (conf%channel(i)%unstable_products) - end if - end subroutine decay_configuration_set_channel - -@ %def decay_configuration_set_channel -@ Check an existing decay configuration whether the stability of the decay -products has changed. If yes, re-initialize event generation for the -corresponding channel. - -Do the check only if the configuration corresponds to a particle that is -currently known as unstable. -<>= - subroutine decay_configuration_recheck_final_state (conf, verbose) - type(decay_configuration_t), intent(inout) :: conf - logical, intent(in), optional :: verbose - type(flavor_t), dimension(:), allocatable :: flv_unstable - logical, dimension(:), allocatable :: isotropic, diagonal - logical :: modified, verb - integer :: u, i, n_unstable_products - u = logfile_unit () - verb = .false.; if (present (verbose)) verb = verbose - if (flavor_is_stable (conf%flv)) return - do i = 1, size (conf%channel) - call process_get_unstable_products & - (conf%channel(i)%process, flv_unstable) - n_unstable_products = size (flv_unstable) - allocate (isotropic (n_unstable_products)) - allocate (diagonal (n_unstable_products)) - isotropic = flavor_decays_isotropically (flv_unstable) - diagonal = flavor_decays_diagonal (flv_unstable) - if (n_unstable_products == size (conf%channel(i)%unstable_products)) & - then - modified = & - any (flv_unstable /= conf%channel(i)%unstable_products) & - .or. & - any (isotropic .neqv. conf%channel(i)%isotropic) & - .or. & - any (diagonal .neqv. conf%channel(i)%diagonal) - else - modified = .true. - deallocate (conf%channel(i)%unstable_products) - deallocate (conf%channel(i)%isotropic) - deallocate (conf%channel(i)%diagonal) - allocate (conf%channel(i)%unstable_products (n_unstable_products)) - allocate (conf%channel(i)%isotropic (n_unstable_products)) - allocate (conf%channel(i)%diagonal (n_unstable_products)) - end if - if (modified) then - conf%channel(i)%unstable_products = flv_unstable - conf%channel(i)%isotropic = isotropic - conf%channel(i)%diagonal = diagonal - call process_setup_event_generation (conf%channel(i)%process, & - qn_mask_in = new_quantum_numbers_mask (.false., .false., & - mask_h = conf%isotropic, mask_hd = conf%diagonal)) - if (verb) then - call msg_message ("Further modified decay configuration:") - call decay_configuration_write (conf) - call decay_configuration_write (conf, u) - end if - end if - deallocate (flv_unstable, isotropic, diagonal) - end do - end subroutine decay_configuration_recheck_final_state - -@ %def decay_configuration_recheck_final_state -@ Check an existing decay configuration whether it contains any of a -given list of processes, which have been updated since the decay -configuration was stored. If yes, re-initialize event generation for -the updated processes, recalculate the branching ratios and report the -updated decay configuration. - -We assume that the record has been initialized before. -<>= - subroutine decay_configuration_update (conf, process_id, verbose) - type(decay_configuration_t), intent(inout) :: conf - type(string_t), dimension(:), intent(in) :: process_id - logical, intent(in), optional :: verbose - logical, dimension(:), allocatable :: updated - real(default), dimension(:), allocatable :: integral, br - real(default) :: integral_sum - integer :: u, i, j, n_channels - type(process_t), pointer :: process - logical :: verb - u = logfile_unit () - verb = .false.; if (present (verbose)) verb = verbose - if (flavor_is_stable (conf%flv)) return - n_channels = size (conf%channel) - allocate (updated (n_channels)) - allocate (integral (n_channels), br (n_channels)) - updated = .false. - do j = 1, n_channels - do i = 1, size (process_id) - if (process_id(i) == conf%process_id(j)) then - updated(j) = .true. - end if - end do - end do - if (any (updated)) then - do j = 1, n_channels - process => conf%channel(j)%process - integral(j) = process_get_integral (process) - if (integral(j) < 0) then - call msg_fatal ("Integral of process '" & - // char (process_get_id (process)) // "' is negative") - end if - if (updated(j)) then - call process_setup_event_generation (process, & - qn_mask_in = new_quantum_numbers_mask (.false., .false., & - mask_h = conf%isotropic, mask_hd = conf%diagonal)) - end if - end do - integral_sum = sum (integral) - if (integral_sum /= 0) then - br = integral / integral_sum - else - call msg_fatal ("Unstable particle: Computed total width vanishes") - br = 0 - end if - conf%width = integral_sum - conf%channel%br = br - if (verb) then - call msg_message ("Updated decay configuration:") - call decay_configuration_write (conf) - call decay_configuration_write (conf, u) - end if - end if - end subroutine decay_configuration_update - -@ %def decay_configuration_update -@ Output. Note that either no channel or all channels have to be defined. -<>= - public :: decay_configuration_write -<>= - subroutine decay_configuration_write (conf, unit) - type(decay_configuration_t), intent(in) :: conf - integer, intent(in), optional :: unit - character(12) :: fmt - integer :: n_channels, proc_id_len - integer :: u, i, j - u = output_unit (unit); if (u < 0) return - write (u, "(A)") "Decay configuration of particle '" & - // char (flavor_get_name (conf%flv)) // "' in model '" & - // char (model_get_name (conf%model)) // "':" - write (u, *) " Computed total width = ", conf%width, " GeV" - if (conf%isotropic) then - write (u, *) " Isotropic decays requested for simulation." - end if - if (conf%diagonal) then - write (u, *) " Diagonal density matrix in decays " & - // "requested for simulation." - end if - write (u, *) " Branching ratios:" - n_channels = decay_configuration_get_n_channels (conf) - if (n_channels /= 0) then - proc_id_len = maxval (len (conf%process_id)) - do i = 1, n_channels - write (u, "(F12.7,1x,A)", advance="no") 100 * conf%channel(i)%br, "%" - write (fmt, "(2x,A,I0,A)") "(4x,A", proc_id_len + 1, ")" - write (u, fmt, advance="no") char (conf%process_id(i)) - if (allocated (conf%channel(i)%unstable_products)) then - if (size (conf%channel(i)%unstable_products) /= 0) then - write (u, "(1x,A)", advance="no") " -> unstable:" - do j = 1, size (conf%channel(i)%unstable_products) - write (u, "(1x,A)", advance="no") char (flavor_get_name & - (conf%channel(i)%unstable_products(j))) - if (conf%channel(i)%isotropic(j)) then - write (u, "(A)", advance="no") "[I]" - else if (conf%channel(i)%diagonal(j)) then - write (u, "(A)", advance="no") "[D]" - end if - end do - end if - end if - write (u, *) - end do - else - write (u, *) " [undefined]" - end if - end subroutine decay_configuration_write - -@ %def decay_configuration_write -@ Return the number of decay channels: -<>= - public :: decay_configuration_get_n_channels -<>= - function decay_configuration_get_n_channels (conf) result (n) - integer :: n - type(decay_configuration_t), intent(in) :: conf - if (allocated (conf%channel)) then - n = size (conf%channel) - else - n = 0 - end if - end function decay_configuration_get_n_channels - -@ %def decay_configuration_get_n_channels -@ Select a decay channel, using the random-number generator. Return -the process pointer. Note that the sum of branching ratios must be -unity. (As a fallback, the last channel is selected if the sum of -ratios is less than unity.) -<>= - function decay_configuration_select_channel (conf, rng) result (channel) - integer :: channel - type(decay_configuration_t), intent(in) :: conf - type(tao_random_state), intent(inout) :: rng - real(default) :: x - real(default) :: x_sum - call tao_random_number (rng, x) - x_sum = 0 - do channel = 1, size (conf%channel) - x_sum = x_sum + conf%channel(channel)%br - if (x < x_sum) return - end do - channel = size (conf%channel) - end function decay_configuration_select_channel - -@ %def decay_configuration_select_channel -@ Return a pointer to a specified decay process. -<>= - function decay_configuration_get_process_ptr (conf, channel) & - result (process) - type(process_t), pointer :: process - type(decay_configuration_t), intent(in) :: conf - integer, intent(in) :: channel - process => conf%channel(channel)%process - end function decay_configuration_get_process_ptr - -@ %def decay_configuration_get_process_ptr -@ -\subsection{List of decay configurations} -Similar to the list of active processes ([[process_store]]), we -maintain a list of unstable particles and their decay properties. -<>= - type :: decay_store_t - private - integer :: n = 0 - type(decay_configuration_t), pointer :: first => null () - type(decay_configuration_t), pointer :: last => null () - end type decay_store_t - -@ %def decay_store_t -<>= - type(decay_store_t), save :: store - -@ %def decay_store -@ Finalize. -<>= - public :: decay_store_final -<>= - subroutine decay_store_final () - type(decay_configuration_t), pointer :: current - store%last => null () - do while (associated (store%first)) - current => store%first - store%first => current%next - deallocate (current) - end do - store%n = 0 - end subroutine decay_store_final - -@ %def decay_store_final -@ Output. -<>= - public :: decay_store_write -<>= - subroutine decay_store_write (unit) - integer, intent(in), optional :: unit - type(decay_configuration_t), pointer :: decay - integer :: u - u = output_unit (unit); if (u < 0) return - write (u, "(A)") "Decay configuration for unstable particles:" - decay => store%first - do while (associated (decay)) - if (.not. flavor_is_stable (decay%flv)) & - call decay_configuration_write (decay, unit) - decay => decay%next - end do - end subroutine decay_store_write - -@ %def decay_store_write -@ Retrieve the MD5 sum of the decay store, if there is any decay assigned. -<>= - public :: decay_store_get_md5sum -<>= - function decay_store_get_md5sum () result (md5sum_decays) - character(32) :: md5sum_decays - integer :: u - if (associated (store%first)) then - u = free_unit () - open (u, status="scratch") - call decay_store_write (u) - rewind (u) - md5sum_decays = md5sum (u) - else - md5sum_decays = "" - end if - end function decay_store_get_md5sum - -@ %def decay_store_get_md5sum -@ Append a new entry for an unstable particle. If a decay exists -already, it is overwritten. Return a pointer to the new decay -configuration. -<>= - public :: decay_store_append_decay -<>= - subroutine decay_store_append_decay & - (flv, model, width, n_channels, isotropic, diagonal, decay) - type(flavor_t), intent(in) :: flv - type(model_t), intent(in), target :: model - real(default), intent(in) :: width - integer, intent(in) :: n_channels - logical, intent(in) :: isotropic, diagonal - type(decay_configuration_t), pointer :: decay - type(decay_configuration_t), pointer :: next_decay - decay => store%first - do while (associated (decay)) - if (decay%flv == flv) then - next_decay => decay_configuration_get_next_ptr (decay) - call decay_configuration_init & - (decay, flv, model, width, n_channels, isotropic, diagonal) - call decay_configuration_set_next_ptr (decay, next_decay) - return - end if - decay => decay%next - end do - allocate (decay) - call decay_configuration_init & - (decay, flv, model, width, n_channels, isotropic, diagonal) - if (associated (store%first)) then - store%last%next => decay - else - store%first => decay - end if - store%last => decay - end subroutine decay_store_append_decay - -@ %def decay_store_append_decay -@ Return a pointer to the decay configuration for a particular -unstable particle. -<>= - function decay_store_get_decay_configuration_ptr (flv) result (config) - type(decay_configuration_t), pointer :: config - type(flavor_t), intent(in) :: flv - config => store%first - SCAN_PARTICLES: do while (associated (config)) - if (config%flv == flv) exit SCAN_PARTICLES - config => config%next - end do SCAN_PARTICLES - end function decay_store_get_decay_configuration_ptr - -@ %def decay_store_get_decay_configuration_ptr -@ Recheck all decay configurations whether the stability of the final state -has changed. If yes, re-initialize event generation for the corresponding -decay process. - -This should be executed anytime the stablity of a particle has changed. -<>= - public :: decay_store_recheck_final_state -<>= - subroutine decay_store_recheck_final_state (verbose) - logical, intent(in), optional :: verbose - logical :: modified - type(decay_configuration_t), pointer :: config - config => store%first - do while (associated (config)) - call decay_configuration_recheck_final_state (config, verbose) - config => config%next - end do - end subroutine decay_store_recheck_final_state - -@ %def decay_store_recheck_final_state -@ Update all entries in the decay store which contain a process that -is in the specified list (of processes that have been recalculated). -<>= - public :: decay_store_update -<>= - subroutine decay_store_update (process_id, verbose) - type(string_t), dimension(:), intent(in) :: process_id - logical, intent(in), optional :: verbose - type(decay_configuration_t), pointer :: conf - conf => store%first - do while (associated (conf)) - call decay_configuration_update (conf, process_id, verbose) - conf => conf%next - end do - end subroutine decay_store_update - -@ %def decay_store_update -@ -\subsection{Decays} -The decay object contains a pointer to the decay process, evaluators -that hold the product of production and decay, and a pointer to the -next decay node (which holds all possible subsequent decays). -<>= - type :: decay_t - private - logical :: initialized = .false. - type(process_t), pointer :: process => null () - type(evaluator_t) :: eval_sqme - type(evaluator_t) :: eval_flows - type(decay_node_t), pointer :: next_node => null () - end type decay_t - -@ %def decay_t -@ Initialize the decay with a certain process, and use this together -with the production evaluators to initialize product evaluators. -<>= - subroutine decay_init (decay, process, eval_sqme, eval_flows, i) - type(decay_t), intent(out), target :: decay - type(process_t), intent(inout), target :: process - type(evaluator_t), intent(in), target :: eval_sqme, eval_flows - integer, intent(in) :: i - type(interaction_t), pointer :: prc_int - type(evaluator_t), pointer :: prc_eval_sqme, prc_eval_flows - integer :: n_tot - logical, dimension(:), allocatable :: ignore_hel - type(quantum_numbers_mask_t), dimension(:), allocatable :: & - mask_hel, mask_sqme, mask_flows - type(quantum_numbers_mask_t) :: mask_conn - if (.not. process_has_trivial_kinematics (process)) call msg_bug ( & - "decays@NLO not yet implemented") - call process_request_copy (process, decay%process) - call process_mark_as_cascade_decay (decay%process) - call process_setup_cuts (decay%process) - call process_setup_weight (decay%process) - call process_setup_scale (decay%process) - call process_setup_fac_scale (decay%process) - call process_setup_ren_scale (decay%process) - prc_int => process_get_ci_int_ptr (decay%process) - prc_eval_sqme => process_get_ci_eval_sqme_ptr (decay%process) - prc_eval_flows => process_get_ci_eval_flows_ptr (decay%process) - n_tot = evaluator_get_n_tot (prc_eval_sqme) - if (n_tot < 3) then - call msg_bug (arr = & - (/"Initialization fails for decay '" & - // process_get_id (decay%process) // "':", & - var_str ("Event generation not set up properly.") & -! var_str ("(Missing 'unstable' command after integration?)") & - /)) - end if - allocate (ignore_hel (n_tot)) - ignore_hel(1) = .true. - ignore_hel(2:) = .false. - allocate (mask_hel (n_tot), mask_sqme (n_tot), mask_flows (n_tot)) - call quantum_numbers_mask_set_helicity (mask_hel, ignore_hel) - mask_sqme = evaluator_get_mask (prc_eval_sqme) .or. mask_hel - mask_flows = evaluator_get_mask (prc_eval_flows) .or. mask_hel - mask_conn = new_quantum_numbers_mask (.false., .false., .true.) - call evaluator_set_source_link (prc_eval_sqme, 1, eval_sqme, i) - call evaluator_set_source_link (prc_eval_flows, 1, eval_flows, i) - call evaluator_init_product (decay%eval_sqme, & - eval_sqme, prc_eval_sqme, mask_conn, & - connections_are_resonant=.true.) - call evaluator_init_product (decay%eval_flows, & - eval_flows, prc_eval_flows, mask_conn, & - connections_are_resonant=.true.) - call evaluator_set_source_link (prc_eval_sqme, 1, prc_int, 1) - call evaluator_set_source_link (prc_eval_flows, 1, prc_int, 1) - allocate (decay%next_node) - decay%initialized = .true. - end subroutine decay_init - -@ %def decay_init -@ Finalizer: Delete the evaluators. Do not delete the process copy yet. -<>= - recursive subroutine decay_final (decay) - type(decay_t), intent(inout) :: decay - if (decay%initialized) then - if (associated (decay%next_node)) & - call decay_node_final (decay%next_node) - call evaluator_final (decay%eval_sqme) - call evaluator_final (decay%eval_flows) - end if - end subroutine decay_final - -@ %def decay_final -@ Output. -<>= - subroutine decay_write (decay, unit) - type(decay_t), intent(in) :: decay - integer, intent(in), optional :: unit - integer :: u - u = output_unit (unit); if (u < 0) return - write (u, "(A)") repeat ("=", 72) - write (u, "(A)") "Decay process:" - call process_write (decay%process, unit) - write (u, "(A)") repeat ("=", 72) - write (u, "(A)") "Combined sqme including color factors " & - // "(process + decay):" - call evaluator_write (decay%eval_sqme, unit) - write (u, "(A)") repeat ("-", 72) - write (u, "(A)") "Combined color flow coefficients " & - // "(process + decay):" - call evaluator_write (decay%eval_flows, unit) - end subroutine decay_write - -@ %def decay_write -@ Given preconfigured evaluators, generate an event. - -We generate an unweighted event for the decay process. This is isotropic in -the decaying particle rest frame. To prepare spin correlation selection, we -renormalize the squared matrix element by the trace. (Thus, the sum of the -matrix element values is unity.) - -We must tag the current process as the working copy if there is more than -one. This occurs if the same decay appears more than once in a decay tree. - -TODO: Any excess weight is collected (to avoid VAMP warnings) but not -recorded anywhere. -<>= - subroutine decay_generate (decay, rng, flv, p) - type(decay_t), intent(inout) :: decay - type(tao_random_state), intent(inout) :: rng - type(flavor_t), intent(in) :: flv - type(vector4_t), intent(in) :: p - real(default) :: excess - type(evaluator_t), pointer :: process_eval_sqme - call process_set_beam_momenta (decay%process, (/ p /)) - call process_tag_as_working_copy (decay%process) - call process_generate_unweighted_event (decay%process, rng, excess=excess) - process_eval_sqme => process_get_eval_sqme_ptr (decay%process) - call evaluator_normalize_by_trace (process_eval_sqme) - call evaluator_receive_momenta (decay%eval_sqme) - call evaluator_receive_momenta (decay%eval_flows) - call evaluator_evaluate (decay%eval_sqme) - call evaluator_evaluate (decay%eval_flows) - end subroutine decay_generate - -@ %def decay_generate -@ -\subsection{Decay trees} -A decay tree is created during event generation. Each node holds the -possible decays as branches, together with the decay configuration -which is used to select a branch for a particular event. Whenever a -branch is selected for the first time, it is initialized with the -appropriate evaluators, which are then kept for later use. -<>= - type :: decay_node_t - private - type(decay_configuration_t), pointer :: configuration => null () - integer :: current_channel = 0 - type(decay_t), dimension(:), allocatable :: decay - end type decay_node_t - -@ %def decay_branch_t decay_node_t decay_tree_t -@ Initializer: -<>= - subroutine decay_node_init (node, flv) - type(decay_node_t), intent(out) :: node - type(flavor_t), intent(in) :: flv - node%configuration => decay_store_get_decay_configuration_ptr (flv) - if (associated (node%configuration)) then - allocate (node%decay & - (decay_configuration_get_n_channels (node%configuration))) - else - call msg_bug ("Particle '" // char (flavor_get_name (flv)) & - // "': Missing decay configuration") - end if - end subroutine decay_node_init - -@ %def decay_node_init -@ Recursive finalizer: -<>= - recursive subroutine decay_node_final (node) - type(decay_node_t), intent(inout) :: node - integer :: i - if (allocated (node%decay)) then - do i = 1, size (node%decay) - call decay_final (node%decay(i)) - end do - deallocate (node%decay) - end if - end subroutine decay_node_final - -@ %def decay_branch_final decay_node_final decay_tree_final -@ Write the currently selected decay: -<>= - subroutine decay_node_write (node, unit) - type(decay_node_t), intent(in) :: node - integer, intent(in), optional :: unit - integer :: channel, u - u = output_unit (unit) - write (u, "(A)") "|" // repeat ("=", 79) - if (associated (node%configuration)) then - call decay_configuration_write (node%configuration, unit) - channel = node%current_channel - if (channel /= 0) then - write (u, "(1x,A)", advance="no") "Decay node: " - write (u, *) "current channel = ", channel - call decay_write (node%decay(channel), unit) - else - write (u, *) "Decay node: [no channel selected]" - end if - else - write (u, *) "Decay configuration: [undefined]" - end if - end subroutine decay_node_write - -@ %def decay_node_write -@ Return a pointer to the currently selected decay, or null if absent: -<>= - function decay_node_get_next_ptr (node) result (ptr) - type(decay_node_t), pointer :: ptr - type(decay_node_t), intent(in) :: node - if (node%current_channel /= 0) then - ptr => node%decay(node%current_channel)%next_node - else - ptr => null () - end if - end function decay_node_get_next_ptr - -@ %def decay_node_get_next_ptr -@ The decay tree holds references to the production process as well as -pointers to the final evaluators. -<>= - public :: decay_tree_t -<>= - type :: decay_tree_t - private - integer :: tries = 0 - real(default) :: acceptance_probability = 0 - type(process_t), pointer :: hard_process => null () - type(evaluator_t), pointer :: eval_sqme_in => null () - type(evaluator_t), pointer :: eval_flows_in => null () - type(decay_node_t), pointer :: root => null () - type(evaluator_t), pointer :: eval_sqme => null () - type(evaluator_t), pointer :: eval_flows => null () - end type decay_tree_t - -@ %def decay_tree_t -@ Initialize the decay tree with a particular process and allocate the -root node. -<>= - public :: decay_tree_init -<>= - subroutine decay_tree_init (decay_tree, process) - type(decay_tree_t), intent(out) :: decay_tree - type(process_t), intent(in), target :: process - decay_tree%hard_process => process - decay_tree%eval_sqme_in => process_get_eval_sqme_ptr (process) - decay_tree%eval_flows_in => process_get_eval_flows_ptr (process) - allocate (decay_tree%root) - end subroutine decay_tree_init - -@ %def decay_tree_init -<>= - public :: decay_tree_final -<>= - subroutine decay_tree_final (decay_tree) - type(decay_tree_t), intent(inout) :: decay_tree - if (associated (decay_tree%root)) then - call decay_node_final (decay_tree%root) - deallocate (decay_tree%root) - end if - end subroutine decay_tree_final - -@ %def decay_branch_final decay_node_final decay_tree_final -@ Output. -<>= - public :: decay_tree_write -<>= - subroutine decay_tree_write (decay_tree, unit) - type(decay_tree_t), intent(in) :: decay_tree - integer, intent(in), optional :: unit - type(decay_node_t), pointer :: decay_node - integer :: u - u = output_unit (unit) - write (u, "(A)") "|" // repeat ("=", 79) - write (u, *) "Decay tree:" - write (u, *) " tries = ", decay_tree%tries - write (u, *) " acceptance probability = ", & - decay_tree%acceptance_probability - write (u, "(A)") "|" // repeat ("=", 79) - write (u, "(1x,A)", advance="no") "Mother process = " - if (associated (decay_tree%hard_process)) then - write (u, "(A)") "'" & - // char (process_get_id (decay_tree%hard_process)) & - // "'" - else - write (u, "(A)") "[undefined]" - end if - write (u, "(A)") "|" // repeat ("=", 79) - decay_node => decay_tree%root - if (associated (decay_node)) then - write (u, *) "Decay chain:" - do while (associated (decay_node)) - call decay_node_write (decay_node, unit) - decay_node => decay_node_get_next_ptr (decay_node) - end do - else - write (u, *) "[No decays]" - end if - write (u, "(A)") "|" // repeat ("=", 79) - write (u, "(1x,A)") "Evaluator: " & - // "Color-summed including all decays" - if (associated (decay_tree%eval_sqme)) then - call evaluator_write (decay_tree%eval_sqme, unit) - else - write (u, "(A)") "[undefined]" - end if - write (u, "(A)") "|" // repeat ("=", 79) - write (u, "(1x,A)") "Evaluator: " & - // "Color flow components including all decays" - if (associated (decay_tree%eval_flows)) then - call evaluator_write (decay_tree%eval_flows, unit) - else - write (u, "(A)") "[undefined]" - end if - write (u, "(A)") "|" // repeat ("=", 79) - end subroutine decay_tree_write - -@ %def decay_tree_write -@ Generate a decay chain; construct the decay tree as far as -necessary, otherwise reuse it. - -To prepare for spin correlation selection, we renormalize the matrix elements -of the parent interaction by the entry with maximum value. Normalizing all -decay process appropriately (by the trace of their respective matrix -elements), the (trace of the) product of the evaluators should result in a -single value between zero and one. This is used as the probability for -accepting the decay chain. If the chain is rejected, a new one is generated. -<>= - integer, parameter, public :: MAX_TRIES_FOR_DECAY_CHAIN = 100000 -@ %def MAX_TRIES_FOR_DECAY_CHAIN -<>= - public :: decay_tree_generate_event -<>= - subroutine decay_tree_generate_event (decay_tree, rng) - type(decay_tree_t), intent(inout) :: decay_tree - type(tao_random_state), intent(inout) :: rng - real(default) :: x_decay - real(default) :: x - integer :: i - logical :: decay_occurs - call evaluator_normalize_by_max (decay_tree%eval_sqme_in) - decay_occurs = .false. - REJECTION: do i = 1, MAX_TRIES_FOR_DECAY_CHAIN - decay_tree%tries = i - decay_tree%eval_sqme => decay_tree%eval_sqme_in - decay_tree%eval_flows => decay_tree%eval_flows_in - call decay_node_generate_event (decay_tree%root, decay_occurs) - if (decay_occurs) then - x_decay = evaluator_sum (decay_tree%eval_sqme) - decay_tree%acceptance_probability = x_decay - call tao_random_number (rng, x) - if (x <= x_decay) return - else - return - end if - end do REJECTION - write (msg_buffer, "(A,I0,A)") "Failed to generate a decay chain " & - // "after ", MAX_TRIES_FOR_DECAY_CHAIN, " tries" - call msg_fatal () - contains - recursive subroutine decay_node_generate_event (node, decay_occurs) - type(decay_node_t), intent(inout), target :: node - logical, intent(inout) :: decay_occurs - type(flavor_t) :: flv - type(vector4_t) :: p - integer :: i, channel - type(process_t), pointer :: process - call evaluator_get_unstable_particle (decay_tree%eval_sqme, flv, p, i) - if (flavor_is_defined (flv)) then - decay_occurs = .true. - if (.not. associated (node%configuration)) & - call decay_node_init (node, flv) - channel = decay_configuration_select_channel (node%configuration, rng) - node%current_channel = channel - if (.not. node%decay(channel)%initialized) then - process => decay_configuration_get_process_ptr & - (node%configuration, channel) - call decay_init (node%decay(channel), & - process, decay_tree%eval_sqme, decay_tree%eval_flows, i) - end if - call decay_generate (node%decay(channel), rng, flv, p) - decay_tree%eval_sqme => node%decay(channel)%eval_sqme - decay_tree%eval_flows => node%decay(channel)%eval_flows - call decay_node_generate_event & - (node%decay(channel)%next_node, decay_occurs) - end if - end subroutine decay_node_generate_event - end subroutine decay_tree_generate_event - -@ %def decay_tree_generate_event -@ Return pointers to the final evaluators: -<>= - public :: decay_tree_get_eval_sqme_ptr - public :: decay_tree_get_eval_flows_ptr -<>= - function decay_tree_get_eval_sqme_ptr (decay_tree) result (eval) - type(evaluator_t), pointer :: eval - type(decay_tree_t), intent(in), target :: decay_tree - eval => decay_tree%eval_sqme - end function decay_tree_get_eval_sqme_ptr - - function decay_tree_get_eval_flows_ptr (decay_tree) result (eval) - type(evaluator_t), pointer :: eval - type(decay_tree_t), intent(in), target :: decay_tree - eval => decay_tree%eval_flows - end function decay_tree_get_eval_flows_ptr - -@ %def decay_tree_get_eval_sqme_ptr decay_tree_get_eval_flows_ptr -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Events} - -The event record becomes relevant only after cross sections have been -integrated. It gets filled by some signal process (including -beam/structure functions) if an event has been successfully been -generated (passing rejection). - -If requested, particles in the event are subject to decay and/or -showering. This is not implemented yet. -<<[[events.f90]]>>= -<> - -module events - -<> -<> - use limits, only: RAW_EVENT_FILE_ID_STRING !NODEP! -<> - use diagnostics !NODEP! - use tao_random_numbers !NODEP! - use pdf_builtin !NODEP! - use os_interface - use lexers - use parser - use subevents - use variables - use expressions - use models - use flavors - use state_matrices - use polarizations - use event_formats - use hepmc_interface - use particles - use interactions - use evaluators - use process_libraries - use beams - use sf_lhapdf - use mappings - use phs_forests - use cascades - use processes - use decays - use lorentz !NODEP! - use shower_interface - use lorentz !NODEP! - use ckkw_pseudo_weights_module !NODEP! - use ckkw_matching_module !NODEP! - -<> - -<> - -<> - -contains - -<> - -end module events -@ %def events -@ -\subsection{The event type} -<>= - public :: event_t -<>= - type :: event_t - private - integer :: num_proc_id = 0 - type(process_t), pointer :: process => null () - type(event_vars_t), pointer :: vars => null () - type(decay_tree_t), pointer :: decay_tree => null () - logical :: particle_set_exists = .false. - logical :: is_valid = .false. - logical :: is_vetoed = .false. - type(particle_set_t) :: particle_set - real(default) :: excess = 0 - end type event_t - -@ %def event_t -@ The event record is initialized with a pointer to a specific -``signal'' process. The particle set is not (yet) initialized, this -is done for each event. The event weight and squared matrix element are -presented as a target, so the -event record acquires a pointer to this target. The same target is available -to the analysis evaluation tree. -<>= - public :: event_init -<>= - subroutine event_init (event, process, event_vars, decay_tree) - type(event_t), intent(out) :: event - type(process_t), intent(in), target :: process - type(event_vars_t), intent(in), target :: event_vars - type(decay_tree_t), intent(in), optional, target :: decay_tree - event%process => process - event%vars => event_vars - if (present (decay_tree)) event%decay_tree => decay_tree - end subroutine event_init - -@ %def event_init -@ Finalize the event: delete the particle set. -<>= - public :: event_final -<>= - subroutine event_final (event) - type(event_t), intent(inout) :: event - call particle_set_final (event%particle_set) - event%is_valid = .false. - end subroutine event_final - -@ %def event_final -@ Output: Only the particle set is printed explicitly, unless verbose -format is selected. -<>= - public :: event_write -<>= - subroutine event_write (event, analysis_expr, unit, verbose) - type(event_t), intent(in) :: event - type(eval_tree_t), intent(in), optional :: analysis_expr - integer, intent(in), optional :: unit - logical, intent(in), optional :: verbose - integer :: u - u = output_unit (unit); if (u < 0) return - write (u, *) repeat ("=", 72) - write (u, *) "Event record:" - if (.not. event%is_valid) write (u, *) " [invalid event record]" - if (associated (event%vars)) then - call event_vars_write (event%vars, unit) - end if - if (associated (event%process)) then - if (present (verbose)) then - if (verbose) then - call process_write (event%process, unit) - if (present (analysis_expr)) then - write (u, "(A)") "Analysis expression:" - call eval_tree_write (analysis_expr, unit) - write (u, "(A)") repeat ("#", 79) - end if - write (u, *) - end if - end if - else - write (u, *) " [empty]" - end if - write (u, *) repeat ("=", 72) - if (associated (event%decay_tree)) then - write (u, *) repeat ("=", 72) - call decay_tree_write (event%decay_tree, unit) - end if - write (u, *) " [Process: ", char (process_get_id (event%process)), "]" - write (u, *) - call particle_set_write (event%particle_set, unit) - end subroutine event_write - -@ %def event_write -@ -\subsection{Event generation} -Generate a new event and transfer the resulting data to the event -record. - -The call to [[event_factorize_process]] determines whether the event is -valid. -<>= - public :: event_generate -<>= - subroutine event_generate (event, rng, unweighted, & - factorization_mode, keep_correlations, keep_virtual, os_data, & - shower_settings) - type(event_t), intent(inout), target :: event - type(tao_random_state), intent(inout) :: rng - logical, intent(in) :: unweighted - integer, intent(in) :: factorization_mode - logical, intent(in) :: keep_correlations, keep_virtual - type(os_data_t), intent(in) :: os_data -!!! shower_settings should be intent(in), but the calls to ckkw_pseudo_shower_weights_init -!!! and ckkw_fake_pseudo_shower_weights force it to be declared as intent(inout) -! type(shower_settings_t), intent(in), optional :: shower_settings - type(shower_settings_t), intent(inout), optional :: shower_settings - integer :: u - - event%is_vetoed = .false. - if (unweighted) then - call process_generate_unweighted_event & - (event%process, rng, event%vars%excess) - event%vars%weight = 1 - else - call process_generate_weighted_event & - (event%process, rng, event%vars%weight) - event%vars%excess = 0 - end if - event%vars%n_in = process_get_n_in (event%process) - event%vars%n_out = process_get_n_out_real (event%process) ! or _eff? - event%vars%n_tot = process_get_n_tot_real (event%process) ! or _eff? - event%vars%sqrts = process_get_sqrts (event%process) - event%vars%sqrts_hat = process_get_sqrts_hat (event%process) - event%vars%sqme = process_get_sqme (event%process) - event%vars%sqme_ref = event%vars%sqme - if (associated (event%decay_tree)) then - call decay_tree_generate_event (event%decay_tree, rng) - end if - call event_factorize_process (event, rng, & - factorization_mode, keep_correlations, keep_virtual) - if(event%particle_set_exists.and.present (shower_settings)) then - call event_assure_heprup(event) - - call apply_shower_particle_set(event%particle_set, & - shower_settings, & - process_get_model_ptr(event%process), & - os_data, & - process_get_strfun_type(event%process), & - process_get_strfun_set(event%process), & - event%is_valid, event%is_vetoed) - end if - end subroutine event_generate - -@ %def event_generate -@ Apply decay to an existing event: -<>= - public :: event_decay -<>= - subroutine event_decay (event, rng, decay_tree) - type(event_t), intent(inout) :: event - type(tao_random_state), intent(inout) :: rng - type(decay_tree_t), intent(in), target :: decay_tree - if (event%is_valid) then - call process_complete_evaluators (event%process) - event%decay_tree => decay_tree - call decay_tree_generate_event (event%decay_tree, rng) - end if - end subroutine event_decay - -@ %def event_decay -@ Transfer event data from the process record (if a decay has -happened: the decay chain) to the event record, factorizing the -correlated quantum-number state. We use both the colorless and the -colored evaluators to determine the particle set. The factorization -of the correlated state is done in one of three modes (unpolarized, -definite helicity, generic one-particle density matrices); optionally, -the fully correlated density matrix can also be transferred to the -particle set. - -The [[is_valid]] flag is set unless factorization fails, e.g., if the matrix -element squared vanishes. -<>= - public :: event_factorize_process -<>= - subroutine event_factorize_process (event, rng, & - factorization_mode, keep_correlations, keep_virtual) - type(event_t), intent(inout), target :: event - type(tao_random_state), intent(inout) :: rng - integer, intent(in) :: factorization_mode - logical, intent(in) :: keep_correlations, keep_virtual - type(interaction_t), pointer :: int_sqme, int_flows - real(default), dimension(2) :: r - integer, dimension(:), allocatable :: beam_index - integer, dimension(:), allocatable :: incoming_parton_index - if (associated (event%decay_tree)) then - int_sqme => evaluator_get_int_ptr & - (decay_tree_get_eval_sqme_ptr (event%decay_tree)) - int_flows => evaluator_get_int_ptr & - (decay_tree_get_eval_flows_ptr (event%decay_tree)) - else - int_sqme => evaluator_get_int_ptr & - (process_get_eval_sqme_ptr (event%process)) - int_flows => evaluator_get_int_ptr & - (process_get_eval_flows_ptr (event%process)) - end if - call tao_random_number (rng, r) - if (interaction_get_n_in (int_sqme) /= 0) then - call particle_set_init (event%particle_set, event%is_valid, & - int_sqme, int_flows, factorization_mode, r, & - keep_correlations, keep_virtual) - else - call particle_set_init (event%particle_set, event%is_valid, & - int_sqme, int_flows, factorization_mode, r, & - keep_correlations, keep_virtual, & - n_incoming = process_get_n_in (event%process)) - end if - call process_get_beam_index (event%process, beam_index) - if (allocated (beam_index)) then - call particle_set_reset_status (event%particle_set, & - beam_index, PRT_BEAM) - end if - call process_get_incoming_parton_index (event%process, & - incoming_parton_index) - if (allocated (incoming_parton_index)) then - call particle_set_reset_status (event%particle_set, & - incoming_parton_index, PRT_INCOMING) - end if - event%particle_set_exists = .true. - end subroutine event_factorize_process - -@ %def event_factorize_process -@ Do the reverse operation, as far as possible: Given a complete event, try to -recover the process kinematics. Assume that the process has been initialized -correctly. -<>= - public :: event_recover_process -<>= - subroutine event_recover_process (event) - type(event_t), intent(inout) :: event - call process_recover_kinematics (event%process, event%particle_set) - call process_fill_subevt (event%process) - end subroutine event_recover_process - -@ %def event_recover_process -@ (Re)compute the event scale, model parameters, $\alpha_s$, matrix element, -event weight, and user reweighting factor. -<>= - public :: event_compute_scale - public :: event_update_parameters - public :: event_update_alpha_s - public :: event_compute_sqme - public :: event_update_weight -<>= - subroutine event_compute_scale (event) - type(event_t), intent(inout) :: event - call process_compute_scale (event%process) - end subroutine event_compute_scale - - subroutine event_update_parameters (event) - type(event_t), intent(inout) :: event - call process_update_parameters (event%process) - end subroutine event_update_parameters - - subroutine event_update_alpha_s (event) - type(event_t), intent(inout) :: event - call process_update_alpha_s (event%process) - end subroutine event_update_alpha_s - - subroutine event_compute_sqme (event) - type(event_t), intent(inout) :: event - call process_evaluate (event%process) - event%vars%sqme = process_get_sqme (event%process) - end subroutine event_compute_sqme - - subroutine event_update_weight (event) - type(event_t), intent(inout) :: event - if (event%vars%sqme_ref /= 0) then - call event_renormalize_weight & - (event, event%vars%sqme / event%vars%sqme_ref) - end if - end subroutine event_update_weight - -@ %def event_compute_scale event_update_parameters event_update_alpha_s -@ %def event_compute_sqme event_update_weight -@ Determine whether an event passes selection cuts, if a selection expression -is defined. -<>= - public :: event_passes_selection -<>= - function event_passes_selection (event, subevt, selection_expr) result (flag) - logical :: flag - type(event_t), intent(inout), target :: event - type(subevt_t), intent(inout), target :: subevt - type(eval_tree_t), intent(inout), target :: selection_expr - real(default) :: factor - if (event%is_valid .and. eval_tree_is_defined (selection_expr)) then - call particle_set_to_subevt (event%particle_set, subevt) - call eval_tree_evaluate (selection_expr) - flag = eval_tree_get_log (selection_expr) - else - flag = .true. - end if - end function event_passes_selection - -@ %def event_passes_selection -@ Renormalize the event weight by some factor -<>= - public :: event_renormalize_weight -<>= - subroutine event_renormalize_weight (event, factor) - type(event_t), intent(inout) :: event - real(default), intent(in) :: factor - event%vars%weight = event%vars%weight * factor - end subroutine event_renormalize_weight - -@ %def event_renormalize_weight -@ Reweight the event, if a reweighting expression is defined. -<>= - public :: event_reweight -<>= - subroutine event_reweight (event, subevt, reweight_expr) - type(event_t), intent(inout), target :: event - type(subevt_t), intent(inout), target :: subevt - type(eval_tree_t), intent(inout), target :: reweight_expr - real(default) :: factor - if (event%is_valid .and. eval_tree_is_defined (reweight_expr)) then - call particle_set_to_subevt (event%particle_set, subevt) - call eval_tree_evaluate (reweight_expr) - factor = eval_tree_get_real (reweight_expr) - call event_renormalize_weight (event, factor) - end if - end subroutine event_reweight - -@ %def event_reweight -@ Analyze an event. The [[subevt]] object is used as a messenger object to -store the event particle data; the analysis expression has to be initialized -before with reference to this object. The analysis results are -stored as side-effect operations. -<>= - public :: event_do_analysis -<>= - subroutine event_do_analysis (event, subevt, analysis_expr) - type(event_t), intent(inout), target :: event - type(subevt_t), intent(inout), target :: subevt - type(eval_tree_t), intent(inout), target :: analysis_expr - if (event%is_valid .and. eval_tree_is_defined (analysis_expr)) then - call particle_set_to_subevt (event%particle_set, subevt) - call eval_tree_evaluate (analysis_expr) - end if - end subroutine event_do_analysis - -@ %def event_do_analysis -@ Delete any previous contents of the particle set. -<>= - subroutine event_discard_particle_set (event) - type(event_t), intent(inout), target :: event - if (event%particle_set_exists) then - call particle_set_final (event%particle_set) - event%particle_set_exists = .false. - end if - end subroutine event_discard_particle_set - -@ %def event_discard_particle_set -@ -\subsection{Contents} -<>= - public :: event_is_valid -<>= - function event_is_valid (event) result (flag) - logical :: flag - type(event_t), intent(in) :: event - flag = event%is_valid - end function event_is_valid - -@ %def event_is_valid -@ -<>= - public :: event_is_vetoed -<>= - function event_is_vetoed (event) result (flag) - logical :: flag - type(event_t), intent(in) :: event - flag = event%is_vetoed - end function event_is_vetoed - -@ %def event_is_valid -\subsection{Binary I/O} -Read/write the particle set including the associated state matrix -from/to an unformatted file. This can be used to re-read events -generated in a previous run. - -Version 2 contains a WHIZARD ID string as header. - -Version 3 contains [[sqrts_hat]] in the event-vars record. -<>= - character(*), parameter, public :: & - RAW_EVENT_FILE_ID_STRING = "WHIZARD raw event file" -@ %def RAW_EVENT_FILE_ID_STRING -@ Collect the MD5 sums in a transparent container: -<>= - public :: md5sum_events_t -<>= - type :: md5sum_events_t - character(32), dimension(:), allocatable :: process - character(32), dimension(:), allocatable :: parameters - character(32), dimension(:), allocatable :: results - character(32), dimension(:), allocatable :: polarized - character(32) :: decays = "" - character(32) :: simulation = "" - end type md5sum_events_t - -@ %def md5sum_events_t -@ Check just the event-file format. Return true if the ID string matches, -otherwise return false. -<>= - public :: is_raw_event_file -<>= - function is_raw_event_file (unit) result (flag) - logical :: flag - integer, intent(in) :: unit - character(len=len(RAW_EVENT_FILE_ID_STRING)) :: id_string - integer :: iostat - read (unit, iostat=iostat) id_string - if (iostat /= 0) then - flag = .false. - else if (id_string /= RAW_EVENT_FILE_ID_STRING) then - flag = .false. - else - flag = .true. - end if - end function is_raw_event_file - -@ %def is_raw_event_file -@ Write and read the header including the MD5 sum info. -<>= - public :: raw_event_file_write_header - public :: raw_event_file_read_header -<>= - subroutine raw_event_file_write_header (unit, md5sum, version) - integer, intent(in) :: unit - type(md5sum_events_t), intent(in) :: md5sum - integer, intent(in) :: version - write (unit) RAW_EVENT_FILE_ID_STRING - write (unit) version - write (unit) size (md5sum%process) - write (unit) md5sum%process - write (unit) md5sum%parameters - write (unit) md5sum%results - write (unit) md5sum%polarized - write (unit) md5sum%decays - write (unit) md5sum%simulation - end subroutine raw_event_file_write_header - - subroutine raw_event_file_read_header & - (unit, rescan, check, md5sum, version, ok, iostat) - integer, intent(in) :: unit - logical, intent(in) :: rescan, check - type(md5sum_events_t), intent(in) :: md5sum - integer, intent(in) :: version - logical, intent(out) :: ok - integer, intent(out), optional :: iostat - character(len=len(RAW_EVENT_FILE_ID_STRING)) :: id_string - integer :: file_version, n - character(32), dimension(:), allocatable :: md5sum_array - character(32) :: md5sum_single - logical :: unweighted - ok = .false. - read (unit, iostat=iostat) id_string - if (check .and. id_string /= RAW_EVENT_FILE_ID_STRING) then - call msg_fatal & - ("File doesn't appear to be a WHIZARD raw event file") - return - end if - read (unit, iostat=iostat) file_version - if (check .and. file_version /= version) then - call msg_fatal & - ("Event-file format version mismatch") - return - end if - read (unit, iostat=iostat) n - if (check .and. n /= size (md5sum%process)) then - call msg_message & - ("Process number has changed, discarding old event file") - return - end if - allocate (md5sum_array (n)) - read (unit, iostat=iostat) md5sum_array - if (check .and. any (md5sum%process /= md5sum_array)) then - call msg_message & - ("Process configuration has changed, discarding old event file") - return - end if - read (unit, iostat=iostat) md5sum_array - if (check .and. .not. rescan & - .and. any (md5sum%parameters /= md5sum_array)) then - call msg_message & - ("Model parameters have changed, discarding old event file") - return - end if - read (unit, iostat=iostat) md5sum_array - if (check .and. .not. rescan & - .and. any (md5sum%results /= md5sum_array)) then - call msg_message & - ("Integration results have changed, skipping event file") - return - end if - read (unit, iostat=iostat) md5sum_array - if (check .and. any (md5sum%polarized /= md5sum_array)) then - call msg_message & - ("Polarization setup has changed, discarding old event file") - return - end if - read (unit, iostat=iostat) md5sum_single - if (check .and. .not. rescan .and. md5sum%decays /= md5sum_single) then - call msg_message & - ("Decay configuration has changed, skipping event file") - return - end if - read (unit, iostat=iostat) md5sum_single - if (check .and. md5sum%simulation /= md5sum_single) then - call msg_message & - ("Simulation parameters have changed, skipping event file") - return - end if - ok = .true. - end subroutine raw_event_file_read_header - -@ %def raw_event_file_write_header -@ %def raw_event_file_read_header -@ Write only valid events; an event read from file is valid by definition. -<>= - public :: event_write_raw - public :: event_read_raw -<>= - subroutine event_write_raw (event, unit, version) - type(event_t), intent(in) :: event - integer, intent(in) :: unit - integer, intent(in) :: version - if (event%is_valid) then - if (.not. associated (event%process)) & - call msg_bug ("Writing event: process not associated") - if (.not. associated (event%vars)) & - call msg_bug ("Writing event: event variables not associated") - call event_vars_write_raw (event%vars, unit, version) - write (unit) process_get_scale (event%process) - write (unit) process_get_fac_scale (event%process) - write (unit) process_get_ren_scale (event%process) - write (unit) process_get_alpha_s (event%process) - call particle_set_write_raw (event%particle_set, unit) - end if - end subroutine event_write_raw - - subroutine event_read_raw & - (event, unit, event_vars, prc_array, num_id_array, iostat, version) - type(event_t), intent(out) :: event - integer, intent(in) :: unit - type(event_vars_t), intent(inout), target :: event_vars - type(process_p), dimension(:), intent(in) :: prc_array - integer, dimension(:), intent(in), optional :: num_id_array - integer, intent(out) :: iostat - integer, intent(in) :: version - integer :: proc - type(process_t), pointer :: process - real(default) :: scale, ren_scale, fac_scale, alpha_s, sqme - call event_vars_read_raw (event_vars, unit, iostat, version) - if (iostat /= 0) return - proc = event_vars%process_index - if (proc > 0 .and. proc <= size (prc_array)) then - process => prc_array(proc)%ptr - event_vars%process_id = process_get_id (process) - if (present (num_id_array)) then - event_vars%process_num_id = num_id_array(proc) - else - event_vars%process_num_id = proc - end if - else - call msg_fatal ("Invalid process index encountered in raw event file") - return - end if - call event_init (event, process, event_vars) - event%is_valid = .true. - read (unit, iostat=iostat) scale - if (iostat /= 0) return - read (unit, iostat=iostat) fac_scale - if (iostat /= 0) return - read (unit, iostat=iostat) ren_scale - if (iostat /= 0) return - read (unit, iostat=iostat) alpha_s - if (iostat /= 0) return - call particle_set_read_raw (event%particle_set, unit, iostat=iostat) - if (iostat /= 0) return - event%particle_set_exists = .true. - if (associated (event%process)) then - call process_set_particles (event%process, event%particle_set) - call process_set_scale (event%process, scale) - call process_set_fac_scale (event%process, fac_scale) - call process_set_ren_scale (event%process, ren_scale) - call process_set_alpha_s (event%process, alpha_s) - call process_set_sqme (event%process, event%vars%sqme) - end if - end subroutine event_read_raw - -@ %def event_write_raw -@ %def event_read_raw -@ -\subsection{HepMC interface} -Check whether a file is a HepMC event file. The HepMC format is characterized -by a version ID string, which apparently follows an empty line. Discard the -empty line, then check the ID string (but not the version). -<>= - public :: is_hepmc_event_file -<>= - function is_hepmc_event_file (u) result (flag) - logical :: flag - integer, intent(in) :: u - integer :: iostat - character(*), parameter :: HEPMC_ID_STRING = "HepMC::Version" - character(len=len(HEPMC_ID_STRING)) :: id_string - id_string = "" - do while (id_string == "") - read (u, "(A)", iostat=iostat) id_string - if (iostat /= 0) exit - end do - if (iostat == 0) then - flag = id_string == HEPMC_ID_STRING - else - flag = .false. - end if - end function is_hepmc_event_file - -@ %def is_hepmc_event_file -@ Read/write the particle set as far as possible from/to a HepMC event record. - -The default weight is unity. The further weights are understood as excess -weight, squared matrix element, and reference value for the latter, in that -order. We rely on the HepMC interface routine to return zero for a weight -that does not exist. When writing to the HepMC event, we rely on the weight -container to be empty initially. - -The polarization mode must be known when reading from HepMC because -the HepMC event record does not specify it. - -Write only valid events; an event read from file is valid by definition. -<>= - public :: event_read_from_hepmc - public :: event_write_to_hepmc -<>= - subroutine event_read_from_hepmc (event, hepmc_event, polarization_mode, & - event_vars, prc_array, num_id_array) - type(event_t), intent(out) :: event - type(hepmc_event_t), intent(in) :: hepmc_event - integer, intent(in) :: polarization_mode - type(event_vars_t), intent(inout), target :: event_vars - type(process_p), dimension(:), intent(in) :: prc_array - integer, dimension(:), intent(in), optional :: num_id_array - real(default) :: scale, alpha_s - integer :: num_id, proc, n_weights - type(process_t), pointer :: process - num_id = hepmc_event_get_process_id (hepmc_event) - proc = get_process_index (num_id, num_id_array) - if (proc > 0 .and. proc <= size (prc_array)) then - process => prc_array(proc)%ptr - call event_init (event, process, event_vars) - event%is_valid = .true. - scale = hepmc_event_get_scale (hepmc_event) - if (scale > 0) call process_set_fac_scale (process, scale) - alpha_s = hepmc_event_get_alpha_qcd (hepmc_event) - if (alpha_s > 0) call process_set_alpha_s (process, alpha_s) - event_vars%event_index = hepmc_event_get_event_index (hepmc_event) - event_vars%process_index = proc - event_vars%process_id = process_get_id (process) - event_vars%process_num_id = num_id - event_vars%sqrts_hat = 0 - n_weights = hepmc_event_get_weights_size (hepmc_event) - if (n_weights > 0) then - event_vars%weight = hepmc_event_get_weight (hepmc_event, 1) - else - event_vars%weight = 1 - end if - event_vars%excess = hepmc_event_get_weight (hepmc_event, 2) - event_vars%sqme = hepmc_event_get_weight (hepmc_event, 3) - event_vars%sqme_ref = hepmc_event_get_weight (hepmc_event, 4) - call particle_set_init (event%particle_set, hepmc_event, & - process_get_model_ptr (event%process), polarization_mode) - event%particle_set_exists = .true. - else - call hepmc_event_print (hepmc_event) - write (msg_buffer, "(A,I0,A)") "HepMC event: process ID ", & - proc, " is invalid in the current context" - call msg_fatal () - end if - end subroutine event_read_from_hepmc - - subroutine event_write_to_hepmc (event, hepmc_event) - type(event_t), intent(in) :: event - type(hepmc_event_t), intent(inout) :: hepmc_event - if (event%is_valid) then - call hepmc_event_set_process_id (hepmc_event, event%vars%process_num_id) - call hepmc_event_clear_weights (hepmc_event) - call hepmc_event_add_weight (hepmc_event, event%vars%weight) - call hepmc_event_add_weight (hepmc_event, event%vars%excess) - call hepmc_event_add_weight (hepmc_event, event%vars%sqme) - call hepmc_event_add_weight (hepmc_event, event%vars%sqme_ref) - call hepmc_event_set_scale (hepmc_event, & - process_get_fac_scale (event%process)) - call hepmc_event_set_alpha_qcd (hepmc_event, & - process_get_alpha_s (event%process)) -! call hepmc_event_set_cross_section (hepmc_event, & -! process_get_integral (event%process), & -! process_get_error (event%process)) - call particle_set_fill_hepmc_event (event%particle_set, hepmc_event) - end if - end subroutine event_write_to_hepmc - -@ %def event_read_from_hepmc event_write_to_hepmc -@ -\subsection{Recovering events} -Recover the process index for this event. If the optional array -[[num_id_array]] is present, select the entry which matches the given ID, -otherwise just return the input ID. -<>= - function get_process_index (num_id, num_id_array) result (proc) - integer :: proc - integer, intent(in) :: num_id - integer, dimension(:), intent(in), optional :: num_id_array - if (present (num_id_array)) then - do proc = 1, size (num_id_array) - if (num_id_array(proc) == num_id) return - end do - write (msg_buffer, "(A,I0,A)") "Reading events: numeric process ID ", & - num_id, " does not match any process" - call msg_fatal - proc = 0 - else - proc = num_id - end if - end function get_process_index - -@ %def get_process_index -@ -Given an event, recover process data. -<>= - public :: event_get_process_ptr -<>= - function event_get_process_ptr (event) result (process) - type(process_t), pointer :: process - type(event_t), intent(in) :: event - process => event%process - end function event_get_process_ptr - -@ %def event_get_process_ptr -@ -\subsection{Factorization modes} -We re-export them here from the [[state_matrices]] module: -<>= - public :: FM_IGNORE_HELICITY - public :: FM_SELECT_HELICITY - public :: FM_FACTOR_HELICITY -@ %def FM_IGNORE_HELICITY FM_SELECT_HELICITY FM_FACTOR_HELICITY -@ -\subsection{Test} -<>= - public :: event_test -<>= - subroutine event_test () - type(os_data_t), pointer :: os_data => null () - type(process_library_t), pointer :: prc_lib => null () - type(event_t), target :: event - type(model_t), pointer :: model - type(var_list_t), pointer :: var_list => null () - print *, "*** Read model file" - allocate (os_data) - allocate (prc_lib) - allocate (var_list) - call os_data_init (os_data) - call syntax_model_file_init () - call model_list_read_model & - (var_str("SM"), var_str("SM.mdl"), os_data, model) - var_list => model_get_var_list_ptr (model) - call syntax_pexpr_init () - call syntax_phs_forest_init () - print * - print *, "*** Load process library" - call var_list_append_string (var_list, name = "$library_name", sval = "test_me") ! $ - call var_list_append_log (var_list, name = "?read_color_factors", lval = .true.) - call var_list_append_log (var_list, name = "?alpha_s_is_fixed", lval = .true.) - call process_library_init (prc_lib, var_str("test_me"), os_data) - call process_library_load (prc_lib, os_data, var_list = var_list) - print * - call event_test1 (prc_lib, model, os_data, var_list) - print * - print *, "* Cleanup" - call event_final (event) - call process_store_final () - call syntax_pexpr_final () - call syntax_phs_forest_final () - call syntax_model_file_final () - call process_library_final (prc_lib) - deallocate (os_data) - deallocate (prc_lib) - end subroutine event_test - -@ %def event_test -<>= - subroutine event_test1 (prc_lib, model, os_data, var_list) - type(process_library_t), intent(inout) :: prc_lib - type(model_t), intent(in), target :: model - type(os_data_t), intent(in) :: os_data - type(var_list_t), target :: var_list - type(process_t), pointer :: process - type(phs_parameters_t) :: phs_par - type(mapping_defaults_t) :: mapping_defaults - type(flavor_t), dimension(2) :: flv - type(polarization_t), dimension(2) :: pol - type(beam_data_t) :: beam_data - type(stream_t), target :: stream - type(parse_tree_t) :: parse_tree - type(grid_parameters_t) :: grid_parameters - integer :: i - type(tao_random_state) :: rng - type(event_vars_t), target :: event_vars - type(event_t), target :: event - type(decay_tree_t), target :: decay_tree - logical :: rebuild_phs = .true. - print *, "*** Test process setup" - print * - print *, "* Initialization" - call tao_random_create (rng, 0) - call process_store_init_process & - (process, prc_lib, var_str ("test_me_unit_col"), model, & - var_list, use_beams = .false.) - print *, " Process ID = ", char (process_get_id (process)) - print * - print *, "* Beam setup" - print * - call flavor_init (flv, (/ 2, -2 /), model) - call polarization_init_unpolarized (pol(1), flv(1)) - call polarization_init_unpolarized (pol(2), flv(2)) - call process_setup_beams (process, beam_data, 0, sqrts = 1000._default) - call process_connect_strfun (process) - call process_setup_subevt (process) - print * - print *, "* Phase space setup" - call openmp_set_num_threads_verbose (1) - call process_setup_phase_space (process, rebuild_phs, & - os_data, phs_par, mapping_defaults, filename_out=var_str("test_me_unit_col.phs"), & - vis_channels = .false.) - print * - print *, "* Cuts setup" - call stream_init (stream, var_str ("all Pt > 200 GeV [g]")) - call parse_tree_init_lexpr (parse_tree, stream, .true.) - call process_setup_cuts (process, parse_tree_get_root_ptr (parse_tree)) - call parse_tree_final (parse_tree) - call stream_final (stream) - print * - print *, "*** Integration" - print *, "* Grids setup" - call process_setup_grids (process, grid_parameters, calls=10000) - print * - print *, "* 5 + 3 iterations" - call process_results_write_header (process) - call process_init_vamp_history (process, 8) - call openmp_set_num_threads_verbose (1) - do i = 1, 5 - call process_integrate (process, rng, grid_parameters, & - 1, 1, 1, 5000, i==1, .true., i>2, .true., .true.) - end do - call process_results_write_current_average (process) - call process_integrate (process, rng, grid_parameters, & - 2, 1, 3, 5000, .true., .false., .true., .true., .true.) - call process_results_write_footer (process) - call process_write_time_estimate (process) - print * - print *, "*** Event generation" - call process_setup_event_generation (process) - call decay_tree_init (decay_tree, process) - call event_init (event, process, event_vars, decay_tree=decay_tree) - print * - print *, "* Weighted event" - call event_generate & - (event, rng, .false., FM_IGNORE_HELICITY, .false., .false., os_data) - call event_write (event) - print * - print *, "* Unweighted event" - call event_generate & - (event, rng, .true., FM_SELECT_HELICITY, .false., .true., os_data) - call event_write (event) - print *, " Process data written to fort.81" - call process_write (process, 81) - call event_final (event) - end subroutine event_test1 - -@ %def event_test1 -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Event files configuration} -This module manages the file formats and the file list for reading and writing -events. -<<[[event_files.f90]]>>= -<> - -module event_files - -<> - use kinds, only: i64 !NODEP! -<> -<> - use diagnostics !NODEP! - use variables - use expressions - use flavors - use event_formats - use processes - use stdhep_interface - use hepmc_interface - use events - use decays - -<> - -<> - -<> - -<> - -contains - -<> - -end module event_files -@ %def event_files -@ -\subsection{Available formats} -Files have a name and a format; we need lists of file specifications. -Writing LHEF files, we need beam information and overall process data. -<>= -<>= - integer, parameter, public :: FMT_NONE = 0 - integer, parameter, public :: FMT_RAW = -1 - integer, parameter, public :: FMT_DEFAULT = 1 - integer, parameter, public :: FMT_DEBUG = 2 - integer, parameter, public :: FMT_HEPMC = 10 - integer, parameter, public :: FMT_LHEF = 20 - integer, parameter, public :: FMT_LHA = 21 - integer, parameter, public :: FMT_LHA_VERB = 29 - integer, parameter, public :: FMT_HEPEVT = 30 - integer, parameter, public :: FMT_ASCII_SHORT = 31 - integer, parameter, public :: FMT_ASCII_LONG = 32 - integer, parameter, public :: FMT_ATHENA = 33 - integer, parameter, public :: FMT_MOKKA = 34 - integer, parameter, public :: FMT_HEPEVT_VERB = 39 - integer, parameter, public :: FMT_STDHEP = 40 - integer, parameter, public :: FMT_STDHEP_UP = 41 - -@ %def FMT_NONE FMT_RAW -@ %def FMT_DEFAULT FMT_DEBUG -@ %def FMT_HEPMC FMT_LHEF FMT_LHA -@ %def FMT_HEPEVT FMT_ASCII_SHORT FMT_ASCII_LONG -@ %def FMT_MOKKA FMT_ATHENA FMT_STDHEP FMT_STDHEP_UP -@ %def FMT_HEPEVT_VERB FMT_LHA_VERB -@ Determine the format of an event file. Check first if it is raw format, then -HepMC. Other formats are not (yet) recognized. -<>= - public :: event_file_get_format -<>= - function event_file_get_format (file) result (fmt) - integer :: fmt - type(string_t), intent(in) :: file - if (is_raw_fmt (file)) then - fmt = FMT_RAW - else if (is_hepmc_fmt (file)) then - fmt = FMT_HEPMC - else - fmt = FMT_NONE - end if - end function event_file_get_format - -@ %def event_file_get_format -@ The raw format is actually unformatted. -<>= - function is_raw_fmt (file) result (flag) - logical :: flag - type(string_t), intent(in) :: file - integer :: u, iostat - u = free_unit () - open (unit=u, file=char(file), action="read", status="old", & - form="unformatted", iostat=iostat) - if (iostat == 0) then - flag = is_raw_event_file (u) - close (u) - else - flag = .false. - end if - end function is_raw_fmt - -@ %def is_raw_fmt -@ The HepMC format is characterized by an ID string, which apparently follows -an empty line. Discard empty lines when checking the ID. -<>= - function is_hepmc_fmt (file) result (flag) - logical :: flag - type(string_t), intent(in) :: file - integer :: u, iostat - open (unit=u, file=char(file), action="read", status="old", iostat=iostat) - if (iostat == 0) then - flag = is_hepmc_event_file (u) - close (u) - else - flag = .false. - end if - end function is_hepmc_fmt - -@ %def is_hepmc_fmt -@ -\subsection{Reading event files} -Apart from the raw event format which is handled in the [[events]] module, we -currently support reading only for HepMC. -<>= - public :: input_event_stream_t -<>= - type :: input_event_stream_t - integer :: fmt = FMT_NONE - integer :: polarization_mode = FM_IGNORE_HELICITY - type(hepmc_iostream_t), pointer :: iostream => null () - end type input_event_stream_t - -@ %def input_event_stream_t -<>= - public :: input_event_stream_init -<>= - subroutine input_event_stream_init (input_stream, file, fmt) - type(input_event_stream_t), intent(out) :: input_stream - type(string_t), intent(in) :: file - integer, intent(in) :: fmt - input_stream%fmt = fmt - select case (input_stream%fmt) - case (FMT_HEPMC) - if (hepmc_is_available ()) then - allocate (input_stream%iostream) - call hepmc_iostream_open_in (input_stream%iostream, file) - else - call msg_fatal ("HepMC event reading is disabled " & - // "because HepMC library is not linked.") - input_stream%fmt = FMT_NONE - end if - case default - call msg_bug ("Unsupported file format selected for reading events.") - end select - end subroutine input_event_stream_init - -@ %def input_event_stream_init -<>= - public :: input_event_stream_read_event -<>= - subroutine input_event_stream_read_event (input_stream, event, & - event_vars, prc_array, ok, num_id_array) - type(input_event_stream_t), intent(inout) :: input_stream - type(event_t), intent(out) :: event - type(event_vars_t), intent(inout), target :: event_vars - type(process_p), dimension(:), intent(in) :: prc_array - logical, intent(out) :: ok - integer, dimension(:), intent(in), optional :: num_id_array - type(hepmc_event_t) :: hepmc_event - select case (input_stream%fmt) - case (FMT_HEPMC) - call hepmc_event_init (hepmc_event) - call hepmc_iostream_read_event (input_stream%iostream, hepmc_event, ok) - if (ok) then - call event_read_from_hepmc & - (event, hepmc_event, input_stream%polarization_mode, & - event_vars, prc_array, num_id_array) - ! call hepmc_event_print (hepmc_event) - end if - call hepmc_event_final (hepmc_event) - end select - end subroutine input_event_stream_read_event - -@ %def input_event_stream_read -<>= - public :: input_event_stream_final -<>= - subroutine input_event_stream_final (input_stream) - type(input_event_stream_t), intent(inout) :: input_stream - select case (input_stream%fmt) - case (FMT_HEPMC) - call hepmc_iostream_close (input_stream%iostream) - deallocate (input_stream%iostream) - end select - input_stream%fmt = FMT_NONE - end subroutine input_event_stream_final - -@ %def input_event_stream_final -@ -\subsection{Output file specification and file list} -<>= - type :: file_spec_t - private - type(string_t) :: name - integer :: format = FMT_NONE - type(hepmc_iostream_t), pointer :: iostream => null () - integer :: unit = 0 - type(flavor_t), dimension(:), allocatable :: beam_flv - real(default), dimension(:), allocatable :: beam_energy - real(default), dimension(:), allocatable :: integral - real(default), dimension(:), allocatable :: error - integer :: n_processes = 0 - logical :: unweighted = .true. - logical :: negative_weights = .false. - logical :: keep_beams = .false. - type(file_spec_t), pointer :: next => null () - end type file_spec_t - -@ %def file_spec_t -@ File lists. -<>= - public :: event_file_list_t -<>= - type :: event_file_list_t - private - type(file_spec_t), pointer :: first => null () - type(file_spec_t), pointer :: last => null () - end type event_file_list_t - -@ %def event_file_list_t -<>= - public :: event_file_list_append_file_spec -<>= - subroutine event_file_list_append_file_spec & - (event_file_list, basename, var_list, format, beam_flv, beam_energy, & - n_processes) - ! unweighted, negative_weights, & - type(event_file_list_t), intent(inout) :: event_file_list - type(string_t), intent(in) :: basename - type(var_list_t), intent(in) :: var_list - integer, intent(in) :: format - type(flavor_t), dimension(:), intent(in) :: beam_flv - real(default), dimension(:), intent(in) :: beam_energy - integer, intent(in) :: n_processes -! logical, intent(in) :: unweighted, negative_weights - type(file_spec_t), pointer :: current - allocate (current) - select case (format) - case (FMT_DEFAULT); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_default")) - case (FMT_DEBUG); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_debug")) - case (FMT_HEPMC); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_hepmc")) - case (FMT_LHEF); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_lhef")) - case (FMT_LHA); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_lha")) - case (FMT_HEPEVT); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_hepevt")) - case (FMT_ASCII_SHORT); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_ascii_short")) - case (FMT_ASCII_LONG); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_ascii_long")) - case (FMT_ATHENA); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_athena")) - case (FMT_MOKKA); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_mokka")) - case (FMT_STDHEP); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_stdhep")) - case (FMT_STDHEP_UP); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_stdhep_up")) - case (FMT_HEPEVT_VERB); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_hepevt_verbose")) - case (FMT_LHA_VERB); current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_lha_verbose")) - case default; current%name = basename // "." // var_list_get_sval & - (var_list, var_str ("$extension_default")) - end select - current%format = format - allocate (current%beam_flv (size (beam_flv))) - current%beam_flv = beam_flv - allocate (current%beam_energy (size (beam_energy))) - current%beam_energy = beam_energy - current%n_processes = n_processes - current%keep_beams = var_list_get_lval (var_list, var_str ("?keep_beams")) - if (associated (event_file_list%last)) then - event_file_list%last%next => current - else - event_file_list%first => current - end if - event_file_list%last => current - end subroutine event_file_list_append_file_spec - -@ %def event_file_list_append_file_spec -<>= - subroutine event_file_list_final (event_file_list) - type(event_file_list_t), intent(inout) :: event_file_list - type(file_spec_t), pointer :: current - do while (associated (event_file_list%first)) - current => event_file_list%first - event_file_list%first => current%next - deallocate (current) - end do - event_file_list%last => null () - end subroutine event_file_list_final - -@ %def event_file_list_final -@ -\subsection{Checking filenames} -Check if a filename is reserved as an output filename. -<>= - public :: event_file_list_is_filename -<>= - function event_file_list_is_filename (event_file_list, filename) result (flag) - logical :: flag - type(event_file_list_t), intent(in) :: event_file_list - type(string_t), intent(in) :: filename - type(file_spec_t), pointer :: current - current => event_file_list%first - do while (associated (current)) - if (current%name == filename) then - flag = .true. - return - end if - current => current%next - end do - flag = .false. - end function event_file_list_is_filename - -@ %def event_file_list_is_filename -@ -\subsection{Handling output event files} -LHEF: Initialize run data with beam and simulation parameters. -<>= - public :: event_file_list_open -<>= - subroutine event_file_list_open (event_file_list, process_id, n_events, var_list) - type(event_file_list_t), intent(inout), target :: event_file_list - type(string_t), dimension(:), intent(in) :: process_id - integer, intent(in) :: n_events - real(default), dimension(:), allocatable :: integral, error - type(var_list_t), intent(in) :: var_list - type(process_t), pointer :: process - type(file_spec_t), pointer :: current - integer :: i, n_proc - integer(i64) :: n_events_expected - n_proc = size (process_id) - current => event_file_list%first - allocate (integral (n_proc), error (n_proc)) - do i = 1, n_proc - process => process_store_get_process_ptr (process_id(i)) - if (associated (process)) then - integral(i) = process_get_integral (process) - error(i) = process_get_error (process) - else - integral(i) = 0 - error(i) = 0 - end if - end do - n_events_expected = n_events - do while (associated (current)) - select case (current%format) - case (FMT_DEFAULT) - call msg_message ("Writing events in human-readable format " & - // "to file '" // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - case (FMT_DEBUG) - call msg_message ("Writing events in verbose format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - case (FMT_HEPMC) - call msg_message ("Writing events in HepMC format to file '" & - // char (current%name) // "'") - if (hepmc_is_available ()) then - allocate (current%iostream) - call hepmc_iostream_open_out (current%iostream, current%name) - else - call msg_error ("HepMC event writing is disabled " & - // "because HepMC library is not linked.") - end if - case (FMT_HEPEVT) - call msg_message ("Writing events in HEPEVT format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - case (FMT_ASCII_SHORT) - call msg_message ("Writing events in short ASCII format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - case (FMT_ASCII_LONG) - call msg_message ("Writing events in long ASCII format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - case (FMT_ATHENA) - call msg_message ("Writing events in ATHENA format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - case (FMT_MOKKA) - call msg_message ("Writing events in MOKKA format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - case (FMT_LHEF) - call msg_message ("Writing events in LHEF format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - call les_houches_events_write_header (current%unit) - call heprup_init & - (flavor_get_pdg (current%beam_flv), & - current%beam_energy, & - n_processes = current%n_processes, & - unweighted = current%unweighted, & - negative_weights = current%negative_weights) - do i = 1, n_proc - call heprup_set_process_parameters (i = i, process_id = & - i, cross_section = integral(i), error = error(i)) - end do - call heprup_write_lhef (current%unit) - case (FMT_LHA) - call msg_message ("Writing events in (old) LHA format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - call heprup_init & - (flavor_get_pdg (current%beam_flv), & - current%beam_energy, & - n_processes = current%n_processes, & - unweighted = current%unweighted, & - negative_weights = current%negative_weights) - do i = 1, n_proc - call heprup_set_process_parameters (i = i, process_id = & - i, cross_section = integral(i), error = error(i)) - end do - case (FMT_STDHEP) - call msg_message ("Writing events in binary STDHEP/HEPEVT format to file '" & - // char (current%name) // "'") - call stdhep_init (char(current%name), "WHIZARD event sample", & - n_events_expected) - case (FMT_STDHEP_UP) - call msg_message ("Writing events in binary STDHEP/HEPRUP/HEPEUP format to file '" & - // char (current%name) // "'") - call heprup_init & - (flavor_get_pdg (current%beam_flv), & - current%beam_energy, & - n_processes = current%n_processes, & - unweighted = current%unweighted, & - negative_weights = current%negative_weights) - do i = 1, n_proc - call heprup_set_process_parameters (i = i, process_id = & - i, cross_section = integral(i), error = error(i)) - end do - call stdhep_init (char(current%name), "WHIZARD event sample", & - n_events_expected) - call stdhep_write (STDHEP_HEPRUP) - case (FMT_HEPEVT_VERB) - call msg_message ("Writing events in verbose HEPEVT format to file '" & - // char (current%name) // "'") - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - case (FMT_LHA_VERB) - call msg_message ("Writing events in verbose HEPRUP/HEPEUP format to file '" & - // char (current%name) // "'") - call heprup_init & - (flavor_get_pdg (current%beam_flv), & - current%beam_energy, & - n_processes = current%n_processes, & - unweighted = current%unweighted, & - negative_weights = current%negative_weights) - do i = 1, n_proc - call heprup_set_process_parameters (i = i, process_id = & - i, cross_section = integral(i), error = error(i)) - end do - current%unit = free_unit () - open (unit=current%unit, file=char(current%name), & - action="write", status="replace") - call heprup_write_verbose (current%unit) - end select - current => current%next - end do - end subroutine event_file_list_open - -@ %def event_file_list_open -@ Scan the file list and write the event in the selected formats. -<>= - public :: event_file_list_write_event -<>= - subroutine event_file_list_write_event & - (event_file_list, event, integral_sum, error_sum, analysis_expr, i_evt) - type(event_file_list_t), intent(in), target :: event_file_list - type(event_t), intent(in), target :: event - real(default), intent(in) :: integral_sum, error_sum - type(eval_tree_t), intent(in) :: analysis_expr - integer, intent(in) :: i_evt - type(file_spec_t), pointer :: current - type(hepmc_event_t) :: hepmc_event - current => event_file_list%first - do while (associated (current)) - select case (current%format) - case (FMT_DEFAULT) - call event_write (event, unit=current%unit, verbose=.false.) - case (FMT_DEBUG) - call event_write (event, analysis_expr=analysis_expr, & - unit=current%unit, verbose=.true.) - case (FMT_HEPMC) - if (hepmc_is_available ()) then - call hepmc_event_init (hepmc_event, event_id=i_evt) - call hepmc_event_set_cross_section (hepmc_event, & - integral_sum, error_sum) - call event_write_to_hepmc (event, hepmc_event) - ! call hepmc_event_print (hepmc_event) - call hepmc_iostream_write_event (current%iostream, hepmc_event) - call hepmc_event_final (hepmc_event) - end if - case (FMT_HEPEVT) - call event_write_to_hepevt (event, current%keep_beams) - call hepevt_write_hepevt (current%unit) - case (FMT_ASCII_SHORT) - call event_write_to_hepevt (event, current%keep_beams) - call hepevt_write_ascii (current%unit, .false.) - case (FMT_ASCII_LONG) - call event_write_to_hepevt (event, current%keep_beams) - call hepevt_write_ascii (current%unit, .true.) - case (FMT_ATHENA) - call event_write_to_hepevt (event, current%keep_beams) - call hepevt_write_athena (unit=current%unit, i_evt=i_evt) - case (FMT_MOKKA) - call event_write_to_hepevt (event, current%keep_beams) - call hepevt_write_mokka (unit=current%unit) - case (FMT_LHEF) - call event_write_to_hepeup (event, current%keep_beams) - call hepeup_write_lhef (current%unit) - case (FMT_LHA) - call event_write_to_hepeup (event, current%keep_beams) - call hepeup_write_lha (current%unit) - case (FMT_STDHEP) - call event_write_to_hepevt (event, current%keep_beams) - call stdhep_write (STDHEP_HEPEVT) - case (FMT_STDHEP_UP) - call event_write_to_hepeup (event, current%keep_beams) - call stdhep_write (STDHEP_HEPEUP) - case (FMT_HEPEVT_VERB) - call event_write_to_hepevt (event, current%keep_beams) - call hepevt_write_verbose (current%unit) - case (FMT_LHA_VERB) - call event_write_to_hepeup (event, current%keep_beams) - call hepeup_write_verbose (current%unit) - end select - current => current%next - end do - end subroutine event_file_list_write_event - -@ %def event_file_list_write_event -@ Close streams. -<>= - public :: event_file_list_close -<>= - subroutine event_file_list_close (event_file_list) - type(event_file_list_t), intent(inout), target :: event_file_list - type(file_spec_t), pointer :: current - current => event_file_list%first - do while (associated (current)) - select case (current%format) - case (FMT_HEPMC) - if (hepmc_is_available ()) then - call hepmc_iostream_close (current%iostream) - deallocate (current%iostream) - end if - case (FMT_LHEF) - call les_houches_events_write_footer (current%unit) - close (current%unit) - case (FMT_STDHEP) - call stdhep_end - case (FMT_STDHEP_UP) - call stdhep_end - case default - close (current%unit) - end select - current => current%next - end do - end subroutine event_file_list_close - -@ %def event_file_list_close -@ -\subsection{Additional tools} -<>= - public :: event_format_code -<>= - elemental function event_format_code (format) result (fmt) - integer :: fmt - type(string_t), intent(in) :: format - select case (char (format)) - case ("ascii") - fmt = FMT_DEFAULT - case ("debug") - fmt = FMT_DEBUG - case ("hepmc") - fmt = FMT_HEPMC - case ("hepevt") - fmt = FMT_HEPEVT - case ("short") - fmt = FMT_ASCII_SHORT - case ("long") - fmt = FMT_ASCII_LONG - case ("athena") - fmt = FMT_ATHENA - case ("mokka") - fmt = FMT_MOKKA - case ("lhef") - fmt = FMT_LHEF - case ("lha") - fmt = FMT_LHA - case ("stdhep") - fmt = FMT_STDHEP - case ("stdhep_up") - fmt = FMT_STDHEP_UP - case ("hepevt_verbose") - fmt = FMT_HEPEVT_VERB - case ("lha_verbose") - fmt = FMT_LHA_VERB - case default - fmt = FMT_NONE - end select - end function event_format_code - -@ %def event_format_code -@ -\subsection{Simulation parameters} -This transparent container holds the parameters that control event -generation. - -\emph{This and the following section (simulation object) should end up in a -separate module. We defer this until it is clear whether we need anything -from the [[integrate]] command to be complete.} -<>= - integer, parameter :: NORM_UNDEFINED = 0 - integer, parameter :: NORM_UNIT = 1 - integer, parameter :: NORM_N_EVT = 2 - integer, parameter :: NORM_SIGMA = 3 - integer, parameter :: NORM_SIGMA_N_EVT = 4 - -@ %def NORM_AUTO NORM_UNIT NORM_N_EVT NORM_SIGMA NORM_SIGMA_N_EVT -<>= - type :: simulation_parameters_t - logical :: unweighted = .true. - logical :: use_best_grid = .true. - integer :: normalization_mode = NORM_UNDEFINED - logical :: negative_weights = .false. - logical :: polarized = .false. - type(shower_settings_t) :: shower_settings - end type simulation_parameters_t - -@ %def simulation_parameters_t -@ Initialize the generic simulation parameters. -<>= - recursive subroutine simulation_parameters_init & - (sim, unweighted, use_best_grid, event_normalization, negative_weights, & - polarized) - type(simulation_parameters_t), intent(out) :: sim - logical, intent(in) :: unweighted - logical, intent(in) :: use_best_grid - type(string_t), intent(in) :: event_normalization - logical, intent(in) :: negative_weights, polarized - sim%unweighted = unweighted - sim%use_best_grid = use_best_grid - sim%negative_weights = negative_weights - sim%polarized = polarized - select case (char (event_normalization)) - case ("auto", "Auto", "AUTO", "automatic", "Automatic", "AUTOMATIC") - if (unweighted) then - sim%normalization_mode = NORM_UNIT - else - sim%normalization_mode = NORM_SIGMA - end if - case ("1", "unity", "Unity", "UNITY") - sim%normalization_mode = NORM_UNIT - case ("1/n", "1/N") - sim%normalization_mode = NORM_N_EVT - case ("sigma", "Sigma", "SIGMA") - sim%normalization_mode = NORM_SIGMA - case ("sigma/n", "Sigma/n", "Sigma/N", "SIGMA/N") - sim%normalization_mode = NORM_SIGMA_N_EVT - case default - call msg_error ("Unknown value '" // char (event_normalization) & - // "for $event_normalization. I'll assume 'auto'") - call simulation_parameters_init & - (sim, unweighted, use_best_grid, var_str ("auto"), & - negative_weights, polarized) - end select - end subroutine simulation_parameters_init - -@ %def simulation_parameters_init -@ Initialize the shower parameters. -<>= - subroutine simulation_parameters_init_shower (sim, var_list) - type(simulation_parameters_t), intent(inout) :: sim - type(var_list_t), intent(in) :: var_list - call shower_settings_init (sim%shower_settings, var_list) - end subroutine simulation_parameters_init_shower - -@ %def simulation_parameters_init_shower -<>= - subroutine simulation_parameters_write_message (sim, unit) - type(simulation_parameters_t), intent(in) :: sim - integer, intent(in), optional :: unit - type(string_t) :: weight_str, grid_str, norm_str, neg_str, polarized_str - if (sim%unweighted) then - weight_str = "unweighted" - else - weight_str = "weighted" - end if - if (sim%use_best_grid) then - grid_str = ", best grid" - else - grid_str = ", last grid" - end if - if (sim%polarized) then - polarized_str = ", polarized events" - else - polarized_str = ", unpolarized_events" - end if - select case (sim%normalization_mode) - case (NORM_UNIT) - norm_str = "1" - case (NORM_N_EVT) - norm_str = "1/n" - case (NORM_SIGMA) - norm_str = "sigma" - case (NORM_SIGMA_N_EVT) - norm_str = "sigma/n" - case default - norm_str = "unknown" - end select - if (sim%negative_weights) then - neg_str = ", allow negative weights" - else - neg_str = "" - end if - call msg_message ("Simulation mode = " & - // char (weight_str) // char (grid_str), & - unit) - call msg_message (" " & - // "event_normalization = '" // char (norm_str) & - // "'" // char (neg_str) // char (polarized_str), & - unit) - end subroutine simulation_parameters_write_message - -@ %def simulation_parameters_write -<>= - subroutine simulation_parameters_write (sim, unit) - type(simulation_parameters_t), intent(in) :: sim - integer, intent(in), optional :: unit - integer :: u - u = output_unit (unit) - write (u, *) "Simulation parameters:" - write (u, *) " unweighted = ", sim%unweighted - write (u, *) " use best grid = ", sim%use_best_grid - write (u, *) " normalization_mode = ", sim%normalization_mode - write (u, *) " negative_weights = ", sim%negative_weights - write (u, *) " polarized = ", sim%polarized - call shower_settings_write (sim%shower_settings, unit) - end subroutine simulation_parameters_write - -@ %def simulation_parameters_write -<>= - function simulation_parameters_get_norm (sim, sigma, n) result (norm) - real(default) :: norm - type(simulation_parameters_t), intent(in) :: sim - real(default), intent(in) :: sigma - integer, intent(in) :: n - select case (sim%normalization_mode) - case (NORM_UNIT) - norm = 1 - case (NORM_N_EVT) - if (n /= 0) then - norm = 1._default / n - else - norm = 1 - end if - case (NORM_SIGMA) - norm = sigma - case (NORM_SIGMA_N_EVT) - if (n /= 0) then - norm = sigma / n - else - norm = sigma - end if - case default - norm = 1 - end select - if ((.not. sim%unweighted) .and. sigma /= 0) norm = norm / sigma - end function simulation_parameters_get_norm - -@ %def simulation_parameters_get_norm -<>= - function simulation_parameters_get_md5sum (sim) result (md5sum_sim) - character(32) :: md5sum_sim - type(simulation_parameters_t), intent(in) :: sim - integer :: u - u = free_unit () - open (u, status = "scratch") - call simulation_parameters_write (sim, u) - rewind (u) - md5sum_sim = md5sum (u) - close (u) - end function simulation_parameters_get_md5sum - -@ %def simulation_parameters_get_md5sum -@ -\subsection{The simulation object type} -We set up a data type which holds all information needed for simulation. This -allows to separate initialization, event generation, and finalization of a -simulation run. The type is public, so the object may be used as a black box -by an external caller. - -The objects of this type must carry the [[target]] attribute, since several -components will be pointed to. -<>= - public :: simulation_t -<>= - type :: simulation_t - ! not private anymore as required by the whizard-c-interface - integer :: n_proc = 0 - type(string_t), dimension(:), allocatable :: process_id - type(process_p), dimension(:), allocatable :: prc_array - type(var_list_t) :: var_list - logical :: rebuild_events = .false. - logical :: check_grid_file = .true. - logical :: check_event_file = .true. - integer :: version = 0 - integer :: n_in = 0 - type(flavor_t), dimension(:), allocatable :: beam_flv - real(default), dimension(:), allocatable :: beam_energy - type(string_t) :: basename - logical :: rescan = .false. - logical :: use_num_id = .false. - integer, dimension(:), allocatable :: num_id - logical :: update_parameters = .true. - logical :: update_scale = .false. - logical :: update_alpha_s = .false. - logical :: update_sqme = .true. - logical :: update_weight = .true. - logical :: read_raw = .false. - logical :: read_hepmc = .false. - logical :: write_raw = .false. - type(string_t) :: file_rescan - type(string_t) :: file_raw - type(string_t) :: file_hepmc - type(input_event_stream_t) :: input_stream - type(event_file_list_t) :: event_file_list - integer :: u_raw = -1 - type(simulation_parameters_t) :: spar - real(default), dimension(:), allocatable :: integral - real(default), dimension(:), allocatable :: error - real(default) :: integral_sum = 0 - real(default) :: error_sum = 0 - real(default) :: norm_weight = 0 - logical :: helicity_selection_active = .false. - real(default) :: helicity_selection_threshold = -1 - integer :: helicity_selection_cutoff = 1000 - type(md5sum_events_t) :: md5sum - integer :: n_events = 0 - logical :: n_events_set = .false. - integer :: n_read = 0 - integer :: i_evt = 0 - integer :: n_selected = 0 - real(default) :: luminosity = 0 - logical :: user_selection = .false. - type(eval_tree_t) :: selection_expr - type(eval_tree_t) :: reweight_expr - type(eval_tree_t) :: analysis_expr - type(subevt_t) :: subevt - type(event_vars_t) :: event_vars - logical :: allow_decays = .true. - type(decay_tree_t), dimension(:), allocatable :: decay_tree - type(checkpointing_t) :: checkpointing - type(event_t) :: event - end type simulation_t - -@ %def simulation_t -@ -\subsubsection{Preparing event generation} -This is the basic initializer; it specifies the processes and issues a -message if requested. Furthermore, it initializes some important flags, and it -makes a snapshot of the current variable list. -<>= - subroutine simulation_basic_init (sim, process_id, var_list, rescan, verbose) - type(simulation_t), intent(out) :: sim - type(string_t), dimension(:), intent(in) :: process_id - type(var_list_t), intent(in), target :: var_list - logical, intent(in), optional :: rescan, verbose - type(string_t) :: process_string, version_string - integer :: proc - logical :: generate, verb - generate = .true.; if (present (rescan)) generate = .not. rescan - verb = .true.; if (present (verbose)) verb = verbose - sim%n_proc = size (process_id) - allocate (sim%process_id (sim%n_proc)) - sim%process_id = process_id - allocate (sim%prc_array (sim%n_proc)) - do proc = 1, sim%n_proc - sim%prc_array(proc)%ptr => & - process_store_get_process_ptr (sim%process_id(proc)) - end do - if (verb) then - process_string = "" - do proc = 1, size (process_id) - if (proc > 1) process_string = process_string // ", " - process_string = process_string // sim%process_id (proc) - end do - if (generate) then - call msg_message ("Initializing simulation for processes " & - // char (process_string) // ":") - else - call msg_message ("Initializing rescanning for processes " & - // char (process_string) // ":") - end if - end if - sim%rebuild_events = & - var_list_get_lval (var_list, var_str ("?rebuild_events")) - sim%check_grid_file = & - var_list_get_lval (var_list, var_str ("?check_grid_file")) - sim%check_event_file = & - var_list_get_lval (var_list, var_str ("?check_event_file")) - version_string = & - var_list_get_sval (var_list, var_str ("$event_file_version")) - select case (char (version_string)) - case ("2.00":"2.06"); sim%version = 2 - case default; sim%version = 3 - end select - call simulation_parameters_init (sim%spar, & - var_list_get_lval & - (var_list, var_str ("?unweighted")), & - var_list_get_lval & - (var_list, var_str ("?use_best_grid")), & - var_list_get_sval & - (var_list, var_str ("$event_normalization")), & - var_list_get_lval & - (var_list, var_str ("?negative_weights")), & - var_list_get_lval & - (var_list, var_str ("?polarized_events"))) - call simulation_parameters_init_shower (sim%spar, var_list) - if (present (verbose)) then - if (verbose) call simulation_parameters_write_message (sim%spar) - end if - sim%helicity_selection_active = & - var_list_get_lval (var_list, var_str ("?helicity_selection_active")) - if (sim%helicity_selection_active) then - sim%helicity_selection_threshold = var_list_get_rval (var_list, & - var_str ("helicity_selection_threshold")) - sim%helicity_selection_cutoff = var_list_get_ival (var_list, & - var_str ("helicity_selection_cutoff")) - end if - sim%use_num_id = & - var_list_get_lval (var_list, var_str ("?use_num_id")) - if (sim%use_num_id) then - allocate (sim%num_id (size (process_id))) - do proc = 1, sim%n_proc - sim%num_id(proc) = proc_get_num_id (sim%process_id(proc), var_list) - end do - end if - sim%allow_decays = & - var_list_get_lval (var_list, var_str ("?allow_decays")) - call var_list_init_snapshot (sim%var_list, var_list) - end subroutine simulation_basic_init - -@ %def simulation_basic_init -@ Get the numeric process ID for a process. If not associated, issue an -error. -<>= - function proc_get_num_id (process_id, var_list) result (num_id) - integer :: num_id - type(string_t), intent(in) :: process_id - type(var_list_t), intent(in) :: var_list - type(string_t) :: var_name - var_name = "num_id(" // process_id // ")" - if (var_list_is_known (var_list, var_name)) then - num_id = var_list_get_ival (var_list, var_name) - else - call msg_error ("Numeric process ID '" & - // char (var_name) // "' is undefined, inserting zero.") - num_id = 0 - end if - end function proc_get_num_id - -@ %def proc_get_num_id -@ This is the initializer that applies for rescanning existing event files. -Since the matrix element will be recalculated for each event, we redo the -initializations of the helicity selection and the process variables. -<>= - subroutine simulation_init_rescan & - (sim, file_rescan, process_id, var_list, verbose) - type(simulation_t), intent(out) :: sim - type(string_t), intent(in) :: file_rescan - type(string_t), dimension(:), intent(in) :: process_id - type(var_list_t), intent(in), target :: var_list - logical, intent(in), optional :: verbose - integer :: proc - type(process_t), pointer :: process - logical :: verb - verb = .true.; if (present (verbose)) verb = verbose - call simulation_basic_init & - (sim, process_id, var_list, rescan=.true., verbose=verbose) - sim%rebuild_events = .false. - sim%rescan = .true. - sim%file_rescan = file_rescan - sim%update_parameters = & - var_list_get_lval (var_list, var_str ("?update_parameters")) - sim%update_scale = & - var_list_get_lval (var_list, var_str ("?update_scale")) - sim%update_alpha_s = & - var_list_get_lval (var_list, var_str ("?update_alpha_s")) - sim%update_sqme = & - var_list_get_lval (var_list, var_str ("?update_sqme")) - sim%update_weight = & - var_list_get_lval (var_list, var_str ("?update_weight")) - if (verb) then - call msg_message ("Reading events from file '" & - // char (sim%file_rescan) // "'") - if (sim%update_scale) call msg_message & - ("Recalculating event scale") - if (sim%update_alpha_s) call msg_message & - ("Recalculating alpha_s") - if (sim%update_sqme) then - if (sim%update_parameters) then - call msg_message ("Recalculating squared matrix element " & - // "with updated parameters") - else - call msg_message ("Recalculating squared matrix element") - end if - end if - if (sim%update_weight) call msg_message ("Updating event weight " & - // "using matrix element ratio") - end if - do proc = 1, sim%n_proc - process => sim%prc_array(proc)%ptr - call process_reset_helicity_selection (process, & - sim%helicity_selection_threshold, sim%helicity_selection_cutoff) - end do - end subroutine simulation_init_rescan - -@ %def simulation_init_rescan -@ Do missing integration for processes where this is possible. The results -are inserted into the [[global_var_list]] (the [[global]] object may in fact -be local to the caller). - -If [[rescan]] is set, do just process initialization, no integration. -<>= - subroutine simulation_compute_missing_integrals & - (sim, global, global_var_list, rescan, verbose) - type(simulation_t), intent(inout) :: sim - type(rt_data_t), intent(inout), target :: global - type(var_list_t), intent(inout) :: global_var_list - logical, intent(in), optional :: rescan, verbose - integer :: proc - logical :: me_only - me_only = .false.; if (present (rescan)) me_only = rescan - if (me_only) then - call prepare_me_missing_processes (sim%process_id, global, verbose) - else - call integrate_missing_processes & - (sim%process_id, global, global_var_list, verbose = verbose) - end if - do proc = 1, sim%n_proc - sim%prc_array(proc)%ptr => & - process_store_get_process_ptr (sim%process_id(proc)) - end do - end subroutine simulation_compute_missing_integrals - -@ %def simulation_compute_missing_integrals -@ For each process that has an integral, choose the best integration -grid for event generation. -<>= - subroutine simulation_choose_best_grids (sim) - type(simulation_t), intent(in) :: sim - type(process_t), pointer :: process - integer :: proc - do proc = 1, sim%n_proc - process => sim%prc_array(proc)%ptr - if (associated (process)) then - if (process_has_integral (process)) & - call process_choose_best_grid (process, sim%check_grid_file) - end if - end do - end subroutine simulation_choose_best_grids - -@ %def simulation_choose_best_grids -@ Initialize processes that are not yet contained in the process store, if -possible. This applies when rescanning files. We do not need integrals in -that case, but the process must be initialized including beam data, if any. -We also allow for weight and scale expressions (if absent, the values in the -file are used), and take notice of the $\alpha_s$ scheme. -<>= - subroutine simulation_init_missing_processes (sim, global, verbose) - type(simulation_t), intent(inout) :: sim - type(rt_data_t), intent(inout), target :: global - logical, intent(in), optional :: verbose - integer :: n_missing - type(string_t), dimension(:), allocatable :: missing_process_id - logical, dimension(:), allocatable :: missing - integer :: proc - logical :: verb - verb = .false.; if (present (verbose)) verb = verbose - allocate (missing (sim%n_proc)) - do proc = 1, sim%n_proc - missing(proc) = .not. associated (sim%prc_array(proc)%ptr) - end do - n_missing = count (missing) - if (n_missing > 0) then - allocate (missing_process_id (n_missing)) - missing_process_id = pack (sim%process_id, missing) - call prepare_me_evaluation (missing_process_id, global) - do proc = 1, sim%n_proc - if (missing(proc)) sim%prc_array(proc)%ptr => & - process_store_get_process_ptr (sim%process_id(proc)) - end do - end if - end subroutine simulation_init_missing_processes - -@ %def simulation_init_missing_processes -@ Check whether for the selected combination of processes, simulation is -possible at all. -<>= - subroutine simulation_check (sim, ok) - type(simulation_t), intent(inout) :: sim - logical, intent(out) :: ok - type(process_t), pointer :: process - integer :: proc - type(flavor_t), dimension(:), allocatable :: beam_flv - real(default), dimension(:), allocatable :: beam_energy - ok = .false. - do proc = 1, sim%n_proc - process => sim%prc_array(proc)%ptr - if (.not. associated (process)) then - call msg_fatal ("Process '" // char (sim%process_id(proc)) & - // "' is not available for simulation.") - return - end if - select case (proc) - case (1) - sim%n_in = process_get_n_in (process) - allocate (beam_flv (sim%n_in), beam_energy (sim%n_in)) - beam_flv = process_get_beam_flv (process) - beam_energy = process_get_beam_energy (process) - case default - if (.not. process_has_matrix_element (process)) cycle - if (process_get_n_in (process) /= sim%n_in) then - call msg_fatal ("Simulation: " & - // "Mixture of scattering and decays") - return - else if (any (process_get_beam_flv (process) /= beam_flv)) then - call msg_fatal ("Simulation: Mismatch in beam particles") - return - else if (any (process_get_beam_energy (process) & - /= beam_energy))then - call msg_fatal ("Simulation: Mismatch in beam energies") - return - end if - end select - end do - allocate (sim%beam_flv (sim%n_in), sim%beam_energy (sim%n_in)) - sim%beam_flv = beam_flv - sim%beam_energy = beam_energy - ok = .true. - end subroutine simulation_check - -@ %def simulation_check -@ Initialize I/O files and switches. The [[event_fmt]] array may be -unallocated, therefore we keep its [[allocatable]] attribute. -<>= - subroutine simulation_setup_event_file_list (sim, event_fmt, basename_default) - type(simulation_t), intent(inout) :: sim - integer, dimension(:), intent(in), allocatable :: event_fmt - type(string_t), intent(in) :: basename_default - type(string_t) :: extension_raw - integer :: i - type(string_t) :: matching_basename - sim%basename = var_list_get_sval (sim%var_list, var_str ("$sample")) - if (sim%basename == "") sim%basename = basename_default - if (sim%rescan) then - select case (event_file_get_format (sim%file_rescan)) - case (FMT_RAW) - sim%read_raw = .true. - sim%file_raw = sim%file_rescan - case (FMT_HEPMC) - sim%read_hepmc = .true. - sim%file_hepmc = sim%file_rescan - case default - call msg_fatal ("Rescanning event file '" // char (sim%file_rescan) & - // "': file format not supported") - end select - sim%write_raw = .false. - else - sim%read_raw = var_list_get_lval (sim%var_list, var_str ("?read_raw")) & - .and. .not. sim%rebuild_events - sim%write_raw = var_list_get_lval (sim%var_list, var_str ("?write_raw")) - extension_raw = var_list_get_sval (sim%var_list, var_str ("$extension_raw")) - sim%file_raw = sim%basename // "." // extension_raw - end if - if (allocated (event_fmt)) then - do i = 1, size (event_fmt) - call event_file_list_append_file_spec (sim%event_file_list, & - sim%basename, sim%var_list, event_fmt(i), & - sim%beam_flv, sim%beam_energy, sim%n_proc) - end do - end if - if (sim%rescan) then - if (sim%read_raw) then - if (event_file_list_is_filename (sim%event_file_list, sim%file_raw)) & - call msg_fatal ("Output event file '" & - // char (sim%file_raw) // "' coincides with input file") - else if (sim%read_hepmc) then - if (event_file_list_is_filename (sim%event_file_list, sim%file_hepmc)) & - call msg_fatal ("Output event file '" & - // char (sim%file_hepmc) // "' coincides with input file") - end if - end if - end subroutine simulation_setup_event_file_list - -@ %def simulation_setup_event_file_list -@ Collect and store the integrals (cross sections) for the processes to -simulate. -<>= - subroutine simulation_collect_integrals (sim, var_list, ok) - type(simulation_t), intent(inout) :: sim - type(var_list_t), intent(in) :: var_list - logical, intent(out) :: ok - integer :: proc - type(process_t), pointer :: process - type(string_t) :: process_id - allocate (sim%integral (sim%n_proc)) - allocate (sim%error (sim%n_proc)) - do proc = 1, sim%n_proc - process => sim%prc_array(proc)%ptr - process_id = process_get_id (process) - sim%integral(proc) = var_list_get_rval (var_list, & - var_str ("integral(") // process_id // ")") - sim%error(proc) = var_list_get_rval (var_list, & - var_str ("error(") // process_id // ")") - if (sim%integral(proc) < 0 .and. .not.sim%spar%negative_weights) then - call msg_fatal ("Integral of process '" & - // char (process_id) // "' is negative") - end if - end do - sim%integral_sum = sum (sim%integral) - sim%error_sum = sqrt (sum (sim%error ** 2)) - if (sim%integral_sum > 0) then - ok = .true. - else - if (sim%spar%negative_weights) then - ok = .false. - else - call msg_error ("Simulation: " & - // "sum of process integrals must be positive; skipping") - ok = .false. - end if - end if - end subroutine simulation_collect_integrals - -@ %def simulation_collect_integrals -@ Collect the MD5 sums that we will check when reading a raw event file. -<>= - subroutine simulation_collect_md5sums (sim) - type(simulation_t), intent(inout) :: sim - integer :: proc - type(process_t), pointer :: process - allocate (sim%md5sum%process (sim%n_proc)) - allocate (sim%md5sum%parameters (sim%n_proc)) - allocate (sim%md5sum%results (sim%n_proc)) - allocate (sim%md5sum%polarized (sim%n_proc)) - do proc = 1, sim%n_proc - process => sim%prc_array(proc)%ptr - sim%md5sum%process(proc) = process_get_md5sum (process) - sim%md5sum%parameters(proc) = process_get_md5sum_parameters (process) - sim%md5sum%results(proc) = process_get_md5sum_results (process) - sim%md5sum%polarized(proc) = process_get_md5sum_polarized (process) - end do - if (sim%allow_decays) then - sim%md5sum%decays = decay_store_get_md5sum () - else - sim%md5sum%decays = "" - end if - sim%md5sum%simulation = simulation_parameters_get_md5sum (sim%spar) - end subroutine simulation_collect_md5sums - -@ %def simulation_collect_md5sums -@ Choose the number of events to generate from either the luminosity -or the specified [[n_events]], whatever is larger. Return revised values for -both luminosity and number of events. - -Also determine the event weight normalization. -<>= - subroutine simulation_setup_n_events (sim, verbose) - type(simulation_t), intent(inout) :: sim - logical, intent(in), optional :: verbose - integer :: n_events - real(default) :: luminosity - logical :: verb - verb = .true.; if (present (verbose)) verb = verbose - n_events = var_list_get_ival (sim%var_list, var_str ("n_events")) - if (sim%rescan) then - if (n_events /= 0) then - sim%n_events = n_events - if (verb) then - write (msg_buffer, "(A,1x,I0)") & - "Requested number of events =", sim%n_events - call msg_message () - end if - else - sim%n_events = huge (1) - end if - sim%luminosity = 0 - sim%norm_weight = 0 - else - luminosity = var_list_get_rval (sim%var_list, var_str ("luminosity")) - if (.not.sim%spar%unweighted) then - if (luminosity > 0) then - if (n_events == 0) then - call msg_fatal ("Setting a luminosity is only allowed for " // & - "unweighted events. Please set n_events.") - else - call msg_warning ("Setting a luminosity is only allowed for " // & - "unweighted events. Luminosity will be ignored.") - end if - luminosity = 0 - end if - end if - sim%n_events = max (nint (luminosity * sim%integral_sum), n_events) - sim%n_events_set = (sim%n_events.eq.n_events) - sim%luminosity = max (luminosity, sim%n_events / sim%integral_sum) - sim%norm_weight = simulation_parameters_get_norm & - (sim%spar, sim%integral_sum, sim%n_events) - if (verb) then - write (msg_buffer, "(A,1x,I0)") & - "Requested number of events =", sim%n_events - call msg_message () - if (sim%spar%unweighted) then - write (msg_buffer, "(A,1x,G11.4)") & - "This corresponds to luminosity [fb-1] = ", & - sim%luminosity - call msg_message () - end if - end if - end if - end subroutine simulation_setup_n_events - -@ %def simulation_setup_n_events -@ Final preliminaries for event generation: Set up decay trees, prepare each -process, and open files. -<>= - subroutine simulation_prepare_event_generation (sim, verbose) - type(simulation_t), intent(inout), target :: sim - logical, intent(in), optional :: verbose - integer :: proc - logical :: ok, verb - type(process_t), pointer :: process - verb = .false.; if (present (verbose)) verb = verbose - if (sim%allow_decays) allocate (sim%decay_tree (sim%n_proc)) - do proc = 1, sim%n_proc - process => sim%prc_array(proc)%ptr - call process_setup_event_generation (process) - if (sim%allow_decays) & - call decay_tree_init (sim%decay_tree(proc), process) - end do - call event_file_list_open (sim%event_file_list, sim%process_id, & - sim%n_events, sim%var_list) - if (sim%read_raw) then - call open_raw_event_file_for_reading & - (sim%file_raw, sim%rescan, sim%check_event_file, sim%md5sum, & - sim%version, sim%u_raw, ok, verbose) - if (.not. ok) sim%read_raw = .false. - else if (sim%read_hepmc) then - call input_event_stream_init & - (sim%input_stream, sim%file_hepmc, FMT_HEPMC) - else - if (verb) then - write (msg_buffer, "(A,I0,A)") & - "Generating ", sim%n_events, " events ..." - call msg_message - end if - end if - if (.not. sim%read_raw) then - if (sim%write_raw) then - call open_raw_event_file_for_writing & - (sim%file_raw, sim%md5sum, sim%version, sim%u_raw, verbose) - end if - end if - call checkpointing_init (sim%checkpointing, sim%var_list) - sim%n_read = 0 - sim%i_evt = 0 - sim%n_selected = 0 - end subroutine simulation_prepare_event_generation - -@ %def simulation_prepare_event_generation -@ Initialize a selection expression. This establishes a pointer-target -relation between the selection expression, the subevent, and certain -variables. - -This is public, since the analysis is a separate object. -<>= - public :: simulation_setup_selection -<>= - subroutine simulation_setup_selection (sim, pn_selection_lexpr, verbose) - type(simulation_t), intent(inout), target :: sim - type(parse_node_t), pointer :: pn_selection_lexpr - logical, intent(in), optional :: verbose - logical :: verb - verb = .false.; if (present (verbose)) verb = verbose - if (verb) then - if (associated (pn_selection_lexpr)) then - call msg_message ("Applying user-defined selection expression.") - end if - end if - if (associated (pn_selection_lexpr)) then - sim%user_selection = .true. - call eval_tree_init_lexpr (sim%selection_expr, & - pn_selection_lexpr, sim%var_list, sim%subevt, & - sim%event_vars) - else - sim%user_selection = .false. - end if - end subroutine simulation_setup_selection - -@ %def simulation_setup_selection -@ Initialize a reweighting expression. This establishes a pointer-target -relation between the reweighting expression, the subevent, and certain -variables. - -This is public, since the analysis is a separate object. -<>= - public :: simulation_setup_reweight -<>= - subroutine simulation_setup_reweight (sim, pn_reweight_expr, verbose) - type(simulation_t), intent(inout), target :: sim - type(parse_node_t), pointer :: pn_reweight_expr - logical, intent(in), optional :: verbose - logical :: verb - verb = .false.; if (present (verbose)) verb = verbose - if (verb) then - if (associated (pn_reweight_expr)) then - call msg_message ("Applying user-defined reweighting expression.") - end if - end if - if (associated (pn_reweight_expr)) then - call eval_tree_init_expr (sim%reweight_expr, & - pn_reweight_expr, sim%var_list, sim%subevt, & - sim%event_vars) - end if - end subroutine simulation_setup_reweight - -@ %def simulation_setup_reweight -@ Initialize the analysis expression. This establishes a pointer-target -relation between the analysis expression, the subevent, and certain -variables. - -This is public, since the analysis is a separate object. -<>= - public :: simulation_setup_analysis -<>= - subroutine simulation_setup_analysis (sim, pn_analysis_lexpr, verbose) - type(simulation_t), intent(inout), target :: sim - type(parse_node_t), pointer :: pn_analysis_lexpr - logical, intent(in), optional :: verbose - logical :: verb - verb = .false.; if (present (verbose)) verb = verbose - if (verb) then - if (associated (pn_analysis_lexpr)) then - call msg_message ("Applying user-defined analysis setup.") - else - call msg_message ("No analysis setup has been provided.") - end if - end if - if (associated (pn_analysis_lexpr)) then - call eval_tree_init_lexpr (sim%analysis_expr, & - pn_analysis_lexpr, sim%var_list, sim%subevt, & - sim%event_vars) - end if - end subroutine simulation_setup_analysis - -@ %def simulation_setup_analysis -@ -\subsubsection{Generating one event} -Read an event from the 'raw' event file. If EOF is reached, close it, reset -the [[read_raw]] flag, and reopen it for writing if [[write_raw]] is set. - -When reopening the raw event file, we have do re-do some process -initialization that may got lost when reading events from file before. - -This initializes the event object, if successful. -<>= - subroutine simulation_read_event_raw (sim, ok, verbose) - type(simulation_t), intent(inout), target :: sim - logical, intent(out) :: ok - logical, intent(in), optional :: verbose - logical :: verb - integer :: iostat - verb = .false.; if (present (verbose)) verb = verbose - if (sim%use_num_id) then - call event_read_raw (sim%event, sim%u_raw, & - sim%event_vars, sim%prc_array, num_id_array=sim%num_id, & - iostat=iostat, version=sim%version) - else - call event_read_raw (sim%event, sim%u_raw, & - sim%event_vars, sim%prc_array, iostat=iostat, version=sim%version) - end if - if (iostat == 0) then - sim%i_evt = sim%i_evt + 1 - sim%n_read = sim%n_read + 1 - ok = .true. - else - ok = .false. - if (verb) then - write (msg_buffer, "(A,1x,I0,1x,A)") & - "...", sim%n_read, "events read." - call msg_message () - end if - if (.not. sim%rescan) then - sim%read_raw = .false. - if (verb) then - write (msg_buffer, "(A,1x,I0,1x,A)") & - "Generating", sim%n_events - sim%n_read, " events ..." - call msg_message () - end if - if (sim%write_raw) then - call reopen_raw_event_file_for_writing & - (sim%file_raw, sim%u_raw, verbose) - else - close (sim%u_raw) - end if - ok = .true. - call reinitialize_processes (sim%prc_array) - end if - end if - end subroutine simulation_read_event_raw - -@ %def simulation_read_event_raw -@ For all processes in the current simulation, redo the initialization of the -subevent that is used for cuts etc. This subevent may be corrupted by -previous events read from file. -<>= - subroutine reinitialize_processes (prc_array) - type(process_p), dimension(:), intent(in) :: prc_array - type(process_t), pointer :: process - integer :: i - do i = 1, size (prc_array) - process => prc_array(i)%ptr - call process_setup_subevt (process) - end do - end subroutine reinitialize_processes - -@ %def reinitialize_processes -@ Read an event from a HepMC file. -<>= - subroutine simulation_read_event_hepmc (sim, ok) - type(simulation_t), intent(inout), target :: sim - logical, intent(out) :: ok - if (sim%use_num_id) then - call input_event_stream_read_event (sim%input_stream, sim%event, & - sim%event_vars, sim%prc_array, ok, num_id_array=sim%num_id) - else - call input_event_stream_read_event (sim%input_stream, sim%event, & - sim%event_vars, sim%prc_array, ok) - end if - end subroutine simulation_read_event_hepmc - -@ %def simulation_read_event_hepmc -@ Select a random process for the current event, based on the relative sizes -of the process integrals. -<>= - subroutine simulation_select_process (sim, rng, process, proc) - type(simulation_t), intent(in) :: sim - type(tao_random_state), intent(inout) :: rng - type(process_t), pointer :: process - integer, intent(out) :: proc - real(default) :: integral_cmp, x - call tao_random_number (rng, x) - integral_cmp = 0 - do proc = 1, sim%n_proc - integral_cmp = integral_cmp + sim%integral(proc) - if (integral_cmp > x * sim%integral_sum) exit - end do - proc = min (proc, sim%n_proc) - process => sim%prc_array(proc)%ptr - end subroutine simulation_select_process - -@ %def simulation_select_process -@ Recover the process for the current event, which should be filled already. -<>= - subroutine simulation_recover_process (sim, proc) - type(simulation_t), intent(inout) :: sim - integer, intent(out) :: proc - type(string_t) :: process_id - type(process_t), pointer :: process - process => event_get_process_ptr (sim%event) - if (associated (process)) then - process_id = process_get_id (process) - do proc = 1, sim%n_proc - if (process_id == process_get_id (sim%prc_array(proc)%ptr)) then - call event_recover_process (sim%event) - return - end if - end do - end if - call event_write (sim%event) - call msg_fatal ("Simulation: recovering process data from event failed.") - proc = 0 - end subroutine simulation_recover_process - -@ %def simulation_recover_process -@ Recalculate the matrix element for the process, refreshing the model -parameters and, if required, the scale and $\alpha_s$ values. -<>= - subroutine simulation_recalculate (sim) - type(simulation_t), intent(inout) :: sim - if (sim%update_parameters) call event_update_parameters (sim%event) - if (sim%update_scale) call event_compute_scale (sim%event) - if (sim%update_alpha_s) call event_update_alpha_s (sim%event) - if (sim%update_sqme) call event_compute_sqme (sim%event) - if (sim%update_weight) call event_update_weight (sim%event) - end subroutine simulation_recalculate - -@ %def simulation_recalculate -@ Generate a new event for the selected process. This initializes the event -object. We reject invalid events until a valid event could be produced. -<>= - integer, parameter, public :: MAX_TRIES_FOR_SINGLE_EVENT = 100000 -@ %def MAX_TRIES_FOR_SINGLE_EVENT -<>= - subroutine simulation_generate_event (sim, rng, process, proc, os_data) - type(simulation_t), intent(inout), target :: sim - type(tao_random_state), intent(inout) :: rng - type(process_t), intent(in), target :: process - integer, intent(in) :: proc - type(os_data_t), intent(in) :: os_data - integer :: factorization_mode, try - if (sim%allow_decays) then - call event_init (sim%event, process, & - sim%event_vars, sim%decay_tree(proc)) - else - call event_init (sim%event, process, sim%event_vars) - end if - if (sim%use_num_id) then - sim%event_vars%process_num_id = sim%num_id(proc) - else - sim%event_vars%process_num_id = proc - end if - sim%event_vars%process_id = process_get_id (process) - if (sim%spar%polarized) then - factorization_mode = FM_SELECT_HELICITY - else - factorization_mode = FM_IGNORE_HELICITY - end if - GENERATE: do try = 1, MAX_TRIES_FOR_SINGLE_EVENT - call event_generate & - (sim%event, rng, sim%spar%unweighted, & - factorization_mode, & - keep_correlations=.false., & - keep_virtual=.true., os_data=os_data, & - shower_settings = sim%spar%shower_settings) - if(event_is_vetoed(sim%event).and. & - (.not.sim%n_events_set)) then - sim%n_events = sim%n_events - 1 - if(sim%i_evt .ge. sim%n_events) then - call event_final(sim%event) - return - end if - end if - if (event_is_valid (sim%event).and. & - (.not.event_is_vetoed(sim%event))) exit GENERATE - end do GENERATE - if (.not. event_is_valid (sim%event)) then - write (msg_buffer, "(A,I0,A)") "Failed to generate a valid event " & - // "after ", MAX_TRIES_FOR_SINGLE_EVENT, " tries" - call msg_fatal () - end if - sim%i_evt = sim%i_evt + 1 - sim%event_vars%process_index = proc - sim%event_vars%event_index = sim%i_evt - call event_renormalize_weight (sim%event, sim%norm_weight) - end subroutine simulation_generate_event - -@ %def simulation_generate_event -@ Explicitly apply decays to an existing event. (Implicitly called by the -previous procedure.) -<>= - subroutine simulation_decay (sim, rng, proc) - type(simulation_t), intent(inout), target :: sim - type(tao_random_state), intent(inout) :: rng - integer, intent(in) :: proc - if (sim%allow_decays) then - call event_decay (sim%event, rng, sim%decay_tree(proc)) - call event_factorize_process (sim%event, rng, & - FM_IGNORE_HELICITY, & - keep_correlations=.false., & - keep_virtual=.true.) - end if - end subroutine simulation_decay - -@ %def simulation_decay -@ Further process an event. This implies analysis and output. Events -which fail extra selection cuts (if any) are neither analyzed nor written -to file, but they count for the total number of generated events. However, -the raw event file will contain the rejected events. - -Writing to raw event file is appropriate only if reading from this file is -disabled or has terminated. -<>= - subroutine simulation_handle_event (sim) - type(simulation_t), intent(inout), target :: sim - if (event_passes_selection (sim%event, sim%subevt, sim%selection_expr)) & - then - sim%n_selected = sim%n_selected + 1 - call event_reweight (sim%event, sim%subevt, sim%reweight_expr) - call event_do_analysis (sim%event, sim%subevt, sim%analysis_expr) - call event_file_list_write_event & - (sim%event_file_list, sim%event, sim%integral_sum, sim%error_sum, & - sim%analysis_expr, i_evt=sim%i_evt) - end if - if (sim%write_raw .and. .not. sim%read_raw) & - call event_write_raw (sim%event, sim%u_raw, sim%version) - call checkpointing_msg_event & - (sim%checkpointing, sim%n_events, sim%n_read, sim%i_evt) - end subroutine simulation_handle_event - -@ %def simulation_handle_event -@ Finalize the event. -<>= - subroutine simulation_final_event (sim) - type(simulation_t), intent(inout), target :: sim - call event_final (sim%event) - end subroutine simulation_final_event - -@ %def simulation_final_event -@ -\subsubsection{Wrapup} -Close open files and delete the decay tree and analysis expression: -<>= - subroutine simulation_finish_event_generation (sim, verbose) - type(simulation_t), intent(inout) :: sim - logical, intent(in), optional :: verbose - integer :: proc - logical :: verb - verb = .false.; if (present (verbose)) verb = verbose - call checkpointing_msg_end & - (sim%checkpointing, sim%n_read, sim%i_evt) - call event_file_list_close (sim%event_file_list) - if (sim%read_raw .or. sim%write_raw) close (sim%u_raw) - if (sim%read_hepmc) call input_event_stream_final (sim%input_stream) - if (sim%allow_decays) then - do proc = 1, sim%n_proc - call decay_tree_final (sim%decay_tree(proc)) - end do - end if - call eval_tree_final (sim%analysis_expr) - if (verb) then - if (sim%rescan) then - call msg_selection (sim%user_selection, sim%n_selected) - call msg_message ("Rescanning finished.") - else - if (sim%read_raw) then - write (msg_buffer, "(A,1x,I0,1x,A,1x,I0,1x,A)") & - "...", sim%n_read, "events read,", sim%n_events, "total." - call msg_message () - else - write (msg_buffer, "(A,1x,I0,1x,A,1x,I0,1x,A)") & - "...", sim%n_events - sim%n_read, "events generated.", & - sim%n_events, "total." - call msg_message () - end if - call msg_selection (sim%user_selection, sim%n_selected) - call msg_message ("Simulation finished.") - end if - end if - contains - subroutine msg_selection (user_selection, n_selected) - logical, intent(in) :: user_selection - integer, intent(in) :: n_selected - if (user_selection) then - write (msg_buffer, "(A,1x,I0)") & - "Events passing selection cuts:", n_selected - call msg_message () - end if - end subroutine msg_selection - end subroutine simulation_finish_event_generation - -@ %def subroutine simulation_finish_event_generation -@ Deallocate extra memory where necessary -<>= - subroutine simulation_basic_final (sim) - type(simulation_t), intent(inout) :: sim - call var_list_final (sim%var_list) - end subroutine simulation_basic_final - -@ %def simulation_basic_final -@ -\subsubsection{Dealing with the event file} -Open a raw event file for reading, check the header and validity. If -[[rescan]] is set, check only processes and simulation parameters, otherwise -check everything. -<>= - subroutine open_raw_event_file_for_reading & - (file_raw, rescan, check, md5sum, version, u_raw, ok, verbose) - type(string_t), intent(in) :: file_raw - logical, intent(in) :: rescan, check - type(md5sum_events_t), intent(in) :: md5sum - integer, intent(in) :: version - integer, intent(out) :: u_raw - logical, intent(out) :: ok - logical, intent(in), optional :: verbose - logical :: verb - integer :: iostat - verb = .false.; if (present (verbose)) verb = verbose - if (.not. check) call msg_warning & - ("Validity checks turned off for event file '" & - // char (file_raw) // "'") - inquire (file = char (file_raw), exist = ok) - if (check .and. ok) then - ok = event_file_get_format (file_raw) == FMT_RAW - if (.not. ok) then - call msg_warning ("File '" // char (file_raw) & - // "' is not a WHIZARD raw event file, discarding.") - end if - end if - if (ok) then - if (verb) call msg_message ("Reading events from file '" & - // char (file_raw) // "' ...") - u_raw = free_unit () - open (file = char (file_raw), unit = u_raw, form = "unformatted", & - action = "read", status = "old") - call raw_event_file_read_header & - (u_raw, rescan, check, md5sum, version, ok, iostat) - if (iostat /= 0) then - call msg_error ("Event file '" & - // char (file_raw) // "' is corrupt, discarding.") - close (u_raw) - ok = .false. - else if (.not. ok) then - close (u_raw) - ok = .false. - else - ok = .true. - end if - end if - end subroutine open_raw_event_file_for_reading - -@ %def open_raw_event_file_for_reading -@ Open a raw event file for writing, write header. If [[append]] is set, close -the existing file and reopen it for appending more events. -<>= - subroutine open_raw_event_file_for_writing & - (file_raw, md5sum, version, u_raw, verbose) - type(string_t), intent(in) :: file_raw - type(md5sum_events_t), intent(in) :: md5sum - integer, intent(in) :: version - integer, intent(out) :: u_raw - logical, intent(in), optional :: verbose - logical :: verb - verb = .false.; if (present (verbose)) verb = verbose - if (verb) then - call msg_message ("Writing events in internal format to file '" & - // char (file_raw) // "'") - end if - u_raw = free_unit () - open (file = char (file_raw), unit = u_raw, form = "unformatted", & - action = "write", status = "replace") - call raw_event_file_write_header (u_raw, md5sum, version) - end subroutine open_raw_event_file_for_writing - -@ %def open_raw_event_file_for_writing -@ Reopen a raw event file for writing, no header. Append new events to the -end. -<>= - subroutine reopen_raw_event_file_for_writing (file_raw, u_raw, verbose) - type(string_t), intent(in) :: file_raw - integer, intent(in) :: u_raw - logical, intent(in), optional :: verbose - logical :: verb - verb = .false.; if (present (verbose)) verb = verbose - if (verb) then - call msg_message ("Appending events in internal format to file '" & - // char (file_raw) // "'") - end if - close (u_raw) - open (file = char (file_raw), unit = u_raw, form = "unformatted", & - action = "write", status = "old", position = "append") - end subroutine reopen_raw_event_file_for_writing - -@ %def reopen_raw_event_file_for_writing -@ -\subsubsection{API for simulation objects} -This initializer does everything, except assigning the analysis expression. -If [[ok]] is false, initialization failed and the simulation should be -skipped. - -If [[filename]] is provided, this is not a simulation but rescanning an event -file. - -The [[global_var_list]] is the one where missing integrals are inserted, if -they are computed here. It is not necessarily the one within the [[global]] -object. -<>= - public :: simulation_init -<>= - subroutine simulation_init & - (sim, process_id, global, global_var_list, ok, filename, verbose) - type(simulation_t), intent(out) :: sim - type(string_t), dimension(:), intent(in) :: process_id - type(rt_data_t), intent(inout), target :: global - type(var_list_t), intent(inout) :: global_var_list - logical, intent(out) :: ok - type(string_t), intent(in), optional :: filename - logical, intent(in), optional :: verbose - type(string_t) :: basename_default - logical :: rescan - rescan = present (filename) - if (size (process_id) /= 0) then - basename_default = process_id(1) - else - basename_default = "whizard" - end if - if (rescan) then - call simulation_init_rescan & - (sim, filename, process_id, global%var_list, verbose) - else - call simulation_basic_init & - (sim, process_id, global%var_list, verbose=verbose) - end if - call simulation_compute_missing_integrals & - (sim, global, global_var_list, rescan, verbose) - if (sim%spar%use_best_grid) call simulation_choose_best_grids (sim) - call simulation_check (sim, ok) - if (ok .and. .not. rescan) then - call simulation_collect_integrals (sim, global%var_list, ok) - end if - if (ok) then - call simulation_setup_event_file_list & - (sim, global%event_fmt, basename_default) - call simulation_collect_md5sums (sim) - call simulation_setup_n_events (sim, verbose) - call simulation_prepare_event_generation (sim, verbose) - end if - if (.not. ok) call simulation_basic_final (sim) - end subroutine simulation_init - -@ %def simulation_init -@ Return the number of events determined during initialization. -<>= - public :: simulation_get_n_events -<>= - function simulation_get_n_events (sim) result (n_events) - integer :: n_events - type(simulation_t), intent(in) :: sim - n_events = sim%n_events - end function simulation_get_n_events - -@ %def simulation_get_n_events -@ Return the number of events simulated so far. -<>= - public :: simulation_get_i_evt -<>= - function simulation_get_i_evt (sim) result (i_evt) - integer :: i_evt - type(simulation_t), intent(in) :: sim - i_evt = sim%i_evt - end function simulation_get_i_evt - -@ %def simulation_get_n_events -@ Get and handle a new event. Either read it from file or generate it. If -reading fails and we are allowed to generate new events, [[read_raw]] is -reset, so we need a separate check. -<>= - public :: simulation_event -<>= - subroutine simulation_event (sim, rng, ok, os_data, verbose) - type(simulation_t), intent(inout), target :: sim - type(tao_random_state), intent(inout) :: rng - logical, intent(out) :: ok - type(os_data_t), intent(in) :: os_data - logical, intent(in), optional :: verbose - type(process_t), pointer :: process - integer :: proc - if (sim%read_raw) then - call simulation_read_event_raw (sim, ok, verbose) - else if (sim%read_hepmc) then - call simulation_read_event_hepmc (sim, ok) - end if - if (sim%rescan) then - if (.not. ok) return - call simulation_recover_process (sim, proc) - call simulation_recalculate (sim) - call simulation_decay (sim, rng, proc) - else if (.not. sim%read_raw) then - if (sim%checkpointing%active .and. (.not. sim%checkpointing%running)) & - call checkpointing_msg_start (sim%checkpointing, sim%n_events, & - sim%i_evt) - call simulation_select_process (sim, rng, process, proc) - call simulation_generate_event (sim, rng, process, proc, os_data) - end if - call simulation_handle_event (sim) - call simulation_final_event (sim) - end subroutine simulation_event - -@ %def simulation_event -@ Finalize simulation and the simulation object. -<>= - public :: simulation_final -<>= - subroutine simulation_final (sim, verbose) - type(simulation_t), intent(inout) :: sim - logical, intent(in), optional :: verbose - call simulation_finish_event_generation (sim, verbose) - call simulation_basic_final (sim) - end subroutine simulation_final - -@ %def simulation_final -@ -<>= - subroutine strfun_pair_compile (strfun_pair, pn_strfun_pair, global) - type(strfun_pair_t), intent(out) :: strfun_pair - type(parse_node_t), intent(in), target :: pn_strfun_pair - type(rt_data_t), intent(in), target :: global - type(parse_node_t), pointer :: pn_strfun_def - integer :: i - strfun_pair%n = parse_node_get_n_sub (pn_strfun_pair) - pn_strfun_def => parse_node_get_sub_ptr (pn_strfun_pair) - do i = 1, strfun_pair%n - call strfun_def_compile (strfun_pair%def(i), pn_strfun_def, global) - pn_strfun_def => parse_node_get_next_ptr (pn_strfun_def) - end do - end subroutine strfun_pair_compile - - subroutine strfun_def_compile (strfun_def, pn_strfun_def, global) - type(strfun_def_t), intent(out) :: strfun_def - type(parse_node_t), intent(in), target :: pn_strfun_def - type(rt_data_t), intent(in), target :: global - type(parse_node_t), pointer :: pn_key, pn_opt, pn_arg - pn_key => parse_node_get_sub_ptr (pn_strfun_def) - pn_opt => parse_node_get_next_ptr (pn_key) - select case (char (parse_node_get_rule_key (pn_key))) - case ("none") - strfun_def%type = STRF_NONE - case ("lhapdf") - strfun_def%type = STRF_LHAPDF - case ("pdf_builtin") - strfun_def%type = STRF_PDF_BUILTIN - case ("isr") - strfun_def%type = STRF_ISR - case ("epa") - strfun_def%type = STRF_EPA - case ("ewa") - strfun_def%type = STRF_EWA - case ("circe1") - strfun_def%type = STRF_CIRCE1 - case ("circe2") - strfun_def%type = STRF_CIRCE2 - case ("energy_scan") - strfun_def%type = STRF_ESCAN - case ("beam_events") - strfun_def%type = STRF_BEVT - case ("user_sf_spec") - strfun_def%type = STRF_USER - pn_arg => parse_node_get_sub_ptr (pn_key, 2) - strfun_def%pn_user_name => parse_node_get_sub_ptr (pn_arg) - end select - call rt_data_local_init (strfun_def%local, global) - if (associated (pn_opt)) then - allocate (strfun_def%options) - call command_list_compile & - (strfun_def%options, pn_opt, strfun_def%local) - end if - call rt_data_local_reset (strfun_def%local) - end subroutine strfun_def_compile - -@ %def strfun_pair_compile strfun_def_compile -@ For user structure functions, it is not evident whether they apply -to single beams or to the beam pair, before the data set has been -initialized. Therefore, we have to shortcut the scan over the two -beams if we encounter a structure function that applies to the beam -pair. -<>= - subroutine sf_list_register_user (sf_list, affects_beam, & - model, flv, user_name, var_list) - type(sf_list_t), intent(inout) :: sf_list - logical, dimension(2), intent(in) :: affects_beam - type(model_t), intent(in), target :: model - type(flavor_t), dimension(2), intent(in) :: flv - type(string_t), intent(in) :: user_name - type(var_list_t), intent(in) :: var_list - type(sf_data_t), pointer :: sf_data - logical :: user_strfun_mapping - real(default) :: user_strfun_mapping_power - integer :: i - do i = 1, 2 - if (affects_beam(i)) then - allocate (sf_data) - call sf_data_init_user (sf_data, i, flv, user_name, model) - call sf_list_append (sf_list, sf_data) - if (all (sf_data_affects_beam (sf_data))) then - if (.not. all (affects_beam)) call msg_fatal & - ("User spectrum/structure function inconsistently applied") - exit - end if - end if - end do - user_strfun_mapping = & - var_list_get_lval (var_list, var_str ("?user_strfun_mapping")) - user_strfun_mapping_power = & - var_list_get_rval (var_list, var_str ("user_strfun_mapping_power")) - if (all (affects_beam) .and. user_strfun_mapping) then - if (all (sf_data_affects_beam (sf_data))) then - call sf_data_setup_mapping & - (sf_data, SFM_PAIR, & - (/ sf_data_get_n_parameters (sf_data) - 1, & - sf_data_get_n_parameters (sf_data) /), & - user_strfun_mapping_power) - else - call sf_data_setup_mapping & - (sf_data, SFM_PAIR, & - (/ 0, sf_data_get_n_parameters (sf_data) /), & - user_strfun_mapping_power) - end if - end if - ! No pair mapping - end subroutine sf_list_register_user - -@ %def sf_list_register_beam_events -@ -<>= - !! !! subroutine interaction_apply_lhapdf (int, scale, x, f, s, lhapdf_data) - !! !! type(interaction_t), intent(inout) :: int - !! !! real(default), intent(in) :: scale, x, f, s - !! !! type(lhapdf_data_t), intent(in) :: lhapdf_data - !! !! double precision :: xx, qq, ss - !! !! double precision, dimension(-6:6) :: ff - !! !! double precision :: fphot - !! !! complex(default), dimension(:), allocatable :: fc - !! !! external :: evolvePDFM, evolvePDFpM - !! !! xx = x - !! !! qq = min (lhapdf_data% qmax, scale) - !! !! qq = max (lhapdf_data% qmin, qq) - !! !! if (.not. lhapdf_data% photon) then - !! !! if (lhapdf_data% invert) then - !! !! if (lhapdf_data%has_photon) then - !! !! call evolvePDFphotonM (lhapdf_data% set, xx, qq, ff(6:-6:-1), fphot) - !! !! else - !! !! call evolvePDFM (lhapdf_data% set, xx, qq, ff(6:-6:-1)) - !! !! end if - !! !! else - !! !! if (lhapdf_data%has_photon) then - !! !! call evolvePDFphotonM (lhapdf_data% set, xx, qq, ff, fphot) - !! !! else - !! !! call evolvePDFM (lhapdf_data% set, xx, qq, ff) - !! !! end if - !! !! end if - !! !! else - !! !! ss = s - !! !! call evolvePDFpM (lhapdf_data% set, xx, qq, & - !! !! ss, lhapdf_data% photon_scheme, ff) - !! !! end if - !! !! if (lhapdf_data%has_photon) then - !! !! allocate (fc (count ((/lhapdf_data%mask, lhapdf_data%mask_photon/)))) - !! !! fc = max (pack ((/ff, fphot/) / x, & - !! !! (/lhapdf_data% mask, lhapdf_data%mask_photon/)) * f, 0._default) - !! !! else - !! !! allocate (fc (count (lhapdf_data%mask))) - !! !! fc = max (pack (ff / x, lhapdf_data%mask) * f, 0._default) - !! !! end if - !! !! call interaction_set_matrix_element (int, fc) - !! !! end subroutine interaction_apply_lhapdf - -@ %def interaction_apply_lhapdf - -\subsubsection{Beam polarization} -We define an assortment of containers for the options of the different beam -polarization constructors. -<>= - type :: bp_circ_data_t - private - type(parse_node_t), pointer :: pn_fraction => null () - real(default) :: fraction - end type bp_circ_data_t - - type :: bp_trans_data_t - private - type(parse_node_t), pointer :: pn_fraction => null () - type(parse_node_t), pointer :: pn_phi => null () - real(default) :: fraction, phi - end type bp_trans_data_t - - type :: bp_long_data_t - private - type(parse_node_t), pointer :: pn_fraction => null () - real(default) :: fraction - end type bp_long_data_t - - type :: bp_axis_data_t - private - type(parse_node_t), pointer :: pn_fraction => null () - type(parse_node_t), pointer :: pn_theta => null () - type(parse_node_t), pointer :: pn_phi => null () - real(default) :: fraction, theta, phi - end type bp_axis_data_t - - type :: bp_diag_data_t - private - type(parse_node_p), dimension(:), allocatable :: pn_hel - type(parse_node_p), dimension(:), allocatable :: pn_fraction - integer, dimension(:), allocatable :: hel - real(default), dimension(:), allocatable :: fraction - end type bp_diag_data_t - - type :: bp_density_data_t - private - type(parse_node_t), pointer :: pn_d => null () - type(parse_node_t), pointer :: pn_nd => null () - real(default) :: d - complex(default) :: nd - end type bp_density_data_t - -@ %def bp_circ_data_t -@ %def bp_trans_data_t -@ %def bp_long_data_t -@ %def bp_axis_data_t -@ %def bp_diag_data_t -@ %def bp_density_data_t -@ The actual scratch container for the command. A negative [[n]] means the -structure is invalid, and a negative [[type]] tells the execution subprogram to -disable beam polarization altogether. -<>= - type :: cmd_beam_polarization_t - private - integer :: n = -1 - integer, dimension(2) :: type = -1 - type(bp_circ_data_t), dimension(:), pointer :: circ_data => null () - type(bp_trans_data_t), dimension(:), pointer :: trans_data => null () - type(bp_long_data_t), dimension(:), pointer :: long_data => null () - type(bp_axis_data_t), dimension(:), pointer :: axis_data => null () - type(bp_diag_data_t), dimension(:), pointer :: diag_data => null () - type(bp_density_data_t), dimension(:), pointer :: & - density_data => null () - type(command_list_t), pointer :: options => null () - type(rt_data_t) :: local - type(beam_polarization_t), dimension(:), pointer :: & - beam_polarization => null () - end type cmd_beam_polarization_t - -@ %def cmd_beam_polarization_t -@ Finalize the container. We define a separate finalizer for each subcontainer. -<>= - elemental subroutine bp_circ_data_final (d) - type(bp_circ_data_t), intent(inout) :: d - end subroutine bp_circ_data_final - - elemental subroutine bp_trans_data_final (d) - type(bp_trans_data_t), intent(inout) :: d - end subroutine bp_trans_data_final - - elemental subroutine bp_long_data_final (d) - type(bp_long_data_t), intent(inout) :: d - end subroutine bp_long_data_final - - elemental subroutine bp_axis_data_final (d) - type(bp_axis_data_t), intent(inout) :: d - end subroutine bp_axis_data_final - - elemental subroutine bp_diag_data_final (d) - type(bp_diag_data_t), intent(inout) :: d - deallocate (d%pn_hel) - deallocate (d%pn_fraction) - if (allocated (d%hel)) deallocate (d%hel) - if (allocated (d%fraction)) deallocate (d%fraction) - end subroutine bp_diag_data_final - - elemental subroutine bp_density_data_final (d) - type(bp_density_data_t), intent(inout) :: d - end subroutine bp_density_data_final - - subroutine cmd_beam_polarization_final (bp) - type(cmd_beam_polarization_t), intent(inout) :: bp - if (associated (bp%circ_data)) then - call bp_circ_data_final (bp%circ_data) - deallocate (bp%circ_data) - end if - if (associated (bp%trans_data)) then - call bp_trans_data_final (bp%trans_data) - deallocate (bp%trans_data) - end if - if (associated (bp%long_data)) then - call bp_long_data_final (bp%long_data) - deallocate (bp%long_data) - end if - if (associated (bp%axis_data)) then - call bp_axis_data_final (bp%axis_data) - deallocate (bp%axis_data) - end if - if (associated (bp%diag_data)) then - call bp_diag_data_final (bp%diag_data) - deallocate (bp%diag_data) - end if - if (associated (bp%density_data)) then - call bp_density_data_final (bp%density_data) - deallocate (bp%density_data) - end if - if (associated (bp%options)) then - call command_list_final (bp%options) - deallocate (bp%options) - end if - if (associated (bp%beam_polarization)) deallocate (bp%beam_polarization) - bp%type = -1 - bp%n = -1 - end subroutine cmd_beam_polarization_final - -@ %def bp_circ_data_final -@ %def bp_trans_data_final -@ %def bp_long_data_final -@ %def bp_axis_data_final -@ %def bp_diag_data_final -@ %def bp_density_data_final -@ %def cmd_beam_polarization_final -@ Compile. -<>= - subroutine cmd_beam_polarization_compile (bp, pn, global) - type(cmd_beam_polarization_t), pointer, intent(inout) :: bp - type(parse_node_t), intent(in), target :: pn - type(rt_data_t), intent(in), target :: global - type(parse_node_t), pointer :: pn_list, pn_opts, pn_args, pn_entry - integer :: i, n - pn_list => parse_node_get_sub_ptr (pn, 3) - pn_opts => parse_node_get_sub_ptr (pn, 4) - allocate (bp) - call rt_data_local_init (bp%local, global) - if (associated (pn_opts)) then - allocate (bp%options) - call command_list_compile (bp%options, pn_opts, bp%local) - end if - if (parse_node_get_rule_key (pn_list) == "off") then - bp%n = 0 - bp%type = -1 - return - end if - bp%n = parse_node_get_n_sub (pn_list) - pn_list => parse_node_get_sub_ptr (pn_list) - do i = 1, bp%n - pn_args => parse_node_get_sub_ptr (pn_list, 2) - select case (char (parse_node_get_rule_key (pn_list))) - case ("none") - bp%type(i) = BP_NONE - case ("bp_circ") - if (parse_node_get_n_sub (pn_args) /= 1) then - call cmd_beam_polarization_final (bp) - call msg_fatal & - ("syntax error: expecting 'circular (fraction)'") - return - end if - bp%type(i) = BP_CIRC - if (.not. associated (bp%circ_data)) & - allocate (bp%circ_data(2)) - bp%circ_data(i)%pn_fraction => parse_node_get_sub_ptr (pn_args, 1) - case ("bp_trans") - if (parse_node_get_n_sub (pn_args) /= 2) then - call cmd_beam_polarization_final (bp) - call msg_fatal & - ("syntax error: expecting transverse (fraction, phi)'") - return - end if - bp%type(i) = BP_TRANS - if (.not. associated (bp%trans_data)) & - allocate (bp%trans_data(2)) - bp%trans_data(i)%pn_fraction => parse_node_get_sub_ptr (pn_args, 1) - bp%trans_data(i)%pn_phi => parse_node_get_sub_ptr (pn_args, 2) - case ("bp_axis") - if (parse_node_get_n_sub (pn_args) /= 3) then - call cmd_beam_polarization_final (bp) - call msg_fatal & - ("syntax error: expecting 'axis (fraction, theta, phi)'") - return - end if - bp%type(i) = BP_AXIS - if (.not. associated (bp%axis_data)) & - allocate (bp%axis_data(2)) - bp%axis_data(i)%pn_fraction => parse_node_get_sub_ptr (pn_args, 1) - bp%axis_data(i)%pn_theta => parse_node_get_sub_ptr (pn_args, 2) - bp%axis_data(i)%pn_phi => parse_node_get_sub_ptr (pn_args, 3) - case ("bp_long") - if (parse_node_get_n_sub (pn_args) /= 1) then - call cmd_beam_polarization_final (bp) - call msg_fatal & - ("syntax error: expecting 'longitudinal (fraction)'") - return - end if - bp%type(i) = BP_LONG - if (.not. associated (bp%long_data)) & - allocate (bp%long_data(2)) - bp%long_data(i)%pn_fraction => parse_node_get_sub_ptr (pn_args, 1) - case ("bp_dens") - if (parse_node_get_n_sub (pn_args) /= 2) then - call cmd_beam_polarization_final (bp) - call msg_fatal & - ("syntax error: expecting 'density_matrix (a, b)'") - return - end if - bp%type(i) = BP_DENSITY - if (.not. associated (bp%density_data)) & - allocate (bp%density_data (2)) - bp%density_data(i)%pn_d => parse_node_get_sub_ptr (pn_args, 1) - bp%density_data(i)%pn_nd => parse_node_get_sub_ptr (pn_args, 2) - case ("bp_diag") - bp%type(i) = BP_DIAG - n = parse_node_get_n_sub (pn_args) - if (.not. associated (bp%diag_data)) & - allocate (bp%diag_data(2)) - allocate (bp%diag_data(i)%pn_hel (n)) - allocate (bp%diag_data(i)%pn_fraction (n)) - allocate (bp%diag_data(i)%hel (n)) - allocate (bp%diag_data(i)%fraction (n)) - pn_entry => parse_node_get_sub_ptr (pn_args) - n = 1 - do while (associated (pn_entry)) - bp%diag_data(i)%pn_hel(n)%ptr & - => parse_node_get_sub_ptr (pn_entry, 1) - bp%diag_data(i)%pn_fraction(n)%ptr & - => parse_node_get_sub_ptr (pn_entry, 3) - pn_entry => parse_node_get_next_ptr (pn_entry) - n = n + 1 - end do - case default - call msg_bug ("cmd_beam_polarization_compile: invalid " & - // "polarization type") - end select - pn_list => parse_node_get_next_ptr (pn_list) - end do - - call rt_data_local_reset (bp%local) - end subroutine cmd_beam_polarization_compile - -@ %def cmd_beam_polarization_compile -@ Execute. -<>= - subroutine cmd_beam_polarization_execute (bp, global) - type(cmd_beam_polarization_t), pointer, intent(inout) :: bp - type(rt_data_t), intent(inout), target :: global - type(polarization_t), dimension(:), allocatable :: pol - integer :: i, j, k, ulog - ulog = logfile_unit () - call rt_data_link (bp%local, global) - if (associated (bp%options)) & - call command_list_execute (bp%options, bp%local) - if (bp%n < 0) then - call rt_data_restore (global, bp%local) - return - end if - if (bp%type(1) < 0) then - call rt_data_restore (global, bp%local) - global%beam_polarization => null () - if (beam_data_are_valid (global%beam_data)) & - call beam_data_kill_polarization (global%beam_data) - if (global%environment /= CMD_BEAMS) call msg_message & - ("beam polarization disabled") - return - end if - if (.not. associated (bp%beam_polarization)) then - allocate (bp%beam_polarization(bp%n)) - else - do i = 1, bp%n - call beam_polarization_final (bp%beam_polarization(i)) - end do - end if - do i = 1, bp%n - select case (bp%type(i)) - case (BP_NONE, BP_TRIVIAL) - if (bp%n == 2) then - call beam_polarization_init_none (bp%beam_polarization(i)) - else - call beam_polarization_init_trivial (bp%beam_polarization(i)) - end if - case (BP_CIRC) - bp%circ_data(i)%fraction = & - eval_real (bp%circ_data(i)%pn_fraction, bp%local%var_list) - call beam_polarization_init_circ (bp%beam_polarization(i), & - bp%circ_data(i)%fraction) - case (BP_TRANS) - bp%trans_data(i)%fraction = & - eval_real (bp%trans_data(i)%pn_fraction, bp%local%var_list) - bp%trans_data(i)%phi = & - eval_real (bp%trans_data(i)%pn_phi, bp%local%var_list) - call beam_polarization_init_trans (bp%beam_polarization(i), & - bp%trans_data(i)%fraction, bp%trans_data(i)%phi) - case (BP_LONG) - bp%long_data(i)%fraction = & - eval_real (bp%long_data(i)%pn_fraction, bp%local%var_list) - call beam_polarization_init_long (bp%beam_polarization(i), & - bp%long_data(i)%fraction) - case (BP_AXIS) - bp%axis_data(i)%fraction = & - eval_real (bp%axis_data(i)%pn_fraction, bp%local%var_list) - bp%axis_data(i)%theta = & - eval_real (bp%axis_data(i)%pn_theta, bp%local%var_list) - bp%axis_data(i)%phi = & - eval_real (bp%axis_data(i)%pn_phi, bp%local%var_list) - call beam_polarization_init_axis (bp%beam_polarization(i), & - bp%axis_data(i)%fraction, bp%axis_data(i)%theta, & - bp%axis_data(i)%phi) - case (BP_DENSITY) - bp%density_data(i)%d = & - eval_real (bp%density_data(i)%pn_d, bp%local%var_list) - bp%density_data(i)%nd = & - eval_cmplx (bp%density_data(i)%pn_nd, bp%local%var_list) - call beam_polarization_init_density (bp%beam_polarization (i), & - bp%density_data(i)%d, bp%density_data(i)%nd) - case (BP_DIAG) - do j = 1, size (bp%diag_data(i)%hel) - bp%diag_data(i)%hel(j) = & - eval_int (bp%diag_data(i)%pn_hel(j)%ptr, bp%local%var_list) - bp%diag_data(i)%fraction(j) = & - eval_real (bp%diag_data(i)%pn_fraction(j)%ptr, & - bp%local%var_list) - if (j > 1) then - do k = 1, j - 1 - if (bp%diag_data(i)%hel(j) == bp%diag_data(i)%hel(k)) then - call msg_error ( & - "'diagonal_density (h1:f1 [, h2:f2, ...])': " & - // "h" // int2char(j) // " and h" // int2char (k) & - // " must not be equal") - call rt_data_restore (global, bp%local) - return - end if - end do - end if - end do - call beam_polarization_init_diag (bp%beam_polarization(i), & - bp%diag_data(i)%hel, bp%diag_data(i)%fraction) - case default - call msg_bug ("cmd_beam_polarization_execute: " & - // "unknown polarization type") - end select - if (global%environment /= CMD_BEAMS) then - call msg_message & - ("polarization of incoming particle " // int2char (i) // ":") - call beam_polarization_write (bp%beam_polarization(i)) - call beam_polarization_write (bp%beam_polarization(i), ulog) - end if - end do - - call rt_data_restore (global, bp%local) - global%beam_polarization => bp%beam_polarization - if (beam_data_are_valid (global%beam_data)) then - if (beam_data_get_n_in (global%beam_data) /= bp%n) then - call msg_error ("the number of incoming particles differs " & - // "between beam and polarization setup - ignoring polarization") - else - allocate (pol (bp%n)) - do i = 1, bp%n - pol(i) = beam_polarization2polarization & - (bp%beam_polarization(i), global%beam_data%flv(i), & - decay=(bp%n == 1)) - end do - call beam_data_set_polarization (global%beam_data, pol) - end if - else - if (global%environment /= CMD_BEAMS) call msg_warning ( & - "beam_polarization only works with a beam setup") - end if - - end subroutine cmd_beam_polarization_execute - -@ %def cmd_beam_polarization_execute -@ -@ -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -\section{Beam polarization} -Beam polarization is encapsulated in a designated type und only converted into -a density matrix when the beams are actually initialized --- the flavor -information necessary for initialization is not available -earlier. -<<[[beam_polarizations.f90]]>>= -<> - -module beam_polarizations - -<> -<> -<> - use diagnostics !NODEP! - use flavors - use polarizations - -<> - -<> - -<> - -<> - -contains - -<> - -end module beam_polarizations -@ %def beam_polarizations -@ -\subsection{Parameters and type definition} -<>= - public :: BP_NONE, BP_CIRC, BP_TRANS, BP_LONG, BP_AXIS, BP_DIAG, BP_DENSITY - public :: BP_TRIVIAL - public :: beam_polarization_t -<>= - integer, parameter :: & - BP_NONE = 0, BP_CIRC = 1, BP_TRANS = 2, BP_LONG = 3, BP_AXIS = 4, & - BP_DIAG = 5, BP_DENSITY = 6, BP_TRIVIAL = 7 -<>= - type :: beam_polarization_t - private - integer :: type = BP_NONE - real(default) :: fraction - real(default) :: theta - real(default) :: phi - real(default) :: d - complex(default) :: nd - integer, dimension(:), allocatable :: hels - real(default), dimension(:), allocatable :: fractions - end type beam_polarization_t - -@ %def BP_NONE BP_CIRC BP_TRANS BP_LONG BP_AXIS BP_DIAG BP_DENSITY BP_TRIVIAL -@ %def beam_polarization_t -@ -\subsection{Constructors} -The type is filled by dedicated constructors: -<>= - public :: beam_polarization_init_none - public :: beam_polarization_init_trivial - public :: beam_polarization_init_circ - public :: beam_polarization_init_trans - public :: beam_polarization_init_long - public :: beam_polarization_init_axis - public :: beam_polarization_init_diag - public :: beam_polarization_init_density - public :: beam_polarization_final -<>= - subroutine beam_polarization_init_none (bp) - type(beam_polarization_t), intent(inout) :: bp - bp%type = BP_NONE - end subroutine beam_polarization_init_none - - subroutine beam_polarization_init_trivial (bp) - type(beam_polarization_t), intent(inout) :: bp - bp%type = BP_TRIVIAL - end subroutine beam_polarization_init_trivial - - subroutine beam_polarization_init_circ (bp, fraction) - type(beam_polarization_t), intent(inout) :: bp - real(default), intent(in) :: fraction - bp%type = BP_CIRC - bp%fraction = fraction - end subroutine beam_polarization_init_circ - - subroutine beam_polarization_init_trans (bp, fraction, phi) - type(beam_polarization_t), intent(inout) :: bp - real(default), intent(in) :: fraction, phi - bp%type = BP_TRANS - bp%fraction = fraction - bp%phi = phi - end subroutine beam_polarization_init_trans - - subroutine beam_polarization_init_long (bp, fraction) - type(beam_polarization_t), intent(inout) :: bp - real(default), intent(in) :: fraction - bp%type = BP_LONG - bp%fraction = fraction - end subroutine beam_polarization_init_long - - subroutine beam_polarization_init_axis (bp, fraction, theta, phi) - type(beam_polarization_t), intent(inout) :: bp - real(default), intent(in) :: fraction, theta, phi - bp%type = BP_AXIS - bp%fraction = fraction - bp%theta = theta - bp%phi = phi - end subroutine beam_polarization_init_axis - - subroutine beam_polarization_init_diag (bp, hels, fracs) - type(beam_polarization_t), intent(inout) :: bp - integer, dimension(:), intent(in) :: hels - real(default), dimension(:), intent(in) :: fracs - bp%type = BP_DIAG - allocate (bp%hels(size (hels))) - allocate (bp%fractions(size (fracs))) - bp%hels = hels - bp%fractions = fracs - end subroutine beam_polarization_init_diag - - subroutine beam_polarization_init_density (bp, d, nd) - type(beam_polarization_t), intent(inout) :: bp - real(default), intent(in) :: d - complex(default), intent(in) :: nd - bp%type = BP_DENSITY - bp%d = d - bp%nd = nd - end subroutine beam_polarization_init_density - - subroutine beam_polarization_final (bp) - type(beam_polarization_t), intent(inout) :: bp - if (allocated (bp%hels)) deallocate (bp%hels) - if (allocated (bp%fractions)) deallocate (bp%fractions) - end subroutine beam_polarization_final - -@ %def beam_polarization_init_none -@ %def beam_polarization_init_trivial -@ %def beam_polarization_init_circ -@ %def beam_polarization_init_trans -@ %def beam_polarization_init_long -@ %def beam_polarization_init_axis -@ %def beam_polarization_init_diag -@ %def beam_polarization_init_density -@ %def beam_polarization_final -@ -\subsection{Tools} -Together with the necessary flavor information, [[beam_polarization_t]] can -can be promoted to [[polarization_t]] -<>= - public :: beam_polarization2polarization -<>= - function beam_polarization2polarization (bp, flv, decay) result (pol) - type(beam_polarization_t), intent(in) :: bp - type(flavor_t), intent(in) :: flv - logical, optional, intent(in) :: decay - type(polarization_t) :: pol - logical :: fail - real(default), dimension(:), allocatable :: frac_vector - integer :: i, j, mult - type(string_t) :: msg - if (flavor_get_multiplicity (flv) == 1) then - select case (bp%type) - case (BP_NONE, BP_TRIVIAL) - case default - if (flavor_is_left_handed (flv)) then - msg = "left-handed" - elseif (flavor_is_right_handed (flv)) then - msg = "right-handed" - else - msg = "scalar" - end if - call msg_error (char (msg) // " particle '" & - // char (flavor_get_name (flv)) & - // "' cannot be polarized - ignoring polarization") - call emergency_unpolarized - return - end select - end if - select case (bp%type) - case (BP_NONE) - call polarization_init_unpolarized (pol, flv) - case (BP_TRIVIAL) - call polarization_init_trivial (pol, flv) - case (BP_CIRC) - if ((bp%fraction <= 1) .and. (bp%fraction >= -1)) then - call polarization_init_circular (pol, flv, bp%fraction) - else - call msg_error ( & - "circular polarization: 'fraction' must be within [-1; 1] - " & - // "ignoring polarization") - call emergency_unpolarized - end if - case (BP_TRANS) - if ((bp%fraction <= 1) .and. (bp%fraction >= -1)) then - call polarization_init_transversal (pol, flv, bp%phi, bp%fraction) - else - call msg_error ( & - "transverse polarization: 'fraction' must be within [-1; 1] - " & - // "ignoring polarization") - call emergency_unpolarized - end if - case (BP_LONG) - if ((bp%fraction > 1) .or. (bp%fraction < 0)) then - call msg_error ( & - "longitudinal polarization: 'fraction' must be within [0; 1]" & - // " - ignoring polarization"); - call emergency_unpolarized - elseif (mod (flavor_get_multiplicity (flv), 2) == 0) then - call msg_error ( & - "longitudinal polarization is only available for massive " & - // " bosons - ignoring polarization") - call emergency_unpolarized - else - call polarization_init_longitudinal (pol, flv, bp%fraction) - end if - case (BP_AXIS) - if ((bp%fraction <= 1) .and. (bp%fraction >= -1)) then - call polarization_init_angles (pol, flv, bp%fraction, bp%theta, & - bp%phi) - else - call msg_error ( & - "axial polarization: 'fraction' must be within [-1; 1] - " & - // "ignoring polarization") - call emergency_unpolarized - end if - case (BP_DENSITY) - if ((bp%d <= 1) .and. (bp%d >= 0) .and. (abs (bp%nd) <= 0.5)) then - call polarization_init_axis (pol, flv, & - (/real (bp%nd, default), (-1.) * aimag (bp%nd), 2. * bp%d - 1./)) - else - call msg_error ( & - "density matrix polarization: 'a' must be within [0; 1], |b| " & - // "within [0; 0.5] - ignoring polarization") - call emergency_unpolarized - end if - case (BP_DIAG) - fail = .false. - mult = flavor_get_multiplicity (flv) - allocate (frac_vector (mult)) - frac_vector = 0 - if (minval (bp%fractions) < 0) then - call msg_error ( & - "diagonal polarization: negative fractions are not allowed " & - // "- ignoring polarization") - fail = .true. - else - select case (mult) - case (1) - call msg_bug (& - "beam_polarizeation2polarization: invalid multiplicity") - case (2) - if ((size (bp%hels) <= 2) .and. all (abs (bp%hels) == 1)) then - frac_vector = 0 - do i = 1, size(bp%hels) - frac_vector((bp%hels(i) + 1) / 2 + 1) = bp%fractions(i) - end do - else - call msg_error ( & - "diagonal polarization: the only admissible helicities " & - // "for particle '" // char (flavor_get_name (flv)) & - // "' are" // " -1 and 1 - ignoring polarization") - fail = .true. - end if - case default - if (maxval (abs (bp%hels)) <= mult / 2) then - if (mod (mult, 2) == 0) then - if (minval (abs (bp%hels)) == 0) then - call msg_error ( & - "diagonal polarization: helicity 0 not allowed " & - // "for particle '" // char (flavor_get_name (flv)) & - // "' - ignoring polarization") - fail = .true. - else - do i = 1, size (bp%hels) - if (bp%hels(i) < 0) then - j = bp%hels(i) + mult / 2 + 1 - else - j = bp%hels(i) + mult / 2 - end if - frac_vector(j) = bp%fractions(i) - end do - end if - else - do i = 1, size (bp%hels) - j = bp%hels(i) + mult / 2 + 1 - frac_vector(j) = bp%fractions(i) - end do - end if - else - call msg_error ( & - "diagonal polarization: helicity exceeds admissible " & - // "range for particle '" // char (flavor_get_name (flv)) & - // "' - ignoring polarization") - fail = .true. - end if - end select - end if - if (fail) then - call emergency_unpolarized - else - if (sum (frac_vector) /= 1) & - call msg_warning ( & - "diagonal polarization: fractions will be normalized to 1") - call polarization_init_diagonal (pol, flv, frac_vector) - end if - deallocate (frac_vector) - end select - - contains - - subroutine emergency_unpolarized - logical :: is_decay - if (present (decay)) then - is_decay = decay - else - is_decay = .false. - end if - if (is_decay) then - call polarization_init_trivial (pol, flv) - else - call polarization_init_unpolarized (pol, flv) - end if - end subroutine emergency_unpolarized - - end function beam_polarization2polarization - -@ %def beam_polarization2polarization -@ Writing. -<>= - public :: beam_polarization_write -<>= - subroutine beam_polarization_write (bp, unit, indent) - type(beam_polarization_t), intent(in) :: bp - integer, intent(in), optional :: unit, indent - integer :: u, i - type(string_t), dimension(:), allocatable :: msgs - type(string_t) :: header, is - u = output_unit (unit) - if (u < 0) return - select case (bp%type) - case (BP_NONE, BP_TRIVIAL) - call printer ("none") - case (BP_CIRC) - call printer ("circular (fraction):") - call printer (" fraction: " // real2char (bp%fraction)) - case (BP_TRANS) - call printer ("transverse (fraction, phi):") - call printer (" fraction: " // real2char (bp%fraction)) - call printer (" phi : " // real2char (bp%phi)) - case (BP_AXIS) - call printer ("axis (fraction, theta, phi):") - call printer (" fraction: " // real2char (bp%fraction)) - call printer (" theta : " // real2char (bp%theta)) - call printer (" phi : " // real2char (bp%phi)) - case (BP_LONG) - call printer ("longitudinal (fraction):") - call printer (" fraction: " // real2char (bp%fraction)) - case (BP_DENSITY) - call printer ("density_matrix (a, b):") - call printer (" a: " // real2char (bp%d)) - call printer (" b: " // char (cmplx2string (bp%nd))) - case (BP_DIAG) - allocate (msgs(size (bp%fractions))) - header = "diagonal_density (" - do i = 1, size (msgs) - is = int2string (i) - if (i > 1) header = header // ", " - header = header // "h" // is // ":f" // is - msgs (i) = "h" // is // ": " // int2string (bp%hels(i)) & - // " , f" // is // ": " // real2string (bp%fractions(i)) - end do - call printer (char (header) // ")") - do i = 1, size (msgs) - call printer (" " // char (msgs(i))) - end do - deallocate (msgs) - case default - call msg_bug ("beam_polarization_write: illegal polarization type") - end select - flush (u) - - contains - - subroutine printer (s) - character(*), intent(in) :: s - if (present (indent)) write (u, '(A)', advance="no") & - repeat (" ", indent) - write (u, '(1x,A)') s - end subroutine printer - - end subroutine beam_polarization_write - -@ %def beam_polarization_write